module Ext_bytes : sig 
#1 "ext_bytes.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)





external unsafe_blit_string : string -> int -> bytes -> int -> int -> unit
                     = "caml_blit_string" 

[@@noalloc]
                     
    


(** Port the {!Bytes.escaped} from trunk to make it not locale sensitive *)

val escaped : bytes -> bytes

end = struct
#1 "ext_bytes.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)







external unsafe_blit_string : string -> int -> bytes -> int -> int -> unit
                     = "caml_blit_string" 

[@@noalloc]                     


external char_code: char -> int = "%identity"
external char_chr: int -> char = "%identity"

let escaped s =
  let n = Pervasives.ref 0 in
  for i = 0 to Bytes.length s - 1 do
    n := !n +
      (match Bytes.unsafe_get s i with
       | '"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2
       | ' ' .. '~' -> 1
       | _ -> 4)
  done;
  if !n = Bytes.length s then Bytes.copy s else begin
    let s' = Bytes.create !n in
    n := 0;
    for i = 0 to Bytes.length s - 1 do
      begin match Bytes.unsafe_get s i with
      | ('"' | '\\') as c ->
          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n c
      | '\n' ->
          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'n'
      | '\t' ->
          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 't'
      | '\r' ->
          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'r'
      | '\b' ->
          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'b'
      | (' ' .. '~') as c -> Bytes.unsafe_set s' !n c
      | c ->
          let a = char_code c in
          Bytes.unsafe_set s' !n '\\';
          incr n;
          Bytes.unsafe_set s' !n (char_chr (48 + a / 100));
          incr n;
          Bytes.unsafe_set s' !n (char_chr (48 + (a / 10) mod 10));
          incr n;
          Bytes.unsafe_set s' !n (char_chr (48 + a mod 10));
      end;
      incr n
    done;
    s'
  end

end
module Ext_list : sig 
#1 "ext_list.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


val map : 
  'a list -> 
  ('a -> 'b) -> 
  'b list 

val has_string :   
  string list ->
  string -> 
  bool
val map_split_opt :  
  'a list ->
  ('a -> 'b option * 'c option) ->
  'b list * 'c list 

val mapi :
  'a list -> 
  (int -> 'a -> 'b) -> 
  'b list 
  
val map_snd : ('a * 'b) list -> ('b -> 'c) -> ('a * 'c) list 

(** [map_last f xs ]
    will pass [true] to [f] for the last element, 
    [false] otherwise. 
    For empty list, it returns empty
*)
val map_last : 
    'a list -> 
    (bool -> 'a -> 'b) -> 'b list

(** [last l]
    return the last element
    raise if the list is empty
*)
val last : 'a list -> 'a

val append : 
  'a list -> 
  'a list -> 
  'a list 

val append_one :  
  'a list -> 
  'a -> 
  'a list

val map_append :  
  'b list -> 
  'a list -> 
  ('b -> 'a) -> 
  'a list

val fold_right : 
  'a list -> 
  'b -> 
  ('a -> 'b -> 'b) -> 
  'b

val fold_right2 : 
  'a list -> 
  'b list -> 
  'c -> 
  ('a -> 'b -> 'c -> 'c) ->  'c

val map2 : 
  'a list ->
  'b list ->
  ('a -> 'b -> 'c) ->
  'c list

val fold_left_with_offset : 
  'a list -> 
  'acc -> 
  int -> 
  ('a -> 'acc ->  int ->  'acc) ->   
  'acc 


(** @unused *)
val filter_map : 
  'a list -> 
  ('a -> 'b option) -> 
  'b list  

(** [exclude p l] is the opposite of [filter p l] *)
val exclude : 
  'a list -> 
  ('a -> bool) -> 
  'a list 

(** [excludes p l]
    return a tuple [excluded,newl]
    where [exluded] is true indicates that at least one  
    element is removed,[newl] is the new list where all [p x] for [x] is false

*)
val exclude_with_val : 
  'a list -> 
  ('a -> bool) -> 
  'a list option


val same_length : 'a list -> 'b list -> bool

val init : int -> (int -> 'a) -> 'a list

(** [split_at n l]
    will split [l] into two lists [a,b], [a] will be of length [n], 
    otherwise, it will raise
*)
val split_at : 
  'a list -> 
  int -> 
  'a list * 'a list


(** [split_at_last l]
    It is equivalent to [split_at (List.length l - 1) l ]
*)
val split_at_last : 'a list -> 'a list * 'a

val filter_mapi : 
  'a list -> 
  ('a -> int ->  'b option) -> 
  'b list

val filter_map2 : 
  'a list -> 
  'b list -> 
  ('a -> 'b -> 'c option) -> 
  'c list


val length_compare : 'a list -> int -> [`Gt | `Eq | `Lt ]

val length_ge : 'a list -> int -> bool

(**

   {[length xs = length ys + n ]}
   input n should be positive 
   TODO: input checking
*)

val length_larger_than_n : 
  'a list -> 
  'a list -> 
   int -> 
   bool


(**
   [rev_map_append f l1 l2]
   [map f l1] and reverse it to append [l2]
   This weird semantics is due to it is the most efficient operation
   we can do
*)
val rev_map_append : 
  'a list -> 
  'b list -> 
  ('a -> 'b) -> 
  'b list


val flat_map : 
  'a list -> 
  ('a -> 'b list) -> 
  'b list

val flat_map_append : 
  'a list -> 
  'b list  ->
  ('a -> 'b list) -> 
  'b list


(**
    [stable_group eq lst]
    Example:
    Input:
   {[
     stable_group (=) [1;2;3;4;3]
   ]}
    Output:
   {[
     [[1];[2];[4];[3;3]]
   ]}
    TODO: this is O(n^2) behavior 
    which could be improved later
*)
val stable_group : 
  'a list -> 
  ('a -> 'a -> bool) -> 
  'a list list 

(** [drop n list]
    raise when [n] is negative
    raise when list's length is less than [n]
*)
val drop : 
  'a list -> 
  int -> 
  'a list 

val find_first :   
    'a list ->
    ('a -> bool) ->
    'a option 
    
(** [find_first_not p lst ]
    if all elements in [lst] pass, return [None] 
    otherwise return the first element [e] as [Some e] which
    fails the predicate
*)
val find_first_not : 
  'a list -> 
  ('a -> bool) -> 
  'a option 

(** [find_opt f l] returns [None] if all return [None],  
    otherwise returns the first one. 
*)

val find_opt : 
  'a list -> 
  ('a -> 'b option) -> 
  'b option 


val rev_iter : 
  'a list -> 
  ('a -> unit) -> 
  unit 

val iter:   
   'a list ->  
   ('a -> unit) -> 
   unit
   
val for_all:  
    'a list -> 
    ('a -> bool) -> 
    bool
val for_all_snd:    
    ('a * 'b) list -> 
    ('b -> bool) -> 
    bool

(** [for_all2_no_exn p xs ys]
    return [true] if all satisfied,
    [false] otherwise or length not equal
*)
val for_all2_no_exn : 
  'a list -> 
  'b list -> 
  ('a -> 'b -> bool) -> 
  bool



(** [f] is applied follow the list order *)
val split_map : 
  'a list -> 
  ('a -> 'b * 'c) -> 
  'b list * 'c list       

(** [fn] is applied from left to right *)
val reduce_from_left : 
  'a list -> 
  ('a -> 'a -> 'a) ->
  'a

val sort_via_array :
  'a list -> 
  ('a -> 'a -> int) -> 
  'a list  




(** [assoc_by_string default key lst]
    if  [key] is found in the list  return that val,
    other unbox the [default], 
    otherwise [assert false ]
*)
val assoc_by_string : 
  (string * 'a) list -> 
  string -> 
  'a  option ->   
  'a  

val assoc_by_int : 
  (int * 'a) list -> 
  int -> 
  'a  option ->   
  'a   


val nth_opt : 'a list -> int -> 'a option  

val iter_snd : ('a * 'b) list -> ('b -> unit) -> unit 

val iter_fst : ('a * 'b) list -> ('a -> unit) -> unit 

val exists : 'a list -> ('a -> bool) -> bool 

val exists_fst : 
  ('a * 'b) list ->
  ('a -> bool) ->
  bool

val exists_snd : 
  ('a * 'b) list -> 
  ('b -> bool) -> 
  bool

val concat_append:
    'a list list -> 
    'a list -> 
    'a list

val fold_left2:
    'a list -> 
    'b list -> 
    'c -> 
    ('a -> 'b -> 'c -> 'c)
    -> 'c 

val fold_left:    
    'a list -> 
    'b -> 
    ('b -> 'a -> 'b) -> 
    'b

val singleton_exn:     
    'a list -> 'a

val mem_string :     
    string list -> 
    string -> 
    bool
end = struct
#1 "ext_list.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)




let rec map l f =
  match l with
  | [] ->
    []
  | [x1] ->
    let y1 = f x1 in
    [y1]
  | [x1; x2] ->
    let y1 = f x1 in
    let y2 = f x2 in
    [y1; y2]
  | [x1; x2; x3] ->
    let y1 = f x1 in
    let y2 = f x2 in
    let y3 = f x3 in
    [y1; y2; y3]
  | [x1; x2; x3; x4] ->
    let y1 = f x1 in
    let y2 = f x2 in
    let y3 = f x3 in
    let y4 = f x4 in
    [y1; y2; y3; y4]
  | x1::x2::x3::x4::x5::tail ->
    let y1 = f x1 in
    let y2 = f x2 in
    let y3 = f x3 in
    let y4 = f x4 in
    let y5 = f x5 in
    y1::y2::y3::y4::y5::(map tail f)

let rec has_string l f =
  match l with
  | [] ->
    false
  | [x1] ->
    x1 = f
  | [x1; x2] ->
    x1 = f || x2 = f
  | [x1; x2; x3] ->
    x1 = f || x2 = f || x3 = f
  | x1 :: x2 :: x3 :: x4 ->
    x1 = f || x2 = f || x3 = f || has_string x4 f 
  

let rec map_split_opt 
  (xs : 'a list)  (f : 'a -> 'b option * 'c option) 
  : 'b list * 'c list = 
  match xs with 
  | [] -> [], []
  | x::xs ->
    let c,d = f x in 
    let cs,ds = map_split_opt xs f in 
    (match c with Some c -> c::cs | None -> cs),
    (match d with Some d -> d::ds | None -> ds)

let rec map_snd l f =
  match l with
  | [] ->
    []
  | [ v1,x1 ] ->
    let y1 = f x1 in
    [v1,y1]
  | [v1, x1; v2, x2] ->
    let y1 = f x1 in
    let y2 = f x2 in
    [v1, y1; v2, y2]
  | [ v1, x1; v2, x2; v3, x3] ->
    let y1 = f x1 in
    let y2 = f x2 in
    let y3 = f x3 in
    [v1, y1; v2, y2; v3, y3]
  | [ v1, x1; v2, x2; v3, x3; v4, x4] ->
    let y1 = f x1 in
    let y2 = f x2 in
    let y3 = f x3 in
    let y4 = f x4 in
    [v1, y1; v2, y2; v3, y3; v4, y4]
  | (v1, x1) ::(v2, x2) :: (v3, x3)::(v4, x4) :: (v5, x5) ::tail ->
    let y1 = f x1 in
    let y2 = f x2 in
    let y3 = f x3 in
    let y4 = f x4 in
    let y5 = f x5 in
    (v1, y1)::(v2, y2) :: (v3, y3) :: (v4, y4) :: (v5, y5) :: (map_snd tail f)


let rec map_last l f=
  match l with
  | [] ->
    []
  | [x1] ->
    let y1 = f true x1 in
    [y1]
  | [x1; x2] ->
    let y1 = f false x1 in
    let y2 = f true x2 in
    [y1; y2]
  | [x1; x2; x3] ->
    let y1 = f false x1 in
    let y2 = f false x2 in
    let y3 = f true x3 in
    [y1; y2; y3]
  | [x1; x2; x3; x4] ->
    let y1 = f false x1 in
    let y2 = f false x2 in
    let y3 = f false x3 in
    let y4 = f true x4 in
    [y1; y2; y3; y4]
  | x1::x2::x3::x4::tail ->
    (* make sure that tail is not empty *)    
    let y1 = f false x1 in
    let y2 = f false x2 in
    let y3 = f false x3 in
    let y4 = f false x4 in
    y1::y2::y3::y4::(map_last tail f)

let rec mapi_aux lst i f = 
  match lst with
    [] -> []
  | a::l -> 
    let r = f i a in r :: mapi_aux l (i + 1) f 

let mapi lst f = mapi_aux lst 0 f

let rec last xs =
  match xs with 
  | [x] -> x 
  | _ :: tl -> last tl 
  | [] -> invalid_arg "Ext_list.last"    



let rec append_aux l1 l2 = 
  match l1 with
  | [] -> l2
  | [a0] -> a0::l2
  | [a0;a1] -> a0::a1::l2
  | [a0;a1;a2] -> a0::a1::a2::l2
  | [a0;a1;a2;a3] -> a0::a1::a2::a3::l2
  | [a0;a1;a2;a3;a4] -> a0::a1::a2::a3::a4::l2
  | a0::a1::a2::a3::a4::rest -> a0::a1::a2::a3::a4::append_aux rest l2

let append l1 l2 =   
  match l2 with 
  | [] -> l1 
  | _ -> append_aux l1 l2  

let append_one l1 x = append_aux l1 [x]  

let rec map_append l1 l2 f =   
  match l1 with
  | [] -> l2
  | [a0] -> f a0::l2
  | [a0;a1] -> 
    let b0 = f a0 in 
    let b1 = f a1 in 
    b0::b1::l2
  | [a0;a1;a2] -> 
    let b0 = f a0 in 
    let b1 = f a1 in  
    let b2 = f a2 in 
    b0::b1::b2::l2
  | [a0;a1;a2;a3] -> 
    let b0 = f a0 in 
    let b1 = f a1 in 
    let b2 = f a2 in 
    let b3 = f a3 in 
    b0::b1::b2::b3::l2
  | [a0;a1;a2;a3;a4] -> 
    let b0 = f a0 in 
    let b1 = f a1 in 
    let b2 = f a2 in 
    let b3 = f a3 in 
    let b4 = f a4 in 
    b0::b1::b2::b3::b4::l2

  | a0::a1::a2::a3::a4::rest ->
    let b0 = f a0 in 
    let b1 = f a1 in 
    let b2 = f a2 in 
    let b3 = f a3 in 
    let b4 = f a4 in 
    b0::b1::b2::b3::b4::map_append rest l2 f



let rec fold_right l acc f  = 
  match l with  
  | [] -> acc 
  | [a0] -> f a0 acc 
  | [a0;a1] -> f a0 (f a1 acc)
  | [a0;a1;a2] -> f a0 (f a1 (f a2 acc))
  | [a0;a1;a2;a3] -> f a0 (f a1 (f a2 (f a3 acc))) 
  | [a0;a1;a2;a3;a4] -> 
    f a0 (f a1 (f a2 (f a3 (f a4 acc))))
  | a0::a1::a2::a3::a4::rest -> 
    f a0 (f a1 (f a2 (f a3 (f a4 (fold_right rest acc f )))))  

let rec fold_right2 l r acc f = 
  match l,r  with  
  | [],[] -> acc 
  | [a0],[b0] -> f a0 b0 acc 
  | [a0;a1],[b0;b1] -> f a0 b0 (f a1 b1 acc)
  | [a0;a1;a2],[b0;b1;b2] -> f a0 b0 (f a1 b1 (f a2 b2 acc))
  | [a0;a1;a2;a3],[b0;b1;b2;b3] ->
    f a0 b0 (f a1 b1 (f a2 b2 (f a3 b3 acc))) 
  | [a0;a1;a2;a3;a4], [b0;b1;b2;b3;b4] -> 
    f a0 b0 (f a1 b1 (f a2 b2 (f a3 b3 (f a4 b4 acc))))
  | a0::a1::a2::a3::a4::arest, b0::b1::b2::b3::b4::brest -> 
    f a0 b0 (f a1 b1 (f a2 b2 (f a3 b3 (f a4 b4 (fold_right2 arest brest acc f )))))  
  | _, _ -> invalid_arg "Ext_list.fold_right2"

let rec map2  l r f = 
  match l,r  with  
  | [],[] -> []
  | [a0],[b0] -> [f a0 b0]
  | [a0;a1],[b0;b1] -> 
    let c0 = f a0 b0 in 
    let c1 = f a1 b1 in 
    [c0; c1]
  | [a0;a1;a2],[b0;b1;b2] -> 
    let c0 = f a0 b0 in 
    let c1 = f a1 b1 in 
    let c2 = f a2 b2 in 
    [c0;c1;c2]
  | [a0;a1;a2;a3],[b0;b1;b2;b3] ->
    let c0 = f a0 b0 in 
    let c1 = f a1 b1 in 
    let c2 = f a2 b2 in 
    let c3 = f a3 b3 in 
    [c0;c1;c2;c3]
  | [a0;a1;a2;a3;a4], [b0;b1;b2;b3;b4] -> 
    let c0 = f a0 b0 in 
    let c1 = f a1 b1 in 
    let c2 = f a2 b2 in 
    let c3 = f a3 b3 in 
    let c4 = f a4 b4 in 
    [c0;c1;c2;c3;c4]
  | a0::a1::a2::a3::a4::arest, b0::b1::b2::b3::b4::brest -> 
    let c0 = f a0 b0 in 
    let c1 = f a1 b1 in 
    let c2 = f a2 b2 in 
    let c3 = f a3 b3 in 
    let c4 = f a4 b4 in 
    c0::c1::c2::c3::c4::map2 arest brest f
  | _, _ -> invalid_arg "Ext_list.map2"

let rec fold_left_with_offset l accu i f =
  match l with
  | [] -> accu
  | a::l -> 
    fold_left_with_offset 
    l     
    (f  a accu  i)  
    (i + 1)
    f  


let rec filter_map xs (f: 'a -> 'b option)= 
  match xs with 
  | [] -> []
  | y :: ys -> 
    begin match f y with 
      | None -> filter_map ys f 
      | Some z -> z :: filter_map ys f 
    end

let rec exclude (xs : 'a list) (p : 'a -> bool) : 'a list =   
  match xs with 
  | [] ->  []
  | x::xs -> 
    if p x then exclude xs p
    else x:: exclude xs p

let rec exclude_with_val l p =
  match l with 
  | [] ->  None
  | a0::xs -> 
    if p a0 then Some (exclude xs p)
    else 
      match xs with 
      | [] -> None
      | a1::rest -> 
        if p a1 then 
          Some (a0:: exclude rest p)
        else 
          match exclude_with_val rest p with 
          | None -> None 
          | Some  rest -> Some (a0::a1::rest)



let rec same_length xs ys = 
  match xs, ys with 
  | [], [] -> true
  | _::xs, _::ys -> same_length xs ys 
  | _, _ -> false 


let init n f = 
  match n with 
  | 0 -> []
  | 1 -> 
    let a0 = f 0 in  
    [a0]
  | 2 -> 
    let a0 = f 0 in 
    let a1 = f 1 in 
    [a0; a1]
  | 3 -> 
    let a0 = f 0 in 
    let a1 = f 1 in 
    let a2 = f 2 in 
    [a0; a1; a2]
  | 4 -> 
    let a0 = f 0 in 
    let a1 = f 1 in 
    let a2 = f 2 in 
    let a3 = f 3 in 
    [a0; a1; a2; a3]
  | 5 -> 
    let a0 = f 0 in 
    let a1 = f 1 in 
    let a2 = f 2 in 
    let a3 = f 3 in 
    let a4 = f 4 in  
    [a0; a1; a2; a3; a4]
  | _ ->
    Array.to_list (Array.init n f)

let rec rev_append l1 l2 =
  match l1 with
    [] -> l2
  | a :: l -> rev_append l   (a :: l2)

let rev l = rev_append l []      

let rec small_split_at n acc l = 
  if n <= 0 then rev acc , l 
  else 
    match l with 
    | x::xs -> small_split_at (n - 1) (x ::acc) xs 
    | _ -> invalid_arg "Ext_list.split_at"

let split_at l n = 
  small_split_at n [] l 

let rec split_at_last_aux acc x = 
  match x with 
  | [] -> invalid_arg "Ext_list.split_at_last"
  | [ x] -> rev acc, x
  | y0::ys -> split_at_last_aux (y0::acc) ys   

let split_at_last (x : 'a list) = 
  match x with 
  | [] -> invalid_arg "Ext_list.split_at_last"
  | [a0] -> 
    [], a0
  | [a0;a1] -> 
    [a0], a1  
  | [a0;a1;a2] -> 
    [a0;a1], a2 
  | [a0;a1;a2;a3] -> 
    [a0;a1;a2], a3 
  | [a0;a1;a2;a3;a4] ->
    [a0;a1;a2;a3], a4 
  | a0::a1::a2::a3::a4::rest  ->  
    let rev, last = split_at_last_aux [] rest
    in 
    a0::a1::a2::a3::a4::  rev , last

(**
   can not do loop unroll due to state combination
*)  
let  filter_mapi xs f  = 
  let rec aux i xs = 
    match xs with 
    | [] -> []
    | y :: ys -> 
      begin match f y i with 
        | None -> aux (i + 1) ys
        | Some z -> z :: aux (i + 1) ys
      end in
  aux 0 xs 

let rec filter_map2  xs ys (f: 'a -> 'b -> 'c option) = 
  match xs,ys with 
  | [],[] -> []
  | u::us, v :: vs -> 
    begin match f u v with 
      | None -> filter_map2 us vs f (* idea: rec f us vs instead? *)
      | Some z -> z :: filter_map2  us vs f
    end
  | _ -> invalid_arg "Ext_list.filter_map2"


let rec rev_map_append l1 l2 f =
  match l1 with
  | [] -> l2
  | a :: l -> rev_map_append l (f a :: l2) f



(** It is not worth loop unrolling, 
    it is already tail-call, and we need to be careful 
    about evaluation order when unroll
*)
let rec flat_map_aux f acc append lx =
  match lx with
  | [] -> rev_append acc  append
  | a0::rest -> flat_map_aux f (rev_append (f a0)  acc ) append rest 

let flat_map lx f  =
  flat_map_aux f [] [] lx

let flat_map_append lx append f =
  flat_map_aux f [] append lx  


let rec length_compare l n = 
  if n < 0 then `Gt 
  else 
    begin match l with 
      | _ ::xs -> length_compare xs (n - 1)
      | [] ->  
        if n = 0 then `Eq 
        else `Lt 
    end

let rec length_ge l n =   
  if n > 0 then
    match l with 
    | _ :: tl -> length_ge tl (n - 1)
    | [] -> false
  else true
(**

   {[length xs = length ys + n ]}
*)
let rec length_larger_than_n xs ys n =
  match xs, ys with 
  | _, [] -> length_compare xs n = `Eq   
  | _::xs, _::ys -> 
    length_larger_than_n xs ys n
  | [], _ -> false 




let rec group (eq : 'a -> 'a -> bool) lst =
  match lst with 
  | [] -> []
  | x::xs -> 
    aux eq x (group eq xs )

and aux eq (x : 'a)  (xss : 'a list list) : 'a list list = 
  match xss with 
  | [] -> [[x]]
  | (y0::_ as y)::ys -> (* cannot be empty *) 
    if eq x y0 then
      (x::y) :: ys 
    else
      y :: aux eq x ys                                 
  | _ :: _ -> assert false    

let stable_group lst eq =  group eq lst |> rev  

let rec drop h n = 
  if n < 0 then invalid_arg "Ext_list.drop"
  else
  if n = 0 then h 
  else 
    match h with 
    | [] ->
      invalid_arg "Ext_list.drop"
    | _ :: tl ->   
      drop tl (n - 1)

let rec find_first x p = 
  match x with 
  | [] -> None
  | x :: l -> 
    if p x then Some x 
    else find_first l p

let rec find_first_not  xs p = 
  match xs with 
  | [] -> None
  | a::l -> 
    if p a 
    then find_first_not l p 
    else Some a 


let rec rev_iter l f = 
  match l with
  | [] -> ()    
  | [x1] ->
    f x1 
  | [x1; x2] ->
    f x2 ; f x1 
  | [x1; x2; x3] ->
    f x3 ; f x2 ; f x1 
  | [x1; x2; x3; x4] ->
    f x4; f x3; f x2; f x1 
  | x1::x2::x3::x4::x5::tail ->
    rev_iter tail f;
    f x5; f x4 ; f x3; f x2 ; f x1

let rec iter l f = 
  match l with
  | [] -> ()    
  | [x1] ->
    f x1 
  | [x1; x2] ->
    f x1 ; f x2
  | [x1; x2; x3] ->
    f x1 ; f x2 ; f x3
  | [x1; x2; x3; x4] ->
    f x1; f x2; f x3; f x4
  | x1::x2::x3::x4::x5::tail ->
    f x1; f x2 ; f x3; f x4 ; f x5;
    iter tail f 


let rec for_all lst p = 
  match lst with 
    [] -> true
  | a::l -> p a && for_all l p

let rec for_all_snd lst p = 
  match lst with 
    [] -> true
  | (_,a)::l -> p a && for_all_snd l p


let rec for_all2_no_exn  l1 l2 p = 
  match (l1, l2) with
  | ([], []) -> true
  | (a1::l1, a2::l2) -> p a1 a2 && for_all2_no_exn l1 l2 p
  | (_, _) -> false


let rec find_opt xs p = 
  match xs with 
  | [] -> None
  | x :: l -> 
    match  p x with 
    | Some _ as v  ->  v
    | None -> find_opt l p



let rec split_map l f = 
  match l with
  | [] ->
    [],[]
  | [x1] ->
    let a0,b0 = f x1 in
    [a0],[b0]
  | [x1; x2] ->
    let a1,b1 = f x1 in
    let a2,b2 = f x2 in
    [a1;a2],[b1;b2]
  | [x1; x2; x3] ->
    let a1,b1 = f x1 in
    let a2,b2 = f x2 in
    let a3,b3 = f x3 in
    [a1;a2;a3], [b1;b2;b3]
  | [x1; x2; x3; x4] ->
    let a1,b1 = f x1 in
    let a2,b2 = f x2 in
    let a3,b3 = f x3 in
    let a4,b4 = f x4 in
    [a1;a2;a3;a4], [b1;b2;b3;b4] 
  | x1::x2::x3::x4::x5::tail ->
    let a1,b1 = f x1 in
    let a2,b2 = f x2 in
    let a3,b3 = f x3 in
    let a4,b4 = f x4 in
    let a5,b5 = f x5 in
    let ass,bss = split_map tail f in 
    a1::a2::a3::a4::a5::ass,
    b1::b2::b3::b4::b5::bss




let sort_via_array lst cmp =
  let arr = Array.of_list lst  in
  Array.sort cmp arr;
  Array.to_list arr




let rec assoc_by_string lst (k : string) def  = 
  match lst with 
  | [] -> 
    begin match def with 
      | None -> assert false 
      | Some x -> x end
  | (k1,v1)::rest -> 
    if  k1 = k then v1 else 
      assoc_by_string  rest k def 

let rec assoc_by_int lst (k : int) def = 
  match lst with 
  | [] -> 
    begin match def with
      | None -> assert false 
      | Some x -> x end
  | (k1,v1)::rest -> 
    if k1 = k then v1 else 
      assoc_by_int rest k def 


let rec nth_aux l n =
  match l with
  | [] -> None
  | a::l -> if n = 0 then Some a else nth_aux l (n-1)

let nth_opt l n =
  if n < 0 then None 
  else
    nth_aux l n

let rec iter_snd lst f =     
  match lst with
  | [] -> ()
  | (_,x)::xs -> 
    f x ; 
    iter_snd xs f 
    
let rec iter_fst lst f =     
  match lst with
  | [] -> ()
  | (x,_)::xs -> 
    f x ; 
    iter_fst xs f 

let rec exists l p =     
  match l with 
    [] -> false  
  | x :: xs -> p x || exists xs p

let rec exists_fst l p = 
  match l with 
    [] -> false
  | (a,_)::l -> p a || exists_fst l p 

let rec exists_snd l p = 
  match l with 
    [] -> false
  | (_, a)::l -> p a || exists_snd l p 

let rec concat_append 
  (xss : 'a list list)  
  (xs : 'a list) : 'a list = 
  match xss with 
  | [] -> xs 
  | l::r -> append l (concat_append r xs)

let rec fold_left l accu f =
  match l with
    [] -> accu
  | a::l -> fold_left l (f accu a) f 
  
let reduce_from_left lst fn = 
  match lst with 
  | first :: rest ->  fold_left rest first fn 
  | _ -> invalid_arg "Ext_list.reduce_from_left"

let rec fold_left2 l1 l2 accu f =
  match (l1, l2) with
    ([], []) -> accu
  | (a1::l1, a2::l2) -> fold_left2  l1 l2 (f a1 a2 accu) f 
  | (_, _) -> invalid_arg "Ext_list.fold_left2"

let singleton_exn xs = match xs with [x] -> x | _ -> assert false

let rec mem_string (xs : string list) (x : string) = 
  match xs with 
    [] -> false
  | a::l ->  a = x  || mem_string l x

end
module Ext_string : sig 
#1 "ext_string.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Extension to the standard library [String] module, fixed some bugs like
    avoiding locale sensitivity *) 

(** default is false *)    
val split_by : ?keep_empty:bool -> (char -> bool) -> string -> string list


(** remove whitespace letters ('\t', '\n', ' ') on both side*)
val trim : string -> string 


(** default is false *)
val split : ?keep_empty:bool -> string -> char -> string list

(** split by space chars for quick scripting *)
val quick_split_by_ws : string -> string list 



val starts_with : string -> string -> bool

(**
   return [-1] when not found, the returned index is useful 
   see [ends_with_then_chop]
*)
val ends_with_index : string -> string -> int

val ends_with : string -> string -> bool

(**
  [ends_with_then_chop name ext]
  @example:
   {[
     ends_with_then_chop "a.cmj" ".cmj"
     "a"
   ]}
   This is useful in controlled or file case sensitve system
*)
val ends_with_then_chop : string -> string -> string option


val escaped : string -> string

(**
  [for_all_from  s start p]
  if [start] is negative, it raises,
  if [start] is too large, it returns true
*)
val for_all_from:
  string -> 
  int -> 
  (char -> bool) -> 
  bool 

val for_all : 
  string -> 
  (char -> bool) -> 
  bool

val is_empty : string -> bool

val repeat : int -> string -> string 

val equal : string -> string -> bool

(**
  [extract_until s cursor sep]
   When [sep] not found, the cursor is updated to -1,
   otherwise cursor is increased to 1 + [sep_position]
   User can not determine whether it is found or not by
   telling the return string is empty since 
   "\n\n" would result in an empty string too.
*)
(* val extract_until:
  string -> 
  int ref -> (* cursor to be updated *)
  char -> 
  string *)

val index_count:  
  string -> 
  int ->
  char -> 
  int -> 
  int 

(* val index_next :
  string -> 
  int ->
  char -> 
  int  *)

  
(**
  [find ~start ~sub s]
  returns [-1] if not found
*)
val find : ?start:int -> sub:string -> string -> int

val contain_substring : string -> string -> bool 

val non_overlap_count : sub:string -> string -> int 

val rfind : sub:string -> string -> int

(** [tail_from s 1]
  return a substring from offset 1 (inclusive)
*)
val tail_from : string -> int -> string


(** returns negative number if not found *)
val rindex_neg : string -> char -> int 

val rindex_opt : string -> char -> int option


val no_char : string -> char -> int -> int -> bool 


val no_slash : string -> bool 

(** return negative means no slash, otherwise [i] means the place for first slash *)
val no_slash_idx : string -> int 

val no_slash_idx_from : string -> int -> int 

(** if no conversion happens, reference equality holds *)
val replace_slash_backward : string -> string 

(** if no conversion happens, reference equality holds *)
val replace_backward_slash : string -> string 

val empty : string 


external compare : string -> string -> int = "caml_string_length_based_compare" [@@noalloc];;  
  
val single_space : string

val concat3 : string -> string -> string -> string 
val concat4 : string -> string -> string -> string -> string 
val concat5 : string -> string -> string -> string -> string -> string  
val inter2 : string -> string -> string
val inter3 : string -> string -> string -> string 
val inter4 : string -> string -> string -> string -> string
val concat_array : string -> string array -> string 

val single_colon : string 

val parent_dir_lit : string
val current_dir_lit : string

val capitalize_ascii : string -> string

val capitalize_sub:
  string -> 
  int -> 
  string
  
val uncapitalize_ascii : string -> string

val lowercase_ascii : string -> string 

(** Play parity to {!Ext_buffer.add_int_1} *)
val get_int_1 : string -> int -> int 
val get_int_2 : string -> int -> int 
val get_int_3 : string -> int -> int 
val get_int_4 : string -> int -> int 

val get_1_2_3_4 : 
  string -> 
  off:int ->  
  int -> 
  int 

val unsafe_sub :   
  string -> 
  int -> 
  int -> 
  string
end = struct
#1 "ext_string.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)







(*
   {[ split " test_unsafe_obj_ffi_ppx.cmi" ~keep_empty:false ' ']}
*)
let split_by ?(keep_empty=false) is_delim str =
  let len = String.length str in
  let rec loop acc last_pos pos =
    if pos = -1 then
      if last_pos = 0 && not keep_empty then

        acc
      else 
        String.sub str 0 last_pos :: acc
    else
    if is_delim str.[pos] then
      let new_len = (last_pos - pos - 1) in
      if new_len <> 0 || keep_empty then 
        let v = String.sub str (pos + 1) new_len in
        loop ( v :: acc)
          pos (pos - 1)
      else loop acc pos (pos - 1)
    else loop acc last_pos (pos - 1)
  in
  loop [] len (len - 1)

let trim s = 
  let i = ref 0  in
  let j = String.length s in 
  while !i < j &&  
        let u = String.unsafe_get s !i in 
        u = '\t' || u = '\n' || u = ' ' 
  do 
    incr i;
  done;
  let k = ref (j - 1)  in 
  while !k >= !i && 
        let u = String.unsafe_get s !k in 
        u = '\t' || u = '\n' || u = ' ' do 
    decr k ;
  done;
  String.sub s !i (!k - !i + 1)

let split ?keep_empty  str on = 
  if str = "" then [] else 
    split_by ?keep_empty (fun x -> (x : char) = on) str  ;;

let quick_split_by_ws str : string list = 
  split_by ~keep_empty:false (fun x -> x = '\t' || x = '\n' || x = ' ') str

let starts_with s beg = 
  let beg_len = String.length beg in
  let s_len = String.length s in
  beg_len <=  s_len &&
  (let i = ref 0 in
   while !i <  beg_len 
         && String.unsafe_get s !i =
            String.unsafe_get beg !i do 
     incr i 
   done;
   !i = beg_len
  )

let rec ends_aux s end_ j k = 
  if k < 0 then (j + 1)
  else if String.unsafe_get s j = String.unsafe_get end_ k then 
    ends_aux s end_ (j - 1) (k - 1)
  else  -1   

(** return an index which is minus when [s] does not 
    end with [beg]
*)
let ends_with_index s end_ : int = 
  let s_finish = String.length s - 1 in
  let s_beg = String.length end_ - 1 in
  if s_beg > s_finish then -1
  else
    ends_aux s end_ s_finish s_beg

let ends_with s end_ = ends_with_index s end_ >= 0 

let ends_with_then_chop s beg = 
  let i =  ends_with_index s beg in 
  if i >= 0 then Some (String.sub s 0 i) 
  else None

let check_suffix_case = ends_with 
let check_suffix_case_then_chop = ends_with_then_chop

let check_any_suffix_case s suffixes = 
  Ext_list.exists suffixes (fun x -> check_suffix_case s x) 

let check_any_suffix_case_then_chop s suffixes = 
  let rec aux suffixes = 
    match suffixes with 
    | [] -> None 
    | x::xs -> 
      let id = ends_with_index s x in 
      if id >= 0 then Some (String.sub s 0 id)
      else aux xs in 
  aux suffixes    



(**  In OCaml 4.02.3, {!String.escaped} is locale senstive, 
     this version try to make it not locale senstive, this bug is fixed
     in the compiler trunk     
*)
let escaped s =
  let rec needs_escape i =
    if i >= String.length s then false else
      match String.unsafe_get s i with
      | '"' | '\\' | '\n' | '\t' | '\r' | '\b' -> true
      | ' ' .. '~' -> needs_escape (i+1)
      | _ -> true
  in
  if needs_escape 0 then
    Bytes.unsafe_to_string (Ext_bytes.escaped (Bytes.unsafe_of_string s))
  else
    s

(* it is unsafe to expose such API as unsafe since 
   user can provide bad input range 

*)
let rec unsafe_for_all_range s ~start ~finish p =     
  start > finish ||
  p (String.unsafe_get s start) && 
  unsafe_for_all_range s ~start:(start + 1) ~finish p

let for_all_from s start  p = 
  let len = String.length s in 
  if start < 0  then invalid_arg "Ext_string.for_all_from"
  else unsafe_for_all_range s ~start ~finish:(len - 1) p 


let for_all s (p : char -> bool)  =   
  unsafe_for_all_range s ~start:0  ~finish:(String.length s - 1) p 

let is_empty s = String.length s = 0


let repeat n s  =
  let len = String.length s in
  let res = Bytes.create(n * len) in
  for i = 0 to pred n do
    String.blit s 0 res (i * len) len
  done;
  Bytes.to_string res

let equal (x : string) y  = x = y



let unsafe_is_sub ~sub i s j ~len =
  let rec check k =
    if k = len
    then true
    else 
      String.unsafe_get sub (i+k) = 
      String.unsafe_get s (j+k) && check (k+1)
  in
  j+len <= String.length s && check 0


exception Local_exit 
let find ?(start=0) ~sub s =
  let n = String.length sub in
  let s_len = String.length s in 
  let i = ref start in  
  try
    while !i + n <= s_len do
      if unsafe_is_sub ~sub 0 s !i ~len:n then
        raise_notrace Local_exit;
      incr i
    done;
    -1
  with Local_exit ->
    !i

let contain_substring s sub = 
  find s ~sub >= 0 

(** TODO: optimize 
    avoid nonterminating when string is empty 
*)
let non_overlap_count ~sub s = 
  let sub_len = String.length sub in 
  let rec aux  acc off = 
    let i = find ~start:off ~sub s  in 
    if i < 0 then acc 
    else aux (acc + 1) (i + sub_len) in
  if String.length sub = 0 then invalid_arg "Ext_string.non_overlap_count"
  else aux 0 0  


let rfind ~sub s =
  let n = String.length sub in
  let i = ref (String.length s - n) in
  let module M = struct exception Exit end in 
  try
    while !i >= 0 do
      if unsafe_is_sub ~sub 0 s !i ~len:n then 
        raise_notrace Local_exit;
      decr i
    done;
    -1
  with Local_exit ->
    !i

let tail_from s x = 
  let len = String.length s  in 
  if  x > len then invalid_arg ("Ext_string.tail_from " ^s ^ " : "^ string_of_int x )
  else String.sub s x (len - x)

let equal (x : string) y  = x = y

(* let rec index_rec s lim i c =
  if i >= lim then -1 else
  if String.unsafe_get s i = c then i 
  else index_rec s lim (i + 1) c *)



let rec index_rec_count s lim i c count =
  if i >= lim then -1 else
  if String.unsafe_get s i = c then 
    if count = 1 then i 
    else index_rec_count s lim (i + 1) c (count - 1)
  else index_rec_count s lim (i + 1) c count

let index_count s i c count =     
  let lim = String.length s in 
  if i < 0 || i >= lim || count < 1 then 
    invalid_arg ("index_count: ( " ^string_of_int i ^ "," ^string_of_int count ^ ")" );
  index_rec_count s lim i c count 

(* let index_next s i c =   
  index_count s i c 1  *)

(* let extract_until s cursor c =       
  let len = String.length s in   
  let start = !cursor in 
  if start < 0 || start >= len then (
    cursor := -1;
    ""
    )
  else 
    let i = index_rec s len start c in   
    let finish = 
      if i < 0 then (      
        cursor := -1 ;
        len 
      )
      else (
        cursor := i + 1;
        i 
      ) in 
    String.sub s start (finish - start) *)
  
let rec rindex_rec s i c =
  if i < 0 then i else
  if String.unsafe_get s i = c then i else rindex_rec s (i - 1) c;;

let rec rindex_rec_opt s i c =
  if i < 0 then None else
  if String.unsafe_get s i = c then Some i else rindex_rec_opt s (i - 1) c;;

let rindex_neg s c = 
  rindex_rec s (String.length s - 1) c;;

let rindex_opt s c = 
  rindex_rec_opt s (String.length s - 1) c;;


(** TODO: can be improved to return a positive integer instead *)
let rec unsafe_no_char x ch i  last_idx = 
  i > last_idx  || 
  (String.unsafe_get x i <> ch && unsafe_no_char x ch (i + 1)  last_idx)

let rec unsafe_no_char_idx x ch i last_idx = 
  if i > last_idx  then -1 
  else 
  if String.unsafe_get x i <> ch then 
    unsafe_no_char_idx x ch (i + 1)  last_idx
  else i

let no_char x ch i len  : bool =
  let str_len = String.length x in 
  if i < 0 || i >= str_len || len >= str_len then invalid_arg "Ext_string.no_char"   
  else unsafe_no_char x ch i len 


let no_slash x = 
  unsafe_no_char x '/' 0 (String.length x - 1)

let no_slash_idx x = 
  unsafe_no_char_idx x '/' 0 (String.length x - 1)

let no_slash_idx_from x from = 
  let last_idx = String.length x - 1  in 
  assert (from >= 0); 
  unsafe_no_char_idx x '/' from last_idx

let replace_slash_backward (x : string ) = 
  let len = String.length x in 
  if unsafe_no_char x '/' 0  (len - 1) then x 
  else 
    String.map (function 
        | '/' -> '\\'
        | x -> x ) x 

let replace_backward_slash (x : string)=
  let len = String.length x in
  if unsafe_no_char x '\\' 0  (len -1) then x 
  else  
    String.map (function 
        |'\\'-> '/'
        | x -> x) x

let empty = ""


external compare : string -> string -> int = "caml_string_length_based_compare" [@@noalloc];;    

let single_space = " "
let single_colon = ":"

let concat_array sep (s : string array) =   
  let s_len = Array.length s in 
  match s_len with 
  | 0 -> empty 
  | 1 -> Array.unsafe_get s 0
  | _ ->     
    let sep_len = String.length sep in 
    let len = ref 0 in 
    for i = 0 to  s_len - 1 do 
      len := !len + String.length (Array.unsafe_get s i)
    done;
    let target = 
      Bytes.create 
        (!len + (s_len - 1) * sep_len ) in    
    let hd = (Array.unsafe_get s 0) in     
    let hd_len = String.length hd in 
    String.unsafe_blit hd  0  target 0 hd_len;   
    let current_offset = ref hd_len in     
    for i = 1 to s_len - 1 do 
      String.unsafe_blit sep 0 target  !current_offset sep_len;
      let cur = Array.unsafe_get s i in 
      let cur_len = String.length cur in     
      let new_off_set = (!current_offset + sep_len ) in
      String.unsafe_blit cur 0 target new_off_set cur_len; 
      current_offset := 
        new_off_set + cur_len ; 
    done;
    Bytes.unsafe_to_string target   

let concat3 a b c = 
  let a_len = String.length a in 
  let b_len = String.length b in 
  let c_len = String.length c in 
  let len = a_len + b_len + c_len in 
  let target = Bytes.create len in 
  String.unsafe_blit a 0 target 0 a_len ; 
  String.unsafe_blit b 0 target a_len b_len;
  String.unsafe_blit c 0 target (a_len + b_len) c_len;
  Bytes.unsafe_to_string target

let concat4 a b c d =
  let a_len = String.length a in 
  let b_len = String.length b in 
  let c_len = String.length c in 
  let d_len = String.length d in 
  let len = a_len + b_len + c_len + d_len in 

  let target = Bytes.create len in 
  String.unsafe_blit a 0 target 0 a_len ; 
  String.unsafe_blit b 0 target a_len b_len;
  String.unsafe_blit c 0 target (a_len + b_len) c_len;
  String.unsafe_blit d 0 target (a_len + b_len + c_len) d_len;
  Bytes.unsafe_to_string target


let concat5 a b c d e =
  let a_len = String.length a in 
  let b_len = String.length b in 
  let c_len = String.length c in 
  let d_len = String.length d in 
  let e_len = String.length e in 
  let len = a_len + b_len + c_len + d_len + e_len in 

  let target = Bytes.create len in 
  String.unsafe_blit a 0 target 0 a_len ; 
  String.unsafe_blit b 0 target a_len b_len;
  String.unsafe_blit c 0 target (a_len + b_len) c_len;
  String.unsafe_blit d 0 target (a_len + b_len + c_len) d_len;
  String.unsafe_blit e 0 target (a_len + b_len + c_len + d_len) e_len;
  Bytes.unsafe_to_string target



let inter2 a b = 
  concat3 a single_space b 


let inter3 a b c = 
  concat5 a  single_space  b  single_space  c 





let inter4 a b c d =
  concat_array single_space [| a; b ; c; d|]


let parent_dir_lit = ".."    
let current_dir_lit = "."


(* reference {!Bytes.unppercase} *)
let capitalize_ascii (s : string) : string = 
  if String.length s = 0 then s 
  else 
    begin
      let c = String.unsafe_get s 0 in 
      if (c >= 'a' && c <= 'z')
      || (c >= '\224' && c <= '\246')
      || (c >= '\248' && c <= '\254') then 
        let uc = Char.unsafe_chr (Char.code c - 32) in 
        let bytes = Bytes.of_string s in
        Bytes.unsafe_set bytes 0 uc;
        Bytes.unsafe_to_string bytes 
      else s 
    end

let capitalize_sub (s : string) len : string = 
  let slen = String.length s in 
  if  len < 0 || len > slen then invalid_arg "Ext_string.capitalize_sub"
  else 
  if len = 0 then ""
  else 
    let bytes = Bytes.create len in 
    let uc = 
      let c = String.unsafe_get s 0 in 
      if (c >= 'a' && c <= 'z')
      || (c >= '\224' && c <= '\246')
      || (c >= '\248' && c <= '\254') then 
        Char.unsafe_chr (Char.code c - 32) else c in 
    Bytes.unsafe_set bytes 0 uc;
    for i = 1 to len - 1 do 
      Bytes.unsafe_set bytes i (String.unsafe_get s i)
    done ;
    Bytes.unsafe_to_string bytes 

    

let uncapitalize_ascii =

    String.uncapitalize_ascii
      


 
let lowercase_ascii = String.lowercase_ascii




let get_int_1 (x : string) off : int = 
  Char.code x.[off]

let get_int_2 (x : string) off : int = 
  Char.code x.[off] lor   
  Char.code x.[off+1] lsl 8
  
let get_int_3 (x : string) off : int = 
  Char.code x.[off] lor   
  Char.code x.[off+1] lsl 8  lor 
  Char.code x.[off+2] lsl 16

let get_int_4 (x : string) off : int =   
  Char.code x.[off] lor   
  Char.code x.[off+1] lsl 8  lor 
  Char.code x.[off+2] lsl 16 lor
  Char.code x.[off+3] lsl 24 

let get_1_2_3_4 (x : string) ~off len : int =  
  if len = 1 then get_int_1 x off 
  else if len = 2 then get_int_2 x off 
  else if len = 3 then get_int_3 x off 
  else if len = 4 then get_int_4 x off 
  else assert false

let unsafe_sub  x offs len =
  let b = Bytes.create len in 
  Ext_bytes.unsafe_blit_string x offs b 0 len;
  (Bytes.unsafe_to_string b);
end
module Ext_filename : sig 
#1 "ext_filename.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)





(* TODO:
   Change the module name, this code is not really an extension of the standard 
    library but rather specific to JS Module name convention. 
*)





(** An extension module to calculate relative path follow node/npm style. 
    TODO : this short name will have to change upon renaming the file.
*)

val is_dir_sep : 
  char -> bool 
  
val maybe_quote:
  string -> 
  string

val chop_extension_maybe:
  string -> 
  string

(* return an empty string if no extension found *)  
val get_extension_maybe:   
  string -> 
  string


val new_extension:  
  string -> 
  string -> 
  string

val chop_all_extensions_maybe:
  string -> 
  string  

(* OCaml specific abstraction*)
val module_name:  
  string ->
  string




type module_info = {
  module_name : string ;
  case : bool;
}   



val as_module:
  basename:string -> 
  module_info option
end = struct
#1 "ext_filename.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)




let is_dir_sep_unix c = c = '/'
let is_dir_sep_win_cygwin c = 
  c = '/' || c = '\\' || c = ':'

let is_dir_sep = 
  if Sys.unix then is_dir_sep_unix else is_dir_sep_win_cygwin

(* reference ninja.cc IsKnownShellSafeCharacter *)
let maybe_quote ( s : string) = 
  let noneed_quote = 
    Ext_string.for_all s (function
        | '0' .. '9' 
        | 'a' .. 'z' 
        | 'A' .. 'Z'
        | '_' | '+' 
        | '-' | '.'
        | '/' 
        | '@' -> true
        | _ -> false
      )  in 
  if noneed_quote then
    s
  else Filename.quote s 


let chop_extension_maybe name =
  let rec search_dot i =
    if i < 0 || is_dir_sep (String.unsafe_get name i) then name
    else if String.unsafe_get name i = '.' then String.sub name 0 i
    else search_dot (i - 1) in
  search_dot (String.length name - 1)

let get_extension_maybe name =   
  let name_len = String.length name in  
  let rec search_dot name i name_len =
    if i < 0 || is_dir_sep (String.unsafe_get name i) then ""
    else if String.unsafe_get name i = '.' then String.sub name i (name_len - i)
    else search_dot name (i - 1) name_len in
  search_dot name (name_len - 1) name_len

let chop_all_extensions_maybe name =
  let rec search_dot i last =
    if i < 0 || is_dir_sep (String.unsafe_get name i) then 
      (match last with 
      | None -> name
      | Some i -> String.sub name 0 i)  
    else if String.unsafe_get name i = '.' then 
      search_dot (i - 1) (Some i)
    else search_dot (i - 1) last in
  search_dot (String.length name - 1) None


let new_extension name (ext : string) = 
  let rec search_dot name i ext =
    if i < 0 || is_dir_sep (String.unsafe_get name i) then 
      name ^ ext 
    else if String.unsafe_get name i = '.' then 
      let ext_len = String.length ext in
      let buf = Bytes.create (i + ext_len) in 
      Bytes.blit_string name 0 buf 0 i;
      Bytes.blit_string ext 0 buf i ext_len;
      Bytes.unsafe_to_string buf
    else search_dot name (i - 1) ext  in
  search_dot name (String.length name - 1) ext



(** TODO: improve efficiency
   given a path, calcuate its module name 
   Note that `ocamlc.opt -c aa.xx.mli` gives `aa.xx.cmi`
   we can not strip all extensions, otherwise
   we can not tell the difference between "x.cpp.ml" 
   and "x.ml"
*)
let module_name name = 
  let rec search_dot i  name =
    if i < 0  then 
      Ext_string.capitalize_ascii name
    else 
    if String.unsafe_get name i = '.' then 
      Ext_string.capitalize_sub name i 
    else 
      search_dot (i - 1) name in  
  let name = Filename.basename  name in 
  let name_len = String.length name in 
  search_dot (name_len - 1)  name 

type module_info = {
  module_name : string ;
  case : bool;
} 



let rec valid_module_name_aux name off len =
  if off >= len then true 
  else 
    let c = String.unsafe_get name off in 
    match c with 
    | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '\'' -> 
      valid_module_name_aux name (off + 1) len 
    | _ -> false

type state = 
  | Invalid
  | Upper
  | Lower

let valid_module_name name len =     
  if len = 0 then Invalid
  else 
    let c = String.unsafe_get name 0 in 
    match c with 
    | 'A' .. 'Z'
      -> 
      if valid_module_name_aux name 1 len then 
        Upper
      else Invalid  
    | 'a' .. 'z' 
      -> 
      if valid_module_name_aux name 1 len then
        Lower
      else Invalid
    | _ -> Invalid


let as_module ~basename =
  let rec search_dot i  name name_len =
    if i < 0  then
      (* Input e.g, [a_b] *)
      match valid_module_name name name_len with 
      | Invalid -> None 
      | Upper ->  Some {module_name = name; case = true }
      | Lower -> Some {module_name = Ext_string.capitalize_ascii name; case = false}
    else 
    if String.unsafe_get name i = '.' then 
      (*Input e.g, [A_b] *)
      match valid_module_name  name i with 
      | Invalid -> None 
      | Upper -> 
        Some {module_name = Ext_string.capitalize_sub name i; case = true}
      | Lower -> 
        Some {module_name = Ext_string.capitalize_sub name i; case = false}
    else 
      search_dot (i - 1) name name_len in  
  let name_len = String.length basename in       
  search_dot (name_len - 1)  basename name_len
    
end
module Arg_helper : sig 
#1 "arg_helper.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                       Pierre Chambart, OCamlPro                        *)
(*           Mark Shinwell and Leo White, Jane Street Europe              *)
(*                                                                        *)
(*   Copyright 2015--2016 OCamlPro SAS                                    *)
(*   Copyright 2015--2016 Jane Street Group LLC                           *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Decipher command line arguments of the form
        <value> | <key>=<value>[,...]
    (as used for example for the specification of inlining parameters
    varying by simplification round).
*)

module Make (S : sig
  module Key : sig
    type t

    (** The textual representation of a key must not contain '=' or ','. *)
    val of_string : string -> t

    module Map : Map.S with type key = t
  end

  module Value : sig
    type t

    (** The textual representation of a value must not contain ','. *)
    val of_string : string -> t
  end
end) : sig
  type parsed

  val default : S.Value.t -> parsed

  val set_base_default : S.Value.t -> parsed -> parsed

  val add_base_override : S.Key.t -> S.Value.t -> parsed -> parsed

  val reset_base_overrides : parsed -> parsed

  val set_user_default : S.Value.t -> parsed -> parsed

  val add_user_override : S.Key.t -> S.Value.t -> parsed -> parsed

  val parse : string -> string -> parsed ref -> unit

  type parse_result =
    | Ok
    | Parse_failed of exn

  val parse_no_error : string -> parsed ref -> parse_result

  val get : key:S.Key.t -> parsed -> S.Value.t
end

end = struct
#1 "arg_helper.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                       Pierre Chambart, OCamlPro                        *)
(*           Mark Shinwell and Leo White, Jane Street Europe              *)
(*                                                                        *)
(*   Copyright 2015--2016 OCamlPro SAS                                    *)
(*   Copyright 2015--2016 Jane Street Group LLC                           *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

let fatal err =
  prerr_endline err;
  exit 2

module Make (S : sig
  module Key : sig
    type t
    val of_string : string -> t
    module Map : Map.S with type key = t
  end

  module Value : sig
    type t
    val of_string : string -> t
  end
end) = struct
  type parsed = {
    base_default : S.Value.t;
    base_override : S.Value.t S.Key.Map.t;
    user_default : S.Value.t option;
    user_override : S.Value.t S.Key.Map.t;
  }

  let default v =
    { base_default = v;
      base_override = S.Key.Map.empty;
      user_default = None;
      user_override = S.Key.Map.empty; }

  let set_base_default value t =
    { t with base_default = value }

  let add_base_override key value t =
    { t with base_override = S.Key.Map.add key value t.base_override }

  let reset_base_overrides t =
    { t with base_override = S.Key.Map.empty }

  let set_user_default value t =
    { t with user_default = Some value }

  let add_user_override key value t =
    { t with user_override = S.Key.Map.add key value t.user_override }

  exception Parse_failure of exn

  let parse_exn str ~update =
    (* Is the removal of empty chunks really relevant here? *)
    (* (It has been added to mimic the old Misc.String.split.) *)
    let values = String.split_on_char ',' str |> List.filter ((<>) "") in
    let parsed =
      List.fold_left (fun acc value ->
          match String.index value '=' with
          | exception Not_found ->
            begin match S.Value.of_string value with
            | value -> set_user_default value acc
            | exception exn -> raise (Parse_failure exn)
            end
          | equals ->
            let key_value_pair = value in
            let length = String.length key_value_pair in
            assert (equals >= 0 && equals < length);
            if equals = 0 then begin
              raise (Parse_failure (
                Failure "Missing key in argument specification"))
            end;
            let key =
              let key = String.sub key_value_pair 0 equals in
              try S.Key.of_string key
              with exn -> raise (Parse_failure exn)
            in
            let value =
              let value =
                String.sub key_value_pair (equals + 1) (length - equals - 1)
              in
              try S.Value.of_string value
              with exn -> raise (Parse_failure exn)
            in
            add_user_override key value acc)
        !update
        values
    in
    update := parsed

  let parse str help_text update =
    match parse_exn str ~update with
    | () -> ()
    | exception (Parse_failure exn) ->
      fatal (Printf.sprintf "%s: %s" (Printexc.to_string exn) help_text)

  type parse_result =
    | Ok
    | Parse_failed of exn

  let parse_no_error str update =
    match parse_exn str ~update with
    | () -> Ok
    | exception (Parse_failure exn) -> Parse_failed exn

  let get ~key parsed =
    match S.Key.Map.find key parsed.user_override with
    | value -> value
    | exception Not_found ->
      match parsed.user_default with
      | Some value -> value
      | None ->
        match S.Key.Map.find key parsed.base_override with
        | value -> value
        | exception Not_found -> parsed.base_default

end

end
module Config_whole_compiler : sig 
#1 "config_whole_compiler.mli"

(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* System configuration *)

val version: string
        (* The current version number of the system *)

val standard_library: string
        (* The directory containing the standard libraries *)
val standard_runtime: string
        (* The full path to the standard bytecode interpreter ocamlrun *)
val ccomp_type: string
        (* The "kind" of the C compiler, assembler and linker used: one of
               "cc" (for Unix-style C compilers)
               "msvc" (for Microsoft Visual C++ and MASM) *)
val c_compiler: string
        (* The compiler to use for compiling C files *)
val c_output_obj: string
        (* Name of the option of the C compiler for specifying the output file *)
val ocamlc_cflags : string
        (* The flags ocamlc should pass to the C compiler *)
val ocamlc_cppflags : string
        (* The flags ocamlc should pass to the C preprocessor *)
val ocamlopt_cflags : string
        (* The flags ocamlopt should pass to the C compiler *)
val ocamlopt_cppflags : string
        (* The flags ocamlopt should pass to the C preprocessor *)
val bytecomp_c_libraries: string
        (* The C libraries to link with custom runtimes *)
val native_c_libraries: string
        (* The C libraries to link with native-code programs *)
val native_pack_linker: string
        (* The linker to use for packaging (ocamlopt -pack) and for partial
           links (ocamlopt -output-obj). *)
val mkdll: string
        (* The linker command line to build dynamic libraries. *)
val mkexe: string
        (* The linker command line to build executables. *)
val mkmaindll: string
        (* The linker command line to build main programs as dlls. *)
val ranlib: string
        (* Command to randomize a library, or "" if not needed *)
val ar: string
        (* Name of the ar command, or "" if not needed  (MSVC) *)
val cc_profile : string
        (* The command line option to the C compiler to enable profiling. *)

val load_path: string list ref
        (* Directories in the search path for .cmi and .cmo files *)

val interface_suffix: string ref
        (* Suffix for interface file names *)

val exec_magic_number: string
        (* Magic number for bytecode executable files *)
val cmi_magic_number: string
        (* Magic number for compiled interface files *)
val cmo_magic_number: string
        (* Magic number for object bytecode files *)
val cma_magic_number: string
        (* Magic number for archive files *)
val cmx_magic_number: string
        (* Magic number for compilation unit descriptions *)
val cmxa_magic_number: string
        (* Magic number for libraries of compilation unit descriptions *)
val ast_intf_magic_number: string
        (* Magic number for file holding an interface syntax tree *)
val ast_impl_magic_number: string
        (* Magic number for file holding an implementation syntax tree *)
val cmxs_magic_number: string
        (* Magic number for dynamically-loadable plugins *)
val cmt_magic_number: string
        (* Magic number for compiled interface files *)

val max_tag: int
        (* Biggest tag that can be stored in the header of a regular block. *)
val lazy_tag : int
        (* Normally the same as Obj.lazy_tag.  Separate definition because
           of technical reasons for bootstrapping. *)
val max_young_wosize: int
        (* Maximal size of arrays that are directly allocated in the
           minor heap *)
val stack_threshold: int
        (* Size in words of safe area at bottom of VM stack,
           see byterun/config.h *)
val stack_safety_margin: int
        (* Size in words of the safety margin between the bottom of
           the stack and the stack pointer. This margin can be used by
           intermediate computations of some instructions, or the event
           handler. *)

val architecture: string
        (* Name of processor type for the native-code compiler *)
val model: string
        (* Name of processor submodel for the native-code compiler *)
val system: string
        (* Name of operating system for the native-code compiler *)

val asm: string
        (* The assembler (and flags) to use for assembling
           ocamlopt-generated code. *)

val asm_cfi_supported: bool
        (* Whether assembler understands CFI directives *)
val with_frame_pointers : bool
        (* Whether assembler should maintain frame pointers *)

val ext_obj: string
        (* Extension for object files, e.g. [.o] under Unix. *)
val ext_asm: string
        (* Extension for assembler files, e.g. [.s] under Unix. *)
val ext_lib: string
        (* Extension for library files, e.g. [.a] under Unix. *)
val ext_dll: string
        (* Extension for dynamically-loaded libraries, e.g. [.so] under Unix.*)

val default_executable_name: string
        (* Name of executable produced by linking if none is given with -o,
           e.g. [a.out] under Unix. *)

val systhread_supported : bool
        (* Whether the system thread library is implemented *)

val flexdll_dirs : string list
        (* Directories needed for the FlexDLL objects *)

val host : string
        (* Whether the compiler is a cross-compiler *)

val target : string
        (* Whether the compiler is a cross-compiler *)

val print_config : out_channel -> unit;;

val profiling : bool
        (* Whether profiling with gprof is supported on this platform *)

val flambda : bool
        (* Whether the compiler was configured for flambda *)

val spacetime : bool
        (* Whether the compiler was configured for Spacetime profiling *)
val enable_call_counts : bool
        (* Whether call counts are to be available when Spacetime profiling *)
val profinfo : bool
        (* Whether the compiler was configured for profiling *)
val profinfo_width : int
        (* How many bits are to be used in values' headers for profiling
           information *)
val libunwind_available : bool
        (* Whether the libunwind library is available on the target *)
val libunwind_link_flags : string
        (* Linker flags to use libunwind *)

val safe_string: bool
        (* Whether the compiler was configured with -force-safe-string;
           in that case, the -unsafe-string compile-time option is unavailable

           @since 4.05.0 *)
val default_safe_string: bool
        (* Whether the compiler was configured to use the -safe-string
           or -unsafe-string compile-time option by default.

           @since 4.06.0 *)
val flat_float_array : bool
        (* Whether the compiler and runtime automagically flatten float
           arrays *)
val windows_unicode: bool
        (* Whether Windows Unicode runtime is enabled *)
val afl_instrument : bool
        (* Whether afl-fuzz instrumentation is generated by default *)


end = struct
#1 "config_whole_compiler.ml"

(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* The main OCaml version string has moved to ../VERSION *)
let version = "4.06.1+BS"
let standard_library =
  Filename.concat (Filename.dirname Sys.executable_name)  "ocaml"
let standard_library_default = standard_library

let standard_runtime = "ocamlrun" (*dont care:path to ocamlrun*)
let ccomp_type = "cc"
let c_compiler = "gcc"
let c_output_obj = "-o "
let ocamlc_cflags = "-O2 -fno-strict-aliasing -fwrapv "
let ocamlc_cppflags = "-D_FILE_OFFSET_BITS=64 -D_REENTRANT"
let ocamlopt_cflags = "-O2 -fno-strict-aliasing -fwrapv"
let ocamlopt_cppflags = "-D_FILE_OFFSET_BITS=64 -D_REENTRANT"
let bytecomp_c_libraries = "-lcurses -lpthread                  "
(* bytecomp_c_compiler and native_c_compiler have been supported for a
   long time and are retained for backwards compatibility.
   For programs that don't need compatibility with older OCaml releases
   the recommended approach is to use the constituent variables
   c_compiler, ocamlc_cflags, ocamlc_cppflags etc., directly.
*)
let bytecomp_c_compiler =
  "" 
let native_c_compiler =
  ""
let native_c_libraries = ""
let native_pack_linker = "ld -r -arch x86_64 -o\ "
let ranlib = "ranlib"
let ar = "ar"
let cc_profile = "-pg"
let mkdll = ""
let mkexe = "" 
let mkmaindll = ""

let profiling = true
let flambda = false
let safe_string = false
let default_safe_string = true
let windows_unicode = 0 != 0

let flat_float_array = true

let afl_instrument = false

let exec_magic_number = "Caml1999X011"
and cmi_magic_number = "Caml1999I022"
and cmo_magic_number = "Caml1999O022"
and cma_magic_number = "Caml1999A022"
and cmx_magic_number =
  (* if flambda then
    "Caml1999y022"
  else *)
    "Caml1999Y022"
and cmxa_magic_number =
  (* if flambda then
    "Caml1999z022"
  else *)
    "Caml1999Z022"
and ast_impl_magic_number = "Caml1999M022"
and ast_intf_magic_number = "Caml1999N022"
and cmxs_magic_number = "Caml1999D022"
    (* cmxs_magic_number is duplicated in otherlibs/dynlink/natdynlink.ml *)
and cmt_magic_number = "Caml1999T022"

let load_path = ref ([] : string list)

let interface_suffix = ref ".mli"

let max_tag = 245
(* This is normally the same as in obj.ml, but we have to define it
   separately because it can differ when we're in the middle of a
   bootstrapping phase. *)
let lazy_tag = 246

let max_young_wosize = 256
let stack_threshold = 256 (* see byterun/config.h *)
let stack_safety_margin = 60

let architecture = "amd64"
let model = "default"
let system = "macosx"

let asm = "clang -arch x86_64 -Wno-trigraphs -c"
let asm_cfi_supported = true
let with_frame_pointers = false
let spacetime = false
let enable_call_counts = true
let libunwind_available = false
let libunwind_link_flags = ""
let profinfo = false
let profinfo_width = 0

let ext_exe = ""
let ext_obj = ".o"
let ext_asm = ".s"
let ext_lib = ".a"
let ext_dll = ".so"

let host = "x86_64-apple-darwin17.7.0"
let target = "x86_64-apple-darwin17.7.0"

let default_executable_name =
  ""

let systhread_supported = false;;

let flexdll_dirs = [];;

let print_config oc =
  let p name valu = Printf.fprintf oc "%s: %s\n" name valu in
  let p_int name valu = Printf.fprintf oc "%s: %d\n" name valu in
  let p_bool name valu = Printf.fprintf oc "%s: %B\n" name valu in
  p "version" version;
  p "standard_library_default" standard_library_default;
  p "standard_library" standard_library;
  p "standard_runtime" standard_runtime;
  p "ccomp_type" ccomp_type;
  p "c_compiler" c_compiler;
  p "ocamlc_cflags" ocamlc_cflags;
  p "ocamlc_cppflags" ocamlc_cppflags;
  p "ocamlopt_cflags" ocamlopt_cflags;
  p "ocamlopt_cppflags" ocamlopt_cppflags;
  p "bytecomp_c_compiler" bytecomp_c_compiler;
  p "native_c_compiler" native_c_compiler;
  p "bytecomp_c_libraries" bytecomp_c_libraries;
  p "native_c_libraries" native_c_libraries;
  p "native_pack_linker" native_pack_linker;
  p "ranlib" ranlib;
  p "cc_profile" cc_profile;
  p "architecture" architecture;
  p "model" model;
  p_int "int_size" Sys.int_size;
  p_int "word_size" Sys.word_size;
  p "system" system;
  p "asm" asm;
  p_bool "asm_cfi_supported" asm_cfi_supported;
  p_bool "with_frame_pointers" with_frame_pointers;
  p "ext_exe" ext_exe;
  p "ext_obj" ext_obj;
  p "ext_asm" ext_asm;
  p "ext_lib" ext_lib;
  p "ext_dll" ext_dll;
  p "os_type" Sys.os_type;
  p "default_executable_name" default_executable_name;
  p_bool "systhread_supported" systhread_supported;
  p "host" host;
  p "target" target;
  p_bool "profiling" profiling;
  p_bool "flambda" flambda;
  p_bool "spacetime" spacetime;
  p_bool "safe_string" safe_string;
  p_bool "default_safe_string" default_safe_string;
  p_bool "flat_float_array" flat_float_array;
  p_bool "afl_instrument" afl_instrument;
  p_bool "windows_unicode" windows_unicode;

  (* print the magic number *)
  p "exec_magic_number" exec_magic_number;
  p "cmi_magic_number" cmi_magic_number;
  p "cmo_magic_number" cmo_magic_number;
  p "cma_magic_number" cma_magic_number;
  p "cmx_magic_number" cmx_magic_number;
  p "cmxa_magic_number" cmxa_magic_number;
  p "ast_impl_magic_number" ast_impl_magic_number;
  p "ast_intf_magic_number" ast_intf_magic_number;
  p "cmxs_magic_number" cmxs_magic_number;
  p "cmt_magic_number" cmt_magic_number;

  flush oc;
;;


end
module Config = Config_whole_compiler 
module Misc : sig 
#1 "misc.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Miscellaneous useful types and functions *)

val fatal_error: string -> 'a
val fatal_errorf: ('a, Format.formatter, unit, 'b) format4 -> 'a
exception Fatal_error

val try_finally : (unit -> 'a) -> (unit -> unit) -> 'a;;

val map_end: ('a -> 'b) -> 'a list -> 'b list -> 'b list
        (* [map_end f l t] is [map f l @ t], just more efficient. *)
val map_left_right: ('a -> 'b) -> 'a list -> 'b list
        (* Like [List.map], with guaranteed left-to-right evaluation order *)
val for_all2: ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
        (* Same as [List.for_all] but for a binary predicate.
           In addition, this [for_all2] never fails: given two lists
           with different lengths, it returns false. *)
val replicate_list: 'a -> int -> 'a list
        (* [replicate_list elem n] is the list with [n] elements
           all identical to [elem]. *)
val list_remove: 'a -> 'a list -> 'a list
        (* [list_remove x l] returns a copy of [l] with the first
           element equal to [x] removed. *)
val split_last: 'a list -> 'a list * 'a
        (* Return the last element and the other elements of the given list. *)
val may: ('a -> unit) -> 'a option -> unit
val may_map: ('a -> 'b) -> 'a option -> 'b option

type ref_and_value = R : 'a ref * 'a -> ref_and_value

val protect_refs : ref_and_value list -> (unit -> 'a) -> 'a
(** [protect_refs l f] temporarily sets [r] to [v] for each [R (r, v)] in [l]
    while executing [f]. The previous contents of the references is restored
    even if [f] raises an exception. *)

module Stdlib : sig
  module List : sig
    type 'a t = 'a list

    val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
    (** The lexicographic order supported by the provided order.
        There is no constraint on the relative lengths of the lists. *)

    val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
    (** Returns [true] iff the given lists have the same length and content
        with respect to the given equality function. *)

    val filter_map : ('a -> 'b option) -> 'a t -> 'b t
    (** [filter_map f l] applies [f] to every element of [l], filters
        out the [None] elements and returns the list of the arguments of
        the [Some] elements. *)

    val some_if_all_elements_are_some : 'a option t -> 'a t option
    (** If all elements of the given list are [Some _] then [Some xs]
        is returned with the [xs] being the contents of those [Some]s, with
        order preserved.  Otherwise return [None]. *)

    val map2_prefix : ('a -> 'b -> 'c) -> 'a t -> 'b t -> ('c t * 'b t)
    (** [let r1, r2 = map2_prefix f l1 l2]
        If [l1] is of length n and [l2 = h2 @ t2] with h2 of length n,
        r1 is [List.map2 f l1 h1] and r2 is t2. *)

    val split_at : int -> 'a t -> 'a t * 'a t
    (** [split_at n l] returns the pair [before, after] where [before] is
        the [n] first elements of [l] and [after] the remaining ones.
        If [l] has less than [n] elements, raises Invalid_argument. *)
  end

  module Option : sig
    type 'a t = 'a option

    val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool

    val iter : ('a -> unit) -> 'a t -> unit
    val map : ('a -> 'b) -> 'a t -> 'b t
    val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
    val value_default : ('a -> 'b) -> default:'b -> 'a t -> 'b
  end

  module Array : sig
    val exists2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
    (* Same as [Array.exists], but for a two-argument predicate. Raise
       Invalid_argument if the two arrays are determined to have
       different lengths. *)
  end
end

val find_in_path: string list -> string -> string
        (* Search a file in a list of directories. *)
val find_in_path_rel: string list -> string -> string
        (* Search a relative file in a list of directories. *)
val find_in_path_uncap: string list -> string -> string
        (* Same, but search also for uncapitalized name, i.e.
           if name is Foo.ml, allow /path/Foo.ml and /path/foo.ml
           to match. *)
val remove_file: string -> unit
        (* Delete the given file if it exists. Never raise an error. *)
val expand_directory: string -> string -> string
        (* [expand_directory alt file] eventually expands a [+] at the
           beginning of file into [alt] (an alternate root directory) *)

val create_hashtable: int -> ('a * 'b) list -> ('a, 'b) Hashtbl.t
        (* Create a hashtable of the given size and fills it with the
           given bindings. *)

val copy_file: in_channel -> out_channel -> unit
        (* [copy_file ic oc] reads the contents of file [ic] and copies
           them to [oc]. It stops when encountering EOF on [ic]. *)
val copy_file_chunk: in_channel -> out_channel -> int -> unit
        (* [copy_file_chunk ic oc n] reads [n] bytes from [ic] and copies
           them to [oc]. It raises [End_of_file] when encountering
           EOF on [ic]. *)
val string_of_file: in_channel -> string
        (* [string_of_file ic] reads the contents of file [ic] and copies
           them to a string. It stops when encountering EOF on [ic]. *)
val output_to_file_via_temporary:
      ?mode:open_flag list -> string -> (string -> out_channel -> 'a) -> 'a
        (* Produce output in temporary file, then rename it
           (as atomically as possible) to the desired output file name.
           [output_to_file_via_temporary filename fn] opens a temporary file
           which is passed to [fn] (name + output channel).  When [fn] returns,
           the channel is closed and the temporary file is renamed to
           [filename]. *)

val log2: int -> int
        (* [log2 n] returns [s] such that [n = 1 lsl s]
           if [n] is a power of 2*)
val align: int -> int -> int
        (* [align n a] rounds [n] upwards to a multiple of [a]
           (a power of 2). *)
val no_overflow_add: int -> int -> bool
        (* [no_overflow_add n1 n2] returns [true] if the computation of
           [n1 + n2] does not overflow. *)
val no_overflow_sub: int -> int -> bool
        (* [no_overflow_sub n1 n2] returns [true] if the computation of
           [n1 - n2] does not overflow. *)
val no_overflow_mul: int -> int -> bool
        (* [no_overflow_mul n1 n2] returns [true] if the computation of
           [n1 * n2] does not overflow. *)
val no_overflow_lsl: int -> int -> bool
        (* [no_overflow_lsl n k] returns [true] if the computation of
           [n lsl k] does not overflow. *)

module Int_literal_converter : sig
  val int : string -> int
  val int32 : string -> int32
  val int64 : string -> int64
  val nativeint : string -> nativeint
end

val chop_extensions: string -> string
        (* Return the given file name without its extensions. The extensions
           is the longest suffix starting with a period and not including
           a directory separator, [.xyz.uvw] for instance.

           Return the given name if it does not contain an extension. *)

val search_substring: string -> string -> int -> int
        (* [search_substring pat str start] returns the position of the first
           occurrence of string [pat] in string [str].  Search starts
           at offset [start] in [str].  Raise [Not_found] if [pat]
           does not occur. *)

val replace_substring: before:string -> after:string -> string -> string
        (* [replace_substring ~before ~after str] replaces all
           occurrences of [before] with [after] in [str] and returns
           the resulting string. *)

val rev_split_words: string -> string list
        (* [rev_split_words s] splits [s] in blank-separated words, and returns
           the list of words in reverse order. *)

val get_ref: 'a list ref -> 'a list
        (* [get_ref lr] returns the content of the list reference [lr] and reset
           its content to the empty list. *)


val fst3: 'a * 'b * 'c -> 'a
val snd3: 'a * 'b * 'c -> 'b
val thd3: 'a * 'b * 'c -> 'c

val fst4: 'a * 'b * 'c * 'd -> 'a
val snd4: 'a * 'b * 'c * 'd -> 'b
val thd4: 'a * 'b * 'c * 'd -> 'c
val for4: 'a * 'b * 'c * 'd -> 'd

module LongString :
  sig
    type t = bytes array
    val create : int -> t
    val length : t -> int
    val get : t -> int -> char
    val set : t -> int -> char -> unit
    val blit : t -> int -> t -> int -> int -> unit
    val output : out_channel -> t -> int -> int -> unit
    val unsafe_blit_to_bytes : t -> int -> bytes -> int -> int -> unit
    val input_bytes : in_channel -> int -> t
  end

val edit_distance : string -> string -> int -> int option
(** [edit_distance a b cutoff] computes the edit distance between
    strings [a] and [b]. To help efficiency, it uses a cutoff: if the
    distance [d] is smaller than [cutoff], it returns [Some d], else
    [None].

    The distance algorithm currently used is Damerau-Levenshtein: it
    computes the number of insertion, deletion, substitution of
    letters, or swapping of adjacent letters to go from one word to the
    other. The particular algorithm may change in the future.
*)

val spellcheck : string list -> string -> string list
(** [spellcheck env name] takes a list of names [env] that exist in
    the current environment and an erroneous [name], and returns a
    list of suggestions taken from [env], that are close enough to
    [name] that it may be a typo for one of them. *)

val did_you_mean : Format.formatter -> (unit -> string list) -> unit
(** [did_you_mean ppf get_choices] hints that the user may have meant
    one of the option returned by calling [get_choices]. It does nothing
    if the returned list is empty.

    The [unit -> ...] thunking is meant to delay any potentially-slow
    computation (typically computing edit-distance with many things
    from the current environment) to when the hint message is to be
    printed. You should print an understandable error message before
    calling [did_you_mean], so that users get a clear notification of
    the failure even if producing the hint is slow.
*)

val cut_at : string -> char -> string * string
(** [String.cut_at s c] returns a pair containing the sub-string before
   the first occurrence of [c] in [s], and the sub-string after the
   first occurrence of [c] in [s].
   [let (before, after) = String.cut_at s c in
    before ^ String.make 1 c ^ after] is the identity if [s] contains [c].

   Raise [Not_found] if the character does not appear in the string
   @since 4.01
*)


module StringSet: Set.S with type elt = string
module StringMap: Map.S with type key = string
(* TODO: replace all custom instantiations of StringSet/StringMap in various
   compiler modules with this one. *)

(* Color handling *)
module Color : sig
  type color =
    | Black
    | Red
    | Green
    | Yellow
    | Blue
    | Magenta
    | Cyan
    | White
  ;;

  type style =
    | FG of color (* foreground *)
    | BG of color (* background *)
    | Bold
    | Reset

    | Dim


  val ansi_of_style_l : style list -> string
  (* ANSI escape sequence for the given style *)

  type styles = {
    error: style list;
    warning: style list;
    loc: style list;
  }

  val default_styles: styles
  val get_styles: unit -> styles
  val set_styles: styles -> unit

  type setting = Auto | Always | Never

  val setup : setting option -> unit
  (* [setup opt] will enable or disable color handling on standard formatters
     according to the value of color setting [opt].
     Only the first call to this function has an effect. *)

  val set_color_tag_handling : Format.formatter -> unit
  (* adds functions to support color tags to the given formatter. *)
end

val normalise_eol : string -> string
(** [normalise_eol s] returns a fresh copy of [s] with any '\r' characters
   removed. Intended for pre-processing text which will subsequently be printed
   on a channel which performs EOL transformations (i.e. Windows) *)

val delete_eol_spaces : string -> string
(** [delete_eol_spaces s] returns a fresh copy of [s] with any end of
   line spaces removed. Intended to normalize the output of the
   toplevel for tests. *)



(** {1 Hook machinery}

    Hooks machinery:
   [add_hook name f] will register a function that will be called on the
    argument of a later call to [apply_hooks]. Hooks are applied in the
    lexicographical order of their names.
*)

type hook_info = {
  sourcefile : string;
}

exception HookExnWrapper of
    {
      error: exn;
      hook_name: string;
      hook_info: hook_info;
    }
    (** An exception raised by a hook will be wrapped into a
        [HookExnWrapper] constructor by the hook machinery.  *)


val raise_direct_hook_exn: exn -> 'a
  (** A hook can use [raise_unwrapped_hook_exn] to raise an exception that will
      not be wrapped into a {!HookExnWrapper}. *)

module type HookSig = sig
  type t
  val add_hook : string -> (hook_info -> t -> t) -> unit
  val apply_hooks : hook_info -> t -> t
end

module MakeHooks : functor (M : sig type t end) -> HookSig with type t = M.t

end = struct
#1 "misc.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Errors *)

exception Fatal_error

let fatal_error msg =
  prerr_string ">> Fatal error: "; prerr_endline msg; raise Fatal_error

let fatal_errorf fmt = Format.kasprintf fatal_error fmt

(* Exceptions *)

let try_finally work cleanup =
  let result = (try work () with e -> cleanup (); raise e) in
  cleanup ();
  result
;;

type ref_and_value = R : 'a ref * 'a -> ref_and_value

let protect_refs =
  let set_refs l = List.iter (fun (R (r, v)) -> r := v) l in
  fun refs f ->
    let backup = List.map (fun (R (r, _)) -> R (r, !r)) refs in
    set_refs refs;
    match f () with
    | x           -> set_refs backup; x
    | exception e -> set_refs backup; raise e

(* List functions *)

let rec map_end f l1 l2 =
  match l1 with
    [] -> l2
  | hd::tl -> f hd :: map_end f tl l2

let rec map_left_right f = function
    [] -> []
  | hd::tl -> let res = f hd in res :: map_left_right f tl

let rec for_all2 pred l1 l2 =
  match (l1, l2) with
    ([], []) -> true
  | (hd1::tl1, hd2::tl2) -> pred hd1 hd2 && for_all2 pred tl1 tl2
  | (_, _) -> false

let rec replicate_list elem n =
  if n <= 0 then [] else elem :: replicate_list elem (n-1)

let rec list_remove x = function
    [] -> []
  | hd :: tl ->
      if hd = x then tl else hd :: list_remove x tl

let rec split_last = function
    [] -> assert false
  | [x] -> ([], x)
  | hd :: tl ->
      let (lst, last) = split_last tl in
      (hd :: lst, last)

module Stdlib = struct
  module List = struct
    type 'a t = 'a list

    let rec compare cmp l1 l2 =
      match l1, l2 with
      | [], [] -> 0
      | [], _::_ -> -1
      | _::_, [] -> 1
      | h1::t1, h2::t2 ->
        let c = cmp h1 h2 in
        if c <> 0 then c
        else compare cmp t1 t2

    let rec equal eq l1 l2 =
      match l1, l2 with
      | ([], []) -> true
      | (hd1 :: tl1, hd2 :: tl2) -> eq hd1 hd2 && equal eq tl1 tl2
      | (_, _) -> false

    let filter_map f l =
      let rec aux acc l =
        match l with
        | [] -> List.rev acc
        | h :: t ->
          match f h with
          | None -> aux acc t
          | Some v -> aux (v :: acc) t
      in
      aux [] l

    let map2_prefix f l1 l2 =
      let rec aux acc l1 l2 =
        match l1, l2 with
        | [], _ -> (List.rev acc, l2)
        | _ :: _, [] -> raise (Invalid_argument "map2_prefix")
        | h1::t1, h2::t2 ->
          let h = f h1 h2 in
          aux (h :: acc) t1 t2
      in
      aux [] l1 l2

    let some_if_all_elements_are_some l =
      let rec aux acc l =
        match l with
        | [] -> Some (List.rev acc)
        | None :: _ -> None
        | Some h :: t -> aux (h :: acc) t
      in
      aux [] l

    let split_at n l =
      let rec aux n acc l =
        if n = 0
        then List.rev acc, l
        else
          match l with
          | [] -> raise (Invalid_argument "split_at")
          | t::q -> aux (n-1) (t::acc) q
      in
      aux n [] l
  end

  module Option = struct
    type 'a t = 'a option

    let equal eq o1 o2 =
      match o1, o2 with
      | None, None -> true
      | Some e1, Some e2 -> eq e1 e2
      | _, _ -> false

    let iter f = function
      | Some x -> f x
      | None -> ()

    let map f = function
      | Some x -> Some (f x)
      | None -> None

    let fold f a b =
      match a with
      | None -> b
      | Some a -> f a b

    let value_default f ~default a =
      match a with
      | None -> default
      | Some a -> f a
  end

  module Array = struct
    let exists2 p a1 a2 =
      let n = Array.length a1 in
      if Array.length a2 <> n then invalid_arg "Misc.Stdlib.Array.exists2";
      let rec loop i =
        if i = n then false
        else if p (Array.unsafe_get a1 i) (Array.unsafe_get a2 i) then true
        else loop (succ i) in
      loop 0
  end
end

let may = Stdlib.Option.iter
let may_map = Stdlib.Option.map

(* File functions *)

let find_in_path path name =
  if not (Filename.is_implicit name) then
    if Sys.file_exists name then name else raise Not_found
  else begin
    let rec try_dir = function
      [] -> raise Not_found
    | dir::rem ->
        let fullname = Filename.concat dir name in
        if Sys.file_exists fullname then fullname else try_dir rem
    in try_dir path
  end

let find_in_path_rel path name =
  let rec simplify s =
    let open Filename in
    let base = basename s in
    let dir = dirname s in
    if dir = s then dir
    else if base = current_dir_name then simplify dir
    else concat (simplify dir) base
  in
  let rec try_dir = function
    [] -> raise Not_found
  | dir::rem ->
      let fullname = simplify (Filename.concat dir name) in
      if Sys.file_exists fullname then fullname else try_dir rem
  in try_dir path

let find_in_path_uncap path name =
  let uname = String.uncapitalize_ascii name in
  let rec try_dir = function
    [] -> raise Not_found
  | dir::rem ->
      let fullname = Filename.concat dir name
      and ufullname = Filename.concat dir uname in
      if Sys.file_exists ufullname then ufullname
      else if Sys.file_exists fullname then fullname
      else try_dir rem
  in try_dir path

let remove_file filename =
  try
    if Sys.file_exists filename
    then Sys.remove filename
  with Sys_error _msg ->
    ()

(* Expand a -I option: if it starts with +, make it relative to the standard
   library directory *)

let expand_directory alt s =
  if String.length s > 0 && s.[0] = '+'
  then Filename.concat alt
                       (String.sub s 1 (String.length s - 1))
  else s

(* Hashtable functions *)

let create_hashtable size init =
  let tbl = Hashtbl.create size in
  List.iter (fun (key, data) -> Hashtbl.add tbl key data) init;
  tbl

(* File copy *)

let copy_file ic oc =
  let buff = Bytes.create 0x1000 in
  let rec copy () =
    let n = input ic buff 0 0x1000 in
    if n = 0 then () else (output oc buff 0 n; copy())
  in copy()

let copy_file_chunk ic oc len =
  let buff = Bytes.create 0x1000 in
  let rec copy n =
    if n <= 0 then () else begin
      let r = input ic buff 0 (min n 0x1000) in
      if r = 0 then raise End_of_file else (output oc buff 0 r; copy(n-r))
    end
  in copy len

let string_of_file ic =
  let b = Buffer.create 0x10000 in
  let buff = Bytes.create 0x1000 in
  let rec copy () =
    let n = input ic buff 0 0x1000 in
    if n = 0 then Buffer.contents b else
      (Buffer.add_subbytes b buff 0 n; copy())
  in copy()

let output_to_file_via_temporary ?(mode = [Open_text]) filename fn =
  let (temp_filename, oc) =
    Filename.open_temp_file
       ~mode ~perms:0o666 ~temp_dir:(Filename.dirname filename)
       (Filename.basename filename) ".tmp" in
    (* The 0o666 permissions will be modified by the umask.  It's just
       like what [open_out] and [open_out_bin] do.
       With temp_dir = dirname filename, we ensure that the returned
       temp file is in the same directory as filename itself, making
       it safe to rename temp_filename to filename later.
       With prefix = basename filename, we are almost certain that
       the first generated name will be unique.  A fixed prefix
       would work too but might generate more collisions if many
       files are being produced simultaneously in the same directory. *)
  match fn temp_filename oc with
  | res ->
      close_out oc;
      begin try
        Sys.rename temp_filename filename; res
      with exn ->
        remove_file temp_filename; raise exn
      end
  | exception exn ->
      close_out oc; remove_file temp_filename; raise exn

(* Integer operations *)

let rec log2 n =
  if n <= 1 then 0 else 1 + log2(n asr 1)

let align n a =
  if n >= 0 then (n + a - 1) land (-a) else n land (-a)

let no_overflow_add a b = (a lxor b) lor (a lxor (lnot (a+b))) < 0

let no_overflow_sub a b = (a lxor (lnot b)) lor (b lxor (a-b)) < 0

let no_overflow_mul a b = b <> 0 && (a * b) / b = a

let no_overflow_lsl a k =
  0 <= k && k < Sys.word_size && min_int asr k <= a && a <= max_int asr k

module Int_literal_converter = struct
  (* To convert integer literals, allowing max_int + 1 (PR#4210) *)
  let cvt_int_aux str neg of_string =
    if String.length str = 0 || str.[0]= '-'
    then of_string str
    else neg (of_string ("-" ^ str))
  let int s = cvt_int_aux s (~-) int_of_string
  let int32 s = cvt_int_aux s Int32.neg Int32.of_string
  let int64 s = cvt_int_aux s Int64.neg Int64.of_string
  let nativeint s = cvt_int_aux s Nativeint.neg Nativeint.of_string
end

(* String operations *)

let chop_extensions file =
  let dirname = Filename.dirname file and basename = Filename.basename file in
  try
    let pos = String.index basename '.' in
    let basename = String.sub basename 0 pos in
    if Filename.is_implicit file && dirname = Filename.current_dir_name then
      basename
    else
      Filename.concat dirname basename
  with Not_found -> file

let search_substring pat str start =
  let rec search i j =
    if j >= String.length pat then i
    else if i + j >= String.length str then raise Not_found
    else if str.[i + j] = pat.[j] then search i (j+1)
    else search (i+1) 0
  in search start 0

let replace_substring ~before ~after str =
  let rec search acc curr =
    match search_substring before str curr with
      | next ->
         let prefix = String.sub str curr (next - curr) in
         search (prefix :: acc) (next + String.length before)
      | exception Not_found ->
        let suffix = String.sub str curr (String.length str - curr) in
        List.rev (suffix :: acc)
  in String.concat after (search [] 0)

let rev_split_words s =
  let rec split1 res i =
    if i >= String.length s then res else begin
      match s.[i] with
        ' ' | '\t' | '\r' | '\n' -> split1 res (i+1)
      | _ -> split2 res i (i+1)
    end
  and split2 res i j =
    if j >= String.length s then String.sub s i (j-i) :: res else begin
      match s.[j] with
        ' ' | '\t' | '\r' | '\n' -> split1 (String.sub s i (j-i) :: res) (j+1)
      | _ -> split2 res i (j+1)
    end
  in split1 [] 0

let get_ref r =
  let v = !r in
  r := []; v

let fst3 (x, _, _) = x
let snd3 (_,x,_) = x
let thd3 (_,_,x) = x

let fst4 (x, _, _, _) = x
let snd4 (_,x,_, _) = x
let thd4 (_,_,x,_) = x
let for4 (_,_,_,x) = x


module LongString = struct
  type t = bytes array

  let create str_size =
    let tbl_size = str_size / Sys.max_string_length + 1 in
    let tbl = Array.make tbl_size Bytes.empty in
    for i = 0 to tbl_size - 2 do
      tbl.(i) <- Bytes.create Sys.max_string_length;
    done;
    tbl.(tbl_size - 1) <- Bytes.create (str_size mod Sys.max_string_length);
    tbl

  let length tbl =
    let tbl_size = Array.length tbl in
    Sys.max_string_length * (tbl_size - 1) + Bytes.length tbl.(tbl_size - 1)

  let get tbl ind =
    Bytes.get tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length)

  let set tbl ind c =
    Bytes.set tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length)
              c

  let blit src srcoff dst dstoff len =
    for i = 0 to len - 1 do
      set dst (dstoff + i) (get src (srcoff + i))
    done

  let output oc tbl pos len =
    for i = pos to pos + len - 1 do
      output_char oc (get tbl i)
    done

  let unsafe_blit_to_bytes src srcoff dst dstoff len =
    for i = 0 to len - 1 do
      Bytes.unsafe_set dst (dstoff + i) (get src (srcoff + i))
    done

  let input_bytes ic len =
    let tbl = create len in
    Array.iter (fun str -> really_input ic str 0 (Bytes.length str)) tbl;
    tbl
end


let edit_distance a b cutoff =
  let la, lb = String.length a, String.length b in
  let cutoff =
    (* using max_int for cutoff would cause overflows in (i + cutoff + 1);
       we bring it back to the (max la lb) worstcase *)
    min (max la lb) cutoff in
  if abs (la - lb) > cutoff then None
  else begin
    (* initialize with 'cutoff + 1' so that not-yet-written-to cases have
       the worst possible cost; this is useful when computing the cost of
       a case just at the boundary of the cutoff diagonal. *)
    let m = Array.make_matrix (la + 1) (lb + 1) (cutoff + 1) in
    m.(0).(0) <- 0;
    for i = 1 to la do
      m.(i).(0) <- i;
    done;
    for j = 1 to lb do
      m.(0).(j) <- j;
    done;
    for i = 1 to la do
      for j = max 1 (i - cutoff - 1) to min lb (i + cutoff + 1) do
        let cost = if a.[i-1] = b.[j-1] then 0 else 1 in
        let best =
          (* insert, delete or substitute *)
          min (1 + min m.(i-1).(j) m.(i).(j-1)) (m.(i-1).(j-1) + cost)
        in
        let best =
          (* swap two adjacent letters; we use "cost" again in case of
             a swap between two identical letters; this is slightly
             redundant as this is a double-substitution case, but it
             was done this way in most online implementations and
             imitation has its virtues *)
          if not (i > 1 && j > 1 && a.[i-1] = b.[j-2] && a.[i-2] = b.[j-1])
          then best
          else min best (m.(i-2).(j-2) + cost)
        in
        m.(i).(j) <- best
      done;
    done;
    let result = m.(la).(lb) in
    if result > cutoff
    then None
    else Some result
  end

let spellcheck env name =
  let cutoff =
    match String.length name with
      | 1 | 2 -> 0
      | 3 | 4 -> 1
      | 5 | 6 -> 2
      | _ -> 3
  in
  let compare target acc head =
    match edit_distance target head cutoff with
      | None -> acc
      | Some dist ->
         let (best_choice, best_dist) = acc in
         if dist < best_dist then ([head], dist)
         else if dist = best_dist then (head :: best_choice, dist)
         else acc
  in
  fst (List.fold_left (compare name) ([], max_int) env)

let did_you_mean ppf get_choices =
  (* flush now to get the error report early, in the (unheard of) case
     where the search in the get_choices function would take a bit of
     time; in the worst case, the user has seen the error, she can
     interrupt the process before the spell-checking terminates. *)
  Format.fprintf ppf "@?";
  match get_choices () with
  | [] -> ()
  | choices ->
     let rest, last = split_last choices in
     Format.fprintf ppf "@\nHint: Did you mean %s%s%s?@?"
       (String.concat ", " rest)
       (if rest = [] then "" else " or ")
       last

let cut_at s c =
  let pos = String.index s c in
  String.sub s 0 pos, String.sub s (pos+1) (String.length s - pos - 1)


module StringSet = Set.Make(struct type t = string let compare = compare end)
module StringMap = Map.Make(struct type t = string let compare = compare end)

(* Color handling *)
module Color = struct
  (* use ANSI color codes, see https://en.wikipedia.org/wiki/ANSI_escape_code *)
  type color =
    | Black
    | Red
    | Green
    | Yellow
    | Blue
    | Magenta
    | Cyan
    | White
  ;;

  type style =
    | FG of color (* foreground *)
    | BG of color (* background *)
    | Bold
    | Reset

    | Dim


  let ansi_of_color = function
    | Black -> "0"
    | Red -> "1"
    | Green -> "2"
    | Yellow -> "3"
    | Blue -> "4"
    | Magenta -> "5"
    | Cyan -> "6"
    | White -> "7"

  let code_of_style = function
    | FG c -> "3" ^ ansi_of_color c
    | BG c -> "4" ^ ansi_of_color c
    | Bold -> "1"
    | Reset -> "0"

    | Dim -> "2"


  let ansi_of_style_l l =
    let s = match l with
      | [] -> code_of_style Reset
      | [s] -> code_of_style s
      | _ -> String.concat ";" (List.map code_of_style l)
    in
    "\x1b[" ^ s ^ "m"

  type styles = {
    error: style list;
    warning: style list;
    loc: style list;
  }

  let default_styles = {
    warning = [Bold; FG Magenta];
    error = [Bold; FG Red];
    loc = [Bold];
  }

  let cur_styles = ref default_styles
  let get_styles () = !cur_styles
  let set_styles s = cur_styles := s

  (* map a tag to a style, if the tag is known.
     @raise Not_found otherwise *)
  let style_of_tag s = match s with
    | "error" -> (!cur_styles).error
    | "warning" -> (!cur_styles).warning
    | "loc" -> (!cur_styles).loc

    | "info" -> [Bold; FG Yellow]
    | "dim" -> [Dim]
    | "filename" -> [FG Cyan]
                 
    | _ -> raise Not_found

  let color_enabled = ref true

  (* either prints the tag of [s] or delegates to [or_else] *)
  let mark_open_tag ~or_else s =
    try
      let style = style_of_tag s in
      if !color_enabled then ansi_of_style_l style else ""
    with Not_found -> or_else s

  let mark_close_tag ~or_else s =
    try
      let _ = style_of_tag s in
      if !color_enabled then ansi_of_style_l [Reset] else ""
    with Not_found -> or_else s

  (* add color handling to formatter [ppf] *)
  let set_color_tag_handling ppf =
    let open Format in
    let functions = pp_get_formatter_tag_functions ppf () in
    let functions' = {functions with
      mark_open_tag=(mark_open_tag ~or_else:functions.mark_open_tag);
      mark_close_tag=(mark_close_tag ~or_else:functions.mark_close_tag);
    } in
    pp_set_mark_tags ppf true; (* enable tags *)
    pp_set_formatter_tag_functions ppf functions';
    (* also setup margins *)
    pp_set_margin ppf (pp_get_margin std_formatter());
    ()

  external isatty : out_channel -> bool = "caml_sys_isatty"

  (* reasonable heuristic on whether colors should be enabled *)
  let should_enable_color () =
    let term = try Sys.getenv "TERM" with Not_found -> "" in
    term <> "dumb"
    && term <> ""
    && isatty stderr

  type setting = Auto | Always | Never

  let setup =
    let first = ref true in (* initialize only once *)
    let formatter_l =
      [Format.std_formatter; Format.err_formatter; Format.str_formatter]
    in
    fun o ->
      if !first then (
        first := false;
        Format.set_mark_tags true;
        List.iter set_color_tag_handling formatter_l;
        color_enabled := (match o with
            | Some Always -> true
            | Some Auto -> should_enable_color ()
            | Some Never -> false
            | None -> should_enable_color ())
      );
      ()
end

let normalise_eol s =
  let b = Buffer.create 80 in
    for i = 0 to String.length s - 1 do
      if s.[i] <> '\r' then Buffer.add_char b s.[i]
    done;
    Buffer.contents b

let delete_eol_spaces src =
  let len_src = String.length src in
  let dst = Bytes.create len_src in
  let rec loop i_src i_dst =
    if i_src = len_src then
      i_dst
    else
      match src.[i_src] with
      | ' ' | '\t' ->
        loop_spaces 1 (i_src + 1) i_dst
      | c ->
        Bytes.set dst i_dst c;
        loop (i_src + 1) (i_dst + 1)
  and loop_spaces spaces i_src i_dst =
    if i_src = len_src then
      i_dst
    else
      match src.[i_src] with
      | ' ' | '\t' ->
        loop_spaces (spaces + 1) (i_src + 1) i_dst
      | '\n' ->
        Bytes.set dst i_dst '\n';
        loop (i_src + 1) (i_dst + 1)
      | _ ->
        for n = 0 to spaces do
          Bytes.set dst (i_dst + n) src.[i_src - spaces + n]
        done;
        loop (i_src + 1) (i_dst + spaces + 1)
  in
  let stop = loop 0 0 in
  Bytes.sub_string dst 0 stop

type hook_info = {
  sourcefile : string;
}

exception HookExnWrapper of
    {
      error: exn;
      hook_name: string;
      hook_info: hook_info;
    }

exception HookExn of exn

let raise_direct_hook_exn e = raise (HookExn e)

let fold_hooks list hook_info ast =
  List.fold_left (fun ast (hook_name,f) ->
    try
      f hook_info ast
    with
    | HookExn e -> raise e
    | error -> raise (HookExnWrapper {error; hook_name; hook_info})
       (* when explicit reraise with backtrace will be available,
          it should be used here *)

  ) ast (List.sort compare list)

module type HookSig = sig
  type t

  val add_hook : string -> (hook_info -> t -> t) -> unit
  val apply_hooks : hook_info -> t -> t
end

module MakeHooks(M: sig
    type t
  end) : HookSig with type t = M.t
= struct

  type t = M.t

  let hooks = ref []
  let add_hook name f = hooks := (name, f) :: !hooks
  let apply_hooks sourcefile intf =
    fold_hooks !hooks sourcefile intf
end

end
module Identifiable : sig 
#1 "identifiable.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                       Pierre Chambart, OCamlPro                        *)
(*           Mark Shinwell and Leo White, Jane Street Europe              *)
(*                                                                        *)
(*   Copyright 2013--2016 OCamlPro SAS                                    *)
(*   Copyright 2014--2016 Jane Street Group LLC                           *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Uniform interface for common data structures over various things. *)

module type Thing = sig
  type t

  include Hashtbl.HashedType with type t := t
  include Map.OrderedType with type t := t

  val output : out_channel -> t -> unit
  val print : Format.formatter -> t -> unit
end

module Pair : functor (A : Thing) (B : Thing) -> Thing with type t = A.t * B.t

module type Set = sig
  module T : Set.OrderedType
  include Set.S
    with type elt = T.t
     and type t = Set.Make (T).t

  val output : out_channel -> t -> unit
  val print : Format.formatter -> t -> unit
  val to_string : t -> string
  val of_list : elt list -> t
  val map : (elt -> elt) -> t -> t
end

module type Map = sig
  module T : Map.OrderedType
  include Map.S
    with type key = T.t
     and type 'a t = 'a Map.Make (T).t

  val filter_map : 'a t -> f:(key -> 'a -> 'b option) -> 'b t
  val of_list : (key * 'a) list -> 'a t

  (** [disjoint_union m1 m2] contains all bindings from [m1] and
      [m2]. If some binding is present in both and the associated
      value is not equal, a Fatal_error is raised *)
  val disjoint_union : ?eq:('a -> 'a -> bool) -> ?print:(Format.formatter -> 'a -> unit) -> 'a t -> 'a t -> 'a t

  (** [union_right m1 m2] contains all bindings from [m1] and [m2]. If
      some binding is present in both, the one from [m2] is taken *)
  val union_right : 'a t -> 'a t -> 'a t

  (** [union_left m1 m2 = union_right m2 m1] *)
  val union_left : 'a t -> 'a t -> 'a t

  val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
  val rename : key t -> key -> key
  val map_keys : (key -> key) -> 'a t -> 'a t
  val keys : 'a t -> Set.Make(T).t
  val data : 'a t -> 'a list
  val of_set : (key -> 'a) -> Set.Make(T).t -> 'a t
  val transpose_keys_and_data : key t -> key t
  val transpose_keys_and_data_set : key t -> Set.Make(T).t t
  val print :
    (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
end

module type Tbl = sig
  module T : sig
    type t
    include Map.OrderedType with type t := t
    include Hashtbl.HashedType with type t := t
  end
  include Hashtbl.S
    with type key = T.t
     and type 'a t = 'a Hashtbl.Make (T).t

  val to_list : 'a t -> (T.t * 'a) list
  val of_list : (T.t * 'a) list -> 'a t

  val to_map : 'a t -> 'a Map.Make(T).t
  val of_map : 'a Map.Make(T).t -> 'a t
  val memoize : 'a t -> (key -> 'a) -> key -> 'a
  val map : 'a t -> ('a -> 'b) -> 'b t
end

module type S = sig
  type t

  module T : Thing with type t = t
  include Thing with type t := T.t

  module Set : Set with module T := T
  module Map : Map with module T := T
  module Tbl : Tbl with module T := T
end

module Make (T : Thing) : S with type t := T.t

end = struct
#1 "identifiable.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                       Pierre Chambart, OCamlPro                        *)
(*           Mark Shinwell and Leo White, Jane Street Europe              *)
(*                                                                        *)
(*   Copyright 2013--2016 OCamlPro SAS                                    *)
(*   Copyright 2014--2016 Jane Street Group LLC                           *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

module type Thing = sig
  type t

  include Hashtbl.HashedType with type t := t
  include Map.OrderedType with type t := t

  val output : out_channel -> t -> unit
  val print : Format.formatter -> t -> unit
end

module type Set = sig
  module T : Set.OrderedType
  include Set.S
    with type elt = T.t
     and type t = Set.Make (T).t

  val output : out_channel -> t -> unit
  val print : Format.formatter -> t -> unit
  val to_string : t -> string
  val of_list : elt list -> t
  val map : (elt -> elt) -> t -> t
end

module type Map = sig
  module T : Map.OrderedType
  include Map.S
    with type key = T.t
     and type 'a t = 'a Map.Make (T).t

  val filter_map : 'a t -> f:(key -> 'a -> 'b option) -> 'b t
  val of_list : (key * 'a) list -> 'a t

  val disjoint_union : ?eq:('a -> 'a -> bool) -> ?print:(Format.formatter -> 'a -> unit) -> 'a t -> 'a t -> 'a t

  val union_right : 'a t -> 'a t -> 'a t

  val union_left : 'a t -> 'a t -> 'a t

  val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
  val rename : key t -> key -> key
  val map_keys : (key -> key) -> 'a t -> 'a t
  val keys : 'a t -> Set.Make(T).t
  val data : 'a t -> 'a list
  val of_set : (key -> 'a) -> Set.Make(T).t -> 'a t
  val transpose_keys_and_data : key t -> key t
  val transpose_keys_and_data_set : key t -> Set.Make(T).t t
  val print :
    (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
end

module type Tbl = sig
  module T : sig
    type t
    include Map.OrderedType with type t := t
    include Hashtbl.HashedType with type t := t
  end
  include Hashtbl.S
    with type key = T.t
     and type 'a t = 'a Hashtbl.Make (T).t

  val to_list : 'a t -> (T.t * 'a) list
  val of_list : (T.t * 'a) list -> 'a t

  val to_map : 'a t -> 'a Map.Make(T).t
  val of_map : 'a Map.Make(T).t -> 'a t
  val memoize : 'a t -> (key -> 'a) -> key -> 'a
  val map : 'a t -> ('a -> 'b) -> 'b t
end

module Pair (A : Thing) (B : Thing) : Thing with type t = A.t * B.t = struct
  type t = A.t * B.t

  let compare (a1, b1) (a2, b2) =
    let c = A.compare a1 a2 in
    if c <> 0 then c
    else B.compare b1 b2

  let output oc (a, b) = Printf.fprintf oc " (%a, %a)" A.output a B.output b
  let hash (a, b) = Hashtbl.hash (A.hash a, B.hash b)
  let equal (a1, b1) (a2, b2) = A.equal a1 a2 && B.equal b1 b2
  let print ppf (a, b) = Format.fprintf ppf " (%a, @ %a)" A.print a B.print b
end

module Make_map (T : Thing) = struct
  include Map.Make (T)

  let filter_map t ~f =
    fold (fun id v map ->
        match f id v with
        | None -> map
        | Some r -> add id r map) t empty

  let of_list l =
    List.fold_left (fun map (id, v) -> add id v map) empty l

  let disjoint_union ?eq ?print m1 m2 =
    union (fun id v1 v2 ->
        let ok = match eq with
          | None -> false
          | Some eq -> eq v1 v2
        in
        if not ok then
          let err =
            match print with
            | None ->
              Format.asprintf "Map.disjoint_union %a" T.print id
            | Some print ->
              Format.asprintf "Map.disjoint_union %a => %a <> %a"
                T.print id print v1 print v2
          in
          Misc.fatal_error err
        else Some v1)
      m1 m2

  let union_right m1 m2 =
    merge (fun _id x y -> match x, y with
        | None, None -> None
        | None, Some v
        | Some v, None
        | Some _, Some v -> Some v)
      m1 m2

  let union_left m1 m2 = union_right m2 m1

  let union_merge f m1 m2 =
    let aux _ m1 m2 =
      match m1, m2 with
      | None, m | m, None -> m
      | Some m1, Some m2 -> Some (f m1 m2)
    in
    merge aux m1 m2

  let rename m v =
    try find v m
    with Not_found -> v

  let map_keys f m =
    of_list (List.map (fun (k, v) -> f k, v) (bindings m))

  let print f ppf s =
    let elts ppf s = iter (fun id v ->
        Format.fprintf ppf "@ (@[%a@ %a@])" T.print id f v) s in
    Format.fprintf ppf "@[<1>{@[%a@ @]}@]" elts s

  module T_set = Set.Make (T)

  let keys map = fold (fun k _ set -> T_set.add k set) map T_set.empty

  let data t = List.map snd (bindings t)

  let of_set f set = T_set.fold (fun e map -> add e (f e) map) set empty

  let transpose_keys_and_data map = fold (fun k v m -> add v k m) map empty
  let transpose_keys_and_data_set map =
    fold (fun k v m ->
        let set =
          match find v m with
          | exception Not_found ->
            T_set.singleton k
          | set ->
            T_set.add k set
        in
        add v set m)
      map empty
end

module Make_set (T : Thing) = struct
  include Set.Make (T)

  let output oc s =
    Printf.fprintf oc " ( ";
    iter (fun v -> Printf.fprintf oc "%a " T.output v) s;
    Printf.fprintf oc ")"

  let print ppf s =
    let elts ppf s = iter (fun e -> Format.fprintf ppf "@ %a" T.print e) s in
    Format.fprintf ppf "@[<1>{@[%a@ @]}@]" elts s

  let to_string s = Format.asprintf "%a" print s

  let of_list l = match l with
    | [] -> empty
    | [t] -> singleton t
    | t :: q -> List.fold_left (fun acc e -> add e acc) (singleton t) q

  let map f s = of_list (List.map f (elements s))
end

module Make_tbl (T : Thing) = struct
  include Hashtbl.Make (T)

  module T_map = Make_map (T)

  let to_list t =
    fold (fun key datum elts -> (key, datum)::elts) t []

  let of_list elts =
    let t = create 42 in
    List.iter (fun (key, datum) -> add t key datum) elts;
    t

  let to_map v = fold T_map.add v T_map.empty

  let of_map m =
    let t = create (T_map.cardinal m) in
    T_map.iter (fun k v -> add t k v) m;
    t

  let memoize t f = fun key ->
    try find t key with
    | Not_found ->
      let r = f key in
      add t key r;
      r

  let map t f =
    of_map (T_map.map f (to_map t))
end

module type S = sig
  type t

  module T : Thing with type t = t
  include Thing with type t := T.t

  module Set : Set with module T := T
  module Map : Map with module T := T
  module Tbl : Tbl with module T := T
end

module Make (T : Thing) = struct
  module T = T
  include T

  module Set = Make_set (T)
  module Map = Make_map (T)
  module Tbl = Make_tbl (T)
end

end
module Numbers : sig 
#1 "numbers.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                       Pierre Chambart, OCamlPro                        *)
(*           Mark Shinwell and Leo White, Jane Street Europe              *)
(*                                                                        *)
(*   Copyright 2013--2016 OCamlPro SAS                                    *)
(*   Copyright 2014--2016 Jane Street Group LLC                           *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Modules about numbers, some of which satisfy {!Identifiable.S}. *)

module Int : sig
  include Identifiable.S with type t = int

  (** [zero_to_n n] is the set of numbers \{0, ..., n\} (inclusive). *)
  val zero_to_n : int -> Set.t
end

module Int8 : sig
  type t

  val zero : t
  val one : t

  val of_int_exn : int -> t
  val to_int : t -> int
end

module Int16 : sig
  type t

  val of_int_exn : int -> t
  val of_int64_exn : Int64.t -> t

  val to_int : t -> int
end

module Float : Identifiable.S with type t = float

end = struct
#1 "numbers.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                       Pierre Chambart, OCamlPro                        *)
(*           Mark Shinwell and Leo White, Jane Street Europe              *)
(*                                                                        *)
(*   Copyright 2013--2016 OCamlPro SAS                                    *)
(*   Copyright 2014--2016 Jane Street Group LLC                           *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

module Int_base = Identifiable.Make (struct
  type t = int

  let compare x y = x - y
  let output oc x = Printf.fprintf oc "%i" x
  let hash i = i
  let equal (i : int) j = i = j
  let print = Format.pp_print_int
end)

module Int = struct
  type t = int

  include Int_base

  let rec zero_to_n n =
    if n < 0 then Set.empty else Set.add n (zero_to_n (n-1))
end

module Int8 = struct
  type t = int

  let zero = 0
  let one = 1

  let of_int_exn i =
    if i < -(1 lsl 7) || i > ((1 lsl 7) - 1) then
      Misc.fatal_errorf "Int8.of_int_exn: %d is out of range" i
    else
      i

  let to_int i = i
end

module Int16 = struct
  type t = int

  let of_int_exn i =
    if i < -(1 lsl 15) || i > ((1 lsl 15) - 1) then
      Misc.fatal_errorf "Int16.of_int_exn: %d is out of range" i
    else
      i

  let lower_int64 = Int64.neg (Int64.shift_left Int64.one 15)
  let upper_int64 = Int64.sub (Int64.shift_left Int64.one 15) Int64.one

  let of_int64_exn i =
    if Int64.compare i lower_int64 < 0
        || Int64.compare i upper_int64 > 0
    then
      Misc.fatal_errorf "Int16.of_int64_exn: %Ld is out of range" i
    else
      Int64.to_int i

  let to_int t = t
end

module Float = struct
  type t = float

  include Identifiable.Make (struct
    type t = float

    let compare x y = Pervasives.compare x y
    let output oc x = Printf.fprintf oc "%f" x
    let hash f = Hashtbl.hash f
    let equal (i : float) j = i = j
    let print = Format.pp_print_float
  end)
end

end
module Profile : sig 
#1 "profile.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                      Pierre Chambart, OCamlPro                         *)
(*                                                                        *)
(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Compiler performance recording *)

type file = string

val reset : unit -> unit
(** erase all recorded profile information *)

val record_call : ?accumulate:bool -> string -> (unit -> 'a) -> 'a
(** [record_call pass f] calls [f] and records its profile information. *)

val record : ?accumulate:bool -> string -> ('a -> 'b) -> 'a -> 'b
(** [record pass f arg] records the profile information of [f arg] *)

type column = [ `Time | `Alloc | `Top_heap | `Abs_top_heap ]

val print : Format.formatter -> column list -> unit
(** Prints the selected recorded profiling information to the formatter. *)

(** Command line flags *)

val options_doc : string
val all_columns : column list

(** A few pass names that are needed in several places, and shared to
    avoid typos. *)

val generate : string
val transl : string
val typing : string

end = struct
#1 "profile.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                      Pierre Chambart, OCamlPro                         *)
(*                                                                        *)
(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

[@@@ocaml.warning "+a-18-40-42-48"]

type file = string

external time_include_children: bool -> float = "caml_sys_time_include_children"
let cpu_time () = time_include_children true

module Measure = struct
  type t = {
    time : float;
    allocated_words : float;
    top_heap_words : int;
  }
  let create () =
    let stat = Gc.quick_stat () in
    {
      time = cpu_time ();
      allocated_words = stat.minor_words +. stat.major_words;
      top_heap_words = stat.top_heap_words;
    }
  let zero = { time = 0.; allocated_words = 0.; top_heap_words = 0 }
end

module Measure_diff = struct
  let timestamp = let r = ref (-1) in fun () -> incr r; !r
  type t = {
    timestamp : int;
    duration : float;
    allocated_words : float;
    top_heap_words_increase : int;
  }
  let zero () = {
    timestamp = timestamp ();
    duration = 0.;
    allocated_words = 0.;
    top_heap_words_increase = 0;
  }
  let accumulate t (m1 : Measure.t) (m2 : Measure.t) = {
    timestamp = t.timestamp;
    duration = t.duration +. (m2.time -. m1.time);
    allocated_words =
      t.allocated_words +. (m2.allocated_words -. m1.allocated_words);
    top_heap_words_increase =
      t.top_heap_words_increase + (m2.top_heap_words - m1.top_heap_words);
  }
  let of_diff m1 m2 =
    accumulate (zero ()) m1 m2
end

type hierarchy =
  | E of (string, Measure_diff.t * hierarchy) Hashtbl.t
[@@unboxed]

let create () = E (Hashtbl.create 2)
let hierarchy = ref (create ())
let initial_measure = ref None
let reset () = hierarchy := create (); initial_measure := None

let record_call ?(accumulate = false) name f =
  let E prev_hierarchy = !hierarchy in
  let start_measure = Measure.create () in
  if !initial_measure = None then initial_measure := Some start_measure;
  let this_measure_diff, this_table =
    (* We allow the recording of multiple categories by the same name, for tools
       like ocamldoc that use the compiler libs but don't care about profile
       information, and so may record, say, "parsing" multiple times. *)
    if accumulate
    then
      match Hashtbl.find prev_hierarchy name with
      | exception Not_found -> Measure_diff.zero (), Hashtbl.create 2
      | measure_diff, E table ->
        Hashtbl.remove prev_hierarchy name;
        measure_diff, table
    else Measure_diff.zero (), Hashtbl.create 2
  in
  hierarchy := E this_table;
  Misc.try_finally f
    (fun () ->
       hierarchy := E prev_hierarchy;
       let end_measure = Measure.create () in
       let measure_diff =
         Measure_diff.accumulate this_measure_diff start_measure end_measure in
       Hashtbl.add prev_hierarchy name (measure_diff, E this_table))

let record ?accumulate pass f x = record_call ?accumulate pass (fun () -> f x)

type display = {
  to_string : max:float -> width:int -> string;
  worth_displaying : max:float -> bool;
}

let time_display v : display =
  (* Because indentation is meaningful, and because the durations are
     the first element of each row, we can't pad them with spaces. *)
  let to_string_without_unit v ~width = Printf.sprintf "%0*.03f" width v in
  let to_string ~max:_ ~width =
    to_string_without_unit v ~width:(width - 1) ^ "s" in
  let worth_displaying ~max:_ =
    float_of_string (to_string_without_unit v ~width:0) <> 0. in
  { to_string; worth_displaying }

let memory_word_display =
  (* To make memory numbers easily comparable across rows, we choose a single
     scale for an entire column. To keep the display compact and not overly
     precise (no one cares about the exact number of bytes), we pick the largest
     scale we can and we only show 3 digits. Avoiding showing tiny numbers also
     allows us to avoid displaying passes that barely allocate compared to the
     rest of the compiler.  *)
  let bytes_of_words words = words *. float_of_int (Sys.word_size / 8) in
  let to_string_without_unit v ~width scale =
    let precision = 3 and precision_power = 1e3 in
    let v_rescaled = bytes_of_words v /. scale in
    let v_rounded =
      floor (v_rescaled *. precision_power +. 0.5) /. precision_power in
    let v_str = Printf.sprintf "%.*f" precision v_rounded in
    let index_of_dot = String.index v_str '.' in
    let v_str_truncated =
      String.sub v_str 0
        (if index_of_dot >= precision
         then index_of_dot
         else precision + 1)
    in
    Printf.sprintf "%*s" width v_str_truncated
  in
  let choose_memory_scale =
    let units = [|"B"; "kB"; "MB"; "GB"|] in
    fun words ->
      let bytes = bytes_of_words words in
      let scale = ref (Array.length units - 1) in
      while !scale > 0 && bytes < 1024. ** float_of_int !scale do
        decr scale
      done;
      1024. ** float_of_int !scale, units.(!scale)
  in
  fun ?previous v : display ->
    let to_string ~max ~width =
      let scale, scale_str = choose_memory_scale max in
      let width = width - String.length scale_str in
      to_string_without_unit v ~width scale ^ scale_str
    in
    let worth_displaying ~max =
      let scale, _ = choose_memory_scale max in
      float_of_string (to_string_without_unit v ~width:0 scale) <> 0.
      && match previous with
      | None -> true
      | Some p ->
         (* This branch is for numbers that represent absolute quantity, rather
            than differences. It allows us to skip displaying the same absolute
            quantity many times in a row. *)
         to_string_without_unit p ~width:0 scale
         <> to_string_without_unit v ~width:0 scale
    in
    { to_string; worth_displaying }

let profile_list (E table) =
  let l = Hashtbl.fold (fun k d l -> (k, d) :: l) table [] in
  List.sort (fun (_, (p1, _)) (_, (p2, _)) ->
    compare p1.Measure_diff.timestamp p2.Measure_diff.timestamp) l

let compute_other_category (E table : hierarchy) (total : Measure_diff.t) =
  let r = ref total in
  Hashtbl.iter (fun _pass ((p2 : Measure_diff.t), _) ->
    let p1 = !r in
    r := {
      timestamp = p1.timestamp;
      duration = p1.duration -. p2.duration;
      allocated_words = p1.allocated_words -. p2.allocated_words;
      top_heap_words_increase =
        p1.top_heap_words_increase - p2.top_heap_words_increase;
    }
  ) table;
  !r

type row = R of string * (float * display) list * row list
type column = [ `Time | `Alloc | `Top_heap | `Abs_top_heap ]

let rec rows_of_hierarchy ~nesting make_row name measure_diff hierarchy env =
  let rows =
    rows_of_hierarchy_list
      ~nesting:(nesting + 1) make_row hierarchy measure_diff env in
  let values, env =
    make_row env measure_diff ~toplevel_other:(nesting = 0 && name = "other") in
  R (name, values, rows), env

and rows_of_hierarchy_list ~nesting make_row hierarchy total env =
  let list = profile_list hierarchy in
  let list =
    if list <> [] || nesting = 0
    then list @ [ "other", (compute_other_category hierarchy total, create ()) ]
    else []
  in
  let env = ref env in
  List.map (fun (name, (measure_diff, hierarchy)) ->
    let a, env' =
      rows_of_hierarchy ~nesting make_row name measure_diff hierarchy !env in
    env := env';
    a
  ) list

let rows_of_hierarchy hierarchy measure_diff initial_measure columns =
  (* Computing top heap size is a bit complicated: if the compiler applies a
     list of passes n times (rather than applying pass1 n times, then pass2 n
     times etc), we only show one row for that pass but what does "top heap
     size at the end of that pass" even mean?
     It seems the only sensible answer is to pretend the compiler applied pass1
     n times, pass2 n times by accumulating all the heap size increases that
     happened during each pass, and then compute what the heap size would have
     been. So that's what we do.
     There's a bit of extra complication, which is that the heap can increase in
     between measurements. So the heap sizes can be a bit off until the "other"
     rows account for what's missing. We special case the toplevel "other" row
     so that any increases that happened before the start of the compilation is
     correctly reported, as a lot of code may run before the start of the
     compilation (eg functor applications). *)
    let make_row prev_top_heap_words (p : Measure_diff.t) ~toplevel_other =
      let top_heap_words =
        prev_top_heap_words
        + p.top_heap_words_increase
        - if toplevel_other
          then initial_measure.Measure.top_heap_words
          else 0
      in
      let make value ~f = value, f value in
      List.map (function
        | `Time ->
          make p.duration ~f:time_display
        | `Alloc ->
          make p.allocated_words ~f:memory_word_display
        | `Top_heap ->
          make (float_of_int p.top_heap_words_increase) ~f:memory_word_display
        | `Abs_top_heap ->
          make (float_of_int top_heap_words)
           ~f:(memory_word_display ~previous:(float_of_int prev_top_heap_words))
      ) columns,
      top_heap_words
  in
  rows_of_hierarchy_list ~nesting:0 make_row hierarchy measure_diff
    initial_measure.top_heap_words

let max_by_column ~n_columns rows =
  let a = Array.make n_columns 0. in
  let rec loop (R (_, values, rows)) =
    List.iteri (fun i (v, _) -> a.(i) <- max a.(i) v) values;
    List.iter loop rows
  in
  List.iter loop rows;
  a

let width_by_column ~n_columns ~display_cell rows =
  let a = Array.make n_columns 1 in
  let rec loop (R (_, values, rows)) =
    List.iteri (fun i cell ->
      let _, str = display_cell i cell ~width:0 in
      a.(i) <- max a.(i) (String.length str)
    ) values;
    List.iter loop rows;
  in
  List.iter loop rows;
  a

let display_rows ppf rows =
  let n_columns =
    match rows with
    | [] -> 0
    | R (_, values, _) :: _ -> List.length values
  in
  let maxs = max_by_column ~n_columns rows in
  let display_cell i (_, c) ~width =
    let display_cell = c.worth_displaying ~max:maxs.(i) in
    display_cell, if display_cell
                  then c.to_string ~max:maxs.(i) ~width
                  else String.make width '-'
  in
  let widths = width_by_column ~n_columns ~display_cell rows in
  let rec loop (R (name, values, rows)) ~indentation =
    let worth_displaying, cell_strings =
      values
      |> List.mapi (fun i cell -> display_cell i cell ~width:widths.(i))
      |> List.split
    in
    if List.exists (fun b -> b) worth_displaying then
      Format.fprintf ppf "%s%s %s@\n"
        indentation (String.concat " " cell_strings) name;
    List.iter (loop ~indentation:("  " ^ indentation)) rows;
  in
  List.iter (loop ~indentation:"") rows

let print ppf columns =
  match columns with
  | [] -> ()
  | _ :: _ ->
     let initial_measure =
       match !initial_measure with
       | Some v -> v
       | None -> Measure.zero
     in
     let total = Measure_diff.of_diff Measure.zero (Measure.create ()) in
     display_rows ppf (rows_of_hierarchy !hierarchy total initial_measure columns)

let column_mapping = [
  "time", `Time;
  "alloc", `Alloc;
  "top-heap", `Top_heap;
  "absolute-top-heap", `Abs_top_heap;
]

let column_names = List.map fst column_mapping

let options_doc =
  Printf.sprintf
    " Print performance information for each pass\
   \n    The columns are: %s."
    (String.concat " " column_names)

let all_columns = List.map snd column_mapping

let generate = "generate"
let transl = "transl"
let typing = "typing"

end
module Clflags : sig 
#1 "clflags.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 2005 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Command line flags *)

(** Optimization parameters represented as ints indexed by round number. *)
module Int_arg_helper : sig
  type parsed

  val parse : string -> string -> parsed ref -> unit

  type parse_result =
    | Ok
    | Parse_failed of exn
  val parse_no_error : string -> parsed ref -> parse_result

  val get : key:int -> parsed -> int
end

(** Optimization parameters represented as floats indexed by round number. *)
module Float_arg_helper : sig
  type parsed

  val parse : string -> string -> parsed ref -> unit

  type parse_result =
    | Ok
    | Parse_failed of exn
  val parse_no_error : string -> parsed ref -> parse_result

  val get : key:int -> parsed -> float
end

type inlining_arguments = {
  inline_call_cost : int option;
  inline_alloc_cost : int option;
  inline_prim_cost : int option;
  inline_branch_cost : int option;
  inline_indirect_cost : int option;
  inline_lifting_benefit : int option;
  inline_branch_factor : float option;
  inline_max_depth : int option;
  inline_max_unroll : int option;
  inline_threshold : float option;
  inline_toplevel_threshold : int option;
}

val classic_arguments : inlining_arguments
val o1_arguments : inlining_arguments
val o2_arguments : inlining_arguments
val o3_arguments : inlining_arguments

(** Set all the inlining arguments for a round.
    The default is set if no round is provided. *)
val use_inlining_arguments_set : ?round:int -> inlining_arguments -> unit

val objfiles : string list ref
val ccobjs : string list ref
val dllibs : string list ref
val compile_only : bool ref
val output_name : string option ref
val include_dirs : string list ref
val no_std_include : bool ref
val print_types : bool ref
val make_archive : bool ref
val debug : bool ref
val fast : bool ref
val use_linscan : bool ref
val link_everything : bool ref
val custom_runtime : bool ref
val no_check_prims : bool ref
val bytecode_compatible_32 : bool ref
val output_c_object : bool ref
val output_complete_object : bool ref
val all_ccopts : string list ref
val classic : bool ref
val nopervasives : bool ref
val open_modules : string list ref
val preprocessor : string option ref
val all_ppx : string list ref
val annotations : bool ref
val binary_annotations : bool ref
val use_threads : bool ref
val use_vmthreads : bool ref
val noassert : bool ref
val verbose : bool ref
val noprompt : bool ref
val nopromptcont : bool ref
val init_file : string option ref
val noinit : bool ref
val noversion : bool ref
val use_prims : string ref
val use_runtime : string ref
val principal : bool ref
val real_paths : bool ref
val recursive_types : bool ref
val strict_sequence : bool ref
val strict_formats : bool ref
val applicative_functors : bool ref
val make_runtime : bool ref
val gprofile : bool ref
val c_compiler : string option ref
val no_auto_link : bool ref
val dllpaths : string list ref
val make_package : bool ref
val for_package : string option ref
val error_size : int ref
val float_const_prop : bool ref
val transparent_modules : bool ref
val dump_source : bool ref
val dump_parsetree : bool ref
val dump_typedtree : bool ref
val dump_rawlambda : bool ref
val dump_lambda : bool ref
val dump_rawclambda : bool ref
val dump_clambda : bool ref
val dump_rawflambda : bool ref
val dump_flambda : bool ref
val dump_flambda_let : int option ref
val dump_instr : bool ref
val keep_asm_file : bool ref
val optimize_for_speed : bool ref
val dump_cmm : bool ref
val dump_selection : bool ref
val dump_cse : bool ref
val dump_live : bool ref
val dump_avail : bool ref
val debug_runavail : bool ref
val dump_spill : bool ref
val dump_split : bool ref
val dump_interf : bool ref
val dump_prefer : bool ref
val dump_regalloc : bool ref
val dump_reload : bool ref
val dump_scheduling : bool ref
val dump_linear : bool ref
val dump_interval : bool ref
val keep_startup_file : bool ref
val dump_combine : bool ref
val native_code : bool ref
val default_inline_threshold : float
val inline_threshold : Float_arg_helper.parsed ref
val inlining_report : bool ref
val simplify_rounds : int option ref
val default_simplify_rounds : int ref
val rounds : unit -> int
val default_inline_max_unroll : int
val inline_max_unroll : Int_arg_helper.parsed ref
val default_inline_toplevel_threshold : int
val inline_toplevel_threshold : Int_arg_helper.parsed ref
val default_inline_call_cost : int
val default_inline_alloc_cost : int
val default_inline_prim_cost : int
val default_inline_branch_cost : int
val default_inline_indirect_cost : int
val default_inline_lifting_benefit : int
val inline_call_cost : Int_arg_helper.parsed ref
val inline_alloc_cost : Int_arg_helper.parsed ref
val inline_prim_cost : Int_arg_helper.parsed ref
val inline_branch_cost : Int_arg_helper.parsed ref
val inline_indirect_cost : Int_arg_helper.parsed ref
val inline_lifting_benefit : Int_arg_helper.parsed ref
val default_inline_branch_factor : float
val inline_branch_factor : Float_arg_helper.parsed ref
val dont_write_files : bool ref
val std_include_flag : string -> string
val std_include_dir : unit -> string list
val shared : bool ref
val dlcode : bool ref
val pic_code : bool ref
val runtime_variant : string ref
val force_slash : bool ref
val keep_docs : bool ref
val keep_locs : bool ref
val unsafe_string : bool ref
val opaque : bool ref
val profile_columns : Profile.column list ref
val flambda_invariant_checks : bool ref
val unbox_closures : bool ref
val unbox_closures_factor : int ref
val default_unbox_closures_factor : int
val unbox_free_vars_of_closures : bool ref
val unbox_specialised_args : bool ref
val clambda_checks : bool ref
val default_inline_max_depth : int
val inline_max_depth : Int_arg_helper.parsed ref
val remove_unused_arguments : bool ref
val dump_flambda_verbose : bool ref
val classic_inlining : bool ref
val afl_instrument : bool ref
val afl_inst_ratio : int ref

val all_passes : string list ref
val dumped_pass : string -> bool
val set_dumped_pass : string -> bool -> unit

val parse_color_setting : string -> Misc.Color.setting option
val color : Misc.Color.setting option ref

val unboxed_types : bool ref

val arg_spec : (string * Arg.spec * string) list ref

(* [add_arguments __LOC__ args] will add the arguments from [args] at
   the end of [arg_spec], checking that they have not already been
   added by [add_arguments] before. A warning is printed showing the
   locations of the function from which the argument was previously
   added. *)
val add_arguments : string -> (string * Arg.spec * string) list -> unit

(* [parse_arguments anon_arg usage] will parse the arguments, using
  the arguments provided in [Clflags.arg_spec]. It allows plugins to
  provide their own arguments.
*)
val parse_arguments : Arg.anon_fun -> string -> unit

(* [print_arguments usage] print the standard usage message *)
val print_arguments : string -> unit

(* [reset_arguments ()] clear all declared arguments *)
val reset_arguments : unit -> unit


type mli_status = Mli_na | Mli_exists | Mli_non_exists
val no_implicit_current_dir : bool ref
val assume_no_mli : mli_status ref
val record_event_when_debug : bool ref
val bs_vscode : bool
val dont_record_crc_unit : string option ref
val bs_only : bool ref (* set true on bs top*)
val bs_gentype : string option ref
val no_assert_false : bool ref
val bs_quiet : bool ref 


end = struct
#1 "clflags.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Command-line parameters *)

module Int_arg_helper = Arg_helper.Make (struct
  module Key = struct
    include Numbers.Int
    let of_string = int_of_string
  end

  module Value = struct
    include Numbers.Int
    let of_string = int_of_string
  end
end)
module Float_arg_helper = Arg_helper.Make (struct
  module Key = struct
    include Numbers.Int
    let of_string = int_of_string
  end

  module Value = struct
    include Numbers.Float
    let of_string = float_of_string
  end
end)

let objfiles = ref ([] : string list)   (* .cmo and .cma files *)
and ccobjs = ref ([] : string list)     (* .o, .a, .so and -cclib -lxxx *)
and dllibs = ref ([] : string list)     (* .so and -dllib -lxxx *)

let compile_only = ref false            (* -c *)
and output_name = ref (None : string option) (* -o *)
and include_dirs = ref ([] : string list)(* -I *)
and no_std_include = ref false          (* -nostdlib *)
and print_types = ref false             (* -i *)
and make_archive = ref false            (* -a *)
and debug = ref false                   (* -g *)
and fast = ref false                    (* -unsafe *)
and use_linscan = ref false             (* -linscan *)
and link_everything = ref false         (* -linkall *)
and custom_runtime = ref false          (* -custom *)
and no_check_prims = ref false          (* -no-check-prims *)
and bytecode_compatible_32 = ref false  (* -compat-32 *)
and output_c_object = ref false         (* -output-obj *)
and output_complete_object = ref false  (* -output-complete-obj *)
and all_ccopts = ref ([] : string list)     (* -ccopt *)
and classic = ref false                 (* -nolabels *)
and nopervasives = ref false            (* -nopervasives *)
and preprocessor = ref(None : string option) (* -pp *)
and all_ppx = ref ([] : string list)        (* -ppx *)
let annotations = ref false             (* -annot *)
let binary_annotations = ref false      (* -annot *)
and use_threads = ref false             (* -thread *)
and use_vmthreads = ref false           (* -vmthread *)
and noassert = ref false                (* -noassert *)
and verbose = ref false                 (* -verbose *)
and noversion = ref false               (* -no-version *)
and noprompt = ref false                (* -noprompt *)
and nopromptcont = ref false            (* -nopromptcont *)
and init_file = ref (None : string option)   (* -init *)
and noinit = ref false                  (* -noinit *)
and open_modules = ref []               (* -open *)
and use_prims = ref ""                  (* -use-prims ... *)
and use_runtime = ref ""                (* -use-runtime ... *)
and principal = ref false               (* -principal *)
and real_paths = ref true               (* -short-paths *)
and recursive_types = ref false         (* -rectypes *)
and strict_sequence = ref false         (* -strict-sequence *)
and strict_formats = ref false          (* -strict-formats *)
and applicative_functors = ref true     (* -no-app-funct *)
and make_runtime = ref false            (* -make-runtime *)
and gprofile = ref false                (* -p *)
and c_compiler = ref (None: string option) (* -cc *)
and no_auto_link = ref false            (* -noautolink *)
and dllpaths = ref ([] : string list)   (* -dllpath *)
and make_package = ref false            (* -pack *)
and for_package = ref (None: string option) (* -for-pack *)
and error_size = ref 500                (* -error-size *)
and float_const_prop = ref true         (* -no-float-const-prop *)
and transparent_modules = ref false     (* -trans-mod *)
let dump_source = ref false             (* -dsource *)
let dump_parsetree = ref false          (* -dparsetree *)
and dump_typedtree = ref false          (* -dtypedtree *)
and dump_rawlambda = ref false          (* -drawlambda *)
and dump_lambda = ref false             (* -dlambda *)
and dump_rawclambda = ref false         (* -drawclambda *)
and dump_clambda = ref false            (* -dclambda *)
and dump_rawflambda = ref false            (* -drawflambda *)
and dump_flambda = ref false            (* -dflambda *)
and dump_flambda_let = ref (None : int option) (* -dflambda-let=... *)
and dump_flambda_verbose = ref false    (* -dflambda-verbose *)
and dump_instr = ref false              (* -dinstr *)

let keep_asm_file = ref false           (* -S *)
let optimize_for_speed = ref true       (* -compact *)
and opaque = ref false                  (* -opaque *)

and dump_cmm = ref false                (* -dcmm *)
let dump_selection = ref false          (* -dsel *)
let dump_cse = ref false                (* -dcse *)
let dump_live = ref false               (* -dlive *)
let dump_avail = ref false              (* -davail *)
let dump_spill = ref false              (* -dspill *)
let dump_split = ref false              (* -dsplit *)
let dump_interf = ref false             (* -dinterf *)
let dump_prefer = ref false             (* -dprefer *)
let dump_regalloc = ref false           (* -dalloc *)
let dump_reload = ref false             (* -dreload *)
let dump_scheduling = ref false         (* -dscheduling *)
let dump_linear = ref false             (* -dlinear *)
let dump_interval = ref false           (* -dinterval *)
let keep_startup_file = ref false       (* -dstartup *)
let dump_combine = ref false            (* -dcombine *)
let profile_columns : Profile.column list ref = ref [] (* -dprofile/-dtimings *)

let debug_runavail = ref false          (* -drunavail *)

let native_code = ref false             (* set to true under ocamlopt *)

let force_slash = ref false             (* for ocamldep *)
let clambda_checks = ref false          (* -clambda-checks *)

let flambda_invariant_checks = ref true (* -flambda-invariants *)

let dont_write_files = ref false        (* set to true under ocamldoc *)

let std_include_flag prefix =
  if !no_std_include then ""
  else (prefix ^ (Filename.quote Config.standard_library))
;;

let std_include_dir () =
  if !no_std_include then [] else [Config.standard_library]
;;

let shared = ref false (* -shared *)
let dlcode = ref true (* not -nodynlink *)

let pic_code = ref (match Config.architecture with (* -fPIC *)
                     | "amd64" -> true
                     | _       -> false)

let runtime_variant = ref "";;      (* -runtime-variant *)

let keep_docs = ref false              (* -keep-docs *)
let keep_locs = ref true               (* -keep-locs *)
let unsafe_string =
  if Config.safe_string then ref false
  else ref (not Config.default_safe_string)
                                   (* -safe-string / -unsafe-string *)

let classic_inlining = ref false       (* -Oclassic *)
let inlining_report = ref false    (* -inlining-report *)

let afl_instrument = ref Config.afl_instrument (* -afl-instrument *)
let afl_inst_ratio = ref 100           (* -afl-inst-ratio *)

let simplify_rounds = ref None        (* -rounds *)
let default_simplify_rounds = ref 1        (* -rounds *)
let rounds () =
  match !simplify_rounds with
  | None -> !default_simplify_rounds
  | Some r -> r

let default_inline_threshold = if Config.flambda then 10. else 10. /. 8.
let inline_toplevel_multiplier = 16
let default_inline_toplevel_threshold =
  int_of_float ((float inline_toplevel_multiplier) *. default_inline_threshold)
let default_inline_call_cost = 5
let default_inline_alloc_cost = 7
let default_inline_prim_cost = 3
let default_inline_branch_cost = 5
let default_inline_indirect_cost = 4
let default_inline_branch_factor = 0.1
let default_inline_lifting_benefit = 1300
let default_inline_max_unroll = 0
let default_inline_max_depth = 1

let inline_threshold = ref (Float_arg_helper.default default_inline_threshold)
let inline_toplevel_threshold =
  ref (Int_arg_helper.default default_inline_toplevel_threshold)
let inline_call_cost = ref (Int_arg_helper.default default_inline_call_cost)
let inline_alloc_cost = ref (Int_arg_helper.default default_inline_alloc_cost)
let inline_prim_cost = ref (Int_arg_helper.default default_inline_prim_cost)
let inline_branch_cost =
  ref (Int_arg_helper.default default_inline_branch_cost)
let inline_indirect_cost =
  ref (Int_arg_helper.default default_inline_indirect_cost)
let inline_branch_factor =
  ref (Float_arg_helper.default default_inline_branch_factor)
let inline_lifting_benefit =
  ref (Int_arg_helper.default default_inline_lifting_benefit)
let inline_max_unroll =
  ref (Int_arg_helper.default default_inline_max_unroll)
let inline_max_depth =
  ref (Int_arg_helper.default default_inline_max_depth)


let unbox_specialised_args = ref true   (* -no-unbox-specialised-args *)
let unbox_free_vars_of_closures = ref true
let unbox_closures = ref false          (* -unbox-closures *)
let default_unbox_closures_factor = 10
let unbox_closures_factor =
  ref default_unbox_closures_factor      (* -unbox-closures-factor *)
let remove_unused_arguments = ref false (* -remove-unused-arguments *)

type inlining_arguments = {
  inline_call_cost : int option;
  inline_alloc_cost : int option;
  inline_prim_cost : int option;
  inline_branch_cost : int option;
  inline_indirect_cost : int option;
  inline_lifting_benefit : int option;
  inline_branch_factor : float option;
  inline_max_depth : int option;
  inline_max_unroll : int option;
  inline_threshold : float option;
  inline_toplevel_threshold : int option;
}

let set_int_arg round (arg:Int_arg_helper.parsed ref) default value =
  let value : int =
    match value with
    | None -> default
    | Some value -> value
  in
  match round with
  | None ->
    arg := Int_arg_helper.set_base_default value
             (Int_arg_helper.reset_base_overrides !arg)
  | Some round ->
    arg := Int_arg_helper.add_base_override round value !arg

let set_float_arg round (arg:Float_arg_helper.parsed ref) default value =
  let value =
    match value with
    | None -> default
    | Some value -> value
  in
  match round with
  | None ->
    arg := Float_arg_helper.set_base_default value
             (Float_arg_helper.reset_base_overrides !arg)
  | Some round ->
    arg := Float_arg_helper.add_base_override round value !arg

let use_inlining_arguments_set ?round (arg:inlining_arguments) =
  let set_int = set_int_arg round in
  let set_float = set_float_arg round in
  set_int inline_call_cost default_inline_call_cost arg.inline_call_cost;
  set_int inline_alloc_cost default_inline_alloc_cost arg.inline_alloc_cost;
  set_int inline_prim_cost default_inline_prim_cost arg.inline_prim_cost;
  set_int inline_branch_cost
    default_inline_branch_cost arg.inline_branch_cost;
  set_int inline_indirect_cost
    default_inline_indirect_cost arg.inline_indirect_cost;
  set_int inline_lifting_benefit
    default_inline_lifting_benefit arg.inline_lifting_benefit;
  set_float inline_branch_factor
    default_inline_branch_factor arg.inline_branch_factor;
  set_int inline_max_depth
    default_inline_max_depth arg.inline_max_depth;
  set_int inline_max_unroll
    default_inline_max_unroll arg.inline_max_unroll;
  set_float inline_threshold
    default_inline_threshold arg.inline_threshold;
  set_int inline_toplevel_threshold
    default_inline_toplevel_threshold arg.inline_toplevel_threshold

(* o1 is the default *)
let o1_arguments = {
  inline_call_cost = None;
  inline_alloc_cost = None;
  inline_prim_cost = None;
  inline_branch_cost = None;
  inline_indirect_cost = None;
  inline_lifting_benefit = None;
  inline_branch_factor = None;
  inline_max_depth = None;
  inline_max_unroll = None;
  inline_threshold = None;
  inline_toplevel_threshold = None;
}

let classic_arguments = {
  inline_call_cost = None;
  inline_alloc_cost = None;
  inline_prim_cost = None;
  inline_branch_cost = None;
  inline_indirect_cost = None;
  inline_lifting_benefit = None;
  inline_branch_factor = None;
  inline_max_depth = None;
  inline_max_unroll = None;
  (* [inline_threshold] matches the current compiler's default.
     Note that this particular fraction can be expressed exactly in
     floating point. *)
  inline_threshold = Some (10. /. 8.);
  (* [inline_toplevel_threshold] is not used in classic mode. *)
  inline_toplevel_threshold = Some 1;
}

let o2_arguments = {
  inline_call_cost = Some (2 * default_inline_call_cost);
  inline_alloc_cost = Some (2 * default_inline_alloc_cost);
  inline_prim_cost = Some (2 * default_inline_prim_cost);
  inline_branch_cost = Some (2 * default_inline_branch_cost);
  inline_indirect_cost = Some (2 * default_inline_indirect_cost);
  inline_lifting_benefit = None;
  inline_branch_factor = None;
  inline_max_depth = Some 2;
  inline_max_unroll = None;
  inline_threshold = Some 25.;
  inline_toplevel_threshold = Some (25 * inline_toplevel_multiplier);
}

let o3_arguments = {
  inline_call_cost = Some (3 * default_inline_call_cost);
  inline_alloc_cost = Some (3 * default_inline_alloc_cost);
  inline_prim_cost = Some (3 * default_inline_prim_cost);
  inline_branch_cost = Some (3 * default_inline_branch_cost);
  inline_indirect_cost = Some (3 * default_inline_indirect_cost);
  inline_lifting_benefit = None;
  inline_branch_factor = Some 0.;
  inline_max_depth = Some 3;
  inline_max_unroll = Some 1;
  inline_threshold = Some 50.;
  inline_toplevel_threshold = Some (50 * inline_toplevel_multiplier);
}

let all_passes = ref []
let dumped_passes_list = ref []
let dumped_pass s =
  assert(List.mem s !all_passes);
  List.mem s !dumped_passes_list

let set_dumped_pass s enabled =
  if (List.mem s !all_passes) then begin
    let passes_without_s = List.filter ((<>) s) !dumped_passes_list in
    let dumped_passes =
      if enabled then
        s :: passes_without_s
      else
        passes_without_s
    in
    dumped_passes_list := dumped_passes
  end

let parse_color_setting = function
  | "auto" -> Some Misc.Color.Auto
  | "always" -> Some Misc.Color.Always
  | "never" -> Some Misc.Color.Never
  | _ -> None
let color = ref None ;; (* -color *)

let unboxed_types = ref false

let arg_spec = ref []
let arg_names = ref Misc.StringMap.empty

let reset_arguments () =
  arg_spec := [];
  arg_names := Misc.StringMap.empty

let add_arguments loc args =
  List.iter (function (arg_name, _, _) as arg ->
    try
      let loc2 = Misc.StringMap.find arg_name !arg_names in
      Printf.eprintf
        "Warning: plugin argument %s is already defined:\n" arg_name;
      Printf.eprintf "   First definition: %s\n" loc2;
      Printf.eprintf "   New definition: %s\n" loc;
    with Not_found ->
      arg_spec := !arg_spec @ [ arg ];
      arg_names := Misc.StringMap.add arg_name loc !arg_names
  ) args

let print_arguments usage =
  Arg.usage !arg_spec usage

(* This function is almost the same as [Arg.parse_expand], except
   that [Arg.parse_expand] could not be used because it does not take a
   reference for [arg_spec].*)
let parse_arguments f msg =
  try
    let argv = ref Sys.argv in
    let current = ref (!Arg.current) in
    Arg.parse_and_expand_argv_dynamic current argv arg_spec f msg
  with
  | Arg.Bad msg -> Printf.eprintf "%s" msg; exit 2
  | Arg.Help msg -> Printf.printf "%s" msg; exit 0


type mli_status = Mli_na | Mli_exists | Mli_non_exists
let no_implicit_current_dir = ref false
let assume_no_mli = ref Mli_na
let record_event_when_debug = ref true (* turned off in BuckleScript*)
let bs_vscode =
    try ignore @@ Sys.getenv "BS_VSCODE" ; true with _ -> false
    (* We get it from environment variable mostly due to
       we don't want to rebuild when flip on or off
    *)
let dont_record_crc_unit : string option ref = ref None
let bs_only = ref false
let bs_gentype = ref None
let no_assert_false = ref false
let bs_quiet = ref false


end
module Terminfo : sig 
#1 "terminfo.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Basic interface to the terminfo database *)

type status =
  | Uninitialised
  | Bad_term
  | Good_term of int  (* number of lines of the terminal *)
;;
external setup : out_channel -> status = "caml_terminfo_setup";;
external backup : int -> unit = "caml_terminfo_backup";;
external standout : bool -> unit = "caml_terminfo_standout";;
external resume : int -> unit = "caml_terminfo_resume";;

end = struct
#1 "terminfo.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Basic interface to the terminfo database *)

type status =
  | Uninitialised
  | Bad_term
  | Good_term of int
;;
external setup : out_channel -> status = "caml_terminfo_setup";;
external backup : int -> unit = "caml_terminfo_backup";;
external standout : bool -> unit = "caml_terminfo_standout";;
external resume : int -> unit = "caml_terminfo_resume";;

end
module Warnings : sig 
#1 "warnings.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Pierre Weis && Damien Doligez, INRIA Rocquencourt          *)
(*                                                                        *)
(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

type loc = {
  loc_start: Lexing.position;
  loc_end: Lexing.position;
  loc_ghost: bool;
}

type t =
  | Comment_start                           (*  1 *)
  | Comment_not_end                         (*  2 *)
  | Deprecated of string * loc * loc        (*  3 *)
  | Fragile_match of string                 (*  4 *)
  | Partial_application                     (*  5 *)
  | Labels_omitted of string list           (*  6 *)
  | Method_override of string list          (*  7 *)
  | Partial_match of string                 (*  8 *)
  | Non_closed_record_pattern of string     (*  9 *)
  | Statement_type                          (* 10 *)
  | Unused_match                            (* 11 *)
  | Unused_pat                              (* 12 *)
  | Instance_variable_override of string list (* 13 *)
  | Illegal_backslash                       (* 14 *)
  | Implicit_public_methods of string list  (* 15 *)
  | Unerasable_optional_argument            (* 16 *)
  | Undeclared_virtual_method of string     (* 17 *)
  | Not_principal of string                 (* 18 *)
  | Without_principality of string          (* 19 *)
  | Unused_argument                         (* 20 *)
  | Nonreturning_statement                  (* 21 *)
  | Preprocessor of string                  (* 22 *)
  | Useless_record_with                     (* 23 *)
  | Bad_module_name of string               (* 24 *)
  | All_clauses_guarded                     (* 8, used to be 25 *)
  | Unused_var of string                    (* 26 *)
  | Unused_var_strict of string             (* 27 *)
  | Wildcard_arg_to_constant_constr         (* 28 *)
  | Eol_in_string                           (* 29 *)
  | Duplicate_definitions of string * string * string * string (* 30 *)
  | Multiple_definition of string * string * string (* 31 *)
  | Unused_value_declaration of string      (* 32 *)
  | Unused_open of string                   (* 33 *)
  | Unused_type_declaration of string       (* 34 *)
  | Unused_for_index of string              (* 35 *)
  | Unused_ancestor of string               (* 36 *)
  | Unused_constructor of string * bool * bool (* 37 *)
  | Unused_extension of string * bool * bool * bool (* 38 *)
  | Unused_rec_flag                         (* 39 *)
  | Name_out_of_scope of string * string list * bool   (* 40 *)
  | Ambiguous_name of string list * string list * bool (* 41 *)
  | Disambiguated_name of string            (* 42 *)
  | Nonoptional_label of string             (* 43 *)
  | Open_shadow_identifier of string * string (* 44 *)
  | Open_shadow_label_constructor of string * string (* 45 *)
  | Bad_env_variable of string * string     (* 46 *)
  | Attribute_payload of string * string    (* 47 *)
  | Eliminated_optional_arguments of string list (* 48 *)
  | No_cmi_file of string * string option   (* 49 *)
  | Bad_docstring of bool                   (* 50 *)
  | Expect_tailcall                         (* 51 *)
  | Fragile_literal_pattern                 (* 52 *)
  | Misplaced_attribute of string           (* 53 *)
  | Duplicated_attribute of string          (* 54 *)
  | Inlining_impossible of string           (* 55 *)
  | Unreachable_case                        (* 56 *)
  | Ambiguous_pattern of string list        (* 57 *)
  | No_cmx_file of string                   (* 58 *)
  | Assignment_to_non_mutable_value         (* 59 *)
  | Unused_module of string                 (* 60 *)
  | Unboxable_type_in_prim_decl of string   (* 61 *)
  | Constraint_on_gadt                      (* 62 *)

  | Bs_unused_attribute of string           (* 101 *)
  | Bs_polymorphic_comparison               (* 102 *)
  | Bs_ffi_warning of string                (* 103 *)
  | Bs_derive_warning of string             (* 104 *)
  | Bs_fragile_external of string           (* 105 *)
        
;;

val parse_options : bool -> string -> unit;;

val without_warnings : (unit -> 'a) -> 'a

val is_active : t -> bool;;
val is_error : t -> bool;;

val defaults_w : string;;
val defaults_warn_error : string;;

type reporting_information =
  { number : int
  ; message : string
  ; is_error : bool
  ; sub_locs : (loc * string) list;
  }

val report : t -> [ `Active of reporting_information | `Inactive ]

exception Errors;;

val check_fatal : unit -> unit;;
val reset_fatal: unit -> unit

val help_warnings: unit -> unit

type state
val backup: unit -> state
val restore: state -> unit
val mk_lazy: (unit -> 'a) -> 'a Lazy.t
    (** Like [Lazy.of_fun], but the function is applied with
        the warning settings at the time [mk_lazy] is called. *)


val message : t -> string 
val number: t -> int
val super_report :
  (t -> string) ->
  t ->  [ `Active of reporting_information | `Inactive ]


end = struct
#1 "warnings.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Pierre Weis && Damien Doligez, INRIA Rocquencourt          *)
(*                                                                        *)
(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* When you change this, you need to update the documentation:
   - man/ocamlc.m
   - man/ocamlopt.m
   - manual/manual/cmds/comp.etex
   - manual/manual/cmds/native.etex
*)

type loc = {
  loc_start: Lexing.position;
  loc_end: Lexing.position;
  loc_ghost: bool;
}

type t =
  | Comment_start                           (*  1 *)
  | Comment_not_end                         (*  2 *)
  | Deprecated of string * loc * loc        (*  3 *)
  | Fragile_match of string                 (*  4 *)
  | Partial_application                     (*  5 *)
  | Labels_omitted of string list           (*  6 *)
  | Method_override of string list          (*  7 *)
  | Partial_match of string                 (*  8 *)
  | Non_closed_record_pattern of string     (*  9 *)
  | Statement_type                          (* 10 *)
  | Unused_match                            (* 11 *)
  | Unused_pat                              (* 12 *)
  | Instance_variable_override of string list (* 13 *)
  | Illegal_backslash                       (* 14 *)
  | Implicit_public_methods of string list  (* 15 *)
  | Unerasable_optional_argument            (* 16 *)
  | Undeclared_virtual_method of string     (* 17 *)
  | Not_principal of string                 (* 18 *)
  | Without_principality of string          (* 19 *)
  | Unused_argument                         (* 20 *)
  | Nonreturning_statement                  (* 21 *)
  | Preprocessor of string                  (* 22 *)
  | Useless_record_with                     (* 23 *)
  | Bad_module_name of string               (* 24 *)
  | All_clauses_guarded                     (* 8, used to be 25 *)
  | Unused_var of string                    (* 26 *)
  | Unused_var_strict of string             (* 27 *)
  | Wildcard_arg_to_constant_constr         (* 28 *)
  | Eol_in_string                           (* 29 *)
  | Duplicate_definitions of string * string * string * string (*30 *)
  | Multiple_definition of string * string * string (* 31 *)
  | Unused_value_declaration of string      (* 32 *)
  | Unused_open of string                   (* 33 *)
  | Unused_type_declaration of string       (* 34 *)
  | Unused_for_index of string              (* 35 *)
  | Unused_ancestor of string               (* 36 *)
  | Unused_constructor of string * bool * bool  (* 37 *)
  | Unused_extension of string * bool * bool * bool (* 38 *)
  | Unused_rec_flag                         (* 39 *)
  | Name_out_of_scope of string * string list * bool (* 40 *)
  | Ambiguous_name of string list * string list *  bool    (* 41 *)
  | Disambiguated_name of string            (* 42 *)
  | Nonoptional_label of string             (* 43 *)
  | Open_shadow_identifier of string * string (* 44 *)
  | Open_shadow_label_constructor of string * string (* 45 *)
  | Bad_env_variable of string * string     (* 46 *)
  | Attribute_payload of string * string    (* 47 *)
  | Eliminated_optional_arguments of string list (* 48 *)
  | No_cmi_file of string * string option   (* 49 *)
  | Bad_docstring of bool                   (* 50 *)
  | Expect_tailcall                         (* 51 *)
  | Fragile_literal_pattern                 (* 52 *)
  | Misplaced_attribute of string           (* 53 *)
  | Duplicated_attribute of string          (* 54 *)
  | Inlining_impossible of string           (* 55 *)
  | Unreachable_case                        (* 56 *)
  | Ambiguous_pattern of string list        (* 57 *)
  | No_cmx_file of string                   (* 58 *)
  | Assignment_to_non_mutable_value         (* 59 *)
  | Unused_module of string                 (* 60 *)
  | Unboxable_type_in_prim_decl of string   (* 61 *)
  | Constraint_on_gadt                      (* 62 *)
    
    
  | Bs_unused_attribute of string           (* 101 *)
  | Bs_polymorphic_comparison               (* 102 *)
  | Bs_ffi_warning of string                (* 103 *)
  | Bs_derive_warning of string             (* 104 *)
  | Bs_fragile_external of string           (* 105 *)
  
;;

(* If you remove a warning, leave a hole in the numbering.  NEVER change
   the numbers of existing warnings.
   If you add a new warning, add it at the end with a new number;
   do NOT reuse one of the holes.
*)

let number = function
  | Comment_start -> 1
  | Comment_not_end -> 2
  | Deprecated _ -> 3
  | Fragile_match _ -> 4
  | Partial_application -> 5
  | Labels_omitted _ -> 6
  | Method_override _ -> 7
  | Partial_match _ -> 8
  | Non_closed_record_pattern _ -> 9
  | Statement_type -> 10
  | Unused_match -> 11
  | Unused_pat -> 12
  | Instance_variable_override _ -> 13
  | Illegal_backslash -> 14
  | Implicit_public_methods _ -> 15
  | Unerasable_optional_argument -> 16
  | Undeclared_virtual_method _ -> 17
  | Not_principal _ -> 18
  | Without_principality _ -> 19
  | Unused_argument -> 20
  | Nonreturning_statement -> 21
  | Preprocessor _ -> 22
  | Useless_record_with -> 23
  | Bad_module_name _ -> 24
  | All_clauses_guarded -> 8 (* used to be 25 *)
  | Unused_var _ -> 26
  | Unused_var_strict _ -> 27
  | Wildcard_arg_to_constant_constr -> 28
  | Eol_in_string -> 29
  | Duplicate_definitions _ -> 30
  | Multiple_definition _ -> 31
  | Unused_value_declaration _ -> 32
  | Unused_open _ -> 33
  | Unused_type_declaration _ -> 34
  | Unused_for_index _ -> 35
  | Unused_ancestor _ -> 36
  | Unused_constructor _ -> 37
  | Unused_extension _ -> 38
  | Unused_rec_flag -> 39
  | Name_out_of_scope _ -> 40
  | Ambiguous_name _ -> 41
  | Disambiguated_name _ -> 42
  | Nonoptional_label _ -> 43
  | Open_shadow_identifier _ -> 44
  | Open_shadow_label_constructor _ -> 45
  | Bad_env_variable _ -> 46
  | Attribute_payload _ -> 47
  | Eliminated_optional_arguments _ -> 48
  | No_cmi_file _ -> 49
  | Bad_docstring _ -> 50
  | Expect_tailcall -> 51
  | Fragile_literal_pattern -> 52
  | Misplaced_attribute _ -> 53
  | Duplicated_attribute _ -> 54
  | Inlining_impossible _ -> 55
  | Unreachable_case -> 56
  | Ambiguous_pattern _ -> 57
  | No_cmx_file _ -> 58
  | Assignment_to_non_mutable_value -> 59
  | Unused_module _ -> 60
  | Unboxable_type_in_prim_decl _ -> 61
  | Constraint_on_gadt -> 62

    
  | Bs_unused_attribute _ -> 101
  | Bs_polymorphic_comparison -> 102
  | Bs_ffi_warning _ -> 103
  | Bs_derive_warning _ -> 104
  | Bs_fragile_external _ -> 105
  
;;

let last_warning_number = 105
let letter_all = 
  let rec loop i = if i = 0 then [] else i :: loop (i - 1) in
  loop last_warning_number

(* Must be the max number returned by the [number] function. *)

let letter = function
  | 'a' -> letter_all
  | 'b' -> []
  | 'c' -> [1; 2]
  | 'd' -> [3]
  | 'e' -> [4]
  | 'f' -> [5]
  | 'g' -> []
  | 'h' -> []
  | 'i' -> []
  | 'j' -> []
  | 'k' -> [32; 33; 34; 35; 36; 37; 38; 39]
  | 'l' -> [6]
  | 'm' -> [7]
  | 'n' -> []
  | 'o' -> []
  | 'p' -> [8]
  | 'q' -> []
  | 'r' -> [9]
  | 's' -> [10]
  | 't' -> []
  | 'u' -> [11; 12]
  | 'v' -> [13]
  | 'w' -> []
  | 'x' -> [14; 15; 16; 17; 18; 19; 20; 21; 22; 23; 24; 30]
  | 'y' -> [26]
  | 'z' -> [27]
  | _ -> assert false
;;

type state =
  {
    active: bool array;
    error: bool array;
  }

let current =
  ref
    {
      active = Array.make (last_warning_number + 1) true;
      error = Array.make (last_warning_number + 1) false;
    }

let disabled = ref false

let without_warnings f =
  Misc.protect_refs [Misc.R(disabled, true)] f

let backup () = !current

let restore x = current := x

let is_active x = not !disabled && (!current).active.(number x);;
let is_error x = not !disabled && (!current).error.(number x);;

let mk_lazy f =
  let state = backup () in
  lazy
    (
      let prev = backup () in
      restore state;
      try
        let r = f () in
        restore prev;
        r
      with exn ->
        restore prev;
        raise exn
    )

let parse_opt error active flags s =
  let set i = flags.(i) <- true in
  let clear i = flags.(i) <- false in
  let set_all i = active.(i) <- true; error.(i) <- true in
  let error () = raise (Arg.Bad "Ill-formed list of warnings") in
  let rec get_num n i =
    if i >= String.length s then i, n
    else match s.[i] with
    | '0'..'9' -> get_num (10 * n + Char.code s.[i] - Char.code '0') (i + 1)
    | _ -> i, n
  in
  let get_range i =
    let i, n1 = get_num 0 i in
    if i + 2 < String.length s && s.[i] = '.' && s.[i + 1] = '.' then
      let i, n2 = get_num 0 (i + 2) in
      if n2 < n1 then error ();
      i, n1, n2
    else
      i, n1, n1
  in
  let rec loop i =
    if i >= String.length s then () else
    match s.[i] with
    | 'A' .. 'Z' ->
       List.iter set (letter (Char.lowercase_ascii s.[i]));
       loop (i+1)
    | 'a' .. 'z' ->
       List.iter clear (letter s.[i]);
       loop (i+1)
    | '+' -> loop_letter_num set (i+1)
    | '-' -> loop_letter_num clear (i+1)
    | '@' -> loop_letter_num set_all (i+1)
    | _ -> error ()
  and loop_letter_num myset i =
    if i >= String.length s then error () else
    match s.[i] with
    | '0' .. '9' ->
        let i, n1, n2 = get_range i in
        for n = n1 to min n2 last_warning_number do myset n done;
        loop i
    | 'A' .. 'Z' ->
       List.iter myset (letter (Char.lowercase_ascii s.[i]));
       loop (i+1)
    | 'a' .. 'z' ->
       List.iter myset (letter s.[i]);
       loop (i+1)
    | _ -> error ()
  in
  loop 0
;;

let parse_options errflag s =
  let error = Array.copy (!current).error in
  let active = Array.copy (!current).active in
  parse_opt error active (if errflag then error else active) s;
  current := {error; active}

(* If you change these, don't forget to change them in man/ocamlc.m *)
let defaults_w = "+a-4-6-7-9-27-29-32..42-44-45-48-50-60-102";;
let defaults_warn_error = "-a+31";;

let () = parse_options false defaults_w;;
let () = parse_options true defaults_warn_error;;

let message = function
  | Comment_start -> "this is the start of a comment."
  | Comment_not_end -> "this is not the end of a comment."
  | Deprecated (s, _, _) ->
      (* Reduce \r\n to \n:
           - Prevents any \r characters being printed on Unix when processing
             Windows sources
           - Prevents \r\r\n being generated on Windows, which affects the
             testsuite
       *)
       "deprecated: " ^ Misc.normalise_eol s
  | Fragile_match "" ->
      "this pattern-matching is fragile."
  | Fragile_match s ->
      "this pattern-matching is fragile.\n\
       It will remain exhaustive when constructors are added to type " ^ s ^ "."
  | Partial_application ->
      "this function application is partial,\n\
       maybe some arguments are missing."
  | Labels_omitted [] -> assert false
  | Labels_omitted [l] ->
     "label " ^ l ^ " was omitted in the application of this function."
  | Labels_omitted ls ->
     "labels " ^ String.concat ", " ls ^
       " were omitted in the application of this function."
  | Method_override [lab] ->
      "the method " ^ lab ^ " is overridden."
  | Method_override (cname :: slist) ->
      String.concat " "
        ("the following methods are overridden by the class"
         :: cname  :: ":\n " :: slist)
  | Method_override [] -> assert false
  | Partial_match "" -> "this pattern-matching is not exhaustive."
  | Partial_match s ->
      "this pattern-matching is not exhaustive.\n\
       Here is an example of a case that is not matched:\n" ^ s
  | Non_closed_record_pattern s ->
      "the following labels are not bound in this record pattern:\n" ^ s ^
      "\nEither bind these labels explicitly or add '; _' to the pattern."
  | Statement_type ->
      "this expression should have type unit."
  | Unused_match -> "this match case is unused."
  | Unused_pat   -> "this sub-pattern is unused."
  | Instance_variable_override [lab] ->
      "the instance variable " ^ lab ^ " is overridden.\n" ^
      "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)"
  | Instance_variable_override (cname :: slist) ->
      String.concat " "
        ("the following instance variables are overridden by the class"
         :: cname  :: ":\n " :: slist) ^
      "\nThe behaviour changed in ocaml 3.10 (previous behaviour was hiding.)"
  | Instance_variable_override [] -> assert false
  | Illegal_backslash -> "illegal backslash escape in string."
  | Implicit_public_methods l ->
      "the following private methods were made public implicitly:\n "
      ^ String.concat " " l ^ "."
  | Unerasable_optional_argument -> "this optional argument cannot be erased."
  | Undeclared_virtual_method m -> "the virtual method "^m^" is not declared."
  | Not_principal s -> s^" is not principal."
  | Without_principality s -> s^" without principality."
  | Unused_argument -> "this argument will not be used by the function."
  | Nonreturning_statement ->
      "this statement never returns (or has an unsound type.)"
  | Preprocessor s -> s
  | Useless_record_with ->
      "all the fields are explicitly listed in this record:\n\
       the 'with' clause is useless."
  | Bad_module_name (modname) ->
      "bad source file name: \"" ^ modname ^ "\" is not a valid module name."
  | All_clauses_guarded ->
      "this pattern-matching is not exhaustive.\n\
       All clauses in this pattern-matching are guarded."
  | Unused_var v | Unused_var_strict v -> "unused variable " ^ v ^ "."
  | Wildcard_arg_to_constant_constr ->
     "wildcard pattern given as argument to a constant constructor"
  | Eol_in_string ->
     "unescaped end-of-line in a string constant (non-portable code)"
  | Duplicate_definitions (kind, cname, tc1, tc2) ->
      Printf.sprintf "the %s %s is defined in both types %s and %s."
        kind cname tc1 tc2
  | Multiple_definition(modname, file1, file2) ->
      Printf.sprintf
        "files %s and %s both define a module named %s"
        file1 file2 modname
  | Unused_value_declaration v -> "unused value " ^ v ^ "."
  | Unused_open s -> "unused open " ^ s ^ "."
  | Unused_type_declaration s -> "unused type " ^ s ^ "."
  | Unused_for_index s -> "unused for-loop index " ^ s ^ "."
  | Unused_ancestor s -> "unused ancestor variable " ^ s ^ "."
  | Unused_constructor (s, false, false) -> "unused constructor " ^ s ^ "."
  | Unused_constructor (s, true, _) ->
      "constructor " ^ s ^
      " is never used to build values.\n\
        (However, this constructor appears in patterns.)"
  | Unused_constructor (s, false, true) ->
      "constructor " ^ s ^
      " is never used to build values.\n\
        Its type is exported as a private type."
  | Unused_extension (s, is_exception, cu_pattern, cu_privatize) ->
     let kind =
       if is_exception then "exception" else "extension constructor" in
     let name = kind ^ " " ^ s in
     begin match cu_pattern, cu_privatize with
       | false, false -> "unused " ^ name
       | true, _ ->
          name ^
          " is never used to build values.\n\
           (However, this constructor appears in patterns.)"
       | false, true ->
          name ^
          " is never used to build values.\n\
            It is exported or rebound as a private extension."
     end
  | Unused_rec_flag ->
      "unused rec flag."
  | Name_out_of_scope (ty, [nm], false) ->
      nm ^ " was selected from type " ^ ty ^
      ".\nIt is not visible in the current scope, and will not \n\
       be selected if the type becomes unknown."
  | Name_out_of_scope (_, _, false) -> assert false
  | Name_out_of_scope (ty, slist, true) ->
      "this record of type "^ ty ^" contains fields that are \n\
       not visible in the current scope: "
      ^ String.concat " " slist ^ ".\n\
       They will not be selected if the type becomes unknown."
  | Ambiguous_name ([s], tl, false) ->
      s ^ " belongs to several types: " ^ String.concat " " tl ^
      "\nThe first one was selected. Please disambiguate if this is wrong."
  | Ambiguous_name (_, _, false) -> assert false
  | Ambiguous_name (_slist, tl, true) ->
      "these field labels belong to several types: " ^
      String.concat " " tl ^
      "\nThe first one was selected. Please disambiguate if this is wrong."
  | Disambiguated_name s ->
      "this use of " ^ s ^ " relies on type-directed disambiguation,\n\
       it will not compile with OCaml 4.00 or earlier."
  | Nonoptional_label s ->
      "the label " ^ s ^ " is not optional."
  | Open_shadow_identifier (kind, s) ->
      Printf.sprintf
        "this open statement shadows the %s identifier %s (which is later used)"
        kind s
  | Open_shadow_label_constructor (kind, s) ->
      Printf.sprintf
        "this open statement shadows the %s %s (which is later used)"
        kind s
  | Bad_env_variable (var, s) ->
      Printf.sprintf "illegal environment variable %s : %s" var s
  | Attribute_payload (a, s) ->
      Printf.sprintf "illegal payload for attribute '%s'.\n%s" a s
  | Eliminated_optional_arguments sl ->
      Printf.sprintf "implicit elimination of optional argument%s %s"
        (if List.length sl = 1 then "" else "s")
        (String.concat ", " sl)
  | No_cmi_file(name, None) ->
      "no cmi file was found in path for module " ^ name
  | No_cmi_file(name, Some msg) ->
      Printf.sprintf
        "no valid cmi file was found in path for module %s. %s"
        name msg
  | Bad_docstring unattached ->
      if unattached then "unattached documentation comment (ignored)"
      else "ambiguous documentation comment"
  | Expect_tailcall ->
      Printf.sprintf "expected tailcall"
  | Fragile_literal_pattern ->
      Printf.sprintf
        "Code should not depend on the actual values of\n\
         this constructor's arguments. They are only for information\n\
         and may change in future versions. (See manual section 8.5)"
  | Unreachable_case ->
      "this match case is unreachable.\n\
       Consider replacing it with a refutation case '<pat> -> .'"
  | Misplaced_attribute attr_name ->
      Printf.sprintf "the %S attribute cannot appear in this context" attr_name
  | Duplicated_attribute attr_name ->
      Printf.sprintf "the %S attribute is used more than once on this \
          expression"
        attr_name
  | Inlining_impossible reason ->
      Printf.sprintf "Cannot inline: %s" reason
  | Ambiguous_pattern vars ->
      let msg =
        let vars = List.sort String.compare vars in
        match vars with
        | [] -> assert false
        | [x] -> "variable " ^ x
        | _::_ ->
            "variables " ^ String.concat "," vars in
      Printf.sprintf
        "Ambiguous or-pattern variables under guard;\n\
         %s may match different arguments. (See manual section 8.5)"
        msg
  | No_cmx_file name ->
      Printf.sprintf
        "no cmx file was found in path for module %s, \
         and its interface was not compiled with -opaque" name
  | Assignment_to_non_mutable_value ->
      "A potential assignment to a non-mutable value was detected \n\
        in this source file.  Such assignments may generate incorrect code \n\
        when using Flambda."
  | Unused_module s -> "unused module " ^ s ^ "."
  | Unboxable_type_in_prim_decl t ->
      Printf.sprintf
        "This primitive declaration uses type %s, which is unannotated and\n\
         unboxable. The representation of such types may change in future\n\
         versions. You should annotate the declaration of %s with [@@boxed]\n\
         or [@@unboxed]." t t
  | Constraint_on_gadt ->
      "Type constraints do not apply to GADT cases of variant types."


  | Bs_unused_attribute s ->
      "Unused BuckleScript attribute: " ^ s
  | Bs_polymorphic_comparison ->
      "polymorphic comparison introduced (maybe unsafe)"
  | Bs_ffi_warning s ->
      "BuckleScript FFI warning: " ^ s
  | Bs_derive_warning s ->
      "BuckleScript bs.deriving warning: " ^ s 
  | Bs_fragile_external s ->     
      "BuckleScript warning: " ^ s ^" : the external name is inferred from val name is unsafe from refactoring when changing value name"
      
;;

let sub_locs = function
  | Deprecated (_, def, use) ->
      [
        def, "Definition";
        use, "Expected signature";
      ]
  | _ -> []

let nerrors = ref 0;;

type reporting_information =
  { number : int
  ; message : string
  ; is_error : bool
  ; sub_locs : (loc * string) list;
  }

let report w =
  match is_active w with
  | false -> `Inactive
  | true ->
     if is_error w then incr nerrors;
     `Active { number = number w; message = message w; is_error = is_error w;
               sub_locs = sub_locs w;
             }
;;


let super_report message w =
  match is_active w with
  | false -> `Inactive
  | true ->
     if is_error w then incr nerrors;
     `Active { number = number w; message = message w; is_error = is_error w;
               sub_locs = sub_locs w;
             }
;;    

exception Errors;;

let reset_fatal () =
  nerrors := 0

let check_fatal () =
  if !nerrors > 0 then begin
    nerrors := 0;
    raise Errors;
  end;
;;

let descriptions =
  [
    1, "Suspicious-looking start-of-comment mark.";
    2, "Suspicious-looking end-of-comment mark.";
    3, "Deprecated feature.";
    4, "Fragile pattern matching: matching that will remain complete even\n\
   \    if additional constructors are added to one of the variant types\n\
   \    matched.";
    5, "Partially applied function: expression whose result has function\n\
   \    type and is ignored.";
    6, "Label omitted in function application.";
    7, "Method overridden.";
    8, "Partial match: missing cases in pattern-matching.";
    9, "Missing fields in a record pattern.";
   10, "Expression on the left-hand side of a sequence that doesn't have \
      type\n\
   \    \"unit\" (and that is not a function, see warning number 5).";
   11, "Redundant case in a pattern matching (unused match case).";
   12, "Redundant sub-pattern in a pattern-matching.";
   13, "Instance variable overridden.";
   14, "Illegal backslash escape in a string constant.";
   15, "Private method made public implicitly.";
   16, "Unerasable optional argument.";
   17, "Undeclared virtual method.";
   18, "Non-principal type.";
   19, "Type without principality.";
   20, "Unused function argument.";
   21, "Non-returning statement.";
   22, "Preprocessor warning.";
   23, "Useless record \"with\" clause.";
   24, "Bad module name: the source file name is not a valid OCaml module \
        name.";
   25, "Deprecated: now part of warning 8.";
   26, "Suspicious unused variable: unused variable that is bound\n\
   \    with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\
   \    character.";
   27, "Innocuous unused variable: unused variable that is not bound with\n\
   \    \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\
   \    character.";
   28, "Wildcard pattern given as argument to a constant constructor.";
   29, "Unescaped end-of-line in a string constant (non-portable code).";
   30, "Two labels or constructors of the same name are defined in two\n\
   \    mutually recursive types.";
   31, "A module is linked twice in the same executable.";
   32, "Unused value declaration.";
   33, "Unused open statement.";
   34, "Unused type declaration.";
   35, "Unused for-loop index.";
   36, "Unused ancestor variable.";
   37, "Unused constructor.";
   38, "Unused extension constructor.";
   39, "Unused rec flag.";
   40, "Constructor or label name used out of scope.";
   41, "Ambiguous constructor or label name.";
   42, "Disambiguated constructor or label name (compatibility warning).";
   43, "Nonoptional label applied as optional.";
   44, "Open statement shadows an already defined identifier.";
   45, "Open statement shadows an already defined label or constructor.";
   46, "Error in environment variable.";
   47, "Illegal attribute payload.";
   48, "Implicit elimination of optional arguments.";
   49, "Absent cmi file when looking up module alias.";
   50, "Unexpected documentation comment.";
   51, "Warning on non-tail calls if @tailcall present.";
   52, "Fragile constant pattern.";
   53, "Attribute cannot appear in this context";
   54, "Attribute used more than once on an expression";
   55, "Inlining impossible";
   56, "Unreachable case in a pattern-matching (based on type information).";
   57, "Ambiguous or-pattern variables under guard";
   58, "Missing cmx file";
   59, "Assignment to non-mutable value";
   60, "Unused module declaration";
   61, "Unboxable type in primitive declaration";
   62, "Type constraint on GADT type declaration";
    
    
   101, "Unused bs attributes";
   102, "polymorphic comparison introduced (maybe unsafe)";
   103, "BuckleScript FFI warning: " ;
   104, "BuckleScript bs.deriving warning: "
   
  ]
;;

let help_warnings () =
  List.iter (fun (i, s) -> Printf.printf "%3i %s\n" i s) descriptions;
  print_endline "  A all warnings";
  for i = Char.code 'b' to Char.code 'z' do
    let c = Char.chr i in
    match letter c with
    | [] -> ()
    | [n] ->
        Printf.printf "  %c Alias for warning %i.\n" (Char.uppercase_ascii c) n
    | l ->
        Printf.printf "  %c warnings %s.\n"
          (Char.uppercase_ascii c)
          (String.concat ", " (List.map string_of_int l))
  done;
  exit 0
;;

end
module Location : sig 
#1 "location.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Source code locations (ranges of positions), used in parsetree. *)

open Format

type t = Warnings.loc = {
  loc_start: Lexing.position;
  loc_end: Lexing.position;
  loc_ghost: bool;
}

(** Note on the use of Lexing.position in this module.
   If [pos_fname = ""], then use [!input_name] instead.
   If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and
     re-parse the file to get the line and character numbers.
   Else all fields are correct.
*)

val none : t
(** An arbitrary value of type [t]; describes an empty ghost range. *)

val in_file : string -> t
(** Return an empty ghost range located in a given file. *)

val init : Lexing.lexbuf -> string -> unit
(** Set the file name and line number of the [lexbuf] to be the start
    of the named file. *)

val curr : Lexing.lexbuf -> t
(** Get the location of the current token from the [lexbuf]. *)

val symbol_rloc: unit -> t
val symbol_gloc: unit -> t

(** [rhs_loc n] returns the location of the symbol at position [n], starting
  at 1, in the current parser rule. *)
val rhs_loc: int -> t

val input_name: string ref
val input_lexbuf: Lexing.lexbuf option ref

val get_pos_info: Lexing.position -> string * int * int (* file, line, char *)
val print_loc: formatter -> t -> unit
val print_error: formatter -> t -> unit
val print_error_cur_file: formatter -> unit -> unit
val print_warning: t -> formatter -> Warnings.t -> unit
val formatter_for_warnings : formatter ref
val prerr_warning: t -> Warnings.t -> unit
val echo_eof: unit -> unit
val reset: unit -> unit

val default_printer : formatter -> t -> unit
val printer : (formatter -> t -> unit) ref

val warning_printer : (t -> formatter -> Warnings.t -> unit) ref
(** Hook for intercepting warnings. *)

val default_warning_printer : t -> formatter -> Warnings.t -> unit
(** Original warning printer for use in hooks. *)

val highlight_locations: formatter -> t list -> bool

type 'a loc = {
  txt : 'a;
  loc : t;
}

val mknoloc : 'a -> 'a loc
val mkloc : 'a -> t -> 'a loc

val print: formatter -> t -> unit
val print_compact: formatter -> t -> unit
val print_filename: formatter -> string -> unit

val absolute_path: string -> string

val show_filename: string -> string
    (** In -absname mode, return the absolute path for this filename.
        Otherwise, returns the filename unchanged. *)


val absname: bool ref

(** Support for located errors *)

type error =
  {
    loc: t;
    msg: string;
    sub: error list;
    if_highlight: string; (* alternative message if locations are highlighted *)
  }

exception Already_displayed_error
exception Error of error

val error: ?loc:t -> ?sub:error list -> ?if_highlight:string -> string -> error


val print_error_prefix : Format.formatter -> unit
val pp_ksprintf : ?before:(formatter -> unit) -> (string -> 'a) -> ('b, formatter, unit, 'a) format4 -> 'b


val errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string
            -> ('a, Format.formatter, unit, error) format4 -> 'a

val raise_errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string
            -> ('a, Format.formatter, unit, 'b) format4 -> 'a

val error_of_printer: t -> (formatter -> 'a -> unit) -> 'a -> error

val error_of_printer_file: (formatter -> 'a -> unit) -> 'a -> error

val error_of_exn: exn -> [ `Ok of error | `Already_displayed ] option

val register_error_of_exn: (exn -> error option) -> unit
(** Each compiler module which defines a custom type of exception
    which can surface as a user-visible error should register
    a "printer" for this exception using [register_error_of_exn].
    The result of the printer is an [error] value containing
    a location, a message, and optionally sub-messages (each of them
    being located as well). *)

val report_error: formatter -> error -> unit

val error_reporter : (formatter -> error -> unit) ref
(** Hook for intercepting error reports. *)

val default_error_reporter : formatter -> error -> unit
(** Original error reporter for use in hooks. *)

val report_exception: formatter -> exn -> unit
(** Reraise the exception if it is unknown. *)

val deprecated: ?def:t -> ?use:t -> t -> string -> unit

end = struct
#1 "location.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Lexing

let absname = ref false
    (* This reference should be in Clflags, but it would create an additional
       dependency and make bootstrapping Camlp4 more difficult. *)

type t = Warnings.loc = { loc_start: position; loc_end: position; loc_ghost: bool };;

let in_file name =
  let loc = {
    pos_fname = name;
    pos_lnum = 1;
    pos_bol = 0;
    pos_cnum = -1;
  } in
  { loc_start = loc; loc_end = loc; loc_ghost = true }
;;

let none = in_file "_none_";;

let curr lexbuf = {
  loc_start = lexbuf.lex_start_p;
  loc_end = lexbuf.lex_curr_p;
  loc_ghost = false
};;

let init lexbuf fname =
  lexbuf.lex_curr_p <- {
    pos_fname = fname;
    pos_lnum = 1;
    pos_bol = 0;
    pos_cnum = 0;
  }
;;

let symbol_rloc () = {
  loc_start = Parsing.symbol_start_pos ();
  loc_end = Parsing.symbol_end_pos ();
  loc_ghost = false;
};;

let symbol_gloc () = {
  loc_start = Parsing.symbol_start_pos ();
  loc_end = Parsing.symbol_end_pos ();
  loc_ghost = true;
};;

let rhs_loc n = {
  loc_start = Parsing.rhs_start_pos n;
  loc_end = Parsing.rhs_end_pos n;
  loc_ghost = false;
};;

let input_name = ref "_none_"
let input_lexbuf = ref (None : lexbuf option)

(* Terminal info *)

let status = ref Terminfo.Uninitialised

let num_loc_lines = ref 0 (* number of lines already printed after input *)

let print_updating_num_loc_lines ppf f arg =
  let open Format in
  let out_functions = pp_get_formatter_out_functions ppf () in
  let out_string str start len =
    let rec count i c =
      if i = start + len then c
      else if String.get str i = '\n' then count (succ i) (succ c)
      else count (succ i) c in
    num_loc_lines := !num_loc_lines + count start 0 ;
    out_functions.out_string str start len in
  pp_set_formatter_out_functions ppf
    { out_functions with out_string } ;
  f ppf arg ;
  pp_print_flush ppf ();
  pp_set_formatter_out_functions ppf out_functions

(* Highlight the locations using standout mode. *)

let highlight_terminfo ppf num_lines lb locs =
  Format.pp_print_flush ppf ();  (* avoid mixing Format and normal output *)
  (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
  let pos0 = -lb.lex_abs_pos in
  (* Do nothing if the buffer does not contain the whole phrase. *)
  if pos0 < 0 then raise Exit;
  (* Count number of lines in phrase *)
  let lines = ref !num_loc_lines in
  for i = pos0 to lb.lex_buffer_len - 1 do
    if Bytes.get lb.lex_buffer i = '\n' then incr lines
  done;
  (* If too many lines, give up *)
  if !lines >= num_lines - 2 then raise Exit;
  (* Move cursor up that number of lines *)
  flush stdout; Terminfo.backup !lines;
  (* Print the input, switching to standout for the location *)
  let bol = ref false in
  print_string "# ";
  for pos = 0 to lb.lex_buffer_len - pos0 - 1 do
    if !bol then (print_string "  "; bol := false);
    if List.exists (fun loc -> pos = loc.loc_start.pos_cnum) locs then
      Terminfo.standout true;
    if List.exists (fun loc -> pos = loc.loc_end.pos_cnum) locs then
      Terminfo.standout false;
    let c = Bytes.get lb.lex_buffer (pos + pos0) in
    print_char c;
    bol := (c = '\n')
  done;
  (* Make sure standout mode is over *)
  Terminfo.standout false;
  (* Position cursor back to original location *)
  Terminfo.resume !num_loc_lines;
  flush stdout

(* Highlight the location by printing it again. *)

let highlight_dumb ppf lb loc =
  (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
  let pos0 = -lb.lex_abs_pos in
  (* Do nothing if the buffer does not contain the whole phrase. *)
  if pos0 < 0 then raise Exit;
  let end_pos = lb.lex_buffer_len - pos0 - 1 in
  (* Determine line numbers for the start and end points *)
  let line_start = ref 0 and line_end = ref 0 in
  for pos = 0 to end_pos do
    if Bytes.get lb.lex_buffer (pos + pos0) = '\n' then begin
      if loc.loc_start.pos_cnum > pos then incr line_start;
      if loc.loc_end.pos_cnum   > pos then incr line_end;
    end
  done;
  (* Print character location (useful for Emacs) *)
  Format.fprintf ppf "@[<v>Characters %i-%i:@,"
                 loc.loc_start.pos_cnum loc.loc_end.pos_cnum;
  (* Print the input, underlining the location *)
  Format.pp_print_string ppf "  ";
  let line = ref 0 in
  let pos_at_bol = ref 0 in
  for pos = 0 to end_pos do
    match Bytes.get lb.lex_buffer (pos + pos0) with
    | '\n' ->
      if !line = !line_start && !line = !line_end then begin
        (* loc is on one line: underline location *)
        Format.fprintf ppf "@,  ";
        for _i = !pos_at_bol to loc.loc_start.pos_cnum - 1 do
          Format.pp_print_char ppf ' '
        done;
        for _i = loc.loc_start.pos_cnum to loc.loc_end.pos_cnum - 1 do
          Format.pp_print_char ppf '^'
        done
      end;
      if !line >= !line_start && !line <= !line_end then begin
        Format.fprintf ppf "@,";
        if pos < loc.loc_end.pos_cnum then Format.pp_print_string ppf "  "
      end;
      incr line;
      pos_at_bol := pos + 1
    | '\r' -> () (* discard *)
    | c ->
      if !line = !line_start && !line = !line_end then
        (* loc is on one line: print whole line *)
        Format.pp_print_char ppf c
      else if !line = !line_start then
        (* first line of multiline loc:
           print a dot for each char before loc_start *)
        if pos < loc.loc_start.pos_cnum then
          Format.pp_print_char ppf '.'
        else
          Format.pp_print_char ppf c
      else if !line = !line_end then
        (* last line of multiline loc: print a dot for each char
           after loc_end, even whitespaces *)
        if pos < loc.loc_end.pos_cnum then
          Format.pp_print_char ppf c
        else
          Format.pp_print_char ppf '.'
      else if !line > !line_start && !line < !line_end then
        (* intermediate line of multiline loc: print whole line *)
        Format.pp_print_char ppf c
  done;
  Format.fprintf ppf "@]"

(* Highlight the location using one of the supported modes. *)

let rec highlight_locations ppf locs =
  match !status with
    Terminfo.Uninitialised ->
      status := Terminfo.setup stdout; highlight_locations ppf locs
  | Terminfo.Bad_term ->
      begin match !input_lexbuf with
        None -> false
      | Some lb ->
          let norepeat =
            try Sys.getenv "TERM" = "norepeat" with Not_found -> false in
          if norepeat then false else
            let loc1 = List.hd locs in
            try highlight_dumb ppf lb loc1; true
            with Exit -> false
      end
  | Terminfo.Good_term num_lines ->
      begin match !input_lexbuf with
        None -> false
      | Some lb ->
          try highlight_terminfo ppf num_lines lb locs; true
          with Exit -> false
      end

(* Print the location in some way or another *)

open Format

let absolute_path s = (* This function could go into Filename *)
  let open Filename in
  let s = if is_relative s then concat (Sys.getcwd ()) s else s in
  (* Now simplify . and .. components *)
  let rec aux s =
    let base = basename s in
    let dir = dirname s in
    if dir = s then dir
    else if base = current_dir_name then aux dir
    else if base = parent_dir_name then dirname (aux dir)
    else concat (aux dir) base
  in
  aux s

let show_filename file =
  if !absname then absolute_path file else file

let print_filename ppf file =
  Format.fprintf ppf "%s" (show_filename file)

let reset () =
  num_loc_lines := 0

let (msg_file, msg_line, msg_chars, msg_to, msg_colon) =
  ("File \"", "\", line ", ", characters ", "-", ":")

(* return file, line, char from the given position *)
let get_pos_info pos =
  (pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol)
;;

let setup_colors () =
  Misc.Color.setup !Clflags.color

let print_loc ppf loc =
  setup_colors ();
  let (file, line, startchar) = get_pos_info loc.loc_start in
 
  let startchar = 
    if Clflags.bs_vscode then startchar + 1 else startchar in 
      
  let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in
  if file = "//toplevel//" then begin
    if highlight_locations ppf [loc] then () else
      fprintf ppf "Characters %i-%i"
              loc.loc_start.pos_cnum loc.loc_end.pos_cnum
  end else begin
    fprintf ppf "%s@{<loc>%a%s%i" msg_file print_filename file msg_line line;
    if startchar >= 0 then
      fprintf ppf "%s%i%s%i" msg_chars startchar msg_to endchar;
    fprintf ppf "@}"
  end
;;

let default_printer ppf loc =
  setup_colors ();
  if loc.loc_start.pos_fname = "//toplevel//"
  && highlight_locations ppf [loc] then ()
  else fprintf ppf "@{<loc>%a@}%s@," print_loc loc msg_colon
;;

let printer = ref default_printer
let print ppf loc = !printer ppf loc

let error_prefix = "Error"
let warning_prefix = "Warning"

let print_error_prefix ppf =
  setup_colors ();
  fprintf ppf "@{<error>%s@}" error_prefix;
;;

let print_compact ppf loc =
  if loc.loc_start.pos_fname = "//toplevel//"
  && highlight_locations ppf [loc] then ()
  else begin
    let (file, line, startchar) = get_pos_info loc.loc_start in
    let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in
    fprintf ppf "%a:%i" print_filename file line;
    if startchar >= 0 then fprintf ppf ",%i--%i" startchar endchar
  end
;;

let print_error ppf loc =
  fprintf ppf "%a%t:" print loc print_error_prefix;
;;

let print_error_cur_file ppf () = print_error ppf (in_file !input_name);;

let default_warning_printer loc ppf w =
  match Warnings.report w with
  | `Inactive -> ()
  | `Active { Warnings. number; message; is_error; sub_locs } ->
    setup_colors ();
    fprintf ppf "@[<v>";
    print ppf loc;
    if is_error
    then
      fprintf ppf "%t (%s %d): %s@," print_error_prefix
           (String.uncapitalize_ascii warning_prefix) number message
    else fprintf ppf "@{<warning>%s@} %d: %s@," warning_prefix number message;
    List.iter
      (fun (loc, msg) ->
         if loc <> none then fprintf ppf "  %a  %s@," print loc msg
      )
      sub_locs;
    fprintf ppf "@]"
;;

let warning_printer = ref default_warning_printer ;;

let print_warning loc ppf w =
  print_updating_num_loc_lines ppf (!warning_printer loc) w
;;

let formatter_for_warnings = ref err_formatter;;
let prerr_warning loc w = 
    if not !Clflags.bs_quiet then
      print_warning loc !formatter_for_warnings w;;

let echo_eof () =
  print_newline ();
  incr num_loc_lines

type 'a loc = {
  txt : 'a;
  loc : t;
}

let mkloc txt loc = { txt ; loc }
let mknoloc txt = mkloc txt none


type error =
  {
    loc: t;
    msg: string;
    sub: error list;
    if_highlight: string; (* alternative message if locations are highlighted *)
  }

let pp_ksprintf ?before k fmt =
  let buf = Buffer.create 64 in
  let ppf = Format.formatter_of_buffer buf in
  Misc.Color.set_color_tag_handling ppf;
  begin match before with
    | None -> ()
    | Some f -> f ppf
  end;
  kfprintf
    (fun _ ->
      pp_print_flush ppf ();
      let msg = Buffer.contents buf in
      k msg)
    ppf fmt

(* Shift the formatter's offset by the length of the error prefix, which
   is always added by the compiler after the message has been formatted *)
let print_phanton_error_prefix ppf =
  Format.pp_print_as ppf (String.length error_prefix + 2 (* ": " *)) ""

let errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") fmt =
  pp_ksprintf
    ~before:print_phanton_error_prefix
    (fun msg -> {loc; msg; sub; if_highlight})
    fmt

let error ?(loc = none) ?(sub = []) ?(if_highlight = "") msg =
  {loc; msg; sub; if_highlight}

let error_of_exn : (exn -> error option) list ref = ref []

let register_error_of_exn f = error_of_exn := f :: !error_of_exn

exception Already_displayed_error = Warnings.Errors

let error_of_exn exn =
  match exn with
  | Already_displayed_error -> Some `Already_displayed
  | _ ->
     let rec loop = function
       | [] -> None
       | f :: rest ->
          match f exn with
          | Some error -> Some (`Ok error)
          | None -> loop rest
     in
     loop !error_of_exn

let rec default_error_reporter ppf ({loc; msg; sub; if_highlight} as err) =
  let highlighted =
    if if_highlight <> "" && loc.loc_start.pos_fname = "//toplevel//" then
      let rec collect_locs locs {loc; sub; _} =
        List.fold_left collect_locs (loc :: locs) sub
      in
      let locs = collect_locs [] err in
      highlight_locations ppf locs
    else
      false
  in
  if highlighted then
    Format.pp_print_string ppf if_highlight
  else begin
    fprintf ppf "@[<v>%a %s" print_error loc msg;
    List.iter (Format.fprintf ppf "@,@[<2>%a@]" default_error_reporter) sub;
    fprintf ppf "@]"
  end

let error_reporter = ref default_error_reporter

let report_error ppf err =
  print_updating_num_loc_lines ppf !error_reporter err
;;

let error_of_printer loc print x =
  errorf ~loc "%a@?" print x

let error_of_printer_file print x =
  error_of_printer (in_file !input_name) print x

let () =
  register_error_of_exn
    (function
      | Sys_error msg ->
          Some (errorf ~loc:(in_file !input_name)
                "I/O error: %s" msg)

      | Misc.HookExnWrapper {error = e; hook_name;
                             hook_info={Misc.sourcefile}} ->
          let sub = match error_of_exn e with
            | None | Some `Already_displayed -> error (Printexc.to_string e)
            | Some (`Ok err) -> err
          in
          Some
            (errorf ~loc:(in_file sourcefile)
               "In hook %S:" hook_name
               ~sub:[sub])
      | _ -> None
    )

external reraise : exn -> 'a = "%reraise"

let rec report_exception_rec n ppf exn =
  try
    match error_of_exn exn with
    | None -> reraise exn
    | Some `Already_displayed -> ()
    | Some (`Ok err) -> fprintf ppf "@[%a@]@." report_error err
  with exn when n > 0 -> report_exception_rec (n-1) ppf exn

let report_exception ppf exn = report_exception_rec 5 ppf exn


exception Error of error

let () =
  register_error_of_exn
    (function
      | Error e -> Some e
      | _ -> None
    )

let raise_errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") =
  pp_ksprintf
    ~before:print_phanton_error_prefix
    (fun msg -> raise (Error ({loc; msg; sub; if_highlight})))

let deprecated ?(def = none) ?(use = none) loc msg =
  prerr_warning loc (Warnings.Deprecated (msg, def, use))

end
module Js_config : sig 
#1 "js_config.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)





(* val get_packages_info :
   unit -> Js_packages_info.t *)


(** set/get header *)
val no_version_header : bool ref 


(** return [package_name] and [path] 
    when in script mode: 
*)

(* val get_current_package_name_and_path : 
  Js_packages_info.module_system -> 
  Js_packages_info.info_query *)


(* val set_package_name : string -> unit  
val get_package_name : unit -> string option *)

(** cross module inline option *)
val cross_module_inline : bool ref
val set_cross_module_inline : bool -> unit
val get_cross_module_inline : unit -> bool
  
(** diagnose option *)
val diagnose : bool ref 
val get_diagnose : unit -> bool 
val set_diagnose : bool -> unit 


(** options for builtin ppx *)
val no_builtin_ppx_ml : bool ref 
val no_builtin_ppx_mli : bool ref 



val no_warn_unimplemented_external : bool ref 

(** check-div-by-zero option *)
val check_div_by_zero : bool ref 
val get_check_div_by_zero : unit -> bool 








val set_debug_file : string -> unit


val is_same_file : unit -> bool 

val tool_name : string


val sort_imports : bool ref 

val syntax_only  : bool ref
val binary_ast : bool ref


val bs_suffix : bool ref
val debug : bool ref

val cmi_only  : bool ref
val force_cmi : bool ref 
val force_cmj : bool ref

val jsx_version : int ref
val refmt : string option ref
val is_reason : bool ref 
end = struct
#1 "js_config.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






(* let add_npm_package_path s =
  match !packages_info  with
  | Empty ->
    Ext_arg.bad_argf "please set package name first using -bs-package-name ";
  | NonBrowser(name,  envs) ->
    let env, path =
      match Ext_string.split ~keep_empty:false s ':' with
      | [ package_name; path]  ->
        (match Js_packages_info.module_system_of_string package_name with
         | Some x -> x
         | None ->
           Ext_arg.bad_argf "invalid module system %s" package_name), path
      | [path] ->
        NodeJS, path
      | _ ->
        Ext_arg.bad_argf "invalid npm package path: %s" s
    in
    packages_info := NonBrowser (name,  ((env,path) :: envs)) *)
(** Browser is not set via command line only for internal use *)


let no_version_header = ref false

let cross_module_inline = ref false

let get_cross_module_inline () = !cross_module_inline
let set_cross_module_inline b =
  cross_module_inline := b


let diagnose = ref false
let get_diagnose () = !diagnose
let set_diagnose b = diagnose := b

let (//) = Filename.concat

(* let get_packages_info () = !packages_info *)

let no_builtin_ppx_ml = ref false
let no_builtin_ppx_mli = ref false


(** TODO: will flip the option when it is ready *)
let no_warn_unimplemented_external = ref false 

let debug_file = ref ""


let set_debug_file  f = debug_file := f

let is_same_file () =
  !debug_file <> "" &&  !debug_file = !Location.input_name

let tool_name = "BuckleScript"

let check_div_by_zero = ref true
let get_check_div_by_zero () = !check_div_by_zero




let sort_imports = ref true

let syntax_only = ref false
let binary_ast = ref false

let bs_suffix = ref false 

let debug = ref false

let cmi_only = ref false  
let force_cmi = ref false
let force_cmj = ref false

let jsx_version = ref (-1)

let refmt = ref None

let is_reason = ref false
end
module Ast_reason_pp : sig 
#1 "ast_reason_pp.mli"
(* Copyright (C) 2019- Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


exception Pp_error

val pp : 
  string -> 
  string
end = struct
#1 "ast_reason_pp.ml"
(* Copyright (C) 2019- Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



exception Pp_error
(* Sync up with {!Pparse.preprocess} 
  The generated file should not sit 
  in the same directory as sourctree
*)
let pp (sourcefile : string) =
  
  
  let tmpfile = Filename.temp_file "bspp" "" in
  let pp = (*TODO: check to avoid double quoting *)
    Ext_filename.maybe_quote 
      (match !Js_config.refmt with 
       | None ->
         Filename.concat (Filename.dirname Sys.executable_name) "refmt.exe" 
       | Some x -> x)
  in 
  let comm = Printf.sprintf "%s --print=binary %s > %s"
      pp (Ext_filename.maybe_quote sourcefile) tmpfile
  in
  if Sys.command comm <> 0 then begin
    (try Sys.remove tmpfile with _ -> ());
    raise Pp_error
  end;
  tmpfile  


end
module Bs_version : sig 
#1 "bs_version.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

val version : string

val header : string 

val package_name : string
end = struct
#1 "bs_version.ml"

(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)    
let version = "5.1.0-dev.3"
let header = 
   "// Generated by BUCKLESCRIPT, PLEASE EDIT WITH CARE"  
let package_name = "bs-platform"   
    
end
(** Interface as module  *)
module Asttypes
= struct
#1 "asttypes.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Auxiliary AST types used by parsetree and typedtree. *)

type constant =
    Const_int of int
  | Const_char of char
  | Const_string of string * string option
  | Const_float of string
  | Const_int32 of int32
  | Const_int64 of int64
  | Const_nativeint of nativeint

type rec_flag = Nonrecursive | Recursive

type direction_flag = Upto | Downto

(* Order matters, used in polymorphic comparison *)
type private_flag = Private | Public

type mutable_flag = Immutable | Mutable

type virtual_flag = Virtual | Concrete

type override_flag = Override | Fresh

type closed_flag = Closed | Open

type label = string

type arg_label =
    Nolabel
  | Labelled of string (*  label:T -> ... *)
  | Optional of string (* ?label:T -> ... *)

type 'a loc = 'a Location.loc = {
  txt : 'a;
  loc : Location.t;
}


type variance =
  | Covariant
  | Contravariant
  | Invariant

end
module Longident : sig 
#1 "longident.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Long identifiers, used in parsetree. *)

type t =
    Lident of string
  | Ldot of t * string
  | Lapply of t * t

val flatten: t -> string list
val unflatten: string list -> t option
val last: t -> string
val parse: string -> t

end = struct
#1 "longident.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

type t =
    Lident of string
  | Ldot of t * string
  | Lapply of t * t

let rec flat accu = function
    Lident s -> s :: accu
  | Ldot(lid, s) -> flat (s :: accu) lid
  | Lapply(_, _) -> Misc.fatal_error "Longident.flat"

let flatten lid = flat [] lid

let last = function
    Lident s -> s
  | Ldot(_, s) -> s
  | Lapply(_, _) -> Misc.fatal_error "Longident.last"

let rec split_at_dots s pos =
  try
    let dot = String.index_from s pos '.' in
    String.sub s pos (dot - pos) :: split_at_dots s (dot + 1)
  with Not_found ->
    [String.sub s pos (String.length s - pos)]

let unflatten l =
  match l with
  | [] -> None
  | hd :: tl -> Some (List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl)

let parse s =
  match unflatten (split_at_dots s 0) with
  | None -> Lident ""  (* should not happen, but don't put assert false
                          so as not to crash the toplevel (see Genprintval) *)
  | Some v -> v

end
(** Interface as module  *)
module Parsetree
= struct
#1 "parsetree.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Abstract syntax tree produced by parsing *)

open Asttypes

type constant =
    Pconst_integer of string * char option
  (* 3 3l 3L 3n

     Suffixes [g-z][G-Z] are accepted by the parser.
     Suffixes except 'l', 'L' and 'n' are rejected by the typechecker
  *)
  | Pconst_char of char
  (* 'c' *)
  | Pconst_string of string * string option
  (* "constant"
     {delim|other constant|delim}
  *)
  | Pconst_float of string * char option
  (* 3.4 2e5 1.4e-4

     Suffixes [g-z][G-Z] are accepted by the parser.
     Suffixes are rejected by the typechecker.
  *)

(** {1 Extension points} *)

type attribute = string loc * payload
       (* [@id ARG]
          [@@id ARG]

          Metadata containers passed around within the AST.
          The compiler ignores unknown attributes.
       *)

and extension = string loc * payload
      (* [%id ARG]
         [%%id ARG]

         Sub-language placeholder -- rejected by the typechecker.
      *)

and attributes = attribute list

and payload =
  | PStr of structure
  | PSig of signature (* : SIG *)
  | PTyp of core_type  (* : T *)
  | PPat of pattern * expression option  (* ? P  or  ? P when E *)

(** {1 Core language} *)

(* Type expressions *)

and core_type =
    {
     ptyp_desc: core_type_desc;
     ptyp_loc: Location.t;
     ptyp_attributes: attributes; (* ... [@id1] [@id2] *)
    }

and core_type_desc =
  | Ptyp_any
        (*  _ *)
  | Ptyp_var of string
        (* 'a *)
  | Ptyp_arrow of arg_label * core_type * core_type
        (* T1 -> T2       Simple
           ~l:T1 -> T2    Labelled
           ?l:T1 -> T2    Optional
         *)
  | Ptyp_tuple of core_type list
        (* T1 * ... * Tn

           Invariant: n >= 2
        *)
  | Ptyp_constr of Longident.t loc * core_type list
        (* tconstr
           T tconstr
           (T1, ..., Tn) tconstr
         *)
  | Ptyp_object of object_field list * closed_flag
        (* < l1:T1; ...; ln:Tn >     (flag = Closed)
           < l1:T1; ...; ln:Tn; .. > (flag = Open)
         *)
  | Ptyp_class of Longident.t loc * core_type list
        (* #tconstr
           T #tconstr
           (T1, ..., Tn) #tconstr
         *)
  | Ptyp_alias of core_type * string
        (* T as 'a *)
  | Ptyp_variant of row_field list * closed_flag * label list option
        (* [ `A|`B ]         (flag = Closed; labels = None)
           [> `A|`B ]        (flag = Open;   labels = None)
           [< `A|`B ]        (flag = Closed; labels = Some [])
           [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"])
         *)
  | Ptyp_poly of string loc list * core_type
        (* 'a1 ... 'an. T

           Can only appear in the following context:

           - As the core_type of a Ppat_constraint node corresponding
             to a constraint on a let-binding: let x : 'a1 ... 'an. T
             = e ...

           - Under Cfk_virtual for methods (not values).

           - As the core_type of a Pctf_method node.

           - As the core_type of a Pexp_poly node.

           - As the pld_type field of a label_declaration.

           - As a core_type of a Ptyp_object node.
         *)

  | Ptyp_package of package_type
        (* (module S) *)
  | Ptyp_extension of extension
        (* [%id] *)

and package_type = Longident.t loc * (Longident.t loc * core_type) list
      (*
        (module S)
        (module S with type t1 = T1 and ... and tn = Tn)
       *)

and row_field =
  | Rtag of label loc * attributes * bool * core_type list
        (* [`A]                   ( true,  [] )
           [`A of T]              ( false, [T] )
           [`A of T1 & .. & Tn]   ( false, [T1;...Tn] )
           [`A of & T1 & .. & Tn] ( true,  [T1;...Tn] )

          - The 2nd field is true if the tag contains a
            constant (empty) constructor.
          - '&' occurs when several types are used for the same constructor
            (see 4.2 in the manual)

          - TODO: switch to a record representation, and keep location
        *)
  | Rinherit of core_type
        (* [ T ] *)

and object_field =
  | Otag of label loc * attributes * core_type
  | Oinherit of core_type

(* Patterns *)

and pattern =
    {
     ppat_desc: pattern_desc;
     ppat_loc: Location.t;
     ppat_attributes: attributes; (* ... [@id1] [@id2] *)
    }

and pattern_desc =
  | Ppat_any
        (* _ *)
  | Ppat_var of string loc
        (* x *)
  | Ppat_alias of pattern * string loc
        (* P as 'a *)
  | Ppat_constant of constant
        (* 1, 'a', "true", 1.0, 1l, 1L, 1n *)
  | Ppat_interval of constant * constant
        (* 'a'..'z'

           Other forms of interval are recognized by the parser
           but rejected by the type-checker. *)
  | Ppat_tuple of pattern list
        (* (P1, ..., Pn)

           Invariant: n >= 2
        *)
  | Ppat_construct of Longident.t loc * pattern option
        (* C                None
           C P              Some P
           C (P1, ..., Pn)  Some (Ppat_tuple [P1; ...; Pn])
         *)
  | Ppat_variant of label * pattern option
        (* `A             (None)
           `A P           (Some P)
         *)
  | Ppat_record of (Longident.t loc * pattern) list * closed_flag
        (* { l1=P1; ...; ln=Pn }     (flag = Closed)
           { l1=P1; ...; ln=Pn; _}   (flag = Open)

           Invariant: n > 0
         *)
  | Ppat_array of pattern list
        (* [| P1; ...; Pn |] *)
  | Ppat_or of pattern * pattern
        (* P1 | P2 *)
  | Ppat_constraint of pattern * core_type
        (* (P : T) *)
  | Ppat_type of Longident.t loc
        (* #tconst *)
  | Ppat_lazy of pattern
        (* lazy P *)
  | Ppat_unpack of string loc
        (* (module P)
           Note: (module P : S) is represented as
           Ppat_constraint(Ppat_unpack, Ptyp_package)
         *)
  | Ppat_exception of pattern
        (* exception P *)
  | Ppat_extension of extension
        (* [%id] *)
  | Ppat_open of Longident.t loc * pattern
        (* M.(P) *)

(* Value expressions *)

and expression =
    {
     pexp_desc: expression_desc;
     pexp_loc: Location.t;
     pexp_attributes: attributes; (* ... [@id1] [@id2] *)
    }

and expression_desc =
  | Pexp_ident of Longident.t loc
        (* x
           M.x
         *)
  | Pexp_constant of constant
        (* 1, 'a', "true", 1.0, 1l, 1L, 1n *)
  | Pexp_let of rec_flag * value_binding list * expression
        (* let P1 = E1 and ... and Pn = EN in E       (flag = Nonrecursive)
           let rec P1 = E1 and ... and Pn = EN in E   (flag = Recursive)
         *)
  | Pexp_function of case list
        (* function P1 -> E1 | ... | Pn -> En *)
  | Pexp_fun of arg_label * expression option * pattern * expression
        (* fun P -> E1                          (Simple, None)
           fun ~l:P -> E1                       (Labelled l, None)
           fun ?l:P -> E1                       (Optional l, None)
           fun ?l:(P = E0) -> E1                (Optional l, Some E0)

           Notes:
           - If E0 is provided, only Optional is allowed.
           - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun.
           - "let f P = E" is represented using Pexp_fun.
         *)
  | Pexp_apply of expression * (arg_label * expression) list
        (* E0 ~l1:E1 ... ~ln:En
           li can be empty (non labeled argument) or start with '?'
           (optional argument).

           Invariant: n > 0
         *)
  | Pexp_match of expression * case list
        (* match E0 with P1 -> E1 | ... | Pn -> En *)
  | Pexp_try of expression * case list
        (* try E0 with P1 -> E1 | ... | Pn -> En *)
  | Pexp_tuple of expression list
        (* (E1, ..., En)

           Invariant: n >= 2
        *)
  | Pexp_construct of Longident.t loc * expression option
        (* C                None
           C E              Some E
           C (E1, ..., En)  Some (Pexp_tuple[E1;...;En])
        *)
  | Pexp_variant of label * expression option
        (* `A             (None)
           `A E           (Some E)
         *)
  | Pexp_record of (Longident.t loc * expression) list * expression option
        (* { l1=P1; ...; ln=Pn }     (None)
           { E0 with l1=P1; ...; ln=Pn }   (Some E0)

           Invariant: n > 0
         *)
  | Pexp_field of expression * Longident.t loc
        (* E.l *)
  | Pexp_setfield of expression * Longident.t loc * expression
        (* E1.l <- E2 *)
  | Pexp_array of expression list
        (* [| E1; ...; En |] *)
  | Pexp_ifthenelse of expression * expression * expression option
        (* if E1 then E2 else E3 *)
  | Pexp_sequence of expression * expression
        (* E1; E2 *)
  | Pexp_while of expression * expression
        (* while E1 do E2 done *)
  | Pexp_for of
      pattern *  expression * expression * direction_flag * expression
        (* for i = E1 to E2 do E3 done      (flag = Upto)
           for i = E1 downto E2 do E3 done  (flag = Downto)
         *)
  | Pexp_constraint of expression * core_type
        (* (E : T) *)
  | Pexp_coerce of expression * core_type option * core_type
        (* (E :> T)        (None, T)
           (E : T0 :> T)   (Some T0, T)
         *)
  | Pexp_send of expression * label loc
        (*  E # m *)
  | Pexp_new of Longident.t loc
        (* new M.c *)
  | Pexp_setinstvar of label loc * expression
        (* x <- 2 *)
  | Pexp_override of (label loc * expression) list
        (* {< x1 = E1; ...; Xn = En >} *)
  | Pexp_letmodule of string loc * module_expr * expression
        (* let module M = ME in E *)
  | Pexp_letexception of extension_constructor * expression
        (* let exception C in E *)
  | Pexp_assert of expression
        (* assert E
           Note: "assert false" is treated in a special way by the
           type-checker. *)
  | Pexp_lazy of expression
        (* lazy E *)
  | Pexp_poly of expression * core_type option
        (* Used for method bodies.

           Can only be used as the expression under Cfk_concrete
           for methods (not values). *)
  | Pexp_object of class_structure
        (* object ... end *)
  | Pexp_newtype of string loc * expression
        (* fun (type t) -> E *)
  | Pexp_pack of module_expr
        (* (module ME)

           (module ME : S) is represented as
           Pexp_constraint(Pexp_pack, Ptyp_package S) *)
  | Pexp_open of override_flag * Longident.t loc * expression
        (* M.(E)
           let open M in E
           let! open M in E *)
  | Pexp_extension of extension
        (* [%id] *)
  | Pexp_unreachable
        (* . *)

and case =   (* (P -> E) or (P when E0 -> E) *)
    {
     pc_lhs: pattern;
     pc_guard: expression option;
     pc_rhs: expression;
    }

(* Value descriptions *)

and value_description =
    {
     pval_name: string loc;
     pval_type: core_type;
     pval_prim: string list;
     pval_attributes: attributes;  (* ... [@@id1] [@@id2] *)
     pval_loc: Location.t;
    }

(*
  val x: T                            (prim = [])
  external x: T = "s1" ... "sn"       (prim = ["s1";..."sn"])
*)

(* Type declarations *)

and type_declaration =
    {
     ptype_name: string loc;
     ptype_params: (core_type * variance) list;
           (* ('a1,...'an) t; None represents  _*)
     ptype_cstrs: (core_type * core_type * Location.t) list;
           (* ... constraint T1=T1'  ... constraint Tn=Tn' *)
     ptype_kind: type_kind;
     ptype_private: private_flag;   (* = private ... *)
     ptype_manifest: core_type option;  (* = T *)
     ptype_attributes: attributes;   (* ... [@@id1] [@@id2] *)
     ptype_loc: Location.t;
    }

(*
  type t                     (abstract, no manifest)
  type t = T0                (abstract, manifest=T0)
  type t = C of T | ...      (variant,  no manifest)
  type t = T0 = C of T | ... (variant,  manifest=T0)
  type t = {l: T; ...}       (record,   no manifest)
  type t = T0 = {l : T; ...} (record,   manifest=T0)
  type t = ..                (open,     no manifest)
*)

and type_kind =
  | Ptype_abstract
  | Ptype_variant of constructor_declaration list
        (* Invariant: non-empty list *)
  | Ptype_record of label_declaration list
        (* Invariant: non-empty list *)
  | Ptype_open

and label_declaration =
    {
     pld_name: string loc;
     pld_mutable: mutable_flag;
     pld_type: core_type;
     pld_loc: Location.t;
     pld_attributes: attributes; (* l : T [@id1] [@id2] *)
    }

(*  { ...; l: T; ... }            (mutable=Immutable)
    { ...; mutable l: T; ... }    (mutable=Mutable)

    Note: T can be a Ptyp_poly.
*)

and constructor_declaration =
    {
     pcd_name: string loc;
     pcd_args: constructor_arguments;
     pcd_res: core_type option;
     pcd_loc: Location.t;
     pcd_attributes: attributes; (* C of ... [@id1] [@id2] *)
    }

and constructor_arguments =
  | Pcstr_tuple of core_type list
  | Pcstr_record of label_declaration list

(*
  | C of T1 * ... * Tn     (res = None,    args = Pcstr_tuple [])
  | C: T0                  (res = Some T0, args = [])
  | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple)
  | C of {...}             (res = None,    args = Pcstr_record)
  | C: {...} -> T0         (res = Some T0, args = Pcstr_record)
  | C of {...} as t        (res = None,    args = Pcstr_record)
*)

and type_extension =
    {
     ptyext_path: Longident.t loc;
     ptyext_params: (core_type * variance) list;
     ptyext_constructors: extension_constructor list;
     ptyext_private: private_flag;
     ptyext_attributes: attributes;   (* ... [@@id1] [@@id2] *)
    }
(*
  type t += ...
*)

and extension_constructor =
    {
     pext_name: string loc;
     pext_kind : extension_constructor_kind;
     pext_loc : Location.t;
     pext_attributes: attributes; (* C of ... [@id1] [@id2] *)
    }

and extension_constructor_kind =
    Pext_decl of constructor_arguments * core_type option
      (*
         | C of T1 * ... * Tn     ([T1; ...; Tn], None)
         | C: T0                  ([], Some T0)
         | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0)
       *)
  | Pext_rebind of Longident.t loc
      (*
         | C = D
       *)

(** {1 Class language} *)

(* Type expressions for the class language *)

and class_type =
    {
     pcty_desc: class_type_desc;
     pcty_loc: Location.t;
     pcty_attributes: attributes; (* ... [@id1] [@id2] *)
    }

and class_type_desc =
  | Pcty_constr of Longident.t loc * core_type list
        (* c
           ['a1, ..., 'an] c *)
  | Pcty_signature of class_signature
        (* object ... end *)
  | Pcty_arrow of arg_label * core_type * class_type
        (* T -> CT       Simple
           ~l:T -> CT    Labelled l
           ?l:T -> CT    Optional l
         *)
  | Pcty_extension of extension
        (* [%id] *)
  | Pcty_open of override_flag * Longident.t loc * class_type
        (* let open M in CT *)

and class_signature =
    {
     pcsig_self: core_type;
     pcsig_fields: class_type_field list;
    }
(* object('selfpat) ... end
   object ... end             (self = Ptyp_any)
 *)

and class_type_field =
    {
     pctf_desc: class_type_field_desc;
     pctf_loc: Location.t;
     pctf_attributes: attributes; (* ... [@@id1] [@@id2] *)
    }

and class_type_field_desc =
  | Pctf_inherit of class_type
        (* inherit CT *)
  | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type)
        (* val x: T *)
  | Pctf_method  of (label loc * private_flag * virtual_flag * core_type)
        (* method x: T

           Note: T can be a Ptyp_poly.
         *)
  | Pctf_constraint  of (core_type * core_type)
        (* constraint T1 = T2 *)
  | Pctf_attribute of attribute
        (* [@@@id] *)
  | Pctf_extension of extension
        (* [%%id] *)

and 'a class_infos =
    {
     pci_virt: virtual_flag;
     pci_params: (core_type * variance) list;
     pci_name: string loc;
     pci_expr: 'a;
     pci_loc: Location.t;
     pci_attributes: attributes;  (* ... [@@id1] [@@id2] *)
    }
(* class c = ...
   class ['a1,...,'an] c = ...
   class virtual c = ...

   Also used for "class type" declaration.
*)

and class_description = class_type class_infos

and class_type_declaration = class_type class_infos

(* Value expressions for the class language *)

and class_expr =
    {
     pcl_desc: class_expr_desc;
     pcl_loc: Location.t;
     pcl_attributes: attributes; (* ... [@id1] [@id2] *)
    }

and class_expr_desc =
  | Pcl_constr of Longident.t loc * core_type list
        (* c
           ['a1, ..., 'an] c *)
  | Pcl_structure of class_structure
        (* object ... end *)
  | Pcl_fun of arg_label * expression option * pattern * class_expr
        (* fun P -> CE                          (Simple, None)
           fun ~l:P -> CE                       (Labelled l, None)
           fun ?l:P -> CE                       (Optional l, None)
           fun ?l:(P = E0) -> CE                (Optional l, Some E0)
         *)
  | Pcl_apply of class_expr * (arg_label * expression) list
        (* CE ~l1:E1 ... ~ln:En
           li can be empty (non labeled argument) or start with '?'
           (optional argument).

           Invariant: n > 0
         *)
  | Pcl_let of rec_flag * value_binding list * class_expr
        (* let P1 = E1 and ... and Pn = EN in CE      (flag = Nonrecursive)
           let rec P1 = E1 and ... and Pn = EN in CE  (flag = Recursive)
         *)
  | Pcl_constraint of class_expr * class_type
        (* (CE : CT) *)
  | Pcl_extension of extension
  (* [%id] *)
  | Pcl_open of override_flag * Longident.t loc * class_expr
  (* let open M in CE *)


and class_structure =
    {
     pcstr_self: pattern;
     pcstr_fields: class_field list;
    }
(* object(selfpat) ... end
   object ... end           (self = Ppat_any)
 *)

and class_field =
    {
     pcf_desc: class_field_desc;
     pcf_loc: Location.t;
     pcf_attributes: attributes; (* ... [@@id1] [@@id2] *)
    }

and class_field_desc =
  | Pcf_inherit of override_flag * class_expr * string loc option
        (* inherit CE
           inherit CE as x
           inherit! CE
           inherit! CE as x
         *)
  | Pcf_val of (label loc * mutable_flag * class_field_kind)
        (* val x = E
           val virtual x: T
         *)
  | Pcf_method of (label loc * private_flag * class_field_kind)
        (* method x = E            (E can be a Pexp_poly)
           method virtual x: T     (T can be a Ptyp_poly)
         *)
  | Pcf_constraint of (core_type * core_type)
        (* constraint T1 = T2 *)
  | Pcf_initializer of expression
        (* initializer E *)
  | Pcf_attribute of attribute
        (* [@@@id] *)
  | Pcf_extension of extension
        (* [%%id] *)

and class_field_kind =
  | Cfk_virtual of core_type
  | Cfk_concrete of override_flag * expression

and class_declaration = class_expr class_infos

(** {1 Module language} *)

(* Type expressions for the module language *)

and module_type =
    {
     pmty_desc: module_type_desc;
     pmty_loc: Location.t;
     pmty_attributes: attributes; (* ... [@id1] [@id2] *)
    }

and module_type_desc =
  | Pmty_ident of Longident.t loc
        (* S *)
  | Pmty_signature of signature
        (* sig ... end *)
  | Pmty_functor of string loc * module_type option * module_type
        (* functor(X : MT1) -> MT2 *)
  | Pmty_with of module_type * with_constraint list
        (* MT with ... *)
  | Pmty_typeof of module_expr
        (* module type of ME *)
  | Pmty_extension of extension
        (* [%id] *)
  | Pmty_alias of Longident.t loc
        (* (module M) *)

and signature = signature_item list

and signature_item =
    {
     psig_desc: signature_item_desc;
     psig_loc: Location.t;
    }

and signature_item_desc =
  | Psig_value of value_description
        (*
          val x: T
          external x: T = "s1" ... "sn"
         *)
  | Psig_type of rec_flag * type_declaration list
        (* type t1 = ... and ... and tn = ... *)
  | Psig_typext of type_extension
        (* type t1 += ... *)
  | Psig_exception of extension_constructor
        (* exception C of T *)
  | Psig_module of module_declaration
        (* module X : MT *)
  | Psig_recmodule of module_declaration list
        (* module rec X1 : MT1 and ... and Xn : MTn *)
  | Psig_modtype of module_type_declaration
        (* module type S = MT
           module type S *)
  | Psig_open of open_description
        (* open X *)
  | Psig_include of include_description
        (* include MT *)
  | Psig_class of class_description list
        (* class c1 : ... and ... and cn : ... *)
  | Psig_class_type of class_type_declaration list
        (* class type ct1 = ... and ... and ctn = ... *)
  | Psig_attribute of attribute
        (* [@@@id] *)
  | Psig_extension of extension * attributes
        (* [%%id] *)

and module_declaration =
    {
     pmd_name: string loc;
     pmd_type: module_type;
     pmd_attributes: attributes; (* ... [@@id1] [@@id2] *)
     pmd_loc: Location.t;
    }
(* S : MT *)

and module_type_declaration =
    {
     pmtd_name: string loc;
     pmtd_type: module_type option;
     pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *)
     pmtd_loc: Location.t;
    }
(* S = MT
   S       (abstract module type declaration, pmtd_type = None)
*)

and open_description =
    {
     popen_lid: Longident.t loc;
     popen_override: override_flag;
     popen_loc: Location.t;
     popen_attributes: attributes;
    }
(* open! X - popen_override = Override (silences the 'used identifier
                              shadowing' warning)
   open  X - popen_override = Fresh
 *)

and 'a include_infos =
    {
     pincl_mod: 'a;
     pincl_loc: Location.t;
     pincl_attributes: attributes;
    }

and include_description = module_type include_infos
(* include MT *)

and include_declaration = module_expr include_infos
(* include ME *)

and with_constraint =
  | Pwith_type of Longident.t loc * type_declaration
        (* with type X.t = ...

           Note: the last component of the longident must match
           the name of the type_declaration. *)
  | Pwith_module of Longident.t loc * Longident.t loc
        (* with module X.Y = Z *)
  | Pwith_typesubst of Longident.t loc * type_declaration
        (* with type X.t := ..., same format as [Pwith_type] *)
  | Pwith_modsubst of Longident.t loc * Longident.t loc
        (* with module X.Y := Z *)

(* Value expressions for the module language *)

and module_expr =
    {
     pmod_desc: module_expr_desc;
     pmod_loc: Location.t;
     pmod_attributes: attributes; (* ... [@id1] [@id2] *)
    }

and module_expr_desc =
  | Pmod_ident of Longident.t loc
        (* X *)
  | Pmod_structure of structure
        (* struct ... end *)
  | Pmod_functor of string loc * module_type option * module_expr
        (* functor(X : MT1) -> ME *)
  | Pmod_apply of module_expr * module_expr
        (* ME1(ME2) *)
  | Pmod_constraint of module_expr * module_type
        (* (ME : MT) *)
  | Pmod_unpack of expression
        (* (val E) *)
  | Pmod_extension of extension
        (* [%id] *)

and structure = structure_item list

and structure_item =
    {
     pstr_desc: structure_item_desc;
     pstr_loc: Location.t;
    }

and structure_item_desc =
  | Pstr_eval of expression * attributes
        (* E *)
  | Pstr_value of rec_flag * value_binding list
        (* let P1 = E1 and ... and Pn = EN       (flag = Nonrecursive)
           let rec P1 = E1 and ... and Pn = EN   (flag = Recursive)
         *)
  | Pstr_primitive of value_description
        (*  val x: T
            external x: T = "s1" ... "sn" *)
  | Pstr_type of rec_flag * type_declaration list
        (* type t1 = ... and ... and tn = ... *)
  | Pstr_typext of type_extension
        (* type t1 += ... *)
  | Pstr_exception of extension_constructor
        (* exception C of T
           exception C = M.X *)
  | Pstr_module of module_binding
        (* module X = ME *)
  | Pstr_recmodule of module_binding list
        (* module rec X1 = ME1 and ... and Xn = MEn *)
  | Pstr_modtype of module_type_declaration
        (* module type S = MT *)
  | Pstr_open of open_description
        (* open X *)
  | Pstr_class of class_declaration list
        (* class c1 = ... and ... and cn = ... *)
  | Pstr_class_type of class_type_declaration list
        (* class type ct1 = ... and ... and ctn = ... *)
  | Pstr_include of include_declaration
        (* include ME *)
  | Pstr_attribute of attribute
        (* [@@@id] *)
  | Pstr_extension of extension * attributes
        (* [%%id] *)

and value_binding =
  {
    pvb_pat: pattern;
    pvb_expr: expression;
    pvb_attributes: attributes;
    pvb_loc: Location.t;
  }

and module_binding =
    {
     pmb_name: string loc;
     pmb_expr: module_expr;
     pmb_attributes: attributes;
     pmb_loc: Location.t;
    }
(* X = ME *)

(** {1 Toplevel} *)

(* Toplevel phrases *)

type toplevel_phrase =
  | Ptop_def of structure
  | Ptop_dir of string * directive_argument
     (* #use, #load ... *)

and directive_argument =
  | Pdir_none
  | Pdir_string of string
  | Pdir_int of string * char option
  | Pdir_ident of Longident.t
  | Pdir_bool of bool

end
module Docstrings : sig 
#1 "docstrings.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                               Leo White                                *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Documentation comments *)

(** (Re)Initialise all docstring state *)
val init : unit -> unit

(** Emit warnings for unattached and ambiguous docstrings *)
val warn_bad_docstrings : unit -> unit

(** {2 Docstrings} *)

(** Documentation comments *)
type docstring

(** Create a docstring *)
val docstring : string -> Location.t -> docstring

(** Register a docstring *)
val register : docstring -> unit

(** Get the text of a docstring *)
val docstring_body : docstring -> string

(** Get the location of a docstring *)
val docstring_loc : docstring -> Location.t

(** {2 Set functions}

   These functions are used by the lexer to associate docstrings to
   the locations of tokens. *)

(** Docstrings immediately preceding a token *)
val set_pre_docstrings : Lexing.position -> docstring list -> unit

(** Docstrings immediately following a token *)
val set_post_docstrings : Lexing.position -> docstring list -> unit

(** Docstrings not immediately adjacent to a token *)
val set_floating_docstrings : Lexing.position -> docstring list -> unit

(** Docstrings immediately following the token which precedes this one *)
val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit

(** Docstrings immediately preceding the token which follows this one *)
val set_post_extra_docstrings : Lexing.position -> docstring list -> unit

(** {2 Items}

    The {!docs} type represents documentation attached to an item. *)

type docs =
  { docs_pre: docstring option;
    docs_post: docstring option; }

val empty_docs : docs

val docs_attr : docstring -> Parsetree.attribute

(** Convert item documentation to attributes and add them to an
    attribute list *)
val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes

(** Fetch the item documentation for the current symbol. This also
    marks this documentation (for ambiguity warnings). *)
val symbol_docs : unit -> docs
val symbol_docs_lazy : unit -> docs Lazy.t

(** Fetch the item documentation for the symbols between two
    positions. This also marks this documentation (for ambiguity
    warnings). *)
val rhs_docs : int -> int -> docs
val rhs_docs_lazy : int -> int -> docs Lazy.t

(** Mark the item documentation for the current symbol (for ambiguity
    warnings). *)
val mark_symbol_docs : unit -> unit

(** Mark as associated the item documentation for the symbols between
    two positions (for ambiguity warnings) *)
val mark_rhs_docs : int -> int -> unit

(** {2 Fields and constructors}

    The {!info} type represents documentation attached to a field or
    constructor. *)

type info = docstring option

val empty_info : info

val info_attr : docstring -> Parsetree.attribute

(** Convert field info to attributes and add them to an
    attribute list *)
val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes

(** Fetch the field info for the current symbol. *)
val symbol_info : unit -> info

(** Fetch the field info following the symbol at a given position. *)
val rhs_info : int -> info

(** {2 Unattached comments}

    The {!text} type represents documentation which is not attached to
    anything. *)

type text = docstring list

val empty_text : text
val empty_text_lazy : text Lazy.t

val text_attr : docstring -> Parsetree.attribute

(** Convert text to attributes and add them to an attribute list *)
val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes

(** Fetch the text preceding the current symbol. *)
val symbol_text : unit -> text
val symbol_text_lazy : unit -> text Lazy.t

(** Fetch the text preceding the symbol at the given position. *)
val rhs_text : int -> text
val rhs_text_lazy : int -> text Lazy.t

(** {2 Extra text}

    There may be additional text attached to the delimiters of a block
    (e.g. [struct] and [end]). This is fetched by the following
    functions, which are applied to the contents of the block rather
    than the delimiters. *)

(** Fetch additional text preceding the current symbol *)
val symbol_pre_extra_text : unit -> text

(** Fetch additional text following the current symbol *)
val symbol_post_extra_text : unit -> text

(** Fetch additional text preceding the symbol at the given position *)
val rhs_pre_extra_text : int -> text

(** Fetch additional text following the symbol at the given position *)
val rhs_post_extra_text : int -> text

end = struct
#1 "docstrings.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                               Leo White                                *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Location

(* Docstrings *)

(* A docstring is "attached" if it has been inserted in the AST. This
   is used for generating unexpected docstring warnings. *)
type ds_attached =
  | Unattached   (* Not yet attached anything.*)
  | Info         (* Attached to a field or constructor. *)
  | Docs         (* Attached to an item or as floating text. *)

(* A docstring is "associated" with an item if there are no blank lines between
   them. This is used for generating docstring ambiguity warnings. *)
type ds_associated =
  | Zero             (* Not associated with an item *)
  | One              (* Associated with one item *)
  | Many             (* Associated with multiple items (ambiguity) *)

type docstring =
  { ds_body: string;
    ds_loc: Location.t;
    mutable ds_attached: ds_attached;
    mutable ds_associated: ds_associated; }

(* List of docstrings *)

let docstrings : docstring list ref = ref []

(* Warn for unused and ambiguous docstrings *)

let warn_bad_docstrings () =
  if Warnings.is_active (Warnings.Bad_docstring true) then begin
    List.iter
      (fun ds ->
         match ds.ds_attached with
         | Info -> ()
         | Unattached ->
           prerr_warning ds.ds_loc (Warnings.Bad_docstring true)
         | Docs ->
             match ds.ds_associated with
             | Zero | One -> ()
             | Many ->
               prerr_warning ds.ds_loc (Warnings.Bad_docstring false))
      (List.rev !docstrings)
end

(* Docstring constructors and destructors *)

let docstring body loc =
  let ds =
    { ds_body = body;
      ds_loc = loc;
      ds_attached = Unattached;
      ds_associated = Zero; }
  in
  ds

let register ds =
  docstrings := ds :: !docstrings

let docstring_body ds = ds.ds_body

let docstring_loc ds = ds.ds_loc

(* Docstrings attached to items *)

type docs =
  { docs_pre: docstring option;
    docs_post: docstring option; }

let empty_docs = { docs_pre = None; docs_post = None }

let doc_loc = {txt = "ocaml.doc"; loc = Location.none}

let docs_attr ds =
  let open Parsetree in
  let exp =
    { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None));
      pexp_loc = ds.ds_loc;
      pexp_attributes = []; }
  in
  let item =
    { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc }
  in
    (doc_loc, PStr [item])

let add_docs_attrs docs attrs =
  let attrs =
    match docs.docs_pre with
    | None | Some { ds_body=""; _ } -> attrs
    | Some ds -> docs_attr ds :: attrs
  in
  let attrs =
    match docs.docs_post with
    | None | Some { ds_body=""; _ } -> attrs
    | Some ds -> attrs @ [docs_attr ds]
  in
  attrs

(* Docstrings attached to constructors or fields *)

type info = docstring option

let empty_info = None

let info_attr = docs_attr

let add_info_attrs info attrs =
  match info with
  | None | Some {ds_body=""; _} -> attrs
  | Some ds -> attrs @ [info_attr ds]

(* Docstrings not attached to a specific item *)

type text = docstring list

let empty_text = []
let empty_text_lazy = lazy []

let text_loc = {txt = "ocaml.text"; loc = Location.none}

let text_attr ds =
  let open Parsetree in
  let exp =
    { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None));
      pexp_loc = ds.ds_loc;
      pexp_attributes = []; }
  in
  let item =
    { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc }
  in
    (text_loc, PStr [item])

let add_text_attrs dsl attrs =
  let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in
  (List.map text_attr fdsl) @ attrs

(* Find the first non-info docstring in a list, attach it and return it *)
let get_docstring ~info dsl =
  let rec loop = function
    | [] -> None
    | {ds_attached = Info; _} :: rest -> loop rest
    | ds :: _ ->
        ds.ds_attached <- if info then Info else Docs;
        Some ds
  in
  loop dsl

(* Find all the non-info docstrings in a list, attach them and return them *)
let get_docstrings dsl =
  let rec loop acc = function
    | [] -> List.rev acc
    | {ds_attached = Info; _} :: rest -> loop acc rest
    | ds :: rest ->
        ds.ds_attached <- Docs;
        loop (ds :: acc) rest
  in
    loop [] dsl

(* "Associate" all the docstrings in a list *)
let associate_docstrings dsl =
  List.iter
    (fun ds ->
       match ds.ds_associated with
       | Zero -> ds.ds_associated <- One
       | (One | Many) -> ds.ds_associated <- Many)
    dsl

(* Map from positions to pre docstrings *)

let pre_table : (Lexing.position, docstring list) Hashtbl.t =
  Hashtbl.create 50

let set_pre_docstrings pos dsl =
  if dsl <> [] then Hashtbl.add pre_table pos dsl

let get_pre_docs pos =
  try
    let dsl = Hashtbl.find pre_table pos in
      associate_docstrings dsl;
      get_docstring ~info:false dsl
  with Not_found -> None

let mark_pre_docs pos =
  try
    let dsl = Hashtbl.find pre_table pos in
      associate_docstrings dsl
  with Not_found -> ()

(* Map from positions to post docstrings *)

let post_table : (Lexing.position, docstring list) Hashtbl.t =
  Hashtbl.create 50

let set_post_docstrings pos dsl =
  if dsl <> [] then Hashtbl.add post_table pos dsl

let get_post_docs pos =
  try
    let dsl = Hashtbl.find post_table pos in
      associate_docstrings dsl;
      get_docstring ~info:false dsl
  with Not_found -> None

let mark_post_docs pos =
  try
    let dsl = Hashtbl.find post_table pos in
      associate_docstrings dsl
  with Not_found -> ()

let get_info pos =
  try
    let dsl = Hashtbl.find post_table pos in
      get_docstring ~info:true dsl
  with Not_found -> None

(* Map from positions to floating docstrings *)

let floating_table : (Lexing.position, docstring list) Hashtbl.t =
  Hashtbl.create 50

let set_floating_docstrings pos dsl =
  if dsl <> [] then Hashtbl.add floating_table pos dsl

let get_text pos =
  try
    let dsl = Hashtbl.find floating_table pos in
      get_docstrings dsl
  with Not_found -> []

(* Maps from positions to extra docstrings *)

let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t =
  Hashtbl.create 50

let set_pre_extra_docstrings pos dsl =
  if dsl <> [] then Hashtbl.add pre_extra_table pos dsl

let get_pre_extra_text pos =
  try
    let dsl = Hashtbl.find pre_extra_table pos in
      get_docstrings dsl
  with Not_found -> []

let post_extra_table : (Lexing.position, docstring list) Hashtbl.t =
  Hashtbl.create 50

let set_post_extra_docstrings pos dsl =
  if dsl <> [] then Hashtbl.add post_extra_table pos dsl

let get_post_extra_text pos =
  try
    let dsl = Hashtbl.find post_extra_table pos in
      get_docstrings dsl
  with Not_found -> []

(* Docstrings from parser actions *)

let symbol_docs () =
  { docs_pre = get_pre_docs (Parsing.symbol_start_pos ());
    docs_post = get_post_docs (Parsing.symbol_end_pos ()); }

let symbol_docs_lazy () =
  let p1 = Parsing.symbol_start_pos () in
  let p2 = Parsing.symbol_end_pos () in
    lazy { docs_pre = get_pre_docs p1;
           docs_post = get_post_docs p2; }

let rhs_docs pos1 pos2 =
  { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1);
    docs_post = get_post_docs (Parsing.rhs_end_pos pos2); }

let rhs_docs_lazy pos1 pos2 =
  let p1 = Parsing.rhs_start_pos pos1 in
  let p2 = Parsing.rhs_end_pos pos2 in
    lazy { docs_pre = get_pre_docs p1;
           docs_post = get_post_docs p2; }

let mark_symbol_docs () =
  mark_pre_docs (Parsing.symbol_start_pos ());
  mark_post_docs (Parsing.symbol_end_pos ())

let mark_rhs_docs pos1 pos2 =
  mark_pre_docs (Parsing.rhs_start_pos pos1);
  mark_post_docs (Parsing.rhs_end_pos pos2)

let symbol_info () =
  get_info (Parsing.symbol_end_pos ())

let rhs_info pos =
  get_info (Parsing.rhs_end_pos pos)

let symbol_text () =
  get_text (Parsing.symbol_start_pos ())

let symbol_text_lazy () =
  let pos = Parsing.symbol_start_pos () in
    lazy (get_text pos)

let rhs_text pos =
  get_text (Parsing.rhs_start_pos pos)

let rhs_text_lazy pos =
  let pos = Parsing.rhs_start_pos pos in
    lazy (get_text pos)

let symbol_pre_extra_text () =
  get_pre_extra_text (Parsing.symbol_start_pos ())

let symbol_post_extra_text () =
  get_post_extra_text (Parsing.symbol_end_pos ())

let rhs_pre_extra_text pos =
  get_pre_extra_text (Parsing.rhs_start_pos pos)

let rhs_post_extra_text pos =
  get_post_extra_text (Parsing.rhs_end_pos pos)


(* (Re)Initialise all comment state *)

let init () =
  docstrings := [];
  Hashtbl.reset pre_table;
  Hashtbl.reset post_table;
  Hashtbl.reset floating_table;
  Hashtbl.reset pre_extra_table;
  Hashtbl.reset post_extra_table

end
module Syntaxerr : sig 
#1 "syntaxerr.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Auxiliary type for reporting syntax errors *)

open Format

type error =
    Unclosed of Location.t * string * Location.t * string
  | Expecting of Location.t * string
  | Not_expecting of Location.t * string
  | Applicative_path of Location.t
  | Variable_in_scope of Location.t * string
  | Other of Location.t
  | Ill_formed_ast of Location.t * string
  | Invalid_package_type of Location.t * string

exception Error of error
exception Escape_error

val report_error: formatter -> error -> unit
 (** @deprecated Use {!Location.error_of_exn}, {!Location.report_error}. *)

val location_of_error: error -> Location.t
val ill_formed_ast: Location.t -> string -> 'a

end = struct
#1 "syntaxerr.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Auxiliary type for reporting syntax errors *)

type error =
    Unclosed of Location.t * string * Location.t * string
  | Expecting of Location.t * string
  | Not_expecting of Location.t * string
  | Applicative_path of Location.t
  | Variable_in_scope of Location.t * string
  | Other of Location.t
  | Ill_formed_ast of Location.t * string
  | Invalid_package_type of Location.t * string

exception Error of error
exception Escape_error

let prepare_error = function
  | Unclosed(opening_loc, opening, closing_loc, closing) ->
      Location.errorf ~loc:closing_loc
        ~sub:[
          Location.errorf ~loc:opening_loc
            "This '%s' might be unmatched" opening
        ]
        ~if_highlight:
          (Printf.sprintf "Syntax error: '%s' expected, \
                           the highlighted '%s' might be unmatched"
             closing opening)
        "Syntax error: '%s' expected" closing

  | Expecting (loc, nonterm) ->
      Location.errorf ~loc "Syntax error: %s expected." nonterm
  | Not_expecting (loc, nonterm) ->
      Location.errorf ~loc "Syntax error: %s not expected." nonterm
  | Applicative_path loc ->
      Location.errorf ~loc
        "Syntax error: applicative paths of the form F(X).t \
         are not supported when the option -no-app-func is set."
  | Variable_in_scope (loc, var) ->
      Location.errorf ~loc
        "In this scoped type, variable '%s \
         is reserved for the local type %s."
         var var
  | Other loc ->
      Location.errorf ~loc "Syntax error"
  | Ill_formed_ast (loc, s) ->
      Location.errorf ~loc "broken invariant in parsetree: %s" s
  | Invalid_package_type (loc, s) ->
      Location.errorf ~loc "invalid package type: %s" s

let () =
  Location.register_error_of_exn
    (function
      | Error err -> Some (prepare_error err)
      | _ -> None
    )


let report_error ppf err =
  Location.report_error ppf (prepare_error err)

let location_of_error = function
  | Unclosed(l,_,_,_)
  | Applicative_path l
  | Variable_in_scope(l,_)
  | Other l
  | Not_expecting (l, _)
  | Ill_formed_ast (l, _)
  | Invalid_package_type (l, _)
  | Expecting (l, _) -> l


let ill_formed_ast loc s =
  raise (Error (Ill_formed_ast (loc, s)))

end
module Ast_helper : sig 
#1 "ast_helper.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                         Alain Frisch, LexiFi                           *)
(*                                                                        *)
(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Helpers to produce Parsetree fragments *)

open Asttypes
open Docstrings
open Parsetree

type lid = Longident.t loc
type str = string loc
type loc = Location.t
type attrs = attribute list

(** {1 Default locations} *)

val default_loc: loc ref
    (** Default value for all optional location arguments. *)

val with_default_loc: loc -> (unit -> 'a) -> 'a
    (** Set the [default_loc] within the scope of the execution
        of the provided function. *)

(** {1 Constants} *)

module Const : sig
  val char : char -> constant
  val string : ?quotation_delimiter:string -> string -> constant
  val integer : ?suffix:char -> string -> constant
  val int : ?suffix:char -> int -> constant
  val int32 : ?suffix:char -> int32 -> constant
  val int64 : ?suffix:char -> int64 -> constant
  val nativeint : ?suffix:char -> nativeint -> constant
  val float : ?suffix:char -> string -> constant
end

(** {1 Core language} *)

(** Type expressions *)
module Typ :
  sig
    val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type
    val attr: core_type -> attribute -> core_type

    val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type
    val var: ?loc:loc -> ?attrs:attrs -> string -> core_type
    val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type
               -> core_type
    val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type
    val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
    val object_: ?loc:loc -> ?attrs:attrs -> object_field list
                   -> closed_flag -> core_type
    val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
    val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type
    val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag
                 -> label list option -> core_type
    val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type
    val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list
                 -> core_type
    val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type

    val force_poly: core_type -> core_type

    val varify_constructors: str list -> core_type -> core_type
    (** [varify_constructors newtypes te] is type expression [te], of which
        any of nullary type constructor [tc] is replaced by type variable of
        the same name, if [tc]'s name appears in [newtypes].
        Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te]
        appears in [newtypes].
        @since 4.05
     *)
  end

(** Patterns *)
module Pat:
  sig
    val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern
    val attr:pattern -> attribute -> pattern

    val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern
    val var: ?loc:loc -> ?attrs:attrs -> str -> pattern
    val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern
    val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern
    val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern
    val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern
    val construct: ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern
    val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern
    val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag
                -> pattern
    val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern
    val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern
    val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern
    val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern
    val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
    val unpack: ?loc:loc -> ?attrs:attrs -> str -> pattern
    val open_: ?loc:loc -> ?attrs:attrs  -> lid -> pattern -> pattern
    val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
    val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern
  end

(** Expressions *)
module Exp:
  sig
    val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression
    val attr: expression -> attribute -> expression

    val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression
    val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression
    val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list
              -> expression -> expression
    val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option
              -> pattern -> expression -> expression
    val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression
    val apply: ?loc:loc -> ?attrs:attrs -> expression
               -> (arg_label * expression) list -> expression
    val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list
                -> expression
    val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression
    val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression
    val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option
                   -> expression
    val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option
                 -> expression
    val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list
                -> expression option -> expression
    val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression
    val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression
                  -> expression
    val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression
    val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression
                    -> expression option -> expression
    val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression
                  -> expression
    val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression
                -> expression
    val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression
              -> direction_flag -> expression -> expression
    val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option
                -> core_type -> expression
    val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type
                     -> expression
    val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression
    val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression
    val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
    val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list
                  -> expression
    val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression
                   -> expression
    val letexception:
      ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression
      -> expression
    val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression
    val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression
    val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option
              -> expression
    val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression
    val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
    val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression
    val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> expression
               -> expression
    val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression
    val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression

    val case: pattern -> ?guard:expression -> expression -> case
  end

(** Value declarations *)
module Val:
  sig
    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
      ?prim:string list -> str -> core_type -> value_description
  end

(** Type declarations *)
module Type:
  sig
    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
      ?params:(core_type * variance) list ->
      ?cstrs:(core_type * core_type * loc) list ->
      ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str ->
      type_declaration

    val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info ->
      ?args:constructor_arguments -> ?res:core_type -> str ->
      constructor_declaration
    val field: ?loc:loc -> ?attrs:attrs -> ?info:info ->
      ?mut:mutable_flag -> str -> core_type -> label_declaration
  end

(** Type extensions *)
module Te:
  sig
    val mk: ?attrs:attrs -> ?docs:docs ->
      ?params:(core_type * variance) list -> ?priv:private_flag ->
      lid -> extension_constructor list -> type_extension

    val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
      str -> extension_constructor_kind -> extension_constructor

    val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
      ?args:constructor_arguments -> ?res:core_type -> str ->
      extension_constructor
    val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
      str -> lid -> extension_constructor
  end

(** {1 Module language} *)

(** Module type expressions *)
module Mty:
  sig
    val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type
    val attr: module_type -> attribute -> module_type

    val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type
    val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type
    val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type
    val functor_: ?loc:loc -> ?attrs:attrs ->
      str -> module_type option -> module_type -> module_type
    val with_: ?loc:loc -> ?attrs:attrs -> module_type ->
      with_constraint list -> module_type
    val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type
    val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type
  end

(** Module expressions *)
module Mod:
  sig
    val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr
    val attr: module_expr -> attribute -> module_expr

    val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr
    val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr
    val functor_: ?loc:loc -> ?attrs:attrs ->
      str -> module_type option -> module_expr -> module_expr
    val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr ->
      module_expr
    val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type ->
      module_expr
    val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr
    val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr
  end

(** Signature items *)
module Sig:
  sig
    val mk: ?loc:loc -> signature_item_desc -> signature_item

    val value: ?loc:loc -> value_description -> signature_item
    val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item
    val type_extension: ?loc:loc -> type_extension -> signature_item
    val exception_: ?loc:loc -> extension_constructor -> signature_item
    val module_: ?loc:loc -> module_declaration -> signature_item
    val rec_module: ?loc:loc -> module_declaration list -> signature_item
    val modtype: ?loc:loc -> module_type_declaration -> signature_item
    val open_: ?loc:loc -> open_description -> signature_item
    val include_: ?loc:loc -> include_description -> signature_item
    val class_: ?loc:loc -> class_description list -> signature_item
    val class_type: ?loc:loc -> class_type_declaration list -> signature_item
    val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item
    val attribute: ?loc:loc -> attribute -> signature_item
    val text: text -> signature_item list
  end

(** Structure items *)
module Str:
  sig
    val mk: ?loc:loc -> structure_item_desc -> structure_item

    val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item
    val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item
    val primitive: ?loc:loc -> value_description -> structure_item
    val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item
    val type_extension: ?loc:loc -> type_extension -> structure_item
    val exception_: ?loc:loc -> extension_constructor -> structure_item
    val module_: ?loc:loc -> module_binding -> structure_item
    val rec_module: ?loc:loc -> module_binding list -> structure_item
    val modtype: ?loc:loc -> module_type_declaration -> structure_item
    val open_: ?loc:loc -> open_description -> structure_item
    val class_: ?loc:loc -> class_declaration list -> structure_item
    val class_type: ?loc:loc -> class_type_declaration list -> structure_item
    val include_: ?loc:loc -> include_declaration -> structure_item
    val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item
    val attribute: ?loc:loc -> attribute -> structure_item
    val text: text -> structure_item list
  end

(** Module declarations *)
module Md:
  sig
    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
      str -> module_type -> module_declaration
  end

(** Module type declarations *)
module Mtd:
  sig
    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
      ?typ:module_type -> str -> module_type_declaration
  end

(** Module bindings *)
module Mb:
  sig
    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
      str -> module_expr -> module_binding
  end

(** Opens *)
module Opn:
  sig
    val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs ->
      ?override:override_flag -> lid -> open_description
  end

(** Includes *)
module Incl:
  sig
    val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos
  end

(** Value bindings *)
module Vb:
  sig
    val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
      pattern -> expression -> value_binding
  end


(** {1 Class language} *)

(** Class type expressions *)
module Cty:
  sig
    val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type
    val attr: class_type -> attribute -> class_type

    val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type
    val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type
    val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type ->
      class_type -> class_type
    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type
    val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_type
               -> class_type
  end

(** Class type fields *)
module Ctf:
  sig
    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
      class_type_field_desc -> class_type_field
    val attr: class_type_field -> attribute -> class_type_field

    val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field
    val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag ->
      virtual_flag -> core_type -> class_type_field
    val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag ->
      virtual_flag -> core_type -> class_type_field
    val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type ->
      class_type_field
    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field
    val attribute: ?loc:loc -> attribute -> class_type_field
    val text: text -> class_type_field list
  end

(** Class expressions *)
module Cl:
  sig
    val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr
    val attr: class_expr -> attribute -> class_expr

    val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr
    val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr
    val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option ->
      pattern -> class_expr -> class_expr
    val apply: ?loc:loc -> ?attrs:attrs -> class_expr ->
      (arg_label * expression) list -> class_expr
    val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list ->
      class_expr -> class_expr
    val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type ->
      class_expr
    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr
    val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_expr
               -> class_expr
  end

(** Class fields *)
module Cf:
  sig
    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc ->
      class_field
    val attr: class_field -> attribute -> class_field

    val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr ->
      str option -> class_field
    val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag ->
      class_field_kind -> class_field
    val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag ->
      class_field_kind -> class_field
    val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type ->
      class_field
    val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field
    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field
    val attribute: ?loc:loc -> attribute -> class_field
    val text: text -> class_field list

    val virtual_: core_type -> class_field_kind
    val concrete: override_flag -> expression -> class_field_kind

  end

(** Classes *)
module Ci:
  sig
    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
      ?virt:virtual_flag -> ?params:(core_type * variance) list ->
      str -> 'a -> 'a class_infos
  end

(** Class signatures *)
module Csig:
  sig
    val mk: core_type -> class_type_field list -> class_signature
  end

(** Class structures *)
module Cstr:
  sig
    val mk: pattern -> class_field list -> class_structure
  end

end = struct
#1 "ast_helper.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                         Alain Frisch, LexiFi                           *)
(*                                                                        *)
(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Helpers to produce Parsetree fragments *)

open Asttypes
open Parsetree
open Docstrings

type lid = Longident.t loc
type str = string loc
type loc = Location.t
type attrs = attribute list

let default_loc = ref Location.none

let with_default_loc l f =
  let old = !default_loc in
  default_loc := l;
  try let r = f () in default_loc := old; r
  with exn -> default_loc := old; raise exn

module Const = struct
  let integer ?suffix i = Pconst_integer (i, suffix)
  let int ?suffix i = integer ?suffix (string_of_int i)
  let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i)
  let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i)
  let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i)
  let float ?suffix f = Pconst_float (f, suffix)
  let char c = Pconst_char c
  let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter)
end

module Typ = struct
  let mk ?(loc = !default_loc) ?(attrs = []) d =
    {ptyp_desc = d; ptyp_loc = loc; ptyp_attributes = attrs}
  let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]}

  let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any
  let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a)
  let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c))
  let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a)
  let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b))
  let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b))
  let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b))
  let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b))
  let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c))
  let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b))
  let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b))
  let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a)

  let force_poly t =
    match t.ptyp_desc with
    | Ptyp_poly _ -> t
    | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *)

  let varify_constructors var_names t =
    let check_variable vl loc v =
      if List.mem v vl then
        raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in
    let var_names = List.map (fun v -> v.txt) var_names in
    let rec loop t =
      let desc =
        match t.ptyp_desc with
        | Ptyp_any -> Ptyp_any
        | Ptyp_var x ->
            check_variable var_names t.ptyp_loc x;
            Ptyp_var x
        | Ptyp_arrow (label,core_type,core_type') ->
            Ptyp_arrow(label, loop core_type, loop core_type')
        | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)
        | Ptyp_constr( { txt = Longident.Lident s }, [])
          when List.mem s var_names ->
            Ptyp_var s
        | Ptyp_constr(longident, lst) ->
            Ptyp_constr(longident, List.map loop lst)
        | Ptyp_object (lst, o) ->
            Ptyp_object (List.map loop_object_field lst, o)
        | Ptyp_class (longident, lst) ->
            Ptyp_class (longident, List.map loop lst)
        | Ptyp_alias(core_type, string) ->
            check_variable var_names t.ptyp_loc string;
            Ptyp_alias(loop core_type, string)
        | Ptyp_variant(row_field_list, flag, lbl_lst_option) ->
            Ptyp_variant(List.map loop_row_field row_field_list,
                         flag, lbl_lst_option)
        | Ptyp_poly(string_lst, core_type) ->
          List.iter (fun v ->
            check_variable var_names t.ptyp_loc v.txt) string_lst;
            Ptyp_poly(string_lst, loop core_type)
        | Ptyp_package(longident,lst) ->
            Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst)
        | Ptyp_extension (s, arg) ->
            Ptyp_extension (s, arg)
      in
      {t with ptyp_desc = desc}
    and loop_row_field  =
      function
        | Rtag(label,attrs,flag,lst) ->
            Rtag(label,attrs,flag,List.map loop lst)
        | Rinherit t ->
            Rinherit (loop t)
    and loop_object_field =
      function
        | Otag(label, attrs, t) ->
            Otag(label, attrs, loop t)
        | Oinherit t ->
            Oinherit (loop t)
    in
    loop t

end

module Pat = struct
  let mk ?(loc = !default_loc) ?(attrs = []) d =
    {ppat_desc = d; ppat_loc = loc; ppat_attributes = attrs}
  let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]}

  let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any
  let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a)
  let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b))
  let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a)
  let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b))
  let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a)
  let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b))
  let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b))
  let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b))
  let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a)
  let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b))
  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b))
  let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a)
  let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a)
  let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a)
  let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b))
  let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a)
  let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a)
end

module Exp = struct
  let mk ?(loc = !default_loc) ?(attrs = []) d =
    {pexp_desc = d; pexp_loc = loc; pexp_attributes = attrs}
  let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]}

  let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a)
  let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a)
  let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c))
  let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d))
  let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a)
  let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b))
  let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b))
  let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b))
  let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a)
  let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b))
  let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b))
  let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b))
  let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b))
  let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c))
  let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a)
  let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c))
  let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b))
  let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b))
  let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e))
  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b))
  let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c))
  let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b))
  let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a)
  let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b))
  let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a)
  let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c))
  let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b))
  let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a)
  let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a)
  let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b))
  let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a)
  let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b))
  let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a)
  let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_open (a, b, c))
  let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a)
  let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable

  let case lhs ?guard rhs =
    {
     pc_lhs = lhs;
     pc_guard = guard;
     pc_rhs = rhs;
    }
end

module Mty = struct
  let mk ?(loc = !default_loc) ?(attrs = []) d =
    {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs}
  let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]}

  let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a)
  let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a)
  let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a)
  let functor_ ?loc ?attrs a b c = mk ?loc ?attrs (Pmty_functor (a, b, c))
  let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b))
  let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a)
  let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a)
end

module Mod = struct
let mk ?(loc = !default_loc) ?(attrs = []) d =
  {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs}
  let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]}

  let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x)
  let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x)
  let functor_ ?loc ?attrs arg arg_ty body =
    mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body))
  let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2))
  let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty))
  let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e)
  let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a)
end

module Sig = struct
  let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc}

  let value ?loc a = mk ?loc (Psig_value a)
  let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a))
  let type_extension ?loc a = mk ?loc (Psig_typext a)
  let exception_ ?loc a = mk ?loc (Psig_exception a)
  let module_ ?loc a = mk ?loc (Psig_module a)
  let rec_module ?loc a = mk ?loc (Psig_recmodule a)
  let modtype ?loc a = mk ?loc (Psig_modtype a)
  let open_ ?loc a = mk ?loc (Psig_open a)
  let include_ ?loc a = mk ?loc (Psig_include a)
  let class_ ?loc a = mk ?loc (Psig_class a)
  let class_type ?loc a = mk ?loc (Psig_class_type a)
  let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs))
  let attribute ?loc a = mk ?loc (Psig_attribute a)
  let text txt =
    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
    List.map
      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
      f_txt
end

module Str = struct
  let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc}

  let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs))
  let value ?loc a b = mk ?loc (Pstr_value (a, b))
  let primitive ?loc a = mk ?loc (Pstr_primitive a)
  let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a))
  let type_extension ?loc a = mk ?loc (Pstr_typext a)
  let exception_ ?loc a = mk ?loc (Pstr_exception a)
  let module_ ?loc a = mk ?loc (Pstr_module a)
  let rec_module ?loc a = mk ?loc (Pstr_recmodule a)
  let modtype ?loc a = mk ?loc (Pstr_modtype a)
  let open_ ?loc a = mk ?loc (Pstr_open a)
  let class_ ?loc a = mk ?loc (Pstr_class a)
  let class_type ?loc a = mk ?loc (Pstr_class_type a)
  let include_ ?loc a = mk ?loc (Pstr_include a)
  let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs))
  let attribute ?loc a = mk ?loc (Pstr_attribute a)
  let text txt =
    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
    List.map
      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
      f_txt
end

module Cl = struct
  let mk ?(loc = !default_loc) ?(attrs = []) d =
    {
     pcl_desc = d;
     pcl_loc = loc;
     pcl_attributes = attrs;
    }
  let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]}

  let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b))
  let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a)
  let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d))
  let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b))
  let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c))
  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b))
  let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a)
  let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_open (a, b, c))
end

module Cty = struct
  let mk ?(loc = !default_loc) ?(attrs = []) d =
    {
     pcty_desc = d;
     pcty_loc = loc;
     pcty_attributes = attrs;
    }
  let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]}

  let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b))
  let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a)
  let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c))
  let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a)
  let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_open (a, b, c))
end

module Ctf = struct
  let mk ?(loc = !default_loc) ?(attrs = [])
           ?(docs = empty_docs) d =
    {
     pctf_desc = d;
     pctf_loc = loc;
     pctf_attributes = add_docs_attrs docs attrs;
    }

  let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a)
  let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d))
  let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d))
  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b))
  let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a)
  let attribute ?loc a = mk ?loc (Pctf_attribute a)
  let text txt =
   let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
     List.map
      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
      f_txt

  let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]}

end

module Cf = struct
  let mk ?(loc = !default_loc) ?(attrs = [])
        ?(docs = empty_docs) d =
    {
     pcf_desc = d;
     pcf_loc = loc;
     pcf_attributes = add_docs_attrs docs attrs;
    }

  let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c))
  let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c))
  let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c))
  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b))
  let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a)
  let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a)
  let attribute ?loc a = mk ?loc (Pcf_attribute a)
  let text txt =
    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
    List.map
      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
      f_txt

  let virtual_ ct = Cfk_virtual ct
  let concrete o e = Cfk_concrete (o, e)

  let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]}

end

module Val = struct
  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
        ?(prim = []) name typ =
    {
     pval_name = name;
     pval_type = typ;
     pval_attributes = add_docs_attrs docs attrs;
     pval_loc = loc;
     pval_prim = prim;
    }
end

module Md = struct
  let mk ?(loc = !default_loc) ?(attrs = [])
        ?(docs = empty_docs) ?(text = []) name typ =
    {
     pmd_name = name;
     pmd_type = typ;
     pmd_attributes =
       add_text_attrs text (add_docs_attrs docs attrs);
     pmd_loc = loc;
    }
end

module Mtd = struct
  let mk ?(loc = !default_loc) ?(attrs = [])
        ?(docs = empty_docs) ?(text = []) ?typ name =
    {
     pmtd_name = name;
     pmtd_type = typ;
     pmtd_attributes =
       add_text_attrs text (add_docs_attrs docs attrs);
     pmtd_loc = loc;
    }
end

module Mb = struct
  let mk ?(loc = !default_loc) ?(attrs = [])
        ?(docs = empty_docs) ?(text = []) name expr =
    {
     pmb_name = name;
     pmb_expr = expr;
     pmb_attributes =
       add_text_attrs text (add_docs_attrs docs attrs);
     pmb_loc = loc;
    }
end

module Opn = struct
  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
        ?(override = Fresh) lid =
    {
     popen_lid = lid;
     popen_override = override;
     popen_loc = loc;
     popen_attributes = add_docs_attrs docs attrs;
    }
end

module Incl = struct
  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr =
    {
     pincl_mod = mexpr;
     pincl_loc = loc;
     pincl_attributes = add_docs_attrs docs attrs;
    }

end

module Vb = struct
  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
        ?(text = []) pat expr =
    {
     pvb_pat = pat;
     pvb_expr = expr;
     pvb_attributes =
       add_text_attrs text (add_docs_attrs docs attrs);
     pvb_loc = loc;
    }
end

module Ci = struct
  let mk ?(loc = !default_loc) ?(attrs = [])
        ?(docs = empty_docs) ?(text = [])
        ?(virt = Concrete) ?(params = []) name expr =
    {
     pci_virt = virt;
     pci_params = params;
     pci_name = name;
     pci_expr = expr;
     pci_attributes =
       add_text_attrs text (add_docs_attrs docs attrs);
     pci_loc = loc;
    }
end

module Type = struct
  let mk ?(loc = !default_loc) ?(attrs = [])
        ?(docs = empty_docs) ?(text = [])
      ?(params = [])
      ?(cstrs = [])
      ?(kind = Ptype_abstract)
      ?(priv = Public)
      ?manifest
      name =
    {
     ptype_name = name;
     ptype_params = params;
     ptype_cstrs = cstrs;
     ptype_kind = kind;
     ptype_private = priv;
     ptype_manifest = manifest;
     ptype_attributes =
       add_text_attrs text (add_docs_attrs docs attrs);
     ptype_loc = loc;
    }

  let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info)
        ?(args = Pcstr_tuple []) ?res name =
    {
     pcd_name = name;
     pcd_args = args;
     pcd_res = res;
     pcd_loc = loc;
     pcd_attributes = add_info_attrs info attrs;
    }

  let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info)
        ?(mut = Immutable) name typ =
    {
     pld_name = name;
     pld_mutable = mut;
     pld_type = typ;
     pld_loc = loc;
     pld_attributes = add_info_attrs info attrs;
    }

end

(** Type extensions *)
module Te = struct
  let mk ?(attrs = []) ?(docs = empty_docs)
        ?(params = []) ?(priv = Public) path constructors =
    {
     ptyext_path = path;
     ptyext_params = params;
     ptyext_constructors = constructors;
     ptyext_private = priv;
     ptyext_attributes = add_docs_attrs docs attrs;
    }

  let constructor ?(loc = !default_loc) ?(attrs = [])
        ?(docs = empty_docs) ?(info = empty_info) name kind =
    {
     pext_name = name;
     pext_kind = kind;
     pext_loc = loc;
     pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
    }

  let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
             ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name =
    {
     pext_name = name;
     pext_kind = Pext_decl(args, res);
     pext_loc = loc;
     pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
    }

  let rebind ?(loc = !default_loc) ?(attrs = [])
        ?(docs = empty_docs) ?(info = empty_info) name lid =
    {
     pext_name = name;
     pext_kind = Pext_rebind lid;
     pext_loc = loc;
     pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
    }

end

module Csig = struct
  let mk self fields =
    {
     pcsig_self = self;
     pcsig_fields = fields;
    }
end

module Cstr = struct
  let mk self fields =
    {
     pcstr_self = self;
     pcstr_fields = fields;
    }
end

end
module Parser : sig 
#1 "parser.mli"
type token =
  | AMPERAMPER
  | AMPERSAND
  | AND
  | AS
  | ASSERT
  | BACKQUOTE
  | BANG
  | BAR
  | BARBAR
  | BARRBRACKET
  | BEGIN
  | CHAR of (char)
  | CLASS
  | COLON
  | COLONCOLON
  | COLONEQUAL
  | COLONGREATER
  | COMMA
  | CONSTRAINT
  | DO
  | DONE
  | DOT
  | DOTDOT
  | DOWNTO
  | ELSE
  | END
  | EOF
  | EQUAL
  | EXCEPTION
  | EXTERNAL
  | FALSE
  | FLOAT of (string * char option)
  | FOR
  | FUN
  | FUNCTION
  | FUNCTOR
  | GREATER
  | GREATERRBRACE
  | GREATERRBRACKET
  | IF
  | IN
  | INCLUDE
  | INFIXOP0 of (string)
  | INFIXOP1 of (string)
  | INFIXOP2 of (string)
  | INFIXOP3 of (string)
  | INFIXOP4 of (string)
  | DOTOP of (string)
  | INHERIT
  | INITIALIZER
  | INT of (string * char option)
  | LABEL of (string)
  | LAZY
  | LBRACE
  | LBRACELESS
  | LBRACKET
  | LBRACKETBAR
  | LBRACKETLESS
  | LBRACKETGREATER
  | LBRACKETPERCENT
  | LBRACKETPERCENTPERCENT
  | LESS
  | LESSMINUS
  | LET
  | LIDENT of (string)
  | LPAREN
  | LBRACKETAT
  | LBRACKETATAT
  | LBRACKETATATAT
  | MATCH
  | METHOD
  | MINUS
  | MINUSDOT
  | MINUSGREATER
  | MODULE
  | MUTABLE
  | NEW
  | NONREC
  | OBJECT
  | OF
  | OPEN
  | OPTLABEL of (string)
  | OR
  | PERCENT
  | PLUS
  | PLUSDOT
  | PLUSEQ
  | PREFIXOP of (string)
  | PRIVATE
  | QUESTION
  | QUOTE
  | RBRACE
  | RBRACKET
  | REC
  | RPAREN
  | SEMI
  | SEMISEMI
  | HASH
  | HASHOP of (string)
  | SIG
  | STAR
  | STRING of (string * string option)
  | STRUCT
  | THEN
  | TILDE
  | TO
  | TRUE
  | TRY
  | TYPE
  | UIDENT of (string)
  | UNDERSCORE
  | VAL
  | VIRTUAL
  | WHEN
  | WHILE
  | WITH
  | COMMENT of (string * Location.t)
  | DOCSTRING of (Docstrings.docstring)
  | EOL

val implementation :
  (Lexing.lexbuf  -> token) -> Lexing.lexbuf -> Parsetree.structure
val interface :
  (Lexing.lexbuf  -> token) -> Lexing.lexbuf -> Parsetree.signature
val toplevel_phrase :
  (Lexing.lexbuf  -> token) -> Lexing.lexbuf -> Parsetree.toplevel_phrase
val use_file :
  (Lexing.lexbuf  -> token) -> Lexing.lexbuf -> Parsetree.toplevel_phrase list
val parse_core_type :
  (Lexing.lexbuf  -> token) -> Lexing.lexbuf -> Parsetree.core_type
val parse_expression :
  (Lexing.lexbuf  -> token) -> Lexing.lexbuf -> Parsetree.expression
val parse_pattern :
  (Lexing.lexbuf  -> token) -> Lexing.lexbuf -> Parsetree.pattern

end = struct
#1 "parser.ml"
type token =
  | AMPERAMPER
  | AMPERSAND
  | AND
  | AS
  | ASSERT
  | BACKQUOTE
  | BANG
  | BAR
  | BARBAR
  | BARRBRACKET
  | BEGIN
  | CHAR of (char)
  | CLASS
  | COLON
  | COLONCOLON
  | COLONEQUAL
  | COLONGREATER
  | COMMA
  | CONSTRAINT
  | DO
  | DONE
  | DOT
  | DOTDOT
  | DOWNTO
  | ELSE
  | END
  | EOF
  | EQUAL
  | EXCEPTION
  | EXTERNAL
  | FALSE
  | FLOAT of (string * char option)
  | FOR
  | FUN
  | FUNCTION
  | FUNCTOR
  | GREATER
  | GREATERRBRACE
  | GREATERRBRACKET
  | IF
  | IN
  | INCLUDE
  | INFIXOP0 of (string)
  | INFIXOP1 of (string)
  | INFIXOP2 of (string)
  | INFIXOP3 of (string)
  | INFIXOP4 of (string)
  | DOTOP of (string)
  | INHERIT
  | INITIALIZER
  | INT of (string * char option)
  | LABEL of (string)
  | LAZY
  | LBRACE
  | LBRACELESS
  | LBRACKET
  | LBRACKETBAR
  | LBRACKETLESS
  | LBRACKETGREATER
  | LBRACKETPERCENT
  | LBRACKETPERCENTPERCENT
  | LESS
  | LESSMINUS
  | LET
  | LIDENT of (string)
  | LPAREN
  | LBRACKETAT
  | LBRACKETATAT
  | LBRACKETATATAT
  | MATCH
  | METHOD
  | MINUS
  | MINUSDOT
  | MINUSGREATER
  | MODULE
  | MUTABLE
  | NEW
  | NONREC
  | OBJECT
  | OF
  | OPEN
  | OPTLABEL of (string)
  | OR
  | PERCENT
  | PLUS
  | PLUSDOT
  | PLUSEQ
  | PREFIXOP of (string)
  | PRIVATE
  | QUESTION
  | QUOTE
  | RBRACE
  | RBRACKET
  | REC
  | RPAREN
  | SEMI
  | SEMISEMI
  | HASH
  | HASHOP of (string)
  | SIG
  | STAR
  | STRING of (string * string option)
  | STRUCT
  | THEN
  | TILDE
  | TO
  | TRUE
  | TRY
  | TYPE
  | UIDENT of (string)
  | UNDERSCORE
  | VAL
  | VIRTUAL
  | WHEN
  | WHILE
  | WITH
  | COMMENT of (string * Location.t)
  | DOCSTRING of (Docstrings.docstring)
  | EOL

open Parsing;;
let _ = parse_error;;
# 19 "parsing/parser.mly"
open Location
open Asttypes
open Longident
open Parsetree
open Ast_helper
open Docstrings

let mktyp d = Typ.mk ~loc:(symbol_rloc()) d
let mkpat d = Pat.mk ~loc:(symbol_rloc()) d
let mkexp d = Exp.mk ~loc:(symbol_rloc()) d
let mkmty ?attrs d = Mty.mk ~loc:(symbol_rloc()) ?attrs d
let mksig d = Sig.mk ~loc:(symbol_rloc()) d
let mkmod ?attrs d = Mod.mk ~loc:(symbol_rloc()) ?attrs d
let mkstr d = Str.mk ~loc:(symbol_rloc()) d
let mkclass ?attrs d = Cl.mk ~loc:(symbol_rloc()) ?attrs d
let mkcty ?attrs d = Cty.mk ~loc:(symbol_rloc()) ?attrs d
let mkctf ?attrs ?docs d =
  Ctf.mk ~loc:(symbol_rloc()) ?attrs ?docs d
let mkcf ?attrs ?docs d =
  Cf.mk ~loc:(symbol_rloc()) ?attrs ?docs d

let mkrhs rhs pos = mkloc rhs (rhs_loc pos)

let reloc_pat x = { x with ppat_loc = symbol_rloc () };;
let reloc_exp x = { x with pexp_loc = symbol_rloc () };;

let mkoperator name pos =
  let loc = rhs_loc pos in
  Exp.mk ~loc (Pexp_ident(mkloc (Lident name) loc))

let mkpatvar name pos =
  Pat.mk ~loc:(rhs_loc pos) (Ppat_var (mkrhs name pos))

(*
  Ghost expressions and patterns:
  expressions and patterns that do not appear explicitly in the
  source file they have the loc_ghost flag set to true.
  Then the profiler will not try to instrument them and the
  -annot option will not try to display their type.

  Every grammar rule that generates an element with a location must
  make at most one non-ghost element, the topmost one.

  How to tell whether your location must be ghost:
  A location corresponds to a range of characters in the source file.
  If the location contains a piece of code that is syntactically
  valid (according to the documentation), and corresponds to the
  AST node, then the location must be real; in all other cases,
  it must be ghost.
*)
let ghexp d = Exp.mk ~loc:(symbol_gloc ()) d
let ghpat d = Pat.mk ~loc:(symbol_gloc ()) d
let ghtyp d = Typ.mk ~loc:(symbol_gloc ()) d
let ghloc d = { txt = d; loc = symbol_gloc () }
let ghstr d = Str.mk ~loc:(symbol_gloc()) d
let ghsig d = Sig.mk ~loc:(symbol_gloc()) d

let mkinfix arg1 name arg2 =
  mkexp(Pexp_apply(mkoperator name 2, [Nolabel, arg1; Nolabel, arg2]))

let neg_string f =
  if String.length f > 0 && f.[0] = '-'
  then String.sub f 1 (String.length f - 1)
  else "-" ^ f

let mkuminus name arg =
  match name, arg.pexp_desc with
  | "-", Pexp_constant(Pconst_integer (n,m)) ->
      mkexp(Pexp_constant(Pconst_integer(neg_string n,m)))
  | ("-" | "-."), Pexp_constant(Pconst_float (f, m)) ->
      mkexp(Pexp_constant(Pconst_float(neg_string f, m)))
  | _ ->
      mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg]))

let mkuplus name arg =
  let desc = arg.pexp_desc in
  match name, desc with
  | "+", Pexp_constant(Pconst_integer _)
  | ("+" | "+."), Pexp_constant(Pconst_float _) -> mkexp desc
  | _ ->
      mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg]))

let mkexp_cons consloc args loc =
  Exp.mk ~loc (Pexp_construct(mkloc (Lident "::") consloc, Some args))

let mkpat_cons consloc args loc =
  Pat.mk ~loc (Ppat_construct(mkloc (Lident "::") consloc, Some args))

let rec mktailexp nilloc = function
    [] ->
      let loc = { nilloc with loc_ghost = true } in
      let nil = { txt = Lident "[]"; loc = loc } in
      Exp.mk ~loc (Pexp_construct (nil, None))
  | e1 :: el ->
      let exp_el = mktailexp nilloc el in
      let loc = {loc_start = e1.pexp_loc.loc_start;
               loc_end = exp_el.pexp_loc.loc_end;
               loc_ghost = true}
      in
      let arg = Exp.mk ~loc (Pexp_tuple [e1; exp_el]) in
      mkexp_cons {loc with loc_ghost = true} arg loc

let rec mktailpat nilloc = function
    [] ->
      let loc = { nilloc with loc_ghost = true } in
      let nil = { txt = Lident "[]"; loc = loc } in
      Pat.mk ~loc (Ppat_construct (nil, None))
  | p1 :: pl ->
      let pat_pl = mktailpat nilloc pl in
      let loc = {loc_start = p1.ppat_loc.loc_start;
               loc_end = pat_pl.ppat_loc.loc_end;
               loc_ghost = true}
      in
      let arg = Pat.mk ~loc (Ppat_tuple [p1; pat_pl]) in
      mkpat_cons {loc with loc_ghost = true} arg loc

let mkstrexp e attrs =
  { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc }

let mkexp_constraint e (t1, t2) =
  match t1, t2 with
  | Some t, None -> ghexp(Pexp_constraint(e, t))
  | _, Some t -> ghexp(Pexp_coerce(e, t1, t))
  | None, None -> assert false

let mkexp_opt_constraint e = function
  | None -> e
  | Some constraint_ -> mkexp_constraint e constraint_

let mkpat_opt_constraint p = function
  | None -> p
  | Some typ -> mkpat (Ppat_constraint(p, typ))

let array_function str name =
  ghloc (Ldot(Lident str, (if !Clflags.fast then "unsafe_" ^ name else name)))

let syntax_error () =
  raise Syntaxerr.Escape_error

let unclosed opening_name opening_num closing_name closing_num =
  raise(Syntaxerr.Error(Syntaxerr.Unclosed(rhs_loc opening_num, opening_name,
                                           rhs_loc closing_num, closing_name)))

let expecting pos nonterm =
    raise Syntaxerr.(Error(Expecting(rhs_loc pos, nonterm)))

let not_expecting pos nonterm =
    raise Syntaxerr.(Error(Not_expecting(rhs_loc pos, nonterm)))

let bigarray_function str name =
  ghloc (Ldot(Ldot(Lident "Bigarray", str), name))

let bigarray_untuplify = function
    { pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist
  | exp -> [exp]

let bigarray_get arr arg =
  let get = if !Clflags.fast then "unsafe_get" else "get" in
  match bigarray_untuplify arg with
    [c1] ->
      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" get)),
                       [Nolabel, arr; Nolabel, c1]))
  | [c1;c2] ->
      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" get)),
                       [Nolabel, arr; Nolabel, c1; Nolabel, c2]))
  | [c1;c2;c3] ->
      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" get)),
                       [Nolabel, arr; Nolabel, c1; Nolabel, c2; Nolabel, c3]))
  | coords ->
      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "get")),
                       [Nolabel, arr; Nolabel, ghexp(Pexp_array coords)]))

let bigarray_set arr arg newval =
  let set = if !Clflags.fast then "unsafe_set" else "set" in
  match bigarray_untuplify arg with
    [c1] ->
      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" set)),
                       [Nolabel, arr; Nolabel, c1; Nolabel, newval]))
  | [c1;c2] ->
      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" set)),
                       [Nolabel, arr; Nolabel, c1;
                        Nolabel, c2; Nolabel, newval]))
  | [c1;c2;c3] ->
      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" set)),
                       [Nolabel, arr; Nolabel, c1;
                        Nolabel, c2; Nolabel, c3; Nolabel, newval]))
  | coords ->
      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "set")),
                       [Nolabel, arr;
                        Nolabel, ghexp(Pexp_array coords);
                        Nolabel, newval]))

let lapply p1 p2 =
  if !Clflags.applicative_functors
  then Lapply(p1, p2)
  else raise (Syntaxerr.Error(Syntaxerr.Applicative_path (symbol_rloc())))

let exp_of_label lbl pos =
  mkexp (Pexp_ident(mkrhs (Lident(Longident.last lbl)) pos))

let pat_of_label lbl pos =
  mkpat (Ppat_var (mkrhs (Longident.last lbl) pos))

let mk_newtypes newtypes exp =
  List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp)))
    newtypes exp

let wrap_type_annotation newtypes core_type body =
  let exp = mkexp(Pexp_constraint(body,core_type)) in
  let exp = mk_newtypes newtypes exp in
  (exp, ghtyp(Ptyp_poly(newtypes, Typ.varify_constructors newtypes core_type)))

let wrap_exp_attrs body (ext, attrs) =
  (* todo: keep exact location for the entire attribute *)
  let body = {body with pexp_attributes = attrs @ body.pexp_attributes} in
  match ext with
  | None -> body
  | Some id -> ghexp(Pexp_extension (id, PStr [mkstrexp body []]))

let mkexp_attrs d attrs =
  wrap_exp_attrs (mkexp d) attrs

let wrap_typ_attrs typ (ext, attrs) =
  (* todo: keep exact location for the entire attribute *)
  let typ = {typ with ptyp_attributes = attrs @ typ.ptyp_attributes} in
  match ext with
  | None -> typ
  | Some id -> ghtyp(Ptyp_extension (id, PTyp typ))

let mktyp_attrs d attrs =
  wrap_typ_attrs (mktyp d) attrs

let wrap_pat_attrs pat (ext, attrs) =
  (* todo: keep exact location for the entire attribute *)
  let pat = {pat with ppat_attributes = attrs @ pat.ppat_attributes} in
  match ext with
  | None -> pat
  | Some id -> ghpat(Ppat_extension (id, PPat (pat, None)))

let mkpat_attrs d attrs =
  wrap_pat_attrs (mkpat d) attrs

let wrap_class_attrs body attrs =
  {body with pcl_attributes = attrs @ body.pcl_attributes}
let wrap_class_type_attrs body attrs =
  {body with pcty_attributes = attrs @ body.pcty_attributes}
let wrap_mod_attrs body attrs =
  {body with pmod_attributes = attrs @ body.pmod_attributes}
let wrap_mty_attrs body attrs =
  {body with pmty_attributes = attrs @ body.pmty_attributes}

let wrap_str_ext body ext =
  match ext with
  | None -> body
  | Some id -> ghstr(Pstr_extension ((id, PStr [body]), []))

let mkstr_ext d ext =
  wrap_str_ext (mkstr d) ext

let wrap_sig_ext body ext =
  match ext with
  | None -> body
  | Some id -> ghsig(Psig_extension ((id, PSig [body]), []))

let mksig_ext d ext =
  wrap_sig_ext (mksig d) ext

let text_str pos = Str.text (rhs_text pos)
let text_sig pos = Sig.text (rhs_text pos)
let text_cstr pos = Cf.text (rhs_text pos)
let text_csig pos = Ctf.text (rhs_text pos)
let text_def pos = [Ptop_def (Str.text (rhs_text pos))]

let extra_text text pos items =
  let pre_extras = rhs_pre_extra_text pos in
  let post_extras = rhs_post_extra_text pos in
    text pre_extras @ items @ text post_extras

let extra_str pos items = extra_text Str.text pos items
let extra_sig pos items = extra_text Sig.text pos items
let extra_cstr pos items = extra_text Cf.text pos items
let extra_csig pos items = extra_text Ctf.text pos items
let extra_def pos items =
  extra_text (fun txt -> [Ptop_def (Str.text txt)]) pos items

let extra_rhs_core_type ct ~pos =
  let docs = rhs_info pos in
  { ct with ptyp_attributes = add_info_attrs docs ct.ptyp_attributes }

type let_binding =
  { lb_pattern: pattern;
    lb_expression: expression;
    lb_attributes: attributes;
    lb_docs: docs Lazy.t;
    lb_text: text Lazy.t;
    lb_loc: Location.t; }

type let_bindings =
  { lbs_bindings: let_binding list;
    lbs_rec: rec_flag;
    lbs_extension: string Asttypes.loc option;
    lbs_loc: Location.t }

let mklb first (p, e) attrs =
  { lb_pattern = p;
    lb_expression = e;
    lb_attributes = attrs;
    lb_docs = symbol_docs_lazy ();
    lb_text = if first then empty_text_lazy
              else symbol_text_lazy ();
    lb_loc = symbol_rloc (); }

let mklbs ext rf lb =
  { lbs_bindings = [lb];
    lbs_rec = rf;
    lbs_extension = ext ;
    lbs_loc = symbol_rloc (); }

let addlb lbs lb =
  { lbs with lbs_bindings = lb :: lbs.lbs_bindings }

let val_of_let_bindings lbs =
  let bindings =
    List.map
      (fun lb ->
         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
           ~docs:(Lazy.force lb.lb_docs)
           ~text:(Lazy.force lb.lb_text)
           lb.lb_pattern lb.lb_expression)
      lbs.lbs_bindings
  in
  let str = mkstr(Pstr_value(lbs.lbs_rec, List.rev bindings)) in
  match lbs.lbs_extension with
  | None -> str
  | Some id -> ghstr (Pstr_extension((id, PStr [str]), []))

let expr_of_let_bindings lbs body =
  let bindings =
    List.map
      (fun lb ->
         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
           lb.lb_pattern lb.lb_expression)
      lbs.lbs_bindings
  in
    mkexp_attrs (Pexp_let(lbs.lbs_rec, List.rev bindings, body))
      (lbs.lbs_extension, [])

let class_of_let_bindings lbs body =
  let bindings =
    List.map
      (fun lb ->
         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
           lb.lb_pattern lb.lb_expression)
      lbs.lbs_bindings
  in
    if lbs.lbs_extension <> None then
      raise Syntaxerr.(Error(Not_expecting(lbs.lbs_loc, "extension")));
    mkclass(Pcl_let (lbs.lbs_rec, List.rev bindings, body))


(* Alternatively, we could keep the generic module type in the Parsetree
   and extract the package type during type-checking. In that case,
   the assertions below should be turned into explicit checks. *)
let package_type_of_module_type pmty =
  let err loc s =
    raise (Syntaxerr.Error (Syntaxerr.Invalid_package_type (loc, s)))
  in
  let map_cstr = function
    | Pwith_type (lid, ptyp) ->
        let loc = ptyp.ptype_loc in
        if ptyp.ptype_params <> [] then
          err loc "parametrized types are not supported";
        if ptyp.ptype_cstrs <> [] then
          err loc "constrained types are not supported";
        if ptyp.ptype_private <> Public then
          err loc "private types are not supported";

        (* restrictions below are checked by the 'with_constraint' rule *)
        assert (ptyp.ptype_kind = Ptype_abstract);
        assert (ptyp.ptype_attributes = []);
        let ty =
          match ptyp.ptype_manifest with
          | Some ty -> ty
          | None -> assert false
        in
        (lid, ty)
    | _ ->
        err pmty.pmty_loc "only 'with type t =' constraints are supported"
  in
  match pmty with
  | {pmty_desc = Pmty_ident lid} -> (lid, [])
  | {pmty_desc = Pmty_with({pmty_desc = Pmty_ident lid}, cstrs)} ->
      (lid, List.map map_cstr cstrs)
  | _ ->
      err pmty.pmty_loc
        "only module type identifier and 'with type' constraints are supported"


# 524 "parsing/parser.ml"
let yytransl_const = [|
  257 (* AMPERAMPER *);
  258 (* AMPERSAND *);
  259 (* AND *);
  260 (* AS *);
  261 (* ASSERT *);
  262 (* BACKQUOTE *);
  263 (* BANG *);
  264 (* BAR *);
  265 (* BARBAR *);
  266 (* BARRBRACKET *);
  267 (* BEGIN *);
  269 (* CLASS *);
  270 (* COLON *);
  271 (* COLONCOLON *);
  272 (* COLONEQUAL *);
  273 (* COLONGREATER *);
  274 (* COMMA *);
  275 (* CONSTRAINT *);
  276 (* DO *);
  277 (* DONE *);
  278 (* DOT *);
  279 (* DOTDOT *);
  280 (* DOWNTO *);
  281 (* ELSE *);
  282 (* END *);
    0 (* EOF *);
  283 (* EQUAL *);
  284 (* EXCEPTION *);
  285 (* EXTERNAL *);
  286 (* FALSE *);
  288 (* FOR *);
  289 (* FUN *);
  290 (* FUNCTION *);
  291 (* FUNCTOR *);
  292 (* GREATER *);
  293 (* GREATERRBRACE *);
  294 (* GREATERRBRACKET *);
  295 (* IF *);
  296 (* IN *);
  297 (* INCLUDE *);
  304 (* INHERIT *);
  305 (* INITIALIZER *);
  308 (* LAZY *);
  309 (* LBRACE *);
  310 (* LBRACELESS *);
  311 (* LBRACKET *);
  312 (* LBRACKETBAR *);
  313 (* LBRACKETLESS *);
  314 (* LBRACKETGREATER *);
  315 (* LBRACKETPERCENT *);
  316 (* LBRACKETPERCENTPERCENT *);
  317 (* LESS *);
  318 (* LESSMINUS *);
  319 (* LET *);
  321 (* LPAREN *);
  322 (* LBRACKETAT *);
  323 (* LBRACKETATAT *);
  324 (* LBRACKETATATAT *);
  325 (* MATCH *);
  326 (* METHOD *);
  327 (* MINUS *);
  328 (* MINUSDOT *);
  329 (* MINUSGREATER *);
  330 (* MODULE *);
  331 (* MUTABLE *);
  332 (* NEW *);
  333 (* NONREC *);
  334 (* OBJECT *);
  335 (* OF *);
  336 (* OPEN *);
  338 (* OR *);
  339 (* PERCENT *);
  340 (* PLUS *);
  341 (* PLUSDOT *);
  342 (* PLUSEQ *);
  344 (* PRIVATE *);
  345 (* QUESTION *);
  346 (* QUOTE *);
  347 (* RBRACE *);
  348 (* RBRACKET *);
  349 (* REC *);
  350 (* RPAREN *);
  351 (* SEMI *);
  352 (* SEMISEMI *);
  353 (* HASH *);
  355 (* SIG *);
  356 (* STAR *);
  358 (* STRUCT *);
  359 (* THEN *);
  360 (* TILDE *);
  361 (* TO *);
  362 (* TRUE *);
  363 (* TRY *);
  364 (* TYPE *);
  366 (* UNDERSCORE *);
  367 (* VAL *);
  368 (* VIRTUAL *);
  369 (* WHEN *);
  370 (* WHILE *);
  371 (* WITH *);
  374 (* EOL *);
    0|]

let yytransl_block = [|
  268 (* CHAR *);
  287 (* FLOAT *);
  298 (* INFIXOP0 *);
  299 (* INFIXOP1 *);
  300 (* INFIXOP2 *);
  301 (* INFIXOP3 *);
  302 (* INFIXOP4 *);
  303 (* DOTOP *);
  306 (* INT *);
  307 (* LABEL *);
  320 (* LIDENT *);
  337 (* OPTLABEL *);
  343 (* PREFIXOP *);
  354 (* HASHOP *);
  357 (* STRING *);
  365 (* UIDENT *);
  372 (* COMMENT *);
  373 (* DOCSTRING *);
    0|]

let yylhs = "\255\255\
\001\000\002\000\003\000\003\000\003\000\010\000\010\000\014\000\
\014\000\004\000\016\000\016\000\017\000\017\000\017\000\017\000\
\017\000\017\000\017\000\005\000\006\000\007\000\020\000\020\000\
\021\000\021\000\023\000\023\000\024\000\024\000\024\000\024\000\
\024\000\024\000\024\000\024\000\024\000\027\000\027\000\027\000\
\027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\
\008\000\008\000\032\000\032\000\032\000\015\000\015\000\015\000\
\015\000\015\000\015\000\015\000\015\000\015\000\015\000\015\000\
\015\000\015\000\015\000\015\000\045\000\049\000\049\000\049\000\
\039\000\040\000\040\000\050\000\051\000\022\000\022\000\022\000\
\022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\
\009\000\009\000\009\000\054\000\054\000\054\000\054\000\054\000\
\054\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\
\054\000\054\000\042\000\060\000\063\000\063\000\063\000\057\000\
\058\000\059\000\059\000\064\000\065\000\066\000\066\000\041\000\
\043\000\043\000\068\000\069\000\072\000\072\000\072\000\071\000\
\071\000\077\000\077\000\073\000\073\000\073\000\073\000\073\000\
\073\000\073\000\078\000\078\000\078\000\078\000\078\000\078\000\
\078\000\078\000\082\000\083\000\083\000\083\000\084\000\084\000\
\085\000\085\000\085\000\085\000\085\000\085\000\085\000\086\000\
\086\000\087\000\087\000\087\000\087\000\088\000\088\000\088\000\
\088\000\088\000\074\000\074\000\074\000\074\000\074\000\097\000\
\097\000\097\000\097\000\097\000\097\000\097\000\100\000\101\000\
\101\000\102\000\102\000\103\000\103\000\103\000\103\000\103\000\
\103\000\104\000\104\000\104\000\106\000\089\000\061\000\061\000\
\107\000\108\000\044\000\044\000\109\000\110\000\012\000\012\000\
\012\000\012\000\075\000\075\000\075\000\075\000\075\000\075\000\
\075\000\075\000\116\000\116\000\113\000\113\000\112\000\112\000\
\114\000\115\000\115\000\030\000\030\000\030\000\030\000\030\000\
\030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\
\030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\
\030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\
\030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\
\030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\
\030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\
\030\000\030\000\030\000\030\000\030\000\030\000\118\000\118\000\
\118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\
\118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\
\118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\
\118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\
\118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\
\118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\
\118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\
\118\000\118\000\118\000\118\000\118\000\118\000\079\000\079\000\
\136\000\136\000\137\000\137\000\137\000\137\000\138\000\096\000\
\096\000\139\000\139\000\139\000\139\000\139\000\139\000\033\000\
\033\000\144\000\145\000\147\000\147\000\095\000\095\000\095\000\
\121\000\121\000\148\000\148\000\148\000\122\000\122\000\122\000\
\122\000\123\000\123\000\132\000\132\000\150\000\150\000\150\000\
\151\000\151\000\135\000\135\000\153\000\153\000\133\000\133\000\
\092\000\092\000\092\000\092\000\092\000\152\000\152\000\019\000\
\019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\
\019\000\142\000\142\000\142\000\142\000\142\000\142\000\142\000\
\142\000\142\000\155\000\155\000\155\000\155\000\117\000\117\000\
\143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\
\143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\
\143\000\143\000\143\000\143\000\143\000\143\000\159\000\159\000\
\159\000\159\000\159\000\159\000\159\000\154\000\154\000\154\000\
\156\000\156\000\156\000\161\000\161\000\160\000\160\000\160\000\
\160\000\162\000\162\000\163\000\163\000\035\000\164\000\164\000\
\034\000\036\000\036\000\165\000\166\000\170\000\170\000\169\000\
\169\000\169\000\169\000\169\000\169\000\169\000\169\000\169\000\
\169\000\169\000\168\000\168\000\168\000\173\000\174\000\174\000\
\176\000\176\000\177\000\175\000\175\000\175\000\178\000\076\000\
\076\000\171\000\171\000\171\000\179\000\180\000\038\000\038\000\
\056\000\119\000\182\000\182\000\182\000\182\000\183\000\183\000\
\172\000\172\000\172\000\185\000\186\000\037\000\055\000\188\000\
\188\000\188\000\188\000\188\000\188\000\189\000\189\000\189\000\
\190\000\191\000\192\000\193\000\053\000\053\000\194\000\194\000\
\194\000\194\000\195\000\195\000\141\000\141\000\093\000\093\000\
\187\000\187\000\018\000\018\000\196\000\196\000\198\000\198\000\
\198\000\198\000\198\000\149\000\149\000\199\000\199\000\199\000\
\199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\
\199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\
\031\000\202\000\202\000\203\000\203\000\201\000\201\000\205\000\
\205\000\206\000\206\000\204\000\204\000\098\000\098\000\080\000\
\080\000\184\000\184\000\200\000\200\000\200\000\200\000\200\000\
\200\000\200\000\209\000\207\000\208\000\090\000\131\000\131\000\
\131\000\131\000\157\000\157\000\157\000\157\000\157\000\067\000\
\067\000\140\000\140\000\140\000\140\000\140\000\210\000\210\000\
\210\000\210\000\210\000\210\000\210\000\210\000\210\000\210\000\
\210\000\210\000\210\000\210\000\210\000\210\000\210\000\210\000\
\210\000\210\000\210\000\210\000\210\000\210\000\210\000\210\000\
\210\000\210\000\210\000\181\000\181\000\181\000\181\000\181\000\
\181\000\130\000\130\000\124\000\124\000\124\000\124\000\124\000\
\124\000\124\000\129\000\129\000\158\000\158\000\025\000\025\000\
\197\000\197\000\197\000\052\000\052\000\099\000\099\000\081\000\
\081\000\011\000\011\000\011\000\011\000\011\000\011\000\011\000\
\125\000\146\000\146\000\167\000\167\000\126\000\126\000\094\000\
\094\000\091\000\091\000\070\000\070\000\105\000\105\000\105\000\
\105\000\105\000\062\000\062\000\120\000\120\000\134\000\134\000\
\127\000\127\000\128\000\128\000\211\000\211\000\211\000\211\000\
\211\000\211\000\211\000\211\000\211\000\211\000\211\000\211\000\
\211\000\211\000\211\000\211\000\211\000\211\000\211\000\211\000\
\211\000\211\000\211\000\211\000\211\000\211\000\211\000\211\000\
\211\000\211\000\211\000\211\000\211\000\211\000\211\000\211\000\
\211\000\211\000\211\000\211\000\211\000\211\000\211\000\211\000\
\211\000\211\000\211\000\211\000\211\000\211\000\211\000\111\000\
\111\000\028\000\213\000\047\000\013\000\013\000\026\000\026\000\
\048\000\048\000\048\000\029\000\046\000\212\000\212\000\212\000\
\212\000\212\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000"

let yylen = "\002\000\
\002\000\002\000\002\000\002\000\001\000\002\000\001\000\000\000\
\002\000\001\000\001\000\003\000\001\000\002\000\004\000\003\000\
\003\000\002\000\002\000\002\000\002\000\002\000\002\000\005\000\
\001\000\001\000\002\000\001\000\001\000\004\000\004\000\005\000\
\002\000\003\000\001\000\002\000\001\000\005\000\005\000\003\000\
\003\000\005\000\007\000\009\000\007\000\006\000\006\000\005\000\
\003\000\001\000\000\000\002\000\002\000\001\000\001\000\001\000\
\001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\
\001\000\001\000\002\000\001\000\004\000\002\000\004\000\002\000\
\005\000\001\000\002\000\006\000\005\000\001\000\004\000\004\000\
\005\000\003\000\003\000\005\000\003\000\003\000\001\000\002\000\
\000\000\002\000\002\000\001\000\001\000\001\000\001\000\001\000\
\001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\
\002\000\001\000\005\000\004\000\002\000\006\000\003\000\005\000\
\006\000\001\000\002\000\007\000\006\000\000\000\002\000\006\000\
\001\000\002\000\007\000\007\000\002\000\004\000\002\000\000\000\
\003\000\003\000\002\000\001\000\003\000\002\000\003\000\007\000\
\002\000\001\000\004\000\001\000\004\000\004\000\005\000\005\000\
\003\000\003\000\002\000\003\000\005\000\000\000\000\000\002\000\
\006\000\003\000\003\000\004\000\004\000\002\000\001\000\002\000\
\000\000\007\000\007\000\006\000\007\000\007\000\007\000\005\000\
\008\000\011\000\001\000\006\000\004\000\005\000\003\000\004\000\
\001\000\004\000\004\000\002\000\001\000\007\000\002\000\003\000\
\000\000\000\000\002\000\004\000\004\000\007\000\004\000\002\000\
\001\000\005\000\005\000\003\000\003\000\003\000\001\000\002\000\
\008\000\008\000\001\000\002\000\009\000\008\000\001\000\002\000\
\003\000\005\000\005\000\002\000\005\000\002\000\004\000\002\000\
\002\000\001\000\001\000\001\000\000\000\002\000\001\000\003\000\
\001\000\001\000\003\000\001\000\002\000\003\000\007\000\006\000\
\007\000\004\000\004\000\007\000\006\000\006\000\005\000\001\000\
\002\000\002\000\007\000\005\000\006\000\010\000\003\000\003\000\
\003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\
\003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\
\003\000\003\000\003\000\002\000\002\000\005\000\007\000\007\000\
\007\000\007\000\007\000\007\000\009\000\009\000\009\000\003\000\
\003\000\003\000\004\000\004\000\002\000\001\000\001\000\001\000\
\001\000\001\000\003\000\003\000\004\000\003\000\004\000\004\000\
\003\000\005\000\004\000\005\000\005\000\005\000\005\000\005\000\
\005\000\005\000\005\000\005\000\005\000\005\000\007\000\007\000\
\007\000\007\000\007\000\007\000\005\000\005\000\003\000\003\000\
\005\000\005\000\004\000\004\000\002\000\006\000\004\000\006\000\
\004\000\004\000\006\000\004\000\006\000\002\000\002\000\003\000\
\003\000\003\000\002\000\005\000\004\000\005\000\003\000\003\000\
\005\000\007\000\006\000\009\000\008\000\001\000\001\000\002\000\
\001\000\001\000\002\000\002\000\002\000\002\000\001\000\001\000\
\002\000\002\000\004\000\007\000\008\000\003\000\005\000\001\000\
\002\000\005\000\004\000\001\000\003\000\002\000\002\000\005\000\
\001\000\003\000\003\000\005\000\003\000\002\000\004\000\002\000\
\005\000\003\000\003\000\003\000\001\000\001\000\003\000\002\000\
\004\000\002\000\002\000\003\000\003\000\001\000\001\000\003\000\
\002\000\004\000\002\000\002\000\002\000\001\000\000\000\003\000\
\003\000\001\000\003\000\003\000\003\000\003\000\003\000\002\000\
\001\000\003\000\003\000\001\000\003\000\003\000\003\000\003\000\
\002\000\001\000\001\000\002\000\002\000\003\000\001\000\001\000\
\001\000\001\000\003\000\001\000\001\000\002\000\001\000\003\000\
\004\000\004\000\005\000\005\000\004\000\003\000\003\000\005\000\
\005\000\004\000\005\000\007\000\007\000\001\000\003\000\003\000\
\004\000\004\000\004\000\002\000\004\000\003\000\003\000\003\000\
\003\000\003\000\003\000\001\000\003\000\001\000\002\000\004\000\
\003\000\004\000\002\000\002\000\000\000\006\000\001\000\002\000\
\008\000\001\000\002\000\008\000\007\000\003\000\000\000\000\000\
\002\000\003\000\002\000\003\000\002\000\003\000\005\000\005\000\
\005\000\007\000\000\000\001\000\003\000\002\000\001\000\003\000\
\002\000\001\000\002\000\000\000\001\000\001\000\002\000\001\000\
\003\000\001\000\001\000\002\000\003\000\004\000\001\000\007\000\
\006\000\003\000\000\000\002\000\004\000\002\000\001\000\003\000\
\001\000\001\000\002\000\005\000\007\000\009\000\009\000\001\000\
\001\000\001\000\001\000\002\000\002\000\001\000\001\000\002\000\
\003\000\004\000\004\000\005\000\001\000\003\000\006\000\005\000\
\004\000\004\000\001\000\002\000\002\000\003\000\001\000\003\000\
\001\000\003\000\001\000\002\000\001\000\004\000\001\000\006\000\
\004\000\005\000\003\000\001\000\003\000\002\000\001\000\001\000\
\002\000\004\000\003\000\002\000\002\000\003\000\005\000\003\000\
\004\000\005\000\004\000\002\000\004\000\006\000\005\000\001\000\
\001\000\001\000\003\000\001\000\001\000\005\000\002\000\001\000\
\000\000\001\000\003\000\001\000\002\000\001\000\003\000\001\000\
\003\000\001\000\003\000\002\000\002\000\001\000\001\000\001\000\
\001\000\001\000\004\000\006\000\002\000\001\000\001\000\001\000\
\001\000\001\000\001\000\002\000\002\000\002\000\002\000\001\000\
\001\000\001\000\003\000\003\000\002\000\003\000\001\000\001\000\
\001\000\001\000\001\000\001\000\003\000\004\000\003\000\004\000\
\003\000\004\000\001\000\001\000\001\000\001\000\001\000\001\000\
\001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\
\001\000\001\000\001\000\001\000\002\000\002\000\003\000\001\000\
\001\000\001\000\003\000\001\000\005\000\002\000\002\000\003\000\
\001\000\001\000\001\000\003\000\001\000\003\000\001\000\003\000\
\001\000\003\000\004\000\001\000\003\000\001\000\003\000\001\000\
\003\000\002\000\003\000\003\000\003\000\003\000\003\000\003\000\
\002\000\000\000\001\000\000\000\001\000\001\000\001\000\000\000\
\001\000\000\000\001\000\000\000\001\000\000\000\001\000\001\000\
\002\000\002\000\000\000\001\000\000\000\001\000\000\000\001\000\
\001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\
\001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\
\001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\
\001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\
\001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\
\001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\
\001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\
\003\000\004\000\004\000\004\000\000\000\002\000\000\000\002\000\
\000\000\002\000\003\000\004\000\004\000\001\000\002\000\002\000\
\002\000\004\000\002\000\002\000\002\000\002\000\002\000\002\000\
\002\000"

let yydefred = "\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\112\002\000\000\000\000\000\000\
\169\002\114\002\000\000\000\000\000\000\000\000\000\000\111\002\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\217\002\218\002\000\000\000\000\
\000\000\000\000\219\002\220\002\000\000\000\000\113\002\170\002\
\000\000\000\000\175\002\030\001\000\000\000\000\035\003\000\000\
\000\000\000\000\000\000\094\001\000\000\050\000\000\000\055\000\
\056\000\000\000\058\000\059\000\060\000\000\000\062\000\063\000\
\000\000\000\000\066\000\000\000\068\000\074\000\007\002\121\000\
\000\000\203\000\000\000\000\000\000\000\000\000\000\000\000\000\
\031\001\032\001\162\002\112\001\226\001\000\000\000\000\000\000\
\000\000\000\000\000\000\036\003\000\000\093\000\092\000\000\000\
\100\000\101\000\000\000\000\000\106\000\000\000\095\000\096\000\
\097\000\098\000\000\000\102\000\000\000\114\000\199\000\005\000\
\000\000\037\003\000\000\000\000\000\000\007\000\000\000\013\000\
\000\000\038\003\000\000\000\000\000\000\010\000\011\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\177\002\063\002\039\003\000\000\080\002\055\002\000\000\
\064\002\051\002\000\000\000\000\000\000\040\003\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\122\002\000\000\000\000\
\000\000\000\000\177\001\041\003\000\000\000\000\198\001\171\001\
\000\000\000\000\115\002\175\001\176\001\000\000\161\001\000\000\
\183\001\000\000\000\000\000\000\000\000\121\002\120\002\193\002\
\079\001\033\001\034\001\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\133\001\000\000\083\001\110\002\000\000\
\000\000\000\000\166\002\000\000\000\000\069\001\000\000\223\002\
\224\002\225\002\226\002\227\002\228\002\229\002\230\002\231\002\
\232\002\233\002\234\002\235\002\236\002\237\002\238\002\239\002\
\240\002\241\002\242\002\243\002\244\002\245\002\246\002\247\002\
\221\002\248\002\249\002\250\002\251\002\252\002\253\002\254\002\
\255\002\000\003\001\003\002\003\003\003\004\003\005\003\006\003\
\007\003\008\003\009\003\010\003\222\002\011\003\012\003\013\003\
\014\003\015\003\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\125\002\152\002\151\002\000\000\150\002\000\000\153\002\
\146\002\148\002\128\002\129\002\130\002\131\002\132\002\000\000\
\147\002\000\000\000\000\000\000\149\002\155\002\000\000\000\000\
\154\002\000\000\167\002\139\002\145\002\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\212\002\000\000\078\001\
\052\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\
\000\000\000\000\053\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\029\001\000\000\000\000\113\001\
\000\000\227\001\000\000\075\000\000\000\122\000\000\000\204\000\
\067\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\095\001\098\001\000\000\000\000\
\000\000\012\001\013\001\000\000\000\000\000\000\000\000\090\000\
\000\000\002\000\105\000\091\000\000\000\115\000\000\000\200\000\
\000\000\003\000\004\000\006\000\009\000\014\000\000\000\000\000\
\000\000\019\000\000\000\018\000\000\000\173\002\000\000\085\002\
\000\000\000\000\214\002\000\000\076\002\000\000\106\002\068\002\
\000\000\000\000\000\000\000\000\000\000\000\000\103\002\000\000\
\000\000\000\000\000\000\000\000\000\000\062\002\184\002\000\000\
\069\002\020\000\052\002\000\000\000\000\000\000\000\000\000\000\
\000\000\065\002\021\000\000\000\000\000\171\002\000\000\000\000\
\000\000\000\000\000\000\000\000\204\001\000\000\140\002\000\000\
\144\002\000\000\000\000\142\002\127\002\000\000\117\002\116\002\
\119\002\118\002\182\001\000\000\000\000\000\000\000\000\022\000\
\160\001\000\000\172\001\173\001\000\000\000\000\000\000\000\000\
\026\003\000\000\000\000\000\000\000\000\038\001\000\000\000\000\
\205\002\000\000\160\002\000\000\000\000\161\002\156\002\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\218\000\180\001\181\001\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\035\000\037\000\000\000\000\000\000\000\
\000\000\000\000\150\001\000\000\064\001\063\001\000\000\000\000\
\082\001\081\001\000\000\139\001\000\000\000\000\000\000\000\000\
\000\000\030\003\000\000\000\000\000\000\000\000\000\000\000\000\
\195\002\000\000\168\002\000\000\000\000\000\000\126\002\000\000\
\036\001\035\001\000\000\124\002\123\002\000\000\000\000\000\000\
\000\000\000\000\080\001\000\000\000\000\151\000\000\000\000\000\
\197\002\000\000\000\000\000\000\000\000\049\000\022\003\000\000\
\000\000\000\000\000\000\000\000\176\002\163\002\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\209\000\000\000\000\000\230\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\103\001\
\101\001\087\001\000\000\100\001\096\001\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\087\000\078\000\
\180\002\000\000\000\000\000\000\000\000\000\000\000\000\191\002\
\188\002\187\002\192\002\000\000\189\002\017\000\000\000\016\000\
\012\000\084\002\000\000\082\002\000\000\087\002\072\002\000\000\
\000\000\000\000\000\000\109\002\067\002\100\002\101\002\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\098\002\000\000\
\174\002\178\002\000\000\000\000\000\000\070\002\159\001\174\001\
\000\000\000\000\000\000\200\001\199\001\000\000\000\000\000\000\
\000\000\000\000\191\001\000\000\190\001\153\001\152\001\158\001\
\000\000\156\001\000\000\208\001\000\000\000\000\000\000\184\001\
\000\000\179\001\000\000\027\003\024\003\000\000\000\000\000\000\
\000\000\041\001\000\000\000\000\000\000\039\001\037\001\000\000\
\000\000\000\000\157\002\000\000\158\002\000\000\000\000\000\000\
\000\000\143\002\000\000\141\002\000\000\000\000\217\000\000\000\
\219\000\000\000\220\000\214\000\225\000\000\000\212\000\000\000\
\216\000\000\000\000\000\000\000\000\000\235\000\000\000\000\000\
\121\001\000\000\000\000\000\000\000\000\000\000\000\000\069\000\
\033\000\036\000\000\000\000\000\132\001\148\001\000\000\149\001\
\000\000\000\000\135\001\000\000\140\001\000\000\074\001\073\001\
\068\001\067\001\031\003\000\000\000\000\028\003\017\003\029\003\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\170\001\000\000\000\000\000\000\000\000\000\000\040\001\020\003\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\028\001\027\001\000\000\000\000\000\000\000\000\254\001\
\253\001\000\000\244\001\000\000\000\000\000\000\000\000\000\000\
\085\001\000\000\076\001\000\000\071\001\000\000\000\000\000\000\
\043\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\108\000\088\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\015\000\000\000\073\002\088\002\
\000\000\000\000\000\000\077\002\075\002\000\000\000\000\000\000\
\049\002\000\000\000\000\000\000\000\000\000\000\066\002\000\000\
\000\000\185\002\000\000\000\000\179\002\054\002\172\002\000\000\
\000\000\000\000\217\001\000\000\202\001\201\001\205\001\203\001\
\000\000\194\001\000\000\185\001\189\001\186\001\000\000\018\003\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\002\000\000\159\002\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\012\002\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\126\001\128\001\000\000\000\000\000\000\000\000\
\028\000\000\000\000\000\041\000\000\000\040\000\000\000\034\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\114\001\
\000\000\000\000\000\000\000\000\000\000\106\001\000\000\000\000\
\000\000\000\000\000\000\169\001\000\000\000\000\138\002\136\002\
\134\002\000\000\089\001\000\000\000\000\000\000\000\000\000\000\
\000\000\023\000\025\000\026\000\000\000\072\000\073\000\000\000\
\148\000\000\000\000\000\000\000\000\000\000\000\000\000\159\000\
\152\000\107\000\239\000\000\000\247\001\000\000\000\000\000\000\
\000\000\250\001\246\001\000\000\000\000\019\003\066\001\065\001\
\086\001\084\001\000\000\000\000\165\002\000\000\044\001\042\001\
\210\000\115\001\000\000\000\000\000\000\000\000\000\000\062\001\
\048\001\000\000\046\001\000\000\000\000\000\000\000\000\000\000\
\054\001\000\000\050\001\000\000\052\001\000\000\000\000\000\000\
\086\000\085\000\000\000\000\000\000\000\000\000\000\000\000\000\
\037\002\000\000\181\002\000\000\000\000\000\000\000\000\000\000\
\112\000\000\000\000\000\000\000\083\002\090\002\000\000\074\002\
\092\002\000\000\000\000\000\000\000\000\000\000\000\000\079\002\
\071\002\000\000\099\002\000\000\216\002\216\001\000\000\195\001\
\193\001\192\001\188\001\187\001\061\001\047\001\045\001\000\000\
\000\000\000\000\053\001\049\001\051\001\000\000\000\000\129\000\
\000\000\251\001\000\000\000\000\000\000\000\000\203\002\000\000\
\000\000\017\002\000\000\000\000\000\000\000\000\009\002\000\000\
\199\002\198\002\000\000\105\001\000\000\000\000\000\000\000\000\
\000\000\000\000\215\000\000\000\000\000\125\001\123\001\000\000\
\122\001\000\000\000\000\027\000\000\000\000\000\031\000\030\000\
\000\000\034\003\232\000\010\002\000\000\000\000\000\000\000\000\
\118\001\000\000\000\000\116\001\119\001\000\000\163\001\162\001\
\168\001\000\000\166\001\000\000\211\001\000\000\110\001\000\000\
\000\000\091\001\000\000\000\000\000\000\120\000\076\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\158\000\000\000\000\000\245\001\000\000\231\001\000\000\
\249\001\222\001\245\000\077\001\075\001\072\001\070\001\000\000\
\231\001\077\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\080\000\079\000\000\000\000\000\000\000\000\000\113\000\111\000\
\000\000\000\000\000\000\000\000\000\000\086\002\078\002\093\002\
\050\002\046\002\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\001\002\255\001\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\177\000\000\000\000\000\
\000\000\000\000\000\000\000\000\138\000\000\000\000\000\000\000\
\140\000\123\000\127\000\000\000\016\002\019\002\013\002\000\000\
\008\002\000\000\000\000\000\000\236\000\000\000\222\000\213\000\
\211\000\000\000\127\001\000\000\000\000\000\000\000\000\048\000\
\000\000\000\000\042\000\039\000\038\000\231\000\233\000\000\000\
\000\000\000\000\000\000\107\001\000\000\090\001\000\000\000\000\
\149\000\000\000\000\000\000\000\000\000\000\000\155\000\000\000\
\154\000\248\001\000\000\237\001\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\002\002\003\002\000\000\000\000\201\002\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\060\001\000\000\056\001\000\000\058\001\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\038\002\
\116\000\000\000\000\000\117\000\000\000\091\002\108\002\197\001\
\196\001\059\001\055\001\057\001\000\000\182\002\181\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\180\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\137\000\000\000\000\000\224\001\225\001\000\000\
\129\001\124\001\046\000\000\000\047\000\000\000\000\000\000\000\
\000\000\117\001\111\001\024\000\000\000\156\000\000\000\157\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\238\001\
\000\000\000\000\000\000\000\000\004\002\000\000\000\000\228\001\
\000\000\000\000\000\000\024\002\025\002\026\002\027\002\093\001\
\000\000\229\001\124\000\000\000\000\000\000\000\000\000\201\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\030\002\031\002\000\000\205\000\000\000\000\000\000\000\
\000\000\000\000\000\000\186\000\000\000\000\000\000\000\175\000\
\000\000\000\000\133\000\000\000\000\000\146\000\000\000\145\000\
\000\000\000\000\000\000\000\000\000\000\043\000\045\000\000\000\
\000\000\120\001\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\005\002\000\000\
\230\001\000\000\000\000\000\000\022\002\028\002\029\002\092\001\
\206\000\000\000\000\000\000\000\040\002\044\002\231\001\110\000\
\000\000\023\002\032\002\202\000\183\002\176\000\000\000\000\000\
\000\000\179\000\178\000\000\000\173\000\000\000\000\000\131\000\
\139\000\000\000\000\000\142\000\141\000\000\000\246\000\000\000\
\000\000\108\001\160\000\153\000\000\000\000\000\000\000\168\000\
\000\000\000\000\000\000\000\000\006\002\241\001\000\000\000\000\
\239\001\000\000\000\000\000\000\000\000\033\002\000\000\000\000\
\174\000\184\000\000\000\000\000\000\000\000\000\000\000\193\000\
\187\000\000\000\000\000\000\000\144\000\143\000\000\000\044\000\
\109\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\164\000\000\000\000\000\000\000\000\000\034\002\035\002\
\000\000\000\000\000\000\000\000\000\000\192\000\172\000\000\000\
\021\002\166\000\167\000\000\000\000\000\000\000\000\000\000\000\
\165\000\242\001\036\002\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\169\000\
\000\000\191\000\188\000\209\002\210\002\000\000\000\000\000\000\
\000\000\189\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\170\000\190\000\000\000\000\000"

let yydgoto = "\008\000\
\055\000\100\000\122\000\130\000\148\000\158\000\172\000\034\002\
\101\000\123\000\131\000\057\000\072\001\126\000\058\000\134\000\
\135\000\178\001\214\001\055\003\245\003\131\003\202\003\005\003\
\059\000\233\001\012\002\101\001\060\000\061\000\132\003\062\000\
\160\000\064\000\065\000\066\000\067\000\068\000\069\000\070\000\
\071\000\072\000\073\000\074\000\075\000\076\000\077\000\025\001\
\056\003\078\000\108\001\136\002\056\004\110\000\111\000\079\000\
\113\000\114\000\115\000\116\000\117\000\063\001\112\003\118\000\
\142\001\238\003\137\002\080\000\110\001\242\001\226\002\109\004\
\007\005\251\004\253\002\169\003\211\005\008\005\123\001\179\001\
\009\005\061\002\062\002\060\003\001\004\229\005\185\004\183\004\
\051\005\081\000\112\004\155\004\070\006\066\005\156\004\187\003\
\252\004\151\000\254\004\203\005\204\005\012\006\057\006\109\006\
\105\006\241\005\119\000\144\001\082\000\112\001\019\001\190\003\
\128\004\191\003\189\003\244\002\176\000\083\000\033\003\164\001\
\000\003\254\002\084\000\085\000\086\000\123\004\087\000\088\000\
\210\000\089\000\090\000\211\000\221\000\028\002\217\000\125\001\
\126\001\121\002\037\003\091\000\071\006\039\003\181\000\092\000\
\104\001\042\002\157\004\001\003\152\000\212\000\213\000\020\002\
\218\000\182\000\183\000\042\003\184\000\153\000\185\000\201\001\
\204\001\202\001\187\002\019\005\093\000\106\001\066\002\066\003\
\191\004\071\005\067\005\113\004\067\003\006\004\068\003\011\004\
\171\003\106\004\068\005\069\005\070\005\233\002\176\003\177\003\
\114\004\115\004\128\003\171\005\193\005\172\005\173\005\174\005\
\175\005\057\004\189\005\154\000\155\000\156\000\157\000\172\001\
\154\002\155\002\156\002\074\004\121\003\071\004\173\001\174\001\
\175\001\055\001\020\001\035\002\073\001"

let yysindex = "\141\009\
\228\067\075\007\170\051\083\051\204\051\233\070\196\074\000\000\
\155\005\110\002\080\074\155\005\000\000\184\003\155\005\155\005\
\000\000\000\000\155\005\155\005\155\005\155\005\155\005\000\000\
\155\005\225\076\083\004\058\068\146\068\170\063\170\063\014\004\
\000\000\024\061\170\063\155\005\000\000\000\000\087\005\155\005\
\155\005\134\255\000\000\000\000\080\074\228\067\000\000\000\000\
\155\005\155\005\000\000\000\000\155\005\155\005\000\000\160\000\
\229\255\096\018\048\000\000\000\151\080\000\000\108\004\000\000\
\000\000\195\000\000\000\000\000\000\000\075\001\000\000\000\000\
\110\001\176\001\000\000\229\255\000\000\000\000\000\000\000\000\
\171\000\000\000\105\076\218\001\080\074\080\074\233\070\233\070\
\000\000\000\000\000\000\000\000\000\000\184\003\155\005\155\005\
\087\005\075\007\155\005\000\000\049\003\000\000\000\000\195\000\
\000\000\000\000\176\001\229\255\000\000\075\007\000\000\000\000\
\000\000\000\000\128\002\000\000\177\002\000\000\000\000\000\000\
\110\002\000\000\137\002\160\002\229\255\000\000\143\005\000\000\
\035\052\000\000\171\007\229\255\171\007\000\000\000\000\151\044\
\000\004\085\255\082\013\202\003\041\048\204\051\206\003\110\002\
\058\003\000\000\000\000\000\000\070\000\000\000\000\000\222\003\
\000\000\000\000\030\002\126\001\097\003\000\000\071\005\108\004\
\155\005\155\005\208\003\199\073\006\074\000\000\136\065\090\003\
\235\005\069\004\000\000\000\000\175\000\106\004\000\000\000\000\
\196\074\196\074\000\000\000\000\000\000\162\004\000\000\154\004\
\000\000\170\063\170\063\116\004\080\074\000\000\000\000\000\000\
\000\000\000\000\000\000\231\068\155\005\147\004\023\002\116\003\
\196\074\244\072\000\004\233\070\143\002\080\074\000\000\002\005\
\070\001\197\003\149\255\000\000\241\004\000\000\000\000\092\005\
\146\004\046\005\000\000\110\081\057\005\000\000\057\005\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\141\067\192\005\141\067\155\005\155\005\134\255\
\162\005\000\000\000\000\000\000\080\074\000\000\154\005\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\203\006\
\000\000\000\000\000\000\131\001\000\000\000\000\000\000\000\000\
\000\000\080\074\000\000\000\000\000\000\156\000\166\255\141\067\
\233\070\155\005\184\005\058\003\001\006\000\000\155\005\000\000\
\000\000\233\070\211\005\116\003\233\070\000\000\170\063\096\018\
\229\255\155\005\000\000\075\006\209\005\233\070\233\070\233\070\
\233\070\233\070\233\070\233\070\233\070\233\070\233\070\233\070\
\233\070\233\070\233\070\233\070\233\070\233\070\233\070\233\070\
\233\070\233\070\060\069\233\070\000\000\116\004\233\070\000\000\
\116\004\000\000\116\004\000\000\116\004\000\000\116\004\000\000\
\000\000\233\070\169\004\225\006\080\074\080\074\027\006\068\006\
\080\074\027\006\165\076\043\002\000\000\000\000\233\070\043\002\
\043\002\000\000\000\000\147\004\023\002\075\004\236\005\000\000\
\211\005\000\000\000\000\000\000\116\004\000\000\116\004\000\000\
\195\003\000\000\000\000\000\000\000\000\000\000\171\007\229\255\
\171\007\000\000\171\007\000\000\136\012\000\000\130\005\000\000\
\042\006\138\006\000\000\136\012\000\000\136\012\000\000\000\000\
\000\000\134\006\060\006\133\006\170\040\170\040\000\000\204\051\
\155\005\116\004\009\001\104\006\167\006\000\000\000\000\164\006\
\000\000\000\000\000\000\216\041\077\004\081\006\098\006\204\051\
\058\003\000\000\000\000\196\074\009\076\000\000\173\006\179\006\
\206\255\107\006\070\005\109\006\000\000\109\006\000\000\090\003\
\000\000\131\001\235\005\000\000\000\000\102\002\000\000\000\000\
\000\000\000\000\000\000\033\002\031\066\092\066\153\066\000\000\
\000\000\176\003\000\000\000\000\196\074\242\001\141\067\116\004\
\000\000\116\004\043\002\058\005\231\006\000\000\041\003\147\004\
\000\000\153\006\000\000\119\006\140\000\000\000\000\000\078\002\
\188\077\208\006\178\003\009\076\059\064\125\002\245\005\050\006\
\048\072\000\000\000\000\000\000\196\074\110\006\116\004\254\003\
\116\004\026\007\205\006\000\000\000\000\043\002\255\007\208\003\
\202\009\124\017\000\000\202\006\000\000\000\000\208\003\233\070\
\000\000\000\000\068\006\000\000\233\070\104\255\211\004\013\082\
\196\074\000\000\149\006\170\063\155\006\023\002\142\006\155\005\
\000\000\116\075\000\000\157\006\161\006\175\006\000\000\143\002\
\000\000\000\000\182\006\000\000\000\000\163\006\166\006\110\002\
\158\006\084\003\000\000\196\074\120\003\000\000\186\006\189\006\
\000\000\092\006\252\006\006\007\141\067\000\000\000\000\225\076\
\038\005\145\069\233\069\135\061\000\000\000\000\235\081\235\081\
\203\081\110\013\110\081\203\081\184\012\184\012\184\012\184\012\
\053\004\255\006\255\006\184\012\053\004\053\004\203\081\255\006\
\053\004\053\004\053\004\170\063\000\000\255\006\116\075\000\000\
\092\006\207\006\147\004\147\004\110\081\233\070\233\070\233\070\
\252\001\249\006\233\070\233\070\233\070\043\002\043\002\000\000\
\000\000\000\000\065\004\000\000\000\000\203\081\153\006\151\255\
\116\004\075\004\213\006\116\004\000\000\163\002\000\000\000\000\
\000\000\175\002\216\006\041\004\092\006\221\006\147\004\000\000\
\000\000\000\000\000\000\055\007\000\000\000\000\171\007\000\000\
\000\000\000\000\253\255\000\000\078\007\000\000\000\000\136\012\
\127\001\112\000\120\054\000\000\000\000\000\000\000\000\008\007\
\075\004\204\051\015\005\204\051\204\051\135\004\000\000\239\006\
\000\000\000\000\220\001\110\002\022\007\000\000\000\000\000\000\
\194\004\204\051\070\007\000\000\000\000\203\004\196\074\174\000\
\024\006\247\006\000\000\254\046\000\000\000\000\000\000\000\000\
\141\002\000\000\091\007\000\000\035\002\067\074\226\065\000\000\
\035\002\000\000\015\007\000\000\000\000\233\070\233\070\233\070\
\160\005\000\000\233\070\233\070\233\070\000\000\000\000\153\006\
\237\005\044\007\000\000\018\007\000\000\013\041\179\002\013\041\
\116\004\000\000\114\007\000\000\204\051\233\070\000\000\051\007\
\000\000\196\074\000\000\000\000\000\000\053\007\000\000\053\007\
\000\000\216\041\170\064\233\070\048\072\000\000\182\255\111\007\
\000\000\233\070\056\007\116\004\033\001\228\067\247\002\000\000\
\000\000\000\000\017\007\000\000\000\000\000\000\108\255\000\000\
\116\004\233\070\000\000\110\081\000\000\110\081\000\000\000\000\
\000\000\000\000\000\000\116\004\247\000\000\000\000\000\000\000\
\087\007\151\255\084\003\186\006\229\255\216\071\239\004\115\007\
\000\000\110\007\068\007\069\007\071\007\139\001\000\000\000\000\
\000\004\109\007\084\003\075\004\143\002\150\005\084\003\229\255\
\210\002\000\000\000\000\167\001\183\002\018\000\237\005\000\000\
\000\000\209\004\000\000\136\002\204\051\233\070\047\007\242\255\
\000\000\251\004\000\000\057\005\000\000\057\005\046\007\131\001\
\000\000\184\255\233\070\229\255\077\007\084\003\153\006\153\006\
\212\080\151\001\192\000\194\255\245\006\233\070\011\078\043\078\
\121\078\080\007\056\007\119\255\063\007\075\007\075\004\060\255\
\000\000\000\000\028\005\131\007\075\004\186\006\205\005\229\255\
\209\004\134\007\153\006\017\003\000\000\136\012\000\000\000\000\
\204\051\218\000\144\007\000\000\000\000\110\002\111\001\116\004\
\000\000\204\051\255\002\058\007\116\004\058\003\000\000\022\007\
\081\007\000\000\216\041\048\007\000\000\000\000\000\000\116\004\
\196\074\065\007\000\000\070\005\000\000\000\000\000\000\000\000\
\087\001\000\000\129\255\000\000\000\000\000\000\053\003\000\000\
\017\081\048\001\246\255\020\007\153\078\231\078\007\079\102\007\
\129\001\082\007\000\000\129\072\000\000\092\007\000\000\095\007\
\239\006\083\007\144\001\151\007\116\004\000\000\229\255\245\001\
\102\000\051\007\084\007\108\006\150\007\150\007\165\007\093\007\
\108\007\051\007\000\000\000\000\063\070\233\070\196\074\049\081\
\000\000\201\003\233\070\000\000\075\004\000\000\150\003\000\000\
\204\051\110\081\233\070\233\070\116\004\142\007\228\004\000\000\
\162\015\233\070\025\065\021\072\164\007\000\000\152\002\214\066\
\019\067\080\067\233\070\000\000\204\051\196\074\000\000\000\000\
\000\000\122\000\000\000\196\074\075\004\229\255\229\255\107\001\
\053\006\000\000\000\000\000\000\180\007\000\000\000\000\204\051\
\000\000\116\004\134\255\116\004\134\255\134\255\229\255\000\000\
\000\000\000\000\000\000\196\074\000\000\207\001\168\007\112\007\
\110\002\000\000\000\000\151\006\175\007\000\000\000\000\000\000\
\000\000\000\000\060\001\168\006\000\000\143\002\000\000\000\000\
\000\000\000\000\168\007\229\255\137\007\139\007\147\007\000\000\
\000\000\148\007\000\000\154\007\233\070\233\070\233\070\110\081\
\000\000\157\007\000\000\158\007\000\000\159\007\199\007\033\006\
\000\000\000\000\116\004\159\004\255\002\186\006\092\006\219\007\
\000\000\000\000\000\000\075\004\255\002\183\002\098\002\211\007\
\000\000\140\007\075\004\163\007\000\000\000\000\072\001\000\000\
\000\000\172\255\000\000\204\051\110\002\138\007\022\007\000\000\
\000\000\204\051\000\000\070\005\000\000\000\000\075\004\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\233\070\
\233\070\233\070\000\000\000\000\000\000\202\007\237\005\000\000\
\110\002\000\000\136\050\096\005\229\255\129\072\000\000\068\006\
\141\007\000\000\092\007\216\041\009\002\229\255\000\000\135\007\
\000\000\000\000\233\070\000\000\048\072\204\051\233\070\146\007\
\149\007\204\051\000\000\233\070\152\007\000\000\000\000\162\007\
\000\000\233\070\143\002\000\000\100\077\137\255\000\000\000\000\
\116\004\000\000\000\000\000\000\233\070\233\070\051\007\142\001\
\000\000\051\007\214\007\000\000\000\000\233\070\000\000\000\000\
\000\000\141\002\000\000\091\007\000\000\035\002\000\000\121\002\
\035\002\000\000\156\007\111\007\255\002\000\000\000\000\143\002\
\075\004\248\003\204\051\116\004\233\070\116\004\229\255\116\004\
\229\255\000\000\111\007\237\005\000\000\031\077\000\000\160\007\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\209\002\
\000\000\000\000\129\072\215\007\233\070\233\070\233\070\094\079\
\126\079\204\079\233\070\233\070\233\070\136\050\075\004\143\002\
\000\000\000\000\148\006\208\003\060\255\163\002\000\000\000\000\
\075\004\160\007\163\002\224\007\204\051\000\000\000\000\000\000\
\000\000\000\000\116\004\022\007\059\000\236\079\058\080\090\080\
\163\005\000\000\000\000\054\012\173\007\230\007\116\004\216\041\
\190\007\000\000\231\007\116\004\186\007\000\000\190\002\116\004\
\204\051\217\005\096\005\116\004\000\000\249\004\116\004\165\076\
\000\000\000\000\000\000\246\007\000\000\000\000\000\000\247\007\
\000\000\135\007\229\255\241\007\000\000\116\004\000\000\000\000\
\000\000\116\004\000\000\048\072\233\070\110\081\053\006\000\000\
\243\000\237\002\000\000\000\000\000\000\000\000\000\000\242\007\
\204\051\172\007\233\070\000\000\233\070\000\000\053\006\100\005\
\000\000\250\002\229\255\096\005\229\255\195\001\000\000\234\004\
\000\000\000\000\023\002\000\000\127\049\148\014\097\047\000\000\
\096\003\217\007\007\008\000\000\000\000\151\255\063\002\000\000\
\150\255\078\003\063\002\229\255\163\005\110\081\110\081\110\081\
\000\000\216\007\000\000\218\007\000\000\221\007\110\081\110\081\
\110\081\229\255\255\002\053\006\081\006\081\006\043\005\000\000\
\000\000\079\006\174\255\000\000\136\050\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\204\051\000\000\000\000\151\006\
\229\002\190\001\222\003\134\255\216\041\208\007\203\007\014\008\
\096\005\000\000\136\050\045\005\049\073\202\001\134\255\166\000\
\001\006\096\005\000\000\165\076\120\054\000\000\000\000\233\070\
\000\000\000\000\000\000\249\255\000\000\193\007\204\051\215\003\
\021\072\000\000\000\000\000\000\204\051\000\000\025\001\000\000\
\177\007\160\007\068\006\181\007\092\007\068\006\151\255\000\000\
\116\004\007\008\160\007\092\007\000\000\116\004\204\051\000\000\
\023\002\082\002\194\001\000\000\000\000\000\000\000\000\000\000\
\201\007\000\000\000\000\151\006\233\070\233\070\233\070\000\000\
\168\003\168\003\204\051\228\007\204\051\098\002\023\002\151\255\
\248\001\000\000\000\000\229\255\000\000\053\005\068\005\116\004\
\223\007\204\051\200\004\000\000\136\050\216\041\116\004\000\000\
\000\000\217\072\000\000\058\003\116\004\000\000\136\050\000\000\
\026\005\116\004\116\004\022\008\075\004\000\000\000\000\008\004\
\233\070\000\000\116\004\238\007\229\255\068\006\068\006\156\072\
\068\006\068\006\103\006\116\004\101\003\212\007\000\000\052\004\
\000\000\246\002\179\002\116\004\000\000\000\000\000\000\000\000\
\000\000\110\081\110\081\110\081\000\000\000\000\000\000\000\000\
\151\255\000\000\000\000\000\000\000\000\000\000\186\006\136\050\
\103\004\000\000\000\000\158\001\000\000\234\007\096\005\000\000\
\000\000\186\006\159\000\000\000\000\000\222\007\000\000\227\007\
\233\070\000\000\000\000\000\000\048\008\052\008\140\048\000\000\
\054\008\056\008\233\070\050\008\000\000\000\000\092\007\007\008\
\000\000\204\051\179\002\116\004\116\004\000\000\060\008\036\005\
\000\000\000\000\116\004\116\004\116\004\116\004\229\255\000\000\
\000\000\136\050\116\004\088\005\000\000\000\000\116\004\000\000\
\000\000\120\054\120\054\051\007\116\004\053\008\238\001\204\051\
\204\051\000\000\233\070\240\007\116\004\116\004\000\000\000\000\
\163\005\204\051\163\005\220\003\033\003\000\000\000\000\096\005\
\000\000\000\000\000\000\062\008\233\070\204\051\116\004\116\004\
\000\000\000\000\000\000\116\004\229\255\151\006\225\007\250\007\
\068\006\147\004\092\007\073\008\229\255\116\004\204\051\000\000\
\116\004\000\000\000\000\000\000\000\000\074\008\068\006\068\006\
\204\051\000\000\057\004\120\054\077\008\079\008\116\004\233\070\
\229\255\204\051\204\051\000\000\000\000\116\004\116\004"

let yyrindex = "\000\000\
\094\009\095\009\000\008\000\000\000\000\000\000\000\000\000\000\
\232\076\000\000\000\000\148\070\000\000\022\003\029\003\171\006\
\000\000\000\000\001\075\076\073\135\074\062\071\230\002\000\000\
\232\076\000\000\000\000\000\000\000\000\000\000\000\000\028\075\
\012\019\000\000\000\000\062\071\000\000\000\000\246\005\069\005\
\015\002\042\004\000\000\000\000\000\000\099\000\000\000\000\000\
\062\071\149\008\000\000\000\000\171\006\062\071\000\000\000\000\
\176\040\099\000\128\019\000\000\016\046\000\000\149\013\000\000\
\000\000\114\015\000\000\000\000\000\000\113\059\000\000\000\000\
\122\059\171\059\000\000\215\059\000\000\000\000\000\000\000\000\
\000\000\000\000\058\027\174\027\081\026\197\026\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\022\003\029\003\131\004\
\246\005\116\000\149\008\000\000\000\000\000\000\000\000\222\041\
\000\000\000\000\065\042\012\043\000\000\116\000\000\000\000\000\
\000\000\000\000\111\043\000\000\058\044\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\002\008\000\000\000\008\000\000\
\000\000\000\000\000\000\247\008\000\000\000\000\000\000\000\000\
\134\014\134\014\000\000\079\010\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\247\010\
\000\000\000\000\000\000\060\049\114\018\000\000\000\000\000\000\
\001\075\036\076\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\150\052\000\000\000\000\
\253\002\225\005\000\000\000\000\000\000\139\006\000\000\002\053\
\000\000\000\000\000\000\165\060\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\022\003\239\255\000\000\000\000\
\000\000\000\000\089\075\000\000\000\000\000\000\067\002\124\002\
\000\000\227\255\000\000\000\000\037\000\000\000\000\000\170\255\
\000\000\142\005\000\000\117\255\095\001\000\000\199\006\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\008\008\052\060\008\008\029\003\251\007\042\004\
\177\075\000\000\000\000\000\000\167\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\076\062\162\062\230\002\000\000\000\000\248\062\078\063\
\000\000\185\000\000\000\000\000\000\000\000\000\000\000\008\008\
\000\000\069\005\000\000\000\000\002\004\000\000\251\007\000\000\
\000\000\000\000\079\005\000\000\000\000\000\000\000\000\099\000\
\222\055\028\075\000\000\149\013\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\220\035\000\000\000\000\204\075\000\000\000\000\
\212\004\000\000\252\007\000\000\108\003\000\000\108\003\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\237\017\244\024\000\000\000\000\000\000\034\028\
\151\028\000\000\000\000\239\255\000\000\000\000\000\000\000\000\
\079\005\000\000\000\000\000\000\252\007\000\000\108\003\000\000\
\059\014\000\000\000\000\000\000\000\000\000\000\000\000\247\008\
\000\000\000\000\000\000\000\000\000\000\000\000\153\001\000\000\
\095\008\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\207\255\000\000\076\008\000\000\078\008\084\008\000\000\000\000\
\131\004\096\001\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\036\000\
\000\000\146\000\068\000\095\001\000\000\199\006\000\000\235\000\
\000\000\251\007\238\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\008\008\165\060\
\000\000\229\050\011\029\000\000\000\000\000\000\000\000\239\255\
\000\000\045\008\000\000\000\000\000\000\000\000\000\000\221\057\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\057\008\000\000\
\246\061\215\059\064\004\000\000\000\000\127\029\000\000\000\000\
\000\000\000\000\000\000\146\255\000\000\000\000\228\000\000\000\
\000\000\000\000\148\005\000\000\090\001\000\000\000\000\018\008\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\251\007\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\175\004\000\000\000\000\008\008\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\138\038\242\038\
\090\039\034\016\245\040\194\039\080\036\197\036\057\037\173\037\
\034\033\244\029\104\030\034\038\150\033\011\034\042\040\220\030\
\127\034\243\034\104\035\000\000\000\000\081\031\000\000\000\000\
\085\001\000\000\239\255\239\255\088\041\000\000\000\000\000\000\
\000\000\244\019\000\000\000\000\000\000\104\025\221\025\000\000\
\000\000\000\000\128\024\000\000\000\000\146\040\045\008\117\011\
\057\008\000\000\000\000\124\012\096\007\012\043\000\000\000\000\
\000\000\000\000\000\000\000\000\175\004\000\000\239\255\000\000\
\000\000\000\000\000\000\061\014\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\173\061\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\230\046\000\000\000\000\000\000\000\000\073\047\
\000\000\000\000\000\000\000\000\172\047\000\000\000\000\000\000\
\000\000\000\000\156\255\000\000\000\000\245\000\090\001\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\016\001\000\000\067\006\000\000\202\000\000\000\000\000\000\000\
\118\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\045\008\
\023\008\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\139\058\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\197\031\
\000\000\000\000\000\000\147\071\000\000\204\005\000\000\000\000\
\000\000\000\000\000\000\086\002\000\000\000\000\217\255\000\000\
\067\000\000\000\000\000\006\000\000\000\144\000\000\000\000\000\
\000\000\000\000\000\000\155\006\029\008\000\000\000\000\000\000\
\000\000\170\005\000\000\000\000\230\057\028\007\000\000\188\006\
\000\000\019\004\003\001\018\001\062\001\000\000\000\000\000\000\
\089\075\204\058\000\000\000\000\000\000\000\000\000\000\215\059\
\000\000\000\000\000\000\216\005\215\059\089\075\159\005\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\095\001\000\000\199\006\000\000\230\002\
\000\000\000\000\000\000\230\057\000\000\000\000\045\008\045\008\
\000\000\142\081\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\219\005\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\043\
\000\000\000\000\045\008\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\230\001\
\000\000\000\000\008\001\000\000\147\001\000\000\000\000\017\048\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\182\000\
\000\000\002\001\000\000\217\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\069\008\187\054\000\000\
\106\055\000\000\000\000\189\007\139\058\000\000\215\059\000\000\
\000\000\009\000\000\000\250\255\040\008\040\008\254\255\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\120\046\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\172\000\000\000\000\000\083\008\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\215\059\253\058\000\000\
\138\008\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\148\077\018\005\147\071\079\002\134\003\168\004\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\182\009\000\000\
\000\000\000\000\000\000\215\059\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\082\056\253\058\000\000\000\000\105\020\000\000\
\000\000\221\020\000\000\081\021\000\000\000\000\000\000\192\041\
\000\000\198\021\000\000\058\022\000\000\174\022\000\000\000\000\
\000\000\000\000\252\004\000\000\197\006\000\000\175\004\246\006\
\000\000\089\008\000\000\000\000\252\052\012\043\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\153\001\000\000\
\000\000\000\000\238\063\000\000\000\000\099\008\116\048\000\000\
\000\000\000\000\000\000\230\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\023\008\000\000\
\000\000\000\000\000\000\000\000\253\058\000\000\000\000\000\000\
\000\000\000\000\085\005\000\000\000\000\215\059\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\197\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\152\006\000\000\170\003\000\000\032\006\000\000\000\000\
\117\006\000\000\000\000\057\032\007\059\000\000\000\000\000\000\
\000\000\000\000\000\000\248\005\000\000\038\004\168\004\117\004\
\168\004\000\000\174\032\159\005\000\000\087\008\000\000\208\255\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\019\041\000\000\000\000\
\000\000\208\255\019\041\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\144\016\215\048\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\037\015\059\008\000\000\
\000\000\236\054\000\000\189\011\000\000\000\000\000\000\137\073\
\000\000\028\075\000\000\047\003\000\000\000\000\027\058\110\053\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\069\059\215\059\000\000\000\000\058\000\000\000\000\000\
\000\000\017\002\000\000\000\000\000\000\035\042\001\017\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\131\056\000\000\
\000\000\000\000\168\004\000\000\168\004\072\008\000\000\069\008\
\000\000\000\000\000\000\000\000\000\000\000\000\100\008\245\011\
\184\056\000\000\237\056\000\000\000\000\147\016\253\058\000\000\
\000\000\000\000\253\058\253\058\000\000\134\042\238\042\081\043\
\000\000\035\023\000\000\151\023\000\000\011\024\180\043\028\044\
\127\044\019\041\079\017\116\050\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\253\058\
\000\000\000\000\119\002\146\003\000\000\194\002\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\146\003\000\000\
\002\004\000\000\000\000\182\053\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\020\006\000\000\
\094\008\072\008\000\000\101\008\069\008\000\000\147\016\000\000\
\056\057\109\057\162\003\069\008\000\000\024\056\000\000\000\000\
\000\000\234\012\215\059\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\253\058\000\000\000\000\000\000\000\000\
\136\049\194\049\000\000\010\078\000\000\000\000\000\000\118\057\
\012\043\000\000\000\000\019\041\000\000\000\000\000\000\252\007\
\000\000\000\000\000\000\000\000\000\000\000\000\080\058\000\000\
\030\055\000\000\000\000\000\000\252\007\000\000\000\000\000\000\
\000\000\240\053\219\002\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\172\006\000\000\168\004\000\000\000\000\000\000\
\000\000\000\000\000\000\024\056\000\000\000\000\000\000\000\000\
\000\000\234\012\000\000\129\058\000\000\000\000\000\000\000\000\
\000\000\226\044\074\045\173\045\000\000\000\000\000\000\000\000\
\118\057\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\253\005\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\046\008\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\069\008\168\057\
\000\000\000\000\000\000\129\058\129\058\000\000\252\049\000\000\
\000\000\000\000\148\077\223\005\038\004\117\004\005\004\000\000\
\000\000\000\000\042\054\000\000\000\000\000\000\111\005\000\000\
\000\000\000\000\000\000\000\000\193\004\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\058\050\129\058\000\000\000\000\
\000\000\000\000\000\000\104\008\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\077\009\186\010\
\000\000\000\000\000\000\164\055\005\004\005\004\107\008\109\008\
\000\000\110\008\069\008\000\000\005\004\100\054\000\000\000\000\
\164\005\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\095\004\000\000\
\005\004\000\000\000\000\000\000\000\000\050\009\222\010"

let yygindex = "\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\033\000\
\215\255\000\000\089\000\072\000\013\006\049\009\060\000\000\000\
\214\255\126\000\233\001\099\253\000\000\217\254\078\006\071\255\
\127\008\195\013\029\254\247\255\098\004\194\013\074\252\051\000\
\093\000\023\000\026\000\034\000\000\000\000\000\000\000\000\000\
\045\000\047\000\000\000\049\000\000\000\002\000\013\000\088\007\
\093\001\000\000\000\000\000\000\000\000\000\000\000\000\052\000\
\000\000\000\000\000\000\000\000\000\000\014\255\005\252\000\000\
\000\000\000\000\027\000\000\000\000\000\142\254\251\253\032\252\
\115\251\156\251\083\255\000\000\226\003\000\000\176\004\175\251\
\113\255\059\004\000\000\000\000\000\000\000\000\000\000\000\000\
\107\003\015\000\026\251\047\255\103\253\199\251\017\253\135\252\
\095\251\043\254\247\003\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\046\000\200\006\
\003\006\006\006\000\000\000\000\078\255\022\000\000\000\168\255\
\184\001\059\253\000\254\108\010\156\012\000\000\000\000\000\000\
\110\255\049\008\009\013\119\007\031\000\094\255\207\000\159\254\
\000\000\080\008\100\007\216\011\115\253\000\000\078\254\000\000\
\000\000\000\000\050\004\009\006\163\255\164\004\000\000\000\000\
\000\000\000\000\073\000\000\000\235\007\157\255\254\007\021\007\
\045\009\000\000\000\000\198\004\000\000\000\000\085\008\213\253\
\190\005\138\251\021\251\213\251\011\253\000\000\097\253\000\000\
\122\005\000\000\000\000\046\251\066\255\001\253\251\006\041\008\
\000\000\000\000\099\004\000\000\000\000\137\004\078\252\000\000\
\066\004\017\005\000\000\146\253\235\012\133\255\000\000\071\006\
\128\255\220\254\141\255\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\082\255\000\000"

let yytablesize = 21372
let yytable = "\188\000\
\019\002\185\001\188\000\108\000\188\000\188\000\188\000\161\001\
\248\001\188\000\188\000\188\000\188\000\188\000\109\000\188\000\
\200\001\127\002\180\001\010\002\162\001\127\003\188\000\002\002\
\102\000\125\002\188\000\103\000\001\002\188\000\188\000\188\000\
\193\000\056\000\213\003\104\000\192\000\040\002\009\003\188\000\
\188\000\216\000\160\001\188\000\188\000\171\001\105\000\209\000\
\106\000\166\001\107\000\171\004\129\003\112\000\222\003\196\003\
\136\001\194\001\030\002\223\000\031\002\085\003\127\000\133\000\
\124\004\170\003\064\001\224\004\140\001\186\001\219\001\014\005\
\133\004\005\004\125\000\132\000\021\001\159\000\065\001\112\005\
\056\001\158\005\075\005\162\005\188\000\188\000\188\000\188\000\
\154\001\188\000\156\001\124\000\163\001\063\000\134\002\063\000\
\063\000\113\003\051\000\108\000\051\002\201\003\037\002\023\003\
\124\001\054\001\128\001\129\001\075\001\090\003\109\000\108\000\
\165\005\090\005\005\002\089\000\143\001\128\005\049\004\040\003\
\102\000\098\003\109\000\103\000\209\003\224\002\143\001\161\002\
\089\004\162\002\149\000\104\000\102\000\054\004\073\005\103\000\
\036\005\054\002\063\000\187\001\062\001\011\005\105\000\104\000\
\106\000\138\001\107\000\145\001\021\002\112\000\076\001\188\000\
\188\000\170\001\105\000\219\001\106\000\169\005\107\000\070\001\
\237\004\112\000\114\005\225\001\230\002\052\002\151\005\055\004\
\099\005\142\001\182\001\180\005\059\002\186\000\224\001\126\005\
\165\001\010\000\234\001\243\001\040\003\191\005\234\005\023\004\
\186\000\220\001\127\000\188\000\153\001\221\001\133\000\103\003\
\133\000\035\004\186\000\024\003\222\001\201\003\128\002\223\001\
\152\001\207\001\186\000\243\001\244\001\188\002\142\001\165\005\
\143\001\103\003\235\001\143\001\050\004\090\003\245\001\200\002\
\145\001\151\001\168\003\076\001\110\002\063\000\090\004\076\001\
\114\002\076\001\151\001\014\002\244\001\232\002\037\005\231\001\
\232\001\104\003\076\005\207\005\138\001\200\002\245\001\022\002\
\138\001\015\004\173\002\145\001\218\005\035\004\219\001\186\000\
\087\003\088\003\219\001\104\003\155\005\151\001\197\003\246\001\
\196\005\040\006\247\001\053\002\118\003\141\001\200\002\231\004\
\142\001\221\005\070\004\239\001\188\000\188\000\173\002\157\001\
\200\002\003\004\184\002\006\002\226\000\024\004\208\005\246\001\
\223\000\163\001\247\001\114\005\115\003\040\005\104\001\036\004\
\042\005\009\003\188\000\221\001\134\001\204\002\198\003\071\001\
\189\002\192\002\141\001\193\002\140\004\173\002\204\002\173\002\
\188\000\182\002\193\000\145\001\168\002\188\000\145\001\145\001\
\211\002\200\002\104\005\173\002\200\002\151\001\221\001\160\001\
\188\000\151\001\147\001\212\001\181\002\077\001\160\001\064\001\
\160\001\239\002\009\003\152\004\016\004\212\001\002\002\171\001\
\171\001\029\004\030\004\095\004\227\000\165\005\222\005\226\000\
\119\003\218\002\100\003\223\000\234\001\147\001\175\002\234\001\
\231\005\234\001\051\000\234\001\141\001\234\001\104\001\034\003\
\013\006\237\005\140\005\142\005\150\002\068\004\152\002\063\000\
\153\002\063\000\019\006\089\000\069\002\206\001\046\003\118\003\
\238\005\170\004\070\002\122\003\051\000\121\004\221\001\134\001\
\055\002\059\006\221\001\234\001\120\006\234\001\122\002\186\000\
\047\006\064\002\118\002\119\002\068\002\089\000\123\002\144\001\
\124\001\214\001\140\004\177\005\063\000\234\001\071\003\227\000\
\105\005\144\001\228\002\049\002\129\002\147\001\061\006\212\001\
\147\001\147\001\212\001\049\006\076\001\214\005\140\002\188\000\
\187\001\017\002\101\002\137\001\018\002\149\003\104\002\100\006\
\195\005\102\006\220\001\215\005\030\000\220\001\221\001\021\005\
\127\002\190\000\130\002\170\001\170\001\222\001\051\000\033\004\
\223\001\225\001\000\006\131\002\146\001\105\001\058\005\170\003\
\188\000\207\001\110\006\125\003\225\001\207\001\122\004\089\000\
\220\001\207\001\133\000\207\001\133\000\087\006\133\000\207\001\
\213\001\225\001\225\001\207\001\132\002\233\004\234\001\146\001\
\234\001\118\003\213\001\136\001\207\001\218\001\133\002\186\000\
\114\001\229\002\143\002\144\001\214\001\141\002\144\001\173\000\
\186\000\225\001\139\005\076\001\215\001\076\001\027\003\076\001\
\246\005\050\002\220\001\076\006\062\006\234\001\221\001\234\001\
\010\003\215\002\137\002\216\005\140\002\222\001\137\001\081\002\
\223\001\150\003\137\001\220\004\240\003\009\003\003\006\157\001\
\220\001\135\002\207\001\157\001\220\001\129\002\127\002\157\001\
\081\002\157\001\170\002\034\004\228\005\157\001\188\000\146\001\
\204\003\108\000\146\001\146\001\207\001\207\001\024\006\207\001\
\207\001\216\000\157\001\200\001\109\000\030\000\205\003\033\004\
\136\003\137\003\190\000\130\002\213\001\072\004\102\000\213\001\
\186\000\103\000\207\001\196\004\131\002\133\002\136\001\053\004\
\218\001\104\000\160\001\063\000\218\001\061\004\166\005\135\003\
\143\002\229\004\002\002\141\002\105\000\107\001\106\000\215\001\
\107\000\031\003\050\003\112\000\221\003\132\002\137\005\216\000\
\157\001\216\002\186\000\236\001\215\002\209\000\215\002\133\002\
\137\002\007\003\186\000\216\002\087\004\081\002\171\002\211\003\
\076\003\078\003\157\001\157\001\117\003\157\001\157\001\135\002\
\109\001\096\002\041\003\002\002\237\001\206\001\102\005\234\001\
\220\003\206\001\234\001\241\003\106\003\206\001\206\003\206\001\
\157\001\191\001\047\002\206\001\076\004\176\004\118\003\206\001\
\175\003\186\000\175\002\094\004\203\001\203\001\015\003\017\003\
\206\001\083\003\103\004\082\003\243\001\253\004\032\004\197\004\
\234\003\227\001\228\001\133\002\193\003\028\003\031\001\236\005\
\023\003\063\000\123\003\041\005\097\002\142\004\120\001\121\001\
\127\001\019\004\244\005\020\004\186\000\225\001\252\001\041\003\
\051\006\251\001\111\001\103\003\088\004\216\002\091\003\092\003\
\016\002\250\003\215\002\096\002\023\003\096\002\206\001\225\001\
\244\005\225\001\252\001\225\001\186\000\173\004\192\001\225\001\
\077\004\169\005\092\006\007\003\186\000\052\006\142\003\170\002\
\206\001\206\001\133\000\206\001\206\001\187\000\251\003\252\003\
\236\003\031\000\124\003\170\002\104\004\104\003\008\004\234\001\
\188\004\035\000\031\000\053\006\009\003\004\004\206\001\077\004\
\235\003\021\003\035\000\127\001\253\003\051\001\097\002\086\004\
\097\002\140\003\044\006\076\001\023\003\225\001\081\004\127\003\
\032\006\002\002\234\001\010\003\180\001\013\000\110\004\191\005\
\253\004\044\006\069\004\094\006\071\001\187\001\079\004\187\001\
\180\004\023\003\182\004\184\004\054\006\066\004\025\003\120\004\
\018\000\185\002\187\001\225\001\222\004\254\003\129\003\074\003\
\160\001\199\005\153\005\227\004\190\001\228\003\162\003\163\003\
\198\002\025\003\119\005\024\000\010\003\212\005\207\003\133\003\
\025\003\002\002\093\003\224\000\189\004\083\004\220\003\225\001\
\138\001\222\001\154\005\189\001\243\001\185\003\186\000\144\003\
\168\000\141\003\071\001\009\003\052\004\255\003\025\003\025\003\
\236\001\155\003\171\002\195\003\023\003\169\000\188\000\077\004\
\000\004\016\005\025\003\009\003\253\005\244\001\255\005\025\003\
\171\002\167\005\025\003\171\002\025\003\172\002\047\000\245\001\
\122\002\237\001\106\003\230\002\200\004\171\002\190\001\230\002\
\166\000\249\001\063\000\172\002\186\000\195\002\172\002\108\000\
\231\002\220\001\184\003\122\002\243\005\221\001\224\000\109\003\
\172\002\122\002\109\000\196\002\222\001\077\002\234\001\223\001\
\009\003\106\003\094\002\187\001\102\000\025\003\085\002\103\000\
\246\001\071\001\141\001\247\001\122\002\059\004\187\001\104\000\
\094\002\048\005\225\001\120\001\121\001\013\004\211\002\253\004\
\211\002\187\001\105\000\045\005\106\000\225\001\107\000\159\004\
\075\004\112\000\025\004\222\001\232\002\171\002\223\001\201\005\
\232\002\171\002\111\003\122\002\122\002\253\004\211\002\186\000\
\090\006\091\006\164\002\234\001\183\002\190\000\187\001\091\005\
\172\002\007\002\225\001\143\001\172\002\122\002\122\002\122\002\
\094\002\098\005\186\000\002\002\241\002\242\002\211\002\094\002\
\110\004\185\000\012\004\197\002\107\003\201\002\203\002\205\002\
\122\002\030\000\002\002\234\001\011\003\209\002\186\000\008\002\
\017\000\031\005\094\002\124\005\185\000\220\001\236\004\166\000\
\249\001\221\001\191\000\185\000\164\002\164\002\074\005\248\003\
\222\001\009\004\129\006\223\001\186\000\071\001\106\003\010\003\
\146\001\178\003\243\002\103\003\141\005\255\002\164\002\190\001\
\234\001\185\000\234\001\179\003\009\002\010\004\047\005\253\004\
\014\006\071\001\198\005\051\000\180\001\185\000\190\001\147\001\
\180\001\253\004\187\001\230\002\180\001\185\000\180\001\185\000\
\025\003\029\003\180\001\180\001\135\004\136\004\180\001\129\002\
\043\006\007\003\186\000\186\000\149\005\104\003\015\005\180\001\
\002\002\007\002\146\004\147\004\048\000\110\004\092\005\051\000\
\025\003\153\004\125\002\193\004\057\003\190\001\025\003\030\000\
\222\002\234\001\167\004\106\003\190\000\130\002\023\003\249\003\
\185\000\030\000\253\004\106\003\091\004\023\003\131\002\008\002\
\220\001\023\003\025\003\186\000\221\001\234\001\180\001\029\000\
\186\000\023\003\223\002\222\001\232\002\180\001\223\001\103\003\
\023\003\095\005\225\001\025\003\025\003\176\005\145\004\132\002\
\166\000\249\001\025\003\025\003\208\003\025\003\015\003\180\001\
\180\001\133\002\180\001\180\001\009\002\025\003\023\003\023\003\
\215\000\052\003\168\004\051\000\253\004\004\003\150\000\234\004\
\175\000\002\002\023\003\106\006\059\005\180\001\053\003\023\003\
\129\002\104\003\023\003\161\001\023\003\178\004\186\000\058\003\
\215\001\183\001\163\005\038\006\159\005\077\002\012\005\214\003\
\162\001\200\005\243\001\243\004\106\003\025\003\025\003\187\001\
\030\000\025\003\170\005\216\001\213\005\190\000\130\002\239\003\
\107\006\059\003\092\004\246\003\054\003\143\004\115\005\131\002\
\225\001\039\006\225\001\244\001\225\001\023\003\187\001\225\001\
\158\001\186\000\023\003\106\003\192\005\245\001\051\000\148\003\
\187\001\200\002\234\001\023\003\234\001\165\001\234\001\144\004\
\132\002\165\001\028\004\166\000\249\001\220\001\203\001\159\003\
\200\002\221\001\133\002\165\001\161\001\140\003\010\003\200\002\
\222\001\193\001\020\005\223\001\165\001\211\002\023\005\211\002\
\006\005\162\001\002\002\027\005\238\002\146\000\246\001\210\005\
\211\002\247\001\017\002\211\002\106\003\018\002\200\002\176\001\
\200\002\106\003\188\003\023\003\038\005\039\005\002\002\160\001\
\144\002\234\001\200\002\220\003\163\000\044\005\206\002\165\000\
\190\001\150\000\242\005\165\001\150\000\234\001\150\000\150\000\
\207\002\225\005\122\005\186\000\145\002\211\002\234\001\119\006\
\188\000\186\000\234\001\022\005\053\005\131\005\211\002\026\005\
\001\006\150\000\166\000\249\001\021\003\175\000\175\000\163\001\
\175\000\054\003\187\000\200\002\187\001\181\001\200\002\198\001\
\187\001\139\004\175\000\175\000\150\000\010\003\164\001\021\003\
\186\000\036\006\164\001\150\000\077\002\124\001\021\003\002\002\
\007\002\164\001\025\006\197\000\210\005\010\003\106\003\146\002\
\187\001\022\001\175\000\175\000\147\002\164\001\013\002\051\000\
\050\005\150\000\150\000\103\006\021\003\002\002\109\003\187\001\
\030\000\186\000\220\003\065\005\051\000\150\000\008\002\029\000\
\021\003\188\001\029\000\110\003\017\006\150\000\195\001\150\000\
\021\003\186\000\021\003\104\006\029\000\029\000\042\006\186\000\
\029\000\106\003\010\003\128\006\164\001\049\005\236\001\023\001\
\106\003\029\000\029\000\029\000\029\000\024\001\196\000\006\005\
\187\000\089\001\090\001\009\002\138\005\023\003\122\005\029\000\
\029\000\111\003\051\000\211\002\004\003\129\002\102\001\237\001\
\150\000\196\000\146\005\021\003\147\005\186\000\131\005\214\000\
\196\000\084\004\186\000\029\000\211\002\023\003\029\000\226\001\
\029\000\029\000\029\000\029\000\158\001\030\000\187\001\095\001\
\029\000\029\000\190\000\130\002\177\002\131\005\196\000\029\000\
\006\005\025\002\215\000\103\001\131\002\023\003\211\002\187\001\
\100\001\124\001\196\000\029\000\234\001\029\000\217\004\029\000\
\029\000\196\000\196\000\172\004\196\000\025\003\144\005\021\003\
\186\000\232\005\122\005\029\000\235\005\132\002\029\000\255\002\
\230\001\146\000\029\000\229\001\023\003\186\000\026\002\133\002\
\218\004\178\002\021\003\187\004\161\005\025\003\234\001\023\003\
\047\002\021\003\025\003\025\003\050\006\131\005\138\003\010\006\
\162\004\164\004\166\004\234\001\025\003\196\000\169\004\220\005\
\131\005\234\001\025\003\047\002\255\002\006\005\187\001\021\003\
\021\003\187\001\047\002\047\002\026\003\110\002\006\005\111\002\
\181\001\011\006\234\001\021\003\023\003\025\003\187\001\135\002\
\198\001\112\002\234\001\021\003\255\002\021\003\243\001\025\003\
\047\002\047\002\223\003\077\002\029\006\030\006\224\003\033\006\
\034\006\011\003\017\004\102\001\047\002\225\003\150\000\187\001\
\226\003\143\003\241\001\047\002\047\002\150\000\047\002\150\000\
\252\001\227\003\198\001\150\004\224\005\055\006\150\000\150\000\
\007\004\150\000\227\005\023\003\023\003\051\000\021\003\015\002\
\056\006\020\006\023\003\243\001\252\001\150\000\023\003\018\004\
\130\005\150\000\234\001\234\001\240\005\175\000\175\000\023\003\
\026\006\234\001\234\001\234\001\234\001\023\003\077\002\047\002\
\186\000\131\005\211\002\021\006\156\005\234\001\023\003\051\000\
\146\003\011\003\187\005\187\001\023\003\146\000\175\000\175\000\
\175\000\023\003\155\001\187\001\234\001\188\005\175\000\009\006\
\211\002\220\001\073\003\081\006\211\002\221\001\158\001\023\002\
\211\002\211\002\211\002\211\002\222\001\187\001\187\001\223\001\
\113\001\157\005\122\005\190\000\122\005\175\000\175\000\211\002\
\065\006\023\003\175\000\108\006\131\005\215\000\175\000\187\001\
\023\003\013\002\074\006\006\005\209\005\011\003\214\002\134\003\
\215\002\187\001\150\000\150\000\005\006\187\001\024\002\118\006\
\139\001\198\001\216\002\146\000\187\001\187\001\211\002\088\006\
\000\005\150\000\175\000\110\005\025\003\125\006\126\006\186\000\
\058\004\148\001\154\001\175\000\027\002\215\002\196\002\196\002\
\155\001\013\002\097\006\216\002\202\002\196\002\001\005\029\002\
\186\000\178\002\030\000\014\000\069\006\175\000\002\005\183\001\
\003\005\178\002\196\002\048\002\112\006\186\000\051\000\077\006\
\196\002\187\000\015\000\016\000\103\003\004\005\023\003\018\002\
\146\000\025\003\215\002\013\003\006\005\185\002\048\002\023\000\
\216\002\023\003\019\003\196\002\196\002\048\002\048\002\069\006\
\069\006\148\005\058\001\186\000\082\000\095\006\096\006\132\006\
\175\000\023\003\031\000\051\000\051\000\074\001\164\003\050\005\
\157\002\011\002\035\000\048\002\048\002\036\002\104\003\147\000\
\039\000\109\005\089\000\113\006\186\000\030\000\042\000\048\002\
\181\001\245\004\110\005\135\002\181\001\051\000\048\002\048\002\
\181\001\048\002\181\001\011\002\123\006\187\000\181\001\181\001\
\247\004\147\000\181\001\242\003\089\000\083\000\127\006\043\002\
\252\001\069\006\050\000\181\001\183\000\053\000\041\002\134\006\
\135\006\150\000\243\003\244\003\150\000\072\002\073\002\074\002\
\075\002\217\001\135\002\150\000\252\001\150\000\150\000\146\000\
\166\000\076\002\048\002\161\000\057\002\023\003\183\000\151\003\
\023\003\023\003\186\000\150\000\218\001\023\003\023\003\065\002\
\175\000\152\003\181\001\210\001\058\002\150\000\161\000\210\001\
\127\005\181\001\063\004\187\000\023\003\161\000\023\003\175\000\
\175\000\210\001\023\003\064\003\245\002\246\002\023\003\023\003\
\023\003\064\004\210\001\181\001\181\001\077\002\181\001\181\001\
\065\003\060\002\155\001\161\000\161\000\023\003\155\001\150\000\
\139\002\150\000\155\001\023\003\155\001\102\001\150\000\161\000\
\155\001\181\001\025\003\175\000\155\001\071\002\161\000\161\000\
\140\002\161\000\120\002\150\000\175\000\155\001\175\000\120\002\
\189\000\054\003\025\003\196\000\023\003\198\000\199\000\200\000\
\013\002\215\004\201\000\202\000\203\000\204\000\205\000\220\001\
\206\000\245\002\248\002\221\001\017\002\007\003\186\000\018\002\
\209\001\126\004\222\001\057\001\209\001\223\001\059\001\060\001\
\061\001\035\006\161\000\215\000\155\001\159\002\209\001\175\000\
\066\001\067\001\154\001\155\001\068\001\069\001\154\001\209\001\
\186\000\160\002\154\001\163\002\154\001\135\002\013\002\103\003\
\154\001\154\001\164\002\167\001\063\003\155\001\155\001\167\001\
\155\001\155\001\064\003\093\005\151\002\154\001\150\000\198\004\
\165\002\011\003\128\000\198\000\190\005\186\000\094\005\065\003\
\172\002\199\004\167\001\155\001\173\002\132\001\133\001\134\001\
\135\001\174\002\137\001\180\002\164\002\146\000\198\000\176\001\
\186\002\104\003\185\002\176\001\082\000\198\000\215\002\082\000\
\135\002\190\002\176\001\191\002\154\001\176\001\135\002\225\002\
\215\002\082\000\227\002\154\001\002\003\082\000\176\001\150\000\
\186\000\071\001\150\000\198\000\198\000\237\002\082\000\082\000\
\082\000\082\000\011\003\150\000\018\003\154\001\154\001\198\000\
\154\001\154\001\025\003\025\003\150\000\082\000\198\000\198\000\
\030\003\198\000\175\000\166\002\167\002\083\000\032\003\043\003\
\196\001\197\001\035\003\154\001\044\003\176\001\048\003\044\002\
\082\000\045\002\083\000\082\000\247\002\249\002\083\000\082\000\
\082\000\069\003\051\003\046\002\045\003\175\000\082\000\083\000\
\083\000\083\000\083\000\047\003\082\000\115\002\008\003\116\002\
\049\003\070\003\198\000\219\002\240\001\220\002\083\000\175\001\
\082\000\117\002\082\000\175\001\082\000\082\000\051\000\221\002\
\175\000\037\004\175\001\038\004\090\001\175\001\135\002\062\003\
\082\000\083\000\150\000\082\000\083\000\039\004\094\003\083\000\
\083\000\083\000\150\000\086\003\175\000\175\000\083\000\083\000\
\101\003\175\000\175\000\175\000\108\003\083\000\150\000\175\000\
\096\004\114\003\097\004\135\002\116\003\175\000\135\002\120\003\
\130\003\083\000\139\003\083\000\098\004\083\000\083\000\094\000\
\120\002\150\000\007\003\186\000\071\001\175\001\192\001\120\002\
\145\003\083\000\120\002\153\003\083\000\175\000\095\000\016\000\
\083\000\222\001\160\003\172\003\120\002\038\002\039\002\173\003\
\120\002\047\002\186\003\096\000\245\002\177\002\199\003\013\002\
\054\003\120\002\120\002\120\002\120\002\077\002\212\003\230\003\
\229\003\231\003\232\003\048\002\233\003\174\000\031\000\237\003\
\120\002\070\000\014\004\021\004\027\004\051\004\035\000\047\004\
\060\004\056\002\105\003\067\004\097\000\010\000\063\002\080\004\
\208\000\082\004\042\000\120\002\178\002\135\002\120\002\085\004\
\177\002\120\002\120\002\120\002\135\002\102\004\111\004\116\004\
\120\002\120\002\098\000\105\004\117\004\150\000\219\000\120\002\
\127\004\125\004\130\004\150\000\132\004\149\004\099\000\014\000\
\135\002\053\000\131\004\120\002\164\002\120\002\158\004\120\002\
\120\002\177\004\190\004\195\004\164\002\192\004\015\000\016\000\
\203\004\164\002\204\004\120\002\250\004\005\005\120\002\175\000\
\205\004\206\004\120\002\023\000\214\004\150\000\164\002\207\004\
\164\002\164\002\211\004\212\004\213\004\221\004\175\000\150\000\
\225\004\226\004\228\004\150\000\241\004\164\002\031\000\013\005\
\235\004\074\001\029\005\018\005\013\002\101\005\035\000\024\005\
\043\005\077\005\025\005\117\005\039\000\028\005\021\003\072\005\
\164\002\046\005\042\000\164\002\116\005\120\005\164\002\164\002\
\164\002\121\005\123\005\133\005\136\005\079\003\164\002\143\005\
\169\002\145\005\129\000\121\000\164\002\164\005\059\005\184\001\
\202\005\013\002\135\002\205\005\150\000\181\005\050\000\182\005\
\164\002\053\000\183\005\206\005\164\002\164\002\223\005\150\000\
\230\005\199\001\174\000\174\000\233\005\174\000\248\005\008\006\
\164\002\194\002\023\006\164\002\175\000\027\006\041\006\174\000\
\174\000\216\003\058\006\072\002\073\002\074\002\075\002\250\004\
\135\002\013\002\023\003\254\005\063\006\066\006\012\003\076\002\
\064\006\067\006\135\002\072\006\247\003\073\006\150\000\174\000\
\174\000\002\004\098\006\011\002\075\006\023\003\167\005\093\006\
\116\006\117\006\111\005\111\006\023\003\150\000\121\006\124\006\
\120\002\150\000\130\006\120\002\131\006\051\000\089\000\008\000\
\026\004\021\003\150\000\051\000\005\005\120\002\084\002\025\003\
\023\003\120\002\023\003\077\002\128\000\089\000\178\002\105\002\
\252\001\102\002\120\002\120\002\120\002\120\002\023\003\104\002\
\033\003\023\003\023\003\023\003\065\004\175\000\023\003\036\003\
\023\003\120\002\135\002\135\002\202\002\221\000\107\002\200\002\
\020\002\070\000\150\000\200\002\070\000\001\000\002\000\003\000\
\004\000\005\000\006\000\007\000\120\002\005\005\070\000\120\002\
\201\002\178\002\120\002\120\002\120\002\201\002\150\000\150\000\
\150\000\120\002\120\002\070\000\203\002\070\000\070\000\206\002\
\120\002\023\003\207\002\135\002\208\002\204\002\111\005\149\001\
\048\004\070\000\070\000\016\006\120\002\232\001\120\002\132\005\
\120\002\120\002\184\001\217\005\101\006\006\006\072\003\192\003\
\129\004\149\002\226\005\119\004\120\002\070\000\250\004\120\002\
\070\000\124\002\084\003\120\002\070\000\070\000\150\000\137\004\
\210\002\206\001\147\003\070\000\025\003\025\003\150\000\134\005\
\201\004\070\000\005\005\025\003\250\004\141\002\175\000\208\002\
\242\004\025\003\182\003\005\005\176\002\070\000\150\000\219\005\
\025\003\070\000\070\000\194\005\247\005\096\005\025\003\000\000\
\150\000\113\002\175\000\000\000\000\000\070\000\150\000\000\000\
\070\000\000\000\174\004\175\004\000\000\000\000\000\000\000\000\
\000\000\025\003\025\003\021\003\000\000\000\000\000\000\000\000\
\150\000\000\000\000\000\186\004\000\000\000\000\000\000\148\002\
\000\000\000\000\021\003\021\003\000\000\000\000\000\000\000\000\
\194\004\000\000\000\000\000\000\150\000\000\000\150\000\021\003\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\202\004\000\000\000\000\150\000\000\000\000\000\250\004\150\000\
\000\000\195\000\021\003\175\000\000\000\021\003\000\000\000\000\
\250\004\000\000\021\003\000\000\000\000\000\000\135\002\184\001\
\021\003\000\000\174\000\174\000\195\000\000\000\021\003\000\000\
\000\000\175\000\223\004\195\000\162\000\000\000\173\002\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\021\003\021\003\
\000\000\000\000\000\000\174\000\174\000\174\000\000\000\162\000\
\000\000\195\000\021\003\174\000\000\000\021\003\162\000\000\000\
\000\000\250\004\217\002\000\000\000\000\195\000\000\000\000\000\
\005\005\000\000\177\000\000\000\195\000\195\000\194\000\195\000\
\000\000\010\005\174\000\174\000\162\000\162\000\000\000\174\000\
\150\000\000\000\017\005\174\000\000\000\194\000\011\002\000\000\
\162\000\000\000\000\000\150\000\000\000\000\000\199\001\162\000\
\162\000\000\000\162\000\000\000\000\000\199\001\000\000\000\000\
\194\000\000\000\000\000\250\004\000\000\000\000\000\000\174\000\
\195\000\000\000\000\000\150\000\150\000\000\000\000\000\022\004\
\174\000\150\000\150\000\000\000\000\000\000\000\011\002\000\000\
\000\000\000\000\111\005\150\000\111\005\232\001\000\000\000\000\
\232\001\005\005\174\000\162\000\000\000\061\003\194\000\150\000\
\194\000\194\000\232\001\055\005\000\000\057\005\208\000\000\000\
\232\001\014\003\000\000\000\000\000\000\000\000\000\000\232\001\
\150\000\232\001\232\001\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\150\000\000\000\000\000\150\000\232\001\000\000\
\000\000\000\000\000\000\150\000\150\000\174\000\000\000\000\000\
\000\000\000\000\097\005\000\000\000\000\000\000\000\000\100\005\
\000\000\232\001\000\000\000\000\232\001\000\000\094\002\000\000\
\232\001\232\001\000\000\000\000\000\000\000\000\000\000\232\001\
\136\000\000\000\137\000\138\000\030\000\232\001\139\000\000\000\
\000\000\140\000\141\000\173\002\000\000\000\000\000\000\177\000\
\177\000\232\001\177\000\000\000\000\000\232\001\232\001\000\000\
\000\000\000\000\142\000\000\000\177\000\177\000\000\000\135\005\
\000\000\232\001\143\000\144\000\232\001\000\000\000\000\000\000\
\194\000\000\000\145\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\177\000\003\002\146\000\147\000\
\000\000\194\000\000\000\000\000\199\001\174\000\000\000\150\005\
\000\000\152\005\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\174\000\174\000\173\002\000\000\
\173\002\173\002\173\002\168\005\000\000\000\000\173\002\178\005\
\179\005\000\000\000\000\173\002\000\000\000\000\000\000\173\002\
\173\002\173\002\000\000\000\000\000\000\180\003\184\005\000\000\
\173\002\173\002\173\002\173\002\000\000\000\000\000\000\000\000\
\174\000\000\000\173\002\000\000\011\002\000\000\000\000\173\002\
\000\000\174\000\000\000\174\000\197\005\000\000\173\002\173\002\
\000\000\000\000\000\000\000\000\000\000\011\002\000\000\000\000\
\194\000\000\000\173\002\000\000\000\000\173\002\173\002\000\000\
\173\002\173\002\173\002\000\000\173\002\000\000\000\000\173\002\
\173\002\000\000\000\000\000\000\000\000\194\000\173\002\000\000\
\000\000\000\000\215\003\000\000\174\000\000\000\000\000\000\000\
\000\000\173\002\173\002\000\000\173\002\173\002\173\002\173\002\
\000\000\000\000\173\002\011\002\000\000\000\000\000\000\245\005\
\000\000\163\000\173\002\173\002\171\000\173\002\000\000\000\000\
\249\005\173\002\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\163\000\002\006\000\000\000\000\
\004\006\000\000\000\000\163\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\194\000\180\000\000\000\
\194\000\194\000\000\000\000\000\194\000\000\000\194\000\000\000\
\000\000\163\000\163\000\000\000\062\004\000\000\000\000\000\000\
\194\000\028\006\000\000\000\000\156\002\163\000\094\002\194\000\
\094\002\094\002\094\002\000\000\163\000\163\000\094\002\163\000\
\000\000\000\000\000\000\094\002\184\001\000\000\000\000\094\002\
\094\002\094\002\000\000\000\000\000\000\194\000\000\000\174\000\
\094\002\094\002\094\002\094\002\000\000\000\000\000\000\000\000\
\000\000\194\000\094\002\000\000\000\000\000\000\000\000\094\002\
\194\000\194\000\000\000\194\000\000\000\000\000\094\002\094\002\
\163\000\000\000\174\000\000\000\000\000\000\000\000\000\177\000\
\003\002\000\000\094\002\000\000\000\000\094\002\000\000\000\000\
\094\002\094\002\094\002\000\000\094\002\000\000\000\000\094\002\
\094\002\000\000\000\000\086\006\000\000\174\000\094\002\000\000\
\177\000\177\000\177\000\000\000\194\000\000\000\000\000\000\000\
\177\000\094\002\094\002\000\000\094\002\094\002\094\002\094\002\
\000\000\174\000\174\000\000\000\000\000\000\000\174\000\174\000\
\174\000\000\000\094\002\000\000\174\000\094\002\000\000\003\002\
\177\000\094\002\174\000\000\000\003\002\000\000\000\000\000\000\
\177\000\114\006\115\006\000\000\011\002\000\000\000\000\000\000\
\000\000\122\006\000\000\180\000\180\000\000\000\180\000\000\000\
\000\000\011\002\174\000\000\000\000\000\000\000\000\000\000\000\
\180\000\180\000\000\000\000\000\177\000\133\006\011\002\000\000\
\011\002\011\002\000\000\000\000\011\002\177\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\011\002\000\000\250\001\
\180\000\180\000\178\000\000\000\000\000\000\000\195\000\177\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\011\002\000\000\000\000\194\000\219\004\195\000\011\002\011\002\
\011\002\000\000\000\000\000\000\171\000\000\000\011\002\171\000\
\000\000\000\000\000\000\000\000\011\002\000\000\000\000\000\000\
\195\000\171\000\000\000\000\000\000\000\000\000\000\000\000\000\
\011\002\000\000\177\000\000\000\011\002\000\000\171\000\171\000\
\171\000\171\000\000\000\000\000\000\000\000\000\000\000\000\000\
\011\002\000\000\000\000\011\002\000\000\171\000\000\000\000\000\
\000\000\011\002\184\001\000\000\174\000\000\000\195\000\000\000\
\195\000\195\000\000\000\000\000\156\002\000\000\000\000\156\002\
\171\000\000\000\000\000\174\000\156\002\000\000\000\000\171\000\
\171\000\156\002\156\002\000\000\000\000\000\000\171\000\156\002\
\000\000\011\002\177\002\000\000\171\000\000\000\156\002\179\000\
\156\002\156\002\000\000\000\000\000\000\000\000\000\000\000\000\
\171\000\000\000\171\000\067\002\171\000\156\002\000\000\000\000\
\000\000\000\000\000\000\159\001\078\002\000\000\000\000\000\000\
\171\000\000\000\177\000\171\000\000\000\000\000\011\002\000\000\
\156\002\000\000\000\000\156\002\000\000\177\002\156\002\156\002\
\156\002\177\000\177\000\010\000\000\000\157\001\156\002\178\000\
\178\000\000\000\178\000\156\002\156\002\000\000\000\000\000\000\
\000\000\174\000\000\000\000\000\178\000\178\000\000\000\000\000\
\156\002\000\000\181\003\000\000\156\002\156\002\011\002\000\000\
\195\000\000\000\199\001\000\000\000\000\177\000\000\000\000\000\
\156\002\000\000\000\000\156\002\178\000\004\002\177\000\000\000\
\003\002\195\000\000\000\000\000\136\000\000\000\137\000\138\000\
\030\000\000\000\139\000\000\000\000\000\140\000\141\000\000\000\
\000\000\000\000\000\000\023\003\000\000\000\000\000\000\000\000\
\000\000\184\001\000\000\000\000\000\000\000\000\142\000\000\000\
\023\003\000\000\000\000\000\000\000\000\010\000\143\000\144\000\
\000\000\003\002\000\000\000\000\054\000\023\003\145\000\023\003\
\023\003\000\000\174\000\180\000\180\000\000\000\000\000\000\000\
\000\000\000\000\146\000\147\000\023\003\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\179\000\179\000\000\000\179\000\
\000\000\000\000\184\001\199\002\180\000\180\000\180\000\023\003\
\195\000\179\000\179\000\000\000\180\000\000\000\136\000\023\003\
\137\000\138\000\030\000\000\000\139\000\023\003\081\001\158\001\
\141\000\000\000\000\000\023\003\000\000\195\000\000\000\000\000\
\000\000\179\000\179\000\180\000\180\000\000\000\000\000\000\000\
\180\000\000\000\000\000\023\003\180\000\220\000\220\000\000\000\
\000\000\144\000\087\001\088\001\089\001\090\001\078\002\023\003\
\145\000\011\002\023\003\000\000\000\000\000\000\000\000\000\000\
\000\000\011\002\000\000\000\000\146\000\147\000\011\002\184\001\
\180\000\186\000\000\000\174\000\177\000\000\000\092\001\093\001\
\184\001\038\003\000\000\011\002\000\000\011\002\011\002\000\000\
\000\000\000\000\095\001\096\001\097\001\098\001\000\000\174\000\
\195\000\195\000\011\002\180\000\195\000\000\000\195\000\003\002\
\130\001\131\001\000\000\100\001\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\011\002\000\000\000\000\
\011\002\000\000\000\000\011\002\011\002\011\002\000\000\000\000\
\000\000\000\000\177\000\011\002\000\000\000\000\000\000\000\000\
\159\001\011\002\186\002\000\000\190\002\000\000\038\003\159\001\
\000\000\159\001\000\000\000\000\000\000\011\002\177\000\003\002\
\000\000\011\002\011\002\177\000\177\000\177\000\000\000\000\000\
\174\000\177\000\184\001\000\000\000\000\011\002\000\000\177\000\
\011\002\000\000\000\000\000\000\000\000\000\000\000\000\178\000\
\004\002\000\000\000\000\000\000\000\000\000\000\174\000\000\000\
\167\001\000\000\000\000\000\000\000\000\000\000\000\000\177\000\
\138\002\180\003\000\000\000\000\000\000\168\001\000\000\000\000\
\178\000\178\000\178\000\000\000\081\001\000\000\000\000\000\000\
\178\000\000\000\000\000\000\000\000\000\048\006\000\000\000\000\
\136\000\000\000\137\000\138\000\030\000\184\001\139\000\000\000\
\060\006\169\001\141\000\000\000\054\000\000\000\180\000\004\002\
\178\000\088\001\089\001\090\001\004\002\000\000\000\000\000\000\
\178\000\054\000\000\000\000\000\000\000\180\000\180\000\000\000\
\179\002\180\003\000\000\144\000\000\000\000\000\054\000\000\000\
\054\000\054\000\145\000\000\000\092\001\093\001\000\000\000\000\
\000\000\000\000\000\000\000\000\178\000\054\000\146\000\147\000\
\095\001\096\001\097\001\098\001\000\000\178\000\000\000\000\000\
\000\000\180\000\000\000\000\000\179\000\179\000\000\000\000\000\
\054\000\100\001\180\000\054\000\180\000\000\000\184\001\178\000\
\054\000\003\002\000\000\000\000\000\000\000\000\054\000\000\000\
\000\000\000\000\000\000\195\000\054\000\179\000\179\000\179\000\
\003\002\000\000\000\000\000\000\000\000\179\000\179\000\000\000\
\054\000\000\000\000\000\000\000\054\000\054\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\180\000\000\000\000\000\
\054\000\000\000\178\000\054\000\179\000\179\000\000\000\000\000\
\000\000\179\000\000\000\000\000\000\000\179\000\000\000\079\002\
\080\002\081\002\082\002\083\002\084\002\085\002\086\002\087\002\
\088\002\089\002\090\002\091\002\092\002\093\002\094\002\095\002\
\096\002\097\002\098\002\099\002\182\002\102\002\000\000\000\000\
\103\002\179\000\000\000\105\002\000\000\106\002\000\000\107\002\
\000\000\108\002\179\000\109\002\000\000\000\000\003\002\000\000\
\000\000\000\000\000\000\159\001\000\000\000\000\000\000\000\000\
\126\002\000\000\000\000\000\000\179\000\000\000\000\000\186\002\
\000\000\190\002\000\000\078\002\000\000\000\000\000\000\142\002\
\000\000\143\002\000\000\000\000\000\000\000\000\186\002\186\002\
\190\002\190\002\178\000\000\000\000\000\000\000\000\000\000\000\
\000\000\158\002\000\000\186\002\000\000\190\002\000\000\000\000\
\180\000\178\000\178\000\000\000\138\002\000\000\000\000\179\000\
\000\000\057\000\000\000\194\000\000\000\000\000\186\002\000\000\
\190\002\186\002\000\000\190\002\000\000\000\000\186\002\000\000\
\190\002\000\000\000\000\180\000\186\002\000\000\190\002\003\002\
\000\000\000\000\186\002\213\002\190\002\178\000\000\000\000\000\
\000\000\000\000\000\000\138\002\000\000\000\000\178\000\000\000\
\004\002\000\000\186\002\186\002\190\002\190\002\180\000\000\000\
\000\000\000\000\228\002\000\000\000\000\000\000\186\002\000\000\
\190\002\186\002\212\002\190\002\213\002\000\000\000\000\000\000\
\000\000\000\000\180\000\180\000\000\000\000\000\160\004\180\000\
\180\000\180\000\000\000\000\000\213\002\180\000\213\002\213\002\
\213\002\004\002\213\002\180\000\000\000\213\002\213\002\179\000\
\000\000\003\003\136\000\006\003\137\000\138\000\030\000\000\000\
\139\000\000\000\000\000\140\000\141\000\000\000\179\000\179\000\
\000\000\020\003\000\000\180\000\000\000\177\001\022\003\213\002\
\000\000\000\000\000\000\000\000\142\000\000\000\213\002\000\000\
\003\002\000\000\000\000\000\000\143\000\144\000\000\000\194\000\
\000\000\229\002\213\002\213\002\145\000\000\000\000\000\000\000\
\000\000\000\000\179\000\000\000\003\002\000\000\000\000\000\000\
\146\000\147\000\000\000\179\000\000\000\179\000\000\000\000\000\
\000\000\000\000\000\000\220\000\220\000\000\000\000\000\000\000\
\000\000\159\001\000\000\000\000\000\000\000\000\073\004\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\138\002\000\000\
\000\000\247\000\000\000\000\000\182\002\000\000\000\000\182\002\
\000\000\000\000\000\000\000\000\178\000\000\000\179\000\089\003\
\000\000\182\002\000\000\000\000\095\003\096\003\097\003\000\000\
\000\000\000\000\000\000\000\000\000\000\003\002\182\002\182\002\
\182\002\182\002\000\000\099\003\000\000\180\000\102\003\004\002\
\000\000\000\000\000\000\000\000\000\000\182\002\000\000\000\000\
\000\000\138\002\000\000\003\002\180\000\000\000\000\000\138\002\
\000\000\000\000\000\000\000\000\000\000\000\000\045\006\000\000\
\182\002\000\000\178\000\000\000\173\002\000\000\182\002\182\002\
\182\002\000\000\000\000\000\000\000\000\173\002\182\002\000\000\
\000\000\057\000\000\000\000\000\182\002\000\000\178\000\004\002\
\000\000\000\000\000\000\178\000\178\000\178\000\057\000\000\000\
\182\002\178\000\182\002\000\000\182\002\173\002\000\000\178\000\
\173\002\000\000\000\000\057\000\000\000\057\000\057\000\000\000\
\182\002\173\002\011\002\182\002\000\000\000\000\078\006\161\003\
\000\000\179\000\057\000\000\000\165\003\166\003\167\003\178\000\
\000\000\014\003\180\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\183\003\000\000\057\000\000\000\000\000\
\057\000\000\000\000\000\000\000\179\000\057\000\000\000\138\002\
\000\000\000\000\000\000\057\000\000\000\000\000\000\000\000\000\
\000\000\057\000\000\000\200\003\000\000\000\000\203\003\000\000\
\000\000\000\000\000\000\000\000\000\000\057\000\000\000\179\000\
\000\000\057\000\057\000\210\003\138\002\000\000\000\000\138\002\
\136\000\000\000\137\000\138\000\030\000\057\000\139\000\000\000\
\057\000\140\000\141\000\179\000\179\000\232\004\000\000\000\000\
\179\000\179\000\179\000\000\000\000\000\000\000\179\000\000\000\
\000\000\000\000\142\000\180\000\179\000\000\000\000\000\000\000\
\000\000\000\000\143\000\126\003\000\000\000\000\000\000\000\000\
\032\000\000\000\145\000\000\000\000\000\000\000\000\000\000\000\
\000\000\004\002\000\000\000\000\179\000\151\004\146\000\147\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\004\002\000\000\000\000\000\000\000\000\000\000\000\000\040\004\
\000\000\247\000\247\000\247\000\247\000\000\000\138\002\000\000\
\000\000\247\000\247\000\247\000\000\000\138\002\247\000\247\000\
\000\000\247\000\247\000\247\000\247\000\247\000\247\000\000\000\
\000\000\247\000\247\000\247\000\247\000\247\000\247\000\000\000\
\000\000\138\002\078\004\000\000\000\000\247\000\247\000\000\000\
\000\000\247\000\247\000\247\000\247\000\000\000\081\000\000\000\
\000\000\247\000\247\000\000\000\180\000\255\004\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\247\000\247\000\000\000\
\247\000\000\000\000\000\247\000\247\000\247\000\004\002\247\000\
\180\000\000\000\247\000\247\000\000\000\000\000\000\000\000\000\
\000\000\247\000\000\000\247\000\000\000\000\000\179\000\118\004\
\000\000\000\000\000\000\000\000\247\000\247\000\000\000\247\000\
\247\000\247\000\247\000\000\000\000\000\179\000\000\000\000\000\
\247\000\000\000\247\000\000\000\141\004\247\000\000\000\159\001\
\247\000\000\000\011\002\000\000\247\000\011\002\000\000\148\004\
\000\000\000\000\011\002\138\002\000\000\000\000\000\000\011\002\
\000\000\000\000\000\000\195\000\000\000\011\002\023\003\000\000\
\000\000\180\000\000\000\000\000\011\002\000\000\011\002\011\002\
\000\000\000\000\000\000\023\003\000\000\000\000\000\000\004\002\
\000\000\000\000\000\000\011\002\179\004\000\000\181\004\180\000\
\255\004\138\002\000\000\000\000\000\000\000\000\023\003\000\000\
\023\003\023\003\023\003\138\002\023\003\000\000\011\002\023\003\
\023\003\011\002\000\000\179\000\011\002\011\002\011\002\000\000\
\159\001\000\000\000\000\113\005\011\002\000\000\000\000\000\000\
\000\000\000\000\011\002\000\000\000\000\000\000\208\004\209\004\
\210\004\023\003\000\000\000\000\229\000\000\000\011\002\000\000\
\023\003\000\000\011\002\011\002\000\000\216\004\000\000\000\000\
\000\000\000\000\000\000\000\000\023\003\023\003\011\002\000\000\
\032\000\011\002\000\000\032\000\000\000\000\000\000\000\000\000\
\000\000\230\004\000\000\138\002\138\002\032\000\032\000\000\000\
\000\000\032\000\000\000\000\000\000\000\000\000\000\000\000\000\
\004\002\000\000\032\000\032\000\032\000\032\000\000\000\195\000\
\000\000\238\004\239\004\240\004\179\000\000\000\000\000\000\000\
\032\000\032\000\000\000\000\000\004\002\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\138\002\000\000\000\000\113\005\
\000\000\000\000\000\000\000\000\032\000\000\000\000\000\032\000\
\000\000\000\000\000\000\032\000\032\000\000\000\000\000\185\005\
\186\005\032\000\032\000\030\005\000\000\000\000\081\000\255\004\
\032\000\081\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\081\000\032\000\000\000\032\000\081\000\
\032\000\032\000\000\000\000\000\000\000\255\004\000\000\000\000\
\081\000\081\000\081\000\081\000\032\000\004\002\000\000\032\000\
\000\000\060\002\000\000\032\000\000\000\000\000\052\005\081\000\
\054\005\000\000\056\005\016\003\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\004\002\000\000\179\000\000\000\000\000\
\000\000\000\000\081\000\000\000\000\000\081\000\078\005\079\005\
\080\005\081\000\081\000\000\000\087\005\088\005\089\005\000\000\
\081\000\179\000\000\000\000\000\000\000\000\000\081\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\081\000\000\000\081\000\103\005\081\000\081\000\
\000\000\113\005\136\000\000\000\137\000\138\000\030\000\255\004\
\139\000\118\005\081\000\140\000\141\000\081\000\000\000\000\000\
\000\000\255\004\125\005\000\000\000\000\000\000\129\005\138\002\
\000\000\000\000\000\000\000\000\142\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\143\000\144\000\000\000\000\000\
\000\000\000\000\179\000\000\000\145\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\146\000\147\000\000\000\000\000\229\000\229\000\229\000\229\000\
\179\000\000\000\255\004\000\000\229\000\229\000\229\000\000\000\
\000\000\229\000\229\000\229\000\229\000\229\000\229\000\229\000\
\229\000\229\000\000\000\000\000\229\000\229\000\229\000\229\000\
\229\000\229\000\000\000\122\002\000\000\000\000\000\000\000\000\
\229\000\229\000\000\000\000\000\229\000\229\000\229\000\229\000\
\229\000\229\000\229\000\000\000\229\000\229\000\000\000\000\000\
\000\000\000\000\000\000\000\000\255\004\000\000\000\000\000\000\
\229\000\229\000\000\000\229\000\000\000\000\000\229\000\229\000\
\229\000\000\000\229\000\229\000\229\000\229\000\229\000\000\000\
\000\000\000\000\000\000\113\005\229\000\113\005\229\000\229\000\
\229\000\229\000\229\000\000\000\000\000\000\000\000\000\229\000\
\229\000\000\000\229\000\229\000\229\000\229\000\000\000\000\000\
\229\000\000\000\000\000\229\000\000\000\229\000\000\000\000\000\
\229\000\000\000\000\000\229\000\000\000\000\000\000\000\229\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\239\005\000\000\000\000\000\000\014\000\000\000\000\000\000\000\
\000\000\060\002\000\000\060\002\060\002\060\002\250\005\251\005\
\252\005\060\002\000\000\015\000\016\000\000\000\060\002\164\002\
\000\000\000\000\060\002\060\002\060\002\000\000\000\000\000\000\
\023\000\000\000\007\006\060\002\060\002\060\002\060\002\000\000\
\000\000\000\000\000\000\000\000\000\000\060\002\000\000\018\006\
\000\000\060\002\060\002\031\000\000\000\022\006\074\001\000\000\
\000\000\060\002\060\002\035\000\000\000\000\000\000\000\000\000\
\000\000\039\000\000\000\000\000\000\000\060\002\037\006\042\000\
\060\002\000\000\000\000\060\002\060\002\060\002\046\006\060\002\
\000\000\000\000\060\002\060\002\000\000\000\000\000\000\046\000\
\000\000\060\002\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\050\000\060\002\060\002\053\000\060\002\
\060\002\060\002\000\000\000\000\000\000\060\002\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\060\002\000\000\000\000\
\060\002\000\000\000\000\000\000\060\002\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\079\006\080\006\
\000\000\000\000\000\000\041\001\000\000\082\006\083\006\084\006\
\085\006\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\089\006\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\122\002\122\002\122\002\122\002\000\000\
\099\006\122\002\122\002\122\002\122\002\122\002\122\002\122\002\
\122\002\122\002\122\002\122\002\122\002\122\002\122\002\122\002\
\122\002\122\002\000\000\122\002\122\002\122\002\122\002\122\002\
\122\002\122\002\122\002\000\000\000\000\000\000\000\000\122\002\
\122\002\000\000\000\000\122\002\122\002\122\002\122\002\122\002\
\122\002\122\002\122\002\122\002\122\002\122\002\122\002\000\000\
\122\002\122\002\122\002\122\002\000\000\000\000\122\002\122\002\
\122\002\110\002\122\002\122\002\122\002\122\002\122\002\122\002\
\000\000\122\002\122\002\122\002\122\002\122\002\000\000\122\002\
\000\000\000\000\000\000\122\002\122\002\122\002\122\002\122\002\
\122\002\122\002\122\002\000\000\122\002\000\000\122\002\122\002\
\061\001\122\002\122\002\122\002\122\002\122\002\000\000\122\002\
\122\002\000\000\122\002\122\002\122\002\122\002\000\000\122\002\
\122\002\000\000\122\002\000\000\000\000\000\000\122\002\164\002\
\164\002\164\002\164\002\164\002\000\000\164\002\164\002\164\002\
\164\002\164\002\164\002\164\002\164\002\164\002\164\002\164\002\
\164\002\164\002\164\002\164\002\164\002\000\000\000\000\164\002\
\164\002\164\002\164\002\164\002\164\002\164\002\164\002\000\000\
\000\000\000\000\000\000\164\002\164\002\000\000\000\000\164\002\
\164\002\164\002\164\002\164\002\164\002\164\002\164\002\164\002\
\164\002\164\002\164\002\000\000\164\002\164\002\164\002\164\002\
\000\000\000\000\164\002\164\002\164\002\000\000\164\002\164\002\
\164\002\164\002\164\002\164\002\000\000\164\002\164\002\164\002\
\164\002\164\002\000\000\164\002\000\000\000\000\000\000\164\002\
\164\002\164\002\164\002\164\002\164\002\164\002\164\002\000\000\
\164\002\000\000\164\002\164\002\047\001\164\002\164\002\164\002\
\164\002\164\002\000\000\164\002\164\002\000\000\164\002\164\002\
\164\002\164\002\000\000\164\002\164\002\000\000\164\002\000\000\
\000\000\000\000\164\002\041\001\041\001\041\001\041\001\000\000\
\000\000\041\001\041\001\041\001\041\001\041\001\041\001\041\001\
\041\001\041\001\041\001\041\001\041\001\041\001\041\001\041\001\
\041\001\041\001\000\000\041\001\041\001\041\001\041\001\041\001\
\041\001\041\001\041\001\000\000\000\000\000\000\000\000\041\001\
\041\001\000\000\000\000\041\001\041\001\041\001\041\001\041\001\
\041\001\041\001\041\001\041\001\041\001\041\001\041\001\000\000\
\041\001\041\001\041\001\041\001\000\000\000\000\041\001\041\001\
\041\001\000\000\041\001\041\001\041\001\041\001\041\001\041\001\
\000\000\041\001\041\001\041\001\041\001\041\001\000\000\041\001\
\000\000\000\000\000\000\041\001\041\001\041\001\041\001\041\001\
\041\001\041\001\041\001\000\000\041\001\000\000\041\001\041\001\
\045\001\041\001\041\001\041\001\041\001\041\001\000\000\041\001\
\041\001\000\000\041\001\041\001\041\001\041\001\000\000\041\001\
\041\001\000\000\041\001\000\000\000\000\000\000\041\001\000\000\
\061\001\061\001\061\001\061\001\000\000\000\000\061\001\061\001\
\061\001\061\001\061\001\061\001\061\001\061\001\061\001\061\001\
\061\001\061\001\061\001\061\001\061\001\061\001\061\001\000\000\
\061\001\061\001\061\001\061\001\061\001\061\001\061\001\061\001\
\000\000\000\000\000\000\000\000\061\001\061\001\000\000\000\000\
\061\001\061\001\061\001\061\001\061\001\061\001\061\001\061\001\
\061\001\061\001\061\001\061\001\000\000\061\001\061\001\061\001\
\061\001\000\000\000\000\061\001\061\001\061\001\000\000\061\001\
\061\001\061\001\061\001\061\001\061\001\000\000\061\001\061\001\
\061\001\061\001\061\001\000\000\061\001\000\000\000\000\000\000\
\061\001\061\001\061\001\061\001\061\001\061\001\061\001\061\001\
\000\000\061\001\000\000\061\001\061\001\053\001\061\001\061\001\
\061\001\061\001\061\001\000\000\061\001\061\001\000\000\061\001\
\061\001\061\001\061\001\000\000\061\001\061\001\000\000\061\001\
\000\000\000\000\000\000\061\001\047\001\047\001\047\001\047\001\
\000\000\000\000\047\001\047\001\047\001\047\001\047\001\047\001\
\047\001\047\001\047\001\047\001\047\001\047\001\047\001\047\001\
\047\001\047\001\047\001\000\000\047\001\047\001\047\001\047\001\
\047\001\047\001\047\001\047\001\000\000\000\000\000\000\000\000\
\047\001\047\001\000\000\000\000\047\001\047\001\047\001\047\001\
\047\001\047\001\047\001\047\001\047\001\047\001\047\001\047\001\
\000\000\047\001\047\001\047\001\047\001\000\000\000\000\047\001\
\047\001\047\001\000\000\047\001\047\001\047\001\047\001\047\001\
\047\001\000\000\047\001\047\001\047\001\047\001\047\001\000\000\
\047\001\000\000\000\000\000\000\047\001\047\001\047\001\047\001\
\047\001\047\001\047\001\047\001\000\000\047\001\000\000\047\001\
\047\001\049\001\047\001\047\001\047\001\047\001\047\001\000\000\
\047\001\047\001\000\000\047\001\047\001\047\001\047\001\000\000\
\047\001\047\001\000\000\047\001\000\000\000\000\000\000\047\001\
\045\001\045\001\045\001\045\001\000\000\000\000\045\001\045\001\
\045\001\045\001\045\001\045\001\045\001\045\001\045\001\045\001\
\045\001\045\001\045\001\045\001\045\001\045\001\045\001\000\000\
\045\001\045\001\045\001\045\001\045\001\045\001\045\001\045\001\
\000\000\000\000\000\000\000\000\045\001\045\001\000\000\000\000\
\045\001\045\001\045\001\045\001\045\001\045\001\045\001\045\001\
\045\001\045\001\045\001\045\001\000\000\045\001\045\001\045\001\
\045\001\000\000\000\000\045\001\045\001\045\001\000\000\045\001\
\045\001\045\001\045\001\045\001\045\001\000\000\045\001\045\001\
\045\001\045\001\045\001\000\000\045\001\000\000\000\000\000\000\
\045\001\045\001\045\001\045\001\045\001\045\001\045\001\045\001\
\000\000\045\001\000\000\045\001\045\001\051\001\045\001\045\001\
\045\001\045\001\045\001\000\000\045\001\045\001\000\000\045\001\
\045\001\045\001\045\001\000\000\045\001\045\001\000\000\045\001\
\000\000\000\000\000\000\045\001\000\000\053\001\053\001\053\001\
\053\001\000\000\000\000\053\001\053\001\053\001\053\001\053\001\
\053\001\053\001\053\001\053\001\053\001\053\001\053\001\053\001\
\053\001\053\001\053\001\053\001\000\000\053\001\053\001\053\001\
\053\001\053\001\053\001\053\001\053\001\000\000\000\000\000\000\
\000\000\053\001\053\001\000\000\000\000\053\001\053\001\053\001\
\053\001\053\001\053\001\053\001\053\001\053\001\053\001\053\001\
\053\001\000\000\053\001\053\001\053\001\053\001\000\000\000\000\
\053\001\053\001\053\001\000\000\053\001\053\001\053\001\053\001\
\053\001\053\001\000\000\053\001\053\001\053\001\053\001\053\001\
\000\000\053\001\000\000\000\000\000\000\053\001\053\001\053\001\
\053\001\053\001\053\001\053\001\053\001\000\000\053\001\000\000\
\053\001\053\001\059\001\053\001\053\001\053\001\053\001\053\001\
\000\000\053\001\053\001\000\000\053\001\053\001\053\001\053\001\
\000\000\053\001\053\001\000\000\053\001\000\000\000\000\000\000\
\053\001\049\001\049\001\049\001\049\001\000\000\000\000\049\001\
\049\001\049\001\049\001\049\001\049\001\049\001\049\001\049\001\
\049\001\049\001\049\001\049\001\049\001\049\001\049\001\049\001\
\000\000\049\001\049\001\049\001\049\001\049\001\049\001\049\001\
\049\001\000\000\000\000\000\000\000\000\049\001\049\001\000\000\
\000\000\049\001\049\001\049\001\049\001\049\001\049\001\049\001\
\049\001\049\001\049\001\049\001\049\001\000\000\049\001\049\001\
\049\001\049\001\000\000\000\000\049\001\049\001\049\001\000\000\
\049\001\049\001\049\001\049\001\049\001\049\001\000\000\049\001\
\049\001\049\001\049\001\049\001\000\000\049\001\000\000\000\000\
\000\000\049\001\049\001\049\001\049\001\049\001\049\001\049\001\
\049\001\000\000\049\001\000\000\049\001\049\001\055\001\049\001\
\049\001\049\001\049\001\049\001\000\000\049\001\049\001\000\000\
\049\001\049\001\049\001\049\001\000\000\049\001\049\001\000\000\
\049\001\000\000\000\000\000\000\049\001\051\001\051\001\051\001\
\051\001\000\000\000\000\051\001\051\001\051\001\051\001\051\001\
\051\001\051\001\051\001\051\001\051\001\051\001\051\001\051\001\
\051\001\051\001\051\001\051\001\000\000\051\001\051\001\051\001\
\051\001\051\001\051\001\051\001\051\001\000\000\000\000\000\000\
\000\000\051\001\051\001\000\000\000\000\051\001\051\001\051\001\
\051\001\051\001\051\001\051\001\051\001\051\001\051\001\051\001\
\051\001\000\000\051\001\051\001\051\001\051\001\000\000\000\000\
\051\001\051\001\051\001\000\000\051\001\051\001\051\001\051\001\
\051\001\051\001\000\000\051\001\051\001\051\001\051\001\051\001\
\000\000\051\001\000\000\000\000\000\000\051\001\051\001\051\001\
\051\001\051\001\051\001\051\001\051\001\000\000\051\001\000\000\
\051\001\051\001\057\001\051\001\051\001\051\001\051\001\051\001\
\000\000\051\001\051\001\000\000\051\001\051\001\051\001\051\001\
\000\000\051\001\051\001\000\000\051\001\000\000\000\000\000\000\
\051\001\000\000\059\001\059\001\059\001\059\001\000\000\000\000\
\059\001\059\001\059\001\059\001\059\001\059\001\059\001\059\001\
\059\001\059\001\059\001\059\001\059\001\059\001\059\001\059\001\
\059\001\000\000\059\001\059\001\059\001\059\001\059\001\059\001\
\059\001\059\001\000\000\000\000\000\000\000\000\059\001\059\001\
\000\000\000\000\059\001\059\001\059\001\059\001\059\001\059\001\
\059\001\059\001\059\001\059\001\059\001\059\001\000\000\059\001\
\059\001\059\001\059\001\000\000\000\000\059\001\059\001\059\001\
\000\000\059\001\059\001\059\001\059\001\059\001\059\001\000\000\
\059\001\059\001\059\001\059\001\059\001\000\000\059\001\000\000\
\000\000\000\000\059\001\059\001\059\001\059\001\059\001\059\001\
\059\001\059\001\000\000\059\001\000\000\059\001\059\001\088\001\
\059\001\059\001\059\001\059\001\059\001\000\000\059\001\059\001\
\000\000\059\001\059\001\059\001\059\001\000\000\059\001\059\001\
\000\000\059\001\000\000\000\000\000\000\059\001\055\001\055\001\
\055\001\055\001\000\000\000\000\055\001\055\001\055\001\055\001\
\055\001\055\001\055\001\055\001\055\001\055\001\055\001\055\001\
\055\001\055\001\055\001\055\001\055\001\000\000\055\001\055\001\
\055\001\055\001\055\001\055\001\055\001\055\001\000\000\000\000\
\000\000\000\000\055\001\055\001\000\000\000\000\055\001\055\001\
\055\001\055\001\055\001\055\001\055\001\055\001\055\001\055\001\
\055\001\055\001\000\000\055\001\055\001\055\001\055\001\000\000\
\000\000\055\001\055\001\055\001\000\000\055\001\055\001\055\001\
\055\001\055\001\055\001\000\000\055\001\055\001\055\001\055\001\
\055\001\000\000\055\001\000\000\000\000\000\000\055\001\055\001\
\055\001\055\001\055\001\055\001\055\001\055\001\000\000\055\001\
\000\000\055\001\055\001\097\001\055\001\055\001\055\001\055\001\
\055\001\000\000\055\001\055\001\000\000\055\001\055\001\055\001\
\055\001\000\000\055\001\055\001\000\000\055\001\000\000\000\000\
\000\000\055\001\057\001\057\001\057\001\057\001\000\000\000\000\
\057\001\057\001\057\001\057\001\057\001\057\001\057\001\057\001\
\057\001\057\001\057\001\057\001\057\001\057\001\057\001\057\001\
\057\001\000\000\057\001\057\001\057\001\057\001\057\001\057\001\
\057\001\057\001\000\000\000\000\000\000\000\000\057\001\057\001\
\000\000\000\000\057\001\057\001\057\001\057\001\057\001\057\001\
\057\001\057\001\057\001\057\001\057\001\057\001\000\000\057\001\
\057\001\057\001\057\001\000\000\000\000\057\001\057\001\057\001\
\000\000\057\001\057\001\057\001\057\001\057\001\057\001\000\000\
\057\001\057\001\057\001\057\001\057\001\000\000\057\001\000\000\
\000\000\000\000\057\001\057\001\057\001\057\001\057\001\057\001\
\057\001\057\001\000\000\057\001\000\000\057\001\057\001\099\001\
\057\001\057\001\057\001\057\001\057\001\000\000\057\001\057\001\
\000\000\057\001\057\001\057\001\057\001\000\000\057\001\057\001\
\000\000\057\001\000\000\000\000\000\000\057\001\000\000\088\001\
\088\001\088\001\088\001\088\001\000\000\088\001\088\001\088\001\
\088\001\088\001\088\001\088\001\088\001\088\001\088\001\088\001\
\088\001\088\001\088\001\088\001\088\001\000\000\000\000\088\001\
\088\001\088\001\088\001\088\001\088\001\088\001\088\001\000\000\
\000\000\000\000\000\000\088\001\088\001\000\000\000\000\088\001\
\088\001\088\001\088\001\088\001\088\001\088\001\000\000\088\001\
\088\001\088\001\088\001\000\000\088\001\088\001\088\001\088\001\
\000\000\000\000\088\001\088\001\088\001\000\000\088\001\088\001\
\088\001\088\001\088\001\088\001\000\000\088\001\088\001\088\001\
\088\001\088\001\000\000\088\001\000\000\000\000\000\000\088\001\
\088\001\088\001\088\001\088\001\088\001\088\001\088\001\000\000\
\088\001\000\000\088\001\088\001\102\001\088\001\088\001\088\001\
\088\001\088\001\000\000\088\001\088\001\000\000\088\001\088\001\
\088\001\088\001\000\000\088\001\088\001\000\000\088\001\000\000\
\000\000\000\000\088\001\097\001\097\001\097\001\097\001\097\001\
\000\000\097\001\097\001\097\001\097\001\097\001\097\001\097\001\
\097\001\097\001\097\001\097\001\097\001\097\001\097\001\097\001\
\097\001\000\000\000\000\097\001\097\001\097\001\097\001\097\001\
\097\001\097\001\097\001\000\000\000\000\000\000\000\000\097\001\
\097\001\000\000\000\000\097\001\097\001\097\001\097\001\097\001\
\097\001\097\001\000\000\097\001\097\001\097\001\097\001\000\000\
\097\001\097\001\097\001\097\001\000\000\000\000\097\001\097\001\
\097\001\000\000\097\001\097\001\097\001\097\001\097\001\097\001\
\000\000\097\001\097\001\097\001\097\001\097\001\000\000\097\001\
\000\000\000\000\000\000\097\001\097\001\097\001\097\001\097\001\
\097\001\097\001\097\001\000\000\097\001\000\000\097\001\097\001\
\033\001\097\001\097\001\097\001\000\000\000\000\000\000\097\001\
\097\001\000\000\097\001\097\001\097\001\097\001\000\000\097\001\
\097\001\000\000\097\001\000\000\000\000\000\000\097\001\099\001\
\099\001\099\001\099\001\099\001\000\000\099\001\099\001\099\001\
\099\001\099\001\099\001\099\001\099\001\099\001\099\001\099\001\
\099\001\099\001\099\001\099\001\099\001\000\000\000\000\099\001\
\099\001\099\001\099\001\099\001\099\001\099\001\099\001\000\000\
\000\000\000\000\000\000\099\001\099\001\000\000\000\000\099\001\
\099\001\099\001\099\001\099\001\099\001\099\001\000\000\099\001\
\099\001\099\001\099\001\000\000\099\001\099\001\099\001\099\001\
\000\000\000\000\099\001\099\001\099\001\000\000\099\001\099\001\
\099\001\099\001\099\001\099\001\000\000\099\001\099\001\099\001\
\099\001\099\001\000\000\099\001\000\000\000\000\000\000\099\001\
\099\001\099\001\099\001\099\001\099\001\099\001\099\001\000\000\
\099\001\000\000\099\001\099\001\034\001\099\001\099\001\099\001\
\000\000\000\000\000\000\099\001\099\001\000\000\099\001\099\001\
\099\001\099\001\000\000\099\001\099\001\000\000\099\001\000\000\
\000\000\000\000\099\001\000\000\102\001\102\001\102\001\102\001\
\102\001\000\000\102\001\102\001\102\001\102\001\102\001\102\001\
\102\001\102\001\102\001\102\001\102\001\102\001\102\001\102\001\
\102\001\102\001\000\000\000\000\102\001\102\001\102\001\102\001\
\102\001\102\001\102\001\102\001\000\000\000\000\000\000\000\000\
\102\001\102\001\000\000\000\000\102\001\102\001\102\001\102\001\
\102\001\102\001\102\001\000\000\102\001\102\001\102\001\102\001\
\000\000\102\001\102\001\102\001\102\001\000\000\000\000\102\001\
\102\001\102\001\000\000\102\001\102\001\102\001\102\001\102\001\
\102\001\000\000\102\001\102\001\102\001\102\001\102\001\000\000\
\102\001\000\000\000\000\000\000\102\001\102\001\102\001\102\001\
\102\001\102\001\102\001\102\001\000\000\102\001\000\000\102\001\
\102\001\228\000\102\001\102\001\102\001\000\000\000\000\000\000\
\102\001\102\001\000\000\102\001\102\001\102\001\102\001\000\000\
\102\001\102\001\000\000\102\001\000\000\000\000\000\000\102\001\
\033\001\033\001\033\001\033\001\000\000\000\000\000\000\000\000\
\033\001\033\001\033\001\000\000\000\000\033\001\033\001\033\001\
\033\001\033\001\033\001\033\001\033\001\033\001\033\001\000\000\
\033\001\033\001\033\001\033\001\033\001\033\001\000\000\000\000\
\000\000\000\000\000\000\000\000\033\001\033\001\000\000\000\000\
\033\001\033\001\033\001\033\001\033\001\033\001\033\001\033\001\
\033\001\033\001\000\000\033\001\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\033\001\033\001\000\000\033\001\
\000\000\000\000\033\001\033\001\033\001\000\000\033\001\033\001\
\033\001\033\001\033\001\000\000\000\000\000\000\000\000\000\000\
\033\001\033\001\033\001\033\001\033\001\033\001\033\001\000\000\
\000\000\033\001\000\000\033\001\033\001\240\000\033\001\033\001\
\033\001\033\001\033\001\000\000\033\001\000\000\000\000\033\001\
\033\001\033\001\000\000\000\000\033\001\000\000\000\000\033\001\
\000\000\000\000\000\000\033\001\034\001\034\001\034\001\034\001\
\000\000\000\000\000\000\000\000\034\001\034\001\034\001\000\000\
\000\000\034\001\034\001\034\001\034\001\034\001\034\001\034\001\
\034\001\034\001\034\001\000\000\034\001\034\001\034\001\034\001\
\034\001\034\001\000\000\000\000\000\000\000\000\000\000\000\000\
\034\001\034\001\000\000\000\000\034\001\034\001\034\001\034\001\
\034\001\034\001\034\001\034\001\034\001\034\001\000\000\034\001\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\034\001\034\001\000\000\034\001\000\000\000\000\034\001\034\001\
\034\001\000\000\034\001\034\001\034\001\034\001\034\001\000\000\
\000\000\000\000\000\000\000\000\034\001\034\001\034\001\034\001\
\034\001\034\001\034\001\000\000\000\000\034\001\000\000\034\001\
\034\001\241\000\034\001\034\001\034\001\034\001\034\001\000\000\
\034\001\000\000\000\000\034\001\034\001\034\001\000\000\000\000\
\034\001\000\000\000\000\034\001\000\000\000\000\000\000\034\001\
\000\000\228\000\228\000\228\000\228\000\000\000\000\000\000\000\
\000\000\228\000\228\000\228\000\000\000\000\000\228\000\228\000\
\228\000\228\000\228\000\228\000\228\000\228\000\228\000\000\000\
\000\000\228\000\228\000\228\000\228\000\228\000\228\000\000\000\
\000\000\000\000\000\000\000\000\000\000\228\000\228\000\000\000\
\000\000\228\000\228\000\228\000\228\000\228\000\228\000\228\000\
\000\000\228\000\228\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\228\000\228\000\000\000\
\228\000\000\000\000\000\228\000\228\000\228\000\000\000\228\000\
\228\000\228\000\228\000\228\000\000\000\000\000\000\000\000\000\
\000\000\228\000\000\000\228\000\228\000\228\000\228\000\228\000\
\000\000\000\000\000\000\000\000\228\000\228\000\242\000\228\000\
\228\000\228\000\000\000\000\000\000\000\228\000\000\000\000\000\
\228\000\000\000\228\000\000\000\000\000\228\000\000\000\000\000\
\228\000\000\000\000\000\000\000\228\000\240\000\240\000\240\000\
\240\000\000\000\000\000\000\000\000\000\240\000\240\000\240\000\
\000\000\000\000\240\000\240\000\240\000\240\000\240\000\000\000\
\240\000\240\000\240\000\000\000\000\000\240\000\240\000\240\000\
\240\000\240\000\240\000\000\000\000\000\000\000\000\000\000\000\
\000\000\240\000\240\000\000\000\000\000\240\000\240\000\240\000\
\240\000\240\000\240\000\240\000\000\000\240\000\240\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\240\000\240\000\000\000\240\000\000\000\000\000\240\000\
\240\000\240\000\000\000\240\000\240\000\240\000\240\000\240\000\
\000\000\000\000\000\000\000\000\000\000\240\000\000\000\240\000\
\240\000\240\000\240\000\240\000\000\000\000\000\000\000\000\000\
\240\000\240\000\025\001\240\000\240\000\240\000\240\000\000\000\
\000\000\240\000\000\000\000\000\240\000\000\000\240\000\000\000\
\000\000\240\000\000\000\000\000\240\000\000\000\000\000\000\000\
\240\000\241\000\241\000\241\000\241\000\000\000\000\000\000\000\
\000\000\241\000\241\000\241\000\000\000\000\000\241\000\241\000\
\241\000\241\000\241\000\241\000\241\000\241\000\241\000\000\000\
\000\000\241\000\241\000\241\000\241\000\241\000\241\000\000\000\
\000\000\000\000\000\000\000\000\000\000\241\000\241\000\000\000\
\000\000\241\000\241\000\241\000\241\000\241\000\241\000\241\000\
\000\000\241\000\241\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\241\000\241\000\000\000\
\241\000\000\000\000\000\241\000\241\000\241\000\000\000\241\000\
\241\000\241\000\241\000\241\000\000\000\000\000\000\000\000\000\
\000\000\241\000\000\000\241\000\241\000\241\000\241\000\241\000\
\000\000\000\000\000\000\000\000\241\000\241\000\026\001\241\000\
\241\000\241\000\000\000\000\000\000\000\241\000\000\000\000\000\
\241\000\000\000\241\000\000\000\000\000\241\000\000\000\000\000\
\241\000\000\000\000\000\000\000\241\000\000\000\242\000\242\000\
\242\000\242\000\000\000\000\000\000\000\000\000\242\000\242\000\
\242\000\000\000\000\000\242\000\242\000\242\000\242\000\242\000\
\242\000\242\000\242\000\242\000\000\000\000\000\242\000\242\000\
\242\000\242\000\242\000\242\000\000\000\000\000\000\000\000\000\
\000\000\000\000\242\000\242\000\000\000\000\000\242\000\242\000\
\242\000\242\000\242\000\242\000\242\000\000\000\242\000\242\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\242\000\242\000\000\000\242\000\000\000\000\000\
\242\000\242\000\242\000\000\000\242\000\242\000\242\000\242\000\
\242\000\000\000\000\000\000\000\000\000\000\000\242\000\000\000\
\242\000\242\000\242\000\242\000\242\000\000\000\000\000\000\000\
\000\000\242\000\242\000\251\000\242\000\242\000\242\000\000\000\
\000\000\000\000\242\000\000\000\000\000\242\000\000\000\242\000\
\000\000\000\000\242\000\000\000\000\000\242\000\000\000\000\000\
\000\000\242\000\025\001\025\001\025\001\025\001\000\000\000\000\
\000\000\000\000\025\001\025\001\025\001\000\000\000\000\025\001\
\025\001\025\001\025\001\025\001\025\001\025\001\025\001\025\001\
\000\000\000\000\025\001\025\001\025\001\025\001\025\001\025\001\
\000\000\000\000\000\000\000\000\000\000\000\000\025\001\025\001\
\000\000\000\000\025\001\025\001\025\001\025\001\025\001\025\001\
\025\001\000\000\025\001\025\001\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\025\001\025\001\
\000\000\025\001\000\000\000\000\025\001\025\001\025\001\000\000\
\025\001\025\001\025\001\025\001\025\001\000\000\000\000\000\000\
\000\000\000\000\025\001\000\000\025\001\025\001\025\001\025\001\
\025\001\000\000\000\000\000\000\000\000\025\001\025\001\252\000\
\025\001\025\001\025\001\000\000\000\000\000\000\025\001\000\000\
\000\000\025\001\000\000\025\001\000\000\000\000\025\001\000\000\
\000\000\025\001\000\000\000\000\000\000\025\001\026\001\026\001\
\026\001\026\001\000\000\000\000\000\000\000\000\026\001\026\001\
\026\001\000\000\000\000\026\001\026\001\026\001\026\001\026\001\
\026\001\026\001\026\001\026\001\000\000\000\000\026\001\026\001\
\026\001\026\001\026\001\026\001\000\000\000\000\000\000\000\000\
\000\000\000\000\026\001\026\001\000\000\000\000\026\001\026\001\
\026\001\026\001\026\001\026\001\026\001\000\000\026\001\026\001\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\026\001\026\001\000\000\026\001\000\000\000\000\
\026\001\026\001\026\001\000\000\026\001\026\001\026\001\026\001\
\026\001\000\000\000\000\000\000\000\000\000\000\026\001\000\000\
\026\001\026\001\026\001\026\001\026\001\000\000\000\000\000\000\
\000\000\026\001\026\001\003\001\026\001\026\001\026\001\000\000\
\000\000\000\000\026\001\000\000\000\000\026\001\000\000\026\001\
\000\000\000\000\026\001\000\000\000\000\026\001\000\000\000\000\
\000\000\026\001\000\000\251\000\251\000\251\000\251\000\000\000\
\000\000\000\000\000\000\251\000\251\000\251\000\000\000\000\000\
\251\000\251\000\251\000\251\000\251\000\251\000\251\000\251\000\
\251\000\000\000\000\000\251\000\251\000\251\000\251\000\251\000\
\251\000\000\000\000\000\000\000\000\000\000\000\000\000\251\000\
\251\000\000\000\000\000\251\000\251\000\251\000\251\000\251\000\
\251\000\000\000\000\000\251\000\251\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\251\000\
\251\000\000\000\251\000\000\000\000\000\251\000\251\000\251\000\
\000\000\251\000\251\000\251\000\251\000\251\000\000\000\000\000\
\000\000\000\000\000\000\251\000\000\000\251\000\251\000\251\000\
\251\000\251\000\000\000\000\000\000\000\000\000\251\000\251\000\
\002\001\251\000\251\000\251\000\251\000\000\000\000\000\251\000\
\000\000\000\000\251\000\000\000\251\000\000\000\000\000\251\000\
\000\000\000\000\251\000\000\000\000\000\000\000\251\000\252\000\
\252\000\252\000\252\000\000\000\000\000\000\000\000\000\252\000\
\252\000\252\000\000\000\000\000\252\000\252\000\252\000\252\000\
\252\000\252\000\252\000\252\000\252\000\000\000\000\000\252\000\
\252\000\252\000\252\000\252\000\252\000\000\000\000\000\000\000\
\000\000\000\000\000\000\252\000\252\000\000\000\000\000\252\000\
\252\000\252\000\252\000\252\000\252\000\000\000\000\000\252\000\
\252\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\252\000\252\000\000\000\252\000\000\000\
\000\000\252\000\252\000\252\000\000\000\252\000\252\000\252\000\
\252\000\252\000\000\000\000\000\000\000\000\000\000\000\252\000\
\000\000\252\000\252\000\252\000\252\000\252\000\000\000\000\000\
\000\000\000\000\252\000\252\000\234\000\252\000\252\000\252\000\
\252\000\000\000\000\000\252\000\000\000\000\000\252\000\000\000\
\252\000\000\000\000\000\252\000\000\000\000\000\252\000\000\000\
\000\000\000\000\252\000\003\001\003\001\003\001\003\001\000\000\
\000\000\000\000\000\000\003\001\003\001\003\001\000\000\000\000\
\003\001\003\001\003\001\003\001\003\001\003\001\003\001\003\001\
\003\001\000\000\000\000\003\001\003\001\003\001\003\001\003\001\
\003\001\000\000\000\000\000\000\000\000\000\000\000\000\003\001\
\003\001\000\000\000\000\003\001\003\001\003\001\003\001\003\001\
\003\001\000\000\000\000\003\001\003\001\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\001\
\003\001\000\000\003\001\000\000\000\000\003\001\003\001\003\001\
\000\000\003\001\003\001\003\001\003\001\003\001\000\000\000\000\
\000\000\000\000\000\000\003\001\000\000\003\001\003\001\003\001\
\003\001\003\001\000\000\000\000\000\000\000\000\003\001\003\001\
\237\000\003\001\003\001\003\001\003\001\000\000\000\000\003\001\
\000\000\000\000\003\001\000\000\003\001\000\000\000\000\003\001\
\000\000\000\000\003\001\000\000\000\000\000\000\003\001\000\000\
\002\001\002\001\002\001\002\001\000\000\000\000\000\000\000\000\
\002\001\002\001\002\001\000\000\000\000\002\001\002\001\002\001\
\002\001\002\001\002\001\002\001\002\001\002\001\000\000\000\000\
\002\001\002\001\002\001\002\001\002\001\002\001\000\000\000\000\
\000\000\000\000\000\000\000\000\002\001\002\001\000\000\000\000\
\002\001\002\001\002\001\002\001\002\001\002\001\000\000\000\000\
\002\001\002\001\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\002\001\002\001\000\000\002\001\
\000\000\000\000\002\001\002\001\002\001\000\000\002\001\002\001\
\002\001\002\001\002\001\000\000\000\000\000\000\000\000\000\000\
\002\001\000\000\002\001\002\001\002\001\002\001\002\001\000\000\
\000\000\000\000\000\000\002\001\002\001\238\000\002\001\002\001\
\002\001\002\001\000\000\000\000\002\001\000\000\000\000\002\001\
\000\000\002\001\000\000\000\000\002\001\000\000\000\000\002\001\
\000\000\000\000\000\000\002\001\234\000\234\000\234\000\234\000\
\000\000\000\000\000\000\000\000\000\000\234\000\234\000\000\000\
\000\000\234\000\234\000\234\000\234\000\234\000\234\000\234\000\
\234\000\234\000\000\000\000\000\234\000\234\000\234\000\234\000\
\234\000\234\000\000\000\000\000\000\000\000\000\000\000\000\000\
\234\000\234\000\000\000\000\000\234\000\234\000\234\000\234\000\
\234\000\234\000\234\000\000\000\234\000\234\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\234\000\234\000\000\000\234\000\000\000\000\000\234\000\234\000\
\234\000\000\000\234\000\234\000\234\000\234\000\234\000\000\000\
\000\000\000\000\000\000\000\000\234\000\000\000\234\000\234\000\
\234\000\234\000\234\000\000\000\000\000\000\000\000\000\234\000\
\234\000\250\000\234\000\234\000\234\000\234\000\000\000\000\000\
\234\000\000\000\000\000\234\000\000\000\234\000\000\000\000\000\
\234\000\000\000\000\000\234\000\000\000\000\000\000\000\234\000\
\237\000\237\000\237\000\237\000\000\000\000\000\000\000\000\000\
\000\000\237\000\237\000\000\000\000\000\237\000\237\000\237\000\
\237\000\237\000\237\000\237\000\237\000\237\000\000\000\000\000\
\237\000\237\000\237\000\237\000\237\000\237\000\000\000\000\000\
\000\000\000\000\000\000\000\000\237\000\237\000\000\000\000\000\
\237\000\237\000\237\000\237\000\237\000\237\000\237\000\000\000\
\237\000\237\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\237\000\237\000\000\000\237\000\
\000\000\000\000\237\000\237\000\237\000\000\000\237\000\237\000\
\237\000\237\000\237\000\000\000\000\000\000\000\000\000\000\000\
\237\000\000\000\237\000\237\000\237\000\237\000\237\000\000\000\
\000\000\000\000\000\000\237\000\237\000\000\001\237\000\237\000\
\237\000\237\000\000\000\000\000\237\000\000\000\000\000\237\000\
\000\000\237\000\000\000\000\000\237\000\000\000\000\000\237\000\
\000\000\000\000\000\000\237\000\000\000\238\000\238\000\238\000\
\238\000\000\000\000\000\000\000\000\000\000\000\238\000\238\000\
\000\000\000\000\238\000\238\000\238\000\238\000\238\000\238\000\
\238\000\238\000\238\000\000\000\000\000\238\000\238\000\238\000\
\238\000\238\000\238\000\000\000\000\000\000\000\000\000\000\000\
\000\000\238\000\238\000\000\000\000\000\238\000\238\000\238\000\
\238\000\238\000\238\000\238\000\000\000\238\000\238\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\238\000\238\000\000\000\238\000\000\000\000\000\238\000\
\238\000\238\000\000\000\238\000\238\000\238\000\238\000\238\000\
\000\000\000\000\000\000\000\000\000\000\238\000\000\000\238\000\
\238\000\238\000\238\000\238\000\000\000\000\000\000\000\000\000\
\238\000\238\000\001\001\238\000\238\000\238\000\238\000\000\000\
\000\000\238\000\000\000\000\000\238\000\000\000\238\000\000\000\
\000\000\238\000\000\000\000\000\238\000\000\000\000\000\000\000\
\238\000\250\000\250\000\250\000\250\000\000\000\000\000\000\000\
\000\000\250\000\250\000\250\000\000\000\000\000\250\000\250\000\
\250\000\250\000\250\000\250\000\250\000\250\000\250\000\000\000\
\000\000\250\000\250\000\250\000\250\000\250\000\250\000\000\000\
\000\000\000\000\000\000\000\000\000\000\250\000\250\000\000\000\
\000\000\250\000\250\000\250\000\250\000\250\000\000\000\000\000\
\000\000\250\000\250\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\250\000\250\000\000\000\
\250\000\000\000\000\000\250\000\250\000\250\000\000\000\250\000\
\250\000\250\000\250\000\250\000\000\000\000\000\000\000\000\000\
\000\000\250\000\000\000\250\000\000\000\250\000\250\000\250\000\
\000\000\000\000\000\000\000\000\250\000\250\000\253\000\250\000\
\250\000\250\000\250\000\000\000\000\000\000\000\000\000\000\000\
\250\000\000\000\250\000\000\000\000\000\250\000\000\000\000\000\
\250\000\000\000\000\000\000\000\250\000\000\001\000\001\000\001\
\000\001\000\000\000\000\000\000\000\000\000\001\000\001\000\001\
\000\000\000\000\000\001\000\001\000\001\000\001\000\001\000\001\
\000\001\000\001\000\001\000\000\000\000\000\001\000\001\000\001\
\000\001\000\001\000\001\000\000\000\000\000\000\000\000\000\000\
\000\000\000\001\000\001\000\000\000\000\000\001\000\001\000\001\
\000\001\000\001\000\000\000\000\000\000\000\001\000\001\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\001\000\001\000\000\000\001\000\000\000\000\000\001\
\000\001\000\001\000\000\000\001\000\001\000\001\000\001\000\001\
\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\001\
\000\000\000\001\000\001\000\001\000\000\000\000\000\000\000\000\
\000\001\000\001\254\000\000\001\000\001\000\001\000\001\000\000\
\000\000\000\000\000\000\000\000\000\001\000\000\000\001\000\000\
\000\000\000\001\000\000\000\000\000\001\000\000\000\000\000\000\
\000\001\000\000\001\001\001\001\001\001\001\001\000\000\000\000\
\000\000\000\000\001\001\001\001\001\001\000\000\000\000\001\001\
\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\
\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\
\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\
\000\000\000\000\001\001\001\001\001\001\001\001\001\001\000\000\
\000\000\000\000\001\001\001\001\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\
\000\000\001\001\000\000\000\000\001\001\001\001\001\001\000\000\
\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\
\000\000\000\000\001\001\000\000\001\001\000\000\001\001\001\001\
\001\001\000\000\000\000\000\000\000\000\001\001\001\001\255\000\
\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\
\000\000\001\001\000\000\001\001\000\000\000\000\001\001\000\000\
\000\000\001\001\000\000\000\000\000\000\001\001\253\000\253\000\
\253\000\253\000\000\000\000\000\000\000\000\000\253\000\253\000\
\253\000\000\000\000\000\253\000\253\000\253\000\253\000\253\000\
\253\000\253\000\253\000\253\000\000\000\000\000\253\000\253\000\
\253\000\253\000\253\000\253\000\000\000\000\000\000\000\000\000\
\000\000\000\000\253\000\253\000\000\000\000\000\253\000\253\000\
\253\000\253\000\253\000\000\000\000\000\000\000\253\000\253\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\253\000\253\000\000\000\253\000\000\000\000\000\
\253\000\253\000\253\000\000\000\253\000\253\000\253\000\253\000\
\253\000\000\000\000\000\000\000\000\000\000\000\253\000\000\000\
\253\000\000\000\253\000\253\000\253\000\000\000\000\000\000\000\
\000\000\253\000\253\000\208\000\253\000\253\000\253\000\253\000\
\000\000\000\000\000\000\000\000\000\000\253\000\000\000\253\000\
\000\000\000\000\253\000\000\000\000\000\253\000\000\000\000\000\
\000\000\253\000\254\000\254\000\254\000\254\000\000\000\000\000\
\000\000\000\000\254\000\254\000\254\000\000\000\000\000\254\000\
\254\000\254\000\254\000\254\000\254\000\254\000\254\000\254\000\
\000\000\000\000\254\000\254\000\254\000\254\000\254\000\254\000\
\000\000\000\000\000\000\000\000\000\000\000\000\254\000\254\000\
\000\000\000\000\254\000\254\000\254\000\254\000\254\000\000\000\
\000\000\000\000\254\000\254\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\254\000\254\000\
\000\000\254\000\000\000\000\000\254\000\254\000\254\000\000\000\
\254\000\254\000\254\000\254\000\254\000\000\000\000\000\000\000\
\000\000\000\000\254\000\000\000\254\000\000\000\254\000\254\000\
\254\000\000\000\000\000\000\000\000\000\254\000\254\000\004\001\
\254\000\254\000\254\000\254\000\000\000\000\000\000\000\000\000\
\000\000\254\000\000\000\254\000\000\000\000\000\254\000\000\000\
\000\000\254\000\000\000\000\000\000\000\254\000\000\000\255\000\
\255\000\255\000\255\000\000\000\000\000\000\000\000\000\255\000\
\255\000\255\000\000\000\000\000\255\000\255\000\255\000\255\000\
\255\000\255\000\255\000\255\000\255\000\000\000\000\000\255\000\
\255\000\255\000\255\000\255\000\255\000\000\000\000\000\000\000\
\000\000\000\000\000\000\255\000\255\000\000\000\000\000\255\000\
\255\000\255\000\255\000\255\000\000\000\000\000\000\000\255\000\
\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\255\000\255\000\000\000\255\000\000\000\
\000\000\255\000\255\000\255\000\000\000\255\000\255\000\255\000\
\255\000\255\000\000\000\000\000\000\000\000\000\000\000\255\000\
\000\000\255\000\000\000\255\000\255\000\255\000\000\000\000\000\
\000\000\000\000\255\000\255\000\006\001\255\000\255\000\255\000\
\255\000\000\000\000\000\000\000\000\000\000\000\255\000\000\000\
\255\000\000\000\000\000\255\000\000\000\000\000\255\000\000\000\
\000\000\000\000\255\000\208\000\208\000\208\000\208\000\000\000\
\000\000\000\000\000\000\208\000\208\000\208\000\000\000\000\000\
\208\000\208\000\208\000\208\000\208\000\208\000\208\000\208\000\
\208\000\000\000\000\000\208\000\208\000\208\000\208\000\208\000\
\208\000\000\000\000\000\000\000\000\000\000\000\000\000\208\000\
\208\000\000\000\000\000\208\000\208\000\208\000\208\000\208\000\
\208\000\208\000\000\000\208\000\208\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\208\000\
\208\000\000\000\000\000\000\000\000\000\208\000\208\000\208\000\
\000\000\208\000\000\000\000\000\208\000\208\000\000\000\000\000\
\000\000\000\000\000\000\208\000\000\000\208\000\000\000\000\000\
\000\000\208\000\000\000\000\000\000\000\000\000\208\000\208\000\
\248\000\208\000\208\000\208\000\208\000\000\000\000\000\208\000\
\000\000\000\000\208\000\000\000\208\000\000\000\000\000\208\000\
\000\000\000\000\208\000\000\000\000\000\000\000\208\000\004\001\
\004\001\004\001\004\001\000\000\000\000\000\000\000\000\004\001\
\004\001\004\001\000\000\000\000\004\001\004\001\000\000\004\001\
\004\001\004\001\004\001\004\001\004\001\000\000\000\000\004\001\
\004\001\004\001\004\001\004\001\004\001\000\000\000\000\000\000\
\000\000\000\000\000\000\004\001\004\001\000\000\000\000\004\001\
\004\001\004\001\000\000\000\000\000\000\000\000\000\000\004\001\
\004\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\004\001\004\001\000\000\004\001\000\000\
\000\000\000\000\004\001\004\001\000\000\004\001\000\000\000\000\
\004\001\004\001\000\000\000\000\000\000\000\000\000\000\004\001\
\000\000\004\001\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\004\001\004\001\249\000\004\001\004\001\004\001\
\004\001\000\000\000\000\000\000\000\000\000\000\004\001\000\000\
\004\001\000\000\000\000\004\001\000\000\000\000\004\001\000\000\
\000\000\000\000\004\001\000\000\006\001\006\001\006\001\006\001\
\000\000\000\000\000\000\000\000\006\001\006\001\006\001\000\000\
\000\000\006\001\006\001\000\000\006\001\006\001\006\001\006\001\
\006\001\006\001\000\000\000\000\006\001\006\001\006\001\006\001\
\006\001\006\001\000\000\000\000\000\000\000\000\000\000\000\000\
\006\001\006\001\000\000\000\000\006\001\006\001\006\001\000\000\
\000\000\000\000\000\000\000\000\006\001\006\001\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\006\001\006\001\000\000\006\001\000\000\000\000\000\000\006\001\
\006\001\000\000\006\001\000\000\000\000\006\001\006\001\000\000\
\000\000\000\000\000\000\000\000\006\001\000\000\006\001\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006\001\
\006\001\005\001\006\001\006\001\006\001\006\001\000\000\000\000\
\000\000\000\000\000\000\006\001\000\000\006\001\000\000\000\000\
\006\001\000\000\000\000\006\001\000\000\000\000\000\000\006\001\
\248\000\248\000\248\000\248\000\000\000\000\000\000\000\000\000\
\248\000\248\000\248\000\000\000\000\000\248\000\248\000\000\000\
\248\000\248\000\248\000\248\000\248\000\248\000\000\000\000\000\
\248\000\248\000\248\000\248\000\248\000\248\000\000\000\000\000\
\000\000\000\000\000\000\000\000\248\000\248\000\000\000\000\000\
\248\000\248\000\248\000\000\000\000\000\000\000\000\000\000\000\
\248\000\248\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\248\000\248\000\000\000\248\000\
\000\000\000\000\000\000\248\000\248\000\000\000\248\000\000\000\
\000\000\248\000\248\000\000\000\000\000\000\000\000\000\000\000\
\248\000\010\001\248\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\248\000\248\000\000\000\248\000\248\000\
\248\000\248\000\000\000\000\000\000\000\000\000\000\000\248\000\
\000\000\248\000\000\000\000\000\248\000\000\000\000\000\248\000\
\000\000\000\000\000\000\248\000\249\000\249\000\249\000\249\000\
\000\000\000\000\000\000\000\000\249\000\249\000\249\000\000\000\
\000\000\249\000\249\000\000\000\249\000\249\000\249\000\249\000\
\249\000\249\000\000\000\000\000\249\000\249\000\249\000\249\000\
\249\000\249\000\000\000\000\000\000\000\000\000\000\000\000\000\
\249\000\249\000\000\000\000\000\249\000\249\000\249\000\000\000\
\000\000\000\000\000\000\000\000\249\000\249\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\249\000\249\000\000\000\249\000\000\000\000\000\000\000\249\000\
\249\000\009\001\249\000\000\000\000\000\249\000\249\000\000\000\
\000\000\000\000\000\000\000\000\249\000\000\000\249\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\249\000\
\249\000\000\000\249\000\249\000\249\000\249\000\000\000\000\000\
\000\000\000\000\000\000\249\000\000\000\249\000\000\000\000\000\
\249\000\000\000\000\000\249\000\000\000\000\000\000\000\249\000\
\000\000\005\001\005\001\005\001\005\001\000\000\000\000\000\000\
\000\000\005\001\005\001\005\001\000\000\000\000\005\001\005\001\
\000\000\005\001\005\001\005\001\005\001\005\001\005\001\000\000\
\000\000\005\001\005\001\005\001\005\001\005\001\005\001\000\000\
\000\000\000\000\000\000\000\000\000\000\005\001\005\001\000\000\
\000\000\005\001\005\001\005\001\000\000\000\000\000\000\000\000\
\000\000\005\001\005\001\000\000\000\000\000\000\000\000\000\000\
\000\000\008\001\000\000\000\000\000\000\005\001\005\001\000\000\
\005\001\000\000\000\000\000\000\005\001\005\001\000\000\005\001\
\000\000\000\000\005\001\005\001\000\000\000\000\000\000\000\000\
\000\000\005\001\000\000\005\001\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\005\001\005\001\000\000\005\001\
\005\001\005\001\005\001\000\000\000\000\000\000\000\000\000\000\
\005\001\010\001\005\001\000\000\010\001\005\001\000\000\000\000\
\005\001\010\001\010\001\010\001\005\001\000\000\010\001\010\001\
\000\000\010\001\010\001\010\001\010\001\010\001\010\001\000\000\
\000\000\010\001\010\001\010\001\000\000\010\001\010\001\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\010\001\000\000\
\000\000\010\001\010\001\000\000\000\000\000\000\000\000\000\000\
\000\000\010\001\010\001\000\000\000\000\000\000\000\000\000\000\
\000\000\131\001\000\000\000\000\000\000\010\001\000\000\000\000\
\010\001\000\000\000\000\000\000\010\001\010\001\000\000\010\001\
\000\000\000\000\010\001\010\001\000\000\000\000\000\000\000\000\
\000\000\010\001\000\000\010\001\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\010\001\010\001\000\000\010\001\
\010\001\010\001\010\001\000\000\000\000\000\000\000\000\000\000\
\010\001\009\001\010\001\000\000\009\001\010\001\000\000\000\000\
\010\001\009\001\009\001\009\001\010\001\000\000\009\001\009\001\
\000\000\009\001\009\001\009\001\009\001\009\001\009\001\000\000\
\000\000\009\001\009\001\009\001\000\000\009\001\009\001\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\009\001\000\000\
\000\000\009\001\009\001\000\000\000\000\000\000\000\000\000\000\
\000\000\009\001\009\001\000\000\000\000\000\000\000\000\000\000\
\000\000\007\001\000\000\000\000\000\000\009\001\000\000\000\000\
\009\001\000\000\000\000\000\000\009\001\009\001\000\000\009\001\
\000\000\000\000\009\001\009\001\000\000\000\000\000\000\000\000\
\000\000\009\001\000\000\009\001\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\009\001\009\001\000\000\009\001\
\009\001\009\001\009\001\000\000\000\000\000\000\000\000\000\000\
\009\001\008\001\009\001\000\000\008\001\009\001\000\000\000\000\
\009\001\008\001\000\000\008\001\009\001\000\000\008\001\008\001\
\000\000\008\001\008\001\008\001\008\001\008\001\008\001\000\000\
\000\000\008\001\008\001\008\001\000\000\008\001\008\001\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\008\001\000\000\
\000\000\008\001\008\001\000\000\000\000\000\000\000\000\000\000\
\000\000\008\001\008\001\000\000\000\000\000\000\000\000\000\000\
\000\000\130\001\000\000\000\000\000\000\008\001\000\000\000\000\
\008\001\000\000\000\000\000\000\008\001\008\001\000\000\008\001\
\000\000\000\000\008\001\008\001\000\000\000\000\000\000\000\000\
\000\000\008\001\000\000\000\000\000\000\000\000\000\000\021\003\
\000\000\000\000\000\000\000\000\008\001\008\001\000\000\008\001\
\008\001\008\001\008\001\000\000\000\000\000\000\000\000\000\000\
\008\001\131\001\008\001\000\000\131\001\008\001\000\000\000\000\
\008\001\131\001\000\000\131\001\008\001\000\000\131\001\131\001\
\000\000\131\001\131\001\131\001\131\001\131\001\131\001\000\000\
\000\000\131\001\131\001\131\001\000\000\131\001\131\001\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\131\001\000\000\
\000\000\131\001\131\001\000\000\000\000\000\000\000\000\000\000\
\000\000\131\001\131\001\000\000\011\001\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\131\001\000\000\000\000\
\131\001\000\000\000\000\000\000\131\001\131\001\000\000\131\001\
\000\000\000\000\131\001\131\001\000\000\000\000\000\000\000\000\
\000\000\131\001\021\003\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\131\001\131\001\000\000\131\001\
\131\001\131\001\131\001\000\000\000\000\000\000\000\000\000\000\
\131\001\007\001\131\001\000\000\007\001\131\001\000\000\000\000\
\131\001\007\001\000\000\007\001\131\001\000\000\007\001\007\001\
\000\000\007\001\007\001\007\001\007\001\007\001\007\001\000\000\
\000\000\007\001\007\001\007\001\000\000\007\001\007\001\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\007\001\000\000\
\000\000\007\001\007\001\000\000\000\000\000\000\000\000\024\001\
\000\000\007\001\007\001\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\007\001\000\000\000\000\
\007\001\000\000\000\000\000\000\007\001\007\001\000\000\007\001\
\000\000\000\000\007\001\007\001\000\000\000\000\000\000\000\000\
\000\000\007\001\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\007\001\007\001\000\000\007\001\
\007\001\007\001\007\001\000\000\000\000\000\000\000\000\000\000\
\007\001\130\001\007\001\000\000\130\001\007\001\000\000\000\000\
\007\001\130\001\000\000\130\001\007\001\000\000\130\001\130\001\
\000\000\130\001\130\001\130\001\130\001\130\001\130\001\000\000\
\000\000\130\001\130\001\130\001\000\000\130\001\130\001\021\003\
\000\000\000\000\000\000\000\000\000\000\000\000\130\001\000\000\
\000\000\130\001\130\001\000\000\021\003\000\000\000\000\014\001\
\167\001\130\001\130\001\000\000\000\000\000\000\000\000\000\000\
\000\000\021\003\000\000\021\003\021\003\130\001\000\000\000\000\
\130\001\000\000\000\000\000\000\130\001\130\001\000\000\130\001\
\021\003\000\000\130\001\130\001\000\000\094\000\000\000\000\000\
\136\000\130\001\137\000\138\000\030\000\000\000\139\000\000\000\
\000\000\169\001\141\000\021\003\130\001\130\001\021\003\130\001\
\130\001\130\001\130\001\021\003\011\001\000\000\000\000\011\001\
\130\001\021\003\130\001\000\000\011\001\130\001\011\001\021\003\
\130\001\011\001\011\001\144\000\130\001\011\001\000\000\011\001\
\011\001\011\001\145\000\021\003\011\001\011\001\011\001\021\003\
\011\001\011\001\021\003\000\000\000\000\021\003\146\000\147\000\
\000\000\011\001\000\000\021\003\011\001\011\001\021\003\021\003\
\000\000\000\000\243\000\000\000\011\001\011\001\000\000\000\000\
\000\000\000\000\000\000\000\000\021\003\000\000\021\003\021\003\
\011\001\000\000\000\000\011\001\000\000\000\000\000\000\011\001\
\011\001\000\000\011\001\021\003\000\000\011\001\011\001\000\000\
\104\000\174\003\000\000\136\000\011\001\137\000\138\000\030\000\
\000\000\139\000\000\000\000\000\158\001\141\000\021\003\011\001\
\011\001\000\000\011\001\011\001\011\001\011\001\021\003\024\001\
\000\000\000\000\024\001\011\001\021\003\011\001\000\000\024\001\
\011\001\024\001\021\003\011\001\024\001\024\001\144\000\011\001\
\024\001\000\000\024\001\024\001\024\001\145\000\021\003\024\001\
\024\001\024\001\021\003\024\001\024\001\000\000\000\000\000\000\
\000\000\146\000\147\000\000\000\024\001\000\000\021\003\024\001\
\024\001\021\003\000\000\000\000\000\000\017\001\000\000\024\001\
\024\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\024\001\000\000\000\000\024\001\000\000\
\000\000\000\000\024\001\024\001\000\000\024\001\000\000\000\000\
\024\001\024\001\000\000\000\000\000\000\000\000\000\000\024\001\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\024\001\024\001\000\000\024\001\024\001\024\001\
\024\001\000\000\000\000\000\000\000\000\000\000\024\001\014\001\
\024\001\000\000\014\001\024\001\000\000\000\000\024\001\014\001\
\000\000\014\001\024\001\000\000\014\001\014\001\000\000\000\000\
\014\001\000\000\014\001\014\001\014\001\000\000\000\000\014\001\
\014\001\014\001\000\000\014\001\014\001\094\000\000\000\000\000\
\000\000\000\000\000\000\000\000\014\001\000\000\000\000\014\001\
\014\001\000\000\094\000\000\000\000\000\016\001\000\000\014\001\
\014\001\000\000\000\000\000\000\000\000\000\000\000\000\094\000\
\000\000\094\000\094\000\014\001\000\000\000\000\014\001\000\000\
\000\000\000\000\014\001\014\001\000\000\014\001\094\000\000\000\
\014\001\014\001\000\000\021\003\000\000\000\000\136\000\014\001\
\137\000\138\000\030\000\000\000\139\000\000\000\000\000\158\001\
\141\000\094\000\014\001\014\001\000\000\014\001\014\001\014\001\
\014\001\094\000\243\000\000\000\000\000\243\000\014\001\094\000\
\014\001\000\000\243\000\014\001\243\000\094\000\014\001\243\000\
\243\000\144\000\014\001\243\000\000\000\243\000\243\000\243\000\
\145\000\094\000\243\000\243\000\243\000\094\000\243\000\243\000\
\104\000\000\000\000\000\000\000\146\000\147\000\000\000\243\000\
\000\000\094\000\243\000\243\000\094\000\104\000\000\000\000\000\
\015\001\000\000\243\000\243\000\000\000\000\000\000\000\000\000\
\000\000\000\000\104\000\000\000\104\000\104\000\243\000\000\000\
\000\000\243\000\000\000\000\000\000\000\243\000\243\000\000\000\
\243\000\104\000\000\000\243\000\243\000\000\000\099\000\000\000\
\000\000\000\000\243\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\104\000\243\000\243\000\000\000\
\243\000\243\000\243\000\243\000\104\000\017\001\000\000\000\000\
\017\001\243\000\104\000\243\000\000\000\017\001\243\000\017\001\
\104\000\243\000\017\001\017\001\000\000\243\000\017\001\000\000\
\017\001\017\001\017\001\000\000\104\000\017\001\017\001\017\001\
\104\000\017\001\017\001\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\017\001\000\000\104\000\017\001\017\001\104\000\
\000\000\000\000\000\000\020\001\000\000\017\001\017\001\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\017\001\000\000\000\000\017\001\000\000\000\000\000\000\
\017\001\017\001\000\000\017\001\000\000\000\000\017\001\017\001\
\000\000\000\000\000\000\000\000\000\000\017\001\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\017\001\017\001\000\000\017\001\017\001\017\001\017\001\000\000\
\000\000\000\000\000\000\000\000\017\001\016\001\017\001\000\000\
\016\001\017\001\000\000\000\000\017\001\016\001\000\000\016\001\
\017\001\000\000\016\001\016\001\000\000\000\000\016\001\000\000\
\016\001\016\001\016\001\000\000\000\000\016\001\016\001\016\001\
\000\000\016\001\016\001\021\003\000\000\000\000\000\000\000\000\
\000\000\000\000\016\001\000\000\000\000\016\001\016\001\000\000\
\021\003\000\000\000\000\018\001\000\000\016\001\016\001\000\000\
\000\000\000\000\000\000\000\000\000\000\021\003\000\000\021\003\
\021\003\016\001\000\000\000\000\016\001\000\000\000\000\000\000\
\016\001\016\001\000\000\016\001\021\003\000\000\016\001\016\001\
\000\000\103\000\000\000\000\000\000\000\016\001\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\021\003\
\016\001\016\001\000\000\016\001\016\001\016\001\016\001\021\003\
\015\001\000\000\000\000\015\001\016\001\021\003\016\001\000\000\
\015\001\016\001\015\001\021\003\016\001\015\001\015\001\000\000\
\016\001\015\001\000\000\015\001\015\001\015\001\000\000\021\003\
\015\001\015\001\015\001\021\003\015\001\015\001\099\000\000\000\
\000\000\000\000\000\000\000\000\000\000\015\001\000\000\021\003\
\015\001\015\001\021\003\099\000\000\000\000\000\019\001\000\000\
\015\001\015\001\000\000\000\000\000\000\000\000\000\000\000\000\
\099\000\000\000\099\000\099\000\015\001\000\000\000\000\015\001\
\000\000\000\000\000\000\015\001\015\001\000\000\015\001\099\000\
\000\000\015\001\015\001\000\000\000\000\000\000\000\000\000\000\
\015\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\099\000\015\001\015\001\000\000\015\001\015\001\
\015\001\015\001\099\000\020\001\000\000\000\000\020\001\015\001\
\099\000\015\001\000\000\020\001\015\001\020\001\099\000\015\001\
\020\001\020\001\000\000\015\001\020\001\000\000\020\001\020\001\
\020\001\000\000\099\000\020\001\020\001\020\001\099\000\020\001\
\020\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\020\001\000\000\099\000\020\001\020\001\099\000\000\000\000\000\
\000\000\023\001\000\000\020\001\020\001\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\020\001\
\000\000\000\000\020\001\000\000\000\000\000\000\020\001\020\001\
\000\000\020\001\000\000\000\000\020\001\020\001\000\000\000\000\
\000\000\000\000\000\000\020\001\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\020\001\020\001\
\000\000\020\001\020\001\020\001\020\001\000\000\000\000\000\000\
\000\000\000\000\020\001\018\001\020\001\000\000\018\001\020\001\
\000\000\000\000\020\001\018\001\000\000\018\001\020\001\000\000\
\018\001\018\001\000\000\000\000\018\001\000\000\018\001\018\001\
\018\001\000\000\000\000\018\001\018\001\018\001\000\000\018\001\
\018\001\103\000\000\000\000\000\000\000\000\000\000\000\000\000\
\018\001\000\000\000\000\018\001\018\001\000\000\103\000\000\000\
\000\000\021\001\000\000\018\001\018\001\000\000\000\000\000\000\
\000\000\000\000\000\000\103\000\000\000\103\000\103\000\018\001\
\000\000\000\000\018\001\000\000\000\000\000\000\018\001\018\001\
\000\000\018\001\103\000\000\000\018\001\018\001\000\000\000\000\
\000\000\000\000\000\000\018\001\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\103\000\018\001\018\001\
\000\000\018\001\018\001\018\001\018\001\103\000\019\001\000\000\
\000\000\019\001\018\001\103\000\018\001\000\000\019\001\018\001\
\019\001\103\000\018\001\019\001\019\001\000\000\018\001\019\001\
\000\000\019\001\019\001\019\001\000\000\103\000\019\001\019\001\
\019\001\103\000\019\001\019\001\010\000\000\000\157\001\000\000\
\000\000\000\000\000\000\019\001\000\000\103\000\019\001\019\001\
\103\000\000\000\000\000\000\000\022\001\000\000\019\001\019\001\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\019\001\000\000\000\000\019\001\000\000\000\000\
\000\000\019\001\019\001\000\000\019\001\000\000\000\000\019\001\
\019\001\000\000\000\000\000\000\000\000\136\000\019\001\137\000\
\138\000\030\000\000\000\139\000\000\000\000\000\158\001\141\000\
\000\000\019\001\019\001\000\000\019\001\019\001\019\001\019\001\
\000\000\023\001\000\000\000\000\023\001\019\001\000\000\019\001\
\000\000\023\001\019\001\023\001\000\000\019\001\023\001\023\001\
\144\000\019\001\023\001\000\000\023\001\023\001\023\001\145\000\
\000\000\023\001\023\001\023\001\000\000\023\001\023\001\000\000\
\000\000\000\000\000\000\146\000\147\000\000\000\023\001\000\000\
\000\000\023\001\023\001\000\000\000\000\000\000\000\000\207\000\
\000\000\023\001\023\001\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\023\001\000\000\000\000\
\023\001\000\000\000\000\000\000\023\001\023\001\000\000\023\001\
\000\000\000\000\023\001\023\001\000\000\000\000\000\000\000\000\
\000\000\023\001\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\023\001\023\001\000\000\023\001\
\023\001\023\001\023\001\000\000\000\000\000\000\000\000\000\000\
\023\001\021\001\023\001\000\000\021\001\023\001\000\000\000\000\
\023\001\021\001\000\000\021\001\023\001\000\000\021\001\021\001\
\000\000\000\000\021\001\000\000\021\001\021\001\021\001\000\000\
\000\000\021\001\021\001\021\001\000\000\021\001\021\001\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\021\001\000\000\
\000\000\021\001\021\001\000\000\000\000\000\000\000\000\244\000\
\000\000\021\001\021\001\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\021\001\000\000\000\000\
\021\001\000\000\000\000\000\000\021\001\021\001\000\000\021\001\
\000\000\000\000\021\001\021\001\000\000\000\000\000\000\000\000\
\000\000\021\001\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\021\001\021\001\000\000\021\001\
\021\001\021\001\021\001\000\000\022\001\000\000\000\000\022\001\
\021\001\000\000\021\001\000\000\022\001\021\001\022\001\000\000\
\021\001\022\001\022\001\000\000\021\001\022\001\000\000\022\001\
\022\001\022\001\000\000\000\000\022\001\022\001\022\001\000\000\
\022\001\022\001\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\022\001\000\000\000\000\022\001\022\001\000\000\000\000\
\000\000\000\000\000\000\000\000\022\001\022\001\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\061\002\000\000\000\000\
\022\001\000\000\000\000\022\001\000\000\000\000\000\000\022\001\
\022\001\000\000\022\001\000\000\000\000\022\001\022\001\000\000\
\000\000\000\000\000\000\000\000\022\001\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\022\001\
\022\001\000\000\022\001\022\001\022\001\022\001\000\000\207\000\
\000\000\000\000\207\000\022\001\000\000\022\001\000\000\207\000\
\022\001\207\000\000\000\022\001\207\000\207\000\000\000\022\001\
\207\000\000\000\207\000\207\000\207\000\000\000\000\000\207\000\
\207\000\207\000\000\000\207\000\207\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\207\000\000\000\000\000\207\000\
\207\000\000\000\000\000\000\000\000\000\000\000\000\000\207\000\
\207\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\095\002\000\000\000\000\207\000\000\000\000\000\207\000\000\000\
\000\000\000\000\207\000\207\000\000\000\207\000\000\000\000\000\
\207\000\207\000\000\000\000\000\000\000\000\000\000\000\207\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\207\000\207\000\000\000\207\000\000\000\207\000\
\207\000\000\000\000\000\000\000\000\000\000\000\207\000\244\000\
\207\000\000\000\244\000\207\000\000\000\000\000\207\000\244\000\
\000\000\244\000\207\000\000\000\244\000\244\000\000\000\000\000\
\244\000\000\000\244\000\244\000\244\000\000\000\000\000\244\000\
\000\000\244\000\000\000\244\000\244\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\244\000\000\000\000\000\244\000\
\244\000\000\000\000\000\000\000\000\000\000\000\000\000\244\000\
\244\000\000\000\000\000\059\002\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\244\000\000\000\000\000\244\000\000\000\
\000\000\000\000\244\000\244\000\000\000\244\000\000\000\000\000\
\244\000\244\000\000\000\000\000\000\000\000\000\000\000\244\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\244\000\244\000\000\000\244\000\244\000\244\000\
\244\000\000\000\000\000\000\000\000\000\000\000\244\000\000\000\
\244\000\000\000\000\000\244\000\000\000\061\002\244\000\061\002\
\061\002\061\002\244\000\000\000\000\000\061\002\000\000\000\000\
\000\000\000\000\061\002\000\000\000\000\000\000\061\002\061\002\
\061\002\000\000\000\000\000\000\000\000\154\003\000\000\061\002\
\061\002\061\002\061\002\000\000\000\000\000\000\000\000\000\000\
\000\000\061\002\000\000\000\000\000\000\061\002\061\002\000\000\
\057\002\000\000\000\000\000\000\000\000\061\002\061\002\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\061\002\000\000\000\000\061\002\000\000\000\000\061\002\
\061\002\061\002\000\000\061\002\000\000\000\000\061\002\061\002\
\000\000\000\000\000\000\000\000\136\000\061\002\137\000\138\000\
\030\000\000\000\139\000\000\000\000\000\140\000\141\000\000\000\
\061\002\061\002\000\000\061\002\061\002\061\002\000\000\000\000\
\095\002\061\002\095\002\095\002\095\002\000\000\142\000\000\000\
\095\002\061\002\000\000\000\000\061\002\095\002\143\000\144\000\
\061\002\095\002\095\002\095\002\000\000\000\000\145\000\000\000\
\000\000\000\000\095\002\095\002\095\002\095\002\000\000\000\000\
\059\005\000\000\146\000\147\000\095\002\000\000\000\000\000\000\
\000\000\095\002\000\000\058\002\000\000\000\000\000\000\160\005\
\095\002\095\002\000\000\000\000\000\000\000\000\243\001\000\000\
\000\000\000\000\000\000\000\000\095\002\000\000\000\000\095\002\
\000\000\000\000\095\002\095\002\095\002\000\000\095\002\000\000\
\000\000\095\002\095\002\000\000\000\000\000\000\000\000\061\005\
\095\002\137\000\138\000\030\000\000\000\139\000\000\000\000\000\
\140\000\062\005\000\000\095\002\095\002\000\000\095\002\095\002\
\095\002\095\002\000\000\059\002\000\000\059\002\059\002\059\002\
\000\000\142\000\000\000\059\002\095\002\000\000\000\000\095\002\
\059\002\143\000\144\000\095\002\059\002\059\002\059\002\000\000\
\000\000\145\000\000\000\000\000\000\000\059\002\059\002\059\002\
\059\002\000\000\246\001\000\000\000\000\064\005\147\000\059\002\
\000\000\000\000\000\000\000\000\059\002\000\000\056\002\000\000\
\000\000\000\000\000\000\059\002\059\002\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\059\002\
\000\000\000\000\059\002\000\000\000\000\059\002\059\002\059\002\
\000\000\059\002\000\000\000\000\000\000\059\002\000\000\000\000\
\000\000\000\000\000\000\059\002\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\059\002\059\002\
\000\000\059\002\059\002\059\002\059\002\000\000\000\000\000\000\
\057\002\000\000\057\002\057\002\057\002\000\000\000\000\059\002\
\057\002\000\000\059\002\000\000\000\000\057\002\059\002\000\000\
\000\000\057\002\057\002\057\002\000\000\000\000\000\000\000\000\
\000\000\000\000\057\002\057\002\057\002\057\002\000\000\000\000\
\000\000\000\000\000\000\000\000\057\002\000\000\000\000\000\000\
\000\000\057\002\000\000\053\002\000\000\000\000\000\000\000\000\
\057\002\057\002\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\057\002\000\000\000\000\057\002\
\000\000\000\000\057\002\057\002\057\002\000\000\057\002\000\000\
\000\000\000\000\057\002\000\000\000\000\000\000\000\000\136\000\
\057\002\137\000\138\000\030\000\000\000\139\000\000\000\000\000\
\140\000\141\000\000\000\057\002\057\002\000\000\057\002\057\002\
\057\002\057\002\177\001\058\002\000\000\058\002\058\002\058\002\
\000\000\142\000\000\000\058\002\057\002\000\000\000\000\057\002\
\058\002\143\000\144\000\057\002\058\002\058\002\058\002\042\002\
\000\000\145\000\000\000\000\000\000\000\058\002\058\002\058\002\
\058\002\000\000\000\000\000\000\000\000\146\000\147\000\058\002\
\000\000\000\000\000\000\000\000\058\002\000\000\000\000\000\000\
\000\000\000\000\000\000\058\002\058\002\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\058\002\
\000\000\000\000\058\002\000\000\000\000\058\002\058\002\058\002\
\000\000\058\002\000\000\000\000\000\000\058\002\000\000\000\000\
\000\000\041\002\136\000\058\002\137\000\138\000\030\000\000\000\
\139\000\000\000\000\000\140\000\141\000\000\000\058\002\058\002\
\000\000\058\002\058\002\058\002\058\002\000\000\056\002\000\000\
\056\002\056\002\056\002\000\000\142\000\000\000\056\002\058\002\
\000\000\000\000\058\002\056\002\143\000\126\003\058\002\056\002\
\056\002\056\002\000\000\000\000\145\000\000\000\000\000\000\000\
\056\002\056\002\056\002\056\002\000\000\000\000\000\000\068\006\
\146\000\147\000\056\002\039\002\000\000\000\000\000\000\056\002\
\000\000\000\000\000\000\000\000\000\000\000\000\056\002\056\002\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\056\002\000\000\000\000\056\002\000\000\000\000\
\056\002\056\002\056\002\000\000\056\002\000\000\000\000\000\000\
\056\002\000\000\000\000\000\000\000\000\000\000\056\002\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\056\002\056\002\000\000\056\002\056\002\056\002\056\002\
\000\000\197\000\000\000\053\002\000\000\053\002\053\002\000\000\
\000\000\000\000\056\002\053\002\000\000\056\002\000\000\000\000\
\053\002\056\002\000\000\000\000\053\002\053\002\053\002\000\000\
\000\000\000\000\000\000\000\000\000\000\053\002\053\002\053\002\
\053\002\000\000\000\000\000\000\000\000\000\000\000\000\053\002\
\000\000\000\000\000\000\000\000\053\002\000\000\000\000\000\000\
\000\000\000\000\000\000\053\002\053\002\000\000\000\000\000\000\
\000\000\000\000\000\000\084\000\000\000\000\000\000\000\053\002\
\000\000\000\000\053\002\000\000\000\000\053\002\053\002\053\002\
\000\000\053\002\000\000\000\000\010\000\053\002\157\001\042\002\
\000\000\000\000\042\002\053\002\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\042\002\000\000\053\002\053\002\
\042\002\053\002\053\002\053\002\053\002\000\000\000\000\000\000\
\000\000\042\002\042\002\042\002\042\002\000\000\000\000\053\002\
\000\000\000\000\053\002\000\000\000\000\000\000\053\002\000\000\
\042\002\000\000\000\000\000\000\000\000\136\000\000\000\137\000\
\138\000\030\000\000\000\139\000\000\000\000\000\158\001\141\000\
\000\000\041\002\000\000\042\002\041\002\000\000\042\002\000\000\
\000\000\042\002\042\002\042\002\000\000\000\000\041\002\000\000\
\042\002\042\002\041\002\000\000\000\000\000\000\000\000\042\002\
\144\000\000\000\227\002\041\002\041\002\041\002\041\002\145\000\
\000\000\000\000\000\000\042\002\023\003\042\002\000\000\042\002\
\042\002\000\000\041\002\146\000\147\000\000\000\000\000\000\000\
\000\000\000\000\000\000\042\002\000\000\000\000\042\002\000\000\
\000\000\000\000\042\002\039\002\000\000\041\002\039\002\000\000\
\041\002\000\000\000\000\041\002\041\002\041\002\000\000\000\000\
\039\002\000\000\041\002\041\002\039\002\000\000\000\000\000\000\
\000\000\041\002\000\000\000\000\000\000\039\002\039\002\039\002\
\039\002\000\000\000\000\000\000\000\000\041\002\000\000\041\002\
\000\000\041\002\041\002\000\000\039\002\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\041\002\000\000\000\000\
\041\002\000\000\000\000\000\000\041\002\000\000\000\000\039\002\
\000\000\197\000\039\002\000\000\197\000\039\002\039\002\039\002\
\000\000\000\000\000\000\000\000\039\002\039\002\197\000\000\000\
\000\000\000\000\197\000\039\002\197\000\000\000\000\000\000\000\
\000\000\000\000\128\000\197\000\197\000\197\000\197\000\039\002\
\000\000\039\002\000\000\039\002\039\002\000\000\000\000\000\000\
\000\000\000\000\197\000\000\000\000\000\000\000\000\000\039\002\
\000\000\000\000\039\002\000\000\000\000\000\000\039\002\000\000\
\000\000\000\000\000\000\084\000\000\000\197\000\084\000\000\000\
\197\000\000\000\000\000\000\000\197\000\197\000\000\000\000\000\
\084\000\000\000\197\000\197\000\084\000\000\000\000\000\000\000\
\000\000\197\000\000\000\000\000\000\000\084\000\084\000\084\000\
\084\000\000\000\000\000\000\000\000\000\197\000\000\000\197\000\
\000\000\197\000\197\000\000\000\084\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\197\000\000\000\000\000\
\197\000\120\000\000\000\000\000\197\000\000\000\000\000\084\000\
\000\000\000\000\084\000\000\000\000\000\000\000\084\000\084\000\
\000\000\000\000\000\000\000\000\084\000\084\000\244\004\000\000\
\137\000\138\000\030\000\084\000\139\000\000\000\245\004\246\004\
\141\000\000\000\000\000\000\000\000\000\000\000\000\000\084\000\
\000\000\084\000\000\000\084\000\084\000\247\004\000\000\000\000\
\248\004\000\000\000\000\000\000\000\000\000\000\000\000\084\000\
\249\004\144\000\084\000\000\000\023\003\000\000\084\000\023\003\
\145\000\023\003\023\003\023\003\023\003\000\000\000\000\023\003\
\023\003\023\003\000\000\000\000\146\000\147\000\000\000\023\003\
\000\000\000\000\000\000\023\003\000\000\000\000\023\003\000\000\
\023\003\023\003\023\003\023\003\023\003\023\003\023\003\023\003\
\023\003\000\000\000\000\023\003\023\003\023\003\000\000\000\000\
\000\000\000\000\000\000\000\000\023\003\023\003\023\003\023\003\
\023\003\023\003\023\003\023\003\023\003\023\003\023\003\023\003\
\023\003\023\003\150\001\023\003\023\003\023\003\000\000\023\003\
\023\003\023\003\023\003\023\003\023\003\000\000\023\003\023\003\
\023\003\023\003\023\003\000\000\023\003\023\003\000\000\000\000\
\023\003\023\003\000\000\023\003\023\003\023\003\023\003\023\003\
\023\003\023\003\000\000\023\003\023\003\023\003\000\000\023\003\
\000\000\023\003\023\003\000\000\023\003\000\000\023\003\023\003\
\023\003\023\003\023\003\023\003\023\003\000\000\023\003\009\000\
\010\000\011\000\000\000\000\000\000\000\012\000\013\000\014\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\015\000\016\000\
\017\000\018\000\019\000\020\000\021\000\000\000\000\000\000\000\
\000\000\022\000\000\000\023\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\024\000\000\000\025\000\026\000\
\027\000\028\000\029\000\000\000\000\000\030\000\031\000\000\000\
\000\000\032\000\033\000\034\000\000\000\164\002\035\000\036\000\
\000\000\037\000\038\000\000\000\039\000\000\000\040\000\000\000\
\041\000\000\000\042\000\000\000\000\000\000\000\043\000\044\000\
\000\000\045\000\000\000\000\000\000\000\000\000\009\000\010\000\
\011\000\000\000\129\000\121\000\012\000\013\000\014\000\047\000\
\000\000\000\000\000\000\000\000\048\000\049\000\050\000\051\000\
\052\000\053\000\000\000\000\000\054\000\015\000\016\000\017\000\
\018\000\019\000\020\000\021\000\000\000\000\000\000\000\000\000\
\022\000\000\000\023\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\024\000\000\000\025\000\026\000\027\000\
\028\000\029\000\000\000\000\000\030\000\031\000\000\000\000\000\
\032\000\033\000\034\000\000\000\000\000\035\000\036\000\000\000\
\037\000\038\000\000\000\039\000\000\000\040\000\000\000\041\000\
\000\000\042\000\000\000\109\000\000\000\043\000\044\000\000\000\
\045\000\178\001\136\000\000\000\137\000\138\000\030\000\000\000\
\139\000\000\000\121\000\140\000\141\000\000\000\047\000\000\000\
\000\000\000\000\000\000\048\000\049\000\050\000\051\000\052\000\
\053\000\000\000\000\000\054\000\142\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\143\000\144\000\000\000\009\000\
\010\000\011\000\000\000\000\000\145\000\012\000\013\000\014\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\146\000\147\000\000\000\000\000\000\000\000\000\015\000\016\000\
\017\000\018\000\019\000\020\000\021\000\000\000\000\000\000\000\
\000\000\022\000\000\000\023\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\024\000\000\000\025\000\026\000\
\027\000\028\000\029\000\000\000\000\000\030\000\031\000\000\000\
\000\000\032\000\033\000\034\000\000\000\000\000\035\000\036\000\
\000\000\037\000\038\000\000\000\039\000\132\000\040\000\000\000\
\041\000\000\000\042\000\000\000\000\000\000\000\043\000\044\000\
\000\000\045\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\121\000\000\000\000\000\000\000\047\000\
\000\000\000\000\000\000\000\000\048\000\049\000\050\000\051\000\
\052\000\053\000\000\000\000\000\054\000\164\002\000\000\000\000\
\000\000\164\002\000\000\164\002\000\000\164\002\000\000\164\002\
\000\000\164\002\000\000\164\002\164\002\000\000\164\002\164\002\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\164\002\164\002\000\000\164\002\164\002\134\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\164\002\
\164\002\164\002\164\002\000\000\164\002\164\002\000\000\000\000\
\164\002\000\000\000\000\000\000\000\000\164\002\164\002\164\002\
\000\000\000\000\000\000\000\000\164\002\000\000\164\002\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\164\002\000\000\
\000\000\164\002\000\000\000\000\000\000\000\000\164\002\135\000\
\164\002\164\002\000\000\164\002\164\002\000\000\164\002\000\000\
\000\000\000\000\164\002\109\000\000\000\164\002\000\000\164\002\
\000\000\178\001\164\002\164\002\000\000\178\001\164\002\178\001\
\109\000\178\001\000\000\178\001\000\000\178\001\000\000\178\001\
\178\001\000\000\178\001\178\001\000\000\109\000\000\000\109\000\
\109\000\000\000\000\000\000\000\178\001\000\000\000\000\178\001\
\178\001\000\000\000\000\000\000\109\000\000\000\000\000\000\000\
\000\000\130\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\178\001\178\001\000\000\178\001\109\000\
\178\001\178\001\000\000\000\000\178\001\000\000\109\000\109\000\
\000\000\178\001\178\001\178\001\000\000\109\000\000\000\000\000\
\178\001\000\000\178\001\109\000\000\000\000\000\000\000\000\000\
\000\000\000\000\178\001\000\000\000\000\178\001\000\000\109\000\
\000\000\000\000\178\001\109\000\178\001\178\001\000\000\178\001\
\178\001\000\000\178\001\136\000\000\000\000\000\178\001\109\000\
\000\000\178\001\109\000\178\001\000\000\132\000\178\001\178\001\
\132\000\132\000\178\001\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\132\000\132\000\000\000\000\000\000\000\000\000\
\132\000\000\000\000\000\000\000\000\000\000\000\000\000\132\000\
\000\000\132\000\132\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\132\000\000\000\
\000\000\000\000\000\000\000\000\000\000\132\000\132\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\132\000\000\000\000\000\132\000\000\000\000\000\132\000\
\132\000\132\000\000\000\132\000\000\000\134\000\000\000\132\000\
\134\000\134\000\014\002\000\000\000\000\132\000\000\000\000\000\
\000\000\000\000\134\000\134\000\000\000\000\000\000\000\000\000\
\134\000\132\000\000\000\132\000\000\000\132\000\132\000\134\000\
\000\000\134\000\134\000\000\000\000\000\000\000\000\000\000\000\
\000\000\132\000\000\000\000\000\132\000\000\000\134\000\000\000\
\000\000\000\000\000\000\000\000\000\000\134\000\134\000\000\000\
\000\000\000\000\000\000\181\000\000\000\000\000\000\000\135\000\
\000\000\134\000\135\000\135\000\134\000\000\000\000\000\134\000\
\134\000\134\000\000\000\134\000\135\000\135\000\000\000\134\000\
\000\000\000\000\135\000\000\000\000\000\134\000\000\000\000\000\
\000\000\135\000\000\000\135\000\135\000\000\000\000\000\000\000\
\000\000\134\000\000\000\134\000\000\000\134\000\134\000\000\000\
\135\000\000\000\000\000\000\000\000\000\183\002\000\000\135\000\
\135\000\134\000\000\000\000\000\134\000\000\000\000\000\000\000\
\000\000\130\000\000\000\135\000\130\000\130\000\135\000\000\000\
\000\000\000\000\135\000\135\000\000\000\135\000\130\000\130\000\
\000\000\135\000\000\000\000\000\130\000\000\000\000\000\135\000\
\000\000\000\000\000\000\130\000\000\000\130\000\130\000\000\000\
\000\000\000\000\000\000\135\000\000\000\135\000\000\000\135\000\
\135\000\000\000\130\000\000\000\000\000\000\000\000\000\000\000\
\000\000\130\000\130\000\135\000\000\000\000\000\135\000\000\000\
\000\000\000\000\000\000\136\000\000\000\130\000\136\000\136\000\
\130\000\015\002\000\000\000\000\130\000\130\000\000\000\130\000\
\136\000\136\000\000\000\130\000\000\000\000\000\136\000\000\000\
\000\000\130\000\000\000\000\000\000\000\136\000\000\000\136\000\
\136\000\000\000\000\000\000\000\000\000\130\000\000\000\130\000\
\000\000\130\000\130\000\000\000\136\000\000\000\000\000\000\000\
\000\000\000\000\000\000\136\000\136\000\130\000\000\000\000\000\
\130\000\000\000\000\000\000\000\000\000\000\000\000\000\136\000\
\000\000\000\000\136\000\182\000\000\000\000\000\136\000\136\000\
\000\000\136\000\000\000\000\000\000\000\136\000\136\000\000\000\
\137\000\138\000\030\000\136\000\139\000\000\000\000\000\140\000\
\141\000\000\000\014\002\000\000\000\000\014\002\000\000\136\000\
\000\000\136\000\014\002\136\000\136\000\000\000\000\000\014\002\
\142\000\000\000\000\000\000\000\000\000\014\002\000\000\136\000\
\143\000\126\003\136\000\000\000\014\002\000\000\014\002\014\002\
\145\000\000\000\000\000\000\000\000\000\021\003\000\000\000\000\
\000\000\000\000\014\002\014\002\146\000\147\000\000\000\000\000\
\000\000\000\000\000\000\181\000\000\000\000\000\181\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\014\002\000\000\
\181\000\014\002\000\000\000\000\014\002\014\002\014\002\000\000\
\000\000\000\000\000\000\098\002\014\002\181\000\181\000\181\000\
\181\000\000\000\014\002\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\181\000\000\000\014\002\023\003\
\000\000\000\000\014\002\014\002\000\000\183\002\098\002\000\000\
\183\002\000\000\000\000\000\000\000\000\000\000\014\002\181\000\
\000\000\014\002\183\002\080\002\000\000\181\000\181\000\181\000\
\000\000\000\000\000\000\000\000\080\002\181\000\000\000\183\002\
\183\002\183\002\183\002\181\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\183\002\181\000\
\000\000\181\000\000\000\181\000\080\002\000\000\000\000\080\002\
\000\000\232\001\000\000\000\000\000\000\000\000\000\000\181\000\
\080\002\183\002\181\000\000\000\000\000\174\002\000\000\183\002\
\183\002\183\002\000\000\000\000\000\000\000\000\174\002\183\002\
\000\000\015\002\000\000\000\000\015\002\183\002\000\000\000\000\
\000\000\015\002\000\000\000\000\000\000\000\000\015\002\000\000\
\000\000\183\002\000\000\183\002\015\002\183\002\174\002\000\000\
\000\000\174\002\071\000\015\002\000\000\015\002\015\002\000\000\
\000\000\183\002\174\002\000\000\183\002\000\000\000\000\000\000\
\000\000\015\002\015\002\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\182\000\000\000\015\002\182\000\000\000\
\015\002\000\000\000\000\015\002\015\002\015\002\000\000\000\000\
\182\000\000\000\015\002\015\002\000\000\000\000\182\000\233\001\
\000\000\015\002\000\000\000\000\000\000\182\000\182\000\182\000\
\182\000\000\000\000\000\000\000\000\000\015\002\000\000\000\000\
\000\000\015\002\015\002\000\000\182\000\000\000\000\000\000\000\
\000\000\000\000\000\000\182\000\000\000\015\002\000\000\000\000\
\015\002\000\000\000\000\000\000\000\000\021\003\000\000\182\000\
\021\003\000\000\182\000\000\000\000\000\000\000\182\000\182\000\
\000\000\182\000\021\003\000\000\235\001\182\000\000\000\000\000\
\021\003\000\000\000\000\182\000\000\000\000\000\000\000\021\003\
\000\000\021\003\021\003\000\000\000\000\000\000\000\000\182\000\
\000\000\182\000\000\000\182\000\182\000\021\003\021\003\000\000\
\000\000\000\000\000\000\000\000\000\000\021\003\021\003\182\000\
\000\000\000\000\182\000\000\000\000\000\000\000\000\000\023\003\
\000\000\021\003\023\003\000\000\021\003\000\000\000\000\023\003\
\000\000\021\003\000\000\021\003\023\003\000\000\000\000\021\003\
\000\000\000\000\023\003\000\000\000\000\021\003\000\000\000\000\
\000\000\023\003\000\000\023\003\023\003\000\000\000\000\234\001\
\000\000\021\003\000\000\000\000\000\000\021\003\021\003\000\000\
\023\003\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\021\003\000\000\000\000\021\003\000\000\000\000\000\000\
\000\000\232\001\000\000\023\003\232\001\000\000\023\003\000\000\
\000\000\000\000\023\003\023\003\000\000\000\000\232\001\000\000\
\000\000\023\003\000\000\000\000\232\001\000\000\000\000\023\003\
\000\000\000\000\000\000\232\001\236\001\232\001\232\001\000\000\
\000\000\000\000\000\000\023\003\000\000\011\002\000\000\023\003\
\023\003\000\000\232\001\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\071\000\023\003\000\000\071\000\023\003\000\000\
\000\000\000\000\000\000\000\000\000\000\232\001\000\000\071\000\
\232\001\000\000\000\000\000\000\232\001\232\001\000\000\000\000\
\000\000\000\000\000\000\232\001\071\000\000\000\071\000\071\000\
\000\000\232\001\000\000\000\000\000\000\000\000\000\000\240\001\
\000\000\000\000\071\000\071\000\000\000\232\001\000\000\000\000\
\000\000\232\001\232\001\000\000\000\000\000\000\000\000\233\001\
\000\000\000\000\233\001\000\000\000\000\232\001\071\000\000\000\
\232\001\071\000\000\000\000\000\233\001\071\000\071\000\000\000\
\000\000\000\000\233\001\000\000\071\000\000\000\000\000\000\000\
\000\000\233\001\071\000\233\001\233\001\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\011\002\000\000\071\000\000\000\
\233\001\000\000\071\000\071\000\000\000\021\003\000\000\000\000\
\000\000\000\000\000\000\000\000\235\001\000\000\071\000\235\001\
\000\000\071\000\000\000\233\001\000\000\000\000\233\001\000\000\
\000\000\235\001\233\001\233\001\000\000\000\000\000\000\235\001\
\000\000\233\001\000\000\000\000\000\000\000\000\235\001\233\001\
\235\001\235\001\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\233\001\000\000\235\001\000\000\233\001\
\233\001\000\000\125\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\233\001\000\000\000\000\233\001\000\000\
\235\001\000\000\000\000\235\001\000\000\000\000\000\000\235\001\
\235\001\000\000\000\000\000\000\000\000\000\000\235\001\234\001\
\000\000\000\000\234\001\000\000\235\001\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\234\001\000\000\000\000\000\000\
\235\001\000\000\234\001\000\000\235\001\235\001\000\000\126\000\
\000\000\234\001\000\000\234\001\234\001\000\000\000\000\000\000\
\235\001\000\000\000\000\235\001\000\000\000\000\000\000\000\000\
\234\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\236\001\000\000\000\000\236\001\
\000\000\000\000\000\000\234\001\000\000\011\002\234\001\000\000\
\000\000\236\001\234\001\234\001\000\000\011\002\000\000\236\001\
\023\003\234\001\011\002\000\000\000\000\000\000\236\001\234\001\
\236\001\236\001\023\003\000\000\000\000\000\000\000\000\011\002\
\000\000\011\002\011\002\234\001\000\000\236\001\000\000\234\001\
\234\001\000\000\000\000\000\000\000\000\000\000\011\002\000\000\
\000\000\000\000\000\000\234\001\000\000\000\000\234\001\240\001\
\236\001\000\000\240\001\236\001\000\000\000\000\000\000\236\001\
\236\001\011\002\000\000\000\000\240\001\000\000\236\001\011\002\
\011\002\011\002\240\001\000\000\236\001\000\000\000\000\011\002\
\000\000\240\001\000\000\240\001\240\001\011\002\000\000\000\000\
\236\001\000\000\000\000\118\000\236\001\236\001\000\000\000\000\
\240\001\011\002\000\000\000\000\000\000\011\002\000\000\000\000\
\236\001\000\000\000\000\236\001\011\002\000\000\000\000\000\000\
\000\000\011\002\000\000\240\001\011\002\021\003\240\001\000\000\
\021\003\011\002\240\001\240\001\000\000\000\000\000\000\000\000\
\000\000\240\001\021\003\000\000\000\000\000\000\011\002\240\001\
\011\002\011\002\000\000\000\000\021\003\000\000\000\000\021\003\
\000\000\021\003\021\003\240\001\000\000\011\002\119\000\240\001\
\240\001\000\000\000\000\000\000\000\000\021\003\021\003\000\000\
\000\000\000\000\000\000\240\001\000\000\000\000\240\001\000\000\
\011\002\000\000\125\000\011\002\000\000\125\000\011\002\011\002\
\011\002\021\003\000\000\000\000\021\003\000\000\011\002\125\000\
\000\000\021\003\000\000\000\000\011\002\000\000\000\000\021\003\
\000\000\000\000\000\000\000\000\125\000\021\003\125\000\125\000\
\011\002\000\000\000\000\000\000\011\002\011\002\000\000\000\000\
\000\000\021\003\000\000\125\000\223\001\021\003\021\003\000\000\
\011\002\000\000\000\000\011\002\000\000\000\000\000\000\126\000\
\000\000\021\003\126\000\000\000\021\003\000\000\125\000\000\000\
\000\000\125\000\000\000\000\000\126\000\125\000\125\000\000\000\
\000\000\000\000\000\000\000\000\125\000\000\000\000\000\000\000\
\000\000\126\000\125\000\126\000\126\000\000\000\000\000\000\000\
\061\000\000\000\000\000\000\000\000\000\000\000\125\000\000\000\
\126\000\064\000\125\000\125\000\000\000\000\000\000\000\000\000\
\023\003\000\000\000\000\000\000\000\000\000\000\125\000\000\000\
\023\003\125\000\023\003\126\000\000\000\023\003\126\000\000\000\
\000\000\000\000\126\000\126\000\000\000\000\000\000\000\023\003\
\000\000\126\000\023\003\000\000\023\003\023\003\000\000\126\000\
\000\000\000\000\000\000\000\000\023\003\000\000\023\003\023\003\
\000\000\023\003\065\000\126\000\000\000\000\000\000\000\126\000\
\126\000\000\000\000\000\023\003\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\126\000\023\003\000\000\126\000\023\003\
\000\000\000\000\000\000\023\003\023\003\000\000\023\003\000\000\
\000\000\023\003\023\003\118\000\000\000\023\003\023\003\000\000\
\023\003\000\000\000\000\000\000\023\003\000\000\021\003\000\000\
\118\000\000\000\023\003\000\000\023\003\000\000\000\000\000\000\
\023\003\023\003\000\000\000\000\000\000\118\000\023\003\118\000\
\118\000\000\000\023\003\023\003\023\003\000\000\000\000\023\003\
\000\000\000\000\000\000\000\000\118\000\000\000\023\003\000\000\
\000\000\023\003\000\000\000\000\021\003\000\000\000\000\021\003\
\000\000\000\000\000\000\000\000\000\000\000\000\119\000\118\000\
\000\000\021\003\118\000\000\000\000\000\000\000\118\000\118\000\
\000\000\000\000\000\000\119\000\000\000\118\000\021\003\000\000\
\021\003\021\003\000\000\118\000\000\000\000\000\000\000\000\000\
\119\000\000\000\119\000\119\000\000\000\021\003\000\000\118\000\
\000\000\000\000\000\000\118\000\118\000\000\000\000\000\119\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\118\000\
\021\003\000\000\118\000\021\003\000\000\000\000\000\000\000\000\
\021\003\000\000\119\000\000\000\223\001\119\000\021\003\000\000\
\000\000\119\000\119\000\000\000\021\003\000\000\000\000\000\000\
\119\000\223\001\000\000\000\000\000\000\000\000\119\000\000\000\
\021\003\000\000\000\000\000\000\021\003\021\003\223\001\000\000\
\223\001\223\001\119\000\000\000\000\000\000\000\119\000\119\000\
\021\003\000\000\000\000\021\003\000\000\223\001\000\000\000\000\
\061\000\000\000\119\000\000\000\000\000\119\000\000\000\000\000\
\000\000\064\000\000\000\000\000\000\000\061\000\000\000\000\000\
\223\001\000\000\000\000\223\001\000\000\000\000\064\000\223\001\
\223\001\000\000\061\000\000\000\061\000\061\000\223\001\000\000\
\000\000\000\000\000\000\064\000\223\001\064\000\064\000\000\000\
\000\000\061\000\000\000\000\000\000\000\000\000\000\000\000\000\
\223\001\000\000\064\000\000\000\223\001\223\001\000\000\000\000\
\000\000\000\000\065\000\000\000\061\000\000\000\000\000\061\000\
\223\001\000\000\000\000\223\001\061\000\064\000\000\000\065\000\
\064\000\000\000\061\000\000\000\000\000\064\000\000\000\000\000\
\061\000\000\000\000\000\064\000\065\000\000\000\065\000\065\000\
\000\000\064\000\000\000\000\000\061\000\000\000\000\000\000\000\
\061\000\061\000\000\000\065\000\000\000\064\000\021\003\000\000\
\000\000\064\000\064\000\000\000\061\000\000\000\000\000\061\000\
\000\000\000\000\000\000\021\003\000\000\064\000\065\000\000\000\
\064\000\065\000\000\000\000\000\000\000\000\000\065\000\000\000\
\021\003\000\000\021\003\021\003\065\000\000\000\000\000\000\000\
\000\000\000\000\065\000\000\000\000\000\000\000\000\000\021\003\
\000\000\000\000\000\000\000\000\000\000\000\000\065\000\000\000\
\000\000\000\000\065\000\065\000\000\000\000\000\000\000\000\000\
\000\000\000\000\021\003\000\000\000\000\021\003\065\000\000\000\
\000\000\065\000\021\003\000\000\000\000\000\000\000\000\000\000\
\021\003\000\000\000\000\000\000\000\000\000\000\021\003\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\021\003\016\003\000\000\000\000\021\003\021\003\
\016\003\016\003\016\003\016\003\000\000\000\000\016\003\016\003\
\016\003\016\003\021\003\000\000\000\000\021\003\016\003\000\000\
\000\000\000\000\000\000\000\000\000\000\016\003\000\000\016\003\
\016\003\016\003\016\003\016\003\016\003\016\003\016\003\000\000\
\000\000\000\000\016\003\000\000\016\003\000\000\000\000\000\000\
\000\000\000\000\000\000\016\003\016\003\016\003\016\003\016\003\
\016\003\016\003\016\003\016\003\000\000\000\000\016\003\016\003\
\000\000\000\000\016\003\016\003\016\003\016\003\000\000\016\003\
\016\003\016\003\016\003\016\003\000\000\016\003\000\000\016\003\
\016\003\016\003\000\000\016\003\016\003\000\000\000\000\016\003\
\016\003\000\000\016\003\000\000\016\003\016\003\000\000\016\003\
\016\003\000\000\000\000\016\003\016\003\000\000\016\003\000\000\
\016\003\016\003\000\000\016\003\000\000\016\003\016\003\016\003\
\016\003\016\003\016\003\016\003\023\003\016\003\000\000\000\000\
\000\000\023\003\023\003\023\003\023\003\000\000\000\000\023\003\
\023\003\000\000\000\000\000\000\000\000\000\000\000\000\023\003\
\000\000\000\000\000\000\000\000\000\000\000\000\023\003\000\000\
\023\003\000\000\023\003\023\003\023\003\023\003\023\003\023\003\
\000\000\000\000\000\000\023\003\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\023\003\023\003\023\003\023\003\
\023\003\023\003\023\003\023\003\023\003\000\000\000\000\023\003\
\023\003\000\000\000\000\023\003\023\003\023\003\000\000\000\000\
\023\003\023\003\023\003\023\003\023\003\000\000\023\003\000\000\
\023\003\023\003\023\003\000\000\000\000\023\003\000\000\000\000\
\023\003\023\003\000\000\023\003\000\000\023\003\023\003\000\000\
\000\000\023\003\000\000\000\000\000\000\023\003\000\000\023\003\
\000\000\023\003\023\003\000\000\023\003\000\000\023\003\023\003\
\000\000\023\003\023\003\023\003\023\003\000\000\023\003\026\001\
\027\001\028\001\000\000\000\000\009\000\010\000\029\001\000\000\
\030\001\000\000\012\000\013\000\000\000\000\000\031\001\032\001\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\033\001\000\000\000\000\017\000\018\000\019\000\
\020\000\021\000\000\000\034\001\000\000\000\000\022\000\000\000\
\000\000\035\001\036\001\037\001\038\001\039\001\040\001\000\000\
\000\000\024\000\000\000\025\000\026\000\027\000\028\000\029\000\
\000\000\000\000\030\000\000\000\041\001\000\000\032\000\033\000\
\034\000\000\000\000\000\000\000\036\000\000\000\042\001\043\001\
\000\000\044\001\000\000\040\000\000\000\041\000\000\000\000\000\
\000\000\045\001\046\001\047\001\048\001\049\001\050\001\000\000\
\000\000\000\000\000\000\000\000\000\000\051\001\000\000\000\000\
\000\000\052\001\000\000\053\001\047\000\000\000\000\000\000\000\
\000\000\048\000\049\000\000\000\051\000\052\000\026\001\027\001\
\028\001\054\000\000\000\009\000\010\000\029\001\000\000\030\001\
\000\000\012\000\013\000\000\000\000\000\079\003\032\001\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\033\001\000\000\000\000\017\000\018\000\019\000\020\000\
\021\000\000\000\034\001\000\000\000\000\022\000\000\000\000\000\
\035\001\036\001\037\001\038\001\039\001\040\001\000\000\000\000\
\024\000\000\000\025\000\026\000\027\000\028\000\029\000\000\000\
\000\000\030\000\000\000\041\001\000\000\032\000\033\000\034\000\
\000\000\000\000\000\000\036\000\000\000\042\001\043\001\000\000\
\080\003\000\000\040\000\000\000\041\000\000\000\000\000\000\000\
\045\001\046\001\047\001\048\001\049\001\050\001\000\000\000\000\
\000\000\000\000\000\000\089\002\081\003\089\002\089\002\089\002\
\052\001\089\002\053\001\047\000\089\002\089\002\000\000\000\000\
\048\000\049\000\000\000\051\000\052\000\023\003\000\000\000\000\
\054\000\000\000\023\003\023\003\023\003\089\002\000\000\000\000\
\023\003\023\003\023\003\000\000\000\000\089\002\089\002\000\000\
\000\000\000\000\000\000\000\000\000\000\089\002\000\000\023\003\
\000\000\023\003\023\003\023\003\023\003\023\003\023\003\023\003\
\000\000\089\002\089\002\000\000\023\003\000\000\023\003\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\023\003\
\000\000\023\003\023\003\023\003\023\003\023\003\000\000\000\000\
\023\003\023\003\000\000\000\000\023\003\023\003\023\003\000\000\
\000\000\023\003\023\003\000\000\023\003\023\003\000\000\023\003\
\000\000\023\003\000\000\023\003\000\000\023\003\000\000\000\000\
\000\000\023\003\023\003\143\002\023\003\000\000\000\000\000\000\
\217\002\217\002\217\002\000\000\000\000\023\003\217\002\217\002\
\000\000\000\000\023\003\000\000\000\000\000\000\000\000\023\003\
\023\003\023\003\023\003\023\003\023\003\000\000\000\000\023\003\
\000\000\217\002\217\002\217\002\217\002\217\002\000\000\000\000\
\000\000\000\000\217\002\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\217\002\000\000\217\002\
\217\002\217\002\217\002\217\002\000\000\000\000\217\002\000\000\
\000\000\000\000\217\002\217\002\217\002\000\000\000\000\000\000\
\217\002\000\000\217\002\217\002\000\000\000\000\000\000\217\002\
\000\000\217\002\000\000\000\000\000\000\000\000\000\000\217\002\
\217\002\144\002\217\002\000\000\000\000\000\000\218\002\218\002\
\218\002\143\002\000\000\000\000\218\002\218\002\000\000\000\000\
\217\002\000\000\000\000\000\000\000\000\217\002\217\002\000\000\
\217\002\217\002\000\000\000\000\000\000\217\002\000\000\218\002\
\218\002\218\002\218\002\218\002\000\000\000\000\000\000\000\000\
\218\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\218\002\000\000\218\002\218\002\218\002\
\218\002\218\002\000\000\000\000\218\002\000\000\000\000\000\000\
\218\002\218\002\218\002\000\000\000\000\000\000\218\002\000\000\
\218\002\218\002\000\000\000\000\000\000\218\002\000\000\218\002\
\000\000\000\000\000\000\000\000\000\000\218\002\218\002\141\002\
\218\002\000\000\000\000\000\000\219\002\219\002\219\002\144\002\
\000\000\000\000\219\002\219\002\000\000\000\000\218\002\000\000\
\000\000\000\000\000\000\218\002\218\002\000\000\218\002\218\002\
\000\000\000\000\000\000\218\002\000\000\219\002\219\002\219\002\
\219\002\219\002\000\000\000\000\000\000\000\000\219\002\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\219\002\000\000\219\002\219\002\219\002\219\002\219\002\
\000\000\000\000\219\002\000\000\000\000\000\000\219\002\219\002\
\219\002\000\000\000\000\000\000\219\002\000\000\219\002\219\002\
\000\000\000\000\000\000\219\002\000\000\219\002\000\000\000\000\
\000\000\000\000\000\000\219\002\219\002\142\002\219\002\000\000\
\000\000\000\000\220\002\220\002\220\002\141\002\000\000\000\000\
\220\002\220\002\000\000\000\000\219\002\000\000\000\000\000\000\
\000\000\219\002\219\002\000\000\219\002\219\002\000\000\000\000\
\000\000\219\002\000\000\220\002\220\002\220\002\220\002\220\002\
\000\000\000\000\000\000\000\000\220\002\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\220\002\
\000\000\220\002\220\002\220\002\220\002\220\002\000\000\000\000\
\220\002\000\000\000\000\000\000\220\002\220\002\220\002\000\000\
\000\000\000\000\220\002\000\000\220\002\220\002\000\000\000\000\
\000\000\220\002\000\000\220\002\000\000\000\000\000\000\000\000\
\000\000\220\002\220\002\000\000\220\002\000\000\000\000\000\000\
\000\000\000\000\000\000\142\002\224\000\225\000\226\000\000\000\
\000\000\000\000\220\002\000\000\227\000\000\000\228\000\220\002\
\220\002\000\000\220\002\220\002\229\000\230\000\231\000\220\002\
\000\000\232\000\233\000\234\000\000\000\235\000\236\000\237\000\
\000\000\238\000\239\000\240\000\241\000\000\000\000\000\000\000\
\242\000\243\000\244\000\000\000\000\000\000\000\000\000\000\000\
\000\000\245\000\246\000\000\000\000\000\247\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\248\000\249\000\000\000\000\000\000\000\062\002\250\000\251\000\
\000\000\062\002\000\000\252\000\253\000\254\000\255\000\000\001\
\001\001\002\001\000\000\003\001\000\000\000\000\062\002\000\000\
\062\002\004\001\000\000\045\002\000\000\000\000\005\001\062\002\
\062\002\000\000\000\000\000\000\006\001\000\000\000\000\007\001\
\008\001\062\002\009\001\010\001\011\001\012\001\013\001\000\000\
\014\001\015\001\016\001\017\001\018\001\062\002\062\002\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\062\002\000\000\000\000\000\000\062\002\000\000\062\002\
\062\002\062\002\000\000\062\002\000\000\000\000\062\002\000\000\
\000\000\000\000\026\001\027\001\028\001\000\000\000\000\000\000\
\010\000\207\001\000\000\030\001\000\000\000\000\013\000\045\002\
\062\002\031\001\032\001\000\000\062\002\000\000\062\002\000\000\
\000\000\062\002\000\000\000\000\000\000\033\001\161\000\000\000\
\017\000\018\000\062\002\000\000\062\002\000\000\034\001\000\000\
\000\000\000\000\000\000\000\000\035\001\036\001\037\001\038\001\
\039\001\040\001\000\000\000\000\024\000\000\000\162\000\163\000\
\000\000\164\000\165\000\000\000\000\000\030\000\000\000\041\001\
\000\000\000\000\166\000\167\000\000\000\000\000\000\000\000\000\
\000\000\208\001\209\001\000\000\210\001\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\045\001\046\001\211\001\212\001\
\049\001\213\001\000\000\000\000\000\000\000\000\000\000\000\000\
\051\001\000\000\000\000\170\000\052\001\000\000\053\001\047\000\
\000\000\000\000\000\000\000\000\048\000\000\000\240\002\051\000\
\171\000\026\001\027\001\028\001\000\000\000\000\000\000\010\000\
\207\001\000\000\030\001\000\000\000\000\013\000\000\000\000\000\
\031\001\032\001\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\033\001\161\000\000\000\017\000\
\018\000\000\000\000\000\000\000\000\000\034\001\000\000\000\000\
\000\000\000\000\000\000\035\001\036\001\037\001\038\001\039\001\
\040\001\000\000\000\000\024\000\000\000\162\000\163\000\000\000\
\164\000\165\000\000\000\000\000\030\000\000\000\041\001\000\000\
\000\000\166\000\167\000\000\000\000\000\000\000\000\000\000\000\
\208\001\209\001\000\000\210\001\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\045\001\046\001\211\001\212\001\049\001\
\213\001\000\000\000\000\000\000\000\000\000\000\000\000\051\001\
\000\000\000\000\170\000\052\001\000\000\053\001\047\000\000\000\
\000\000\000\000\000\000\048\000\000\000\194\003\051\000\171\000\
\026\001\027\001\028\001\000\000\000\000\000\000\010\000\207\001\
\000\000\030\001\000\000\000\000\013\000\000\000\000\000\031\001\
\032\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\033\001\161\000\000\000\017\000\018\000\
\000\000\000\000\000\000\000\000\034\001\000\000\000\000\000\000\
\000\000\000\000\035\001\036\001\037\001\038\001\039\001\040\001\
\000\000\000\000\024\000\000\000\162\000\163\000\000\000\164\000\
\165\000\000\000\000\000\030\000\000\000\041\001\000\000\000\000\
\166\000\167\000\000\000\000\000\000\000\000\000\000\000\208\001\
\209\001\000\000\210\001\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\045\001\046\001\211\001\212\001\049\001\213\001\
\000\000\000\000\000\000\000\000\000\000\000\000\051\001\000\000\
\000\000\170\000\052\001\000\000\053\001\047\000\000\000\000\000\
\000\000\000\000\048\000\000\000\154\004\051\000\171\000\026\001\
\027\001\028\001\000\000\000\000\000\000\010\000\207\001\000\000\
\030\001\000\000\000\000\013\000\000\000\000\000\031\001\032\001\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\033\001\161\000\000\000\017\000\018\000\000\000\
\000\000\000\000\000\000\034\001\000\000\000\000\000\000\000\000\
\000\000\035\001\036\001\037\001\038\001\039\001\040\001\000\000\
\000\000\024\000\000\000\162\000\163\000\000\000\164\000\165\000\
\000\000\000\000\030\000\000\000\041\001\000\000\000\000\166\000\
\167\000\000\000\000\000\000\000\000\000\000\000\208\001\209\001\
\000\000\210\001\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\045\001\046\001\211\001\212\001\049\001\213\001\000\000\
\000\000\157\003\000\000\000\000\000\000\051\001\000\000\010\000\
\170\000\052\001\000\000\053\001\047\000\013\000\000\000\000\000\
\079\003\048\000\000\000\000\000\051\000\171\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\161\000\000\000\017\000\
\018\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\024\000\000\000\162\000\163\000\000\000\
\164\000\165\000\000\000\000\000\030\000\000\000\200\002\000\000\
\000\000\166\000\167\000\000\000\010\000\000\000\000\000\000\000\
\168\000\000\000\013\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\169\000\000\000\000\000\
\000\000\000\000\161\000\000\000\017\000\018\000\000\000\158\003\
\000\000\000\000\170\000\000\000\000\000\000\000\047\000\000\000\
\000\000\000\000\000\000\048\000\000\000\000\000\051\000\171\000\
\024\000\000\000\162\000\163\000\000\000\164\000\165\000\000\000\
\000\000\030\000\000\000\202\002\000\000\000\000\166\000\167\000\
\000\000\010\000\000\000\000\000\000\000\168\000\000\000\013\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\169\000\000\000\000\000\000\000\000\000\161\000\
\000\000\017\000\018\000\000\000\000\000\000\000\000\000\170\000\
\000\000\000\000\000\000\047\000\000\000\000\000\000\000\000\000\
\048\000\000\000\000\000\051\000\171\000\024\000\000\000\162\000\
\163\000\000\000\164\000\165\000\000\000\000\000\030\000\000\000\
\204\002\000\000\000\000\166\000\167\000\000\000\010\000\000\000\
\000\000\000\000\168\000\000\000\013\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\169\000\
\000\000\000\000\000\000\000\000\161\000\000\000\017\000\018\000\
\000\000\000\000\000\000\000\000\170\000\000\000\000\000\000\000\
\047\000\000\000\000\000\000\000\000\000\048\000\000\000\000\000\
\051\000\171\000\024\000\000\000\162\000\163\000\000\000\164\000\
\165\000\000\000\000\000\030\000\000\000\161\004\000\000\000\000\
\166\000\167\000\000\000\010\000\000\000\000\000\000\000\168\000\
\000\000\013\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\169\000\000\000\000\000\000\000\
\000\000\161\000\000\000\017\000\018\000\000\000\000\000\000\000\
\000\000\170\000\000\000\000\000\000\000\047\000\000\000\000\000\
\000\000\000\000\048\000\000\000\000\000\051\000\171\000\024\000\
\000\000\162\000\163\000\000\000\164\000\165\000\000\000\000\000\
\030\000\000\000\163\004\000\000\000\000\166\000\167\000\000\000\
\010\000\000\000\000\000\000\000\168\000\000\000\013\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\169\000\000\000\000\000\000\000\000\000\161\000\000\000\
\017\000\018\000\000\000\000\000\000\000\000\000\170\000\000\000\
\000\000\000\000\047\000\000\000\000\000\000\000\000\000\048\000\
\000\000\000\000\051\000\171\000\024\000\000\000\162\000\163\000\
\000\000\164\000\165\000\000\000\000\000\030\000\000\000\165\004\
\000\000\000\000\166\000\167\000\000\000\010\000\000\000\000\000\
\000\000\168\000\000\000\013\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\169\000\000\000\
\000\000\000\000\000\000\161\000\000\000\017\000\018\000\000\000\
\000\000\000\000\000\000\170\000\000\000\000\000\000\000\047\000\
\000\000\000\000\000\000\000\000\048\000\000\000\000\000\051\000\
\171\000\024\000\000\000\162\000\163\000\000\000\164\000\165\000\
\000\000\000\000\030\000\000\000\000\000\000\000\000\000\166\000\
\167\000\009\000\010\000\011\000\000\000\000\000\168\000\012\000\
\013\000\014\000\032\002\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\169\000\000\000\000\000\000\000\000\000\
\015\000\016\000\017\000\018\000\019\000\020\000\021\000\000\000\
\170\000\000\000\000\000\022\000\047\000\023\000\000\000\000\000\
\000\000\048\000\000\000\000\000\051\000\171\000\024\000\000\000\
\025\000\026\000\027\000\028\000\029\000\000\000\000\000\030\000\
\031\000\000\000\000\000\032\000\033\000\034\000\000\000\000\000\
\035\000\036\000\000\000\037\000\038\000\000\000\039\000\000\000\
\040\000\000\000\041\000\000\000\042\000\000\000\000\000\000\000\
\043\000\044\000\000\000\045\000\000\000\033\002\000\000\000\000\
\009\000\010\000\011\000\000\000\046\000\000\000\012\000\013\000\
\014\000\047\000\000\000\000\000\000\000\000\000\048\000\049\000\
\050\000\051\000\052\000\053\000\000\000\000\000\054\000\015\000\
\016\000\017\000\018\000\019\000\020\000\021\000\000\000\000\000\
\000\000\000\000\022\000\000\000\023\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\024\000\000\000\025\000\
\026\000\027\000\028\000\029\000\000\000\000\000\030\000\031\000\
\000\000\000\000\032\000\033\000\034\000\000\000\000\000\035\000\
\036\000\000\000\037\000\038\000\000\000\039\000\000\000\040\000\
\000\000\041\000\000\000\042\000\000\000\000\000\000\000\043\000\
\044\000\000\000\045\000\000\000\000\000\000\000\009\000\010\000\
\011\000\000\000\000\000\046\000\012\000\013\000\000\000\000\000\
\047\000\000\000\000\000\000\000\000\000\048\000\049\000\050\000\
\051\000\052\000\053\000\000\000\000\000\054\000\000\000\017\000\
\018\000\019\000\020\000\021\000\000\000\000\000\000\000\000\000\
\022\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\024\000\000\000\025\000\026\000\027\000\
\028\000\029\000\000\000\000\000\030\000\000\000\000\000\000\000\
\032\000\033\000\034\000\000\000\000\000\000\000\036\000\000\000\
\037\000\038\000\000\000\000\000\000\000\040\000\000\000\041\000\
\000\000\000\000\000\000\000\000\000\000\043\000\044\000\000\000\
\045\000\000\000\000\000\000\000\000\000\219\000\009\000\010\000\
\011\000\000\000\000\000\222\000\012\000\013\000\047\000\000\000\
\000\000\000\000\000\000\048\000\049\000\000\000\051\000\052\000\
\000\000\000\000\000\000\054\000\000\000\000\000\000\000\017\000\
\018\000\019\000\020\000\021\000\000\000\000\000\000\000\000\000\
\022\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\024\000\000\000\025\000\026\000\027\000\
\028\000\029\000\000\000\000\000\030\000\000\000\000\000\000\000\
\032\000\033\000\034\000\000\000\000\000\000\000\036\000\000\000\
\037\000\038\000\000\000\000\000\000\000\040\000\000\000\041\000\
\000\000\000\000\000\000\000\000\000\000\043\000\044\000\000\000\
\045\000\000\000\000\000\009\000\010\000\011\000\000\000\000\000\
\000\000\012\000\013\000\000\000\000\000\000\000\047\000\000\000\
\000\000\000\000\000\000\048\000\049\000\000\000\051\000\052\000\
\238\001\000\000\000\000\054\000\017\000\018\000\019\000\020\000\
\021\000\000\000\000\000\000\000\000\000\022\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\024\000\000\000\025\000\026\000\027\000\028\000\029\000\000\000\
\000\000\030\000\000\000\000\000\000\000\032\000\033\000\034\000\
\000\000\000\000\000\000\036\000\000\000\037\000\038\000\000\000\
\000\000\000\000\040\000\000\000\041\000\000\000\000\000\000\000\
\000\000\000\000\043\000\044\000\000\000\045\000\000\000\000\000\
\009\000\010\000\011\000\000\000\000\000\000\000\012\000\013\000\
\000\000\000\000\000\000\047\000\000\000\000\000\000\000\000\000\
\048\000\049\000\000\000\051\000\052\000\000\000\000\000\000\000\
\054\000\017\000\018\000\019\000\020\000\021\000\000\000\000\000\
\000\000\000\000\022\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\024\000\000\000\025\000\
\026\000\027\000\028\000\029\000\000\000\000\000\030\000\000\000\
\000\000\000\000\032\000\033\000\034\000\000\000\000\000\000\000\
\036\000\000\000\037\000\038\000\000\000\000\000\000\000\040\000\
\000\000\041\000\000\000\000\000\000\000\000\000\100\002\043\000\
\044\000\000\000\045\000\000\000\000\000\009\000\010\000\011\000\
\000\000\000\000\000\000\012\000\013\000\000\000\000\000\000\000\
\047\000\000\000\000\000\000\000\000\000\048\000\049\000\000\000\
\051\000\052\000\000\000\000\000\000\000\054\000\017\000\018\000\
\019\000\020\000\021\000\000\000\000\000\000\000\000\000\022\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\024\000\000\000\025\000\026\000\027\000\028\000\
\029\000\000\000\000\000\030\000\000\000\000\000\000\000\032\000\
\033\000\034\000\000\000\000\000\000\000\036\000\000\000\037\000\
\038\000\000\000\000\000\000\000\040\000\000\000\041\000\000\000\
\000\000\000\000\000\000\000\000\043\000\044\000\000\000\045\000\
\000\000\000\000\000\000\000\000\075\003\009\000\010\000\011\000\
\000\000\000\000\077\003\012\000\013\000\047\000\000\000\000\000\
\000\000\000\000\048\000\049\000\000\000\051\000\052\000\000\000\
\000\000\000\000\054\000\000\000\000\000\000\000\017\000\018\000\
\019\000\020\000\021\000\000\000\000\000\000\000\000\000\022\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\024\000\000\000\025\000\026\000\027\000\028\000\
\029\000\000\000\000\000\030\000\000\000\000\000\000\000\032\000\
\033\000\034\000\000\000\000\000\000\000\036\000\000\000\037\000\
\038\000\000\000\000\000\000\000\040\000\000\000\041\000\000\000\
\000\000\000\000\000\000\000\000\043\000\044\000\000\000\045\000\
\000\000\000\000\000\000\009\000\010\000\011\000\000\000\000\000\
\000\000\012\000\013\000\000\000\000\000\047\000\000\000\000\000\
\000\000\000\000\048\000\049\000\134\004\051\000\052\000\000\000\
\000\000\000\000\054\000\000\000\017\000\018\000\019\000\020\000\
\021\000\000\000\000\000\000\000\000\000\022\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\024\000\000\000\025\000\026\000\027\000\028\000\029\000\000\000\
\000\000\030\000\000\000\000\000\000\000\032\000\033\000\034\000\
\000\000\000\000\000\000\036\000\000\000\037\000\038\000\000\000\
\000\000\000\000\040\000\000\000\041\000\000\000\000\000\000\000\
\000\000\000\000\043\000\044\000\000\000\045\000\000\000\000\000\
\025\003\025\003\025\003\000\000\000\000\000\000\025\003\025\003\
\000\000\000\000\000\000\047\000\000\000\000\000\000\000\000\000\
\048\000\049\000\000\000\051\000\052\000\025\003\000\000\000\000\
\054\000\025\003\025\003\025\003\025\003\025\003\000\000\000\000\
\000\000\000\000\025\003\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\025\003\000\000\025\003\
\025\003\025\003\025\003\025\003\000\000\000\000\025\003\000\000\
\000\000\000\000\025\003\025\003\025\003\000\000\000\000\000\000\
\025\003\000\000\025\003\025\003\000\000\000\000\000\000\025\003\
\000\000\025\003\000\000\000\000\000\000\000\000\000\000\025\003\
\025\003\000\000\025\003\000\000\000\000\009\000\010\000\011\000\
\000\000\000\000\000\000\012\000\013\000\000\000\000\000\000\000\
\025\003\000\000\000\000\000\000\000\000\025\003\025\003\000\000\
\025\003\025\003\000\000\000\000\000\000\025\003\017\000\018\000\
\019\000\020\000\021\000\000\000\000\000\000\000\000\000\022\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\024\000\000\000\025\000\026\000\027\000\028\000\
\029\000\000\000\000\000\030\000\000\000\000\000\000\000\032\000\
\033\000\034\000\000\000\000\000\000\000\036\000\000\000\037\000\
\038\000\000\000\000\000\000\000\040\000\000\000\041\000\000\000\
\000\000\000\000\000\000\000\000\043\000\044\000\000\000\045\000\
\000\000\000\000\025\003\025\003\025\003\000\000\000\000\000\000\
\025\003\025\003\000\000\000\000\000\000\047\000\000\000\000\000\
\000\000\000\000\048\000\049\000\000\000\051\000\052\000\000\000\
\000\000\000\000\054\000\025\003\025\003\025\003\025\003\025\003\
\000\000\000\000\000\000\000\000\025\003\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\025\003\
\000\000\025\003\025\003\025\003\025\003\025\003\000\000\000\000\
\025\003\000\000\000\000\000\000\025\003\025\003\025\003\000\000\
\000\000\000\000\025\003\000\000\025\003\025\003\000\000\000\000\
\000\000\025\003\000\000\025\003\000\000\000\000\000\000\000\000\
\000\000\025\003\025\003\000\000\025\003\000\000\000\000\023\003\
\023\003\023\003\000\000\000\000\000\000\023\003\023\003\000\000\
\000\000\000\000\025\003\000\000\000\000\000\000\000\000\025\003\
\025\003\000\000\025\003\025\003\000\000\000\000\000\000\025\003\
\023\003\023\003\023\003\023\003\023\003\000\000\000\000\000\000\
\000\000\023\003\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\023\003\000\000\023\003\023\003\
\023\003\023\003\023\003\000\000\000\000\023\003\000\000\000\000\
\000\000\023\003\023\003\023\003\000\000\000\000\000\000\023\003\
\000\000\023\003\023\003\000\000\000\000\010\000\023\003\000\000\
\023\003\000\000\000\000\013\000\000\000\217\003\023\003\023\003\
\018\002\023\003\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\218\003\000\000\000\000\017\000\018\000\023\003\
\000\000\000\000\000\000\000\000\023\003\023\003\000\000\023\003\
\023\003\000\000\000\000\000\000\023\003\000\000\000\000\000\000\
\000\000\024\000\252\001\000\000\163\000\000\000\164\000\165\000\
\000\000\000\000\030\000\000\000\000\000\000\000\000\000\166\000\
\219\003\000\000\010\000\000\000\000\000\000\000\168\000\000\000\
\013\000\000\000\017\002\000\000\000\000\018\002\000\000\000\000\
\254\001\000\000\000\000\169\000\000\000\000\000\000\000\218\003\
\255\001\000\000\017\000\018\000\000\000\010\000\000\000\000\000\
\170\000\000\000\000\000\013\000\047\000\250\002\000\000\000\002\
\000\000\048\000\000\000\000\000\051\000\171\000\024\000\252\001\
\000\000\163\000\000\000\164\000\165\000\017\000\018\000\030\000\
\000\000\000\000\000\000\000\000\166\000\219\003\000\000\000\000\
\000\000\000\000\000\000\168\000\000\000\000\000\000\000\000\000\
\000\000\024\000\252\001\000\000\163\000\254\001\164\000\165\000\
\169\000\000\000\030\000\000\000\000\000\255\001\000\000\166\000\
\251\002\000\000\000\000\000\000\000\000\170\000\168\000\000\000\
\252\002\047\000\000\000\000\000\000\002\000\000\048\000\000\000\
\254\001\051\000\171\000\169\000\000\000\000\000\010\000\000\000\
\255\001\000\000\000\000\000\000\013\000\000\000\107\004\000\000\
\170\000\000\000\000\000\000\000\047\000\000\000\000\000\000\002\
\000\000\048\000\000\000\108\004\051\000\171\000\017\000\018\000\
\000\000\010\000\000\000\000\000\000\000\000\000\000\000\013\000\
\000\000\031\006\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\024\000\252\001\000\000\163\000\218\003\164\000\
\165\000\017\000\018\000\030\000\000\000\000\000\000\000\000\000\
\166\000\167\000\000\000\000\000\000\000\000\000\000\000\168\000\
\000\000\000\000\000\000\000\000\000\000\024\000\252\001\000\000\
\163\000\254\001\164\000\165\000\169\000\000\000\030\000\000\000\
\000\000\255\001\000\000\166\000\219\003\000\000\010\000\000\000\
\000\000\170\000\168\000\000\000\013\000\047\000\000\000\000\000\
\000\002\000\000\048\000\000\000\254\001\051\000\171\000\169\000\
\000\000\000\000\000\000\000\000\255\001\000\000\017\000\018\000\
\000\000\010\000\000\000\000\000\170\000\000\000\000\000\013\000\
\047\000\000\000\000\000\000\002\000\000\048\000\000\000\000\000\
\051\000\171\000\024\000\252\001\000\000\163\000\000\000\164\000\
\165\000\017\000\018\000\030\000\000\000\000\000\000\000\000\000\
\166\000\167\000\000\000\000\000\000\000\000\000\000\000\168\000\
\000\000\015\006\000\000\000\000\000\000\024\000\252\001\000\000\
\163\000\254\001\164\000\165\000\169\000\000\000\030\000\000\000\
\000\000\255\001\000\000\166\000\253\001\000\000\010\000\000\000\
\000\000\170\000\168\000\000\000\013\000\047\000\000\000\000\000\
\000\002\000\000\048\000\000\000\254\001\051\000\171\000\169\000\
\000\000\000\000\000\000\000\000\255\001\000\000\017\000\018\000\
\000\000\025\003\000\000\000\000\170\000\000\000\000\000\025\003\
\047\000\000\000\000\000\000\002\000\000\048\000\000\000\000\000\
\051\000\171\000\024\000\252\001\000\000\163\000\000\000\164\000\
\165\000\025\003\025\003\030\000\000\000\000\000\000\000\000\000\
\166\000\167\000\000\000\000\000\000\000\000\000\000\000\168\000\
\000\000\000\000\000\000\000\000\000\000\025\003\025\003\000\000\
\025\003\254\001\025\003\025\003\169\000\000\000\025\003\000\000\
\000\000\255\001\000\000\025\003\025\003\000\000\023\003\000\000\
\000\000\170\000\025\003\000\000\023\003\047\000\000\000\000\000\
\000\002\000\000\048\000\000\000\025\003\051\000\171\000\025\003\
\000\000\000\000\000\000\000\000\025\003\000\000\023\003\023\003\
\000\000\000\000\000\000\000\000\025\003\000\000\000\000\000\000\
\025\003\000\000\000\000\025\003\000\000\025\003\000\000\000\000\
\025\003\025\003\023\003\023\003\000\000\023\003\000\000\023\003\
\023\003\000\000\000\000\023\003\000\000\000\000\000\000\000\000\
\023\003\023\003\000\000\000\000\010\000\000\000\000\000\023\003\
\000\000\000\000\013\000\000\000\000\000\000\000\000\000\000\000\
\000\000\023\003\000\000\000\000\023\003\000\000\000\000\000\000\
\000\000\023\003\161\000\000\000\017\000\018\000\000\000\000\000\
\000\000\023\003\000\000\000\000\000\000\023\003\000\000\000\000\
\023\003\000\000\023\003\000\000\000\000\023\003\023\003\000\000\
\024\000\000\000\162\000\163\000\000\000\164\000\165\000\000\000\
\000\000\030\000\000\000\000\000\000\000\000\000\166\000\167\000\
\000\000\000\000\000\000\010\000\000\000\168\000\000\000\205\001\
\000\000\013\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\169\000\000\000\000\000\000\000\000\000\000\000\
\000\000\161\000\219\000\017\000\018\000\000\000\000\000\170\000\
\000\000\000\000\000\000\047\000\000\000\000\000\000\000\000\000\
\048\000\000\000\000\000\051\000\171\000\000\000\000\000\024\000\
\000\000\162\000\163\000\000\000\164\000\165\000\000\000\000\000\
\030\000\000\000\000\000\000\000\000\000\166\000\167\000\000\000\
\010\000\000\000\000\000\000\000\168\000\000\000\013\000\000\000\
\000\000\000\000\000\000\000\000\000\000\010\000\011\000\000\000\
\000\000\169\000\012\000\013\000\000\000\000\000\161\000\000\000\
\017\000\018\000\000\000\000\000\000\000\000\000\170\000\000\000\
\000\000\000\000\047\000\000\000\000\000\017\000\018\000\048\000\
\000\000\000\000\051\000\171\000\024\000\000\000\162\000\163\000\
\000\000\164\000\165\000\000\000\000\000\030\000\000\000\000\000\
\000\000\024\000\166\000\167\000\026\000\027\000\028\000\029\000\
\000\000\168\000\030\000\000\000\025\003\000\000\025\003\166\000\
\034\000\000\000\025\003\000\000\000\000\000\000\169\000\000\000\
\000\000\000\000\000\000\040\000\000\000\000\000\156\003\000\000\
\000\000\000\000\025\003\170\000\025\003\025\003\045\000\047\000\
\000\000\000\000\000\000\000\000\048\000\000\000\000\000\051\000\
\171\000\000\000\000\000\000\000\047\000\000\000\000\000\000\000\
\025\003\048\000\025\003\025\003\051\000\025\003\025\003\000\000\
\000\000\025\003\000\000\000\000\000\000\000\000\025\003\025\003\
\000\000\010\000\000\000\000\000\000\000\025\003\000\000\013\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\025\003\000\000\000\000\000\000\000\000\161\000\
\000\000\017\000\018\000\000\000\000\000\000\000\000\000\025\003\
\000\000\000\000\000\000\025\003\000\000\000\000\000\000\000\000\
\025\003\000\000\000\000\025\003\025\003\024\000\000\000\162\000\
\163\000\000\000\164\000\165\000\000\000\000\000\030\000\000\000\
\000\000\000\000\000\000\166\000\167\000\000\000\025\003\000\000\
\000\000\000\000\168\000\000\000\025\003\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\169\000\
\000\000\000\000\000\000\000\000\025\003\000\000\025\003\025\003\
\000\000\025\003\000\000\000\000\170\000\000\000\000\000\025\003\
\047\000\000\000\000\000\000\000\000\000\048\000\000\000\000\000\
\051\000\171\000\025\003\000\000\025\003\025\003\000\000\025\003\
\025\003\025\003\025\003\025\003\000\000\000\000\000\000\000\000\
\025\003\025\003\000\000\000\000\000\000\000\000\000\000\025\003\
\000\000\000\000\000\000\000\000\000\000\025\003\000\000\025\003\
\025\003\000\000\025\003\025\003\025\003\000\000\025\003\000\000\
\000\000\000\000\000\000\025\003\025\003\000\000\213\002\000\000\
\000\000\025\003\025\003\000\000\213\002\025\003\000\000\000\000\
\000\000\000\000\025\003\000\000\000\000\025\003\025\003\025\003\
\000\000\000\000\000\000\000\000\213\002\000\000\213\002\213\002\
\025\003\010\000\000\000\000\000\025\003\000\000\000\000\013\000\
\025\003\000\000\000\000\000\000\000\000\025\003\000\000\000\000\
\025\003\025\003\213\002\000\000\213\002\213\002\000\000\213\002\
\213\002\017\000\018\000\213\002\000\000\000\000\000\000\000\000\
\213\002\213\002\000\000\000\000\000\000\000\000\000\000\213\002\
\000\000\000\000\000\000\000\000\000\000\024\000\000\000\162\000\
\163\000\000\000\164\000\165\000\213\002\000\000\030\000\000\000\
\000\000\000\000\000\000\166\000\167\000\000\000\194\002\000\000\
\000\000\213\002\168\000\000\000\194\002\213\002\000\000\000\000\
\000\000\000\000\213\002\000\000\000\000\213\002\213\002\169\000\
\000\000\000\000\000\000\000\000\000\000\000\000\194\002\194\002\
\000\000\023\003\000\000\000\000\170\000\000\000\000\000\023\003\
\047\000\000\000\000\000\000\000\000\000\048\000\000\000\000\000\
\051\000\171\000\194\002\000\000\194\002\194\002\000\000\194\002\
\194\002\023\003\023\003\194\002\000\000\000\000\000\000\000\000\
\194\002\194\002\000\000\000\000\000\000\000\000\000\000\194\002\
\000\000\000\000\000\000\000\000\000\000\023\003\000\000\023\003\
\023\003\000\000\023\003\023\003\194\002\000\000\023\003\000\000\
\000\000\000\000\000\000\023\003\023\003\000\000\010\000\000\000\
\000\000\194\002\023\003\000\000\013\000\194\002\000\000\000\000\
\000\000\000\000\194\002\000\000\000\000\194\002\194\002\023\003\
\000\000\000\000\000\000\000\000\000\000\000\000\017\000\018\000\
\000\000\025\003\000\000\000\000\023\003\000\000\000\000\025\003\
\023\003\000\000\000\000\000\000\000\000\023\003\000\000\000\000\
\023\003\023\003\024\000\000\000\000\000\163\000\000\000\164\000\
\165\000\025\003\025\003\030\000\000\000\000\000\000\000\000\000\
\166\000\167\000\000\000\000\000\000\000\000\000\000\000\168\000\
\000\000\000\000\000\000\000\000\000\000\025\003\000\000\000\000\
\025\003\000\000\025\003\025\003\169\000\000\000\025\003\000\000\
\000\000\000\000\000\000\025\003\025\003\000\000\000\000\000\000\
\000\000\170\000\025\003\000\000\000\000\047\000\010\000\011\000\
\000\000\000\000\048\000\012\000\013\000\051\000\171\000\025\003\
\000\000\000\000\000\000\000\000\000\000\000\000\115\001\000\000\
\000\000\000\000\000\000\000\000\025\003\000\000\017\000\018\000\
\025\003\000\000\000\000\000\000\000\000\025\003\000\000\000\000\
\025\003\025\003\000\000\000\000\000\000\000\000\000\000\116\001\
\000\000\000\000\024\000\117\001\000\000\026\000\027\000\028\000\
\029\000\000\000\000\000\030\000\000\000\000\000\000\000\000\000\
\166\000\034\000\010\000\011\000\000\000\000\000\000\000\012\000\
\013\000\000\000\000\000\000\000\040\000\000\000\000\000\000\000\
\000\000\118\001\000\000\000\000\000\000\000\000\000\000\045\000\
\000\000\119\001\017\000\018\000\000\000\000\000\000\000\000\000\
\000\000\120\001\121\001\000\000\000\000\047\000\000\000\000\000\
\122\001\000\000\048\000\000\000\000\000\051\000\024\000\117\001\
\000\000\026\000\027\000\028\000\029\000\000\000\000\000\030\000\
\000\000\000\000\000\000\000\000\166\000\034\000\010\000\011\000\
\000\000\000\000\000\000\012\000\013\000\025\003\025\003\000\000\
\040\000\000\000\025\003\025\003\000\000\118\001\000\000\000\000\
\000\000\000\000\000\000\045\000\000\000\119\001\017\000\018\000\
\000\000\000\000\000\000\000\000\000\000\025\003\025\003\000\000\
\000\000\047\000\000\000\000\000\122\001\000\000\048\000\000\000\
\000\000\051\000\024\000\000\000\000\000\026\000\027\000\028\000\
\029\000\025\003\000\000\030\000\025\003\025\003\025\003\025\003\
\207\000\034\000\025\003\000\000\000\000\000\000\059\005\025\003\
\025\003\000\000\000\000\000\000\040\000\000\000\000\000\000\000\
\000\000\000\000\000\000\025\003\000\000\060\005\000\000\045\000\
\000\000\000\000\000\000\000\000\243\001\000\000\025\003\000\000\
\000\000\000\000\000\000\000\000\000\000\047\000\000\000\000\000\
\000\000\000\000\048\000\000\000\025\003\051\000\000\000\000\000\
\000\000\025\003\000\000\000\000\025\003\061\005\000\000\137\000\
\138\000\030\000\000\000\139\000\000\000\000\000\140\000\062\005\
\000\000\000\000\000\000\032\005\078\001\079\001\000\000\000\000\
\000\000\000\000\000\000\000\000\080\001\000\000\000\000\142\000\
\000\000\033\005\081\001\082\001\034\005\083\001\063\005\143\000\
\144\000\000\000\000\000\000\000\000\000\000\000\084\001\145\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\085\001\
\246\001\000\000\000\000\064\005\147\000\086\001\087\001\088\001\
\089\001\090\001\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\091\001\000\000\000\000\000\000\000\000\186\000\000\000\000\000\
\000\000\000\000\092\001\093\001\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\094\001\095\001\096\001\
\097\001\098\001\000\000\026\001\027\001\028\001\000\000\000\000\
\000\000\035\005\207\001\000\000\030\001\000\000\000\000\100\001\
\000\000\000\000\023\003\032\001\023\003\023\003\023\003\000\000\
\023\003\000\000\000\000\023\003\023\003\000\000\033\001\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\034\001\
\000\000\000\000\000\000\000\000\023\003\035\001\036\001\037\001\
\038\001\039\001\040\001\000\000\023\003\023\003\000\000\000\000\
\000\000\000\000\000\000\000\000\023\003\000\000\000\000\000\000\
\041\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\023\003\023\003\234\002\209\001\000\000\235\002\000\000\000\000\
\000\000\000\000\041\004\078\001\079\001\045\001\046\001\236\002\
\212\001\049\001\213\001\080\001\000\000\000\000\000\000\000\000\
\000\000\081\001\082\001\000\000\083\001\052\001\000\000\053\001\
\000\000\000\000\000\000\000\000\000\000\084\001\000\000\000\000\
\000\000\000\000\043\004\078\001\079\001\000\000\085\001\000\000\
\000\000\000\000\000\000\080\001\086\001\087\001\088\001\089\001\
\090\001\081\001\082\001\000\000\083\001\000\000\000\000\000\000\
\043\002\000\000\043\002\043\002\043\002\084\001\043\002\091\001\
\000\000\043\002\043\002\000\000\186\000\000\000\085\001\000\000\
\000\000\092\001\093\001\000\000\086\001\087\001\088\001\089\001\
\090\001\000\000\043\002\000\000\094\001\095\001\096\001\097\001\
\098\001\000\000\043\002\043\002\000\000\042\004\000\000\091\001\
\000\000\000\000\043\002\000\000\186\000\000\000\100\001\000\000\
\000\000\092\001\093\001\000\000\000\000\000\000\043\002\043\002\
\045\004\078\001\079\001\000\000\094\001\095\001\096\001\097\001\
\098\001\080\001\000\000\000\000\000\000\000\000\044\004\081\001\
\082\001\000\000\083\001\000\000\000\000\000\000\100\001\000\000\
\000\000\000\000\000\000\084\001\000\000\000\000\000\000\000\000\
\041\004\078\001\079\001\000\000\085\001\000\000\000\000\000\000\
\000\000\080\001\086\001\087\001\088\001\089\001\090\001\081\001\
\082\001\000\000\083\001\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\084\001\000\000\091\001\000\000\000\000\
\000\000\000\000\186\000\000\000\085\001\000\000\000\000\092\001\
\093\001\000\000\086\001\087\001\088\001\089\001\090\001\000\000\
\000\000\000\000\094\001\095\001\096\001\097\001\098\001\000\000\
\000\000\000\000\000\000\000\000\000\000\091\001\046\004\000\000\
\000\000\000\000\186\000\000\000\100\001\000\000\000\000\092\001\
\093\001\000\000\000\000\000\000\000\000\000\000\043\004\078\001\
\079\001\000\000\094\001\095\001\096\001\097\001\098\001\080\001\
\000\000\000\000\000\000\099\004\000\000\081\001\082\001\000\000\
\083\001\000\000\000\000\000\000\100\001\000\000\000\000\000\000\
\000\000\084\001\000\000\000\000\000\000\000\000\045\004\078\001\
\079\001\000\000\085\001\000\000\000\000\000\000\000\000\080\001\
\086\001\087\001\088\001\089\001\090\001\081\001\082\001\000\000\
\083\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\084\001\000\000\091\001\000\000\000\000\000\000\000\000\
\186\000\000\000\085\001\000\000\000\000\092\001\093\001\000\000\
\086\001\087\001\088\001\089\001\090\001\000\000\000\000\000\000\
\094\001\095\001\096\001\097\001\098\001\000\000\000\000\000\000\
\000\000\000\000\100\004\091\001\000\000\000\000\000\000\000\000\
\186\000\000\000\100\001\000\000\000\000\092\001\093\001\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\094\001\095\001\096\001\097\001\098\001\081\005\078\001\079\001\
\000\000\000\000\000\000\000\000\101\004\000\000\080\001\000\000\
\000\000\000\000\100\001\000\000\081\001\082\001\000\000\083\001\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\084\001\000\000\000\000\000\000\000\000\083\005\078\001\079\001\
\000\000\085\001\000\000\000\000\000\000\000\000\080\001\086\001\
\087\001\088\001\089\001\090\001\081\001\082\001\000\000\083\001\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\084\001\000\000\091\001\000\000\000\000\000\000\000\000\186\000\
\000\000\085\001\000\000\000\000\092\001\093\001\000\000\086\001\
\087\001\088\001\089\001\090\001\000\000\000\000\000\000\094\001\
\095\001\096\001\097\001\098\001\000\000\000\000\000\000\000\000\
\082\005\000\000\091\001\000\000\000\000\000\000\000\000\186\000\
\000\000\100\001\000\000\000\000\092\001\093\001\000\000\000\000\
\000\000\000\000\000\000\085\005\078\001\079\001\000\000\094\001\
\095\001\096\001\097\001\098\001\080\001\000\000\000\000\000\000\
\000\000\084\005\081\001\082\001\000\000\083\001\000\000\000\000\
\000\000\100\001\000\000\000\000\000\000\000\000\084\001\000\000\
\000\000\000\000\000\000\081\005\078\001\079\001\000\000\085\001\
\000\000\000\000\000\000\000\000\080\001\086\001\087\001\088\001\
\089\001\090\001\081\001\082\001\000\000\083\001\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\084\001\000\000\
\091\001\000\000\000\000\000\000\000\000\186\000\000\000\085\001\
\000\000\000\000\092\001\093\001\000\000\086\001\087\001\088\001\
\089\001\090\001\000\000\000\000\000\000\094\001\095\001\096\001\
\097\001\098\001\000\000\000\000\000\000\000\000\000\000\000\000\
\091\001\086\005\000\000\000\000\000\000\186\000\000\000\100\001\
\000\000\000\000\092\001\093\001\000\000\000\000\000\000\000\000\
\000\000\083\005\078\001\079\001\000\000\094\001\095\001\096\001\
\097\001\098\001\080\001\000\000\000\000\000\000\106\005\000\000\
\081\001\082\001\000\000\083\001\000\000\000\000\000\000\100\001\
\000\000\000\000\000\000\000\000\084\001\000\000\000\000\000\000\
\000\000\085\005\078\001\079\001\000\000\085\001\000\000\000\000\
\000\000\000\000\080\001\086\001\087\001\088\001\089\001\090\001\
\081\001\082\001\000\000\083\001\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\084\001\000\000\091\001\000\000\
\000\000\000\000\000\000\186\000\000\000\085\001\000\000\000\000\
\092\001\093\001\000\000\086\001\087\001\088\001\089\001\090\001\
\000\000\000\000\000\000\094\001\095\001\096\001\097\001\098\001\
\000\000\000\000\000\000\000\000\000\000\107\005\091\001\078\001\
\079\001\000\000\000\000\186\000\000\000\100\001\000\000\080\001\
\092\001\093\001\000\000\000\000\000\000\081\001\082\001\000\000\
\083\001\000\000\000\000\094\001\095\001\096\001\097\001\098\001\
\000\000\084\001\000\000\000\000\000\000\000\000\000\000\108\005\
\000\000\000\000\085\001\000\000\000\000\100\001\000\000\000\000\
\086\001\087\001\088\001\089\001\090\001\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\091\001\078\001\079\001\000\000\000\000\
\186\000\000\000\000\000\000\000\080\001\092\001\093\001\000\000\
\000\000\000\000\081\001\082\001\000\000\083\001\000\000\000\000\
\094\001\095\001\096\001\097\001\098\001\000\000\084\001\000\000\
\000\000\000\000\000\000\000\000\000\000\099\001\000\000\085\001\
\000\000\000\000\100\001\000\000\000\000\086\001\087\001\088\001\
\089\001\090\001\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\091\001\078\001\079\001\000\000\000\000\186\000\000\000\000\000\
\000\000\080\001\092\001\093\001\000\000\000\000\000\000\081\001\
\082\001\000\000\083\001\000\000\000\000\094\001\095\001\096\001\
\097\001\098\001\000\000\084\001\000\000\000\000\031\004\000\000\
\000\000\078\001\079\001\000\000\085\001\000\000\000\000\100\001\
\000\000\080\001\086\001\087\001\088\001\089\001\090\001\081\001\
\082\001\000\000\083\001\000\000\000\000\000\000\000\000\000\000\
\000\000\138\004\000\000\084\001\000\000\091\001\000\000\000\000\
\000\000\000\000\186\000\000\000\085\001\000\000\000\000\092\001\
\093\001\000\000\086\001\087\001\088\001\089\001\090\001\000\000\
\000\000\000\000\094\001\095\001\096\001\097\001\098\001\000\000\
\000\000\000\000\000\000\093\004\000\000\091\001\078\001\079\001\
\000\000\000\000\186\000\000\000\100\001\000\000\080\001\092\001\
\093\001\000\000\000\000\000\000\081\001\082\001\000\000\083\001\
\000\000\000\000\094\001\095\001\096\001\097\001\098\001\000\000\
\084\001\000\000\000\000\000\000\000\000\000\000\240\000\240\000\
\000\000\085\001\000\000\000\000\100\001\000\000\240\000\086\001\
\087\001\088\001\089\001\090\001\240\000\240\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\240\000\000\000\091\001\000\000\000\000\000\000\000\000\186\000\
\000\000\240\000\000\000\000\000\092\001\093\001\000\000\240\000\
\240\000\240\000\240\000\240\000\000\000\000\000\000\000\094\001\
\095\001\096\001\097\001\098\001\000\000\000\000\000\000\000\000\
\000\000\000\000\240\000\078\001\079\001\000\000\000\000\240\000\
\000\000\100\001\000\000\080\001\240\000\240\000\000\000\000\000\
\000\000\081\001\000\000\000\000\000\000\000\000\000\000\240\000\
\240\000\240\000\240\000\240\000\000\000\084\001\000\000\000\000\
\240\000\000\000\000\000\078\001\079\001\000\000\085\001\000\000\
\000\000\240\000\000\000\000\000\086\001\087\001\088\001\089\001\
\090\001\081\001\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\084\001\000\000\091\001\
\000\000\000\000\000\000\000\000\186\000\000\000\085\001\000\000\
\000\000\092\001\093\001\000\000\086\001\087\001\088\001\089\001\
\090\001\094\000\000\000\000\000\094\001\095\001\096\001\097\001\
\098\001\000\000\000\000\000\000\000\000\000\000\000\000\091\001\
\095\000\016\000\000\000\000\000\186\000\000\000\100\001\000\000\
\000\000\092\001\093\001\000\000\000\000\096\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\095\001\096\001\097\001\
\098\001\000\000\000\000\136\000\000\000\137\000\138\000\030\000\
\031\000\139\000\000\000\000\000\140\000\141\000\100\001\000\000\
\035\000\000\000\000\000\000\000\000\000\000\000\097\000\000\000\
\000\000\000\000\000\000\000\000\042\000\142\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\143\000\144\000\000\000\
\000\000\000\000\000\000\000\000\098\000\145\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\099\000\146\000\147\000\053\000"

let yycheck = "\009\000\
\210\000\145\000\012\000\002\000\014\000\015\000\016\000\136\000\
\199\000\019\000\020\000\021\000\022\000\023\000\002\000\025\000\
\163\000\132\001\142\000\205\000\136\000\163\002\032\000\202\000\
\002\000\123\001\036\000\002\000\202\000\039\000\040\000\041\000\
\011\000\001\000\034\003\002\000\010\000\024\001\010\002\049\000\
\050\000\027\000\136\000\053\000\054\000\139\000\002\000\026\000\
\002\000\138\000\002\000\234\003\163\002\002\000\038\003\253\002\
\098\000\157\000\221\000\029\000\223\000\105\002\003\000\004\000\
\186\003\225\002\045\000\063\004\110\000\000\000\170\000\115\004\
\194\003\063\003\003\000\004\000\031\000\006\000\046\000\241\004\
\035\000\056\005\201\004\063\005\094\000\095\000\096\000\097\000\
\131\000\099\000\133\000\003\000\008\001\001\000\134\001\003\000\
\004\000\141\002\000\000\098\000\054\001\003\003\021\001\000\001\
\083\000\034\000\085\000\086\000\058\000\110\002\098\000\110\000\
\067\005\214\004\203\000\000\000\000\001\003\005\000\001\042\002\
\098\000\127\002\110\000\098\000\017\001\240\001\010\001\164\001\
\000\001\166\001\005\000\098\000\110\000\074\001\192\004\110\000\
\000\001\056\001\046\000\149\000\007\001\110\004\098\000\110\000\
\098\000\000\001\098\000\121\000\000\001\098\000\058\000\161\000\
\162\000\139\000\110\000\000\001\110\000\008\001\110\000\000\000\
\087\004\110\000\244\004\173\000\014\001\000\001\052\005\108\001\
\226\004\000\001\144\000\077\005\060\001\066\001\000\000\001\005\
\092\001\006\001\188\000\030\001\103\002\008\001\157\005\000\001\
\066\001\004\001\127\000\197\000\129\000\008\001\131\000\073\001\
\133\000\000\001\066\001\092\001\015\001\099\003\133\001\018\001\
\129\000\000\000\066\001\030\001\055\001\000\001\037\001\162\005\
\092\001\073\001\189\000\095\001\094\001\214\002\065\001\008\001\
\000\001\129\000\224\002\127\000\014\001\129\000\094\001\131\000\
\115\001\133\000\000\001\206\000\055\001\079\001\094\001\186\000\
\187\000\115\001\203\004\121\005\091\001\030\001\065\001\091\001\
\095\001\000\001\036\001\027\001\130\005\000\001\091\001\066\001\
\107\002\108\002\095\001\115\001\054\005\027\001\073\001\106\001\
\101\005\237\005\109\001\094\001\008\001\000\001\055\001\092\001\
\095\001\017\001\121\003\196\000\022\001\023\001\064\001\000\000\
\065\001\000\001\197\001\204\000\027\001\094\001\123\005\106\001\
\027\001\008\001\109\001\109\005\143\002\151\004\022\001\094\001\
\154\004\005\003\044\001\000\001\000\001\055\001\113\001\067\001\
\091\001\204\001\037\001\206\001\202\003\095\001\064\001\097\001\
\058\001\193\001\029\001\091\001\176\001\063\001\094\001\095\001\
\231\001\106\001\000\001\109\001\109\001\091\001\027\001\157\001\
\074\001\095\001\000\001\000\001\192\001\022\001\164\001\050\001\
\166\001\252\001\046\003\217\003\091\001\010\001\001\002\173\001\
\174\001\087\003\088\003\094\001\027\001\040\006\094\001\094\001\
\092\001\236\001\130\002\094\001\102\001\027\001\188\001\105\001\
\154\005\107\001\000\001\109\001\095\001\111\001\094\001\038\002\
\205\005\163\005\033\005\034\005\151\001\115\003\153\001\019\001\
\155\001\021\001\215\005\000\001\071\001\000\000\048\002\008\001\
\164\005\000\001\072\001\160\002\026\001\024\001\091\001\091\001\
\057\001\015\006\095\001\141\001\107\006\143\001\120\001\066\001\
\255\005\066\001\117\001\118\001\069\001\026\001\121\001\000\001\
\123\001\000\001\048\004\074\005\056\001\159\001\069\002\094\001\
\094\001\010\001\015\001\000\001\035\001\091\001\000\001\092\001\
\094\001\095\001\095\001\008\006\072\001\000\001\000\001\177\001\
\178\001\014\001\099\001\000\001\017\001\000\001\103\001\081\006\
\099\005\083\006\004\001\014\001\059\001\000\001\008\001\125\004\
\000\001\064\001\065\001\173\001\174\001\015\001\092\001\000\001\
\018\001\203\001\190\005\074\001\000\001\003\001\188\004\103\004\
\210\001\000\001\088\006\092\001\214\001\004\001\105\001\092\001\
\027\001\008\001\151\001\010\001\153\001\058\006\155\001\014\001\
\000\001\227\001\228\001\018\001\099\001\076\004\232\001\027\001\
\234\001\008\001\010\001\000\001\027\001\000\001\109\001\066\001\
\062\001\094\001\000\001\092\001\091\001\000\001\095\001\007\000\
\066\001\251\001\000\001\151\001\000\001\153\001\032\002\155\001\
\171\005\094\001\004\001\039\006\094\001\007\002\008\001\009\002\
\010\002\000\001\000\001\094\001\094\001\015\001\091\001\000\001\
\018\001\092\001\095\001\055\004\052\003\241\003\193\005\000\001\
\091\001\000\001\073\001\004\001\095\001\035\001\094\001\008\001\
\017\001\010\001\018\001\092\001\004\001\014\001\040\002\091\001\
\000\001\032\002\094\001\095\001\091\001\092\001\221\005\094\001\
\095\001\027\002\027\001\190\002\032\002\059\001\014\001\000\001\
\172\002\173\002\064\001\065\001\092\001\092\001\032\002\095\001\
\066\001\032\002\113\001\000\001\074\001\000\001\091\001\103\003\
\091\001\032\002\160\002\231\001\095\001\109\003\070\005\171\002\
\094\001\002\001\253\002\094\001\032\002\003\001\032\002\091\001\
\032\002\036\002\056\002\032\002\038\003\099\001\028\005\073\002\
\073\001\000\001\066\001\022\001\091\001\072\002\000\001\109\001\
\094\001\065\001\066\001\010\001\014\001\094\001\094\001\113\001\
\074\002\075\002\091\001\092\001\151\002\094\001\095\001\094\001\
\003\001\018\001\042\002\038\003\047\001\000\001\229\004\129\002\
\038\003\004\001\132\002\053\003\134\002\008\001\094\001\010\001\
\113\001\004\001\000\001\014\001\022\001\027\001\008\001\018\001\
\230\002\066\001\232\002\092\001\164\000\165\000\017\002\018\002\
\027\001\100\002\018\001\076\002\064\001\107\004\000\001\092\001\
\014\001\177\000\178\000\094\001\250\002\032\002\015\001\159\005\
\008\001\069\002\036\001\022\001\018\001\205\003\097\001\098\001\
\018\001\076\003\170\005\078\003\066\001\183\002\090\001\103\002\
\019\001\201\000\003\001\073\001\094\001\092\001\111\002\112\002\
\115\001\019\001\092\001\092\001\036\001\094\001\073\001\201\002\
\192\005\203\002\110\001\205\002\066\001\237\003\073\001\209\002\
\090\001\008\001\068\006\065\001\066\001\048\001\180\002\018\001\
\091\001\092\001\151\002\094\001\095\001\083\001\048\001\049\001\
\049\003\060\001\092\001\018\001\092\001\115\001\066\003\233\002\
\018\001\068\001\060\001\070\001\200\004\062\003\113\001\090\001\
\094\001\027\002\068\001\018\001\070\001\094\001\092\001\146\003\
\094\001\022\001\242\005\151\002\092\001\255\002\134\003\133\005\
\232\005\172\003\004\003\005\003\000\000\012\001\172\003\008\001\
\214\004\001\006\118\003\022\001\067\001\015\003\130\003\017\003\
\251\003\036\001\253\003\254\003\111\001\113\003\000\001\027\001\
\031\001\022\001\028\003\029\003\060\004\111\001\133\005\073\002\
\118\003\092\001\088\001\067\004\065\001\039\003\215\002\216\002\
\000\001\019\001\248\004\050\001\046\003\092\001\006\003\170\002\
\026\001\220\003\047\001\027\001\094\001\139\003\220\003\057\003\
\000\000\015\001\112\001\022\001\030\001\238\002\066\001\186\002\
\071\001\094\001\067\001\031\005\102\003\060\003\048\001\049\001\
\022\001\196\002\000\001\252\002\095\001\084\001\080\003\090\001\
\060\003\065\001\060\001\047\005\187\005\055\001\189\005\065\001\
\014\001\019\001\068\001\017\001\070\001\000\001\101\001\065\001\
\022\001\047\001\100\003\014\001\022\004\027\001\065\001\014\001\
\064\001\065\001\006\003\014\001\066\001\000\001\017\001\102\003\
\027\001\004\001\237\002\022\001\027\001\008\001\094\001\014\001\
\027\001\047\001\102\003\014\001\015\001\109\001\128\003\018\001\
\092\005\131\003\004\001\133\003\102\003\111\001\008\001\102\003\
\106\001\067\001\003\001\109\001\047\001\107\003\144\003\102\003\
\018\001\177\004\148\003\097\001\098\001\070\003\064\001\101\005\
\066\001\155\003\102\003\027\001\102\003\159\003\102\003\000\001\
\126\003\102\003\083\003\015\001\079\001\091\001\018\001\117\005\
\079\001\095\001\065\001\097\001\098\001\123\005\088\001\066\001\
\066\006\067\006\047\001\181\003\196\001\064\001\184\003\215\004\
\091\001\035\001\188\003\003\001\095\001\115\001\097\001\098\001\
\066\001\225\004\066\001\110\004\064\001\065\001\112\001\073\001\
\110\004\000\001\069\003\094\001\022\001\221\001\222\001\223\001\
\115\001\059\001\125\004\213\003\022\001\229\001\066\001\065\001\
\030\001\139\004\092\001\022\001\019\001\004\001\082\004\064\001\
\065\001\008\001\109\001\026\001\097\001\098\001\014\001\014\001\
\015\001\090\001\124\006\018\001\066\001\067\001\240\003\241\003\
\096\001\055\001\110\001\073\001\000\001\005\002\115\001\065\001\
\250\003\048\001\252\003\065\001\102\001\110\001\176\004\205\005\
\206\005\067\001\022\001\109\001\000\001\060\001\065\001\096\001\
\004\001\215\005\012\004\014\001\008\001\068\001\010\001\070\001\
\035\001\033\002\014\001\015\001\197\003\198\003\018\001\035\001\
\027\001\065\001\066\001\066\001\027\001\115\001\116\004\027\001\
\203\004\035\001\211\003\212\003\106\001\203\004\216\004\109\001\
\059\001\218\003\132\005\009\004\060\002\065\001\065\001\059\001\
\000\001\051\004\227\003\053\004\064\001\065\001\000\001\094\001\
\111\001\059\001\008\006\061\004\000\001\091\001\074\001\065\001\
\004\001\095\001\030\001\066\001\008\001\071\004\066\001\000\000\
\066\001\019\001\026\001\015\001\079\001\073\001\018\001\073\001\
\026\001\220\004\084\004\102\001\055\001\000\001\209\003\099\001\
\064\001\065\001\109\001\055\001\094\001\064\001\217\003\091\001\
\092\001\109\001\094\001\095\001\102\001\065\001\048\001\049\001\
\064\001\014\001\229\003\109\001\058\006\111\001\005\000\077\004\
\007\000\028\005\060\001\075\001\008\001\113\001\027\001\065\001\
\035\001\115\001\068\001\244\004\070\001\248\003\066\001\000\001\
\031\001\064\001\027\001\023\001\059\005\109\001\112\004\035\003\
\244\004\116\005\030\001\105\004\142\004\112\001\106\001\145\004\
\059\001\109\001\073\005\050\001\127\005\064\001\065\001\051\003\
\112\001\026\001\094\001\055\003\065\001\000\001\244\004\074\001\
\162\004\053\001\164\004\055\001\166\004\111\001\168\004\169\004\
\064\001\066\001\055\001\173\004\099\005\065\001\109\001\191\002\
\178\004\008\001\180\004\064\001\182\004\004\001\184\004\026\001\
\099\001\008\001\086\003\064\001\065\001\004\001\206\002\207\002\
\023\001\008\001\109\001\018\001\061\005\022\001\200\004\030\001\
\015\001\097\001\123\004\018\001\027\001\064\001\127\004\066\001\
\108\004\061\005\125\005\132\004\027\001\109\001\106\001\125\005\
\075\001\109\001\014\001\066\001\222\004\017\001\053\001\014\001\
\055\001\227\004\242\002\112\001\149\004\150\004\145\005\061\005\
\030\001\235\004\065\001\145\005\053\001\158\004\055\001\056\001\
\065\001\136\000\169\005\066\001\139\000\247\004\141\000\142\000\
\065\001\027\001\252\004\066\001\050\001\112\001\000\005\106\006\
\002\005\066\001\004\005\126\004\181\004\007\005\109\001\130\004\
\191\005\000\001\064\001\065\001\000\001\164\000\165\000\008\001\
\167\000\065\001\083\001\106\001\022\005\064\001\109\001\064\001\
\026\005\073\001\177\000\178\000\019\001\031\005\004\001\019\001\
\066\001\235\005\008\001\026\001\109\001\008\005\026\001\210\005\
\035\001\015\001\027\001\108\001\210\005\047\005\048\005\101\001\
\050\005\028\001\201\000\202\000\106\001\027\001\205\000\109\001\
\179\004\048\001\049\001\088\001\048\001\232\005\014\001\065\005\
\059\001\066\001\232\005\190\004\109\001\060\001\065\001\000\001\
\060\001\100\001\003\001\027\001\212\005\068\001\000\000\070\001\
\068\001\066\001\070\001\112\001\013\001\014\001\027\001\066\001\
\017\001\091\005\092\005\027\001\066\001\094\001\022\001\074\001\
\098\005\026\001\027\001\028\001\029\001\080\001\000\001\003\005\
\083\001\045\001\046\001\102\001\029\005\064\001\112\005\040\001\
\041\001\065\001\109\001\066\001\111\001\035\001\003\001\047\001\
\111\001\019\001\043\005\111\001\045\005\066\001\128\005\037\001\
\026\001\145\003\066\001\060\001\083\001\088\001\063\001\022\001\
\065\001\066\001\067\001\068\001\064\001\059\001\144\005\083\001\
\073\001\074\001\064\001\065\001\064\001\151\005\048\001\080\001\
\052\005\000\001\064\001\040\001\074\001\112\001\109\001\161\005\
\100\001\132\005\060\001\092\001\166\005\094\001\000\001\096\001\
\097\001\067\001\068\001\236\003\070\001\035\001\041\005\000\001\
\066\001\155\005\180\005\108\001\158\005\099\001\111\001\199\003\
\023\001\109\001\115\001\018\001\064\001\066\001\037\001\109\001\
\026\001\109\001\019\001\004\004\063\005\059\001\200\005\075\001\
\000\001\026\001\064\001\065\001\094\001\207\005\064\001\000\001\
\224\003\225\003\226\003\213\005\074\001\111\001\230\003\136\005\
\218\005\219\005\000\001\019\001\236\003\121\005\224\005\048\001\
\049\001\227\005\026\001\027\001\010\001\053\001\130\005\055\001\
\000\000\026\001\236\005\060\001\112\001\099\001\240\005\134\001\
\064\001\065\001\244\005\068\001\004\004\070\001\064\001\109\001\
\048\001\049\001\004\001\109\001\230\005\231\005\008\001\233\005\
\234\005\022\001\000\001\003\001\060\001\015\001\157\001\009\006\
\018\001\064\001\112\001\067\001\068\001\164\001\070\001\166\001\
\090\001\027\001\064\001\040\001\143\005\012\006\173\001\174\001\
\064\001\176\001\149\005\064\001\065\001\109\001\111\001\022\001\
\012\006\000\001\071\001\109\001\110\001\188\001\035\001\037\001\
\040\001\192\001\044\006\045\006\167\005\196\001\197\001\084\001\
\225\005\051\006\052\006\053\006\054\006\090\001\109\001\111\001\
\066\001\059\006\033\001\026\001\075\001\063\006\059\001\109\001\
\110\001\022\001\016\001\069\006\065\001\109\001\221\001\222\001\
\223\001\110\001\000\000\077\006\078\006\027\001\229\001\202\005\
\055\001\004\001\037\001\040\001\059\001\008\001\064\001\095\001\
\063\001\064\001\065\001\066\001\015\001\095\006\096\006\018\001\
\076\000\112\001\100\006\064\001\102\006\252\001\253\001\078\001\
\025\006\102\001\001\002\085\006\110\006\064\001\005\002\113\006\
\109\001\008\002\035\006\015\006\064\001\022\001\053\001\097\001\
\055\001\123\006\017\002\018\002\064\001\127\006\027\001\105\006\
\108\000\064\001\065\001\109\001\134\006\135\006\109\001\040\001\
\033\001\032\002\033\002\064\001\064\001\119\006\120\006\066\001\
\109\001\125\000\000\000\042\002\095\001\000\001\064\001\065\001\
\132\000\048\002\075\006\000\001\064\001\071\001\055\001\095\001\
\066\001\109\001\059\001\013\001\031\006\060\002\063\001\064\001\
\065\001\109\001\084\001\000\001\093\006\066\001\109\001\042\006\
\090\001\083\001\028\001\029\001\073\001\078\001\064\001\091\001\
\109\001\109\001\037\001\016\002\088\006\022\001\019\001\041\001\
\037\001\075\001\023\002\109\001\110\001\026\001\027\001\066\006\
\067\006\094\001\108\001\066\001\000\000\072\006\073\006\128\006\
\103\002\091\001\060\001\000\001\109\001\063\001\047\001\082\006\
\079\001\040\001\068\001\048\001\049\001\022\001\115\001\000\001\
\074\001\055\001\000\001\094\006\066\001\059\001\080\001\060\001\
\000\001\063\001\064\001\130\002\004\001\026\001\067\001\068\001\
\008\001\070\001\010\001\066\001\111\006\083\001\014\001\015\001\
\078\001\026\001\018\001\094\001\026\001\000\000\121\006\094\001\
\090\001\124\006\108\001\027\001\000\001\111\001\093\001\130\006\
\131\006\160\002\109\001\110\001\163\002\053\001\054\001\055\001\
\056\001\031\001\169\002\170\002\110\001\172\002\173\002\109\001\
\064\001\065\001\111\001\000\001\093\001\055\001\026\001\000\001\
\033\001\059\001\066\001\186\002\050\001\063\001\064\001\077\001\
\191\002\010\001\066\001\004\001\109\001\196\002\019\001\008\001\
\080\001\073\001\094\001\083\001\078\001\026\001\055\001\206\002\
\207\002\018\001\059\001\071\001\064\001\065\001\063\001\064\001\
\065\001\109\001\027\001\091\001\092\001\109\001\094\001\095\001\
\084\001\065\001\000\001\048\001\049\001\078\001\004\001\230\002\
\093\001\232\002\008\001\109\001\010\001\003\001\237\002\060\001\
\014\001\113\001\093\001\242\002\018\001\073\001\067\001\068\001\
\109\001\070\001\064\001\250\002\251\002\027\001\253\002\000\000\
\009\000\065\001\109\001\012\000\109\001\014\000\015\000\016\000\
\007\003\073\001\019\000\020\000\021\000\022\000\023\000\004\001\
\025\000\064\001\065\001\008\001\014\001\065\001\066\001\017\001\
\004\001\014\001\015\001\036\000\008\001\018\001\039\000\040\000\
\041\000\027\001\111\001\064\001\066\001\092\001\018\001\038\003\
\049\000\050\000\000\001\073\001\053\000\054\000\004\001\027\001\
\066\001\008\001\008\001\014\001\010\001\052\003\053\003\073\001\
\014\001\015\001\095\001\004\001\065\001\091\001\092\001\008\001\
\094\001\095\001\071\001\016\001\152\001\027\001\069\003\000\001\
\036\001\022\001\000\000\000\001\094\001\066\001\027\001\084\001\
\073\001\010\001\027\001\113\001\014\001\094\000\095\000\096\000\
\097\000\022\001\099\000\090\001\000\000\109\001\019\001\004\001\
\014\001\115\001\022\001\008\001\000\001\026\001\000\001\003\001\
\103\003\095\001\015\001\095\001\066\001\018\001\109\003\055\001\
\010\001\013\001\092\001\073\001\103\001\017\001\027\001\118\003\
\066\001\067\001\121\003\048\001\049\001\014\001\026\001\027\001\
\028\001\029\001\022\001\130\003\027\001\091\001\092\001\060\001\
\094\001\095\001\064\001\065\001\139\003\041\001\067\001\068\001\
\092\001\070\001\145\003\173\001\174\001\000\001\092\001\091\001\
\161\000\162\000\109\001\113\001\092\001\066\001\092\001\053\001\
\060\001\055\001\013\001\063\001\255\001\000\002\017\001\067\001\
\068\001\014\001\109\001\065\001\094\001\172\003\074\001\026\001\
\027\001\028\001\029\001\094\001\080\001\053\001\010\002\055\001\
\115\001\020\001\111\001\053\001\197\000\055\001\041\001\004\001\
\092\001\065\001\094\001\008\001\096\001\097\001\109\001\065\001\
\199\003\053\001\015\001\055\001\046\001\018\001\205\003\115\001\
\108\001\060\001\209\003\111\001\063\001\065\001\062\001\066\001\
\067\001\068\001\217\003\109\001\219\003\220\003\073\001\074\001\
\108\001\224\003\225\003\226\003\109\001\080\001\229\003\230\003\
\053\001\109\001\055\001\234\003\022\001\236\003\237\003\002\001\
\073\001\092\001\100\001\094\001\065\001\096\001\097\001\013\001\
\000\000\248\003\065\001\066\001\067\001\066\001\073\001\000\001\
\027\001\108\001\003\001\109\001\111\001\004\004\028\001\029\001\
\115\001\015\001\092\001\064\001\013\001\022\001\023\001\094\001\
\017\001\000\001\064\001\041\001\064\001\022\001\008\001\022\004\
\065\001\026\001\027\001\028\001\029\001\109\001\040\001\018\001\
\014\001\062\001\062\001\044\001\062\001\007\000\060\001\027\001\
\041\001\000\000\092\001\094\001\064\001\079\001\068\001\064\001\
\014\001\058\001\134\002\014\001\074\001\006\001\063\001\094\001\
\026\000\073\001\080\001\060\001\109\001\060\004\063\001\095\001\
\065\001\066\001\067\001\068\001\067\004\064\001\075\001\073\001\
\073\001\074\001\096\001\090\001\022\001\076\004\092\001\080\001\
\027\001\094\001\014\001\082\004\073\001\040\001\108\001\013\001\
\087\004\111\001\094\001\092\001\000\001\094\001\027\001\096\001\
\097\001\014\001\027\001\021\001\008\001\086\001\028\001\029\001\
\064\001\013\001\064\001\108\001\107\004\108\004\111\001\110\004\
\062\001\062\001\115\001\041\001\014\001\116\004\026\001\062\001\
\028\001\029\001\062\001\062\001\062\001\003\001\125\004\126\004\
\014\001\086\001\064\001\130\004\027\001\041\001\060\001\091\001\
\095\001\063\001\073\001\101\001\139\004\014\001\068\001\094\001\
\027\001\027\001\094\001\014\001\074\001\094\001\000\000\088\001\
\060\001\094\001\080\001\063\001\080\001\064\001\066\001\067\001\
\068\001\027\001\073\001\014\001\020\001\015\001\074\001\022\001\
\177\001\094\001\096\001\097\001\080\001\053\001\008\001\145\000\
\065\001\176\004\177\004\073\001\179\004\062\001\108\001\062\001\
\092\001\111\001\062\001\014\001\096\001\097\001\094\001\190\004\
\112\001\163\000\164\000\165\000\112\001\167\000\094\001\073\001\
\108\001\210\001\021\001\111\001\203\004\064\001\091\001\177\000\
\178\000\037\003\073\001\053\001\054\001\055\001\056\001\214\004\
\215\004\216\004\000\001\088\001\095\001\014\001\064\001\065\001\
\094\001\014\001\225\004\014\001\056\003\014\001\229\004\201\000\
\202\000\061\003\091\001\205\000\027\001\019\001\019\001\027\001\
\112\001\088\001\241\004\022\001\026\001\244\004\014\001\014\001\
\000\001\248\004\014\001\003\001\014\001\000\000\000\000\096\001\
\084\003\096\001\001\005\092\001\003\005\013\001\008\001\109\001\
\109\001\017\001\048\001\109\001\064\001\092\001\022\001\036\001\
\090\001\036\001\026\001\027\001\028\001\029\001\060\001\036\001\
\092\001\065\001\040\001\065\001\112\003\028\005\068\001\040\002\
\070\001\041\001\033\005\034\005\064\001\094\001\036\001\064\001\
\091\001\000\001\041\005\053\001\003\001\001\000\002\000\003\000\
\004\000\005\000\006\000\007\000\060\001\052\005\013\001\063\001\
\053\001\065\001\066\001\067\001\068\001\064\001\061\005\062\005\
\063\005\073\001\074\001\026\001\064\001\028\001\029\001\064\001\
\080\001\111\001\064\001\074\005\064\001\064\001\077\005\127\000\
\099\003\040\001\041\001\210\005\092\001\000\000\094\001\008\005\
\096\001\097\001\060\001\129\005\082\006\199\005\072\002\248\002\
\190\003\145\001\145\005\183\003\108\001\060\001\101\005\111\001\
\063\001\122\001\103\002\115\001\067\001\068\001\109\005\199\003\
\230\001\165\000\190\002\074\001\064\001\065\001\117\005\018\005\
\027\004\080\001\121\005\071\001\123\005\137\001\125\005\226\001\
\103\004\077\001\232\002\130\005\188\001\092\001\133\005\133\005\
\084\001\096\001\097\001\099\005\171\005\221\004\090\001\255\255\
\143\005\115\001\145\005\255\255\255\255\108\001\149\005\255\255\
\111\001\255\255\238\003\239\003\255\255\255\255\255\255\255\255\
\255\255\109\001\110\001\013\001\255\255\255\255\255\255\255\255\
\167\005\255\255\255\255\255\003\255\255\255\255\255\255\145\001\
\255\255\255\255\028\001\029\001\255\255\255\255\255\255\255\255\
\012\004\255\255\255\255\255\255\187\005\255\255\189\005\041\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\028\004\255\255\255\255\202\005\255\255\255\255\205\005\206\005\
\255\255\000\001\060\001\210\005\255\255\063\001\255\255\255\255\
\215\005\255\255\068\001\255\255\255\255\255\255\221\005\193\001\
\074\001\255\255\196\001\197\001\019\001\255\255\080\001\255\255\
\255\255\232\005\062\004\026\001\000\001\255\255\000\000\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\096\001\097\001\
\255\255\255\255\255\255\221\001\222\001\223\001\255\255\019\001\
\255\255\048\001\108\001\229\001\255\255\111\001\026\001\255\255\
\255\255\008\006\236\001\255\255\255\255\060\001\255\255\255\255\
\015\006\255\255\007\000\255\255\067\001\068\001\011\000\070\001\
\255\255\109\004\252\001\253\001\048\001\049\001\255\255\001\002\
\031\006\255\255\118\004\005\002\255\255\026\000\008\002\255\255\
\060\001\255\255\255\255\042\006\255\255\255\255\016\002\067\001\
\068\001\255\255\070\001\255\255\255\255\023\002\255\255\255\255\
\045\000\255\255\255\255\058\006\255\255\255\255\255\255\033\002\
\111\001\255\255\255\255\066\006\067\006\255\255\255\255\080\003\
\042\002\072\006\073\006\255\255\255\255\255\255\048\002\255\255\
\255\255\255\255\081\006\082\006\083\006\000\001\255\255\255\255\
\003\001\088\006\060\002\111\001\255\255\063\002\083\000\094\006\
\085\000\086\000\013\001\183\004\255\255\185\004\072\002\255\255\
\019\001\000\001\255\255\255\255\255\255\255\255\255\255\026\001\
\111\006\028\001\029\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\121\006\255\255\255\255\124\006\041\001\255\255\
\255\255\255\255\255\255\130\006\131\006\103\002\255\255\255\255\
\255\255\255\255\222\004\255\255\255\255\255\255\255\255\227\004\
\255\255\060\001\255\255\255\255\063\001\255\255\000\000\255\255\
\067\001\068\001\255\255\255\255\255\255\255\255\255\255\074\001\
\055\001\255\255\057\001\058\001\059\001\080\001\061\001\255\255\
\255\255\064\001\065\001\086\001\255\255\255\255\255\255\164\000\
\165\000\092\001\167\000\255\255\255\255\096\001\097\001\255\255\
\255\255\255\255\081\001\255\255\177\000\178\000\255\255\019\005\
\255\255\108\001\089\001\090\001\111\001\255\255\255\255\255\255\
\189\000\255\255\097\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\201\000\202\000\109\001\110\001\
\255\255\206\000\255\255\255\255\190\002\191\002\255\255\051\005\
\255\255\053\005\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\206\002\207\002\000\001\255\255\
\002\001\003\001\004\001\071\005\255\255\255\255\008\001\075\005\
\076\005\255\255\255\255\013\001\255\255\255\255\255\255\017\001\
\018\001\019\001\255\255\255\255\255\255\231\002\090\005\255\255\
\026\001\027\001\028\001\029\001\255\255\255\255\255\255\255\255\
\242\002\255\255\036\001\255\255\000\000\255\255\255\255\041\001\
\255\255\251\002\255\255\253\002\112\005\255\255\048\001\049\001\
\255\255\255\255\255\255\255\255\255\255\007\003\255\255\255\255\
\029\001\255\255\060\001\255\255\255\255\063\001\064\001\255\255\
\066\001\067\001\068\001\255\255\070\001\255\255\255\255\073\001\
\074\001\255\255\255\255\255\255\255\255\050\001\080\001\255\255\
\255\255\255\255\036\003\255\255\038\003\255\255\255\255\255\255\
\255\255\091\001\092\001\255\255\094\001\095\001\096\001\097\001\
\255\255\255\255\100\001\053\003\255\255\255\255\255\255\171\005\
\255\255\000\001\108\001\109\001\000\000\111\001\255\255\255\255\
\180\005\115\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\019\001\193\005\255\255\255\255\
\196\005\255\255\255\255\026\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\000\001\007\000\255\255\
\117\001\118\001\255\255\255\255\121\001\255\255\123\001\255\255\
\255\255\048\001\049\001\255\255\110\003\255\255\255\255\255\255\
\019\001\229\005\255\255\255\255\000\000\060\001\000\001\026\001\
\002\001\003\001\004\001\255\255\067\001\068\001\008\001\070\001\
\255\255\255\255\255\255\013\001\134\003\255\255\255\255\017\001\
\018\001\019\001\255\255\255\255\255\255\048\001\255\255\145\003\
\026\001\027\001\028\001\029\001\255\255\255\255\255\255\255\255\
\255\255\060\001\036\001\255\255\255\255\255\255\255\255\041\001\
\067\001\068\001\255\255\070\001\255\255\255\255\048\001\049\001\
\111\001\255\255\172\003\255\255\255\255\255\255\255\255\196\001\
\197\001\255\255\060\001\255\255\255\255\063\001\255\255\255\255\
\066\001\067\001\068\001\255\255\070\001\255\255\255\255\073\001\
\074\001\255\255\255\255\055\006\255\255\199\003\080\001\255\255\
\221\001\222\001\223\001\255\255\111\001\255\255\255\255\255\255\
\229\001\091\001\092\001\255\255\094\001\095\001\096\001\097\001\
\255\255\219\003\220\003\255\255\255\255\255\255\224\003\225\003\
\226\003\255\255\108\001\255\255\230\003\111\001\255\255\252\001\
\253\001\115\001\236\003\255\255\001\002\255\255\255\255\255\255\
\005\002\101\006\102\006\255\255\000\001\255\255\255\255\255\255\
\255\255\109\006\255\255\164\000\165\000\255\255\167\000\255\255\
\255\255\013\001\004\004\255\255\255\255\255\255\255\255\255\255\
\177\000\178\000\255\255\255\255\033\002\129\006\026\001\255\255\
\028\001\029\001\255\255\255\255\022\004\042\002\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\041\001\255\255\200\000\
\201\000\202\000\007\000\255\255\255\255\255\255\011\000\060\002\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\060\001\255\255\255\255\072\002\054\004\026\000\066\001\067\001\
\068\001\255\255\255\255\255\255\000\001\255\255\074\001\003\001\
\255\255\255\255\255\255\255\255\080\001\255\255\255\255\255\255\
\045\000\013\001\255\255\255\255\255\255\255\255\255\255\255\255\
\092\001\255\255\103\002\255\255\096\001\255\255\026\001\027\001\
\028\001\029\001\255\255\255\255\255\255\255\255\255\255\255\255\
\108\001\255\255\255\255\111\001\255\255\041\001\255\255\255\255\
\255\255\000\000\108\004\255\255\110\004\255\255\083\000\255\255\
\085\000\086\000\255\255\255\255\000\001\255\255\255\255\003\001\
\060\001\255\255\255\255\125\004\008\001\255\255\255\255\067\001\
\068\001\013\001\014\001\255\255\255\255\255\255\074\001\019\001\
\255\255\139\004\022\001\255\255\080\001\255\255\026\001\007\000\
\028\001\029\001\255\255\255\255\255\255\255\255\255\255\255\255\
\092\001\255\255\094\001\068\001\096\001\041\001\255\255\255\255\
\255\255\255\255\255\255\136\000\077\001\255\255\255\255\255\255\
\108\001\255\255\191\002\111\001\255\255\255\255\176\004\255\255\
\060\001\255\255\255\255\063\001\255\255\065\001\066\001\067\001\
\068\001\206\002\207\002\006\001\255\255\008\001\074\001\164\000\
\165\000\255\255\167\000\079\001\080\001\255\255\255\255\255\255\
\255\255\203\004\255\255\255\255\177\000\178\000\255\255\255\255\
\092\001\255\255\231\002\255\255\096\001\097\001\216\004\255\255\
\189\000\255\255\220\004\255\255\255\255\242\002\255\255\255\255\
\108\001\255\255\255\255\111\001\201\000\202\000\251\002\255\255\
\253\002\206\000\255\255\255\255\055\001\255\255\057\001\058\001\
\059\001\255\255\061\001\255\255\255\255\064\001\065\001\255\255\
\255\255\255\255\255\255\000\001\255\255\255\255\255\255\255\255\
\255\255\003\005\255\255\255\255\255\255\255\255\081\001\255\255\
\013\001\255\255\255\255\255\255\255\255\006\001\089\001\090\001\
\255\255\038\003\255\255\255\255\000\000\026\001\097\001\028\001\
\029\001\255\255\028\005\196\001\197\001\255\255\255\255\255\255\
\255\255\255\255\109\001\110\001\041\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\164\000\165\000\255\255\167\000\
\255\255\255\255\052\005\220\001\221\001\222\001\223\001\060\001\
\029\001\177\000\178\000\255\255\229\001\255\255\055\001\068\001\
\057\001\058\001\059\001\255\255\061\001\074\001\015\001\064\001\
\065\001\255\255\255\255\080\001\255\255\050\001\255\255\255\255\
\255\255\201\000\202\000\252\001\253\001\255\255\255\255\255\255\
\001\002\255\255\255\255\096\001\005\002\028\000\029\000\255\255\
\255\255\090\001\043\001\044\001\045\001\046\001\015\002\108\001\
\097\001\000\001\111\001\255\255\255\255\255\255\255\255\255\255\
\255\255\008\001\255\255\255\255\109\001\110\001\013\001\121\005\
\033\002\066\001\255\255\125\005\145\003\255\255\071\001\072\001\
\130\005\042\002\255\255\026\001\255\255\028\001\029\001\255\255\
\255\255\255\255\083\001\084\001\085\001\086\001\255\255\145\005\
\117\001\118\001\041\001\060\002\121\001\255\255\123\001\172\003\
\087\000\088\000\255\255\100\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\060\001\255\255\255\255\
\063\001\255\255\255\255\066\001\067\001\068\001\255\255\255\255\
\255\255\255\255\199\003\074\001\255\255\255\255\255\255\255\255\
\157\001\080\001\000\000\255\255\000\000\255\255\103\002\164\001\
\255\255\166\001\255\255\255\255\255\255\092\001\219\003\220\003\
\255\255\096\001\097\001\224\003\225\003\226\003\255\255\255\255\
\210\005\230\003\212\005\255\255\255\255\108\001\255\255\236\003\
\111\001\255\255\255\255\255\255\255\255\255\255\255\255\196\001\
\197\001\255\255\255\255\255\255\255\255\255\255\232\005\255\255\
\023\001\255\255\255\255\255\255\255\255\255\255\255\255\004\004\
\134\001\243\005\255\255\255\255\255\255\036\001\255\255\255\255\
\221\001\222\001\223\001\255\255\015\001\255\255\255\255\255\255\
\229\001\255\255\255\255\255\255\255\255\007\006\255\255\255\255\
\055\001\255\255\057\001\058\001\059\001\015\006\061\001\255\255\
\018\006\064\001\065\001\255\255\000\001\255\255\191\002\252\001\
\253\001\044\001\045\001\046\001\001\002\255\255\255\255\255\255\
\005\002\013\001\255\255\255\255\255\255\206\002\207\002\255\255\
\190\001\043\006\255\255\090\001\255\255\255\255\026\001\255\255\
\028\001\029\001\097\001\255\255\071\001\072\001\255\255\255\255\
\255\255\255\255\255\255\255\255\033\002\041\001\109\001\110\001\
\083\001\084\001\085\001\086\001\255\255\042\002\255\255\255\255\
\255\255\242\002\255\255\255\255\196\001\197\001\255\255\255\255\
\060\001\100\001\251\002\063\001\253\002\255\255\088\006\060\002\
\068\001\110\004\255\255\255\255\255\255\255\255\074\001\255\255\
\255\255\255\255\255\255\072\002\080\001\221\001\222\001\223\001\
\125\004\255\255\255\255\255\255\255\255\229\001\230\001\255\255\
\092\001\255\255\255\255\255\255\096\001\097\001\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\038\003\255\255\255\255\
\108\001\255\255\103\002\111\001\252\001\253\001\255\255\255\255\
\255\255\001\002\255\255\255\255\255\255\005\002\255\255\078\001\
\079\001\080\001\081\001\082\001\083\001\084\001\085\001\086\001\
\087\001\088\001\089\001\090\001\091\001\092\001\093\001\094\001\
\095\001\096\001\097\001\098\001\000\000\100\001\255\255\255\255\
\102\001\033\002\255\255\105\001\255\255\107\001\255\255\109\001\
\255\255\111\001\042\002\114\001\255\255\255\255\203\004\255\255\
\255\255\255\255\255\255\160\002\255\255\255\255\255\255\255\255\
\127\001\255\255\255\255\255\255\060\002\255\255\255\255\013\001\
\255\255\013\001\255\255\116\003\255\255\255\255\255\255\141\001\
\255\255\143\001\255\255\255\255\255\255\255\255\028\001\029\001\
\028\001\029\001\191\002\255\255\255\255\255\255\255\255\255\255\
\255\255\159\001\255\255\041\001\255\255\041\001\255\255\255\255\
\145\003\206\002\207\002\255\255\130\002\255\255\255\255\103\002\
\255\255\000\000\255\255\008\005\255\255\255\255\060\001\255\255\
\060\001\063\001\255\255\063\001\255\255\255\255\068\001\255\255\
\068\001\255\255\255\255\172\003\074\001\255\255\074\001\028\005\
\255\255\255\255\080\001\006\001\080\001\242\002\255\255\255\255\
\255\255\255\255\255\255\169\002\255\255\255\255\251\002\255\255\
\253\002\255\255\096\001\097\001\096\001\097\001\199\003\255\255\
\255\255\255\255\015\001\255\255\255\255\255\255\108\001\255\255\
\108\001\111\001\232\001\111\001\234\001\255\255\255\255\255\255\
\255\255\255\255\219\003\220\003\255\255\255\255\223\003\224\003\
\225\003\226\003\255\255\255\255\055\001\230\003\057\001\058\001\
\059\001\038\003\061\001\236\003\255\255\064\001\065\001\191\002\
\255\255\007\002\055\001\009\002\057\001\058\001\059\001\255\255\
\061\001\255\255\255\255\064\001\065\001\255\255\206\002\207\002\
\255\255\024\002\255\255\004\004\255\255\074\001\029\002\090\001\
\255\255\255\255\255\255\255\255\081\001\255\255\097\001\255\255\
\125\005\255\255\255\255\255\255\089\001\090\001\255\255\132\005\
\255\255\094\001\109\001\110\001\097\001\255\255\255\255\255\255\
\255\255\255\255\242\002\255\255\145\005\255\255\255\255\255\255\
\109\001\110\001\255\255\251\002\255\255\253\002\255\255\255\255\
\255\255\255\255\255\255\074\002\075\002\255\255\255\255\255\255\
\255\255\118\003\255\255\255\255\255\255\255\255\123\003\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\052\003\255\255\
\255\255\000\000\255\255\255\255\000\001\255\255\255\255\003\001\
\255\255\255\255\255\255\255\255\145\003\255\255\038\003\110\002\
\255\255\013\001\255\255\255\255\115\002\116\002\117\002\255\255\
\255\255\255\255\255\255\255\255\255\255\210\005\026\001\027\001\
\028\001\029\001\255\255\129\002\255\255\110\004\132\002\172\003\
\255\255\255\255\255\255\255\255\255\255\041\001\255\255\255\255\
\255\255\103\003\255\255\232\005\125\004\255\255\255\255\109\003\
\255\255\255\255\255\255\255\255\255\255\255\255\243\005\255\255\
\060\001\255\255\199\003\255\255\064\001\255\255\066\001\067\001\
\068\001\255\255\255\255\255\255\255\255\073\001\074\001\255\255\
\255\255\000\001\255\255\255\255\080\001\255\255\219\003\220\003\
\255\255\255\255\255\255\224\003\225\003\226\003\013\001\255\255\
\092\001\230\003\094\001\255\255\096\001\097\001\255\255\236\003\
\100\001\255\255\255\255\026\001\255\255\028\001\029\001\255\255\
\108\001\109\001\000\000\111\001\255\255\255\255\043\006\214\002\
\255\255\145\003\041\001\255\255\219\002\220\002\221\002\004\004\
\255\255\000\001\203\004\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\233\002\255\255\060\001\255\255\255\255\
\063\001\255\255\255\255\255\255\172\003\068\001\255\255\205\003\
\255\255\255\255\255\255\074\001\255\255\255\255\255\255\255\255\
\255\255\080\001\255\255\002\003\255\255\255\255\004\003\255\255\
\255\255\255\255\255\255\255\255\255\255\092\001\255\255\199\003\
\255\255\096\001\097\001\018\003\234\003\255\255\255\255\237\003\
\055\001\255\255\057\001\058\001\059\001\108\001\061\001\255\255\
\111\001\064\001\065\001\219\003\220\003\074\004\255\255\255\255\
\224\003\225\003\226\003\255\255\255\255\255\255\230\003\255\255\
\255\255\255\255\081\001\028\005\236\003\255\255\255\255\255\255\
\255\255\255\255\089\001\090\001\255\255\255\255\255\255\255\255\
\000\000\255\255\097\001\255\255\255\255\255\255\255\255\255\255\
\255\255\110\004\255\255\255\255\004\004\108\001\109\001\110\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\125\004\255\255\255\255\255\255\255\255\255\255\255\255\094\003\
\255\255\000\001\001\001\002\001\003\001\255\255\060\004\255\255\
\255\255\008\001\009\001\010\001\255\255\067\004\013\001\014\001\
\255\255\016\001\017\001\018\001\019\001\020\001\021\001\255\255\
\255\255\024\001\025\001\026\001\027\001\028\001\029\001\255\255\
\255\255\087\004\128\003\255\255\255\255\036\001\037\001\255\255\
\255\255\040\001\041\001\042\001\043\001\255\255\000\000\255\255\
\255\255\048\001\049\001\255\255\125\005\107\004\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\060\001\061\001\255\255\
\063\001\255\255\255\255\066\001\067\001\068\001\203\004\070\001\
\145\005\255\255\073\001\074\001\255\255\255\255\255\255\255\255\
\255\255\080\001\255\255\082\001\255\255\255\255\110\004\181\003\
\255\255\255\255\255\255\255\255\091\001\092\001\255\255\094\001\
\095\001\096\001\097\001\255\255\255\255\125\004\255\255\255\255\
\103\001\255\255\105\001\255\255\203\003\108\001\255\255\244\004\
\111\001\255\255\000\001\255\255\115\001\003\001\255\255\213\003\
\255\255\255\255\008\001\177\004\255\255\255\255\255\255\013\001\
\255\255\255\255\255\255\008\005\255\255\019\001\023\001\255\255\
\255\255\210\005\255\255\255\255\026\001\255\255\028\001\029\001\
\255\255\255\255\255\255\036\001\255\255\255\255\255\255\028\005\
\255\255\255\255\255\255\041\001\250\003\255\255\252\003\232\005\
\214\004\215\004\255\255\255\255\255\255\255\255\055\001\255\255\
\057\001\058\001\059\001\225\004\061\001\255\255\060\001\064\001\
\065\001\063\001\255\255\203\004\066\001\067\001\068\001\255\255\
\061\005\255\255\255\255\241\004\074\001\255\255\255\255\255\255\
\255\255\255\255\080\001\255\255\255\255\255\255\037\004\038\004\
\039\004\090\001\255\255\255\255\000\000\255\255\092\001\255\255\
\097\001\255\255\096\001\097\001\255\255\051\004\255\255\255\255\
\255\255\255\255\255\255\255\255\109\001\110\001\108\001\255\255\
\000\001\111\001\255\255\003\001\255\255\255\255\255\255\255\255\
\255\255\071\004\255\255\033\005\034\005\013\001\014\001\255\255\
\255\255\017\001\255\255\255\255\255\255\255\255\255\255\255\255\
\125\005\255\255\026\001\027\001\028\001\029\001\255\255\132\005\
\255\255\096\004\097\004\098\004\028\005\255\255\255\255\255\255\
\040\001\041\001\255\255\255\255\145\005\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\074\005\255\255\255\255\077\005\
\255\255\255\255\255\255\255\255\060\001\255\255\255\255\063\001\
\255\255\255\255\255\255\067\001\068\001\255\255\255\255\093\005\
\094\005\073\001\074\001\138\004\255\255\255\255\000\001\101\005\
\080\001\003\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\013\001\092\001\255\255\094\001\017\001\
\096\001\097\001\255\255\255\255\255\255\123\005\255\255\255\255\
\026\001\027\001\028\001\029\001\108\001\210\005\255\255\111\001\
\255\255\000\000\255\255\115\001\255\255\255\255\180\004\041\001\
\182\004\255\255\184\004\000\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\232\005\255\255\125\005\255\255\255\255\
\255\255\255\255\060\001\255\255\255\255\063\001\205\004\206\004\
\207\004\067\001\068\001\255\255\211\004\212\004\213\004\255\255\
\074\001\145\005\255\255\255\255\255\255\255\255\080\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\092\001\255\255\094\001\235\004\096\001\097\001\
\255\255\199\005\055\001\255\255\057\001\058\001\059\001\205\005\
\061\001\247\004\108\001\064\001\065\001\111\001\255\255\255\255\
\255\255\215\005\000\005\255\255\255\255\255\255\004\005\221\005\
\255\255\255\255\255\255\255\255\081\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\089\001\090\001\255\255\255\255\
\255\255\255\255\210\005\255\255\097\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\109\001\110\001\255\255\255\255\000\001\001\001\002\001\003\001\
\232\005\255\255\008\006\255\255\008\001\009\001\010\001\255\255\
\255\255\013\001\014\001\015\001\016\001\017\001\018\001\019\001\
\020\001\021\001\255\255\255\255\024\001\025\001\026\001\027\001\
\028\001\029\001\255\255\000\000\255\255\255\255\255\255\255\255\
\036\001\037\001\255\255\255\255\040\001\041\001\042\001\043\001\
\044\001\045\001\046\001\255\255\048\001\049\001\255\255\255\255\
\255\255\255\255\255\255\255\255\058\006\255\255\255\255\255\255\
\060\001\061\001\255\255\063\001\255\255\255\255\066\001\067\001\
\068\001\255\255\070\001\071\001\072\001\073\001\074\001\255\255\
\255\255\255\255\255\255\081\006\080\001\083\006\082\001\083\001\
\084\001\085\001\086\001\255\255\255\255\255\255\255\255\091\001\
\092\001\255\255\094\001\095\001\096\001\097\001\255\255\255\255\
\100\001\255\255\255\255\103\001\255\255\105\001\255\255\255\255\
\108\001\255\255\255\255\111\001\255\255\255\255\255\255\115\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\166\005\255\255\255\255\255\255\013\001\255\255\255\255\255\255\
\255\255\000\001\255\255\002\001\003\001\004\001\181\005\182\005\
\183\005\008\001\255\255\028\001\029\001\255\255\013\001\000\000\
\255\255\255\255\017\001\018\001\019\001\255\255\255\255\255\255\
\041\001\255\255\200\005\026\001\027\001\028\001\029\001\255\255\
\255\255\255\255\255\255\255\255\255\255\036\001\255\255\213\005\
\255\255\040\001\041\001\060\001\255\255\219\005\063\001\255\255\
\255\255\048\001\049\001\068\001\255\255\255\255\255\255\255\255\
\255\255\074\001\255\255\255\255\255\255\060\001\236\005\080\001\
\063\001\255\255\255\255\066\001\067\001\068\001\244\005\070\001\
\255\255\255\255\073\001\074\001\255\255\255\255\255\255\096\001\
\255\255\080\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\108\001\091\001\092\001\111\001\094\001\
\095\001\096\001\255\255\255\255\255\255\100\001\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\108\001\255\255\255\255\
\111\001\255\255\255\255\255\255\115\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\044\006\045\006\
\255\255\255\255\255\255\000\000\255\255\051\006\052\006\053\006\
\054\006\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\063\006\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\000\001\001\001\002\001\003\001\255\255\
\078\006\006\001\007\001\008\001\009\001\010\001\011\001\012\001\
\013\001\014\001\015\001\016\001\017\001\018\001\019\001\020\001\
\021\001\022\001\255\255\024\001\025\001\026\001\027\001\028\001\
\029\001\030\001\031\001\255\255\255\255\255\255\255\255\036\001\
\037\001\255\255\255\255\040\001\041\001\042\001\043\001\044\001\
\045\001\046\001\047\001\048\001\049\001\050\001\051\001\255\255\
\053\001\054\001\055\001\056\001\255\255\255\255\059\001\060\001\
\061\001\062\001\063\001\064\001\065\001\066\001\067\001\068\001\
\255\255\070\001\071\001\072\001\073\001\074\001\255\255\076\001\
\255\255\255\255\255\255\080\001\081\001\082\001\083\001\084\001\
\085\001\086\001\087\001\255\255\089\001\255\255\091\001\092\001\
\000\000\094\001\095\001\096\001\097\001\098\001\255\255\100\001\
\101\001\255\255\103\001\104\001\105\001\106\001\255\255\108\001\
\109\001\255\255\111\001\255\255\255\255\255\255\115\001\000\001\
\001\001\002\001\003\001\004\001\255\255\006\001\007\001\008\001\
\009\001\010\001\011\001\012\001\013\001\014\001\015\001\016\001\
\017\001\018\001\019\001\020\001\021\001\255\255\255\255\024\001\
\025\001\026\001\027\001\028\001\029\001\030\001\031\001\255\255\
\255\255\255\255\255\255\036\001\037\001\255\255\255\255\040\001\
\041\001\042\001\043\001\044\001\045\001\046\001\047\001\048\001\
\049\001\050\001\051\001\255\255\053\001\054\001\055\001\056\001\
\255\255\255\255\059\001\060\001\061\001\255\255\063\001\064\001\
\065\001\066\001\067\001\068\001\255\255\070\001\071\001\072\001\
\073\001\074\001\255\255\076\001\255\255\255\255\255\255\080\001\
\081\001\082\001\083\001\084\001\085\001\086\001\087\001\255\255\
\089\001\255\255\091\001\092\001\000\000\094\001\095\001\096\001\
\097\001\098\001\255\255\100\001\101\001\255\255\103\001\104\001\
\105\001\106\001\255\255\108\001\109\001\255\255\111\001\255\255\
\255\255\255\255\115\001\000\001\001\001\002\001\003\001\255\255\
\255\255\006\001\007\001\008\001\009\001\010\001\011\001\012\001\
\013\001\014\001\015\001\016\001\017\001\018\001\019\001\020\001\
\021\001\022\001\255\255\024\001\025\001\026\001\027\001\028\001\
\029\001\030\001\031\001\255\255\255\255\255\255\255\255\036\001\
\037\001\255\255\255\255\040\001\041\001\042\001\043\001\044\001\
\045\001\046\001\047\001\048\001\049\001\050\001\051\001\255\255\
\053\001\054\001\055\001\056\001\255\255\255\255\059\001\060\001\
\061\001\255\255\063\001\064\001\065\001\066\001\067\001\068\001\
\255\255\070\001\071\001\072\001\073\001\074\001\255\255\076\001\
\255\255\255\255\255\255\080\001\081\001\082\001\083\001\084\001\
\085\001\086\001\087\001\255\255\089\001\255\255\091\001\092\001\
\000\000\094\001\095\001\096\001\097\001\098\001\255\255\100\001\
\101\001\255\255\103\001\104\001\105\001\106\001\255\255\108\001\
\109\001\255\255\111\001\255\255\255\255\255\255\115\001\255\255\
\000\001\001\001\002\001\003\001\255\255\255\255\006\001\007\001\
\008\001\009\001\010\001\011\001\012\001\013\001\014\001\015\001\
\016\001\017\001\018\001\019\001\020\001\021\001\022\001\255\255\
\024\001\025\001\026\001\027\001\028\001\029\001\030\001\031\001\
\255\255\255\255\255\255\255\255\036\001\037\001\255\255\255\255\
\040\001\041\001\042\001\043\001\044\001\045\001\046\001\047\001\
\048\001\049\001\050\001\051\001\255\255\053\001\054\001\055\001\
\056\001\255\255\255\255\059\001\060\001\061\001\255\255\063\001\
\064\001\065\001\066\001\067\001\068\001\255\255\070\001\071\001\
\072\001\073\001\074\001\255\255\076\001\255\255\255\255\255\255\
\080\001\081\001\082\001\083\001\084\001\085\001\086\001\087\001\
\255\255\089\001\255\255\091\001\092\001\000\000\094\001\095\001\
\096\001\097\001\098\001\255\255\100\001\101\001\255\255\103\001\
\104\001\105\001\106\001\255\255\108\001\109\001\255\255\111\001\
\255\255\255\255\255\255\115\001\000\001\001\001\002\001\003\001\
\255\255\255\255\006\001\007\001\008\001\009\001\010\001\011\001\
\012\001\013\001\014\001\015\001\016\001\017\001\018\001\019\001\
\020\001\021\001\022\001\255\255\024\001\025\001\026\001\027\001\
\028\001\029\001\030\001\031\001\255\255\255\255\255\255\255\255\
\036\001\037\001\255\255\255\255\040\001\041\001\042\001\043\001\
\044\001\045\001\046\001\047\001\048\001\049\001\050\001\051\001\
\255\255\053\001\054\001\055\001\056\001\255\255\255\255\059\001\
\060\001\061\001\255\255\063\001\064\001\065\001\066\001\067\001\
\068\001\255\255\070\001\071\001\072\001\073\001\074\001\255\255\
\076\001\255\255\255\255\255\255\080\001\081\001\082\001\083\001\
\084\001\085\001\086\001\087\001\255\255\089\001\255\255\091\001\
\092\001\000\000\094\001\095\001\096\001\097\001\098\001\255\255\
\100\001\101\001\255\255\103\001\104\001\105\001\106\001\255\255\
\108\001\109\001\255\255\111\001\255\255\255\255\255\255\115\001\
\000\001\001\001\002\001\003\001\255\255\255\255\006\001\007\001\
\008\001\009\001\010\001\011\001\012\001\013\001\014\001\015\001\
\016\001\017\001\018\001\019\001\020\001\021\001\022\001\255\255\
\024\001\025\001\026\001\027\001\028\001\029\001\030\001\031\001\
\255\255\255\255\255\255\255\255\036\001\037\001\255\255\255\255\
\040\001\041\001\042\001\043\001\044\001\045\001\046\001\047\001\
\048\001\049\001\050\001\051\001\255\255\053\001\054\001\055\001\
\056\001\255\255\255\255\059\001\060\001\061\001\255\255\063\001\
\064\001\065\001\066\001\067\001\068\001\255\255\070\001\071\001\
\072\001\073\001\074\001\255\255\076\001\255\255\255\255\255\255\
\080\001\081\001\082\001\083\001\084\001\085\001\086\001\087\001\
\255\255\089\001\255\255\091\001\092\001\000\000\094\001\095\001\
\096\001\097\001\098\001\255\255\100\001\101\001\255\255\103\001\
\104\001\105\001\106\001\255\255\108\001\109\001\255\255\111\001\
\255\255\255\255\255\255\115\001\255\255\000\001\001\001\002\001\
\003\001\255\255\255\255\006\001\007\001\008\001\009\001\010\001\
\011\001\012\001\013\001\014\001\015\001\016\001\017\001\018\001\
\019\001\020\001\021\001\022\001\255\255\024\001\025\001\026\001\
\027\001\028\001\029\001\030\001\031\001\255\255\255\255\255\255\
\255\255\036\001\037\001\255\255\255\255\040\001\041\001\042\001\
\043\001\044\001\045\001\046\001\047\001\048\001\049\001\050\001\
\051\001\255\255\053\001\054\001\055\001\056\001\255\255\255\255\
\059\001\060\001\061\001\255\255\063\001\064\001\065\001\066\001\
\067\001\068\001\255\255\070\001\071\001\072\001\073\001\074\001\
\255\255\076\001\255\255\255\255\255\255\080\001\081\001\082\001\
\083\001\084\001\085\001\086\001\087\001\255\255\089\001\255\255\
\091\001\092\001\000\000\094\001\095\001\096\001\097\001\098\001\
\255\255\100\001\101\001\255\255\103\001\104\001\105\001\106\001\
\255\255\108\001\109\001\255\255\111\001\255\255\255\255\255\255\
\115\001\000\001\001\001\002\001\003\001\255\255\255\255\006\001\
\007\001\008\001\009\001\010\001\011\001\012\001\013\001\014\001\
\015\001\016\001\017\001\018\001\019\001\020\001\021\001\022\001\
\255\255\024\001\025\001\026\001\027\001\028\001\029\001\030\001\
\031\001\255\255\255\255\255\255\255\255\036\001\037\001\255\255\
\255\255\040\001\041\001\042\001\043\001\044\001\045\001\046\001\
\047\001\048\001\049\001\050\001\051\001\255\255\053\001\054\001\
\055\001\056\001\255\255\255\255\059\001\060\001\061\001\255\255\
\063\001\064\001\065\001\066\001\067\001\068\001\255\255\070\001\
\071\001\072\001\073\001\074\001\255\255\076\001\255\255\255\255\
\255\255\080\001\081\001\082\001\083\001\084\001\085\001\086\001\
\087\001\255\255\089\001\255\255\091\001\092\001\000\000\094\001\
\095\001\096\001\097\001\098\001\255\255\100\001\101\001\255\255\
\103\001\104\001\105\001\106\001\255\255\108\001\109\001\255\255\
\111\001\255\255\255\255\255\255\115\001\000\001\001\001\002\001\
\003\001\255\255\255\255\006\001\007\001\008\001\009\001\010\001\
\011\001\012\001\013\001\014\001\015\001\016\001\017\001\018\001\
\019\001\020\001\021\001\022\001\255\255\024\001\025\001\026\001\
\027\001\028\001\029\001\030\001\031\001\255\255\255\255\255\255\
\255\255\036\001\037\001\255\255\255\255\040\001\041\001\042\001\
\043\001\044\001\045\001\046\001\047\001\048\001\049\001\050\001\
\051\001\255\255\053\001\054\001\055\001\056\001\255\255\255\255\
\059\001\060\001\061\001\255\255\063\001\064\001\065\001\066\001\
\067\001\068\001\255\255\070\001\071\001\072\001\073\001\074\001\
\255\255\076\001\255\255\255\255\255\255\080\001\081\001\082\001\
\083\001\084\001\085\001\086\001\087\001\255\255\089\001\255\255\
\091\001\092\001\000\000\094\001\095\001\096\001\097\001\098\001\
\255\255\100\001\101\001\255\255\103\001\104\001\105\001\106\001\
\255\255\108\001\109\001\255\255\111\001\255\255\255\255\255\255\
\115\001\255\255\000\001\001\001\002\001\003\001\255\255\255\255\
\006\001\007\001\008\001\009\001\010\001\011\001\012\001\013\001\
\014\001\015\001\016\001\017\001\018\001\019\001\020\001\021\001\
\022\001\255\255\024\001\025\001\026\001\027\001\028\001\029\001\
\030\001\031\001\255\255\255\255\255\255\255\255\036\001\037\001\
\255\255\255\255\040\001\041\001\042\001\043\001\044\001\045\001\
\046\001\047\001\048\001\049\001\050\001\051\001\255\255\053\001\
\054\001\055\001\056\001\255\255\255\255\059\001\060\001\061\001\
\255\255\063\001\064\001\065\001\066\001\067\001\068\001\255\255\
\070\001\071\001\072\001\073\001\074\001\255\255\076\001\255\255\
\255\255\255\255\080\001\081\001\082\001\083\001\084\001\085\001\
\086\001\087\001\255\255\089\001\255\255\091\001\092\001\000\000\
\094\001\095\001\096\001\097\001\098\001\255\255\100\001\101\001\
\255\255\103\001\104\001\105\001\106\001\255\255\108\001\109\001\
\255\255\111\001\255\255\255\255\255\255\115\001\000\001\001\001\
\002\001\003\001\255\255\255\255\006\001\007\001\008\001\009\001\
\010\001\011\001\012\001\013\001\014\001\015\001\016\001\017\001\
\018\001\019\001\020\001\021\001\022\001\255\255\024\001\025\001\
\026\001\027\001\028\001\029\001\030\001\031\001\255\255\255\255\
\255\255\255\255\036\001\037\001\255\255\255\255\040\001\041\001\
\042\001\043\001\044\001\045\001\046\001\047\001\048\001\049\001\
\050\001\051\001\255\255\053\001\054\001\055\001\056\001\255\255\
\255\255\059\001\060\001\061\001\255\255\063\001\064\001\065\001\
\066\001\067\001\068\001\255\255\070\001\071\001\072\001\073\001\
\074\001\255\255\076\001\255\255\255\255\255\255\080\001\081\001\
\082\001\083\001\084\001\085\001\086\001\087\001\255\255\089\001\
\255\255\091\001\092\001\000\000\094\001\095\001\096\001\097\001\
\098\001\255\255\100\001\101\001\255\255\103\001\104\001\105\001\
\106\001\255\255\108\001\109\001\255\255\111\001\255\255\255\255\
\255\255\115\001\000\001\001\001\002\001\003\001\255\255\255\255\
\006\001\007\001\008\001\009\001\010\001\011\001\012\001\013\001\
\014\001\015\001\016\001\017\001\018\001\019\001\020\001\021\001\
\022\001\255\255\024\001\025\001\026\001\027\001\028\001\029\001\
\030\001\031\001\255\255\255\255\255\255\255\255\036\001\037\001\
\255\255\255\255\040\001\041\001\042\001\043\001\044\001\045\001\
\046\001\047\001\048\001\049\001\050\001\051\001\255\255\053\001\
\054\001\055\001\056\001\255\255\255\255\059\001\060\001\061\001\
\255\255\063\001\064\001\065\001\066\001\067\001\068\001\255\255\
\070\001\071\001\072\001\073\001\074\001\255\255\076\001\255\255\
\255\255\255\255\080\001\081\001\082\001\083\001\084\001\085\001\
\086\001\087\001\255\255\089\001\255\255\091\001\092\001\000\000\
\094\001\095\001\096\001\097\001\098\001\255\255\100\001\101\001\
\255\255\103\001\104\001\105\001\106\001\255\255\108\001\109\001\
\255\255\111\001\255\255\255\255\255\255\115\001\255\255\000\001\
\001\001\002\001\003\001\004\001\255\255\006\001\007\001\008\001\
\009\001\010\001\011\001\012\001\013\001\014\001\015\001\016\001\
\017\001\018\001\019\001\020\001\021\001\255\255\255\255\024\001\
\025\001\026\001\027\001\028\001\029\001\030\001\031\001\255\255\
\255\255\255\255\255\255\036\001\037\001\255\255\255\255\040\001\
\041\001\042\001\043\001\044\001\045\001\046\001\255\255\048\001\
\049\001\050\001\051\001\255\255\053\001\054\001\055\001\056\001\
\255\255\255\255\059\001\060\001\061\001\255\255\063\001\064\001\
\065\001\066\001\067\001\068\001\255\255\070\001\071\001\072\001\
\073\001\074\001\255\255\076\001\255\255\255\255\255\255\080\001\
\081\001\082\001\083\001\084\001\085\001\086\001\087\001\255\255\
\089\001\255\255\091\001\092\001\000\000\094\001\095\001\096\001\
\097\001\098\001\255\255\100\001\101\001\255\255\103\001\104\001\
\105\001\106\001\255\255\108\001\109\001\255\255\111\001\255\255\
\255\255\255\255\115\001\000\001\001\001\002\001\003\001\004\001\
\255\255\006\001\007\001\008\001\009\001\010\001\011\001\012\001\
\013\001\014\001\015\001\016\001\017\001\018\001\019\001\020\001\
\021\001\255\255\255\255\024\001\025\001\026\001\027\001\028\001\
\029\001\030\001\031\001\255\255\255\255\255\255\255\255\036\001\
\037\001\255\255\255\255\040\001\041\001\042\001\043\001\044\001\
\045\001\046\001\255\255\048\001\049\001\050\001\051\001\255\255\
\053\001\054\001\055\001\056\001\255\255\255\255\059\001\060\001\
\061\001\255\255\063\001\064\001\065\001\066\001\067\001\068\001\
\255\255\070\001\071\001\072\001\073\001\074\001\255\255\076\001\
\255\255\255\255\255\255\080\001\081\001\082\001\083\001\084\001\
\085\001\086\001\087\001\255\255\089\001\255\255\091\001\092\001\
\000\000\094\001\095\001\096\001\255\255\255\255\255\255\100\001\
\101\001\255\255\103\001\104\001\105\001\106\001\255\255\108\001\
\109\001\255\255\111\001\255\255\255\255\255\255\115\001\000\001\
\001\001\002\001\003\001\004\001\255\255\006\001\007\001\008\001\
\009\001\010\001\011\001\012\001\013\001\014\001\015\001\016\001\
\017\001\018\001\019\001\020\001\021\001\255\255\255\255\024\001\
\025\001\026\001\027\001\028\001\029\001\030\001\031\001\255\255\
\255\255\255\255\255\255\036\001\037\001\255\255\255\255\040\001\
\041\001\042\001\043\001\044\001\045\001\046\001\255\255\048\001\
\049\001\050\001\051\001\255\255\053\001\054\001\055\001\056\001\
\255\255\255\255\059\001\060\001\061\001\255\255\063\001\064\001\
\065\001\066\001\067\001\068\001\255\255\070\001\071\001\072\001\
\073\001\074\001\255\255\076\001\255\255\255\255\255\255\080\001\
\081\001\082\001\083\001\084\001\085\001\086\001\087\001\255\255\
\089\001\255\255\091\001\092\001\000\000\094\001\095\001\096\001\
\255\255\255\255\255\255\100\001\101\001\255\255\103\001\104\001\
\105\001\106\001\255\255\108\001\109\001\255\255\111\001\255\255\
\255\255\255\255\115\001\255\255\000\001\001\001\002\001\003\001\
\004\001\255\255\006\001\007\001\008\001\009\001\010\001\011\001\
\012\001\013\001\014\001\015\001\016\001\017\001\018\001\019\001\
\020\001\021\001\255\255\255\255\024\001\025\001\026\001\027\001\
\028\001\029\001\030\001\031\001\255\255\255\255\255\255\255\255\
\036\001\037\001\255\255\255\255\040\001\041\001\042\001\043\001\
\044\001\045\001\046\001\255\255\048\001\049\001\050\001\051\001\
\255\255\053\001\054\001\055\001\056\001\255\255\255\255\059\001\
\060\001\061\001\255\255\063\001\064\001\065\001\066\001\067\001\
\068\001\255\255\070\001\071\001\072\001\073\001\074\001\255\255\
\076\001\255\255\255\255\255\255\080\001\081\001\082\001\083\001\
\084\001\085\001\086\001\087\001\255\255\089\001\255\255\091\001\
\092\001\000\000\094\001\095\001\096\001\255\255\255\255\255\255\
\100\001\101\001\255\255\103\001\104\001\105\001\106\001\255\255\
\108\001\109\001\255\255\111\001\255\255\255\255\255\255\115\001\
\000\001\001\001\002\001\003\001\255\255\255\255\255\255\255\255\
\008\001\009\001\010\001\255\255\255\255\013\001\014\001\015\001\
\016\001\017\001\018\001\019\001\020\001\021\001\022\001\255\255\
\024\001\025\001\026\001\027\001\028\001\029\001\255\255\255\255\
\255\255\255\255\255\255\255\255\036\001\037\001\255\255\255\255\
\040\001\041\001\042\001\043\001\044\001\045\001\046\001\047\001\
\048\001\049\001\255\255\051\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\060\001\061\001\255\255\063\001\
\255\255\255\255\066\001\067\001\068\001\255\255\070\001\071\001\
\072\001\073\001\074\001\255\255\255\255\255\255\255\255\255\255\
\080\001\081\001\082\001\083\001\084\001\085\001\086\001\255\255\
\255\255\089\001\255\255\091\001\092\001\000\000\094\001\095\001\
\096\001\097\001\098\001\255\255\100\001\255\255\255\255\103\001\
\104\001\105\001\255\255\255\255\108\001\255\255\255\255\111\001\
\255\255\255\255\255\255\115\001\000\001\001\001\002\001\003\001\
\255\255\255\255\255\255\255\255\008\001\009\001\010\001\255\255\
\255\255\013\001\014\001\015\001\016\001\017\001\018\001\019\001\
\020\001\021\001\022\001\255\255\024\001\025\001\026\001\027\001\
\028\001\029\001\255\255\255\255\255\255\255\255\255\255\255\255\
\036\001\037\001\255\255\255\255\040\001\041\001\042\001\043\001\
\044\001\045\001\046\001\047\001\048\001\049\001\255\255\051\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\060\001\061\001\255\255\063\001\255\255\255\255\066\001\067\001\
\068\001\255\255\070\001\071\001\072\001\073\001\074\001\255\255\
\255\255\255\255\255\255\255\255\080\001\081\001\082\001\083\001\
\084\001\085\001\086\001\255\255\255\255\089\001\255\255\091\001\
\092\001\000\000\094\001\095\001\096\001\097\001\098\001\255\255\
\100\001\255\255\255\255\103\001\104\001\105\001\255\255\255\255\
\108\001\255\255\255\255\111\001\255\255\255\255\255\255\115\001\
\255\255\000\001\001\001\002\001\003\001\255\255\255\255\255\255\
\255\255\008\001\009\001\010\001\255\255\255\255\013\001\014\001\
\015\001\016\001\017\001\018\001\019\001\020\001\021\001\255\255\
\255\255\024\001\025\001\026\001\027\001\028\001\029\001\255\255\
\255\255\255\255\255\255\255\255\255\255\036\001\037\001\255\255\
\255\255\040\001\041\001\042\001\043\001\044\001\045\001\046\001\
\255\255\048\001\049\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\060\001\061\001\255\255\
\063\001\255\255\255\255\066\001\067\001\068\001\255\255\070\001\
\071\001\072\001\073\001\074\001\255\255\255\255\255\255\255\255\
\255\255\080\001\255\255\082\001\083\001\084\001\085\001\086\001\
\255\255\255\255\255\255\255\255\091\001\092\001\000\000\094\001\
\095\001\096\001\255\255\255\255\255\255\100\001\255\255\255\255\
\103\001\255\255\105\001\255\255\255\255\108\001\255\255\255\255\
\111\001\255\255\255\255\255\255\115\001\000\001\001\001\002\001\
\003\001\255\255\255\255\255\255\255\255\008\001\009\001\010\001\
\255\255\255\255\013\001\014\001\015\001\016\001\017\001\255\255\
\019\001\020\001\021\001\255\255\255\255\024\001\025\001\026\001\
\027\001\028\001\029\001\255\255\255\255\255\255\255\255\255\255\
\255\255\036\001\037\001\255\255\255\255\040\001\041\001\042\001\
\043\001\044\001\045\001\046\001\255\255\048\001\049\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\060\001\061\001\255\255\063\001\255\255\255\255\066\001\
\067\001\068\001\255\255\070\001\071\001\072\001\073\001\074\001\
\255\255\255\255\255\255\255\255\255\255\080\001\255\255\082\001\
\083\001\084\001\085\001\086\001\255\255\255\255\255\255\255\255\
\091\001\092\001\000\000\094\001\095\001\096\001\097\001\255\255\
\255\255\100\001\255\255\255\255\103\001\255\255\105\001\255\255\
\255\255\108\001\255\255\255\255\111\001\255\255\255\255\255\255\
\115\001\000\001\001\001\002\001\003\001\255\255\255\255\255\255\
\255\255\008\001\009\001\010\001\255\255\255\255\013\001\014\001\
\015\001\016\001\017\001\018\001\019\001\020\001\021\001\255\255\
\255\255\024\001\025\001\026\001\027\001\028\001\029\001\255\255\
\255\255\255\255\255\255\255\255\255\255\036\001\037\001\255\255\
\255\255\040\001\041\001\042\001\043\001\044\001\045\001\046\001\
\255\255\048\001\049\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\060\001\061\001\255\255\
\063\001\255\255\255\255\066\001\067\001\068\001\255\255\070\001\
\071\001\072\001\073\001\074\001\255\255\255\255\255\255\255\255\
\255\255\080\001\255\255\082\001\083\001\084\001\085\001\086\001\
\255\255\255\255\255\255\255\255\091\001\092\001\000\000\094\001\
\095\001\096\001\255\255\255\255\255\255\100\001\255\255\255\255\
\103\001\255\255\105\001\255\255\255\255\108\001\255\255\255\255\
\111\001\255\255\255\255\255\255\115\001\255\255\000\001\001\001\
\002\001\003\001\255\255\255\255\255\255\255\255\008\001\009\001\
\010\001\255\255\255\255\013\001\014\001\015\001\016\001\017\001\
\018\001\019\001\020\001\021\001\255\255\255\255\024\001\025\001\
\026\001\027\001\028\001\029\001\255\255\255\255\255\255\255\255\
\255\255\255\255\036\001\037\001\255\255\255\255\040\001\041\001\
\042\001\043\001\044\001\045\001\046\001\255\255\048\001\049\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\060\001\061\001\255\255\063\001\255\255\255\255\
\066\001\067\001\068\001\255\255\070\001\071\001\072\001\073\001\
\074\001\255\255\255\255\255\255\255\255\255\255\080\001\255\255\
\082\001\083\001\084\001\085\001\086\001\255\255\255\255\255\255\
\255\255\091\001\092\001\000\000\094\001\095\001\096\001\255\255\
\255\255\255\255\100\001\255\255\255\255\103\001\255\255\105\001\
\255\255\255\255\108\001\255\255\255\255\111\001\255\255\255\255\
\255\255\115\001\000\001\001\001\002\001\003\001\255\255\255\255\
\255\255\255\255\008\001\009\001\010\001\255\255\255\255\013\001\
\014\001\015\001\016\001\017\001\018\001\019\001\020\001\021\001\
\255\255\255\255\024\001\025\001\026\001\027\001\028\001\029\001\
\255\255\255\255\255\255\255\255\255\255\255\255\036\001\037\001\
\255\255\255\255\040\001\041\001\042\001\043\001\044\001\045\001\
\046\001\255\255\048\001\049\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\060\001\061\001\
\255\255\063\001\255\255\255\255\066\001\067\001\068\001\255\255\
\070\001\071\001\072\001\073\001\074\001\255\255\255\255\255\255\
\255\255\255\255\080\001\255\255\082\001\083\001\084\001\085\001\
\086\001\255\255\255\255\255\255\255\255\091\001\092\001\000\000\
\094\001\095\001\096\001\255\255\255\255\255\255\100\001\255\255\
\255\255\103\001\255\255\105\001\255\255\255\255\108\001\255\255\
\255\255\111\001\255\255\255\255\255\255\115\001\000\001\001\001\
\002\001\003\001\255\255\255\255\255\255\255\255\008\001\009\001\
\010\001\255\255\255\255\013\001\014\001\015\001\016\001\017\001\
\018\001\019\001\020\001\021\001\255\255\255\255\024\001\025\001\
\026\001\027\001\028\001\029\001\255\255\255\255\255\255\255\255\
\255\255\255\255\036\001\037\001\255\255\255\255\040\001\041\001\
\042\001\043\001\044\001\045\001\046\001\255\255\048\001\049\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\060\001\061\001\255\255\063\001\255\255\255\255\
\066\001\067\001\068\001\255\255\070\001\071\001\072\001\073\001\
\074\001\255\255\255\255\255\255\255\255\255\255\080\001\255\255\
\082\001\083\001\084\001\085\001\086\001\255\255\255\255\255\255\
\255\255\091\001\092\001\000\000\094\001\095\001\096\001\255\255\
\255\255\255\255\100\001\255\255\255\255\103\001\255\255\105\001\
\255\255\255\255\108\001\255\255\255\255\111\001\255\255\255\255\
\255\255\115\001\255\255\000\001\001\001\002\001\003\001\255\255\
\255\255\255\255\255\255\008\001\009\001\010\001\255\255\255\255\
\013\001\014\001\015\001\016\001\017\001\018\001\019\001\020\001\
\021\001\255\255\255\255\024\001\025\001\026\001\027\001\028\001\
\029\001\255\255\255\255\255\255\255\255\255\255\255\255\036\001\
\037\001\255\255\255\255\040\001\041\001\042\001\043\001\044\001\
\045\001\255\255\255\255\048\001\049\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\060\001\
\061\001\255\255\063\001\255\255\255\255\066\001\067\001\068\001\
\255\255\070\001\071\001\072\001\073\001\074\001\255\255\255\255\
\255\255\255\255\255\255\080\001\255\255\082\001\083\001\084\001\
\085\001\086\001\255\255\255\255\255\255\255\255\091\001\092\001\
\000\000\094\001\095\001\096\001\097\001\255\255\255\255\100\001\
\255\255\255\255\103\001\255\255\105\001\255\255\255\255\108\001\
\255\255\255\255\111\001\255\255\255\255\255\255\115\001\000\001\
\001\001\002\001\003\001\255\255\255\255\255\255\255\255\008\001\
\009\001\010\001\255\255\255\255\013\001\014\001\015\001\016\001\
\017\001\018\001\019\001\020\001\021\001\255\255\255\255\024\001\
\025\001\026\001\027\001\028\001\029\001\255\255\255\255\255\255\
\255\255\255\255\255\255\036\001\037\001\255\255\255\255\040\001\
\041\001\042\001\043\001\044\001\045\001\255\255\255\255\048\001\
\049\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\060\001\061\001\255\255\063\001\255\255\
\255\255\066\001\067\001\068\001\255\255\070\001\071\001\072\001\
\073\001\074\001\255\255\255\255\255\255\255\255\255\255\080\001\
\255\255\082\001\083\001\084\001\085\001\086\001\255\255\255\255\
\255\255\255\255\091\001\092\001\000\000\094\001\095\001\096\001\
\097\001\255\255\255\255\100\001\255\255\255\255\103\001\255\255\
\105\001\255\255\255\255\108\001\255\255\255\255\111\001\255\255\
\255\255\255\255\115\001\000\001\001\001\002\001\003\001\255\255\
\255\255\255\255\255\255\008\001\009\001\010\001\255\255\255\255\
\013\001\014\001\015\001\016\001\017\001\018\001\019\001\020\001\
\021\001\255\255\255\255\024\001\025\001\026\001\027\001\028\001\
\029\001\255\255\255\255\255\255\255\255\255\255\255\255\036\001\
\037\001\255\255\255\255\040\001\041\001\042\001\043\001\044\001\
\045\001\255\255\255\255\048\001\049\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\060\001\
\061\001\255\255\063\001\255\255\255\255\066\001\067\001\068\001\
\255\255\070\001\071\001\072\001\073\001\074\001\255\255\255\255\
\255\255\255\255\255\255\080\001\255\255\082\001\083\001\084\001\
\085\001\086\001\255\255\255\255\255\255\255\255\091\001\092\001\
\000\000\094\001\095\001\096\001\097\001\255\255\255\255\100\001\
\255\255\255\255\103\001\255\255\105\001\255\255\255\255\108\001\
\255\255\255\255\111\001\255\255\255\255\255\255\115\001\255\255\
\000\001\001\001\002\001\003\001\255\255\255\255\255\255\255\255\
\008\001\009\001\010\001\255\255\255\255\013\001\014\001\015\001\
\016\001\017\001\018\001\019\001\020\001\021\001\255\255\255\255\
\024\001\025\001\026\001\027\001\028\001\029\001\255\255\255\255\
\255\255\255\255\255\255\255\255\036\001\037\001\255\255\255\255\
\040\001\041\001\042\001\043\001\044\001\045\001\255\255\255\255\
\048\001\049\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\060\001\061\001\255\255\063\001\
\255\255\255\255\066\001\067\001\068\001\255\255\070\001\071\001\
\072\001\073\001\074\001\255\255\255\255\255\255\255\255\255\255\
\080\001\255\255\082\001\083\001\084\001\085\001\086\001\255\255\
\255\255\255\255\255\255\091\001\092\001\000\000\094\001\095\001\
\096\001\097\001\255\255\255\255\100\001\255\255\255\255\103\001\
\255\255\105\001\255\255\255\255\108\001\255\255\255\255\111\001\
\255\255\255\255\255\255\115\001\000\001\001\001\002\001\003\001\
\255\255\255\255\255\255\255\255\255\255\009\001\010\001\255\255\
\255\255\013\001\014\001\015\001\016\001\017\001\018\001\019\001\
\020\001\021\001\255\255\255\255\024\001\025\001\026\001\027\001\
\028\001\029\001\255\255\255\255\255\255\255\255\255\255\255\255\
\036\001\037\001\255\255\255\255\040\001\041\001\042\001\043\001\
\044\001\045\001\046\001\255\255\048\001\049\001\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\060\001\061\001\255\255\063\001\255\255\255\255\066\001\067\001\
\068\001\255\255\070\001\071\001\072\001\073\001\074\001\255\255\
\255\255\255\255\255\255\255\255\080\001\255\255\082\001\083\001\
\084\001\085\001\086\001\255\255\255\255\255\255\255\255\091\001\
\092\001\000\000\094\001\095\001\096\001\097\001\255\255\255\255\
\100\001\255\255\255\255\103\001\255\255\105\001\255\255\255\255\
\108\001\255\255\255\255\111\001\255\255\255\255\255\255\115\001\
\000\001\001\001\002\001\003\001\255\255\255\255\255\255\255\255\
\255\255\009\001\010\001\255\255\255\255\013\001\014\001\015\001\
\016\001\017\001\018\001\019\001\020\001\021\001\255\255\255\255\
\024\001\025\001\026\001\027\001\028\001\029\001\255\255\255\255\
\255\255\255\255\255\255\255\255\036\001\037\001\255\255\255\255\
\040\001\041\001\042\001\043\001\044\001\045\001\046\001\255\255\
\048\001\049\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\060\001\061\001\255\255\063\001\
\255\255\255\255\066\001\067\001\068\001\255\255\070\001\071\001\
\072\001\073\001\074\001\255\255\255\255\255\255\255\255\255\255\
\080\001\255\255\082\001\083\001\084\001\085\001\086\001\255\255\
\255\255\255\255\255\255\091\001\092\001\000\000\094\001\095\001\
\096\001\097\001\255\255\255\255\100\001\255\255\255\255\103\001\
\255\255\105\001\255\255\255\255\108\001\255\255\255\255\111\001\
\255\255\255\255\255\255\115\001\255\255\000\001\001\001\002\001\
\003\001\255\255\255\255\255\255\255\255\255\255\009\001\010\001\
\255\255\255\255\013\001\014\001\015\001\016\001\017\001\018\001\
\019\001\020\001\021\001\255\255\255\255\024\001\025\001\026\001\
\027\001\028\001\029\001\255\255\255\255\255\255\255\255\255\255\
\255\255\036\001\037\001\255\255\255\255\040\001\041\001\042\001\
\043\001\044\001\045\001\046\001\255\255\048\001\049\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\060\001\061\001\255\255\063\001\255\255\255\255\066\001\
\067\001\068\001\255\255\070\001\071\001\072\001\073\001\074\001\
\255\255\255\255\255\255\255\255\255\255\080\001\255\255\082\001\
\083\001\084\001\085\001\086\001\255\255\255\255\255\255\255\255\
\091\001\092\001\000\000\094\001\095\001\096\001\097\001\255\255\
\255\255\100\001\255\255\255\255\103\001\255\255\105\001\255\255\
\255\255\108\001\255\255\255\255\111\001\255\255\255\255\255\255\
\115\001\000\001\001\001\002\001\003\001\255\255\255\255\255\255\
\255\255\008\001\009\001\010\001\255\255\255\255\013\001\014\001\
\015\001\016\001\017\001\018\001\019\001\020\001\021\001\255\255\
\255\255\024\001\025\001\026\001\027\001\028\001\029\001\255\255\
\255\255\255\255\255\255\255\255\255\255\036\001\037\001\255\255\
\255\255\040\001\041\001\042\001\043\001\044\001\255\255\255\255\
\255\255\048\001\049\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\060\001\061\001\255\255\
\063\001\255\255\255\255\066\001\067\001\068\001\255\255\070\001\
\071\001\072\001\073\001\074\001\255\255\255\255\255\255\255\255\
\255\255\080\001\255\255\082\001\255\255\084\001\085\001\086\001\
\255\255\255\255\255\255\255\255\091\001\092\001\000\000\094\001\
\095\001\096\001\097\001\255\255\255\255\255\255\255\255\255\255\
\103\001\255\255\105\001\255\255\255\255\108\001\255\255\255\255\
\111\001\255\255\255\255\255\255\115\001\000\001\001\001\002\001\
\003\001\255\255\255\255\255\255\255\255\008\001\009\001\010\001\
\255\255\255\255\013\001\014\001\015\001\016\001\017\001\018\001\
\019\001\020\001\021\001\255\255\255\255\024\001\025\001\026\001\
\027\001\028\001\029\001\255\255\255\255\255\255\255\255\255\255\
\255\255\036\001\037\001\255\255\255\255\040\001\041\001\042\001\
\043\001\044\001\255\255\255\255\255\255\048\001\049\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\060\001\061\001\255\255\063\001\255\255\255\255\066\001\
\067\001\068\001\255\255\070\001\071\001\072\001\073\001\074\001\
\255\255\255\255\255\255\255\255\255\255\080\001\255\255\082\001\
\255\255\084\001\085\001\086\001\255\255\255\255\255\255\255\255\
\091\001\092\001\000\000\094\001\095\001\096\001\097\001\255\255\
\255\255\255\255\255\255\255\255\103\001\255\255\105\001\255\255\
\255\255\108\001\255\255\255\255\111\001\255\255\255\255\255\255\
\115\001\255\255\000\001\001\001\002\001\003\001\255\255\255\255\
\255\255\255\255\008\001\009\001\010\001\255\255\255\255\013\001\
\014\001\015\001\016\001\017\001\018\001\019\001\020\001\021\001\
\255\255\255\255\024\001\025\001\026\001\027\001\028\001\029\001\
\255\255\255\255\255\255\255\255\255\255\255\255\036\001\037\001\
\255\255\255\255\040\001\041\001\042\001\043\001\044\001\255\255\
\255\255\255\255\048\001\049\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\060\001\061\001\
\255\255\063\001\255\255\255\255\066\001\067\001\068\001\255\255\
\070\001\071\001\072\001\073\001\074\001\255\255\255\255\255\255\
\255\255\255\255\080\001\255\255\082\001\255\255\084\001\085\001\
\086\001\255\255\255\255\255\255\255\255\091\001\092\001\000\000\
\094\001\095\001\096\001\097\001\255\255\255\255\255\255\255\255\
\255\255\103\001\255\255\105\001\255\255\255\255\108\001\255\255\
\255\255\111\001\255\255\255\255\255\255\115\001\000\001\001\001\
\002\001\003\001\255\255\255\255\255\255\255\255\008\001\009\001\
\010\001\255\255\255\255\013\001\014\001\015\001\016\001\017\001\
\018\001\019\001\020\001\021\001\255\255\255\255\024\001\025\001\
\026\001\027\001\028\001\029\001\255\255\255\255\255\255\255\255\
\255\255\255\255\036\001\037\001\255\255\255\255\040\001\041\001\
\042\001\043\001\044\001\255\255\255\255\255\255\048\001\049\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\060\001\061\001\255\255\063\001\255\255\255\255\
\066\001\067\001\068\001\255\255\070\001\071\001\072\001\073\001\
\074\001\255\255\255\255\255\255\255\255\255\255\080\001\255\255\
\082\001\255\255\084\001\085\001\086\001\255\255\255\255\255\255\
\255\255\091\001\092\001\000\000\094\001\095\001\096\001\097\001\
\255\255\255\255\255\255\255\255\255\255\103\001\255\255\105\001\
\255\255\255\255\108\001\255\255\255\255\111\001\255\255\255\255\
\255\255\115\001\000\001\001\001\002\001\003\001\255\255\255\255\
\255\255\255\255\008\001\009\001\010\001\255\255\255\255\013\001\
\014\001\015\001\016\001\017\001\018\001\019\001\020\001\021\001\
\255\255\255\255\024\001\025\001\026\001\027\001\028\001\029\001\
\255\255\255\255\255\255\255\255\255\255\255\255\036\001\037\001\
\255\255\255\255\040\001\041\001\042\001\043\001\044\001\255\255\
\255\255\255\255\048\001\049\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\060\001\061\001\
\255\255\063\001\255\255\255\255\066\001\067\001\068\001\255\255\
\070\001\071\001\072\001\073\001\074\001\255\255\255\255\255\255\
\255\255\255\255\080\001\255\255\082\001\255\255\084\001\085\001\
\086\001\255\255\255\255\255\255\255\255\091\001\092\001\000\000\
\094\001\095\001\096\001\097\001\255\255\255\255\255\255\255\255\
\255\255\103\001\255\255\105\001\255\255\255\255\108\001\255\255\
\255\255\111\001\255\255\255\255\255\255\115\001\255\255\000\001\
\001\001\002\001\003\001\255\255\255\255\255\255\255\255\008\001\
\009\001\010\001\255\255\255\255\013\001\014\001\015\001\016\001\
\017\001\018\001\019\001\020\001\021\001\255\255\255\255\024\001\
\025\001\026\001\027\001\028\001\029\001\255\255\255\255\255\255\
\255\255\255\255\255\255\036\001\037\001\255\255\255\255\040\001\
\041\001\042\001\043\001\044\001\255\255\255\255\255\255\048\001\
\049\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\060\001\061\001\255\255\063\001\255\255\
\255\255\066\001\067\001\068\001\255\255\070\001\071\001\072\001\
\073\001\074\001\255\255\255\255\255\255\255\255\255\255\080\001\
\255\255\082\001\255\255\084\001\085\001\086\001\255\255\255\255\
\255\255\255\255\091\001\092\001\000\000\094\001\095\001\096\001\
\097\001\255\255\255\255\255\255\255\255\255\255\103\001\255\255\
\105\001\255\255\255\255\108\001\255\255\255\255\111\001\255\255\
\255\255\255\255\115\001\000\001\001\001\002\001\003\001\255\255\
\255\255\255\255\255\255\008\001\009\001\010\001\255\255\255\255\
\013\001\014\001\015\001\016\001\017\001\018\001\019\001\020\001\
\021\001\255\255\255\255\024\001\025\001\026\001\027\001\028\001\
\029\001\255\255\255\255\255\255\255\255\255\255\255\255\036\001\
\037\001\255\255\255\255\040\001\041\001\042\001\043\001\044\001\
\045\001\046\001\255\255\048\001\049\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\060\001\
\061\001\255\255\255\255\255\255\255\255\066\001\067\001\068\001\
\255\255\070\001\255\255\255\255\073\001\074\001\255\255\255\255\
\255\255\255\255\255\255\080\001\255\255\082\001\255\255\255\255\
\255\255\086\001\255\255\255\255\255\255\255\255\091\001\092\001\
\000\000\094\001\095\001\096\001\097\001\255\255\255\255\100\001\
\255\255\255\255\103\001\255\255\105\001\255\255\255\255\108\001\
\255\255\255\255\111\001\255\255\255\255\255\255\115\001\000\001\
\001\001\002\001\003\001\255\255\255\255\255\255\255\255\008\001\
\009\001\010\001\255\255\255\255\013\001\014\001\255\255\016\001\
\017\001\018\001\019\001\020\001\021\001\255\255\255\255\024\001\
\025\001\026\001\027\001\028\001\029\001\255\255\255\255\255\255\
\255\255\255\255\255\255\036\001\037\001\255\255\255\255\040\001\
\041\001\042\001\255\255\255\255\255\255\255\255\255\255\048\001\
\049\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\060\001\061\001\255\255\063\001\255\255\
\255\255\255\255\067\001\068\001\255\255\070\001\255\255\255\255\
\073\001\074\001\255\255\255\255\255\255\255\255\255\255\080\001\
\255\255\082\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\091\001\092\001\000\000\094\001\095\001\096\001\
\097\001\255\255\255\255\255\255\255\255\255\255\103\001\255\255\
\105\001\255\255\255\255\108\001\255\255\255\255\111\001\255\255\
\255\255\255\255\115\001\255\255\000\001\001\001\002\001\003\001\
\255\255\255\255\255\255\255\255\008\001\009\001\010\001\255\255\
\255\255\013\001\014\001\255\255\016\001\017\001\018\001\019\001\
\020\001\021\001\255\255\255\255\024\001\025\001\026\001\027\001\
\028\001\029\001\255\255\255\255\255\255\255\255\255\255\255\255\
\036\001\037\001\255\255\255\255\040\001\041\001\042\001\255\255\
\255\255\255\255\255\255\255\255\048\001\049\001\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\060\001\061\001\255\255\063\001\255\255\255\255\255\255\067\001\
\068\001\255\255\070\001\255\255\255\255\073\001\074\001\255\255\
\255\255\255\255\255\255\255\255\080\001\255\255\082\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\091\001\
\092\001\000\000\094\001\095\001\096\001\097\001\255\255\255\255\
\255\255\255\255\255\255\103\001\255\255\105\001\255\255\255\255\
\108\001\255\255\255\255\111\001\255\255\255\255\255\255\115\001\
\000\001\001\001\002\001\003\001\255\255\255\255\255\255\255\255\
\008\001\009\001\010\001\255\255\255\255\013\001\014\001\255\255\
\016\001\017\001\018\001\019\001\020\001\021\001\255\255\255\255\
\024\001\025\001\026\001\027\001\028\001\029\001\255\255\255\255\
\255\255\255\255\255\255\255\255\036\001\037\001\255\255\255\255\
\040\001\041\001\042\001\255\255\255\255\255\255\255\255\255\255\
\048\001\049\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\060\001\061\001\255\255\063\001\
\255\255\255\255\255\255\067\001\068\001\255\255\070\001\255\255\
\255\255\073\001\074\001\255\255\255\255\255\255\255\255\255\255\
\080\001\000\000\082\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\091\001\092\001\255\255\094\001\095\001\
\096\001\097\001\255\255\255\255\255\255\255\255\255\255\103\001\
\255\255\105\001\255\255\255\255\108\001\255\255\255\255\111\001\
\255\255\255\255\255\255\115\001\000\001\001\001\002\001\003\001\
\255\255\255\255\255\255\255\255\008\001\009\001\010\001\255\255\
\255\255\013\001\014\001\255\255\016\001\017\001\018\001\019\001\
\020\001\021\001\255\255\255\255\024\001\025\001\026\001\027\001\
\028\001\029\001\255\255\255\255\255\255\255\255\255\255\255\255\
\036\001\037\001\255\255\255\255\040\001\041\001\042\001\255\255\
\255\255\255\255\255\255\255\255\048\001\049\001\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\060\001\061\001\255\255\063\001\255\255\255\255\255\255\067\001\
\068\001\000\000\070\001\255\255\255\255\073\001\074\001\255\255\
\255\255\255\255\255\255\255\255\080\001\255\255\082\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\091\001\
\092\001\255\255\094\001\095\001\096\001\097\001\255\255\255\255\
\255\255\255\255\255\255\103\001\255\255\105\001\255\255\255\255\
\108\001\255\255\255\255\111\001\255\255\255\255\255\255\115\001\
\255\255\000\001\001\001\002\001\003\001\255\255\255\255\255\255\
\255\255\008\001\009\001\010\001\255\255\255\255\013\001\014\001\
\255\255\016\001\017\001\018\001\019\001\020\001\021\001\255\255\
\255\255\024\001\025\001\026\001\027\001\028\001\029\001\255\255\
\255\255\255\255\255\255\255\255\255\255\036\001\037\001\255\255\
\255\255\040\001\041\001\042\001\255\255\255\255\255\255\255\255\
\255\255\048\001\049\001\255\255\255\255\255\255\255\255\255\255\
\255\255\000\000\255\255\255\255\255\255\060\001\061\001\255\255\
\063\001\255\255\255\255\255\255\067\001\068\001\255\255\070\001\
\255\255\255\255\073\001\074\001\255\255\255\255\255\255\255\255\
\255\255\080\001\255\255\082\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\091\001\092\001\255\255\094\001\
\095\001\096\001\097\001\255\255\255\255\255\255\255\255\255\255\
\103\001\000\001\105\001\255\255\003\001\108\001\255\255\255\255\
\111\001\008\001\009\001\010\001\115\001\255\255\013\001\014\001\
\255\255\016\001\017\001\018\001\019\001\020\001\021\001\255\255\
\255\255\024\001\025\001\026\001\255\255\028\001\029\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\037\001\255\255\
\255\255\040\001\041\001\255\255\255\255\255\255\255\255\255\255\
\255\255\048\001\049\001\255\255\255\255\255\255\255\255\255\255\
\255\255\000\000\255\255\255\255\255\255\060\001\255\255\255\255\
\063\001\255\255\255\255\255\255\067\001\068\001\255\255\070\001\
\255\255\255\255\073\001\074\001\255\255\255\255\255\255\255\255\
\255\255\080\001\255\255\082\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\091\001\092\001\255\255\094\001\
\095\001\096\001\097\001\255\255\255\255\255\255\255\255\255\255\
\103\001\000\001\105\001\255\255\003\001\108\001\255\255\255\255\
\111\001\008\001\009\001\010\001\115\001\255\255\013\001\014\001\
\255\255\016\001\017\001\018\001\019\001\020\001\021\001\255\255\
\255\255\024\001\025\001\026\001\255\255\028\001\029\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\037\001\255\255\
\255\255\040\001\041\001\255\255\255\255\255\255\255\255\255\255\
\255\255\048\001\049\001\255\255\255\255\255\255\255\255\255\255\
\255\255\000\000\255\255\255\255\255\255\060\001\255\255\255\255\
\063\001\255\255\255\255\255\255\067\001\068\001\255\255\070\001\
\255\255\255\255\073\001\074\001\255\255\255\255\255\255\255\255\
\255\255\080\001\255\255\082\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\091\001\092\001\255\255\094\001\
\095\001\096\001\097\001\255\255\255\255\255\255\255\255\255\255\
\103\001\000\001\105\001\255\255\003\001\108\001\255\255\255\255\
\111\001\008\001\255\255\010\001\115\001\255\255\013\001\014\001\
\255\255\016\001\017\001\018\001\019\001\020\001\021\001\255\255\
\255\255\024\001\025\001\026\001\255\255\028\001\029\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\037\001\255\255\
\255\255\040\001\041\001\255\255\255\255\255\255\255\255\255\255\
\255\255\048\001\049\001\255\255\255\255\255\255\255\255\255\255\
\255\255\000\000\255\255\255\255\255\255\060\001\255\255\255\255\
\063\001\255\255\255\255\255\255\067\001\068\001\255\255\070\001\
\255\255\255\255\073\001\074\001\255\255\255\255\255\255\255\255\
\255\255\080\001\255\255\255\255\255\255\255\255\255\255\000\000\
\255\255\255\255\255\255\255\255\091\001\092\001\255\255\094\001\
\095\001\096\001\097\001\255\255\255\255\255\255\255\255\255\255\
\103\001\000\001\105\001\255\255\003\001\108\001\255\255\255\255\
\111\001\008\001\255\255\010\001\115\001\255\255\013\001\014\001\
\255\255\016\001\017\001\018\001\019\001\020\001\021\001\255\255\
\255\255\024\001\025\001\026\001\255\255\028\001\029\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\037\001\255\255\
\255\255\040\001\041\001\255\255\255\255\255\255\255\255\255\255\
\255\255\048\001\049\001\255\255\000\000\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\060\001\255\255\255\255\
\063\001\255\255\255\255\255\255\067\001\068\001\255\255\070\001\
\255\255\255\255\073\001\074\001\255\255\255\255\255\255\255\255\
\255\255\080\001\000\000\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\091\001\092\001\255\255\094\001\
\095\001\096\001\097\001\255\255\255\255\255\255\255\255\255\255\
\103\001\000\001\105\001\255\255\003\001\108\001\255\255\255\255\
\111\001\008\001\255\255\010\001\115\001\255\255\013\001\014\001\
\255\255\016\001\017\001\018\001\019\001\020\001\021\001\255\255\
\255\255\024\001\025\001\026\001\255\255\028\001\029\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\037\001\255\255\
\255\255\040\001\041\001\255\255\255\255\255\255\255\255\000\000\
\255\255\048\001\049\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\060\001\255\255\255\255\
\063\001\255\255\255\255\255\255\067\001\068\001\255\255\070\001\
\255\255\255\255\073\001\074\001\255\255\255\255\255\255\255\255\
\255\255\080\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\091\001\092\001\255\255\094\001\
\095\001\096\001\097\001\255\255\255\255\255\255\255\255\255\255\
\103\001\000\001\105\001\255\255\003\001\108\001\255\255\255\255\
\111\001\008\001\255\255\010\001\115\001\255\255\013\001\014\001\
\255\255\016\001\017\001\018\001\019\001\020\001\021\001\255\255\
\255\255\024\001\025\001\026\001\255\255\028\001\029\001\000\001\
\255\255\255\255\255\255\255\255\255\255\255\255\037\001\255\255\
\255\255\040\001\041\001\255\255\013\001\255\255\255\255\000\000\
\023\001\048\001\049\001\255\255\255\255\255\255\255\255\255\255\
\255\255\026\001\255\255\028\001\029\001\060\001\255\255\255\255\
\063\001\255\255\255\255\255\255\067\001\068\001\255\255\070\001\
\041\001\255\255\073\001\074\001\255\255\000\000\255\255\255\255\
\055\001\080\001\057\001\058\001\059\001\255\255\061\001\255\255\
\255\255\064\001\065\001\060\001\091\001\092\001\063\001\094\001\
\095\001\096\001\097\001\068\001\000\001\255\255\255\255\003\001\
\103\001\074\001\105\001\255\255\008\001\108\001\010\001\080\001\
\111\001\013\001\014\001\090\001\115\001\017\001\255\255\019\001\
\020\001\021\001\097\001\092\001\024\001\025\001\026\001\096\001\
\028\001\029\001\000\001\255\255\255\255\003\001\109\001\110\001\
\255\255\037\001\255\255\108\001\040\001\041\001\111\001\013\001\
\255\255\255\255\000\000\255\255\048\001\049\001\255\255\255\255\
\255\255\255\255\255\255\255\255\026\001\255\255\028\001\029\001\
\060\001\255\255\255\255\063\001\255\255\255\255\255\255\067\001\
\068\001\255\255\070\001\041\001\255\255\073\001\074\001\255\255\
\000\000\053\001\255\255\055\001\080\001\057\001\058\001\059\001\
\255\255\061\001\255\255\255\255\064\001\065\001\060\001\091\001\
\092\001\255\255\094\001\095\001\096\001\097\001\068\001\000\001\
\255\255\255\255\003\001\103\001\074\001\105\001\255\255\008\001\
\108\001\010\001\080\001\111\001\013\001\014\001\090\001\115\001\
\017\001\255\255\019\001\020\001\021\001\097\001\092\001\024\001\
\025\001\026\001\096\001\028\001\029\001\255\255\255\255\255\255\
\255\255\109\001\110\001\255\255\037\001\255\255\108\001\040\001\
\041\001\111\001\255\255\255\255\255\255\000\000\255\255\048\001\
\049\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\060\001\255\255\255\255\063\001\255\255\
\255\255\255\255\067\001\068\001\255\255\070\001\255\255\255\255\
\073\001\074\001\255\255\255\255\255\255\255\255\255\255\080\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\091\001\092\001\255\255\094\001\095\001\096\001\
\097\001\255\255\255\255\255\255\255\255\255\255\103\001\000\001\
\105\001\255\255\003\001\108\001\255\255\255\255\111\001\008\001\
\255\255\010\001\115\001\255\255\013\001\014\001\255\255\255\255\
\017\001\255\255\019\001\020\001\021\001\255\255\255\255\024\001\
\025\001\026\001\255\255\028\001\029\001\000\001\255\255\255\255\
\255\255\255\255\255\255\255\255\037\001\255\255\255\255\040\001\
\041\001\255\255\013\001\255\255\255\255\000\000\255\255\048\001\
\049\001\255\255\255\255\255\255\255\255\255\255\255\255\026\001\
\255\255\028\001\029\001\060\001\255\255\255\255\063\001\255\255\
\255\255\255\255\067\001\068\001\255\255\070\001\041\001\255\255\
\073\001\074\001\255\255\000\000\255\255\255\255\055\001\080\001\
\057\001\058\001\059\001\255\255\061\001\255\255\255\255\064\001\
\065\001\060\001\091\001\092\001\255\255\094\001\095\001\096\001\
\097\001\068\001\000\001\255\255\255\255\003\001\103\001\074\001\
\105\001\255\255\008\001\108\001\010\001\080\001\111\001\013\001\
\014\001\090\001\115\001\017\001\255\255\019\001\020\001\021\001\
\097\001\092\001\024\001\025\001\026\001\096\001\028\001\029\001\
\000\001\255\255\255\255\255\255\109\001\110\001\255\255\037\001\
\255\255\108\001\040\001\041\001\111\001\013\001\255\255\255\255\
\000\000\255\255\048\001\049\001\255\255\255\255\255\255\255\255\
\255\255\255\255\026\001\255\255\028\001\029\001\060\001\255\255\
\255\255\063\001\255\255\255\255\255\255\067\001\068\001\255\255\
\070\001\041\001\255\255\073\001\074\001\255\255\000\000\255\255\
\255\255\255\255\080\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\060\001\091\001\092\001\255\255\
\094\001\095\001\096\001\097\001\068\001\000\001\255\255\255\255\
\003\001\103\001\074\001\105\001\255\255\008\001\108\001\010\001\
\080\001\111\001\013\001\014\001\255\255\115\001\017\001\255\255\
\019\001\020\001\021\001\255\255\092\001\024\001\025\001\026\001\
\096\001\028\001\029\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\037\001\255\255\108\001\040\001\041\001\111\001\
\255\255\255\255\255\255\000\000\255\255\048\001\049\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\060\001\255\255\255\255\063\001\255\255\255\255\255\255\
\067\001\068\001\255\255\070\001\255\255\255\255\073\001\074\001\
\255\255\255\255\255\255\255\255\255\255\080\001\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\091\001\092\001\255\255\094\001\095\001\096\001\097\001\255\255\
\255\255\255\255\255\255\255\255\103\001\000\001\105\001\255\255\
\003\001\108\001\255\255\255\255\111\001\008\001\255\255\010\001\
\115\001\255\255\013\001\014\001\255\255\255\255\017\001\255\255\
\019\001\020\001\021\001\255\255\255\255\024\001\025\001\026\001\
\255\255\028\001\029\001\000\001\255\255\255\255\255\255\255\255\
\255\255\255\255\037\001\255\255\255\255\040\001\041\001\255\255\
\013\001\255\255\255\255\000\000\255\255\048\001\049\001\255\255\
\255\255\255\255\255\255\255\255\255\255\026\001\255\255\028\001\
\029\001\060\001\255\255\255\255\063\001\255\255\255\255\255\255\
\067\001\068\001\255\255\070\001\041\001\255\255\073\001\074\001\
\255\255\000\000\255\255\255\255\255\255\080\001\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\060\001\
\091\001\092\001\255\255\094\001\095\001\096\001\097\001\068\001\
\000\001\255\255\255\255\003\001\103\001\074\001\105\001\255\255\
\008\001\108\001\010\001\080\001\111\001\013\001\014\001\255\255\
\115\001\017\001\255\255\019\001\020\001\021\001\255\255\092\001\
\024\001\025\001\026\001\096\001\028\001\029\001\000\001\255\255\
\255\255\255\255\255\255\255\255\255\255\037\001\255\255\108\001\
\040\001\041\001\111\001\013\001\255\255\255\255\000\000\255\255\
\048\001\049\001\255\255\255\255\255\255\255\255\255\255\255\255\
\026\001\255\255\028\001\029\001\060\001\255\255\255\255\063\001\
\255\255\255\255\255\255\067\001\068\001\255\255\070\001\041\001\
\255\255\073\001\074\001\255\255\255\255\255\255\255\255\255\255\
\080\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\060\001\091\001\092\001\255\255\094\001\095\001\
\096\001\097\001\068\001\000\001\255\255\255\255\003\001\103\001\
\074\001\105\001\255\255\008\001\108\001\010\001\080\001\111\001\
\013\001\014\001\255\255\115\001\017\001\255\255\019\001\020\001\
\021\001\255\255\092\001\024\001\025\001\026\001\096\001\028\001\
\029\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\037\001\255\255\108\001\040\001\041\001\111\001\255\255\255\255\
\255\255\000\000\255\255\048\001\049\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\060\001\
\255\255\255\255\063\001\255\255\255\255\255\255\067\001\068\001\
\255\255\070\001\255\255\255\255\073\001\074\001\255\255\255\255\
\255\255\255\255\255\255\080\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\091\001\092\001\
\255\255\094\001\095\001\096\001\097\001\255\255\255\255\255\255\
\255\255\255\255\103\001\000\001\105\001\255\255\003\001\108\001\
\255\255\255\255\111\001\008\001\255\255\010\001\115\001\255\255\
\013\001\014\001\255\255\255\255\017\001\255\255\019\001\020\001\
\021\001\255\255\255\255\024\001\025\001\026\001\255\255\028\001\
\029\001\000\001\255\255\255\255\255\255\255\255\255\255\255\255\
\037\001\255\255\255\255\040\001\041\001\255\255\013\001\255\255\
\255\255\000\000\255\255\048\001\049\001\255\255\255\255\255\255\
\255\255\255\255\255\255\026\001\255\255\028\001\029\001\060\001\
\255\255\255\255\063\001\255\255\255\255\255\255\067\001\068\001\
\255\255\070\001\041\001\255\255\073\001\074\001\255\255\255\255\
\255\255\255\255\255\255\080\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\060\001\091\001\092\001\
\255\255\094\001\095\001\096\001\097\001\068\001\000\001\255\255\
\255\255\003\001\103\001\074\001\105\001\255\255\008\001\108\001\
\010\001\080\001\111\001\013\001\014\001\255\255\115\001\017\001\
\255\255\019\001\020\001\021\001\255\255\092\001\024\001\025\001\
\026\001\096\001\028\001\029\001\006\001\255\255\008\001\255\255\
\255\255\255\255\255\255\037\001\255\255\108\001\040\001\041\001\
\111\001\255\255\255\255\255\255\000\000\255\255\048\001\049\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\060\001\255\255\255\255\063\001\255\255\255\255\
\255\255\067\001\068\001\255\255\070\001\255\255\255\255\073\001\
\074\001\255\255\255\255\255\255\255\255\055\001\080\001\057\001\
\058\001\059\001\255\255\061\001\255\255\255\255\064\001\065\001\
\255\255\091\001\092\001\255\255\094\001\095\001\096\001\097\001\
\255\255\000\001\255\255\255\255\003\001\103\001\255\255\105\001\
\255\255\008\001\108\001\010\001\255\255\111\001\013\001\014\001\
\090\001\115\001\017\001\255\255\019\001\020\001\021\001\097\001\
\255\255\024\001\025\001\026\001\255\255\028\001\029\001\255\255\
\255\255\255\255\255\255\109\001\110\001\255\255\037\001\255\255\
\255\255\040\001\041\001\255\255\255\255\255\255\255\255\000\000\
\255\255\048\001\049\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\060\001\255\255\255\255\
\063\001\255\255\255\255\255\255\067\001\068\001\255\255\070\001\
\255\255\255\255\073\001\074\001\255\255\255\255\255\255\255\255\
\255\255\080\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\091\001\092\001\255\255\094\001\
\095\001\096\001\097\001\255\255\255\255\255\255\255\255\255\255\
\103\001\000\001\105\001\255\255\003\001\108\001\255\255\255\255\
\111\001\008\001\255\255\010\001\115\001\255\255\013\001\014\001\
\255\255\255\255\017\001\255\255\019\001\020\001\021\001\255\255\
\255\255\024\001\025\001\026\001\255\255\028\001\029\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\037\001\255\255\
\255\255\040\001\041\001\255\255\255\255\255\255\255\255\000\000\
\255\255\048\001\049\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\060\001\255\255\255\255\
\063\001\255\255\255\255\255\255\067\001\068\001\255\255\070\001\
\255\255\255\255\073\001\074\001\255\255\255\255\255\255\255\255\
\255\255\080\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\091\001\092\001\255\255\094\001\
\095\001\096\001\097\001\255\255\000\001\255\255\255\255\003\001\
\103\001\255\255\105\001\255\255\008\001\108\001\010\001\255\255\
\111\001\013\001\014\001\255\255\115\001\017\001\255\255\019\001\
\020\001\021\001\255\255\255\255\024\001\025\001\026\001\255\255\
\028\001\029\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\037\001\255\255\255\255\040\001\041\001\255\255\255\255\
\255\255\255\255\255\255\255\255\048\001\049\001\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\000\000\255\255\255\255\
\060\001\255\255\255\255\063\001\255\255\255\255\255\255\067\001\
\068\001\255\255\070\001\255\255\255\255\073\001\074\001\255\255\
\255\255\255\255\255\255\255\255\080\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\091\001\
\092\001\255\255\094\001\095\001\096\001\097\001\255\255\000\001\
\255\255\255\255\003\001\103\001\255\255\105\001\255\255\008\001\
\108\001\010\001\255\255\111\001\013\001\014\001\255\255\115\001\
\017\001\255\255\019\001\020\001\021\001\255\255\255\255\024\001\
\025\001\026\001\255\255\028\001\029\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\037\001\255\255\255\255\040\001\
\041\001\255\255\255\255\255\255\255\255\255\255\255\255\048\001\
\049\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\000\000\255\255\255\255\060\001\255\255\255\255\063\001\255\255\
\255\255\255\255\067\001\068\001\255\255\070\001\255\255\255\255\
\073\001\074\001\255\255\255\255\255\255\255\255\255\255\080\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\091\001\092\001\255\255\094\001\255\255\096\001\
\097\001\255\255\255\255\255\255\255\255\255\255\103\001\000\001\
\105\001\255\255\003\001\108\001\255\255\255\255\111\001\008\001\
\255\255\010\001\115\001\255\255\013\001\014\001\255\255\255\255\
\017\001\255\255\019\001\020\001\021\001\255\255\255\255\024\001\
\255\255\026\001\255\255\028\001\029\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\037\001\255\255\255\255\040\001\
\041\001\255\255\255\255\255\255\255\255\255\255\255\255\048\001\
\049\001\255\255\255\255\000\000\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\060\001\255\255\255\255\063\001\255\255\
\255\255\255\255\067\001\068\001\255\255\070\001\255\255\255\255\
\073\001\074\001\255\255\255\255\255\255\255\255\255\255\080\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\091\001\092\001\255\255\094\001\095\001\096\001\
\097\001\255\255\255\255\255\255\255\255\255\255\103\001\255\255\
\105\001\255\255\255\255\108\001\255\255\000\001\111\001\002\001\
\003\001\004\001\115\001\255\255\255\255\008\001\255\255\255\255\
\255\255\255\255\013\001\255\255\255\255\255\255\017\001\018\001\
\019\001\255\255\255\255\255\255\255\255\000\001\255\255\026\001\
\027\001\028\001\029\001\255\255\255\255\255\255\255\255\255\255\
\255\255\036\001\255\255\255\255\255\255\040\001\041\001\255\255\
\000\000\255\255\255\255\255\255\255\255\048\001\049\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\060\001\255\255\255\255\063\001\255\255\255\255\066\001\
\067\001\068\001\255\255\070\001\255\255\255\255\073\001\074\001\
\255\255\255\255\255\255\255\255\055\001\080\001\057\001\058\001\
\059\001\255\255\061\001\255\255\255\255\064\001\065\001\255\255\
\091\001\092\001\255\255\094\001\095\001\096\001\255\255\255\255\
\000\001\100\001\002\001\003\001\004\001\255\255\081\001\255\255\
\008\001\108\001\255\255\255\255\111\001\013\001\089\001\090\001\
\115\001\017\001\018\001\019\001\255\255\255\255\097\001\255\255\
\255\255\255\255\026\001\027\001\028\001\029\001\255\255\255\255\
\008\001\255\255\109\001\110\001\036\001\255\255\255\255\255\255\
\255\255\041\001\255\255\000\000\255\255\255\255\255\255\023\001\
\048\001\049\001\255\255\255\255\255\255\255\255\030\001\255\255\
\255\255\255\255\255\255\255\255\060\001\255\255\255\255\063\001\
\255\255\255\255\066\001\067\001\068\001\255\255\070\001\255\255\
\255\255\073\001\074\001\255\255\255\255\255\255\255\255\055\001\
\080\001\057\001\058\001\059\001\255\255\061\001\255\255\255\255\
\064\001\065\001\255\255\091\001\092\001\255\255\094\001\095\001\
\096\001\097\001\255\255\000\001\255\255\002\001\003\001\004\001\
\255\255\081\001\255\255\008\001\108\001\255\255\255\255\111\001\
\013\001\089\001\090\001\115\001\017\001\018\001\019\001\255\255\
\255\255\097\001\255\255\255\255\255\255\026\001\027\001\028\001\
\029\001\255\255\106\001\255\255\255\255\109\001\110\001\036\001\
\255\255\255\255\255\255\255\255\041\001\255\255\000\000\255\255\
\255\255\255\255\255\255\048\001\049\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\060\001\
\255\255\255\255\063\001\255\255\255\255\066\001\067\001\068\001\
\255\255\070\001\255\255\255\255\255\255\074\001\255\255\255\255\
\255\255\255\255\255\255\080\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\091\001\092\001\
\255\255\094\001\095\001\096\001\097\001\255\255\255\255\255\255\
\000\001\255\255\002\001\003\001\004\001\255\255\255\255\108\001\
\008\001\255\255\111\001\255\255\255\255\013\001\115\001\255\255\
\255\255\017\001\018\001\019\001\255\255\255\255\255\255\255\255\
\255\255\255\255\026\001\027\001\028\001\029\001\255\255\255\255\
\255\255\255\255\255\255\255\255\036\001\255\255\255\255\255\255\
\255\255\041\001\255\255\000\000\255\255\255\255\255\255\255\255\
\048\001\049\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\060\001\255\255\255\255\063\001\
\255\255\255\255\066\001\067\001\068\001\255\255\070\001\255\255\
\255\255\255\255\074\001\255\255\255\255\255\255\255\255\055\001\
\080\001\057\001\058\001\059\001\255\255\061\001\255\255\255\255\
\064\001\065\001\255\255\091\001\092\001\255\255\094\001\095\001\
\096\001\097\001\074\001\000\001\255\255\002\001\003\001\004\001\
\255\255\081\001\255\255\008\001\108\001\255\255\255\255\111\001\
\013\001\089\001\090\001\115\001\017\001\018\001\019\001\000\000\
\255\255\097\001\255\255\255\255\255\255\026\001\027\001\028\001\
\029\001\255\255\255\255\255\255\255\255\109\001\110\001\036\001\
\255\255\255\255\255\255\255\255\041\001\255\255\255\255\255\255\
\255\255\255\255\255\255\048\001\049\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\060\001\
\255\255\255\255\063\001\255\255\255\255\066\001\067\001\068\001\
\255\255\070\001\255\255\255\255\255\255\074\001\255\255\255\255\
\255\255\000\000\055\001\080\001\057\001\058\001\059\001\255\255\
\061\001\255\255\255\255\064\001\065\001\255\255\091\001\092\001\
\255\255\094\001\095\001\096\001\097\001\255\255\000\001\255\255\
\002\001\003\001\004\001\255\255\081\001\255\255\008\001\108\001\
\255\255\255\255\111\001\013\001\089\001\090\001\115\001\017\001\
\018\001\019\001\255\255\255\255\097\001\255\255\255\255\255\255\
\026\001\027\001\028\001\029\001\255\255\255\255\255\255\108\001\
\109\001\110\001\036\001\000\000\255\255\255\255\255\255\041\001\
\255\255\255\255\255\255\255\255\255\255\255\255\048\001\049\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\060\001\255\255\255\255\063\001\255\255\255\255\
\066\001\067\001\068\001\255\255\070\001\255\255\255\255\255\255\
\074\001\255\255\255\255\255\255\255\255\255\255\080\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\091\001\092\001\255\255\094\001\095\001\096\001\097\001\
\255\255\000\000\255\255\000\001\255\255\002\001\003\001\255\255\
\255\255\255\255\108\001\008\001\255\255\111\001\255\255\255\255\
\013\001\115\001\255\255\255\255\017\001\018\001\019\001\255\255\
\255\255\255\255\255\255\255\255\255\255\026\001\027\001\028\001\
\029\001\255\255\255\255\255\255\255\255\255\255\255\255\036\001\
\255\255\255\255\255\255\255\255\041\001\255\255\255\255\255\255\
\255\255\255\255\255\255\048\001\049\001\255\255\255\255\255\255\
\255\255\255\255\255\255\000\000\255\255\255\255\255\255\060\001\
\255\255\255\255\063\001\255\255\255\255\066\001\067\001\068\001\
\255\255\070\001\255\255\255\255\006\001\074\001\008\001\000\001\
\255\255\255\255\003\001\080\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\013\001\255\255\091\001\092\001\
\017\001\094\001\095\001\096\001\097\001\255\255\255\255\255\255\
\255\255\026\001\027\001\028\001\029\001\255\255\255\255\108\001\
\255\255\255\255\111\001\255\255\255\255\255\255\115\001\255\255\
\041\001\255\255\255\255\255\255\255\255\055\001\255\255\057\001\
\058\001\059\001\255\255\061\001\255\255\255\255\064\001\065\001\
\255\255\000\001\255\255\060\001\003\001\255\255\063\001\255\255\
\255\255\066\001\067\001\068\001\255\255\255\255\013\001\255\255\
\073\001\074\001\017\001\255\255\255\255\255\255\255\255\080\001\
\090\001\255\255\092\001\026\001\027\001\028\001\029\001\097\001\
\255\255\255\255\255\255\092\001\000\000\094\001\255\255\096\001\
\097\001\255\255\041\001\109\001\110\001\255\255\255\255\255\255\
\255\255\255\255\255\255\108\001\255\255\255\255\111\001\255\255\
\255\255\255\255\115\001\000\001\255\255\060\001\003\001\255\255\
\063\001\255\255\255\255\066\001\067\001\068\001\255\255\255\255\
\013\001\255\255\073\001\074\001\017\001\255\255\255\255\255\255\
\255\255\080\001\255\255\255\255\255\255\026\001\027\001\028\001\
\029\001\255\255\255\255\255\255\255\255\092\001\255\255\094\001\
\255\255\096\001\097\001\255\255\041\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\108\001\255\255\255\255\
\111\001\255\255\255\255\255\255\115\001\255\255\255\255\060\001\
\255\255\000\001\063\001\255\255\003\001\066\001\067\001\068\001\
\255\255\255\255\255\255\255\255\073\001\074\001\013\001\255\255\
\255\255\255\255\017\001\080\001\019\001\255\255\255\255\255\255\
\255\255\255\255\000\000\026\001\027\001\028\001\029\001\092\001\
\255\255\094\001\255\255\096\001\097\001\255\255\255\255\255\255\
\255\255\255\255\041\001\255\255\255\255\255\255\255\255\108\001\
\255\255\255\255\111\001\255\255\255\255\255\255\115\001\255\255\
\255\255\255\255\255\255\000\001\255\255\060\001\003\001\255\255\
\063\001\255\255\255\255\255\255\067\001\068\001\255\255\255\255\
\013\001\255\255\073\001\074\001\017\001\255\255\255\255\255\255\
\255\255\080\001\255\255\255\255\255\255\026\001\027\001\028\001\
\029\001\255\255\255\255\255\255\255\255\092\001\255\255\094\001\
\255\255\096\001\097\001\255\255\041\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\108\001\255\255\255\255\
\111\001\000\000\255\255\255\255\115\001\255\255\255\255\060\001\
\255\255\255\255\063\001\255\255\255\255\255\255\067\001\068\001\
\255\255\255\255\255\255\255\255\073\001\074\001\055\001\255\255\
\057\001\058\001\059\001\080\001\061\001\255\255\063\001\064\001\
\065\001\255\255\255\255\255\255\255\255\255\255\255\255\092\001\
\255\255\094\001\255\255\096\001\097\001\078\001\255\255\255\255\
\081\001\255\255\255\255\255\255\255\255\255\255\255\255\108\001\
\089\001\090\001\111\001\255\255\000\001\255\255\115\001\003\001\
\097\001\005\001\006\001\007\001\008\001\255\255\255\255\011\001\
\012\001\013\001\255\255\255\255\109\001\110\001\255\255\019\001\
\255\255\255\255\255\255\023\001\255\255\255\255\026\001\255\255\
\028\001\029\001\030\001\031\001\032\001\033\001\034\001\035\001\
\036\001\255\255\255\255\039\001\040\001\041\001\255\255\255\255\
\255\255\255\255\255\255\255\255\048\001\049\001\050\001\051\001\
\052\001\053\001\054\001\055\001\056\001\057\001\058\001\059\001\
\060\001\061\001\000\000\063\001\064\001\065\001\255\255\067\001\
\068\001\069\001\070\001\071\001\072\001\255\255\074\001\075\001\
\076\001\077\001\078\001\255\255\080\001\081\001\255\255\255\255\
\084\001\085\001\255\255\087\001\088\001\089\001\090\001\091\001\
\092\001\093\001\255\255\095\001\096\001\097\001\255\255\099\001\
\255\255\101\001\102\001\255\255\104\001\255\255\106\001\107\001\
\108\001\109\001\110\001\111\001\112\001\255\255\114\001\005\001\
\006\001\007\001\255\255\255\255\255\255\011\001\012\001\013\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\028\001\029\001\
\030\001\031\001\032\001\033\001\034\001\255\255\255\255\255\255\
\255\255\039\001\255\255\041\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\050\001\255\255\052\001\053\001\
\054\001\055\001\056\001\255\255\255\255\059\001\060\001\255\255\
\255\255\063\001\064\001\065\001\255\255\000\000\068\001\069\001\
\255\255\071\001\072\001\255\255\074\001\255\255\076\001\255\255\
\078\001\255\255\080\001\255\255\255\255\255\255\084\001\085\001\
\255\255\087\001\255\255\255\255\255\255\255\255\005\001\006\001\
\007\001\255\255\096\001\097\001\011\001\012\001\013\001\101\001\
\255\255\255\255\255\255\255\255\106\001\107\001\108\001\109\001\
\110\001\111\001\255\255\255\255\114\001\028\001\029\001\030\001\
\031\001\032\001\033\001\034\001\255\255\255\255\255\255\255\255\
\039\001\255\255\041\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\050\001\255\255\052\001\053\001\054\001\
\055\001\056\001\255\255\255\255\059\001\060\001\255\255\255\255\
\063\001\064\001\065\001\255\255\255\255\068\001\069\001\255\255\
\071\001\072\001\255\255\074\001\255\255\076\001\255\255\078\001\
\255\255\080\001\255\255\000\000\255\255\084\001\085\001\255\255\
\087\001\000\000\055\001\255\255\057\001\058\001\059\001\255\255\
\061\001\255\255\097\001\064\001\065\001\255\255\101\001\255\255\
\255\255\255\255\255\255\106\001\107\001\108\001\109\001\110\001\
\111\001\255\255\255\255\114\001\081\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\089\001\090\001\255\255\005\001\
\006\001\007\001\255\255\255\255\097\001\011\001\012\001\013\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\109\001\110\001\255\255\255\255\255\255\255\255\028\001\029\001\
\030\001\031\001\032\001\033\001\034\001\255\255\255\255\255\255\
\255\255\039\001\255\255\041\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\050\001\255\255\052\001\053\001\
\054\001\055\001\056\001\255\255\255\255\059\001\060\001\255\255\
\255\255\063\001\064\001\065\001\255\255\255\255\068\001\069\001\
\255\255\071\001\072\001\255\255\074\001\000\000\076\001\255\255\
\078\001\255\255\080\001\255\255\255\255\255\255\084\001\085\001\
\255\255\087\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\097\001\255\255\255\255\255\255\101\001\
\255\255\255\255\255\255\255\255\106\001\107\001\108\001\109\001\
\110\001\111\001\255\255\255\255\114\001\000\001\255\255\255\255\
\255\255\004\001\255\255\006\001\255\255\008\001\255\255\010\001\
\255\255\012\001\255\255\014\001\015\001\255\255\017\001\018\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\027\001\028\001\255\255\030\001\031\001\000\000\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\050\001\
\051\001\052\001\053\001\255\255\055\001\056\001\255\255\255\255\
\059\001\255\255\255\255\255\255\255\255\064\001\065\001\066\001\
\255\255\255\255\255\255\255\255\071\001\255\255\073\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\081\001\255\255\
\255\255\084\001\255\255\255\255\255\255\255\255\089\001\000\000\
\091\001\092\001\255\255\094\001\095\001\255\255\097\001\255\255\
\255\255\255\255\101\001\000\001\255\255\104\001\255\255\106\001\
\255\255\000\001\109\001\110\001\255\255\004\001\113\001\006\001\
\013\001\008\001\255\255\010\001\255\255\012\001\255\255\014\001\
\015\001\255\255\017\001\018\001\255\255\026\001\255\255\028\001\
\029\001\255\255\255\255\255\255\027\001\255\255\255\255\030\001\
\031\001\255\255\255\255\255\255\041\001\255\255\255\255\255\255\
\255\255\000\000\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\050\001\051\001\255\255\053\001\060\001\
\055\001\056\001\255\255\255\255\059\001\255\255\067\001\068\001\
\255\255\064\001\065\001\066\001\255\255\074\001\255\255\255\255\
\071\001\255\255\073\001\080\001\255\255\255\255\255\255\255\255\
\255\255\255\255\081\001\255\255\255\255\084\001\255\255\092\001\
\255\255\255\255\089\001\096\001\091\001\092\001\255\255\094\001\
\095\001\255\255\097\001\000\000\255\255\255\255\101\001\108\001\
\255\255\104\001\111\001\106\001\255\255\000\001\109\001\110\001\
\003\001\004\001\113\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\013\001\014\001\255\255\255\255\255\255\255\255\
\019\001\255\255\255\255\255\255\255\255\255\255\255\255\026\001\
\255\255\028\001\029\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\041\001\255\255\
\255\255\255\255\255\255\255\255\255\255\048\001\049\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\060\001\255\255\255\255\063\001\255\255\255\255\066\001\
\067\001\068\001\255\255\070\001\255\255\000\001\255\255\074\001\
\003\001\004\001\000\000\255\255\255\255\080\001\255\255\255\255\
\255\255\255\255\013\001\014\001\255\255\255\255\255\255\255\255\
\019\001\092\001\255\255\094\001\255\255\096\001\097\001\026\001\
\255\255\028\001\029\001\255\255\255\255\255\255\255\255\255\255\
\255\255\108\001\255\255\255\255\111\001\255\255\041\001\255\255\
\255\255\255\255\255\255\255\255\255\255\048\001\049\001\255\255\
\255\255\255\255\255\255\000\000\255\255\255\255\255\255\000\001\
\255\255\060\001\003\001\004\001\063\001\255\255\255\255\066\001\
\067\001\068\001\255\255\070\001\013\001\014\001\255\255\074\001\
\255\255\255\255\019\001\255\255\255\255\080\001\255\255\255\255\
\255\255\026\001\255\255\028\001\029\001\255\255\255\255\255\255\
\255\255\092\001\255\255\094\001\255\255\096\001\097\001\255\255\
\041\001\255\255\255\255\255\255\255\255\000\000\255\255\048\001\
\049\001\108\001\255\255\255\255\111\001\255\255\255\255\255\255\
\255\255\000\001\255\255\060\001\003\001\004\001\063\001\255\255\
\255\255\255\255\067\001\068\001\255\255\070\001\013\001\014\001\
\255\255\074\001\255\255\255\255\019\001\255\255\255\255\080\001\
\255\255\255\255\255\255\026\001\255\255\028\001\029\001\255\255\
\255\255\255\255\255\255\092\001\255\255\094\001\255\255\096\001\
\097\001\255\255\041\001\255\255\255\255\255\255\255\255\255\255\
\255\255\048\001\049\001\108\001\255\255\255\255\111\001\255\255\
\255\255\255\255\255\255\000\001\255\255\060\001\003\001\004\001\
\063\001\000\000\255\255\255\255\067\001\068\001\255\255\070\001\
\013\001\014\001\255\255\074\001\255\255\255\255\019\001\255\255\
\255\255\080\001\255\255\255\255\255\255\026\001\255\255\028\001\
\029\001\255\255\255\255\255\255\255\255\092\001\255\255\094\001\
\255\255\096\001\097\001\255\255\041\001\255\255\255\255\255\255\
\255\255\255\255\255\255\048\001\049\001\108\001\255\255\255\255\
\111\001\255\255\255\255\255\255\255\255\255\255\255\255\060\001\
\255\255\255\255\063\001\000\000\255\255\255\255\067\001\068\001\
\255\255\070\001\255\255\255\255\255\255\074\001\055\001\255\255\
\057\001\058\001\059\001\080\001\061\001\255\255\255\255\064\001\
\065\001\255\255\000\001\255\255\255\255\003\001\255\255\092\001\
\255\255\094\001\008\001\096\001\097\001\255\255\255\255\013\001\
\081\001\255\255\255\255\255\255\255\255\019\001\255\255\108\001\
\089\001\090\001\111\001\255\255\026\001\255\255\028\001\029\001\
\097\001\255\255\255\255\255\255\255\255\000\000\255\255\255\255\
\255\255\255\255\040\001\041\001\109\001\110\001\255\255\255\255\
\255\255\255\255\255\255\000\001\255\255\255\255\003\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\060\001\255\255\
\013\001\063\001\255\255\255\255\066\001\067\001\068\001\255\255\
\255\255\255\255\255\255\073\001\074\001\026\001\027\001\028\001\
\029\001\255\255\080\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\041\001\255\255\092\001\000\000\
\255\255\255\255\096\001\097\001\255\255\000\001\100\001\255\255\
\003\001\255\255\255\255\255\255\255\255\255\255\108\001\060\001\
\255\255\111\001\013\001\064\001\255\255\066\001\067\001\068\001\
\255\255\255\255\255\255\255\255\073\001\074\001\255\255\026\001\
\027\001\028\001\029\001\080\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\041\001\092\001\
\255\255\094\001\255\255\096\001\097\001\255\255\255\255\100\001\
\255\255\000\000\255\255\255\255\255\255\255\255\255\255\108\001\
\109\001\060\001\111\001\255\255\255\255\064\001\255\255\066\001\
\067\001\068\001\255\255\255\255\255\255\255\255\073\001\074\001\
\255\255\000\001\255\255\255\255\003\001\080\001\255\255\255\255\
\255\255\008\001\255\255\255\255\255\255\255\255\013\001\255\255\
\255\255\092\001\255\255\094\001\019\001\096\001\097\001\255\255\
\255\255\100\001\000\000\026\001\255\255\028\001\029\001\255\255\
\255\255\108\001\109\001\255\255\111\001\255\255\255\255\255\255\
\255\255\040\001\041\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\000\001\255\255\060\001\003\001\255\255\
\063\001\255\255\255\255\066\001\067\001\068\001\255\255\255\255\
\013\001\255\255\073\001\074\001\255\255\255\255\019\001\000\000\
\255\255\080\001\255\255\255\255\255\255\026\001\027\001\028\001\
\029\001\255\255\255\255\255\255\255\255\092\001\255\255\255\255\
\255\255\096\001\097\001\255\255\041\001\255\255\255\255\255\255\
\255\255\255\255\255\255\048\001\255\255\108\001\255\255\255\255\
\111\001\255\255\255\255\255\255\255\255\000\001\255\255\060\001\
\003\001\255\255\063\001\255\255\255\255\255\255\067\001\068\001\
\255\255\070\001\013\001\255\255\000\000\074\001\255\255\255\255\
\019\001\255\255\255\255\080\001\255\255\255\255\255\255\026\001\
\255\255\028\001\029\001\255\255\255\255\255\255\255\255\092\001\
\255\255\094\001\255\255\096\001\097\001\040\001\041\001\255\255\
\255\255\255\255\255\255\255\255\255\255\048\001\049\001\108\001\
\255\255\255\255\111\001\255\255\255\255\255\255\255\255\000\001\
\255\255\060\001\003\001\255\255\063\001\255\255\255\255\008\001\
\255\255\068\001\255\255\070\001\013\001\255\255\255\255\074\001\
\255\255\255\255\019\001\255\255\255\255\080\001\255\255\255\255\
\255\255\026\001\255\255\028\001\029\001\255\255\255\255\000\000\
\255\255\092\001\255\255\255\255\255\255\096\001\097\001\255\255\
\041\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\108\001\255\255\255\255\111\001\255\255\255\255\255\255\
\255\255\000\001\255\255\060\001\003\001\255\255\063\001\255\255\
\255\255\255\255\067\001\068\001\255\255\255\255\013\001\255\255\
\255\255\074\001\255\255\255\255\019\001\255\255\255\255\080\001\
\255\255\255\255\255\255\026\001\000\000\028\001\029\001\255\255\
\255\255\255\255\255\255\092\001\255\255\000\000\255\255\096\001\
\097\001\255\255\041\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\000\001\108\001\255\255\003\001\111\001\255\255\
\255\255\255\255\255\255\255\255\255\255\060\001\255\255\013\001\
\063\001\255\255\255\255\255\255\067\001\068\001\255\255\255\255\
\255\255\255\255\255\255\074\001\026\001\255\255\028\001\029\001\
\255\255\080\001\255\255\255\255\255\255\255\255\255\255\000\000\
\255\255\255\255\040\001\041\001\255\255\092\001\255\255\255\255\
\255\255\096\001\097\001\255\255\255\255\255\255\255\255\000\001\
\255\255\255\255\003\001\255\255\255\255\108\001\060\001\255\255\
\111\001\063\001\255\255\255\255\013\001\067\001\068\001\255\255\
\255\255\255\255\019\001\255\255\074\001\255\255\255\255\255\255\
\255\255\026\001\080\001\028\001\029\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\000\000\255\255\092\001\255\255\
\041\001\255\255\096\001\097\001\255\255\000\000\255\255\255\255\
\255\255\255\255\255\255\255\255\000\001\255\255\108\001\003\001\
\255\255\111\001\255\255\060\001\255\255\255\255\063\001\255\255\
\255\255\013\001\067\001\068\001\255\255\255\255\255\255\019\001\
\255\255\074\001\255\255\255\255\255\255\255\255\026\001\080\001\
\028\001\029\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\092\001\255\255\041\001\255\255\096\001\
\097\001\255\255\000\000\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\108\001\255\255\255\255\111\001\255\255\
\060\001\255\255\255\255\063\001\255\255\255\255\255\255\067\001\
\068\001\255\255\255\255\255\255\255\255\255\255\074\001\000\001\
\255\255\255\255\003\001\255\255\080\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\013\001\255\255\255\255\255\255\
\092\001\255\255\019\001\255\255\096\001\097\001\255\255\000\000\
\255\255\026\001\255\255\028\001\029\001\255\255\255\255\255\255\
\108\001\255\255\255\255\111\001\255\255\255\255\255\255\255\255\
\041\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\000\001\255\255\255\255\003\001\
\255\255\255\255\255\255\060\001\255\255\000\001\063\001\255\255\
\255\255\013\001\067\001\068\001\255\255\008\001\255\255\019\001\
\000\000\074\001\013\001\255\255\255\255\255\255\026\001\080\001\
\028\001\029\001\000\000\255\255\255\255\255\255\255\255\026\001\
\255\255\028\001\029\001\092\001\255\255\041\001\255\255\096\001\
\097\001\255\255\255\255\255\255\255\255\255\255\041\001\255\255\
\255\255\255\255\255\255\108\001\255\255\255\255\111\001\000\001\
\060\001\255\255\003\001\063\001\255\255\255\255\255\255\067\001\
\068\001\060\001\255\255\255\255\013\001\255\255\074\001\066\001\
\067\001\068\001\019\001\255\255\080\001\255\255\255\255\074\001\
\255\255\026\001\255\255\028\001\029\001\080\001\255\255\255\255\
\092\001\255\255\255\255\000\000\096\001\097\001\255\255\255\255\
\041\001\092\001\255\255\255\255\255\255\096\001\255\255\255\255\
\108\001\255\255\255\255\111\001\000\001\255\255\255\255\255\255\
\255\255\108\001\255\255\060\001\111\001\000\001\063\001\255\255\
\003\001\013\001\067\001\068\001\255\255\255\255\255\255\255\255\
\255\255\074\001\013\001\255\255\255\255\255\255\026\001\080\001\
\028\001\029\001\255\255\255\255\000\000\255\255\255\255\026\001\
\255\255\028\001\029\001\092\001\255\255\041\001\000\000\096\001\
\097\001\255\255\255\255\255\255\255\255\040\001\041\001\255\255\
\255\255\255\255\255\255\108\001\255\255\255\255\111\001\255\255\
\060\001\255\255\000\001\063\001\255\255\003\001\066\001\067\001\
\068\001\060\001\255\255\255\255\063\001\255\255\074\001\013\001\
\255\255\068\001\255\255\255\255\080\001\255\255\255\255\074\001\
\255\255\255\255\255\255\255\255\026\001\080\001\028\001\029\001\
\092\001\255\255\255\255\255\255\096\001\097\001\255\255\255\255\
\255\255\092\001\255\255\041\001\000\000\096\001\097\001\255\255\
\108\001\255\255\255\255\111\001\255\255\255\255\255\255\000\001\
\255\255\108\001\003\001\255\255\111\001\255\255\060\001\255\255\
\255\255\063\001\255\255\255\255\013\001\067\001\068\001\255\255\
\255\255\255\255\255\255\255\255\074\001\255\255\255\255\255\255\
\255\255\026\001\080\001\028\001\029\001\255\255\255\255\255\255\
\000\000\255\255\255\255\255\255\255\255\255\255\092\001\255\255\
\041\001\000\000\096\001\097\001\255\255\255\255\255\255\255\255\
\000\001\255\255\255\255\255\255\255\255\255\255\108\001\255\255\
\008\001\111\001\000\001\060\001\255\255\013\001\063\001\255\255\
\255\255\255\255\067\001\068\001\255\255\255\255\255\255\013\001\
\255\255\074\001\026\001\255\255\028\001\029\001\255\255\080\001\
\255\255\255\255\255\255\255\255\026\001\255\255\028\001\029\001\
\255\255\041\001\000\000\092\001\255\255\255\255\255\255\096\001\
\097\001\255\255\255\255\041\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\108\001\060\001\255\255\111\001\063\001\
\255\255\255\255\255\255\067\001\068\001\255\255\060\001\255\255\
\255\255\063\001\074\001\000\001\255\255\067\001\068\001\255\255\
\080\001\255\255\255\255\255\255\074\001\255\255\000\000\255\255\
\013\001\255\255\080\001\255\255\092\001\255\255\255\255\255\255\
\096\001\097\001\255\255\255\255\255\255\026\001\092\001\028\001\
\029\001\255\255\096\001\097\001\108\001\255\255\255\255\111\001\
\255\255\255\255\255\255\255\255\041\001\255\255\108\001\255\255\
\255\255\111\001\255\255\255\255\000\001\255\255\255\255\003\001\
\255\255\255\255\255\255\255\255\255\255\255\255\000\001\060\001\
\255\255\013\001\063\001\255\255\255\255\255\255\067\001\068\001\
\255\255\255\255\255\255\013\001\255\255\074\001\026\001\255\255\
\028\001\029\001\255\255\080\001\255\255\255\255\255\255\255\255\
\026\001\255\255\028\001\029\001\255\255\041\001\255\255\092\001\
\255\255\255\255\255\255\096\001\097\001\255\255\255\255\041\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\108\001\
\060\001\255\255\111\001\063\001\255\255\255\255\255\255\255\255\
\068\001\255\255\060\001\255\255\000\001\063\001\074\001\255\255\
\255\255\067\001\068\001\255\255\080\001\255\255\255\255\255\255\
\074\001\013\001\255\255\255\255\255\255\255\255\080\001\255\255\
\092\001\255\255\255\255\255\255\096\001\097\001\026\001\255\255\
\028\001\029\001\092\001\255\255\255\255\255\255\096\001\097\001\
\108\001\255\255\255\255\111\001\255\255\041\001\255\255\255\255\
\000\001\255\255\108\001\255\255\255\255\111\001\255\255\255\255\
\255\255\000\001\255\255\255\255\255\255\013\001\255\255\255\255\
\060\001\255\255\255\255\063\001\255\255\255\255\013\001\067\001\
\068\001\255\255\026\001\255\255\028\001\029\001\074\001\255\255\
\255\255\255\255\255\255\026\001\080\001\028\001\029\001\255\255\
\255\255\041\001\255\255\255\255\255\255\255\255\255\255\255\255\
\092\001\255\255\041\001\255\255\096\001\097\001\255\255\255\255\
\255\255\255\255\000\001\255\255\060\001\255\255\255\255\063\001\
\108\001\255\255\255\255\111\001\068\001\060\001\255\255\013\001\
\063\001\255\255\074\001\255\255\255\255\068\001\255\255\255\255\
\080\001\255\255\255\255\074\001\026\001\255\255\028\001\029\001\
\255\255\080\001\255\255\255\255\092\001\255\255\255\255\255\255\
\096\001\097\001\255\255\041\001\255\255\092\001\000\001\255\255\
\255\255\096\001\097\001\255\255\108\001\255\255\255\255\111\001\
\255\255\255\255\255\255\013\001\255\255\108\001\060\001\255\255\
\111\001\063\001\255\255\255\255\255\255\255\255\068\001\255\255\
\026\001\255\255\028\001\029\001\074\001\255\255\255\255\255\255\
\255\255\255\255\080\001\255\255\255\255\255\255\255\255\041\001\
\255\255\255\255\255\255\255\255\255\255\255\255\092\001\255\255\
\255\255\255\255\096\001\097\001\255\255\255\255\255\255\255\255\
\255\255\255\255\060\001\255\255\255\255\063\001\108\001\255\255\
\255\255\111\001\068\001\255\255\255\255\255\255\255\255\255\255\
\074\001\255\255\255\255\255\255\255\255\255\255\080\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\092\001\000\001\255\255\255\255\096\001\097\001\
\005\001\006\001\007\001\008\001\255\255\255\255\011\001\012\001\
\013\001\014\001\108\001\255\255\255\255\111\001\019\001\255\255\
\255\255\255\255\255\255\255\255\255\255\026\001\255\255\028\001\
\029\001\030\001\031\001\032\001\033\001\034\001\035\001\255\255\
\255\255\255\255\039\001\255\255\041\001\255\255\255\255\255\255\
\255\255\255\255\255\255\048\001\049\001\050\001\051\001\052\001\
\053\001\054\001\055\001\056\001\255\255\255\255\059\001\060\001\
\255\255\255\255\063\001\064\001\065\001\066\001\255\255\068\001\
\069\001\070\001\071\001\072\001\255\255\074\001\255\255\076\001\
\077\001\078\001\255\255\080\001\081\001\255\255\255\255\084\001\
\085\001\255\255\087\001\255\255\089\001\090\001\255\255\092\001\
\093\001\255\255\255\255\096\001\097\001\255\255\099\001\255\255\
\101\001\102\001\255\255\104\001\255\255\106\001\107\001\108\001\
\109\001\110\001\111\001\112\001\000\001\114\001\255\255\255\255\
\255\255\005\001\006\001\007\001\008\001\255\255\255\255\011\001\
\012\001\255\255\255\255\255\255\255\255\255\255\255\255\019\001\
\255\255\255\255\255\255\255\255\255\255\255\255\026\001\255\255\
\028\001\255\255\030\001\031\001\032\001\033\001\034\001\035\001\
\255\255\255\255\255\255\039\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\048\001\049\001\050\001\051\001\
\052\001\053\001\054\001\055\001\056\001\255\255\255\255\059\001\
\060\001\255\255\255\255\063\001\064\001\065\001\255\255\255\255\
\068\001\069\001\070\001\071\001\072\001\255\255\074\001\255\255\
\076\001\077\001\078\001\255\255\255\255\081\001\255\255\255\255\
\084\001\085\001\255\255\087\001\255\255\089\001\090\001\255\255\
\255\255\093\001\255\255\255\255\255\255\097\001\255\255\099\001\
\255\255\101\001\102\001\255\255\104\001\255\255\106\001\107\001\
\255\255\109\001\110\001\111\001\112\001\255\255\114\001\000\001\
\001\001\002\001\255\255\255\255\005\001\006\001\007\001\255\255\
\009\001\255\255\011\001\012\001\255\255\255\255\015\001\016\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\027\001\255\255\255\255\030\001\031\001\032\001\
\033\001\034\001\255\255\036\001\255\255\255\255\039\001\255\255\
\255\255\042\001\043\001\044\001\045\001\046\001\047\001\255\255\
\255\255\050\001\255\255\052\001\053\001\054\001\055\001\056\001\
\255\255\255\255\059\001\255\255\061\001\255\255\063\001\064\001\
\065\001\255\255\255\255\255\255\069\001\255\255\071\001\072\001\
\255\255\074\001\255\255\076\001\255\255\078\001\255\255\255\255\
\255\255\082\001\083\001\084\001\085\001\086\001\087\001\255\255\
\255\255\255\255\255\255\255\255\255\255\094\001\255\255\255\255\
\255\255\098\001\255\255\100\001\101\001\255\255\255\255\255\255\
\255\255\106\001\107\001\255\255\109\001\110\001\000\001\001\001\
\002\001\114\001\255\255\005\001\006\001\007\001\255\255\009\001\
\255\255\011\001\012\001\255\255\255\255\015\001\016\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\027\001\255\255\255\255\030\001\031\001\032\001\033\001\
\034\001\255\255\036\001\255\255\255\255\039\001\255\255\255\255\
\042\001\043\001\044\001\045\001\046\001\047\001\255\255\255\255\
\050\001\255\255\052\001\053\001\054\001\055\001\056\001\255\255\
\255\255\059\001\255\255\061\001\255\255\063\001\064\001\065\001\
\255\255\255\255\255\255\069\001\255\255\071\001\072\001\255\255\
\074\001\255\255\076\001\255\255\078\001\255\255\255\255\255\255\
\082\001\083\001\084\001\085\001\086\001\087\001\255\255\255\255\
\255\255\255\255\255\255\055\001\094\001\057\001\058\001\059\001\
\098\001\061\001\100\001\101\001\064\001\065\001\255\255\255\255\
\106\001\107\001\255\255\109\001\110\001\000\001\255\255\255\255\
\114\001\255\255\005\001\006\001\007\001\081\001\255\255\255\255\
\011\001\012\001\013\001\255\255\255\255\089\001\090\001\255\255\
\255\255\255\255\255\255\255\255\255\255\097\001\255\255\026\001\
\255\255\028\001\029\001\030\001\031\001\032\001\033\001\034\001\
\255\255\109\001\110\001\255\255\039\001\255\255\041\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\050\001\
\255\255\052\001\053\001\054\001\055\001\056\001\255\255\255\255\
\059\001\060\001\255\255\255\255\063\001\064\001\065\001\255\255\
\255\255\068\001\069\001\255\255\071\001\072\001\255\255\074\001\
\255\255\076\001\255\255\078\001\255\255\080\001\255\255\255\255\
\255\255\084\001\085\001\000\001\087\001\255\255\255\255\255\255\
\005\001\006\001\007\001\255\255\255\255\096\001\011\001\012\001\
\255\255\255\255\101\001\255\255\255\255\255\255\255\255\106\001\
\107\001\108\001\109\001\110\001\111\001\255\255\255\255\114\001\
\255\255\030\001\031\001\032\001\033\001\034\001\255\255\255\255\
\255\255\255\255\039\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\050\001\255\255\052\001\
\053\001\054\001\055\001\056\001\255\255\255\255\059\001\255\255\
\255\255\255\255\063\001\064\001\065\001\255\255\255\255\255\255\
\069\001\255\255\071\001\072\001\255\255\255\255\255\255\076\001\
\255\255\078\001\255\255\255\255\255\255\255\255\255\255\084\001\
\085\001\000\001\087\001\255\255\255\255\255\255\005\001\006\001\
\007\001\094\001\255\255\255\255\011\001\012\001\255\255\255\255\
\101\001\255\255\255\255\255\255\255\255\106\001\107\001\255\255\
\109\001\110\001\255\255\255\255\255\255\114\001\255\255\030\001\
\031\001\032\001\033\001\034\001\255\255\255\255\255\255\255\255\
\039\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\050\001\255\255\052\001\053\001\054\001\
\055\001\056\001\255\255\255\255\059\001\255\255\255\255\255\255\
\063\001\064\001\065\001\255\255\255\255\255\255\069\001\255\255\
\071\001\072\001\255\255\255\255\255\255\076\001\255\255\078\001\
\255\255\255\255\255\255\255\255\255\255\084\001\085\001\000\001\
\087\001\255\255\255\255\255\255\005\001\006\001\007\001\094\001\
\255\255\255\255\011\001\012\001\255\255\255\255\101\001\255\255\
\255\255\255\255\255\255\106\001\107\001\255\255\109\001\110\001\
\255\255\255\255\255\255\114\001\255\255\030\001\031\001\032\001\
\033\001\034\001\255\255\255\255\255\255\255\255\039\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\050\001\255\255\052\001\053\001\054\001\055\001\056\001\
\255\255\255\255\059\001\255\255\255\255\255\255\063\001\064\001\
\065\001\255\255\255\255\255\255\069\001\255\255\071\001\072\001\
\255\255\255\255\255\255\076\001\255\255\078\001\255\255\255\255\
\255\255\255\255\255\255\084\001\085\001\000\001\087\001\255\255\
\255\255\255\255\005\001\006\001\007\001\094\001\255\255\255\255\
\011\001\012\001\255\255\255\255\101\001\255\255\255\255\255\255\
\255\255\106\001\107\001\255\255\109\001\110\001\255\255\255\255\
\255\255\114\001\255\255\030\001\031\001\032\001\033\001\034\001\
\255\255\255\255\255\255\255\255\039\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\050\001\
\255\255\052\001\053\001\054\001\055\001\056\001\255\255\255\255\
\059\001\255\255\255\255\255\255\063\001\064\001\065\001\255\255\
\255\255\255\255\069\001\255\255\071\001\072\001\255\255\255\255\
\255\255\076\001\255\255\078\001\255\255\255\255\255\255\255\255\
\255\255\084\001\085\001\255\255\087\001\255\255\255\255\255\255\
\255\255\255\255\255\255\094\001\003\001\004\001\005\001\255\255\
\255\255\255\255\101\001\255\255\011\001\255\255\013\001\106\001\
\107\001\255\255\109\001\110\001\019\001\020\001\021\001\114\001\
\255\255\024\001\025\001\026\001\255\255\028\001\029\001\030\001\
\255\255\032\001\033\001\034\001\035\001\255\255\255\255\255\255\
\039\001\040\001\041\001\255\255\255\255\255\255\255\255\255\255\
\255\255\048\001\049\001\255\255\255\255\052\001\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\063\001\064\001\255\255\255\255\255\255\000\001\069\001\070\001\
\255\255\004\001\255\255\074\001\075\001\076\001\077\001\078\001\
\079\001\080\001\255\255\082\001\255\255\255\255\017\001\255\255\
\019\001\088\001\255\255\022\001\255\255\255\255\093\001\026\001\
\027\001\255\255\255\255\255\255\099\001\255\255\255\255\102\001\
\103\001\036\001\105\001\106\001\107\001\108\001\109\001\255\255\
\111\001\112\001\113\001\114\001\115\001\048\001\049\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\060\001\255\255\255\255\255\255\064\001\255\255\066\001\
\067\001\068\001\255\255\070\001\255\255\255\255\073\001\255\255\
\255\255\255\255\000\001\001\001\002\001\255\255\255\255\255\255\
\006\001\007\001\255\255\009\001\255\255\255\255\012\001\090\001\
\091\001\015\001\016\001\255\255\095\001\255\255\097\001\255\255\
\255\255\100\001\255\255\255\255\255\255\027\001\028\001\255\255\
\030\001\031\001\109\001\255\255\111\001\255\255\036\001\255\255\
\255\255\255\255\255\255\255\255\042\001\043\001\044\001\045\001\
\046\001\047\001\255\255\255\255\050\001\255\255\052\001\053\001\
\255\255\055\001\056\001\255\255\255\255\059\001\255\255\061\001\
\255\255\255\255\064\001\065\001\255\255\255\255\255\255\255\255\
\255\255\071\001\072\001\255\255\074\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\082\001\083\001\084\001\085\001\
\086\001\087\001\255\255\255\255\255\255\255\255\255\255\255\255\
\094\001\255\255\255\255\097\001\098\001\255\255\100\001\101\001\
\255\255\255\255\255\255\255\255\106\001\255\255\108\001\109\001\
\110\001\000\001\001\001\002\001\255\255\255\255\255\255\006\001\
\007\001\255\255\009\001\255\255\255\255\012\001\255\255\255\255\
\015\001\016\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\027\001\028\001\255\255\030\001\
\031\001\255\255\255\255\255\255\255\255\036\001\255\255\255\255\
\255\255\255\255\255\255\042\001\043\001\044\001\045\001\046\001\
\047\001\255\255\255\255\050\001\255\255\052\001\053\001\255\255\
\055\001\056\001\255\255\255\255\059\001\255\255\061\001\255\255\
\255\255\064\001\065\001\255\255\255\255\255\255\255\255\255\255\
\071\001\072\001\255\255\074\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\082\001\083\001\084\001\085\001\086\001\
\087\001\255\255\255\255\255\255\255\255\255\255\255\255\094\001\
\255\255\255\255\097\001\098\001\255\255\100\001\101\001\255\255\
\255\255\255\255\255\255\106\001\255\255\108\001\109\001\110\001\
\000\001\001\001\002\001\255\255\255\255\255\255\006\001\007\001\
\255\255\009\001\255\255\255\255\012\001\255\255\255\255\015\001\
\016\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\027\001\028\001\255\255\030\001\031\001\
\255\255\255\255\255\255\255\255\036\001\255\255\255\255\255\255\
\255\255\255\255\042\001\043\001\044\001\045\001\046\001\047\001\
\255\255\255\255\050\001\255\255\052\001\053\001\255\255\055\001\
\056\001\255\255\255\255\059\001\255\255\061\001\255\255\255\255\
\064\001\065\001\255\255\255\255\255\255\255\255\255\255\071\001\
\072\001\255\255\074\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\082\001\083\001\084\001\085\001\086\001\087\001\
\255\255\255\255\255\255\255\255\255\255\255\255\094\001\255\255\
\255\255\097\001\098\001\255\255\100\001\101\001\255\255\255\255\
\255\255\255\255\106\001\255\255\108\001\109\001\110\001\000\001\
\001\001\002\001\255\255\255\255\255\255\006\001\007\001\255\255\
\009\001\255\255\255\255\012\001\255\255\255\255\015\001\016\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\027\001\028\001\255\255\030\001\031\001\255\255\
\255\255\255\255\255\255\036\001\255\255\255\255\255\255\255\255\
\255\255\042\001\043\001\044\001\045\001\046\001\047\001\255\255\
\255\255\050\001\255\255\052\001\053\001\255\255\055\001\056\001\
\255\255\255\255\059\001\255\255\061\001\255\255\255\255\064\001\
\065\001\255\255\255\255\255\255\255\255\255\255\071\001\072\001\
\255\255\074\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\082\001\083\001\084\001\085\001\086\001\087\001\255\255\
\255\255\000\001\255\255\255\255\255\255\094\001\255\255\006\001\
\097\001\098\001\255\255\100\001\101\001\012\001\255\255\255\255\
\015\001\106\001\255\255\255\255\109\001\110\001\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\028\001\255\255\030\001\
\031\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\050\001\255\255\052\001\053\001\255\255\
\055\001\056\001\255\255\255\255\059\001\255\255\000\001\255\255\
\255\255\064\001\065\001\255\255\006\001\255\255\255\255\255\255\
\071\001\255\255\012\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\084\001\255\255\255\255\
\255\255\255\255\028\001\255\255\030\001\031\001\255\255\094\001\
\255\255\255\255\097\001\255\255\255\255\255\255\101\001\255\255\
\255\255\255\255\255\255\106\001\255\255\255\255\109\001\110\001\
\050\001\255\255\052\001\053\001\255\255\055\001\056\001\255\255\
\255\255\059\001\255\255\000\001\255\255\255\255\064\001\065\001\
\255\255\006\001\255\255\255\255\255\255\071\001\255\255\012\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\084\001\255\255\255\255\255\255\255\255\028\001\
\255\255\030\001\031\001\255\255\255\255\255\255\255\255\097\001\
\255\255\255\255\255\255\101\001\255\255\255\255\255\255\255\255\
\106\001\255\255\255\255\109\001\110\001\050\001\255\255\052\001\
\053\001\255\255\055\001\056\001\255\255\255\255\059\001\255\255\
\000\001\255\255\255\255\064\001\065\001\255\255\006\001\255\255\
\255\255\255\255\071\001\255\255\012\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\084\001\
\255\255\255\255\255\255\255\255\028\001\255\255\030\001\031\001\
\255\255\255\255\255\255\255\255\097\001\255\255\255\255\255\255\
\101\001\255\255\255\255\255\255\255\255\106\001\255\255\255\255\
\109\001\110\001\050\001\255\255\052\001\053\001\255\255\055\001\
\056\001\255\255\255\255\059\001\255\255\000\001\255\255\255\255\
\064\001\065\001\255\255\006\001\255\255\255\255\255\255\071\001\
\255\255\012\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\084\001\255\255\255\255\255\255\
\255\255\028\001\255\255\030\001\031\001\255\255\255\255\255\255\
\255\255\097\001\255\255\255\255\255\255\101\001\255\255\255\255\
\255\255\255\255\106\001\255\255\255\255\109\001\110\001\050\001\
\255\255\052\001\053\001\255\255\055\001\056\001\255\255\255\255\
\059\001\255\255\000\001\255\255\255\255\064\001\065\001\255\255\
\006\001\255\255\255\255\255\255\071\001\255\255\012\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\084\001\255\255\255\255\255\255\255\255\028\001\255\255\
\030\001\031\001\255\255\255\255\255\255\255\255\097\001\255\255\
\255\255\255\255\101\001\255\255\255\255\255\255\255\255\106\001\
\255\255\255\255\109\001\110\001\050\001\255\255\052\001\053\001\
\255\255\055\001\056\001\255\255\255\255\059\001\255\255\000\001\
\255\255\255\255\064\001\065\001\255\255\006\001\255\255\255\255\
\255\255\071\001\255\255\012\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\084\001\255\255\
\255\255\255\255\255\255\028\001\255\255\030\001\031\001\255\255\
\255\255\255\255\255\255\097\001\255\255\255\255\255\255\101\001\
\255\255\255\255\255\255\255\255\106\001\255\255\255\255\109\001\
\110\001\050\001\255\255\052\001\053\001\255\255\055\001\056\001\
\255\255\255\255\059\001\255\255\255\255\255\255\255\255\064\001\
\065\001\005\001\006\001\007\001\255\255\255\255\071\001\011\001\
\012\001\013\001\014\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\084\001\255\255\255\255\255\255\255\255\
\028\001\029\001\030\001\031\001\032\001\033\001\034\001\255\255\
\097\001\255\255\255\255\039\001\101\001\041\001\255\255\255\255\
\255\255\106\001\255\255\255\255\109\001\110\001\050\001\255\255\
\052\001\053\001\054\001\055\001\056\001\255\255\255\255\059\001\
\060\001\255\255\255\255\063\001\064\001\065\001\255\255\255\255\
\068\001\069\001\255\255\071\001\072\001\255\255\074\001\255\255\
\076\001\255\255\078\001\255\255\080\001\255\255\255\255\255\255\
\084\001\085\001\255\255\087\001\255\255\089\001\255\255\255\255\
\005\001\006\001\007\001\255\255\096\001\255\255\011\001\012\001\
\013\001\101\001\255\255\255\255\255\255\255\255\106\001\107\001\
\108\001\109\001\110\001\111\001\255\255\255\255\114\001\028\001\
\029\001\030\001\031\001\032\001\033\001\034\001\255\255\255\255\
\255\255\255\255\039\001\255\255\041\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\050\001\255\255\052\001\
\053\001\054\001\055\001\056\001\255\255\255\255\059\001\060\001\
\255\255\255\255\063\001\064\001\065\001\255\255\255\255\068\001\
\069\001\255\255\071\001\072\001\255\255\074\001\255\255\076\001\
\255\255\078\001\255\255\080\001\255\255\255\255\255\255\084\001\
\085\001\255\255\087\001\255\255\255\255\255\255\005\001\006\001\
\007\001\255\255\255\255\096\001\011\001\012\001\255\255\255\255\
\101\001\255\255\255\255\255\255\255\255\106\001\107\001\108\001\
\109\001\110\001\111\001\255\255\255\255\114\001\255\255\030\001\
\031\001\032\001\033\001\034\001\255\255\255\255\255\255\255\255\
\039\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\050\001\255\255\052\001\053\001\054\001\
\055\001\056\001\255\255\255\255\059\001\255\255\255\255\255\255\
\063\001\064\001\065\001\255\255\255\255\255\255\069\001\255\255\
\071\001\072\001\255\255\255\255\255\255\076\001\255\255\078\001\
\255\255\255\255\255\255\255\255\255\255\084\001\085\001\255\255\
\087\001\255\255\255\255\255\255\255\255\092\001\005\001\006\001\
\007\001\255\255\255\255\010\001\011\001\012\001\101\001\255\255\
\255\255\255\255\255\255\106\001\107\001\255\255\109\001\110\001\
\255\255\255\255\255\255\114\001\255\255\255\255\255\255\030\001\
\031\001\032\001\033\001\034\001\255\255\255\255\255\255\255\255\
\039\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\050\001\255\255\052\001\053\001\054\001\
\055\001\056\001\255\255\255\255\059\001\255\255\255\255\255\255\
\063\001\064\001\065\001\255\255\255\255\255\255\069\001\255\255\
\071\001\072\001\255\255\255\255\255\255\076\001\255\255\078\001\
\255\255\255\255\255\255\255\255\255\255\084\001\085\001\255\255\
\087\001\255\255\255\255\005\001\006\001\007\001\255\255\255\255\
\255\255\011\001\012\001\255\255\255\255\255\255\101\001\255\255\
\255\255\255\255\255\255\106\001\107\001\255\255\109\001\110\001\
\026\001\255\255\255\255\114\001\030\001\031\001\032\001\033\001\
\034\001\255\255\255\255\255\255\255\255\039\001\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\050\001\255\255\052\001\053\001\054\001\055\001\056\001\255\255\
\255\255\059\001\255\255\255\255\255\255\063\001\064\001\065\001\
\255\255\255\255\255\255\069\001\255\255\071\001\072\001\255\255\
\255\255\255\255\076\001\255\255\078\001\255\255\255\255\255\255\
\255\255\255\255\084\001\085\001\255\255\087\001\255\255\255\255\
\005\001\006\001\007\001\255\255\255\255\255\255\011\001\012\001\
\255\255\255\255\255\255\101\001\255\255\255\255\255\255\255\255\
\106\001\107\001\255\255\109\001\110\001\255\255\255\255\255\255\
\114\001\030\001\031\001\032\001\033\001\034\001\255\255\255\255\
\255\255\255\255\039\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\050\001\255\255\052\001\
\053\001\054\001\055\001\056\001\255\255\255\255\059\001\255\255\
\255\255\255\255\063\001\064\001\065\001\255\255\255\255\255\255\
\069\001\255\255\071\001\072\001\255\255\255\255\255\255\076\001\
\255\255\078\001\255\255\255\255\255\255\255\255\083\001\084\001\
\085\001\255\255\087\001\255\255\255\255\005\001\006\001\007\001\
\255\255\255\255\255\255\011\001\012\001\255\255\255\255\255\255\
\101\001\255\255\255\255\255\255\255\255\106\001\107\001\255\255\
\109\001\110\001\255\255\255\255\255\255\114\001\030\001\031\001\
\032\001\033\001\034\001\255\255\255\255\255\255\255\255\039\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\050\001\255\255\052\001\053\001\054\001\055\001\
\056\001\255\255\255\255\059\001\255\255\255\255\255\255\063\001\
\064\001\065\001\255\255\255\255\255\255\069\001\255\255\071\001\
\072\001\255\255\255\255\255\255\076\001\255\255\078\001\255\255\
\255\255\255\255\255\255\255\255\084\001\085\001\255\255\087\001\
\255\255\255\255\255\255\255\255\092\001\005\001\006\001\007\001\
\255\255\255\255\010\001\011\001\012\001\101\001\255\255\255\255\
\255\255\255\255\106\001\107\001\255\255\109\001\110\001\255\255\
\255\255\255\255\114\001\255\255\255\255\255\255\030\001\031\001\
\032\001\033\001\034\001\255\255\255\255\255\255\255\255\039\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\050\001\255\255\052\001\053\001\054\001\055\001\
\056\001\255\255\255\255\059\001\255\255\255\255\255\255\063\001\
\064\001\065\001\255\255\255\255\255\255\069\001\255\255\071\001\
\072\001\255\255\255\255\255\255\076\001\255\255\078\001\255\255\
\255\255\255\255\255\255\255\255\084\001\085\001\255\255\087\001\
\255\255\255\255\255\255\005\001\006\001\007\001\255\255\255\255\
\255\255\011\001\012\001\255\255\255\255\101\001\255\255\255\255\
\255\255\255\255\106\001\107\001\022\001\109\001\110\001\255\255\
\255\255\255\255\114\001\255\255\030\001\031\001\032\001\033\001\
\034\001\255\255\255\255\255\255\255\255\039\001\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\050\001\255\255\052\001\053\001\054\001\055\001\056\001\255\255\
\255\255\059\001\255\255\255\255\255\255\063\001\064\001\065\001\
\255\255\255\255\255\255\069\001\255\255\071\001\072\001\255\255\
\255\255\255\255\076\001\255\255\078\001\255\255\255\255\255\255\
\255\255\255\255\084\001\085\001\255\255\087\001\255\255\255\255\
\005\001\006\001\007\001\255\255\255\255\255\255\011\001\012\001\
\255\255\255\255\255\255\101\001\255\255\255\255\255\255\255\255\
\106\001\107\001\255\255\109\001\110\001\026\001\255\255\255\255\
\114\001\030\001\031\001\032\001\033\001\034\001\255\255\255\255\
\255\255\255\255\039\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\050\001\255\255\052\001\
\053\001\054\001\055\001\056\001\255\255\255\255\059\001\255\255\
\255\255\255\255\063\001\064\001\065\001\255\255\255\255\255\255\
\069\001\255\255\071\001\072\001\255\255\255\255\255\255\076\001\
\255\255\078\001\255\255\255\255\255\255\255\255\255\255\084\001\
\085\001\255\255\087\001\255\255\255\255\005\001\006\001\007\001\
\255\255\255\255\255\255\011\001\012\001\255\255\255\255\255\255\
\101\001\255\255\255\255\255\255\255\255\106\001\107\001\255\255\
\109\001\110\001\255\255\255\255\255\255\114\001\030\001\031\001\
\032\001\033\001\034\001\255\255\255\255\255\255\255\255\039\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\050\001\255\255\052\001\053\001\054\001\055\001\
\056\001\255\255\255\255\059\001\255\255\255\255\255\255\063\001\
\064\001\065\001\255\255\255\255\255\255\069\001\255\255\071\001\
\072\001\255\255\255\255\255\255\076\001\255\255\078\001\255\255\
\255\255\255\255\255\255\255\255\084\001\085\001\255\255\087\001\
\255\255\255\255\005\001\006\001\007\001\255\255\255\255\255\255\
\011\001\012\001\255\255\255\255\255\255\101\001\255\255\255\255\
\255\255\255\255\106\001\107\001\255\255\109\001\110\001\255\255\
\255\255\255\255\114\001\030\001\031\001\032\001\033\001\034\001\
\255\255\255\255\255\255\255\255\039\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\050\001\
\255\255\052\001\053\001\054\001\055\001\056\001\255\255\255\255\
\059\001\255\255\255\255\255\255\063\001\064\001\065\001\255\255\
\255\255\255\255\069\001\255\255\071\001\072\001\255\255\255\255\
\255\255\076\001\255\255\078\001\255\255\255\255\255\255\255\255\
\255\255\084\001\085\001\255\255\087\001\255\255\255\255\005\001\
\006\001\007\001\255\255\255\255\255\255\011\001\012\001\255\255\
\255\255\255\255\101\001\255\255\255\255\255\255\255\255\106\001\
\107\001\255\255\109\001\110\001\255\255\255\255\255\255\114\001\
\030\001\031\001\032\001\033\001\034\001\255\255\255\255\255\255\
\255\255\039\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\050\001\255\255\052\001\053\001\
\054\001\055\001\056\001\255\255\255\255\059\001\255\255\255\255\
\255\255\063\001\064\001\065\001\255\255\255\255\255\255\069\001\
\255\255\071\001\072\001\255\255\255\255\006\001\076\001\255\255\
\078\001\255\255\255\255\012\001\255\255\014\001\084\001\085\001\
\017\001\087\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\027\001\255\255\255\255\030\001\031\001\101\001\
\255\255\255\255\255\255\255\255\106\001\107\001\255\255\109\001\
\110\001\255\255\255\255\255\255\114\001\255\255\255\255\255\255\
\255\255\050\001\051\001\255\255\053\001\255\255\055\001\056\001\
\255\255\255\255\059\001\255\255\255\255\255\255\255\255\064\001\
\065\001\255\255\006\001\255\255\255\255\255\255\071\001\255\255\
\012\001\255\255\014\001\255\255\255\255\017\001\255\255\255\255\
\081\001\255\255\255\255\084\001\255\255\255\255\255\255\027\001\
\089\001\255\255\030\001\031\001\255\255\006\001\255\255\255\255\
\097\001\255\255\255\255\012\001\101\001\014\001\255\255\104\001\
\255\255\106\001\255\255\255\255\109\001\110\001\050\001\051\001\
\255\255\053\001\255\255\055\001\056\001\030\001\031\001\059\001\
\255\255\255\255\255\255\255\255\064\001\065\001\255\255\255\255\
\255\255\255\255\255\255\071\001\255\255\255\255\255\255\255\255\
\255\255\050\001\051\001\255\255\053\001\081\001\055\001\056\001\
\084\001\255\255\059\001\255\255\255\255\089\001\255\255\064\001\
\065\001\255\255\255\255\255\255\255\255\097\001\071\001\255\255\
\073\001\101\001\255\255\255\255\104\001\255\255\106\001\255\255\
\081\001\109\001\110\001\084\001\255\255\255\255\006\001\255\255\
\089\001\255\255\255\255\255\255\012\001\255\255\014\001\255\255\
\097\001\255\255\255\255\255\255\101\001\255\255\255\255\104\001\
\255\255\106\001\255\255\027\001\109\001\110\001\030\001\031\001\
\255\255\006\001\255\255\255\255\255\255\255\255\255\255\012\001\
\255\255\014\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\050\001\051\001\255\255\053\001\027\001\055\001\
\056\001\030\001\031\001\059\001\255\255\255\255\255\255\255\255\
\064\001\065\001\255\255\255\255\255\255\255\255\255\255\071\001\
\255\255\255\255\255\255\255\255\255\255\050\001\051\001\255\255\
\053\001\081\001\055\001\056\001\084\001\255\255\059\001\255\255\
\255\255\089\001\255\255\064\001\065\001\255\255\006\001\255\255\
\255\255\097\001\071\001\255\255\012\001\101\001\255\255\255\255\
\104\001\255\255\106\001\255\255\081\001\109\001\110\001\084\001\
\255\255\255\255\255\255\255\255\089\001\255\255\030\001\031\001\
\255\255\006\001\255\255\255\255\097\001\255\255\255\255\012\001\
\101\001\255\255\255\255\104\001\255\255\106\001\255\255\255\255\
\109\001\110\001\050\001\051\001\255\255\053\001\255\255\055\001\
\056\001\030\001\031\001\059\001\255\255\255\255\255\255\255\255\
\064\001\065\001\255\255\255\255\255\255\255\255\255\255\071\001\
\255\255\073\001\255\255\255\255\255\255\050\001\051\001\255\255\
\053\001\081\001\055\001\056\001\084\001\255\255\059\001\255\255\
\255\255\089\001\255\255\064\001\065\001\255\255\006\001\255\255\
\255\255\097\001\071\001\255\255\012\001\101\001\255\255\255\255\
\104\001\255\255\106\001\255\255\081\001\109\001\110\001\084\001\
\255\255\255\255\255\255\255\255\089\001\255\255\030\001\031\001\
\255\255\006\001\255\255\255\255\097\001\255\255\255\255\012\001\
\101\001\255\255\255\255\104\001\255\255\106\001\255\255\255\255\
\109\001\110\001\050\001\051\001\255\255\053\001\255\255\055\001\
\056\001\030\001\031\001\059\001\255\255\255\255\255\255\255\255\
\064\001\065\001\255\255\255\255\255\255\255\255\255\255\071\001\
\255\255\255\255\255\255\255\255\255\255\050\001\051\001\255\255\
\053\001\081\001\055\001\056\001\084\001\255\255\059\001\255\255\
\255\255\089\001\255\255\064\001\065\001\255\255\006\001\255\255\
\255\255\097\001\071\001\255\255\012\001\101\001\255\255\255\255\
\104\001\255\255\106\001\255\255\081\001\109\001\110\001\084\001\
\255\255\255\255\255\255\255\255\089\001\255\255\030\001\031\001\
\255\255\255\255\255\255\255\255\097\001\255\255\255\255\255\255\
\101\001\255\255\255\255\104\001\255\255\106\001\255\255\255\255\
\109\001\110\001\050\001\051\001\255\255\053\001\255\255\055\001\
\056\001\255\255\255\255\059\001\255\255\255\255\255\255\255\255\
\064\001\065\001\255\255\255\255\006\001\255\255\255\255\071\001\
\255\255\255\255\012\001\255\255\255\255\255\255\255\255\255\255\
\255\255\081\001\255\255\255\255\084\001\255\255\255\255\255\255\
\255\255\089\001\028\001\255\255\030\001\031\001\255\255\255\255\
\255\255\097\001\255\255\255\255\255\255\101\001\255\255\255\255\
\104\001\255\255\106\001\255\255\255\255\109\001\110\001\255\255\
\050\001\255\255\052\001\053\001\255\255\055\001\056\001\255\255\
\255\255\059\001\255\255\255\255\255\255\255\255\064\001\065\001\
\255\255\255\255\255\255\006\001\255\255\071\001\255\255\010\001\
\255\255\012\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\084\001\255\255\255\255\255\255\255\255\255\255\
\255\255\028\001\092\001\030\001\031\001\255\255\255\255\097\001\
\255\255\255\255\255\255\101\001\255\255\255\255\255\255\255\255\
\106\001\255\255\255\255\109\001\110\001\255\255\255\255\050\001\
\255\255\052\001\053\001\255\255\055\001\056\001\255\255\255\255\
\059\001\255\255\255\255\255\255\255\255\064\001\065\001\255\255\
\006\001\255\255\255\255\255\255\071\001\255\255\012\001\255\255\
\255\255\255\255\255\255\255\255\255\255\006\001\007\001\255\255\
\255\255\084\001\011\001\012\001\255\255\255\255\028\001\255\255\
\030\001\031\001\255\255\255\255\255\255\255\255\097\001\255\255\
\255\255\255\255\101\001\255\255\255\255\030\001\031\001\106\001\
\255\255\255\255\109\001\110\001\050\001\255\255\052\001\053\001\
\255\255\055\001\056\001\255\255\255\255\059\001\255\255\255\255\
\255\255\050\001\064\001\065\001\053\001\054\001\055\001\056\001\
\255\255\071\001\059\001\255\255\006\001\255\255\008\001\064\001\
\065\001\255\255\012\001\255\255\255\255\255\255\084\001\255\255\
\255\255\255\255\255\255\076\001\255\255\255\255\092\001\255\255\
\255\255\255\255\028\001\097\001\030\001\031\001\087\001\101\001\
\255\255\255\255\255\255\255\255\106\001\255\255\255\255\109\001\
\110\001\255\255\255\255\255\255\101\001\255\255\255\255\255\255\
\050\001\106\001\052\001\053\001\109\001\055\001\056\001\255\255\
\255\255\059\001\255\255\255\255\255\255\255\255\064\001\065\001\
\255\255\006\001\255\255\255\255\255\255\071\001\255\255\012\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\084\001\255\255\255\255\255\255\255\255\028\001\
\255\255\030\001\031\001\255\255\255\255\255\255\255\255\097\001\
\255\255\255\255\255\255\101\001\255\255\255\255\255\255\255\255\
\106\001\255\255\255\255\109\001\110\001\050\001\255\255\052\001\
\053\001\255\255\055\001\056\001\255\255\255\255\059\001\255\255\
\255\255\255\255\255\255\064\001\065\001\255\255\006\001\255\255\
\255\255\255\255\071\001\255\255\012\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\084\001\
\255\255\255\255\255\255\255\255\028\001\255\255\030\001\031\001\
\255\255\006\001\255\255\255\255\097\001\255\255\255\255\012\001\
\101\001\255\255\255\255\255\255\255\255\106\001\255\255\255\255\
\109\001\110\001\050\001\255\255\052\001\053\001\255\255\055\001\
\056\001\030\001\031\001\059\001\255\255\255\255\255\255\255\255\
\064\001\065\001\255\255\255\255\255\255\255\255\255\255\071\001\
\255\255\255\255\255\255\255\255\255\255\050\001\255\255\052\001\
\053\001\255\255\055\001\056\001\084\001\255\255\059\001\255\255\
\255\255\255\255\255\255\064\001\065\001\255\255\006\001\255\255\
\255\255\097\001\071\001\255\255\012\001\101\001\255\255\255\255\
\255\255\255\255\106\001\255\255\255\255\109\001\110\001\084\001\
\255\255\255\255\255\255\255\255\028\001\255\255\030\001\031\001\
\093\001\006\001\255\255\255\255\097\001\255\255\255\255\012\001\
\101\001\255\255\255\255\255\255\255\255\106\001\255\255\255\255\
\109\001\110\001\050\001\255\255\052\001\053\001\255\255\055\001\
\056\001\030\001\031\001\059\001\255\255\255\255\255\255\255\255\
\064\001\065\001\255\255\255\255\255\255\255\255\255\255\071\001\
\255\255\255\255\255\255\255\255\255\255\050\001\255\255\052\001\
\053\001\255\255\055\001\056\001\084\001\255\255\059\001\255\255\
\255\255\255\255\255\255\064\001\065\001\255\255\006\001\255\255\
\255\255\097\001\071\001\255\255\012\001\101\001\255\255\255\255\
\255\255\255\255\106\001\255\255\255\255\109\001\110\001\084\001\
\255\255\255\255\255\255\255\255\255\255\255\255\030\001\031\001\
\255\255\006\001\255\255\255\255\097\001\255\255\255\255\012\001\
\101\001\255\255\255\255\255\255\255\255\106\001\255\255\255\255\
\109\001\110\001\050\001\255\255\052\001\053\001\255\255\055\001\
\056\001\030\001\031\001\059\001\255\255\255\255\255\255\255\255\
\064\001\065\001\255\255\255\255\255\255\255\255\255\255\071\001\
\255\255\255\255\255\255\255\255\255\255\050\001\255\255\052\001\
\053\001\255\255\055\001\056\001\084\001\255\255\059\001\255\255\
\255\255\255\255\255\255\064\001\065\001\255\255\006\001\255\255\
\255\255\097\001\071\001\255\255\012\001\101\001\255\255\255\255\
\255\255\255\255\106\001\255\255\255\255\109\001\110\001\084\001\
\255\255\255\255\255\255\255\255\255\255\255\255\030\001\031\001\
\255\255\006\001\255\255\255\255\097\001\255\255\255\255\012\001\
\101\001\255\255\255\255\255\255\255\255\106\001\255\255\255\255\
\109\001\110\001\050\001\255\255\255\255\053\001\255\255\055\001\
\056\001\030\001\031\001\059\001\255\255\255\255\255\255\255\255\
\064\001\065\001\255\255\255\255\255\255\255\255\255\255\071\001\
\255\255\255\255\255\255\255\255\255\255\050\001\255\255\255\255\
\053\001\255\255\055\001\056\001\084\001\255\255\059\001\255\255\
\255\255\255\255\255\255\064\001\065\001\255\255\255\255\255\255\
\255\255\097\001\071\001\255\255\255\255\101\001\006\001\007\001\
\255\255\255\255\106\001\011\001\012\001\109\001\110\001\084\001\
\255\255\255\255\255\255\255\255\255\255\255\255\022\001\255\255\
\255\255\255\255\255\255\255\255\097\001\255\255\030\001\031\001\
\101\001\255\255\255\255\255\255\255\255\106\001\255\255\255\255\
\109\001\110\001\255\255\255\255\255\255\255\255\255\255\047\001\
\255\255\255\255\050\001\051\001\255\255\053\001\054\001\055\001\
\056\001\255\255\255\255\059\001\255\255\255\255\255\255\255\255\
\064\001\065\001\006\001\007\001\255\255\255\255\255\255\011\001\
\012\001\255\255\255\255\255\255\076\001\255\255\255\255\255\255\
\255\255\081\001\255\255\255\255\255\255\255\255\255\255\087\001\
\255\255\089\001\030\001\031\001\255\255\255\255\255\255\255\255\
\255\255\097\001\098\001\255\255\255\255\101\001\255\255\255\255\
\104\001\255\255\106\001\255\255\255\255\109\001\050\001\051\001\
\255\255\053\001\054\001\055\001\056\001\255\255\255\255\059\001\
\255\255\255\255\255\255\255\255\064\001\065\001\006\001\007\001\
\255\255\255\255\255\255\011\001\012\001\006\001\007\001\255\255\
\076\001\255\255\011\001\012\001\255\255\081\001\255\255\255\255\
\255\255\255\255\255\255\087\001\255\255\089\001\030\001\031\001\
\255\255\255\255\255\255\255\255\255\255\030\001\031\001\255\255\
\255\255\101\001\255\255\255\255\104\001\255\255\106\001\255\255\
\255\255\109\001\050\001\255\255\255\255\053\001\054\001\055\001\
\056\001\050\001\255\255\059\001\053\001\054\001\055\001\056\001\
\064\001\065\001\059\001\255\255\255\255\255\255\008\001\064\001\
\065\001\255\255\255\255\255\255\076\001\255\255\255\255\255\255\
\255\255\255\255\255\255\076\001\255\255\023\001\255\255\087\001\
\255\255\255\255\255\255\255\255\030\001\255\255\087\001\255\255\
\255\255\255\255\255\255\255\255\255\255\101\001\255\255\255\255\
\255\255\255\255\106\001\255\255\101\001\109\001\255\255\255\255\
\255\255\106\001\255\255\255\255\109\001\055\001\255\255\057\001\
\058\001\059\001\255\255\061\001\255\255\255\255\064\001\065\001\
\255\255\255\255\255\255\000\001\001\001\002\001\255\255\255\255\
\255\255\255\255\255\255\255\255\009\001\255\255\255\255\081\001\
\255\255\014\001\015\001\016\001\017\001\018\001\088\001\089\001\
\090\001\255\255\255\255\255\255\255\255\255\255\027\001\097\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\036\001\
\106\001\255\255\255\255\109\001\110\001\042\001\043\001\044\001\
\045\001\046\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\061\001\255\255\255\255\255\255\255\255\066\001\255\255\255\255\
\255\255\255\255\071\001\072\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\082\001\083\001\084\001\
\085\001\086\001\255\255\000\001\001\001\002\001\255\255\255\255\
\255\255\094\001\007\001\255\255\009\001\255\255\255\255\100\001\
\255\255\255\255\055\001\016\001\057\001\058\001\059\001\255\255\
\061\001\255\255\255\255\064\001\065\001\255\255\027\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\036\001\
\255\255\255\255\255\255\255\255\081\001\042\001\043\001\044\001\
\045\001\046\001\047\001\255\255\089\001\090\001\255\255\255\255\
\255\255\255\255\255\255\255\255\097\001\255\255\255\255\255\255\
\061\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\109\001\110\001\071\001\072\001\255\255\074\001\255\255\255\255\
\255\255\255\255\000\001\001\001\002\001\082\001\083\001\084\001\
\085\001\086\001\087\001\009\001\255\255\255\255\255\255\255\255\
\255\255\015\001\016\001\255\255\018\001\098\001\255\255\100\001\
\255\255\255\255\255\255\255\255\255\255\027\001\255\255\255\255\
\255\255\255\255\000\001\001\001\002\001\255\255\036\001\255\255\
\255\255\255\255\255\255\009\001\042\001\043\001\044\001\045\001\
\046\001\015\001\016\001\255\255\018\001\255\255\255\255\255\255\
\055\001\255\255\057\001\058\001\059\001\027\001\061\001\061\001\
\255\255\064\001\065\001\255\255\066\001\255\255\036\001\255\255\
\255\255\071\001\072\001\255\255\042\001\043\001\044\001\045\001\
\046\001\255\255\081\001\255\255\082\001\083\001\084\001\085\001\
\086\001\255\255\089\001\090\001\255\255\091\001\255\255\061\001\
\255\255\255\255\097\001\255\255\066\001\255\255\100\001\255\255\
\255\255\071\001\072\001\255\255\255\255\255\255\109\001\110\001\
\000\001\001\001\002\001\255\255\082\001\083\001\084\001\085\001\
\086\001\009\001\255\255\255\255\255\255\255\255\092\001\015\001\
\016\001\255\255\018\001\255\255\255\255\255\255\100\001\255\255\
\255\255\255\255\255\255\027\001\255\255\255\255\255\255\255\255\
\000\001\001\001\002\001\255\255\036\001\255\255\255\255\255\255\
\255\255\009\001\042\001\043\001\044\001\045\001\046\001\015\001\
\016\001\255\255\018\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\027\001\255\255\061\001\255\255\255\255\
\255\255\255\255\066\001\255\255\036\001\255\255\255\255\071\001\
\072\001\255\255\042\001\043\001\044\001\045\001\046\001\255\255\
\255\255\255\255\082\001\083\001\084\001\085\001\086\001\255\255\
\255\255\255\255\255\255\255\255\255\255\061\001\094\001\255\255\
\255\255\255\255\066\001\255\255\100\001\255\255\255\255\071\001\
\072\001\255\255\255\255\255\255\255\255\255\255\000\001\001\001\
\002\001\255\255\082\001\083\001\084\001\085\001\086\001\009\001\
\255\255\255\255\255\255\091\001\255\255\015\001\016\001\255\255\
\018\001\255\255\255\255\255\255\100\001\255\255\255\255\255\255\
\255\255\027\001\255\255\255\255\255\255\255\255\000\001\001\001\
\002\001\255\255\036\001\255\255\255\255\255\255\255\255\009\001\
\042\001\043\001\044\001\045\001\046\001\015\001\016\001\255\255\
\018\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\027\001\255\255\061\001\255\255\255\255\255\255\255\255\
\066\001\255\255\036\001\255\255\255\255\071\001\072\001\255\255\
\042\001\043\001\044\001\045\001\046\001\255\255\255\255\255\255\
\082\001\083\001\084\001\085\001\086\001\255\255\255\255\255\255\
\255\255\255\255\092\001\061\001\255\255\255\255\255\255\255\255\
\066\001\255\255\100\001\255\255\255\255\071\001\072\001\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\082\001\083\001\084\001\085\001\086\001\000\001\001\001\002\001\
\255\255\255\255\255\255\255\255\094\001\255\255\009\001\255\255\
\255\255\255\255\100\001\255\255\015\001\016\001\255\255\018\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\027\001\255\255\255\255\255\255\255\255\000\001\001\001\002\001\
\255\255\036\001\255\255\255\255\255\255\255\255\009\001\042\001\
\043\001\044\001\045\001\046\001\015\001\016\001\255\255\018\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\027\001\255\255\061\001\255\255\255\255\255\255\255\255\066\001\
\255\255\036\001\255\255\255\255\071\001\072\001\255\255\042\001\
\043\001\044\001\045\001\046\001\255\255\255\255\255\255\082\001\
\083\001\084\001\085\001\086\001\255\255\255\255\255\255\255\255\
\091\001\255\255\061\001\255\255\255\255\255\255\255\255\066\001\
\255\255\100\001\255\255\255\255\071\001\072\001\255\255\255\255\
\255\255\255\255\255\255\000\001\001\001\002\001\255\255\082\001\
\083\001\084\001\085\001\086\001\009\001\255\255\255\255\255\255\
\255\255\092\001\015\001\016\001\255\255\018\001\255\255\255\255\
\255\255\100\001\255\255\255\255\255\255\255\255\027\001\255\255\
\255\255\255\255\255\255\000\001\001\001\002\001\255\255\036\001\
\255\255\255\255\255\255\255\255\009\001\042\001\043\001\044\001\
\045\001\046\001\015\001\016\001\255\255\018\001\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\027\001\255\255\
\061\001\255\255\255\255\255\255\255\255\066\001\255\255\036\001\
\255\255\255\255\071\001\072\001\255\255\042\001\043\001\044\001\
\045\001\046\001\255\255\255\255\255\255\082\001\083\001\084\001\
\085\001\086\001\255\255\255\255\255\255\255\255\255\255\255\255\
\061\001\094\001\255\255\255\255\255\255\066\001\255\255\100\001\
\255\255\255\255\071\001\072\001\255\255\255\255\255\255\255\255\
\255\255\000\001\001\001\002\001\255\255\082\001\083\001\084\001\
\085\001\086\001\009\001\255\255\255\255\255\255\091\001\255\255\
\015\001\016\001\255\255\018\001\255\255\255\255\255\255\100\001\
\255\255\255\255\255\255\255\255\027\001\255\255\255\255\255\255\
\255\255\000\001\001\001\002\001\255\255\036\001\255\255\255\255\
\255\255\255\255\009\001\042\001\043\001\044\001\045\001\046\001\
\015\001\016\001\255\255\018\001\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\027\001\255\255\061\001\255\255\
\255\255\255\255\255\255\066\001\255\255\036\001\255\255\255\255\
\071\001\072\001\255\255\042\001\043\001\044\001\045\001\046\001\
\255\255\255\255\255\255\082\001\083\001\084\001\085\001\086\001\
\255\255\255\255\255\255\255\255\255\255\092\001\061\001\001\001\
\002\001\255\255\255\255\066\001\255\255\100\001\255\255\009\001\
\071\001\072\001\255\255\255\255\255\255\015\001\016\001\255\255\
\018\001\255\255\255\255\082\001\083\001\084\001\085\001\086\001\
\255\255\027\001\255\255\255\255\255\255\255\255\255\255\094\001\
\255\255\255\255\036\001\255\255\255\255\100\001\255\255\255\255\
\042\001\043\001\044\001\045\001\046\001\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\061\001\001\001\002\001\255\255\255\255\
\066\001\255\255\255\255\255\255\009\001\071\001\072\001\255\255\
\255\255\255\255\015\001\016\001\255\255\018\001\255\255\255\255\
\082\001\083\001\084\001\085\001\086\001\255\255\027\001\255\255\
\255\255\255\255\255\255\255\255\255\255\095\001\255\255\036\001\
\255\255\255\255\100\001\255\255\255\255\042\001\043\001\044\001\
\045\001\046\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\061\001\001\001\002\001\255\255\255\255\066\001\255\255\255\255\
\255\255\009\001\071\001\072\001\255\255\255\255\255\255\015\001\
\016\001\255\255\018\001\255\255\255\255\082\001\083\001\084\001\
\085\001\086\001\255\255\027\001\255\255\255\255\091\001\255\255\
\255\255\001\001\002\001\255\255\036\001\255\255\255\255\100\001\
\255\255\009\001\042\001\043\001\044\001\045\001\046\001\015\001\
\016\001\255\255\018\001\255\255\255\255\255\255\255\255\255\255\
\255\255\025\001\255\255\027\001\255\255\061\001\255\255\255\255\
\255\255\255\255\066\001\255\255\036\001\255\255\255\255\071\001\
\072\001\255\255\042\001\043\001\044\001\045\001\046\001\255\255\
\255\255\255\255\082\001\083\001\084\001\085\001\086\001\255\255\
\255\255\255\255\255\255\091\001\255\255\061\001\001\001\002\001\
\255\255\255\255\066\001\255\255\100\001\255\255\009\001\071\001\
\072\001\255\255\255\255\255\255\015\001\016\001\255\255\018\001\
\255\255\255\255\082\001\083\001\084\001\085\001\086\001\255\255\
\027\001\255\255\255\255\255\255\255\255\255\255\001\001\002\001\
\255\255\036\001\255\255\255\255\100\001\255\255\009\001\042\001\
\043\001\044\001\045\001\046\001\015\001\016\001\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\027\001\255\255\061\001\255\255\255\255\255\255\255\255\066\001\
\255\255\036\001\255\255\255\255\071\001\072\001\255\255\042\001\
\043\001\044\001\045\001\046\001\255\255\255\255\255\255\082\001\
\083\001\084\001\085\001\086\001\255\255\255\255\255\255\255\255\
\255\255\255\255\061\001\001\001\002\001\255\255\255\255\066\001\
\255\255\100\001\255\255\009\001\071\001\072\001\255\255\255\255\
\255\255\015\001\255\255\255\255\255\255\255\255\255\255\082\001\
\083\001\084\001\085\001\086\001\255\255\027\001\255\255\255\255\
\091\001\255\255\255\255\001\001\002\001\255\255\036\001\255\255\
\255\255\100\001\255\255\255\255\042\001\043\001\044\001\045\001\
\046\001\015\001\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\027\001\255\255\061\001\
\255\255\255\255\255\255\255\255\066\001\255\255\036\001\255\255\
\255\255\071\001\072\001\255\255\042\001\043\001\044\001\045\001\
\046\001\013\001\255\255\255\255\082\001\083\001\084\001\085\001\
\086\001\255\255\255\255\255\255\255\255\255\255\255\255\061\001\
\028\001\029\001\255\255\255\255\066\001\255\255\100\001\255\255\
\255\255\071\001\072\001\255\255\255\255\041\001\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\083\001\084\001\085\001\
\086\001\255\255\255\255\055\001\255\255\057\001\058\001\059\001\
\060\001\061\001\255\255\255\255\064\001\065\001\100\001\255\255\
\068\001\255\255\255\255\255\255\255\255\255\255\074\001\255\255\
\255\255\255\255\255\255\255\255\080\001\081\001\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\089\001\090\001\255\255\
\255\255\255\255\255\255\255\255\096\001\097\001\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\108\001\109\001\110\001\111\001"

let yynames_const = "\
  AMPERAMPER\000\
  AMPERSAND\000\
  AND\000\
  AS\000\
  ASSERT\000\
  BACKQUOTE\000\
  BANG\000\
  BAR\000\
  BARBAR\000\
  BARRBRACKET\000\
  BEGIN\000\
  CLASS\000\
  COLON\000\
  COLONCOLON\000\
  COLONEQUAL\000\
  COLONGREATER\000\
  COMMA\000\
  CONSTRAINT\000\
  DO\000\
  DONE\000\
  DOT\000\
  DOTDOT\000\
  DOWNTO\000\
  ELSE\000\
  END\000\
  EOF\000\
  EQUAL\000\
  EXCEPTION\000\
  EXTERNAL\000\
  FALSE\000\
  FOR\000\
  FUN\000\
  FUNCTION\000\
  FUNCTOR\000\
  GREATER\000\
  GREATERRBRACE\000\
  GREATERRBRACKET\000\
  IF\000\
  IN\000\
  INCLUDE\000\
  INHERIT\000\
  INITIALIZER\000\
  LAZY\000\
  LBRACE\000\
  LBRACELESS\000\
  LBRACKET\000\
  LBRACKETBAR\000\
  LBRACKETLESS\000\
  LBRACKETGREATER\000\
  LBRACKETPERCENT\000\
  LBRACKETPERCENTPERCENT\000\
  LESS\000\
  LESSMINUS\000\
  LET\000\
  LPAREN\000\
  LBRACKETAT\000\
  LBRACKETATAT\000\
  LBRACKETATATAT\000\
  MATCH\000\
  METHOD\000\
  MINUS\000\
  MINUSDOT\000\
  MINUSGREATER\000\
  MODULE\000\
  MUTABLE\000\
  NEW\000\
  NONREC\000\
  OBJECT\000\
  OF\000\
  OPEN\000\
  OR\000\
  PERCENT\000\
  PLUS\000\
  PLUSDOT\000\
  PLUSEQ\000\
  PRIVATE\000\
  QUESTION\000\
  QUOTE\000\
  RBRACE\000\
  RBRACKET\000\
  REC\000\
  RPAREN\000\
  SEMI\000\
  SEMISEMI\000\
  HASH\000\
  SIG\000\
  STAR\000\
  STRUCT\000\
  THEN\000\
  TILDE\000\
  TO\000\
  TRUE\000\
  TRY\000\
  TYPE\000\
  UNDERSCORE\000\
  VAL\000\
  VIRTUAL\000\
  WHEN\000\
  WHILE\000\
  WITH\000\
  EOL\000\
  "

let yynames_block = "\
  CHAR\000\
  FLOAT\000\
  INFIXOP0\000\
  INFIXOP1\000\
  INFIXOP2\000\
  INFIXOP3\000\
  INFIXOP4\000\
  DOTOP\000\
  INT\000\
  LABEL\000\
  LIDENT\000\
  OPTLABEL\000\
  PREFIXOP\000\
  HASHOP\000\
  STRING\000\
  UIDENT\000\
  COMMENT\000\
  DOCSTRING\000\
  "

let yyact = [|
  (fun _ -> failwith "parser")
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'structure) in
    Obj.repr(
# 630 "parsing/parser.mly"
                                         ( extra_str 1 _1 )
# 7030 "parsing/parser.ml"
               : Parsetree.structure))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'signature) in
    Obj.repr(
# 633 "parsing/parser.mly"
                                         ( extra_sig 1 _1 )
# 7037 "parsing/parser.ml"
               : Parsetree.signature))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'top_structure) in
    Obj.repr(
# 636 "parsing/parser.mly"
                                         ( Ptop_def (extra_str 1 _1) )
# 7044 "parsing/parser.ml"
               : Parsetree.toplevel_phrase))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'toplevel_directive) in
    Obj.repr(
# 637 "parsing/parser.mly"
                                         ( _1 )
# 7051 "parsing/parser.ml"
               : Parsetree.toplevel_phrase))
; (fun __caml_parser_env ->
    Obj.repr(
# 638 "parsing/parser.mly"
                                         ( raise End_of_file )
# 7057 "parsing/parser.ml"
               : Parsetree.toplevel_phrase))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 642 "parsing/parser.mly"
      ( (text_str 1) @ [mkstrexp _1 _2] )
# 7065 "parsing/parser.ml"
               : 'top_structure))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'top_structure_tail) in
    Obj.repr(
# 644 "parsing/parser.mly"
      ( _1 )
# 7072 "parsing/parser.ml"
               : 'top_structure))
; (fun __caml_parser_env ->
    Obj.repr(
# 647 "parsing/parser.mly"
                                         ( [] )
# 7078 "parsing/parser.ml"
               : 'top_structure_tail))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'structure_item) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'top_structure_tail) in
    Obj.repr(
# 648 "parsing/parser.mly"
                                         ( (text_str 1) @ _1 :: _2 )
# 7086 "parsing/parser.ml"
               : 'top_structure_tail))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'use_file_body) in
    Obj.repr(
# 651 "parsing/parser.mly"
                                         ( extra_def 1 _1 )
# 7093 "parsing/parser.ml"
               : Parsetree.toplevel_phrase list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'use_file_tail) in
    Obj.repr(
# 654 "parsing/parser.mly"
                                         ( _1 )
# 7100 "parsing/parser.ml"
               : 'use_file_body))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'seq_expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'post_item_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'use_file_tail) in
    Obj.repr(
# 656 "parsing/parser.mly"
      ( (text_def 1) @ Ptop_def[mkstrexp _1 _2] :: _3 )
# 7109 "parsing/parser.ml"
               : 'use_file_body))
; (fun __caml_parser_env ->
    Obj.repr(
# 660 "parsing/parser.mly"
      ( [] )
# 7115 "parsing/parser.ml"
               : 'use_file_tail))
; (fun __caml_parser_env ->
    Obj.repr(
# 662 "parsing/parser.mly"
      ( text_def 1 )
# 7121 "parsing/parser.ml"
               : 'use_file_tail))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'seq_expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'post_item_attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'use_file_tail) in
    Obj.repr(
# 664 "parsing/parser.mly"
      (  mark_rhs_docs 2 3;
        (text_def 1) @ (text_def 2) @ Ptop_def[mkstrexp _2 _3] :: _4 )
# 7131 "parsing/parser.ml"
               : 'use_file_tail))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'structure_item) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'use_file_tail) in
    Obj.repr(
# 667 "parsing/parser.mly"
      ( (text_def 1) @ (text_def 2) @ Ptop_def[_2] :: _3 )
# 7139 "parsing/parser.ml"
               : 'use_file_tail))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'toplevel_directive) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'use_file_tail) in
    Obj.repr(
# 669 "parsing/parser.mly"
      (  mark_rhs_docs 2 3;
        (text_def 1) @ (text_def 2) @ _2 :: _3 )
# 7148 "parsing/parser.ml"
               : 'use_file_tail))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'structure_item) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'use_file_tail) in
    Obj.repr(
# 672 "parsing/parser.mly"
      ( (text_def 1) @ Ptop_def[_1] :: _2 )
# 7156 "parsing/parser.ml"
               : 'use_file_tail))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'toplevel_directive) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'use_file_tail) in
    Obj.repr(
# 674 "parsing/parser.mly"
      ( mark_rhs_docs 1 1;
        (text_def 1) @ _1 :: _2 )
# 7165 "parsing/parser.ml"
               : 'use_file_tail))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'core_type) in
    Obj.repr(
# 678 "parsing/parser.mly"
                  ( _1 )
# 7172 "parsing/parser.ml"
               : Parsetree.core_type))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in
    Obj.repr(
# 681 "parsing/parser.mly"
                 ( _1 )
# 7179 "parsing/parser.ml"
               : Parsetree.expression))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'pattern) in
    Obj.repr(
# 684 "parsing/parser.mly"
                ( _1 )
# 7186 "parsing/parser.ml"
               : Parsetree.pattern))
; (fun __caml_parser_env ->
    Obj.repr(
# 691 "parsing/parser.mly"
      ( mkrhs "*" 2, None )
# 7192 "parsing/parser.ml"
               : 'functor_arg))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'functor_arg_name) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'module_type) in
    Obj.repr(
# 693 "parsing/parser.mly"
      ( mkrhs _2 2, Some _4 )
# 7200 "parsing/parser.ml"
               : 'functor_arg))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 697 "parsing/parser.mly"
               ( _1 )
# 7207 "parsing/parser.ml"
               : 'functor_arg_name))
; (fun __caml_parser_env ->
    Obj.repr(
# 698 "parsing/parser.mly"
               ( "_" )
# 7213 "parsing/parser.ml"
               : 'functor_arg_name))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'functor_args) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'functor_arg) in
    Obj.repr(
# 703 "parsing/parser.mly"
      ( _2 :: _1 )
# 7221 "parsing/parser.ml"
               : 'functor_args))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'functor_arg) in
    Obj.repr(
# 705 "parsing/parser.mly"
      ( [ _1 ] )
# 7228 "parsing/parser.ml"
               : 'functor_args))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'mod_longident) in
    Obj.repr(
# 710 "parsing/parser.mly"
      ( mkmod(Pmod_ident (mkrhs _1 1)) )
# 7235 "parsing/parser.ml"
               : 'module_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'structure) in
    Obj.repr(
# 712 "parsing/parser.mly"
      ( mkmod ~attrs:_2 (Pmod_structure(extra_str 3 _3)) )
# 7243 "parsing/parser.ml"
               : 'module_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'structure) in
    Obj.repr(
# 714 "parsing/parser.mly"
      ( unclosed "struct" 1 "end" 4 )
# 7251 "parsing/parser.ml"
               : 'module_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'functor_args) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'module_expr) in
    Obj.repr(
# 716 "parsing/parser.mly"
      ( let modexp =
          List.fold_left
            (fun acc (n, t) -> mkmod(Pmod_functor(n, t, acc)))
            _5 _3
        in wrap_mod_attrs modexp _2 )
# 7264 "parsing/parser.ml"
               : 'module_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'module_expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'paren_module_expr) in
    Obj.repr(
# 722 "parsing/parser.mly"
      ( mkmod(Pmod_apply(_1, _2)) )
# 7272 "parsing/parser.ml"
               : 'module_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'module_expr) in
    Obj.repr(
# 724 "parsing/parser.mly"
      ( mkmod(Pmod_apply(_1, mkmod (Pmod_structure []))) )
# 7279 "parsing/parser.ml"
               : 'module_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'paren_module_expr) in
    Obj.repr(
# 726 "parsing/parser.mly"
      ( _1 )
# 7286 "parsing/parser.ml"
               : 'module_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'module_expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attribute) in
    Obj.repr(
# 728 "parsing/parser.mly"
      ( Mod.attr _1 _2 )
# 7294 "parsing/parser.ml"
               : 'module_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'extension) in
    Obj.repr(
# 730 "parsing/parser.mly"
      ( mkmod(Pmod_extension _1) )
# 7301 "parsing/parser.ml"
               : 'module_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'module_expr) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'module_type) in
    Obj.repr(
# 735 "parsing/parser.mly"
      ( mkmod(Pmod_constraint(_2, _4)) )
# 7309 "parsing/parser.ml"
               : 'paren_module_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'module_expr) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'module_type) in
    Obj.repr(
# 737 "parsing/parser.mly"
      ( unclosed "(" 1 ")" 5 )
# 7317 "parsing/parser.ml"
               : 'paren_module_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'module_expr) in
    Obj.repr(
# 739 "parsing/parser.mly"
      ( _2 )
# 7324 "parsing/parser.ml"
               : 'paren_module_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'module_expr) in
    Obj.repr(
# 741 "parsing/parser.mly"
      ( unclosed "(" 1 ")" 3 )
# 7331 "parsing/parser.ml"
               : 'paren_module_expr))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in
    Obj.repr(
# 743 "parsing/parser.mly"
      ( mkmod ~attrs:_3 (Pmod_unpack _4))
# 7339 "parsing/parser.ml"
               : 'paren_module_expr))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : 'expr) in
    let _6 = (Parsing.peek_val __caml_parser_env 1 : 'package_type) in
    Obj.repr(
# 745 "parsing/parser.mly"
      ( mkmod ~attrs:_3
          (Pmod_unpack(
               ghexp(Pexp_constraint(_4, ghtyp(Ptyp_package _6))))) )
# 7350 "parsing/parser.ml"
               : 'paren_module_expr))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 6 : 'attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 5 : 'expr) in
    let _6 = (Parsing.peek_val __caml_parser_env 3 : 'package_type) in
    let _8 = (Parsing.peek_val __caml_parser_env 1 : 'package_type) in
    Obj.repr(
# 750 "parsing/parser.mly"
      ( mkmod ~attrs:_3
          (Pmod_unpack(
               ghexp(Pexp_coerce(_4, Some(ghtyp(Ptyp_package _6)),
                                 ghtyp(Ptyp_package _8))))) )
# 7363 "parsing/parser.ml"
               : 'paren_module_expr))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : 'expr) in
    let _6 = (Parsing.peek_val __caml_parser_env 1 : 'package_type) in
    Obj.repr(
# 755 "parsing/parser.mly"
      ( mkmod ~attrs:_3
          (Pmod_unpack(
               ghexp(Pexp_coerce(_4, None, ghtyp(Ptyp_package _6))))) )
# 7374 "parsing/parser.ml"
               : 'paren_module_expr))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 3 : 'attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    Obj.repr(
# 759 "parsing/parser.mly"
      ( unclosed "(" 1 ")" 6 )
# 7382 "parsing/parser.ml"
               : 'paren_module_expr))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 3 : 'attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    Obj.repr(
# 761 "parsing/parser.mly"
      ( unclosed "(" 1 ")" 6 )
# 7390 "parsing/parser.ml"
               : 'paren_module_expr))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in
    Obj.repr(
# 763 "parsing/parser.mly"
      ( unclosed "(" 1 ")" 5 )
# 7398 "parsing/parser.ml"
               : 'paren_module_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'seq_expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'post_item_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'structure_tail) in
    Obj.repr(
# 768 "parsing/parser.mly"
      ( mark_rhs_docs 1 2;
        (text_str 1) @ mkstrexp _1 _2 :: _3 )
# 7408 "parsing/parser.ml"
               : 'structure))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'structure_tail) in
    Obj.repr(
# 770 "parsing/parser.mly"
                   ( _1 )
# 7415 "parsing/parser.ml"
               : 'structure))
; (fun __caml_parser_env ->
    Obj.repr(
# 773 "parsing/parser.mly"
                         ( [] )
# 7421 "parsing/parser.ml"
               : 'structure_tail))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'structure) in
    Obj.repr(
# 774 "parsing/parser.mly"
                         ( (text_str 1) @ _2 )
# 7428 "parsing/parser.ml"
               : 'structure_tail))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'structure_item) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'structure_tail) in
    Obj.repr(
# 775 "parsing/parser.mly"
                                  ( (text_str 1) @ _1 :: _2 )
# 7436 "parsing/parser.ml"
               : 'structure_tail))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'let_bindings) in
    Obj.repr(
# 779 "parsing/parser.mly"
      ( val_of_let_bindings _1 )
# 7443 "parsing/parser.ml"
               : 'structure_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'primitive_declaration) in
    Obj.repr(
# 781 "parsing/parser.mly"
      ( let (body, ext) = _1 in mkstr_ext (Pstr_primitive body) ext )
# 7450 "parsing/parser.ml"
               : 'structure_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'value_description) in
    Obj.repr(
# 783 "parsing/parser.mly"
      ( let (body, ext) = _1 in mkstr_ext (Pstr_primitive body) ext )
# 7457 "parsing/parser.ml"
               : 'structure_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'type_declarations) in
    Obj.repr(
# 785 "parsing/parser.mly"
      ( let (nr, l, ext ) = _1 in mkstr_ext (Pstr_type (nr, List.rev l)) ext )
# 7464 "parsing/parser.ml"
               : 'structure_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'str_type_extension) in
    Obj.repr(
# 787 "parsing/parser.mly"
      ( let (l, ext) = _1 in mkstr_ext (Pstr_typext l) ext )
# 7471 "parsing/parser.ml"
               : 'structure_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'str_exception_declaration) in
    Obj.repr(
# 789 "parsing/parser.mly"
      ( let (l, ext) = _1 in mkstr_ext (Pstr_exception l) ext )
# 7478 "parsing/parser.ml"
               : 'structure_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'module_binding) in
    Obj.repr(
# 791 "parsing/parser.mly"
      ( let (body, ext) = _1 in mkstr_ext (Pstr_module body) ext )
# 7485 "parsing/parser.ml"
               : 'structure_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rec_module_bindings) in
    Obj.repr(
# 793 "parsing/parser.mly"
      ( let (l, ext) = _1 in mkstr_ext (Pstr_recmodule(List.rev l)) ext )
# 7492 "parsing/parser.ml"
               : 'structure_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'module_type_declaration) in
    Obj.repr(
# 795 "parsing/parser.mly"
      ( let (body, ext) = _1 in mkstr_ext (Pstr_modtype body) ext )
# 7499 "parsing/parser.ml"
               : 'structure_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'open_statement) in
    Obj.repr(
# 797 "parsing/parser.mly"
      ( let (body, ext) = _1 in mkstr_ext (Pstr_open body) ext )
# 7506 "parsing/parser.ml"
               : 'structure_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'class_declarations) in
    Obj.repr(
# 799 "parsing/parser.mly"
      ( let (l, ext) = _1 in mkstr_ext (Pstr_class (List.rev l)) ext )
# 7513 "parsing/parser.ml"
               : 'structure_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'class_type_declarations) in
    Obj.repr(
# 801 "parsing/parser.mly"
      ( let (l, ext) = _1 in mkstr_ext (Pstr_class_type (List.rev l)) ext )
# 7520 "parsing/parser.ml"
               : 'structure_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'str_include_statement) in
    Obj.repr(
# 803 "parsing/parser.mly"
      ( let (body, ext) = _1 in mkstr_ext (Pstr_include body) ext )
# 7527 "parsing/parser.ml"
               : 'structure_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'item_extension) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 805 "parsing/parser.mly"
      ( mkstr(Pstr_extension (_1, (add_docs_attrs (symbol_docs ()) _2))) )
# 7535 "parsing/parser.ml"
               : 'structure_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'floating_attribute) in
    Obj.repr(
# 807 "parsing/parser.mly"
      ( mark_symbol_docs ();
        mkstr(Pstr_attribute _1) )
# 7543 "parsing/parser.ml"
               : 'structure_item))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'module_expr) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 812 "parsing/parser.mly"
      ( let (ext, attrs) = _2 in
        Incl.mk _3 ~attrs:(attrs@_4)
            ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
      , ext )
# 7555 "parsing/parser.ml"
               : 'str_include_statement))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'module_expr) in
    Obj.repr(
# 819 "parsing/parser.mly"
      ( _2 )
# 7562 "parsing/parser.ml"
               : 'module_binding_body))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'module_type) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'module_expr) in
    Obj.repr(
# 821 "parsing/parser.mly"
      ( mkmod(Pmod_constraint(_4, _2)) )
# 7570 "parsing/parser.ml"
               : 'module_binding_body))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'functor_arg) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'module_binding_body) in
    Obj.repr(
# 823 "parsing/parser.mly"
      ( mkmod(Pmod_functor(fst _1, snd _1, _2)) )
# 7578 "parsing/parser.ml"
               : 'module_binding_body))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 2 : string) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'module_binding_body) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 827 "parsing/parser.mly"
      ( let (ext, attrs) = _2 in
        Mb.mk (mkrhs _3 3) _4 ~attrs:(attrs@_5)
            ~loc:(symbol_rloc ()) ~docs:(symbol_docs ())
      , ext )
# 7591 "parsing/parser.ml"
               : 'module_binding))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rec_module_binding) in
    Obj.repr(
# 833 "parsing/parser.mly"
                                           ( let (b, ext) = _1 in ([b], ext) )
# 7598 "parsing/parser.ml"
               : 'rec_module_bindings))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rec_module_bindings) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'and_module_binding) in
    Obj.repr(
# 835 "parsing/parser.mly"
      ( let (l, ext) = _1 in (_2 :: l, ext) )
# 7606 "parsing/parser.ml"
               : 'rec_module_bindings))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 2 : string) in
    let _5 = (Parsing.peek_val __caml_parser_env 1 : 'module_binding_body) in
    let _6 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 839 "parsing/parser.mly"
      ( let (ext, attrs) = _2 in
        Mb.mk (mkrhs _4 4) _5 ~attrs:(attrs@_6)
            ~loc:(symbol_rloc ()) ~docs:(symbol_docs ())
      , ext )
# 7619 "parsing/parser.ml"
               : 'rec_module_binding))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 2 : string) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'module_binding_body) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 846 "parsing/parser.mly"
      ( Mb.mk (mkrhs _3 3) _4 ~attrs:(_2@_5) ~loc:(symbol_rloc ())
               ~text:(symbol_text ()) ~docs:(symbol_docs ()) )
# 7630 "parsing/parser.ml"
               : 'and_module_binding))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'mty_longident) in
    Obj.repr(
# 854 "parsing/parser.mly"
      ( mkmty(Pmty_ident (mkrhs _1 1)) )
# 7637 "parsing/parser.ml"
               : 'module_type))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'signature) in
    Obj.repr(
# 856 "parsing/parser.mly"
      ( mkmty ~attrs:_2 (Pmty_signature (extra_sig 3 _3)) )
# 7645 "parsing/parser.ml"
               : 'module_type))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'signature) in
    Obj.repr(
# 858 "parsing/parser.mly"
      ( unclosed "sig" 1 "end" 4 )
# 7653 "parsing/parser.ml"
               : 'module_type))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'functor_args) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'module_type) in
    Obj.repr(
# 861 "parsing/parser.mly"
      ( let mty =
          List.fold_left
            (fun acc (n, t) -> mkmty(Pmty_functor(n, t, acc)))
            _5 _3
        in wrap_mty_attrs mty _2 )
# 7666 "parsing/parser.ml"
               : 'module_type))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'module_type) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'module_type) in
    Obj.repr(
# 868 "parsing/parser.mly"
      ( mkmty(Pmty_functor(mknoloc "_", Some _1, _3)) )
# 7674 "parsing/parser.ml"
               : 'module_type))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'module_type) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'with_constraints) in
    Obj.repr(
# 870 "parsing/parser.mly"
      ( mkmty(Pmty_with(_1, List.rev _3)) )
# 7682 "parsing/parser.ml"
               : 'module_type))
; (fun __caml_parser_env ->
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'attributes) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'module_expr) in
    Obj.repr(
# 872 "parsing/parser.mly"
      ( mkmty ~attrs:_4 (Pmty_typeof _5) )
# 7690 "parsing/parser.ml"
               : 'module_type))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'module_type) in
    Obj.repr(
# 876 "parsing/parser.mly"
      ( _2 )
# 7697 "parsing/parser.ml"
               : 'module_type))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'module_type) in
    Obj.repr(
# 878 "parsing/parser.mly"
      ( unclosed "(" 1 ")" 3 )
# 7704 "parsing/parser.ml"
               : 'module_type))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'extension) in
    Obj.repr(
# 880 "parsing/parser.mly"
      ( mkmty(Pmty_extension _1) )
# 7711 "parsing/parser.ml"
               : 'module_type))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'module_type) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attribute) in
    Obj.repr(
# 882 "parsing/parser.mly"
      ( Mty.attr _1 _2 )
# 7719 "parsing/parser.ml"
               : 'module_type))
; (fun __caml_parser_env ->
    Obj.repr(
# 885 "parsing/parser.mly"
                         ( [] )
# 7725 "parsing/parser.ml"
               : 'signature))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'signature) in
    Obj.repr(
# 886 "parsing/parser.mly"
                         ( (text_sig 1) @ _2 )
# 7732 "parsing/parser.ml"
               : 'signature))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'signature_item) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'signature) in
    Obj.repr(
# 887 "parsing/parser.mly"
                             ( (text_sig 1) @ _1 :: _2 )
# 7740 "parsing/parser.ml"
               : 'signature))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'value_description) in
    Obj.repr(
# 891 "parsing/parser.mly"
      ( let (body, ext) = _1 in mksig_ext (Psig_value body) ext )
# 7747 "parsing/parser.ml"
               : 'signature_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'primitive_declaration) in
    Obj.repr(
# 893 "parsing/parser.mly"
      ( let (body, ext) = _1 in mksig_ext (Psig_value body) ext)
# 7754 "parsing/parser.ml"
               : 'signature_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'type_declarations) in
    Obj.repr(
# 895 "parsing/parser.mly"
      ( let (nr, l, ext) = _1 in mksig_ext (Psig_type (nr, List.rev l)) ext )
# 7761 "parsing/parser.ml"
               : 'signature_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'sig_type_extension) in
    Obj.repr(
# 897 "parsing/parser.mly"
      ( let (l, ext) = _1 in mksig_ext (Psig_typext l) ext )
# 7768 "parsing/parser.ml"
               : 'signature_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'sig_exception_declaration) in
    Obj.repr(
# 899 "parsing/parser.mly"
      ( let (l, ext) = _1 in mksig_ext (Psig_exception l) ext )
# 7775 "parsing/parser.ml"
               : 'signature_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'module_declaration) in
    Obj.repr(
# 901 "parsing/parser.mly"
      ( let (body, ext) = _1 in mksig_ext (Psig_module body) ext )
# 7782 "parsing/parser.ml"
               : 'signature_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'module_alias) in
    Obj.repr(
# 903 "parsing/parser.mly"
      ( let (body, ext) = _1 in mksig_ext (Psig_module body) ext )
# 7789 "parsing/parser.ml"
               : 'signature_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rec_module_declarations) in
    Obj.repr(
# 905 "parsing/parser.mly"
      ( let (l, ext) = _1 in mksig_ext (Psig_recmodule (List.rev l)) ext )
# 7796 "parsing/parser.ml"
               : 'signature_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'module_type_declaration) in
    Obj.repr(
# 907 "parsing/parser.mly"
      ( let (body, ext) = _1 in mksig_ext (Psig_modtype body) ext )
# 7803 "parsing/parser.ml"
               : 'signature_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'open_statement) in
    Obj.repr(
# 909 "parsing/parser.mly"
      ( let (body, ext) = _1 in mksig_ext (Psig_open body) ext )
# 7810 "parsing/parser.ml"
               : 'signature_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'sig_include_statement) in
    Obj.repr(
# 911 "parsing/parser.mly"
      ( let (body, ext) = _1 in mksig_ext (Psig_include body) ext )
# 7817 "parsing/parser.ml"
               : 'signature_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'class_descriptions) in
    Obj.repr(
# 913 "parsing/parser.mly"
      ( let (l, ext) = _1 in mksig_ext (Psig_class (List.rev l)) ext )
# 7824 "parsing/parser.ml"
               : 'signature_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'class_type_declarations) in
    Obj.repr(
# 915 "parsing/parser.mly"
      ( let (l, ext) = _1 in mksig_ext (Psig_class_type (List.rev l)) ext )
# 7831 "parsing/parser.ml"
               : 'signature_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'item_extension) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 917 "parsing/parser.mly"
      ( mksig(Psig_extension (_1, (add_docs_attrs (symbol_docs ()) _2))) )
# 7839 "parsing/parser.ml"
               : 'signature_item))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'floating_attribute) in
    Obj.repr(
# 919 "parsing/parser.mly"
      ( mark_symbol_docs ();
        mksig(Psig_attribute _1) )
# 7847 "parsing/parser.ml"
               : 'signature_item))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'override_flag) in
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'mod_longident) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 924 "parsing/parser.mly"
      ( let (ext, attrs) = _3 in
        Opn.mk (mkrhs _4 4) ~override:_2 ~attrs:(attrs@_5)
          ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
      , ext)
# 7860 "parsing/parser.ml"
               : 'open_statement))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'module_type) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 931 "parsing/parser.mly"
      ( let (ext, attrs) = _2 in
        Incl.mk _3 ~attrs:(attrs@_4)
            ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
      , ext)
# 7872 "parsing/parser.ml"
               : 'sig_include_statement))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'module_type) in
    Obj.repr(
# 938 "parsing/parser.mly"
      ( _2 )
# 7879 "parsing/parser.ml"
               : 'module_declaration_body))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 4 : string) in
    let _4 = (Parsing.peek_val __caml_parser_env 2 : 'module_type) in
    let _6 = (Parsing.peek_val __caml_parser_env 0 : 'module_declaration_body) in
    Obj.repr(
# 940 "parsing/parser.mly"
      ( mkmty(Pmty_functor(mkrhs _2 2, Some _4, _6)) )
# 7888 "parsing/parser.ml"
               : 'module_declaration_body))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'module_declaration_body) in
    Obj.repr(
# 942 "parsing/parser.mly"
      ( mkmty(Pmty_functor(mkrhs "*" 1, None, _3)) )
# 7895 "parsing/parser.ml"
               : 'module_declaration_body))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 2 : string) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'module_declaration_body) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 946 "parsing/parser.mly"
      ( let (ext, attrs) = _2 in
        Md.mk (mkrhs _3 3) _4 ~attrs:(attrs@_5)
          ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
      , ext )
# 7908 "parsing/parser.ml"
               : 'module_declaration))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _5 = (Parsing.peek_val __caml_parser_env 1 : 'mod_longident) in
    let _6 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 953 "parsing/parser.mly"
      ( let (ext, attrs) = _2 in
        Md.mk (mkrhs _3 3)
          (Mty.alias ~loc:(rhs_loc 5) (mkrhs _5 5)) ~attrs:(attrs@_6)
             ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
      , ext )
# 7922 "parsing/parser.ml"
               : 'module_alias))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rec_module_declaration) in
    Obj.repr(
# 961 "parsing/parser.mly"
      ( let (body, ext) = _1 in ([body], ext) )
# 7929 "parsing/parser.ml"
               : 'rec_module_declarations))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rec_module_declarations) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'and_module_declaration) in
    Obj.repr(
# 963 "parsing/parser.mly"
      ( let (l, ext) = _1 in (_2 :: l, ext) )
# 7937 "parsing/parser.ml"
               : 'rec_module_declarations))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 5 : 'ext_attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _6 = (Parsing.peek_val __caml_parser_env 1 : 'module_type) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 967 "parsing/parser.mly"
      ( let (ext, attrs) = _2 in
        Md.mk (mkrhs _4 4) _6 ~attrs:(attrs@_7)
            ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
      , ext)
# 7950 "parsing/parser.ml"
               : 'rec_module_declaration))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 4 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _5 = (Parsing.peek_val __caml_parser_env 1 : 'module_type) in
    let _6 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 974 "parsing/parser.mly"
      ( Md.mk (mkrhs _3 3) _5 ~attrs:(_2@_6) ~loc:(symbol_rloc())
              ~text:(symbol_text()) ~docs:(symbol_docs()) )
# 7961 "parsing/parser.ml"
               : 'and_module_declaration))
; (fun __caml_parser_env ->
    Obj.repr(
# 978 "parsing/parser.mly"
                              ( None )
# 7967 "parsing/parser.ml"
               : 'module_type_declaration_body))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'module_type) in
    Obj.repr(
# 979 "parsing/parser.mly"
                              ( Some _2 )
# 7974 "parsing/parser.ml"
               : 'module_type_declaration_body))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 3 : 'ext_attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 2 : 'ident) in
    let _5 = (Parsing.peek_val __caml_parser_env 1 : 'module_type_declaration_body) in
    let _6 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 984 "parsing/parser.mly"
      ( let (ext, attrs) = _3 in
        Mtd.mk (mkrhs _4 4) ?typ:_5 ~attrs:(attrs@_6)
          ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
      , ext )
# 7987 "parsing/parser.ml"
               : 'module_type_declaration))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'class_declaration) in
    Obj.repr(
# 993 "parsing/parser.mly"
      ( let (body, ext) = _1 in ([body], ext) )
# 7994 "parsing/parser.ml"
               : 'class_declarations))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'class_declarations) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'and_class_declaration) in
    Obj.repr(
# 995 "parsing/parser.mly"
      ( let (l, ext) = _1 in (_2 :: l, ext) )
# 8002 "parsing/parser.ml"
               : 'class_declarations))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 5 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'virtual_flag) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : 'class_type_parameters) in
    let _5 = (Parsing.peek_val __caml_parser_env 2 : string) in
    let _6 = (Parsing.peek_val __caml_parser_env 1 : 'class_fun_binding) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1000 "parsing/parser.mly"
      ( let (ext, attrs) = _2 in
        Ci.mk (mkrhs _5 5) _6 ~virt:_3 ~params:_4 ~attrs:(attrs@_7)
            ~loc:(symbol_rloc ()) ~docs:(symbol_docs ())
      , ext )
# 8017 "parsing/parser.ml"
               : 'class_declaration))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 5 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'virtual_flag) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : 'class_type_parameters) in
    let _5 = (Parsing.peek_val __caml_parser_env 2 : string) in
    let _6 = (Parsing.peek_val __caml_parser_env 1 : 'class_fun_binding) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1008 "parsing/parser.mly"
      ( Ci.mk (mkrhs _5 5) _6 ~virt:_3 ~params:_4
         ~attrs:(_2@_7) ~loc:(symbol_rloc ())
         ~text:(symbol_text ()) ~docs:(symbol_docs ()) )
# 8031 "parsing/parser.ml"
               : 'and_class_declaration))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'class_expr) in
    Obj.repr(
# 1014 "parsing/parser.mly"
      ( _2 )
# 8038 "parsing/parser.ml"
               : 'class_fun_binding))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'class_type) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'class_expr) in
    Obj.repr(
# 1016 "parsing/parser.mly"
      ( mkclass(Pcl_constraint(_4, _2)) )
# 8046 "parsing/parser.ml"
               : 'class_fun_binding))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'labeled_simple_pattern) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'class_fun_binding) in
    Obj.repr(
# 1018 "parsing/parser.mly"
      ( let (l,o,p) = _1 in mkclass(Pcl_fun(l, o, p, _2)) )
# 8054 "parsing/parser.ml"
               : 'class_fun_binding))
; (fun __caml_parser_env ->
    Obj.repr(
# 1021 "parsing/parser.mly"
                                                ( [] )
# 8060 "parsing/parser.ml"
               : 'class_type_parameters))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'type_parameter_list) in
    Obj.repr(
# 1022 "parsing/parser.mly"
                                                ( List.rev _2 )
# 8067 "parsing/parser.ml"
               : 'class_type_parameters))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'labeled_simple_pattern) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'class_expr) in
    Obj.repr(
# 1026 "parsing/parser.mly"
      ( let (l,o,p) = _1 in mkclass(Pcl_fun(l, o, p, _3)) )
# 8075 "parsing/parser.ml"
               : 'class_fun_def))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'labeled_simple_pattern) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'class_fun_def) in
    Obj.repr(
# 1028 "parsing/parser.mly"
      ( let (l,o,p) = _1 in mkclass(Pcl_fun(l, o, p, _2)) )
# 8083 "parsing/parser.ml"
               : 'class_fun_def))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'class_simple_expr) in
    Obj.repr(
# 1032 "parsing/parser.mly"
      ( _1 )
# 8090 "parsing/parser.ml"
               : 'class_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'class_fun_def) in
    Obj.repr(
# 1034 "parsing/parser.mly"
      ( wrap_class_attrs _3 _2 )
# 8098 "parsing/parser.ml"
               : 'class_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'class_simple_expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'simple_labeled_expr_list) in
    Obj.repr(
# 1036 "parsing/parser.mly"
      ( mkclass(Pcl_apply(_1, List.rev _2)) )
# 8106 "parsing/parser.ml"
               : 'class_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'let_bindings) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'class_expr) in
    Obj.repr(
# 1038 "parsing/parser.mly"
      ( class_of_let_bindings _1 _3 )
# 8114 "parsing/parser.ml"
               : 'class_expr))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'override_flag) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : 'attributes) in
    let _5 = (Parsing.peek_val __caml_parser_env 2 : 'mod_longident) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'class_expr) in
    Obj.repr(
# 1040 "parsing/parser.mly"
      ( wrap_class_attrs (mkclass(Pcl_open(_3, mkrhs _5 5, _7))) _4 )
# 8124 "parsing/parser.ml"
               : 'class_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'class_expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attribute) in
    Obj.repr(
# 1042 "parsing/parser.mly"
      ( Cl.attr _1 _2 )
# 8132 "parsing/parser.ml"
               : 'class_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'extension) in
    Obj.repr(
# 1044 "parsing/parser.mly"
      ( mkclass(Pcl_extension _1) )
# 8139 "parsing/parser.ml"
               : 'class_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'core_type_comma_list) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'class_longident) in
    Obj.repr(
# 1048 "parsing/parser.mly"
      ( mkclass(Pcl_constr(mkloc _4 (rhs_loc 4), List.rev _2)) )
# 8147 "parsing/parser.ml"
               : 'class_simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'class_longident) in
    Obj.repr(
# 1050 "parsing/parser.mly"
      ( mkclass(Pcl_constr(mkrhs _1 1, [])) )
# 8154 "parsing/parser.ml"
               : 'class_simple_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'class_structure) in
    Obj.repr(
# 1052 "parsing/parser.mly"
      ( mkclass ~attrs:_2 (Pcl_structure _3) )
# 8162 "parsing/parser.ml"
               : 'class_simple_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'class_structure) in
    Obj.repr(
# 1054 "parsing/parser.mly"
      ( unclosed "object" 1 "end" 4 )
# 8170 "parsing/parser.ml"
               : 'class_simple_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'class_expr) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'class_type) in
    Obj.repr(
# 1056 "parsing/parser.mly"
      ( mkclass(Pcl_constraint(_2, _4)) )
# 8178 "parsing/parser.ml"
               : 'class_simple_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'class_expr) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'class_type) in
    Obj.repr(
# 1058 "parsing/parser.mly"
      ( unclosed "(" 1 ")" 5 )
# 8186 "parsing/parser.ml"
               : 'class_simple_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'class_expr) in
    Obj.repr(
# 1060 "parsing/parser.mly"
      ( _2 )
# 8193 "parsing/parser.ml"
               : 'class_simple_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'class_expr) in
    Obj.repr(
# 1062 "parsing/parser.mly"
      ( unclosed "(" 1 ")" 3 )
# 8200 "parsing/parser.ml"
               : 'class_simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'class_self_pattern) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'class_fields) in
    Obj.repr(
# 1066 "parsing/parser.mly"
       ( Cstr.mk _1 (extra_cstr 2 (List.rev _2)) )
# 8208 "parsing/parser.ml"
               : 'class_structure))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'pattern) in
    Obj.repr(
# 1070 "parsing/parser.mly"
      ( reloc_pat _2 )
# 8215 "parsing/parser.ml"
               : 'class_self_pattern))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'pattern) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'core_type) in
    Obj.repr(
# 1072 "parsing/parser.mly"
      ( mkpat(Ppat_constraint(_2, _4)) )
# 8223 "parsing/parser.ml"
               : 'class_self_pattern))
; (fun __caml_parser_env ->
    Obj.repr(
# 1074 "parsing/parser.mly"
      ( ghpat(Ppat_any) )
# 8229 "parsing/parser.ml"
               : 'class_self_pattern))
; (fun __caml_parser_env ->
    Obj.repr(
# 1078 "parsing/parser.mly"
      ( [] )
# 8235 "parsing/parser.ml"
               : 'class_fields))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'class_fields) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'class_field) in
    Obj.repr(
# 1080 "parsing/parser.mly"
      ( _2 :: (text_cstr 2) @ _1 )
# 8243 "parsing/parser.ml"
               : 'class_fields))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 4 : 'override_flag) in
    let _3 = (Parsing.peek_val __caml_parser_env 3 : 'attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 2 : 'class_expr) in
    let _5 = (Parsing.peek_val __caml_parser_env 1 : 'parent_binder) in
    let _6 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1085 "parsing/parser.mly"
      ( mkcf (Pcf_inherit (_2, _4, _5)) ~attrs:(_3@_6) ~docs:(symbol_docs ()) )
# 8254 "parsing/parser.ml"
               : 'class_field))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'value) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1087 "parsing/parser.mly"
      ( let v, attrs = _2 in
        mkcf (Pcf_val v) ~attrs:(attrs@_3) ~docs:(symbol_docs ()) )
# 8263 "parsing/parser.ml"
               : 'class_field))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'method_) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1090 "parsing/parser.mly"
      ( let meth, attrs = _2 in
        mkcf (Pcf_method meth) ~attrs:(attrs@_3) ~docs:(symbol_docs ()) )
# 8272 "parsing/parser.ml"
               : 'class_field))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'constrain_field) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1093 "parsing/parser.mly"
      ( mkcf (Pcf_constraint _3) ~attrs:(_2@_4) ~docs:(symbol_docs ()) )
# 8281 "parsing/parser.ml"
               : 'class_field))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1095 "parsing/parser.mly"
      ( mkcf (Pcf_initializer _3) ~attrs:(_2@_4) ~docs:(symbol_docs ()) )
# 8290 "parsing/parser.ml"
               : 'class_field))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'item_extension) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1097 "parsing/parser.mly"
      ( mkcf (Pcf_extension _1) ~attrs:_2 ~docs:(symbol_docs ()) )
# 8298 "parsing/parser.ml"
               : 'class_field))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'floating_attribute) in
    Obj.repr(
# 1099 "parsing/parser.mly"
      ( mark_symbol_docs ();
        mkcf (Pcf_attribute _1) )
# 8306 "parsing/parser.ml"
               : 'class_field))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 1104 "parsing/parser.mly"
          ( Some (mkrhs _2 2) )
# 8313 "parsing/parser.ml"
               : 'parent_binder))
; (fun __caml_parser_env ->
    Obj.repr(
# 1106 "parsing/parser.mly"
          ( None )
# 8319 "parsing/parser.ml"
               : 'parent_binder))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 6 : 'override_flag) in
    let _2 = (Parsing.peek_val __caml_parser_env 5 : 'attributes) in
    let _5 = (Parsing.peek_val __caml_parser_env 2 : 'label) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in
    Obj.repr(
# 1111 "parsing/parser.mly"
      ( if _1 = Override then syntax_error ();
        (mkloc _5 (rhs_loc 5), Mutable, Cfk_virtual _7), _2 )
# 8330 "parsing/parser.ml"
               : 'value))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 6 : 'override_flag) in
    let _2 = (Parsing.peek_val __caml_parser_env 5 : 'attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : 'mutable_flag) in
    let _5 = (Parsing.peek_val __caml_parser_env 2 : 'label) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in
    Obj.repr(
# 1114 "parsing/parser.mly"
      ( if _1 = Override then syntax_error ();
        (mkrhs _5 5, _4, Cfk_virtual _7), _2 )
# 8342 "parsing/parser.ml"
               : 'value))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 5 : 'override_flag) in
    let _2 = (Parsing.peek_val __caml_parser_env 4 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 3 : 'mutable_flag) in
    let _4 = (Parsing.peek_val __caml_parser_env 2 : 'label) in
    let _6 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 1117 "parsing/parser.mly"
      ( (mkrhs _4 4, _3, Cfk_concrete (_1, _6)), _2 )
# 8353 "parsing/parser.ml"
               : 'value))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 6 : 'override_flag) in
    let _2 = (Parsing.peek_val __caml_parser_env 5 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'mutable_flag) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : 'label) in
    let _5 = (Parsing.peek_val __caml_parser_env 2 : 'type_constraint) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 1119 "parsing/parser.mly"
      (
       let e = mkexp_constraint _7 _5 in
       (mkrhs _4 4, _3, Cfk_concrete (_1, e)), _2
      )
# 8368 "parsing/parser.ml"
               : 'value))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 6 : 'override_flag) in
    let _2 = (Parsing.peek_val __caml_parser_env 5 : 'attributes) in
    let _5 = (Parsing.peek_val __caml_parser_env 2 : 'label) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'poly_type) in
    Obj.repr(
# 1127 "parsing/parser.mly"
      ( if _1 = Override then syntax_error ();
        (mkloc _5 (rhs_loc 5), Private, Cfk_virtual _7), _2 )
# 8379 "parsing/parser.ml"
               : 'method_))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 6 : 'override_flag) in
    let _2 = (Parsing.peek_val __caml_parser_env 5 : 'attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : 'private_flag) in
    let _5 = (Parsing.peek_val __caml_parser_env 2 : 'label) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'poly_type) in
    Obj.repr(
# 1130 "parsing/parser.mly"
      ( if _1 = Override then syntax_error ();
        (mkloc _5 (rhs_loc 5), _4, Cfk_virtual _7), _2 )
# 8391 "parsing/parser.ml"
               : 'method_))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'override_flag) in
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'private_flag) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'label) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'strict_binding) in
    Obj.repr(
# 1133 "parsing/parser.mly"
      ( (mkloc _4 (rhs_loc 4), _3,
        Cfk_concrete (_1, ghexp(Pexp_poly (_5, None)))), _2 )
# 8403 "parsing/parser.ml"
               : 'method_))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 7 : 'override_flag) in
    let _2 = (Parsing.peek_val __caml_parser_env 6 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 5 : 'private_flag) in
    let _4 = (Parsing.peek_val __caml_parser_env 4 : 'label) in
    let _6 = (Parsing.peek_val __caml_parser_env 2 : 'poly_type) in
    let _8 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 1136 "parsing/parser.mly"
      ( (mkloc _4 (rhs_loc 4), _3,
        Cfk_concrete (_1, ghexp(Pexp_poly(_8, Some _6)))), _2 )
# 8416 "parsing/parser.ml"
               : 'method_))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 10 : 'override_flag) in
    let _2 = (Parsing.peek_val __caml_parser_env 9 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 8 : 'private_flag) in
    let _4 = (Parsing.peek_val __caml_parser_env 7 : 'label) in
    let _7 = (Parsing.peek_val __caml_parser_env 4 : 'lident_list) in
    let _9 = (Parsing.peek_val __caml_parser_env 2 : 'core_type) in
    let _11 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 1140 "parsing/parser.mly"
      ( let exp, poly = wrap_type_annotation _7 _9 _11 in
        (mkloc _4 (rhs_loc 4), _3,
        Cfk_concrete (_1, ghexp(Pexp_poly(exp, Some poly)))), _2 )
# 8431 "parsing/parser.ml"
               : 'method_))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'class_signature) in
    Obj.repr(
# 1149 "parsing/parser.mly"
      ( _1 )
# 8438 "parsing/parser.ml"
               : 'class_type))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 4 : string) in
    let _4 = (Parsing.peek_val __caml_parser_env 2 : 'simple_core_type_or_tuple) in
    let _6 = (Parsing.peek_val __caml_parser_env 0 : 'class_type) in
    Obj.repr(
# 1152 "parsing/parser.mly"
      ( mkcty(Pcty_arrow(Optional _2 , _4, _6)) )
# 8447 "parsing/parser.ml"
               : 'class_type))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'simple_core_type_or_tuple) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'class_type) in
    Obj.repr(
# 1154 "parsing/parser.mly"
      ( mkcty(Pcty_arrow(Optional _1, _2, _4)) )
# 8456 "parsing/parser.ml"
               : 'class_type))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : string) in
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'simple_core_type_or_tuple) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'class_type) in
    Obj.repr(
# 1156 "parsing/parser.mly"
      ( mkcty(Pcty_arrow(Labelled _1, _3, _5)) )
# 8465 "parsing/parser.ml"
               : 'class_type))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'simple_core_type_or_tuple) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'class_type) in
    Obj.repr(
# 1158 "parsing/parser.mly"
      ( mkcty(Pcty_arrow(Nolabel, _1, _3)) )
# 8473 "parsing/parser.ml"
               : 'class_type))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'core_type_comma_list) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'clty_longident) in
    Obj.repr(
# 1162 "parsing/parser.mly"
      ( mkcty(Pcty_constr (mkloc _4 (rhs_loc 4), List.rev _2)) )
# 8481 "parsing/parser.ml"
               : 'class_signature))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'clty_longident) in
    Obj.repr(
# 1164 "parsing/parser.mly"
      ( mkcty(Pcty_constr (mkrhs _1 1, [])) )
# 8488 "parsing/parser.ml"
               : 'class_signature))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'class_sig_body) in
    Obj.repr(
# 1166 "parsing/parser.mly"
      ( mkcty ~attrs:_2 (Pcty_signature _3) )
# 8496 "parsing/parser.ml"
               : 'class_signature))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'class_sig_body) in
    Obj.repr(
# 1168 "parsing/parser.mly"
      ( unclosed "object" 1 "end" 4 )
# 8504 "parsing/parser.ml"
               : 'class_signature))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'class_signature) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attribute) in
    Obj.repr(
# 1170 "parsing/parser.mly"
      ( Cty.attr _1 _2 )
# 8512 "parsing/parser.ml"
               : 'class_signature))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'extension) in
    Obj.repr(
# 1172 "parsing/parser.mly"
      ( mkcty(Pcty_extension _1) )
# 8519 "parsing/parser.ml"
               : 'class_signature))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'override_flag) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : 'attributes) in
    let _5 = (Parsing.peek_val __caml_parser_env 2 : 'mod_longident) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'class_signature) in
    Obj.repr(
# 1174 "parsing/parser.mly"
      ( wrap_class_type_attrs (mkcty(Pcty_open(_3, mkrhs _5 5, _7))) _4 )
# 8529 "parsing/parser.ml"
               : 'class_signature))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'class_self_type) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'class_sig_fields) in
    Obj.repr(
# 1178 "parsing/parser.mly"
      ( Csig.mk _1 (extra_csig 2 (List.rev _2)) )
# 8537 "parsing/parser.ml"
               : 'class_sig_body))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'core_type) in
    Obj.repr(
# 1182 "parsing/parser.mly"
      ( _2 )
# 8544 "parsing/parser.ml"
               : 'class_self_type))
; (fun __caml_parser_env ->
    Obj.repr(
# 1184 "parsing/parser.mly"
      ( mktyp(Ptyp_any) )
# 8550 "parsing/parser.ml"
               : 'class_self_type))
; (fun __caml_parser_env ->
    Obj.repr(
# 1187 "parsing/parser.mly"
                                                ( [] )
# 8556 "parsing/parser.ml"
               : 'class_sig_fields))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'class_sig_fields) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'class_sig_field) in
    Obj.repr(
# 1188 "parsing/parser.mly"
                                       ( _2 :: (text_csig 2) @ _1 )
# 8564 "parsing/parser.ml"
               : 'class_sig_fields))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'class_signature) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1192 "parsing/parser.mly"
      ( mkctf (Pctf_inherit _3) ~attrs:(_2@_4) ~docs:(symbol_docs ()) )
# 8573 "parsing/parser.ml"
               : 'class_sig_field))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'value_type) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1194 "parsing/parser.mly"
      ( mkctf (Pctf_val _3) ~attrs:(_2@_4) ~docs:(symbol_docs ()) )
# 8582 "parsing/parser.ml"
               : 'class_sig_field))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 5 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'private_virtual_flags) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : 'label) in
    let _6 = (Parsing.peek_val __caml_parser_env 1 : 'poly_type) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1197 "parsing/parser.mly"
      (
       let (p, v) = _3 in
       mkctf (Pctf_method (mkrhs _4 4, p, v, _6)) ~attrs:(_2@_7) ~docs:(symbol_docs ())
      )
# 8596 "parsing/parser.ml"
               : 'class_sig_field))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'constrain_field) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1202 "parsing/parser.mly"
      ( mkctf (Pctf_constraint _3) ~attrs:(_2@_4) ~docs:(symbol_docs ()) )
# 8605 "parsing/parser.ml"
               : 'class_sig_field))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'item_extension) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1204 "parsing/parser.mly"
      ( mkctf (Pctf_extension _1) ~attrs:_2 ~docs:(symbol_docs ()) )
# 8613 "parsing/parser.ml"
               : 'class_sig_field))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'floating_attribute) in
    Obj.repr(
# 1206 "parsing/parser.mly"
      ( mark_symbol_docs ();
        mkctf(Pctf_attribute _1) )
# 8621 "parsing/parser.ml"
               : 'class_sig_field))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'mutable_flag) in
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'label) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in
    Obj.repr(
# 1211 "parsing/parser.mly"
      ( mkrhs _3 3, _2, Virtual, _5 )
# 8630 "parsing/parser.ml"
               : 'value_type))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'virtual_flag) in
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'label) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in
    Obj.repr(
# 1213 "parsing/parser.mly"
      ( mkrhs _3 3, Mutable, _2, _5 )
# 8639 "parsing/parser.ml"
               : 'value_type))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'label) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in
    Obj.repr(
# 1215 "parsing/parser.mly"
      ( mkrhs _1 1, Immutable, Concrete, _3 )
# 8647 "parsing/parser.ml"
               : 'value_type))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'core_type) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in
    Obj.repr(
# 1218 "parsing/parser.mly"
                                           ( _1, _3, symbol_rloc() )
# 8655 "parsing/parser.ml"
               : 'constrain))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'core_type) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in
    Obj.repr(
# 1221 "parsing/parser.mly"
                                           ( _1, _3 )
# 8663 "parsing/parser.ml"
               : 'constrain_field))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'class_description) in
    Obj.repr(
# 1225 "parsing/parser.mly"
      ( let (body, ext) = _1 in ([body],ext) )
# 8670 "parsing/parser.ml"
               : 'class_descriptions))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'class_descriptions) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'and_class_description) in
    Obj.repr(
# 1227 "parsing/parser.mly"
      ( let (l, ext) = _1 in (_2 :: l, ext) )
# 8678 "parsing/parser.ml"
               : 'class_descriptions))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 6 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 5 : 'virtual_flag) in
    let _4 = (Parsing.peek_val __caml_parser_env 4 : 'class_type_parameters) in
    let _5 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _7 = (Parsing.peek_val __caml_parser_env 1 : 'class_type) in
    let _8 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1232 "parsing/parser.mly"
      ( let (ext, attrs) = _2 in
        Ci.mk (mkrhs _5 5) _7 ~virt:_3 ~params:_4 ~attrs:(attrs @ _8)
            ~loc:(symbol_rloc ()) ~docs:(symbol_docs ())
      , ext )
# 8693 "parsing/parser.ml"
               : 'class_description))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 6 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 5 : 'virtual_flag) in
    let _4 = (Parsing.peek_val __caml_parser_env 4 : 'class_type_parameters) in
    let _5 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _7 = (Parsing.peek_val __caml_parser_env 1 : 'class_type) in
    let _8 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1240 "parsing/parser.mly"
      ( Ci.mk (mkrhs _5 5) _7 ~virt:_3 ~params:_4
              ~attrs:(_2@_8) ~loc:(symbol_rloc ())
              ~text:(symbol_text ()) ~docs:(symbol_docs ()) )
# 8707 "parsing/parser.ml"
               : 'and_class_description))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'class_type_declaration) in
    Obj.repr(
# 1246 "parsing/parser.mly"
      ( let (body, ext) = _1 in ([body],ext) )
# 8714 "parsing/parser.ml"
               : 'class_type_declarations))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'class_type_declarations) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'and_class_type_declaration) in
    Obj.repr(
# 1248 "parsing/parser.mly"
      ( let (l, ext) = _1 in (_2 :: l, ext) )
# 8722 "parsing/parser.ml"
               : 'class_type_declarations))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 6 : 'ext_attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 5 : 'virtual_flag) in
    let _5 = (Parsing.peek_val __caml_parser_env 4 : 'class_type_parameters) in
    let _6 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _8 = (Parsing.peek_val __caml_parser_env 1 : 'class_signature) in
    let _9 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1253 "parsing/parser.mly"
      ( let (ext, attrs) = _3 in
        Ci.mk (mkrhs _6 6) _8 ~virt:_4 ~params:_5 ~attrs:(attrs@_9)
            ~loc:(symbol_rloc ()) ~docs:(symbol_docs ())
      , ext)
# 8737 "parsing/parser.ml"
               : 'class_type_declaration))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 6 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 5 : 'virtual_flag) in
    let _4 = (Parsing.peek_val __caml_parser_env 4 : 'class_type_parameters) in
    let _5 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _7 = (Parsing.peek_val __caml_parser_env 1 : 'class_signature) in
    let _8 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1261 "parsing/parser.mly"
      ( Ci.mk (mkrhs _5 5) _7 ~virt:_3 ~params:_4
         ~attrs:(_2@_8) ~loc:(symbol_rloc ())
         ~text:(symbol_text ()) ~docs:(symbol_docs ()) )
# 8751 "parsing/parser.ml"
               : 'and_class_type_declaration))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1269 "parsing/parser.mly"
                                  ( _1 )
# 8758 "parsing/parser.ml"
               : 'seq_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in
    Obj.repr(
# 1270 "parsing/parser.mly"
                                  ( _1 )
# 8765 "parsing/parser.ml"
               : 'seq_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 1271 "parsing/parser.mly"
                                  ( mkexp(Pexp_sequence(_1, _3)) )
# 8773 "parsing/parser.ml"
               : 'seq_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'expr) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'attr_id) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 1273 "parsing/parser.mly"
      ( let seq = mkexp(Pexp_sequence (_1, _5)) in
        let payload = PStr [mkstrexp seq []] in
        mkexp (Pexp_extension (_4, payload)) )
# 8784 "parsing/parser.ml"
               : 'seq_expr))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'label_let_pattern) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'opt_default) in
    Obj.repr(
# 1279 "parsing/parser.mly"
      ( (Optional (fst _3), _4, snd _3) )
# 8792 "parsing/parser.ml"
               : 'labeled_simple_pattern))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'label_var) in
    Obj.repr(
# 1281 "parsing/parser.mly"
      ( (Optional (fst _2), None, snd _2) )
# 8799 "parsing/parser.ml"
               : 'labeled_simple_pattern))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : string) in
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'let_pattern) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'opt_default) in
    Obj.repr(
# 1283 "parsing/parser.mly"
      ( (Optional _1, _4, _3) )
# 8808 "parsing/parser.ml"
               : 'labeled_simple_pattern))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : string) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'pattern_var) in
    Obj.repr(
# 1285 "parsing/parser.mly"
      ( (Optional _1, None, _2) )
# 8816 "parsing/parser.ml"
               : 'labeled_simple_pattern))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'label_let_pattern) in
    Obj.repr(
# 1287 "parsing/parser.mly"
      ( (Labelled (fst _3), None, snd _3) )
# 8823 "parsing/parser.ml"
               : 'labeled_simple_pattern))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'label_var) in
    Obj.repr(
# 1289 "parsing/parser.mly"
      ( (Labelled (fst _2), None, snd _2) )
# 8830 "parsing/parser.ml"
               : 'labeled_simple_pattern))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : string) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'simple_pattern) in
    Obj.repr(
# 1291 "parsing/parser.mly"
      ( (Labelled _1, None, _2) )
# 8838 "parsing/parser.ml"
               : 'labeled_simple_pattern))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_pattern) in
    Obj.repr(
# 1293 "parsing/parser.mly"
      ( (Nolabel, None, _1) )
# 8845 "parsing/parser.ml"
               : 'labeled_simple_pattern))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 1296 "parsing/parser.mly"
                      ( mkpat(Ppat_var (mkrhs _1 1)) )
# 8852 "parsing/parser.ml"
               : 'pattern_var))
; (fun __caml_parser_env ->
    Obj.repr(
# 1297 "parsing/parser.mly"
                      ( mkpat Ppat_any )
# 8858 "parsing/parser.ml"
               : 'pattern_var))
; (fun __caml_parser_env ->
    Obj.repr(
# 1300 "parsing/parser.mly"
                                        ( None )
# 8864 "parsing/parser.ml"
               : 'opt_default))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 1301 "parsing/parser.mly"
                                        ( Some _2 )
# 8871 "parsing/parser.ml"
               : 'opt_default))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'label_var) in
    Obj.repr(
# 1305 "parsing/parser.mly"
      ( _1 )
# 8878 "parsing/parser.ml"
               : 'label_let_pattern))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'label_var) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in
    Obj.repr(
# 1307 "parsing/parser.mly"
      ( let (lab, pat) = _1 in (lab, mkpat(Ppat_constraint(pat, _3))) )
# 8886 "parsing/parser.ml"
               : 'label_let_pattern))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 1310 "parsing/parser.mly"
              ( (_1, mkpat(Ppat_var (mkrhs _1 1))) )
# 8893 "parsing/parser.ml"
               : 'label_var))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in
    Obj.repr(
# 1314 "parsing/parser.mly"
      ( _1 )
# 8900 "parsing/parser.ml"
               : 'let_pattern))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in
    Obj.repr(
# 1316 "parsing/parser.mly"
      ( mkpat(Ppat_constraint(_1, _3)) )
# 8908 "parsing/parser.ml"
               : 'let_pattern))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_expr) in
    Obj.repr(
# 1320 "parsing/parser.mly"
      ( _1 )
# 8915 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'simple_expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'simple_labeled_expr_list) in
    Obj.repr(
# 1322 "parsing/parser.mly"
      ( mkexp(Pexp_apply(_1, List.rev _2)) )
# 8923 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'let_bindings) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 1324 "parsing/parser.mly"
      ( expr_of_let_bindings _1 _3 )
# 8931 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _5 = (Parsing.peek_val __caml_parser_env 2 : 'module_binding_body) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 1326 "parsing/parser.mly"
      ( mkexp_attrs (Pexp_letmodule(mkrhs _4 4, _5, _7)) _3 )
# 8941 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 3 : 'ext_attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 2 : 'let_exception_declaration) in
    let _6 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 1328 "parsing/parser.mly"
      ( mkexp_attrs (Pexp_letexception(_4, _6)) _3 )
# 8950 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'override_flag) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : 'ext_attributes) in
    let _5 = (Parsing.peek_val __caml_parser_env 2 : 'mod_longident) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 1330 "parsing/parser.mly"
      ( mkexp_attrs (Pexp_open(_3, mkrhs _5 5, _7)) _4 )
# 8960 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_bar) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'match_cases) in
    Obj.repr(
# 1332 "parsing/parser.mly"
      ( mkexp_attrs (Pexp_function(List.rev _4)) _2 )
# 8969 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'labeled_simple_pattern) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'fun_def) in
    Obj.repr(
# 1334 "parsing/parser.mly"
      ( let (l,o,p) = _3 in
        mkexp_attrs (Pexp_fun(l, o, p, _4)) _2 )
# 8979 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 5 : 'ext_attributes) in
    let _5 = (Parsing.peek_val __caml_parser_env 2 : 'lident_list) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'fun_def) in
    Obj.repr(
# 1337 "parsing/parser.mly"
      ( mkexp_attrs (mk_newtypes _5 _7).pexp_desc _2 )
# 8988 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 3 : 'seq_expr) in
    let _5 = (Parsing.peek_val __caml_parser_env 1 : 'opt_bar) in
    let _6 = (Parsing.peek_val __caml_parser_env 0 : 'match_cases) in
    Obj.repr(
# 1339 "parsing/parser.mly"
      ( mkexp_attrs (Pexp_match(_3, List.rev _6)) _2 )
# 8998 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 3 : 'seq_expr) in
    let _5 = (Parsing.peek_val __caml_parser_env 1 : 'opt_bar) in
    let _6 = (Parsing.peek_val __caml_parser_env 0 : 'match_cases) in
    Obj.repr(
# 1341 "parsing/parser.mly"
      ( mkexp_attrs (Pexp_try(_3, List.rev _6)) _2 )
# 9008 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'seq_expr) in
    Obj.repr(
# 1343 "parsing/parser.mly"
      ( syntax_error() )
# 9016 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'expr_comma_list) in
    Obj.repr(
# 1345 "parsing/parser.mly"
      ( mkexp(Pexp_tuple(List.rev _1)) )
# 9023 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'constr_longident) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'simple_expr) in
    Obj.repr(
# 1347 "parsing/parser.mly"
      ( mkexp(Pexp_construct(mkrhs _1 1, Some _2)) )
# 9031 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'name_tag) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'simple_expr) in
    Obj.repr(
# 1349 "parsing/parser.mly"
      ( mkexp(Pexp_variant(_1, Some _2)) )
# 9039 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 5 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'seq_expr) in
    let _5 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1351 "parsing/parser.mly"
      ( mkexp_attrs(Pexp_ifthenelse(_3, _5, Some _7)) _2 )
# 9049 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'seq_expr) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1353 "parsing/parser.mly"
      ( mkexp_attrs (Pexp_ifthenelse(_3, _5, None)) _2 )
# 9058 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 3 : 'seq_expr) in
    let _5 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in
    Obj.repr(
# 1355 "parsing/parser.mly"
      ( mkexp_attrs (Pexp_while(_3, _5)) _2 )
# 9067 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 8 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 7 : 'pattern) in
    let _5 = (Parsing.peek_val __caml_parser_env 5 : 'seq_expr) in
    let _6 = (Parsing.peek_val __caml_parser_env 4 : 'direction_flag) in
    let _7 = (Parsing.peek_val __caml_parser_env 3 : 'seq_expr) in
    let _9 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in
    Obj.repr(
# 1358 "parsing/parser.mly"
      ( mkexp_attrs(Pexp_for(_3, _5, _7, _6, _9)) _2 )
# 9079 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1360 "parsing/parser.mly"
      ( mkexp_cons (rhs_loc 2) (ghexp(Pexp_tuple[_1;_3])) (symbol_rloc()) )
# 9087 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 1 : string) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1362 "parsing/parser.mly"
      ( mkinfix _1 _2 _3 )
# 9096 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 1 : string) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1364 "parsing/parser.mly"
      ( mkinfix _1 _2 _3 )
# 9105 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 1 : string) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1366 "parsing/parser.mly"
      ( mkinfix _1 _2 _3 )
# 9114 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 1 : string) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1368 "parsing/parser.mly"
      ( mkinfix _1 _2 _3 )
# 9123 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 1 : string) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1370 "parsing/parser.mly"
      ( mkinfix _1 _2 _3 )
# 9132 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1372 "parsing/parser.mly"
      ( mkinfix _1 "+" _3 )
# 9140 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1374 "parsing/parser.mly"
      ( mkinfix _1 "+." _3 )
# 9148 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1376 "parsing/parser.mly"
      ( mkinfix _1 "+=" _3 )
# 9156 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1378 "parsing/parser.mly"
      ( mkinfix _1 "-" _3 )
# 9164 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1380 "parsing/parser.mly"
      ( mkinfix _1 "-." _3 )
# 9172 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1382 "parsing/parser.mly"
      ( mkinfix _1 "*" _3 )
# 9180 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1384 "parsing/parser.mly"
      ( mkinfix _1 "%" _3 )
# 9188 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1386 "parsing/parser.mly"
      ( mkinfix _1 "=" _3 )
# 9196 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1388 "parsing/parser.mly"
    ( mkinfix _1 "<" _3 )
# 9204 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1390 "parsing/parser.mly"
      ( mkinfix _1 ">" _3 )
# 9212 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1392 "parsing/parser.mly"
      ( mkinfix _1 "or" _3 )
# 9220 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1394 "parsing/parser.mly"
      ( mkinfix _1 "||" _3 )
# 9228 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1396 "parsing/parser.mly"
      ( mkinfix _1 "&" _3 )
# 9236 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1398 "parsing/parser.mly"
      ( mkinfix _1 "&&" _3 )
# 9244 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1400 "parsing/parser.mly"
      ( mkinfix _1 ":=" _3 )
# 9252 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'subtractive) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1402 "parsing/parser.mly"
      ( mkuminus _1 _2 )
# 9260 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'additive) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1404 "parsing/parser.mly"
      ( mkuplus _1 _2 )
# 9268 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'label_longident) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1406 "parsing/parser.mly"
      ( mkexp(Pexp_setfield(_1, mkrhs _3 3, _5)) )
# 9277 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : 'seq_expr) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1408 "parsing/parser.mly"
      ( mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "Array" "set")),
                         [Nolabel,_1; Nolabel,_4; Nolabel,_7])) )
# 9287 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : 'seq_expr) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1411 "parsing/parser.mly"
      ( mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "String" "set")),
                         [Nolabel,_1; Nolabel,_4; Nolabel,_7])) )
# 9297 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : 'expr) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1414 "parsing/parser.mly"
      ( bigarray_set _1 _4 _7 )
# 9306 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 5 : string) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : 'expr) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1416 "parsing/parser.mly"
      ( let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ _2 ^ "[]<-")) in
        mkexp @@ Pexp_apply(id , [Nolabel, _1; Nolabel, _4; Nolabel, _7]) )
# 9317 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 5 : string) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : 'expr) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1419 "parsing/parser.mly"
      ( let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ _2 ^ "()<-")) in
        mkexp @@ Pexp_apply(id , [Nolabel, _1; Nolabel, _4; Nolabel, _7]) )
# 9328 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 5 : string) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : 'expr) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1422 "parsing/parser.mly"
      ( let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ _2 ^ "{}<-")) in
        mkexp @@ Pexp_apply(id , [Nolabel, _1; Nolabel, _4; Nolabel, _7]) )
# 9339 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 8 : 'simple_expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 6 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 5 : string) in
    let _6 = (Parsing.peek_val __caml_parser_env 3 : 'expr) in
    let _9 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1425 "parsing/parser.mly"
      ( let id = mkexp @@ Pexp_ident( ghloc @@ Ldot(_3,"." ^ _4 ^ "[]<-")) in
        mkexp @@ Pexp_apply(id , [Nolabel, _1; Nolabel, _6; Nolabel, _9]) )
# 9351 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 8 : 'simple_expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 6 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 5 : string) in
    let _6 = (Parsing.peek_val __caml_parser_env 3 : 'expr) in
    let _9 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1428 "parsing/parser.mly"
      ( let id = mkexp @@ Pexp_ident( ghloc @@ Ldot(_3, "." ^ _4 ^ "()<-")) in
        mkexp @@ Pexp_apply(id , [Nolabel, _1; Nolabel, _6; Nolabel, _9]) )
# 9363 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 8 : 'simple_expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 6 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 5 : string) in
    let _6 = (Parsing.peek_val __caml_parser_env 3 : 'expr) in
    let _9 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1431 "parsing/parser.mly"
      ( let id = mkexp @@ Pexp_ident( ghloc @@ Ldot(_3, "." ^ _4 ^ "{}<-")) in
        mkexp @@ Pexp_apply(id , [Nolabel, _1; Nolabel, _6; Nolabel, _9]) )
# 9375 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'label) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1434 "parsing/parser.mly"
      ( mkexp(Pexp_setinstvar(mkrhs _1 1, _3)) )
# 9383 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'simple_expr) in
    Obj.repr(
# 1436 "parsing/parser.mly"
      ( mkexp_attrs (Pexp_assert _3) _2 )
# 9391 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'simple_expr) in
    Obj.repr(
# 1438 "parsing/parser.mly"
      ( mkexp_attrs (Pexp_lazy _3) _2 )
# 9399 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'class_structure) in
    Obj.repr(
# 1440 "parsing/parser.mly"
      ( mkexp_attrs (Pexp_object _3) _2 )
# 9407 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'class_structure) in
    Obj.repr(
# 1442 "parsing/parser.mly"
      ( unclosed "object" 1 "end" 4 )
# 9415 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attribute) in
    Obj.repr(
# 1444 "parsing/parser.mly"
      ( Exp.attr _1 _2 )
# 9423 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    Obj.repr(
# 1446 "parsing/parser.mly"
     ( not_expecting 1 "wildcard \"_\"" )
# 9429 "parsing/parser.ml"
               : 'expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'val_longident) in
    Obj.repr(
# 1450 "parsing/parser.mly"
      ( mkexp(Pexp_ident (mkrhs _1 1)) )
# 9436 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'constant) in
    Obj.repr(
# 1452 "parsing/parser.mly"
      ( mkexp(Pexp_constant _1) )
# 9443 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'constr_longident) in
    Obj.repr(
# 1454 "parsing/parser.mly"
      ( mkexp(Pexp_construct(mkrhs _1 1, None)) )
# 9450 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'name_tag) in
    Obj.repr(
# 1456 "parsing/parser.mly"
      ( mkexp(Pexp_variant(_1, None)) )
# 9457 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in
    Obj.repr(
# 1458 "parsing/parser.mly"
      ( reloc_exp _2 )
# 9464 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in
    Obj.repr(
# 1460 "parsing/parser.mly"
      ( unclosed "(" 1 ")" 3 )
# 9471 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in
    Obj.repr(
# 1462 "parsing/parser.mly"
      ( wrap_exp_attrs (reloc_exp _3) _2 (* check location *) )
# 9479 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'ext_attributes) in
    Obj.repr(
# 1464 "parsing/parser.mly"
      ( mkexp_attrs (Pexp_construct (mkloc (Lident "()") (symbol_rloc ()),
                               None)) _2 )
# 9487 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in
    Obj.repr(
# 1467 "parsing/parser.mly"
      ( unclosed "begin" 1 "end" 4 )
# 9495 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'seq_expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'type_constraint) in
    Obj.repr(
# 1469 "parsing/parser.mly"
      ( mkexp_constraint _2 _3 )
# 9503 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'simple_expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'label_longident) in
    Obj.repr(
# 1471 "parsing/parser.mly"
      ( mkexp(Pexp_field(_1, mkrhs _3 3)) )
# 9511 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in
    Obj.repr(
# 1473 "parsing/parser.mly"
      ( mkexp(Pexp_open(Fresh, mkrhs _1 1, _4)) )
# 9519 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 3 : 'mod_longident) in
    Obj.repr(
# 1475 "parsing/parser.mly"
      ( mkexp(Pexp_open(Fresh, mkrhs _1 1,
                        mkexp(Pexp_construct(mkrhs (Lident "()") 1, None)))) )
# 9527 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in
    Obj.repr(
# 1478 "parsing/parser.mly"
      ( unclosed "(" 3 ")" 5 )
# 9535 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in
    Obj.repr(
# 1480 "parsing/parser.mly"
      ( mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "Array" "get")),
                         [Nolabel,_1; Nolabel,_4])) )
# 9544 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in
    Obj.repr(
# 1483 "parsing/parser.mly"
      ( unclosed "(" 3 ")" 5 )
# 9552 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in
    Obj.repr(
# 1485 "parsing/parser.mly"
      ( mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "String" "get")),
                         [Nolabel,_1; Nolabel,_4])) )
# 9561 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in
    Obj.repr(
# 1488 "parsing/parser.mly"
      ( unclosed "[" 3 "]" 5 )
# 9569 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in
    Obj.repr(
# 1490 "parsing/parser.mly"
      ( let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ _2 ^ "[]")) in
        mkexp @@ Pexp_apply(id, [Nolabel, _1; Nolabel, _4]) )
# 9579 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in
    Obj.repr(
# 1493 "parsing/parser.mly"
      ( unclosed "[" 3 "]" 5 )
# 9588 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in
    Obj.repr(
# 1495 "parsing/parser.mly"
      ( let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ _2 ^ "()")) in
        mkexp @@ Pexp_apply(id, [Nolabel, _1; Nolabel, _4]) )
# 9598 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in
    Obj.repr(
# 1498 "parsing/parser.mly"
      ( unclosed "(" 3 ")" 5 )
# 9607 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in
    Obj.repr(
# 1500 "parsing/parser.mly"
      ( let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ _2 ^ "{}")) in
        mkexp @@ Pexp_apply(id, [Nolabel, _1; Nolabel, _4]) )
# 9617 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in
    Obj.repr(
# 1503 "parsing/parser.mly"
      ( unclosed "{" 3 "}" 5 )
# 9626 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _6 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in
    Obj.repr(
# 1505 "parsing/parser.mly"
      ( let id = mkexp @@ Pexp_ident( ghloc @@ Ldot(_3, "." ^ _4 ^ "[]")) in
        mkexp @@ Pexp_apply(id, [Nolabel, _1; Nolabel, _6]) )
# 9637 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _6 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in
    Obj.repr(
# 1508 "parsing/parser.mly"
      ( unclosed "[" 5 "]" 7 )
# 9647 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _6 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in
    Obj.repr(
# 1510 "parsing/parser.mly"
      ( let id = mkexp @@ Pexp_ident( ghloc @@ Ldot(_3, "." ^ _4 ^ "()")) in
        mkexp @@ Pexp_apply(id, [Nolabel, _1; Nolabel, _6]) )
# 9658 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _6 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in
    Obj.repr(
# 1513 "parsing/parser.mly"
      ( unclosed "(" 5 ")" 7 )
# 9668 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _6 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in
    Obj.repr(
# 1515 "parsing/parser.mly"
      ( let id = mkexp @@ Pexp_ident( ghloc @@ Ldot(_3, "." ^ _4 ^ "{}")) in
        mkexp @@ Pexp_apply(id, [Nolabel, _1; Nolabel, _6]) )
# 9679 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _6 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in
    Obj.repr(
# 1518 "parsing/parser.mly"
      ( unclosed "{" 5 "}" 7 )
# 9689 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in
    Obj.repr(
# 1520 "parsing/parser.mly"
      ( bigarray_get _1 _4 )
# 9697 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'expr_comma_list) in
    Obj.repr(
# 1522 "parsing/parser.mly"
      ( unclosed "{" 3 "}" 5 )
# 9705 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'record_expr) in
    Obj.repr(
# 1524 "parsing/parser.mly"
      ( let (exten, fields) = _2 in mkexp (Pexp_record(fields, exten)) )
# 9712 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'record_expr) in
    Obj.repr(
# 1526 "parsing/parser.mly"
      ( unclosed "{" 1 "}" 3 )
# 9719 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'record_expr) in
    Obj.repr(
# 1528 "parsing/parser.mly"
      ( let (exten, fields) = _4 in
        let rec_exp = mkexp(Pexp_record(fields, exten)) in
        mkexp(Pexp_open(Fresh, mkrhs _1 1, rec_exp)) )
# 9729 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'record_expr) in
    Obj.repr(
# 1532 "parsing/parser.mly"
      ( unclosed "{" 3 "}" 5 )
# 9737 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'expr_semi_list) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in
    Obj.repr(
# 1534 "parsing/parser.mly"
      ( mkexp (Pexp_array(List.rev _2)) )
# 9745 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'expr_semi_list) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in
    Obj.repr(
# 1536 "parsing/parser.mly"
      ( unclosed "[|" 1 "|]" 4 )
# 9753 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    Obj.repr(
# 1538 "parsing/parser.mly"
      ( mkexp (Pexp_array []) )
# 9759 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 5 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 2 : 'expr_semi_list) in
    let _5 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in
    Obj.repr(
# 1540 "parsing/parser.mly"
      ( mkexp(Pexp_open(Fresh, mkrhs _1 1, mkexp(Pexp_array(List.rev _4)))) )
# 9768 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 3 : 'mod_longident) in
    Obj.repr(
# 1542 "parsing/parser.mly"
      ( mkexp(Pexp_open(Fresh, mkrhs _1 1, mkexp(Pexp_array []))) )
# 9775 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 5 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 2 : 'expr_semi_list) in
    let _5 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in
    Obj.repr(
# 1544 "parsing/parser.mly"
      ( unclosed "[|" 3 "|]" 6 )
# 9784 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'expr_semi_list) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in
    Obj.repr(
# 1546 "parsing/parser.mly"
      ( reloc_exp (mktailexp (rhs_loc 4) (List.rev _2)) )
# 9792 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'expr_semi_list) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in
    Obj.repr(
# 1548 "parsing/parser.mly"
      ( unclosed "[" 1 "]" 4 )
# 9800 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 5 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 2 : 'expr_semi_list) in
    let _5 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in
    Obj.repr(
# 1550 "parsing/parser.mly"
      ( let list_exp = reloc_exp (mktailexp (rhs_loc 6) (List.rev _4)) in
        mkexp(Pexp_open(Fresh, mkrhs _1 1, list_exp)) )
# 9810 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 3 : 'mod_longident) in
    Obj.repr(
# 1553 "parsing/parser.mly"
      ( mkexp(Pexp_open(Fresh, mkrhs _1 1,
                        mkexp(Pexp_construct(mkrhs (Lident "[]") 1, None)))) )
# 9818 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 5 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 2 : 'expr_semi_list) in
    let _5 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in
    Obj.repr(
# 1556 "parsing/parser.mly"
      ( unclosed "[" 3 "]" 6 )
# 9827 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : string) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'simple_expr) in
    Obj.repr(
# 1558 "parsing/parser.mly"
      ( mkexp(Pexp_apply(mkoperator _1 1, [Nolabel,_2])) )
# 9835 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'simple_expr) in
    Obj.repr(
# 1560 "parsing/parser.mly"
      ( mkexp(Pexp_apply(mkoperator "!" 1, [Nolabel,_2])) )
# 9842 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'class_longident) in
    Obj.repr(
# 1562 "parsing/parser.mly"
      ( mkexp_attrs (Pexp_new(mkrhs _3 3)) _2 )
# 9850 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'field_expr_list) in
    Obj.repr(
# 1564 "parsing/parser.mly"
      ( mkexp (Pexp_override _2) )
# 9857 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'field_expr_list) in
    Obj.repr(
# 1566 "parsing/parser.mly"
      ( unclosed "{<" 1 ">}" 3 )
# 9864 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    Obj.repr(
# 1568 "parsing/parser.mly"
      ( mkexp (Pexp_override []))
# 9870 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'field_expr_list) in
    Obj.repr(
# 1570 "parsing/parser.mly"
      ( mkexp(Pexp_open(Fresh, mkrhs _1 1, mkexp (Pexp_override _4))))
# 9878 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 3 : 'mod_longident) in
    Obj.repr(
# 1572 "parsing/parser.mly"
      ( mkexp(Pexp_open(Fresh, mkrhs _1 1, mkexp (Pexp_override []))))
# 9885 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'field_expr_list) in
    Obj.repr(
# 1574 "parsing/parser.mly"
      ( unclosed "{<" 3 ">}" 5 )
# 9893 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'simple_expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'label) in
    Obj.repr(
# 1576 "parsing/parser.mly"
      ( mkexp(Pexp_send(_1, mkrhs _3 3)) )
# 9901 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'simple_expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 1 : string) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'simple_expr) in
    Obj.repr(
# 1578 "parsing/parser.mly"
      ( mkinfix _1 _2 _3 )
# 9910 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'module_expr) in
    Obj.repr(
# 1580 "parsing/parser.mly"
      ( mkexp_attrs (Pexp_pack _4) _3 )
# 9918 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : 'module_expr) in
    let _6 = (Parsing.peek_val __caml_parser_env 1 : 'package_type) in
    Obj.repr(
# 1582 "parsing/parser.mly"
      ( mkexp_attrs (Pexp_constraint (ghexp (Pexp_pack _4),
                                      ghtyp (Ptyp_package _6)))
                    _3 )
# 9929 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 3 : 'ext_attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 2 : 'module_expr) in
    Obj.repr(
# 1586 "parsing/parser.mly"
      ( unclosed "(" 1 ")" 6 )
# 9937 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 8 : 'mod_longident) in
    let _5 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in
    let _6 = (Parsing.peek_val __caml_parser_env 3 : 'module_expr) in
    let _8 = (Parsing.peek_val __caml_parser_env 1 : 'package_type) in
    Obj.repr(
# 1589 "parsing/parser.mly"
      ( mkexp(Pexp_open(Fresh, mkrhs _1 1,
        mkexp_attrs (Pexp_constraint (ghexp (Pexp_pack _6),
                                ghtyp (Ptyp_package _8)))
                    _5 )) )
# 9950 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 7 : 'mod_longident) in
    let _5 = (Parsing.peek_val __caml_parser_env 3 : 'ext_attributes) in
    let _6 = (Parsing.peek_val __caml_parser_env 2 : 'module_expr) in
    Obj.repr(
# 1594 "parsing/parser.mly"
      ( unclosed "(" 3 ")" 8 )
# 9959 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'extension) in
    Obj.repr(
# 1596 "parsing/parser.mly"
      ( mkexp (Pexp_extension _1) )
# 9966 "parsing/parser.ml"
               : 'simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'labeled_simple_expr) in
    Obj.repr(
# 1600 "parsing/parser.mly"
      ( [_1] )
# 9973 "parsing/parser.ml"
               : 'simple_labeled_expr_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'simple_labeled_expr_list) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'labeled_simple_expr) in
    Obj.repr(
# 1602 "parsing/parser.mly"
      ( _2 :: _1 )
# 9981 "parsing/parser.ml"
               : 'simple_labeled_expr_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_expr) in
    Obj.repr(
# 1606 "parsing/parser.mly"
      ( (Nolabel, _1) )
# 9988 "parsing/parser.ml"
               : 'labeled_simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'label_expr) in
    Obj.repr(
# 1608 "parsing/parser.mly"
      ( _1 )
# 9995 "parsing/parser.ml"
               : 'labeled_simple_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : string) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'simple_expr) in
    Obj.repr(
# 1612 "parsing/parser.mly"
      ( (Labelled _1, _2) )
# 10003 "parsing/parser.ml"
               : 'label_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'label_ident) in
    Obj.repr(
# 1614 "parsing/parser.mly"
      ( (Labelled (fst _2), snd _2) )
# 10010 "parsing/parser.ml"
               : 'label_expr))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'label_ident) in
    Obj.repr(
# 1616 "parsing/parser.mly"
      ( (Optional (fst _2), snd _2) )
# 10017 "parsing/parser.ml"
               : 'label_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : string) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'simple_expr) in
    Obj.repr(
# 1618 "parsing/parser.mly"
      ( (Optional _1, _2) )
# 10025 "parsing/parser.ml"
               : 'label_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 1621 "parsing/parser.mly"
             ( (_1, mkexp(Pexp_ident(mkrhs (Lident _1) 1))) )
# 10032 "parsing/parser.ml"
               : 'label_ident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 1624 "parsing/parser.mly"
                                      ( [mkrhs _1 1] )
# 10039 "parsing/parser.ml"
               : 'lident_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : string) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'lident_list) in
    Obj.repr(
# 1625 "parsing/parser.mly"
                                      ( mkrhs _1 1 :: _2 )
# 10047 "parsing/parser.ml"
               : 'lident_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'val_ident) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'strict_binding) in
    Obj.repr(
# 1629 "parsing/parser.mly"
      ( (mkpatvar _1 1, _2) )
# 10055 "parsing/parser.ml"
               : 'let_binding_body))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 3 : 'val_ident) in
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'type_constraint) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 1631 "parsing/parser.mly"
      ( let v = mkpatvar _1 1 in (* PR#7344 *)
        let t =
          match _2 with
            Some t, None -> t
          | _, Some t -> t
          | _ -> assert false
        in
        (ghpat(Ppat_constraint(v, ghtyp(Ptyp_poly([],t)))),
         mkexp_constraint _4 _2) )
# 10072 "parsing/parser.ml"
               : 'let_binding_body))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 6 : 'val_ident) in
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'typevar_list) in
    let _5 = (Parsing.peek_val __caml_parser_env 2 : 'core_type) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 1641 "parsing/parser.mly"
      ( (ghpat(Ppat_constraint(mkpatvar _1 1,
                               ghtyp(Ptyp_poly(List.rev _3,_5)))),
         _7) )
# 10084 "parsing/parser.ml"
               : 'let_binding_body))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 7 : 'val_ident) in
    let _4 = (Parsing.peek_val __caml_parser_env 4 : 'lident_list) in
    let _6 = (Parsing.peek_val __caml_parser_env 2 : 'core_type) in
    let _8 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 1645 "parsing/parser.mly"
      ( let exp, poly = wrap_type_annotation _4 _6 _8 in
        (ghpat(Ppat_constraint(mkpatvar _1 1, poly)), exp) )
# 10095 "parsing/parser.ml"
               : 'let_binding_body))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_no_exn) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 1648 "parsing/parser.mly"
      ( (_1, _3) )
# 10103 "parsing/parser.ml"
               : 'let_binding_body))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_pattern_not_ident) in
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'core_type) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 1650 "parsing/parser.mly"
      ( (ghpat(Ppat_constraint(_1, _3)), _5) )
# 10112 "parsing/parser.ml"
               : 'let_binding_body))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'let_binding) in
    Obj.repr(
# 1653 "parsing/parser.mly"
                                                ( _1 )
# 10119 "parsing/parser.ml"
               : 'let_bindings))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'let_bindings) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'and_let_binding) in
    Obj.repr(
# 1654 "parsing/parser.mly"
                                                ( addlb _1 _2 )
# 10127 "parsing/parser.ml"
               : 'let_bindings))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'rec_flag) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'let_binding_body) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1658 "parsing/parser.mly"
      ( let (ext, attr) = _2 in
        mklbs ext _3 (mklb true _4 (attr@_5)) )
# 10138 "parsing/parser.ml"
               : 'let_binding))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'let_binding_body) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1663 "parsing/parser.mly"
      ( mklb false _3 (_2@_4) )
# 10147 "parsing/parser.ml"
               : 'and_let_binding))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'strict_binding) in
    Obj.repr(
# 1667 "parsing/parser.mly"
      ( _1 )
# 10154 "parsing/parser.ml"
               : 'fun_binding))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'type_constraint) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 1669 "parsing/parser.mly"
      ( mkexp_constraint _3 _1 )
# 10162 "parsing/parser.ml"
               : 'fun_binding))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 1673 "parsing/parser.mly"
      ( _2 )
# 10169 "parsing/parser.ml"
               : 'strict_binding))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'labeled_simple_pattern) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'fun_binding) in
    Obj.repr(
# 1675 "parsing/parser.mly"
      ( let (l, o, p) = _1 in ghexp(Pexp_fun(l, o, p, _2)) )
# 10177 "parsing/parser.ml"
               : 'strict_binding))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'lident_list) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'fun_binding) in
    Obj.repr(
# 1677 "parsing/parser.mly"
      ( mk_newtypes _3 _5 )
# 10185 "parsing/parser.ml"
               : 'strict_binding))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'match_case) in
    Obj.repr(
# 1680 "parsing/parser.mly"
               ( [_1] )
# 10192 "parsing/parser.ml"
               : 'match_cases))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'match_cases) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'match_case) in
    Obj.repr(
# 1681 "parsing/parser.mly"
                               ( _3 :: _1 )
# 10200 "parsing/parser.ml"
               : 'match_cases))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 1685 "parsing/parser.mly"
      ( Exp.case _1 _3 )
# 10208 "parsing/parser.ml"
               : 'match_case))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'pattern) in
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'seq_expr) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 1687 "parsing/parser.mly"
      ( Exp.case _1 ~guard:_3 _5 )
# 10217 "parsing/parser.ml"
               : 'match_case))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in
    Obj.repr(
# 1689 "parsing/parser.mly"
      ( Exp.case _1 (Exp.unreachable ~loc:(rhs_loc 3) ()))
# 10224 "parsing/parser.ml"
               : 'match_case))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 1693 "parsing/parser.mly"
      ( _2 )
# 10231 "parsing/parser.ml"
               : 'fun_def))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'simple_core_type) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 1695 "parsing/parser.mly"
      ( mkexp (Pexp_constraint (_4, _2)) )
# 10239 "parsing/parser.ml"
               : 'fun_def))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'labeled_simple_pattern) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'fun_def) in
    Obj.repr(
# 1698 "parsing/parser.mly"
      (
       let (l,o,p) = _1 in
       ghexp(Pexp_fun(l, o, p, _2))
      )
# 10250 "parsing/parser.ml"
               : 'fun_def))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'lident_list) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'fun_def) in
    Obj.repr(
# 1703 "parsing/parser.mly"
      ( mk_newtypes _3 _5 )
# 10258 "parsing/parser.ml"
               : 'fun_def))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr_comma_list) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1706 "parsing/parser.mly"
                                                ( _3 :: _1 )
# 10266 "parsing/parser.ml"
               : 'expr_comma_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1707 "parsing/parser.mly"
                                                ( [_3; _1] )
# 10274 "parsing/parser.ml"
               : 'expr_comma_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'simple_expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'lbl_expr_list) in
    Obj.repr(
# 1710 "parsing/parser.mly"
                                                ( (Some _1, _3) )
# 10282 "parsing/parser.ml"
               : 'record_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'lbl_expr_list) in
    Obj.repr(
# 1711 "parsing/parser.mly"
                                                ( (None, _1) )
# 10289 "parsing/parser.ml"
               : 'record_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'lbl_expr) in
    Obj.repr(
# 1714 "parsing/parser.mly"
              ( [_1] )
# 10296 "parsing/parser.ml"
               : 'lbl_expr_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'lbl_expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'lbl_expr_list) in
    Obj.repr(
# 1715 "parsing/parser.mly"
                                 ( _1 :: _3 )
# 10304 "parsing/parser.ml"
               : 'lbl_expr_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'lbl_expr) in
    Obj.repr(
# 1716 "parsing/parser.mly"
                   ( [_1] )
# 10311 "parsing/parser.ml"
               : 'lbl_expr_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 3 : 'label_longident) in
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'opt_type_constraint) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1720 "parsing/parser.mly"
      ( (mkrhs _1 1, mkexp_opt_constraint _4 _2) )
# 10320 "parsing/parser.ml"
               : 'lbl_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'label_longident) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'opt_type_constraint) in
    Obj.repr(
# 1722 "parsing/parser.mly"
      ( (mkrhs _1 1, mkexp_opt_constraint (exp_of_label _1 1) _2) )
# 10328 "parsing/parser.ml"
               : 'lbl_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'field_expr) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'opt_semi) in
    Obj.repr(
# 1725 "parsing/parser.mly"
                        ( [_1] )
# 10336 "parsing/parser.ml"
               : 'field_expr_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'field_expr) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'field_expr_list) in
    Obj.repr(
# 1726 "parsing/parser.mly"
                                    ( _1 :: _3 )
# 10344 "parsing/parser.ml"
               : 'field_expr_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'label) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1730 "parsing/parser.mly"
      ( (mkrhs _1 1, _3) )
# 10352 "parsing/parser.ml"
               : 'field_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'label) in
    Obj.repr(
# 1732 "parsing/parser.mly"
      ( (mkrhs _1 1, exp_of_label (Lident _1) 1) )
# 10359 "parsing/parser.ml"
               : 'field_expr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1735 "parsing/parser.mly"
                                                ( [_1] )
# 10366 "parsing/parser.ml"
               : 'expr_semi_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr_semi_list) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in
    Obj.repr(
# 1736 "parsing/parser.mly"
                                                ( _3 :: _1 )
# 10374 "parsing/parser.ml"
               : 'expr_semi_list))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in
    Obj.repr(
# 1739 "parsing/parser.mly"
                                                ( (Some _2, None) )
# 10381 "parsing/parser.ml"
               : 'type_constraint))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'core_type) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in
    Obj.repr(
# 1740 "parsing/parser.mly"
                                                ( (Some _2, Some _4) )
# 10389 "parsing/parser.ml"
               : 'type_constraint))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in
    Obj.repr(
# 1741 "parsing/parser.mly"
                                                ( (None, Some _2) )
# 10396 "parsing/parser.ml"
               : 'type_constraint))
; (fun __caml_parser_env ->
    Obj.repr(
# 1742 "parsing/parser.mly"
                                                ( syntax_error() )
# 10402 "parsing/parser.ml"
               : 'type_constraint))
; (fun __caml_parser_env ->
    Obj.repr(
# 1743 "parsing/parser.mly"
                                                ( syntax_error() )
# 10408 "parsing/parser.ml"
               : 'type_constraint))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'type_constraint) in
    Obj.repr(
# 1746 "parsing/parser.mly"
                    ( Some _1 )
# 10415 "parsing/parser.ml"
               : 'opt_type_constraint))
; (fun __caml_parser_env ->
    Obj.repr(
# 1747 "parsing/parser.mly"
                ( None )
# 10421 "parsing/parser.ml"
               : 'opt_type_constraint))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'val_ident) in
    Obj.repr(
# 1754 "parsing/parser.mly"
      ( mkpat(Ppat_alias(_1, mkrhs _3 3)) )
# 10429 "parsing/parser.ml"
               : 'pattern))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in
    Obj.repr(
# 1756 "parsing/parser.mly"
      ( expecting 3 "identifier" )
# 10436 "parsing/parser.ml"
               : 'pattern))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'pattern_comma_list) in
    Obj.repr(
# 1758 "parsing/parser.mly"
      ( mkpat(Ppat_tuple(List.rev _1)) )
# 10443 "parsing/parser.ml"
               : 'pattern))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in
    Obj.repr(
# 1760 "parsing/parser.mly"
      ( mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[_1;_3])) (symbol_rloc()) )
# 10451 "parsing/parser.ml"
               : 'pattern))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in
    Obj.repr(
# 1762 "parsing/parser.mly"
      ( expecting 3 "pattern" )
# 10458 "parsing/parser.ml"
               : 'pattern))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in
    Obj.repr(
# 1764 "parsing/parser.mly"
      ( mkpat(Ppat_or(_1, _3)) )
# 10466 "parsing/parser.ml"
               : 'pattern))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in
    Obj.repr(
# 1766 "parsing/parser.mly"
      ( expecting 3 "pattern" )
# 10473 "parsing/parser.ml"
               : 'pattern))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in
    Obj.repr(
# 1768 "parsing/parser.mly"
      ( mkpat_attrs (Ppat_exception _3) _2)
# 10481 "parsing/parser.ml"
               : 'pattern))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'pattern) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attribute) in
    Obj.repr(
# 1770 "parsing/parser.mly"
      ( Pat.attr _1 _2 )
# 10489 "parsing/parser.ml"
               : 'pattern))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'pattern_gen) in
    Obj.repr(
# 1771 "parsing/parser.mly"
                ( _1 )
# 10496 "parsing/parser.ml"
               : 'pattern))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_no_exn) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'val_ident) in
    Obj.repr(
# 1775 "parsing/parser.mly"
      ( mkpat(Ppat_alias(_1, mkrhs _3 3)) )
# 10504 "parsing/parser.ml"
               : 'pattern_no_exn))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_no_exn) in
    Obj.repr(
# 1777 "parsing/parser.mly"
      ( expecting 3 "identifier" )
# 10511 "parsing/parser.ml"
               : 'pattern_no_exn))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'pattern_no_exn_comma_list) in
    Obj.repr(
# 1779 "parsing/parser.mly"
      ( mkpat(Ppat_tuple(List.rev _1)) )
# 10518 "parsing/parser.ml"
               : 'pattern_no_exn))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_no_exn) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in
    Obj.repr(
# 1781 "parsing/parser.mly"
      ( mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[_1;_3])) (symbol_rloc()) )
# 10526 "parsing/parser.ml"
               : 'pattern_no_exn))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_no_exn) in
    Obj.repr(
# 1783 "parsing/parser.mly"
      ( expecting 3 "pattern" )
# 10533 "parsing/parser.ml"
               : 'pattern_no_exn))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_no_exn) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in
    Obj.repr(
# 1785 "parsing/parser.mly"
      ( mkpat(Ppat_or(_1, _3)) )
# 10541 "parsing/parser.ml"
               : 'pattern_no_exn))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_no_exn) in
    Obj.repr(
# 1787 "parsing/parser.mly"
      ( expecting 3 "pattern" )
# 10548 "parsing/parser.ml"
               : 'pattern_no_exn))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'pattern_no_exn) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attribute) in
    Obj.repr(
# 1789 "parsing/parser.mly"
      ( Pat.attr _1 _2 )
# 10556 "parsing/parser.ml"
               : 'pattern_no_exn))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'pattern_gen) in
    Obj.repr(
# 1790 "parsing/parser.mly"
                ( _1 )
# 10563 "parsing/parser.ml"
               : 'pattern_no_exn))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_pattern) in
    Obj.repr(
# 1794 "parsing/parser.mly"
      ( _1 )
# 10570 "parsing/parser.ml"
               : 'pattern_gen))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'constr_longident) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in
    Obj.repr(
# 1796 "parsing/parser.mly"
      ( mkpat(Ppat_construct(mkrhs _1 1, Some _2)) )
# 10578 "parsing/parser.ml"
               : 'pattern_gen))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'name_tag) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in
    Obj.repr(
# 1798 "parsing/parser.mly"
      ( mkpat(Ppat_variant(_1, Some _2)) )
# 10586 "parsing/parser.ml"
               : 'pattern_gen))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'simple_pattern) in
    Obj.repr(
# 1800 "parsing/parser.mly"
      ( mkpat_attrs (Ppat_lazy _3) _2)
# 10594 "parsing/parser.ml"
               : 'pattern_gen))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'val_ident) in
    Obj.repr(
# 1804 "parsing/parser.mly"
      ( mkpat(Ppat_var (mkrhs _1 1)) )
# 10601 "parsing/parser.ml"
               : 'simple_pattern))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_pattern_not_ident) in
    Obj.repr(
# 1805 "parsing/parser.mly"
                             ( _1 )
# 10608 "parsing/parser.ml"
               : 'simple_pattern))
; (fun __caml_parser_env ->
    Obj.repr(
# 1809 "parsing/parser.mly"
      ( mkpat(Ppat_any) )
# 10614 "parsing/parser.ml"
               : 'simple_pattern_not_ident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'signed_constant) in
    Obj.repr(
# 1811 "parsing/parser.mly"
      ( mkpat(Ppat_constant _1) )
# 10621 "parsing/parser.ml"
               : 'simple_pattern_not_ident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'signed_constant) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'signed_constant) in
    Obj.repr(
# 1813 "parsing/parser.mly"
      ( mkpat(Ppat_interval (_1, _3)) )
# 10629 "parsing/parser.ml"
               : 'simple_pattern_not_ident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'constr_longident) in
    Obj.repr(
# 1815 "parsing/parser.mly"
      ( mkpat(Ppat_construct(mkrhs _1 1, None)) )
# 10636 "parsing/parser.ml"
               : 'simple_pattern_not_ident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'name_tag) in
    Obj.repr(
# 1817 "parsing/parser.mly"
      ( mkpat(Ppat_variant(_1, None)) )
# 10643 "parsing/parser.ml"
               : 'simple_pattern_not_ident))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'type_longident) in
    Obj.repr(
# 1819 "parsing/parser.mly"
      ( mkpat(Ppat_type (mkrhs _2 2)) )
# 10650 "parsing/parser.ml"
               : 'simple_pattern_not_ident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_delimited_pattern) in
    Obj.repr(
# 1821 "parsing/parser.mly"
      ( _1 )
# 10657 "parsing/parser.ml"
               : 'simple_pattern_not_ident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'mod_longident) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'simple_delimited_pattern) in
    Obj.repr(
# 1823 "parsing/parser.mly"
      ( mkpat @@ Ppat_open(mkrhs _1 1, _3) )
# 10665 "parsing/parser.ml"
               : 'simple_pattern_not_ident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 3 : 'mod_longident) in
    Obj.repr(
# 1825 "parsing/parser.mly"
    ( mkpat @@ Ppat_open(mkrhs _1 1, mkpat @@
               Ppat_construct ( mkrhs (Lident "[]") 4, None)) )
# 10673 "parsing/parser.ml"
               : 'simple_pattern_not_ident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 3 : 'mod_longident) in
    Obj.repr(
# 1828 "parsing/parser.mly"
      ( mkpat @@ Ppat_open( mkrhs _1 1, mkpat @@
                 Ppat_construct ( mkrhs (Lident "()") 4, None) ) )
# 10681 "parsing/parser.ml"
               : 'simple_pattern_not_ident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'pattern) in
    Obj.repr(
# 1831 "parsing/parser.mly"
      ( mkpat @@ Ppat_open (mkrhs _1 1, _4))
# 10689 "parsing/parser.ml"
               : 'simple_pattern_not_ident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'pattern) in
    Obj.repr(
# 1833 "parsing/parser.mly"
      (unclosed "(" 3 ")" 5  )
# 10697 "parsing/parser.ml"
               : 'simple_pattern_not_ident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 3 : 'mod_longident) in
    Obj.repr(
# 1835 "parsing/parser.mly"
      ( expecting 4 "pattern" )
# 10704 "parsing/parser.ml"
               : 'simple_pattern_not_ident))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'pattern) in
    Obj.repr(
# 1837 "parsing/parser.mly"
      ( reloc_pat _2 )
# 10711 "parsing/parser.ml"
               : 'simple_pattern_not_ident))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'pattern) in
    Obj.repr(
# 1839 "parsing/parser.mly"
      ( unclosed "(" 1 ")" 3 )
# 10718 "parsing/parser.ml"
               : 'simple_pattern_not_ident))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'pattern) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'core_type) in
    Obj.repr(
# 1841 "parsing/parser.mly"
      ( mkpat(Ppat_constraint(_2, _4)) )
# 10726 "parsing/parser.ml"
               : 'simple_pattern_not_ident))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'pattern) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'core_type) in
    Obj.repr(
# 1843 "parsing/parser.mly"
      ( unclosed "(" 1 ")" 5 )
# 10734 "parsing/parser.ml"
               : 'simple_pattern_not_ident))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in
    Obj.repr(
# 1845 "parsing/parser.mly"
      ( expecting 4 "type" )
# 10741 "parsing/parser.ml"
               : 'simple_pattern_not_ident))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : string) in
    Obj.repr(
# 1847 "parsing/parser.mly"
      ( mkpat_attrs (Ppat_unpack (mkrhs _4 4)) _3 )
# 10749 "parsing/parser.ml"
               : 'simple_pattern_not_ident))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _6 = (Parsing.peek_val __caml_parser_env 1 : 'package_type) in
    Obj.repr(
# 1849 "parsing/parser.mly"
      ( mkpat_attrs
          (Ppat_constraint(mkpat(Ppat_unpack (mkrhs _4 4)),
                           ghtyp(Ptyp_package _6)))
          _3 )
# 10761 "parsing/parser.ml"
               : 'simple_pattern_not_ident))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _6 = (Parsing.peek_val __caml_parser_env 1 : 'package_type) in
    Obj.repr(
# 1854 "parsing/parser.mly"
      ( unclosed "(" 1 ")" 7 )
# 10770 "parsing/parser.ml"
               : 'simple_pattern_not_ident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'extension) in
    Obj.repr(
# 1856 "parsing/parser.mly"
      ( mkpat(Ppat_extension _1) )
# 10777 "parsing/parser.ml"
               : 'simple_pattern_not_ident))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'lbl_pattern_list) in
    Obj.repr(
# 1861 "parsing/parser.mly"
    ( let (fields, closed) = _2 in mkpat(Ppat_record(fields, closed)) )
# 10784 "parsing/parser.ml"
               : 'simple_delimited_pattern))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'lbl_pattern_list) in
    Obj.repr(
# 1863 "parsing/parser.mly"
    ( unclosed "{" 1 "}" 3 )
# 10791 "parsing/parser.ml"
               : 'simple_delimited_pattern))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_semi_list) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in
    Obj.repr(
# 1865 "parsing/parser.mly"
    ( reloc_pat (mktailpat (rhs_loc 4) (List.rev _2)) )
# 10799 "parsing/parser.ml"
               : 'simple_delimited_pattern))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_semi_list) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in
    Obj.repr(
# 1867 "parsing/parser.mly"
    ( unclosed "[" 1 "]" 4 )
# 10807 "parsing/parser.ml"
               : 'simple_delimited_pattern))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_semi_list) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in
    Obj.repr(
# 1869 "parsing/parser.mly"
    ( mkpat(Ppat_array(List.rev _2)) )
# 10815 "parsing/parser.ml"
               : 'simple_delimited_pattern))
; (fun __caml_parser_env ->
    Obj.repr(
# 1871 "parsing/parser.mly"
    ( mkpat(Ppat_array []) )
# 10821 "parsing/parser.ml"
               : 'simple_delimited_pattern))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_semi_list) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in
    Obj.repr(
# 1873 "parsing/parser.mly"
    ( unclosed "[|" 1 "|]" 4 )
# 10829 "parsing/parser.ml"
               : 'simple_delimited_pattern))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_comma_list) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in
    Obj.repr(
# 1876 "parsing/parser.mly"
                                                ( _3 :: _1 )
# 10837 "parsing/parser.ml"
               : 'pattern_comma_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in
    Obj.repr(
# 1877 "parsing/parser.mly"
                                                ( [_3; _1] )
# 10845 "parsing/parser.ml"
               : 'pattern_comma_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in
    Obj.repr(
# 1878 "parsing/parser.mly"
                                                ( expecting 3 "pattern" )
# 10852 "parsing/parser.ml"
               : 'pattern_comma_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_no_exn_comma_list) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in
    Obj.repr(
# 1881 "parsing/parser.mly"
                                                ( _3 :: _1 )
# 10860 "parsing/parser.ml"
               : 'pattern_no_exn_comma_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_no_exn) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in
    Obj.repr(
# 1882 "parsing/parser.mly"
                                                ( [_3; _1] )
# 10868 "parsing/parser.ml"
               : 'pattern_no_exn_comma_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_no_exn) in
    Obj.repr(
# 1883 "parsing/parser.mly"
                                                ( expecting 3 "pattern" )
# 10875 "parsing/parser.ml"
               : 'pattern_no_exn_comma_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in
    Obj.repr(
# 1886 "parsing/parser.mly"
                                                ( [_1] )
# 10882 "parsing/parser.ml"
               : 'pattern_semi_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_semi_list) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in
    Obj.repr(
# 1887 "parsing/parser.mly"
                                                ( _3 :: _1 )
# 10890 "parsing/parser.ml"
               : 'pattern_semi_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'lbl_pattern) in
    Obj.repr(
# 1890 "parsing/parser.mly"
                ( [_1], Closed )
# 10897 "parsing/parser.ml"
               : 'lbl_pattern_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'lbl_pattern) in
    Obj.repr(
# 1891 "parsing/parser.mly"
                     ( [_1], Closed )
# 10904 "parsing/parser.ml"
               : 'lbl_pattern_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 3 : 'lbl_pattern) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'opt_semi) in
    Obj.repr(
# 1892 "parsing/parser.mly"
                                         ( [_1], Open )
# 10912 "parsing/parser.ml"
               : 'lbl_pattern_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'lbl_pattern) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'lbl_pattern_list) in
    Obj.repr(
# 1894 "parsing/parser.mly"
      ( let (fields, closed) = _3 in _1 :: fields, closed )
# 10920 "parsing/parser.ml"
               : 'lbl_pattern_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 3 : 'label_longident) in
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'opt_pattern_type_constraint) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in
    Obj.repr(
# 1898 "parsing/parser.mly"
     ( (mkrhs _1 1, mkpat_opt_constraint _4 _2) )
# 10929 "parsing/parser.ml"
               : 'lbl_pattern))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'label_longident) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'opt_pattern_type_constraint) in
    Obj.repr(
# 1900 "parsing/parser.mly"
     ( (mkrhs _1 1, mkpat_opt_constraint (pat_of_label _1 1) _2) )
# 10937 "parsing/parser.ml"
               : 'lbl_pattern))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in
    Obj.repr(
# 1903 "parsing/parser.mly"
                    ( Some _2 )
# 10944 "parsing/parser.ml"
               : 'opt_pattern_type_constraint))
; (fun __caml_parser_env ->
    Obj.repr(
# 1904 "parsing/parser.mly"
                ( None )
# 10950 "parsing/parser.ml"
               : 'opt_pattern_type_constraint))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 3 : 'val_ident) in
    let _5 = (Parsing.peek_val __caml_parser_env 1 : 'core_type) in
    let _6 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1911 "parsing/parser.mly"
      ( let (ext, attrs) = _2 in
        Val.mk (mkrhs _3 3) _5 ~attrs:(attrs@_6)
              ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
      , ext )
# 10963 "parsing/parser.ml"
               : 'value_description))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string * string option) in
    Obj.repr(
# 1920 "parsing/parser.mly"
                                                ( [fst _1] )
# 10970 "parsing/parser.ml"
               : 'primitive_declaration_body))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : string * string option) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'primitive_declaration_body) in
    Obj.repr(
# 1921 "parsing/parser.mly"
                                                ( fst _1 :: _2 )
# 10978 "parsing/parser.ml"
               : 'primitive_declaration_body))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 6 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 5 : 'val_ident) in
    let _5 = (Parsing.peek_val __caml_parser_env 3 : 'core_type) in
    let _7 = (Parsing.peek_val __caml_parser_env 1 : 'primitive_declaration_body) in
    let _8 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1926 "parsing/parser.mly"
      ( let (ext, attrs) = _2 in
        Val.mk (mkrhs _3 3) _5 ~prim:_7 ~attrs:(attrs@_8)
              ~loc:(symbol_rloc ()) ~docs:(symbol_docs ())
      , ext )
# 10992 "parsing/parser.ml"
               : 'primitive_declaration))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'type_declaration) in
    Obj.repr(
# 1936 "parsing/parser.mly"
      ( let (nonrec_flag, ty, ext) = _1 in (nonrec_flag, [ty], ext) )
# 10999 "parsing/parser.ml"
               : 'type_declarations))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'type_declarations) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'and_type_declaration) in
    Obj.repr(
# 1938 "parsing/parser.mly"
      ( let (nonrec_flag, tys, ext) = _1 in (nonrec_flag, _2 :: tys, ext) )
# 11007 "parsing/parser.ml"
               : 'type_declarations))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 6 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 5 : 'nonrec_flag) in
    let _4 = (Parsing.peek_val __caml_parser_env 4 : 'optional_type_parameters) in
    let _5 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _6 = (Parsing.peek_val __caml_parser_env 2 : 'type_kind) in
    let _7 = (Parsing.peek_val __caml_parser_env 1 : 'constraints) in
    let _8 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1944 "parsing/parser.mly"
      ( let (kind, priv, manifest) = _6 in
        let (ext, attrs) = _2 in
        let ty =
          Type.mk (mkrhs _5 5) ~params:_4 ~cstrs:(List.rev _7) ~kind
            ~priv ?manifest ~attrs:(attrs@_8)
            ~loc:(symbol_rloc ()) ~docs:(symbol_docs ())
        in
          (_3, ty, ext) )
# 11027 "parsing/parser.ml"
               : 'type_declaration))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 5 : 'attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'optional_type_parameters) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _5 = (Parsing.peek_val __caml_parser_env 2 : 'type_kind) in
    let _6 = (Parsing.peek_val __caml_parser_env 1 : 'constraints) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 1956 "parsing/parser.mly"
      ( let (kind, priv, manifest) = _5 in
          Type.mk (mkrhs _4 4) ~params:_3 ~cstrs:(List.rev _6)
            ~kind ~priv ?manifest ~attrs:(_2@_7) ~loc:(symbol_rloc ())
            ~text:(symbol_text ()) ~docs:(symbol_docs ()) )
# 11042 "parsing/parser.ml"
               : 'and_type_declaration))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'constraints) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'constrain) in
    Obj.repr(
# 1962 "parsing/parser.mly"
                                                ( _3 :: _1 )
# 11050 "parsing/parser.ml"
               : 'constraints))
; (fun __caml_parser_env ->
    Obj.repr(
# 1963 "parsing/parser.mly"
                                                ( [] )
# 11056 "parsing/parser.ml"
               : 'constraints))
; (fun __caml_parser_env ->
    Obj.repr(
# 1967 "parsing/parser.mly"
      ( (Ptype_abstract, Public, None) )
# 11062 "parsing/parser.ml"
               : 'type_kind))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in
    Obj.repr(
# 1969 "parsing/parser.mly"
      ( (Ptype_abstract, Public, Some _2) )
# 11069 "parsing/parser.ml"
               : 'type_kind))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in
    Obj.repr(
# 1971 "parsing/parser.mly"
      ( (Ptype_abstract, Private, Some _3) )
# 11076 "parsing/parser.ml"
               : 'type_kind))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'constructor_declarations) in
    Obj.repr(
# 1973 "parsing/parser.mly"
      ( (Ptype_variant(List.rev _2), Public, None) )
# 11083 "parsing/parser.ml"
               : 'type_kind))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'constructor_declarations) in
    Obj.repr(
# 1975 "parsing/parser.mly"
      ( (Ptype_variant(List.rev _3), Private, None) )
# 11090 "parsing/parser.ml"
               : 'type_kind))
; (fun __caml_parser_env ->
    Obj.repr(
# 1977 "parsing/parser.mly"
      ( (Ptype_open, Public, None) )
# 11096 "parsing/parser.ml"
               : 'type_kind))
; (fun __caml_parser_env ->
    Obj.repr(
# 1979 "parsing/parser.mly"
      ( (Ptype_open, Private, None) )
# 11102 "parsing/parser.ml"
               : 'type_kind))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'private_flag) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'label_declarations) in
    Obj.repr(
# 1981 "parsing/parser.mly"
      ( (Ptype_record _4, _2, None) )
# 11110 "parsing/parser.ml"
               : 'type_kind))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'core_type) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'private_flag) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'constructor_declarations) in
    Obj.repr(
# 1983 "parsing/parser.mly"
      ( (Ptype_variant(List.rev _5), _4, Some _2) )
# 11119 "parsing/parser.ml"
               : 'type_kind))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'core_type) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'private_flag) in
    Obj.repr(
# 1985 "parsing/parser.mly"
      ( (Ptype_open, _4, Some _2) )
# 11127 "parsing/parser.ml"
               : 'type_kind))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 5 : 'core_type) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : 'private_flag) in
    let _6 = (Parsing.peek_val __caml_parser_env 1 : 'label_declarations) in
    Obj.repr(
# 1987 "parsing/parser.mly"
      ( (Ptype_record _6, _4, Some _2) )
# 11136 "parsing/parser.ml"
               : 'type_kind))
; (fun __caml_parser_env ->
    Obj.repr(
# 1990 "parsing/parser.mly"
                                                ( [] )
# 11142 "parsing/parser.ml"
               : 'optional_type_parameters))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'optional_type_parameter) in
    Obj.repr(
# 1991 "parsing/parser.mly"
                                                ( [_1] )
# 11149 "parsing/parser.ml"
               : 'optional_type_parameters))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'optional_type_parameter_list) in
    Obj.repr(
# 1992 "parsing/parser.mly"
                                                ( List.rev _2 )
# 11156 "parsing/parser.ml"
               : 'optional_type_parameters))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'type_variance) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'optional_type_variable) in
    Obj.repr(
# 1995 "parsing/parser.mly"
                                                ( _2, _1 )
# 11164 "parsing/parser.ml"
               : 'optional_type_parameter))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'optional_type_parameter) in
    Obj.repr(
# 1998 "parsing/parser.mly"
                                                         ( [_1] )
# 11171 "parsing/parser.ml"
               : 'optional_type_parameter_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'optional_type_parameter_list) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'optional_type_parameter) in
    Obj.repr(
# 1999 "parsing/parser.mly"
                                                                  ( _3 :: _1 )
# 11179 "parsing/parser.ml"
               : 'optional_type_parameter_list))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'ident) in
    Obj.repr(
# 2002 "parsing/parser.mly"
                                                ( mktyp(Ptyp_var _2) )
# 11186 "parsing/parser.ml"
               : 'optional_type_variable))
; (fun __caml_parser_env ->
    Obj.repr(
# 2003 "parsing/parser.mly"
                                                ( mktyp(Ptyp_any) )
# 11192 "parsing/parser.ml"
               : 'optional_type_variable))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'type_variance) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'type_variable) in
    Obj.repr(
# 2008 "parsing/parser.mly"
                                                  ( _2, _1 )
# 11200 "parsing/parser.ml"
               : 'type_parameter))
; (fun __caml_parser_env ->
    Obj.repr(
# 2011 "parsing/parser.mly"
                                                ( Invariant )
# 11206 "parsing/parser.ml"
               : 'type_variance))
; (fun __caml_parser_env ->
    Obj.repr(
# 2012 "parsing/parser.mly"
                                                ( Covariant )
# 11212 "parsing/parser.ml"
               : 'type_variance))
; (fun __caml_parser_env ->
    Obj.repr(
# 2013 "parsing/parser.mly"
                                                ( Contravariant )
# 11218 "parsing/parser.ml"
               : 'type_variance))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'ident) in
    Obj.repr(
# 2016 "parsing/parser.mly"
                                                ( mktyp(Ptyp_var _2) )
# 11225 "parsing/parser.ml"
               : 'type_variable))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'type_parameter) in
    Obj.repr(
# 2019 "parsing/parser.mly"
                                                ( [_1] )
# 11232 "parsing/parser.ml"
               : 'type_parameter_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'type_parameter_list) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'type_parameter) in
    Obj.repr(
# 2020 "parsing/parser.mly"
                                                ( _3 :: _1 )
# 11240 "parsing/parser.ml"
               : 'type_parameter_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'constructor_declaration) in
    Obj.repr(
# 2023 "parsing/parser.mly"
                                                         ( [_1] )
# 11247 "parsing/parser.ml"
               : 'constructor_declarations))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'bar_constructor_declaration) in
    Obj.repr(
# 2024 "parsing/parser.mly"
                                                         ( [_1] )
# 11254 "parsing/parser.ml"
               : 'constructor_declarations))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'constructor_declarations) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'bar_constructor_declaration) in
    Obj.repr(
# 2025 "parsing/parser.mly"
                                                         ( _2 :: _1 )
# 11262 "parsing/parser.ml"
               : 'constructor_declarations))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'constr_ident) in
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'generalized_constructor_arguments) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in
    Obj.repr(
# 2029 "parsing/parser.mly"
      (
       let args,res = _2 in
       Type.constructor (mkrhs _1 1) ~args ?res ~attrs:_3
         ~loc:(symbol_rloc()) ~info:(symbol_info ())
      )
# 11275 "parsing/parser.ml"
               : 'constructor_declaration))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'constr_ident) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'generalized_constructor_arguments) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in
    Obj.repr(
# 2037 "parsing/parser.mly"
      (
       let args,res = _3 in
       Type.constructor (mkrhs _2 2) ~args ?res ~attrs:_4
         ~loc:(symbol_rloc()) ~info:(symbol_info ())
      )
# 11288 "parsing/parser.ml"
               : 'bar_constructor_declaration))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'sig_exception_declaration) in
    Obj.repr(
# 2044 "parsing/parser.mly"
                                                 ( _1 )
# 11295 "parsing/parser.ml"
               : 'str_exception_declaration))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 5 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 4 : 'constr_ident) in
    let _5 = (Parsing.peek_val __caml_parser_env 2 : 'constr_longident) in
    let _6 = (Parsing.peek_val __caml_parser_env 1 : 'attributes) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 2047 "parsing/parser.mly"
      ( let (ext,attrs) = _2 in
        Te.rebind (mkrhs _3 3) (mkrhs _5 5) ~attrs:(attrs @ _6 @ _7)
          ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
        , ext )
# 11309 "parsing/parser.ml"
               : 'str_exception_declaration))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 3 : 'constr_ident) in
    let _4 = (Parsing.peek_val __caml_parser_env 2 : 'generalized_constructor_arguments) in
    let _5 = (Parsing.peek_val __caml_parser_env 1 : 'attributes) in
    let _6 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 2055 "parsing/parser.mly"
      ( let args, res = _4 in
        let (ext,attrs) = _2 in
          Te.decl (mkrhs _3 3) ~args ?res ~attrs:(attrs @ _5 @ _6)
            ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
        , ext )
# 11324 "parsing/parser.ml"
               : 'sig_exception_declaration))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'constr_ident) in
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'generalized_constructor_arguments) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in
    Obj.repr(
# 2063 "parsing/parser.mly"
      ( let args, res = _2 in
        Te.decl (mkrhs _1 1) ~args ?res ~attrs:_3 ~loc:(symbol_rloc()) )
# 11334 "parsing/parser.ml"
               : 'let_exception_declaration))
; (fun __caml_parser_env ->
    Obj.repr(
# 2067 "parsing/parser.mly"
                                  ( (Pcstr_tuple [],None) )
# 11340 "parsing/parser.ml"
               : 'generalized_constructor_arguments))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'constructor_arguments) in
    Obj.repr(
# 2068 "parsing/parser.mly"
                                  ( (_2,None) )
# 11347 "parsing/parser.ml"
               : 'generalized_constructor_arguments))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'constructor_arguments) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'simple_core_type) in
    Obj.repr(
# 2070 "parsing/parser.mly"
                                  ( (_2,Some _4) )
# 11355 "parsing/parser.ml"
               : 'generalized_constructor_arguments))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'simple_core_type) in
    Obj.repr(
# 2072 "parsing/parser.mly"
                                  ( (Pcstr_tuple [],Some _2) )
# 11362 "parsing/parser.ml"
               : 'generalized_constructor_arguments))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'core_type_list) in
    Obj.repr(
# 2076 "parsing/parser.mly"
                                     ( Pcstr_tuple (List.rev _1) )
# 11369 "parsing/parser.ml"
               : 'constructor_arguments))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'label_declarations) in
    Obj.repr(
# 2077 "parsing/parser.mly"
                                     ( Pcstr_record _2 )
# 11376 "parsing/parser.ml"
               : 'constructor_arguments))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'label_declaration) in
    Obj.repr(
# 2080 "parsing/parser.mly"
                                                ( [_1] )
# 11383 "parsing/parser.ml"
               : 'label_declarations))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'label_declaration_semi) in
    Obj.repr(
# 2081 "parsing/parser.mly"
                                                ( [_1] )
# 11390 "parsing/parser.ml"
               : 'label_declarations))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'label_declaration_semi) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'label_declarations) in
    Obj.repr(
# 2082 "parsing/parser.mly"
                                                ( _1 :: _2 )
# 11398 "parsing/parser.ml"
               : 'label_declarations))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'mutable_flag) in
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'label) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'poly_type_no_attr) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in
    Obj.repr(
# 2086 "parsing/parser.mly"
      (
       Type.field (mkrhs _2 2) _4 ~mut:_1 ~attrs:_5
         ~loc:(symbol_rloc()) ~info:(symbol_info ())
      )
# 11411 "parsing/parser.ml"
               : 'label_declaration))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 6 : 'mutable_flag) in
    let _2 = (Parsing.peek_val __caml_parser_env 5 : 'label) in
    let _4 = (Parsing.peek_val __caml_parser_env 3 : 'poly_type_no_attr) in
    let _5 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in
    let _7 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in
    Obj.repr(
# 2093 "parsing/parser.mly"
      (
       let info =
         match rhs_info 5 with
         | Some _ as info_before_semi -> info_before_semi
         | None -> symbol_info ()
       in
       Type.field (mkrhs _2 2) _4 ~mut:_1 ~attrs:(_5 @ _7)
         ~loc:(symbol_rloc()) ~info
      )
# 11430 "parsing/parser.ml"
               : 'label_declaration_semi))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 7 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 6 : 'nonrec_flag) in
    let _4 = (Parsing.peek_val __caml_parser_env 5 : 'optional_type_parameters) in
    let _5 = (Parsing.peek_val __caml_parser_env 4 : 'type_longident) in
    let _7 = (Parsing.peek_val __caml_parser_env 2 : 'private_flag) in
    let _8 = (Parsing.peek_val __caml_parser_env 1 : 'str_extension_constructors) in
    let _9 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 2109 "parsing/parser.mly"
      ( let (ext, attrs) = _2 in
        if _3 <> Recursive then not_expecting 3 "nonrec flag";
        Te.mk (mkrhs _5 5) (List.rev _8) ~params:_4 ~priv:_7
          ~attrs:(attrs@_9) ~docs:(symbol_docs ())
        , ext )
# 11447 "parsing/parser.ml"
               : 'str_type_extension))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 7 : 'ext_attributes) in
    let _3 = (Parsing.peek_val __caml_parser_env 6 : 'nonrec_flag) in
    let _4 = (Parsing.peek_val __caml_parser_env 5 : 'optional_type_parameters) in
    let _5 = (Parsing.peek_val __caml_parser_env 4 : 'type_longident) in
    let _7 = (Parsing.peek_val __caml_parser_env 2 : 'private_flag) in
    let _8 = (Parsing.peek_val __caml_parser_env 1 : 'sig_extension_constructors) in
    let _9 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 2118 "parsing/parser.mly"
      ( let (ext, attrs) = _2 in
        if _3 <> Recursive then not_expecting 3 "nonrec flag";
        Te.mk (mkrhs _5 5) (List.rev _8) ~params:_4 ~priv:_7
          ~attrs:(attrs @ _9) ~docs:(symbol_docs ())
        , ext )
# 11464 "parsing/parser.ml"
               : 'sig_type_extension))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'extension_constructor_declaration) in
    Obj.repr(
# 2125 "parsing/parser.mly"
                                                          ( [_1] )
# 11471 "parsing/parser.ml"
               : 'str_extension_constructors))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'bar_extension_constructor_declaration) in
    Obj.repr(
# 2126 "parsing/parser.mly"
                                                          ( [_1] )
# 11478 "parsing/parser.ml"
               : 'str_extension_constructors))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'extension_constructor_rebind) in
    Obj.repr(
# 2127 "parsing/parser.mly"
                                                          ( [_1] )
# 11485 "parsing/parser.ml"
               : 'str_extension_constructors))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'bar_extension_constructor_rebind) in
    Obj.repr(
# 2128 "parsing/parser.mly"
                                                          ( [_1] )
# 11492 "parsing/parser.ml"
               : 'str_extension_constructors))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'str_extension_constructors) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'bar_extension_constructor_declaration) in
    Obj.repr(
# 2130 "parsing/parser.mly"
      ( _2 :: _1 )
# 11500 "parsing/parser.ml"
               : 'str_extension_constructors))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'str_extension_constructors) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'bar_extension_constructor_rebind) in
    Obj.repr(
# 2132 "parsing/parser.mly"
      ( _2 :: _1 )
# 11508 "parsing/parser.ml"
               : 'str_extension_constructors))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'extension_constructor_declaration) in
    Obj.repr(
# 2135 "parsing/parser.mly"
                                                          ( [_1] )
# 11515 "parsing/parser.ml"
               : 'sig_extension_constructors))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'bar_extension_constructor_declaration) in
    Obj.repr(
# 2136 "parsing/parser.mly"
                                                          ( [_1] )
# 11522 "parsing/parser.ml"
               : 'sig_extension_constructors))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'sig_extension_constructors) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'bar_extension_constructor_declaration) in
    Obj.repr(
# 2138 "parsing/parser.mly"
      ( _2 :: _1 )
# 11530 "parsing/parser.ml"
               : 'sig_extension_constructors))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'constr_ident) in
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'generalized_constructor_arguments) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in
    Obj.repr(
# 2142 "parsing/parser.mly"
      ( let args, res = _2 in
        Te.decl (mkrhs _1 1) ~args ?res ~attrs:_3
          ~loc:(symbol_rloc()) ~info:(symbol_info ()) )
# 11541 "parsing/parser.ml"
               : 'extension_constructor_declaration))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'constr_ident) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'generalized_constructor_arguments) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in
    Obj.repr(
# 2148 "parsing/parser.mly"
      ( let args, res = _3 in
        Te.decl (mkrhs _2 2) ~args ?res ~attrs:_4
           ~loc:(symbol_rloc()) ~info:(symbol_info ()) )
# 11552 "parsing/parser.ml"
               : 'bar_extension_constructor_declaration))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 3 : 'constr_ident) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'constr_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in
    Obj.repr(
# 2154 "parsing/parser.mly"
      ( Te.rebind (mkrhs _1 1) (mkrhs _3 3) ~attrs:_4
          ~loc:(symbol_rloc()) ~info:(symbol_info ()) )
# 11562 "parsing/parser.ml"
               : 'extension_constructor_rebind))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'constr_ident) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'constr_longident) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in
    Obj.repr(
# 2159 "parsing/parser.mly"
      ( Te.rebind (mkrhs _2 2) (mkrhs _4 4) ~attrs:_5
          ~loc:(symbol_rloc()) ~info:(symbol_info ()) )
# 11572 "parsing/parser.ml"
               : 'bar_extension_constructor_rebind))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'with_constraint) in
    Obj.repr(
# 2166 "parsing/parser.mly"
                                                ( [_1] )
# 11579 "parsing/parser.ml"
               : 'with_constraints))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'with_constraints) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'with_constraint) in
    Obj.repr(
# 2167 "parsing/parser.mly"
                                                ( _3 :: _1 )
# 11587 "parsing/parser.ml"
               : 'with_constraints))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 4 : 'optional_type_parameters) in
    let _3 = (Parsing.peek_val __caml_parser_env 3 : 'label_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 2 : 'with_type_binder) in
    let _5 = (Parsing.peek_val __caml_parser_env 1 : 'core_type_no_attr) in
    let _6 = (Parsing.peek_val __caml_parser_env 0 : 'constraints) in
    Obj.repr(
# 2172 "parsing/parser.mly"
      ( Pwith_type
          (mkrhs _3 3,
           (Type.mk (mkrhs (Longident.last _3) 3)
              ~params:_2
              ~cstrs:(List.rev _6)
              ~manifest:_5
              ~priv:_4
              ~loc:(symbol_rloc()))) )
# 11605 "parsing/parser.ml"
               : 'with_constraint))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'optional_type_parameters) in
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'label_longident) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'core_type_no_attr) in
    Obj.repr(
# 2183 "parsing/parser.mly"
      ( Pwith_typesubst
         (mkrhs _3 3,
           (Type.mk (mkrhs (Longident.last _3) 3)
             ~params:_2
             ~manifest:_5
             ~loc:(symbol_rloc()))) )
# 11619 "parsing/parser.ml"
               : 'with_constraint))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'mod_ext_longident) in
    Obj.repr(
# 2190 "parsing/parser.mly"
      ( Pwith_module (mkrhs _2 2, mkrhs _4 4) )
# 11627 "parsing/parser.ml"
               : 'with_constraint))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'mod_longident) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'mod_ext_longident) in
    Obj.repr(
# 2192 "parsing/parser.mly"
      ( Pwith_modsubst (mkrhs _2 2, mkrhs _4 4) )
# 11635 "parsing/parser.ml"
               : 'with_constraint))
; (fun __caml_parser_env ->
    Obj.repr(
# 2195 "parsing/parser.mly"
                   ( Public )
# 11641 "parsing/parser.ml"
               : 'with_type_binder))
; (fun __caml_parser_env ->
    Obj.repr(
# 2196 "parsing/parser.mly"
                   ( Private )
# 11647 "parsing/parser.ml"
               : 'with_type_binder))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'ident) in
    Obj.repr(
# 2202 "parsing/parser.mly"
                                                ( [mkrhs _2 2] )
# 11654 "parsing/parser.ml"
               : 'typevar_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'typevar_list) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'ident) in
    Obj.repr(
# 2203 "parsing/parser.mly"
                                                ( mkrhs _3 3 :: _1 )
# 11662 "parsing/parser.ml"
               : 'typevar_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in
    Obj.repr(
# 2207 "parsing/parser.mly"
          ( _1 )
# 11669 "parsing/parser.ml"
               : 'poly_type))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'typevar_list) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in
    Obj.repr(
# 2209 "parsing/parser.mly"
          ( mktyp(Ptyp_poly(List.rev _1, _3)) )
# 11677 "parsing/parser.ml"
               : 'poly_type))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'core_type_no_attr) in
    Obj.repr(
# 2213 "parsing/parser.mly"
          ( _1 )
# 11684 "parsing/parser.ml"
               : 'poly_type_no_attr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'typevar_list) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type_no_attr) in
    Obj.repr(
# 2215 "parsing/parser.mly"
          ( mktyp(Ptyp_poly(List.rev _1, _3)) )
# 11692 "parsing/parser.ml"
               : 'poly_type_no_attr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'core_type_no_attr) in
    Obj.repr(
# 2222 "parsing/parser.mly"
      ( _1 )
# 11699 "parsing/parser.ml"
               : 'core_type))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'core_type) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attribute) in
    Obj.repr(
# 2224 "parsing/parser.mly"
      ( Typ.attr _1 _2 )
# 11707 "parsing/parser.ml"
               : 'core_type))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'core_type2) in
    Obj.repr(
# 2228 "parsing/parser.mly"
      ( _1 )
# 11714 "parsing/parser.ml"
               : 'core_type_no_attr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 3 : 'core_type2) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'ident) in
    Obj.repr(
# 2230 "parsing/parser.mly"
      ( mktyp(Ptyp_alias(_1, _4)) )
# 11722 "parsing/parser.ml"
               : 'core_type_no_attr))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_core_type_or_tuple) in
    Obj.repr(
# 2234 "parsing/parser.mly"
      ( _1 )
# 11729 "parsing/parser.ml"
               : 'core_type2))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 4 : string) in
    let _4 = (Parsing.peek_val __caml_parser_env 2 : 'core_type2) in
    let _6 = (Parsing.peek_val __caml_parser_env 0 : 'core_type2) in
    Obj.repr(
# 2236 "parsing/parser.mly"
      ( let param = extra_rhs_core_type _4 ~pos:4 in
        mktyp (Ptyp_arrow(Optional _2 , param, _6)) )
# 11739 "parsing/parser.ml"
               : 'core_type2))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 3 : string) in
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'core_type2) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'core_type2) in
    Obj.repr(
# 2239 "parsing/parser.mly"
      ( let param = extra_rhs_core_type _2 ~pos:2 in
        mktyp(Ptyp_arrow(Optional _1 , param, _4))
      )
# 11750 "parsing/parser.ml"
               : 'core_type2))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : string) in
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'core_type2) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'core_type2) in
    Obj.repr(
# 2243 "parsing/parser.mly"
      ( let param = extra_rhs_core_type _3 ~pos:3 in
        mktyp(Ptyp_arrow(Labelled _1, param, _5)) )
# 11760 "parsing/parser.ml"
               : 'core_type2))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'core_type2) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type2) in
    Obj.repr(
# 2246 "parsing/parser.mly"
      ( let param = extra_rhs_core_type _1 ~pos:1 in
        mktyp(Ptyp_arrow(Nolabel, param, _3)) )
# 11769 "parsing/parser.ml"
               : 'core_type2))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_core_type2) in
    Obj.repr(
# 2252 "parsing/parser.mly"
      ( _1 )
# 11776 "parsing/parser.ml"
               : 'simple_core_type))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'core_type_comma_list) in
    Obj.repr(
# 2254 "parsing/parser.mly"
      ( match _2 with [sty] -> sty | _ -> raise Parse_error )
# 11783 "parsing/parser.ml"
               : 'simple_core_type))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'ident) in
    Obj.repr(
# 2259 "parsing/parser.mly"
      ( mktyp(Ptyp_var _2) )
# 11790 "parsing/parser.ml"
               : 'simple_core_type2))
; (fun __caml_parser_env ->
    Obj.repr(
# 2261 "parsing/parser.mly"
      ( mktyp(Ptyp_any) )
# 11796 "parsing/parser.ml"
               : 'simple_core_type2))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'type_longident) in
    Obj.repr(
# 2263 "parsing/parser.mly"
      ( mktyp(Ptyp_constr(mkrhs _1 1, [])) )
# 11803 "parsing/parser.ml"
               : 'simple_core_type2))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'simple_core_type2) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'type_longident) in
    Obj.repr(
# 2265 "parsing/parser.mly"
      ( mktyp(Ptyp_constr(mkrhs _2 2, [_1])) )
# 11811 "parsing/parser.ml"
               : 'simple_core_type2))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'core_type_comma_list) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'type_longident) in
    Obj.repr(
# 2267 "parsing/parser.mly"
      ( mktyp(Ptyp_constr(mkrhs _4 4, List.rev _2)) )
# 11819 "parsing/parser.ml"
               : 'simple_core_type2))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'meth_list) in
    Obj.repr(
# 2269 "parsing/parser.mly"
      ( let (f, c) = _2 in mktyp(Ptyp_object (f, c)) )
# 11826 "parsing/parser.ml"
               : 'simple_core_type2))
; (fun __caml_parser_env ->
    Obj.repr(
# 2271 "parsing/parser.mly"
      ( mktyp(Ptyp_object ([], Closed)) )
# 11832 "parsing/parser.ml"
               : 'simple_core_type2))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'class_longident) in
    Obj.repr(
# 2273 "parsing/parser.mly"
      ( mktyp(Ptyp_class(mkrhs _2 2, [])) )
# 11839 "parsing/parser.ml"
               : 'simple_core_type2))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'simple_core_type2) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'class_longident) in
    Obj.repr(
# 2275 "parsing/parser.mly"
      ( mktyp(Ptyp_class(mkrhs _3 3, [_1])) )
# 11847 "parsing/parser.ml"
               : 'simple_core_type2))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'core_type_comma_list) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'class_longident) in
    Obj.repr(
# 2277 "parsing/parser.mly"
      ( mktyp(Ptyp_class(mkrhs _5 5, List.rev _2)) )
# 11855 "parsing/parser.ml"
               : 'simple_core_type2))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'tag_field) in
    Obj.repr(
# 2279 "parsing/parser.mly"
      ( mktyp(Ptyp_variant([_2], Closed, None)) )
# 11862 "parsing/parser.ml"
               : 'simple_core_type2))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'row_field_list) in
    Obj.repr(
# 2285 "parsing/parser.mly"
      ( mktyp(Ptyp_variant(List.rev _3, Closed, None)) )
# 11869 "parsing/parser.ml"
               : 'simple_core_type2))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 3 : 'row_field) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'row_field_list) in
    Obj.repr(
# 2287 "parsing/parser.mly"
      ( mktyp(Ptyp_variant(_2 :: List.rev _4, Closed, None)) )
# 11877 "parsing/parser.ml"
               : 'simple_core_type2))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'opt_bar) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'row_field_list) in
    Obj.repr(
# 2289 "parsing/parser.mly"
      ( mktyp(Ptyp_variant(List.rev _3, Open, None)) )
# 11885 "parsing/parser.ml"
               : 'simple_core_type2))
; (fun __caml_parser_env ->
    Obj.repr(
# 2291 "parsing/parser.mly"
      ( mktyp(Ptyp_variant([], Open, None)) )
# 11891 "parsing/parser.ml"
               : 'simple_core_type2))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'opt_bar) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'row_field_list) in
    Obj.repr(
# 2293 "parsing/parser.mly"
      ( mktyp(Ptyp_variant(List.rev _3, Closed, Some [])) )
# 11899 "parsing/parser.ml"
               : 'simple_core_type2))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 4 : 'opt_bar) in
    let _3 = (Parsing.peek_val __caml_parser_env 3 : 'row_field_list) in
    let _5 = (Parsing.peek_val __caml_parser_env 1 : 'name_tag_list) in
    Obj.repr(
# 2295 "parsing/parser.mly"
      ( mktyp(Ptyp_variant(List.rev _3, Closed, Some (List.rev _5))) )
# 11908 "parsing/parser.ml"
               : 'simple_core_type2))
; (fun __caml_parser_env ->
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'package_type) in
    Obj.repr(
# 2297 "parsing/parser.mly"
      ( mktyp_attrs (Ptyp_package _4) _3 )
# 11916 "parsing/parser.ml"
               : 'simple_core_type2))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'extension) in
    Obj.repr(
# 2299 "parsing/parser.mly"
      ( mktyp (Ptyp_extension _1) )
# 11923 "parsing/parser.ml"
               : 'simple_core_type2))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'module_type) in
    Obj.repr(
# 2302 "parsing/parser.mly"
                ( package_type_of_module_type _1 )
# 11930 "parsing/parser.ml"
               : 'package_type))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'row_field) in
    Obj.repr(
# 2305 "parsing/parser.mly"
                                                ( [_1] )
# 11937 "parsing/parser.ml"
               : 'row_field_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'row_field_list) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'row_field) in
    Obj.repr(
# 2306 "parsing/parser.mly"
                                                ( _3 :: _1 )
# 11945 "parsing/parser.ml"
               : 'row_field_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'tag_field) in
    Obj.repr(
# 2309 "parsing/parser.mly"
                                                ( _1 )
# 11952 "parsing/parser.ml"
               : 'row_field))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_core_type) in
    Obj.repr(
# 2310 "parsing/parser.mly"
                                                ( Rinherit _1 )
# 11959 "parsing/parser.ml"
               : 'row_field))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'name_tag) in
    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'opt_ampersand) in
    let _4 = (Parsing.peek_val __caml_parser_env 1 : 'amper_type_list) in
    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in
    Obj.repr(
# 2314 "parsing/parser.mly"
      ( Rtag (mkrhs _1 1, add_info_attrs (symbol_info ()) _5,
               _3, List.rev _4) )
# 11970 "parsing/parser.ml"
               : 'tag_field))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'name_tag) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in
    Obj.repr(
# 2317 "parsing/parser.mly"
      ( Rtag (mkrhs _1 1, add_info_attrs (symbol_info ()) _2, true, []) )
# 11978 "parsing/parser.ml"
               : 'tag_field))
; (fun __caml_parser_env ->
    Obj.repr(
# 2320 "parsing/parser.mly"
                                                ( true )
# 11984 "parsing/parser.ml"
               : 'opt_ampersand))
; (fun __caml_parser_env ->
    Obj.repr(
# 2321 "parsing/parser.mly"
                                                ( false )
# 11990 "parsing/parser.ml"
               : 'opt_ampersand))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'core_type_no_attr) in
    Obj.repr(
# 2324 "parsing/parser.mly"
                                                ( [_1] )
# 11997 "parsing/parser.ml"
               : 'amper_type_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'amper_type_list) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type_no_attr) in
    Obj.repr(
# 2325 "parsing/parser.mly"
                                                ( _3 :: _1 )
# 12005 "parsing/parser.ml"
               : 'amper_type_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'name_tag) in
    Obj.repr(
# 2328 "parsing/parser.mly"
                                                ( [_1] )
# 12012 "parsing/parser.ml"
               : 'name_tag_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'name_tag_list) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'name_tag) in
    Obj.repr(
# 2329 "parsing/parser.mly"
                                                ( _2 :: _1 )
# 12020 "parsing/parser.ml"
               : 'name_tag_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_core_type) in
    Obj.repr(
# 2332 "parsing/parser.mly"
                     ( _1 )
# 12027 "parsing/parser.ml"
               : 'simple_core_type_or_tuple))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'simple_core_type) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type_list) in
    Obj.repr(
# 2334 "parsing/parser.mly"
      ( mktyp(Ptyp_tuple(_1 :: List.rev _3)) )
# 12035 "parsing/parser.ml"
               : 'simple_core_type_or_tuple))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in
    Obj.repr(
# 2337 "parsing/parser.mly"
                                                ( [_1] )
# 12042 "parsing/parser.ml"
               : 'core_type_comma_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'core_type_comma_list) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in
    Obj.repr(
# 2338 "parsing/parser.mly"
                                                ( _3 :: _1 )
# 12050 "parsing/parser.ml"
               : 'core_type_comma_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_core_type) in
    Obj.repr(
# 2341 "parsing/parser.mly"
                                                ( [_1] )
# 12057 "parsing/parser.ml"
               : 'core_type_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'core_type_list) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'simple_core_type) in
    Obj.repr(
# 2342 "parsing/parser.mly"
                                                ( _3 :: _1 )
# 12065 "parsing/parser.ml"
               : 'core_type_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'field_semi) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'meth_list) in
    Obj.repr(
# 2345 "parsing/parser.mly"
                                                ( let (f, c) = _2 in (_1 :: f, c) )
# 12073 "parsing/parser.ml"
               : 'meth_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'inherit_field_semi) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'meth_list) in
    Obj.repr(
# 2346 "parsing/parser.mly"
                                                ( let (f, c) = _2 in (_1 :: f, c) )
# 12081 "parsing/parser.ml"
               : 'meth_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'field_semi) in
    Obj.repr(
# 2347 "parsing/parser.mly"
                                                ( [_1], Closed )
# 12088 "parsing/parser.ml"
               : 'meth_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'field) in
    Obj.repr(
# 2348 "parsing/parser.mly"
                                                ( [_1], Closed )
# 12095 "parsing/parser.ml"
               : 'meth_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'inherit_field_semi) in
    Obj.repr(
# 2349 "parsing/parser.mly"
                                                ( [_1], Closed )
# 12102 "parsing/parser.ml"
               : 'meth_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_core_type) in
    Obj.repr(
# 2350 "parsing/parser.mly"
                                                ( [Oinherit _1], Closed )
# 12109 "parsing/parser.ml"
               : 'meth_list))
; (fun __caml_parser_env ->
    Obj.repr(
# 2351 "parsing/parser.mly"
                                                ( [], Open )
# 12115 "parsing/parser.ml"
               : 'meth_list))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 3 : 'label) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'poly_type_no_attr) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in
    Obj.repr(
# 2355 "parsing/parser.mly"
    ( Otag (mkrhs _1 1, add_info_attrs (symbol_info ()) _4, _3) )
# 12124 "parsing/parser.ml"
               : 'field))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 5 : 'label) in
    let _3 = (Parsing.peek_val __caml_parser_env 3 : 'poly_type_no_attr) in
    let _4 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in
    let _6 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in
    Obj.repr(
# 2360 "parsing/parser.mly"
    ( let info =
        match rhs_info 4 with
        | Some _ as info_before_semi -> info_before_semi
        | None -> symbol_info ()
      in
      ( Otag (mkrhs _1 1, add_info_attrs info (_4 @ _6), _3)) )
# 12139 "parsing/parser.ml"
               : 'field_semi))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'simple_core_type) in
    Obj.repr(
# 2369 "parsing/parser.mly"
                        ( Oinherit _1 )
# 12146 "parsing/parser.ml"
               : 'inherit_field_semi))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2372 "parsing/parser.mly"
                                                ( _1 )
# 12153 "parsing/parser.ml"
               : 'label))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string * char option) in
    Obj.repr(
# 2378 "parsing/parser.mly"
                 ( let (n, m) = _1 in Pconst_integer (n, m) )
# 12160 "parsing/parser.ml"
               : 'constant))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : char) in
    Obj.repr(
# 2379 "parsing/parser.mly"
                 ( Pconst_char _1 )
# 12167 "parsing/parser.ml"
               : 'constant))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string * string option) in
    Obj.repr(
# 2380 "parsing/parser.mly"
                 ( let (s, d) = _1 in Pconst_string (s, d) )
# 12174 "parsing/parser.ml"
               : 'constant))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string * char option) in
    Obj.repr(
# 2381 "parsing/parser.mly"
                 ( let (f, m) = _1 in Pconst_float (f, m) )
# 12181 "parsing/parser.ml"
               : 'constant))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'constant) in
    Obj.repr(
# 2384 "parsing/parser.mly"
                 ( _1 )
# 12188 "parsing/parser.ml"
               : 'signed_constant))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : string * char option) in
    Obj.repr(
# 2385 "parsing/parser.mly"
                 ( let (n, m) = _2 in Pconst_integer("-" ^ n, m) )
# 12195 "parsing/parser.ml"
               : 'signed_constant))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : string * char option) in
    Obj.repr(
# 2386 "parsing/parser.mly"
                 ( let (f, m) = _2 in Pconst_float("-" ^ f, m) )
# 12202 "parsing/parser.ml"
               : 'signed_constant))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : string * char option) in
    Obj.repr(
# 2387 "parsing/parser.mly"
                 ( let (n, m) = _2 in Pconst_integer (n, m) )
# 12209 "parsing/parser.ml"
               : 'signed_constant))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : string * char option) in
    Obj.repr(
# 2388 "parsing/parser.mly"
                 ( let (f, m) = _2 in Pconst_float(f, m) )
# 12216 "parsing/parser.ml"
               : 'signed_constant))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2394 "parsing/parser.mly"
                                                ( _1 )
# 12223 "parsing/parser.ml"
               : 'ident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2395 "parsing/parser.mly"
                                                ( _1 )
# 12230 "parsing/parser.ml"
               : 'ident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2398 "parsing/parser.mly"
                                                ( _1 )
# 12237 "parsing/parser.ml"
               : 'val_ident))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'operator) in
    Obj.repr(
# 2399 "parsing/parser.mly"
                                                ( _2 )
# 12244 "parsing/parser.ml"
               : 'val_ident))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'operator) in
    Obj.repr(
# 2400 "parsing/parser.mly"
                                                ( unclosed "(" 1 ")" 3 )
# 12251 "parsing/parser.ml"
               : 'val_ident))
; (fun __caml_parser_env ->
    Obj.repr(
# 2401 "parsing/parser.mly"
                                                ( expecting 2 "operator" )
# 12257 "parsing/parser.ml"
               : 'val_ident))
; (fun __caml_parser_env ->
    Obj.repr(
# 2402 "parsing/parser.mly"
                                                ( expecting 3 "module-expr" )
# 12263 "parsing/parser.ml"
               : 'val_ident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2405 "parsing/parser.mly"
                                                ( _1 )
# 12270 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2406 "parsing/parser.mly"
                                                ( _1 )
# 12277 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2407 "parsing/parser.mly"
                                                ( _1 )
# 12284 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2408 "parsing/parser.mly"
                                                ( _1 )
# 12291 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2409 "parsing/parser.mly"
                                                ( _1 )
# 12298 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2410 "parsing/parser.mly"
                                                ( _1 )
# 12305 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : string) in
    Obj.repr(
# 2411 "parsing/parser.mly"
                                                ( "."^ _1 ^"()" )
# 12312 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 3 : string) in
    Obj.repr(
# 2412 "parsing/parser.mly"
                                                ( "."^ _1 ^ "()<-" )
# 12319 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : string) in
    Obj.repr(
# 2413 "parsing/parser.mly"
                                                ( "."^ _1 ^"[]" )
# 12326 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 3 : string) in
    Obj.repr(
# 2414 "parsing/parser.mly"
                                                ( "."^ _1 ^ "[]<-" )
# 12333 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : string) in
    Obj.repr(
# 2415 "parsing/parser.mly"
                                                ( "."^ _1 ^"{}" )
# 12340 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 3 : string) in
    Obj.repr(
# 2416 "parsing/parser.mly"
                                                ( "."^ _1 ^ "{}<-" )
# 12347 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2417 "parsing/parser.mly"
                                                ( _1 )
# 12354 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    Obj.repr(
# 2418 "parsing/parser.mly"
                                                ( "!" )
# 12360 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    Obj.repr(
# 2419 "parsing/parser.mly"
                                                ( "+" )
# 12366 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    Obj.repr(
# 2420 "parsing/parser.mly"
                                                ( "+." )
# 12372 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    Obj.repr(
# 2421 "parsing/parser.mly"
                                                ( "-" )
# 12378 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    Obj.repr(
# 2422 "parsing/parser.mly"
                                                ( "-." )
# 12384 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    Obj.repr(
# 2423 "parsing/parser.mly"
                                                ( "*" )
# 12390 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    Obj.repr(
# 2424 "parsing/parser.mly"
                                                ( "=" )
# 12396 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    Obj.repr(
# 2425 "parsing/parser.mly"
                                                ( "<" )
# 12402 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    Obj.repr(
# 2426 "parsing/parser.mly"
                                                ( ">" )
# 12408 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    Obj.repr(
# 2427 "parsing/parser.mly"
                                                ( "or" )
# 12414 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    Obj.repr(
# 2428 "parsing/parser.mly"
                                                ( "||" )
# 12420 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    Obj.repr(
# 2429 "parsing/parser.mly"
                                                ( "&" )
# 12426 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    Obj.repr(
# 2430 "parsing/parser.mly"
                                                ( "&&" )
# 12432 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    Obj.repr(
# 2431 "parsing/parser.mly"
                                                ( ":=" )
# 12438 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    Obj.repr(
# 2432 "parsing/parser.mly"
                                                ( "+=" )
# 12444 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    Obj.repr(
# 2433 "parsing/parser.mly"
                                                ( "%" )
# 12450 "parsing/parser.ml"
               : 'operator))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2436 "parsing/parser.mly"
                                                ( _1 )
# 12457 "parsing/parser.ml"
               : 'constr_ident))
; (fun __caml_parser_env ->
    Obj.repr(
# 2437 "parsing/parser.mly"
                                                ( "[]" )
# 12463 "parsing/parser.ml"
               : 'constr_ident))
; (fun __caml_parser_env ->
    Obj.repr(
# 2438 "parsing/parser.mly"
                                                ( "()" )
# 12469 "parsing/parser.ml"
               : 'constr_ident))
; (fun __caml_parser_env ->
    Obj.repr(
# 2439 "parsing/parser.mly"
                                                ( "::" )
# 12475 "parsing/parser.ml"
               : 'constr_ident))
; (fun __caml_parser_env ->
    Obj.repr(
# 2440 "parsing/parser.mly"
                                                ( "false" )
# 12481 "parsing/parser.ml"
               : 'constr_ident))
; (fun __caml_parser_env ->
    Obj.repr(
# 2441 "parsing/parser.mly"
                                                ( "true" )
# 12487 "parsing/parser.ml"
               : 'constr_ident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'val_ident) in
    Obj.repr(
# 2445 "parsing/parser.mly"
                                                ( Lident _1 )
# 12494 "parsing/parser.ml"
               : 'val_longident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'mod_longident) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'val_ident) in
    Obj.repr(
# 2446 "parsing/parser.mly"
                                                ( Ldot(_1, _3) )
# 12502 "parsing/parser.ml"
               : 'val_longident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'mod_longident) in
    Obj.repr(
# 2449 "parsing/parser.mly"
                                                ( _1 )
# 12509 "parsing/parser.ml"
               : 'constr_longident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in
    Obj.repr(
# 2450 "parsing/parser.mly"
                                                ( Ldot(_1,"::") )
# 12516 "parsing/parser.ml"
               : 'constr_longident))
; (fun __caml_parser_env ->
    Obj.repr(
# 2451 "parsing/parser.mly"
                                                ( Lident "[]" )
# 12522 "parsing/parser.ml"
               : 'constr_longident))
; (fun __caml_parser_env ->
    Obj.repr(
# 2452 "parsing/parser.mly"
                                                ( Lident "()" )
# 12528 "parsing/parser.ml"
               : 'constr_longident))
; (fun __caml_parser_env ->
    Obj.repr(
# 2453 "parsing/parser.mly"
                                                ( Lident "::" )
# 12534 "parsing/parser.ml"
               : 'constr_longident))
; (fun __caml_parser_env ->
    Obj.repr(
# 2454 "parsing/parser.mly"
                                                ( Lident "false" )
# 12540 "parsing/parser.ml"
               : 'constr_longident))
; (fun __caml_parser_env ->
    Obj.repr(
# 2455 "parsing/parser.mly"
                                                ( Lident "true" )
# 12546 "parsing/parser.ml"
               : 'constr_longident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2458 "parsing/parser.mly"
                                                ( Lident _1 )
# 12553 "parsing/parser.ml"
               : 'label_longident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'mod_longident) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2459 "parsing/parser.mly"
                                                ( Ldot(_1, _3) )
# 12561 "parsing/parser.ml"
               : 'label_longident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2462 "parsing/parser.mly"
                                                ( Lident _1 )
# 12568 "parsing/parser.ml"
               : 'type_longident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'mod_ext_longident) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2463 "parsing/parser.mly"
                                                ( Ldot(_1, _3) )
# 12576 "parsing/parser.ml"
               : 'type_longident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2466 "parsing/parser.mly"
                                                ( Lident _1 )
# 12583 "parsing/parser.ml"
               : 'mod_longident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'mod_longident) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2467 "parsing/parser.mly"
                                                ( Ldot(_1, _3) )
# 12591 "parsing/parser.ml"
               : 'mod_longident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2470 "parsing/parser.mly"
                                                ( Lident _1 )
# 12598 "parsing/parser.ml"
               : 'mod_ext_longident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'mod_ext_longident) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2471 "parsing/parser.mly"
                                                ( Ldot(_1, _3) )
# 12606 "parsing/parser.ml"
               : 'mod_ext_longident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 3 : 'mod_ext_longident) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'mod_ext_longident) in
    Obj.repr(
# 2472 "parsing/parser.mly"
                                                      ( lapply _1 _3 )
# 12614 "parsing/parser.ml"
               : 'mod_ext_longident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'ident) in
    Obj.repr(
# 2475 "parsing/parser.mly"
                                                ( Lident _1 )
# 12621 "parsing/parser.ml"
               : 'mty_longident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'mod_ext_longident) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'ident) in
    Obj.repr(
# 2476 "parsing/parser.mly"
                                                ( Ldot(_1, _3) )
# 12629 "parsing/parser.ml"
               : 'mty_longident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2479 "parsing/parser.mly"
                                                ( Lident _1 )
# 12636 "parsing/parser.ml"
               : 'clty_longident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'mod_ext_longident) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2480 "parsing/parser.mly"
                                                ( Ldot(_1, _3) )
# 12644 "parsing/parser.ml"
               : 'clty_longident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2483 "parsing/parser.mly"
                                                ( Lident _1 )
# 12651 "parsing/parser.ml"
               : 'class_longident))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'mod_longident) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2484 "parsing/parser.mly"
                                                ( Ldot(_1, _3) )
# 12659 "parsing/parser.ml"
               : 'class_longident))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'ident) in
    Obj.repr(
# 2490 "parsing/parser.mly"
                               ( Ptop_dir(_2, Pdir_none) )
# 12666 "parsing/parser.ml"
               : 'toplevel_directive))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'ident) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : string * string option) in
    Obj.repr(
# 2491 "parsing/parser.mly"
                               ( Ptop_dir(_2, Pdir_string (fst _3)) )
# 12674 "parsing/parser.ml"
               : 'toplevel_directive))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'ident) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : string * char option) in
    Obj.repr(
# 2492 "parsing/parser.mly"
                               ( let (n, m) = _3 in
                                  Ptop_dir(_2, Pdir_int (n ,m)) )
# 12683 "parsing/parser.ml"
               : 'toplevel_directive))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'ident) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'val_longident) in
    Obj.repr(
# 2494 "parsing/parser.mly"
                               ( Ptop_dir(_2, Pdir_ident _3) )
# 12691 "parsing/parser.ml"
               : 'toplevel_directive))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'ident) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'mod_longident) in
    Obj.repr(
# 2495 "parsing/parser.mly"
                               ( Ptop_dir(_2, Pdir_ident _3) )
# 12699 "parsing/parser.ml"
               : 'toplevel_directive))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'ident) in
    Obj.repr(
# 2496 "parsing/parser.mly"
                               ( Ptop_dir(_2, Pdir_bool false) )
# 12706 "parsing/parser.ml"
               : 'toplevel_directive))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'ident) in
    Obj.repr(
# 2497 "parsing/parser.mly"
                               ( Ptop_dir(_2, Pdir_bool true) )
# 12713 "parsing/parser.ml"
               : 'toplevel_directive))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'ident) in
    Obj.repr(
# 2503 "parsing/parser.mly"
                                                ( _2 )
# 12720 "parsing/parser.ml"
               : 'name_tag))
; (fun __caml_parser_env ->
    Obj.repr(
# 2506 "parsing/parser.mly"
                                                ( Nonrecursive )
# 12726 "parsing/parser.ml"
               : 'rec_flag))
; (fun __caml_parser_env ->
    Obj.repr(
# 2507 "parsing/parser.mly"
                                                ( Recursive )
# 12732 "parsing/parser.ml"
               : 'rec_flag))
; (fun __caml_parser_env ->
    Obj.repr(
# 2510 "parsing/parser.mly"
                                                ( Recursive )
# 12738 "parsing/parser.ml"
               : 'nonrec_flag))
; (fun __caml_parser_env ->
    Obj.repr(
# 2511 "parsing/parser.mly"
                                                ( Nonrecursive )
# 12744 "parsing/parser.ml"
               : 'nonrec_flag))
; (fun __caml_parser_env ->
    Obj.repr(
# 2514 "parsing/parser.mly"
                                                ( Upto )
# 12750 "parsing/parser.ml"
               : 'direction_flag))
; (fun __caml_parser_env ->
    Obj.repr(
# 2515 "parsing/parser.mly"
                                                ( Downto )
# 12756 "parsing/parser.ml"
               : 'direction_flag))
; (fun __caml_parser_env ->
    Obj.repr(
# 2518 "parsing/parser.mly"
                                                ( Public )
# 12762 "parsing/parser.ml"
               : 'private_flag))
; (fun __caml_parser_env ->
    Obj.repr(
# 2519 "parsing/parser.mly"
                                                ( Private )
# 12768 "parsing/parser.ml"
               : 'private_flag))
; (fun __caml_parser_env ->
    Obj.repr(
# 2522 "parsing/parser.mly"
                                                ( Immutable )
# 12774 "parsing/parser.ml"
               : 'mutable_flag))
; (fun __caml_parser_env ->
    Obj.repr(
# 2523 "parsing/parser.mly"
                                                ( Mutable )
# 12780 "parsing/parser.ml"
               : 'mutable_flag))
; (fun __caml_parser_env ->
    Obj.repr(
# 2526 "parsing/parser.mly"
                                                ( Concrete )
# 12786 "parsing/parser.ml"
               : 'virtual_flag))
; (fun __caml_parser_env ->
    Obj.repr(
# 2527 "parsing/parser.mly"
                                                ( Virtual )
# 12792 "parsing/parser.ml"
               : 'virtual_flag))
; (fun __caml_parser_env ->
    Obj.repr(
# 2530 "parsing/parser.mly"
                 ( Public, Concrete )
# 12798 "parsing/parser.ml"
               : 'private_virtual_flags))
; (fun __caml_parser_env ->
    Obj.repr(
# 2531 "parsing/parser.mly"
            ( Private, Concrete )
# 12804 "parsing/parser.ml"
               : 'private_virtual_flags))
; (fun __caml_parser_env ->
    Obj.repr(
# 2532 "parsing/parser.mly"
            ( Public, Virtual )
# 12810 "parsing/parser.ml"
               : 'private_virtual_flags))
; (fun __caml_parser_env ->
    Obj.repr(
# 2533 "parsing/parser.mly"
                    ( Private, Virtual )
# 12816 "parsing/parser.ml"
               : 'private_virtual_flags))
; (fun __caml_parser_env ->
    Obj.repr(
# 2534 "parsing/parser.mly"
                    ( Private, Virtual )
# 12822 "parsing/parser.ml"
               : 'private_virtual_flags))
; (fun __caml_parser_env ->
    Obj.repr(
# 2537 "parsing/parser.mly"
                                                ( Fresh )
# 12828 "parsing/parser.ml"
               : 'override_flag))
; (fun __caml_parser_env ->
    Obj.repr(
# 2538 "parsing/parser.mly"
                                                ( Override )
# 12834 "parsing/parser.ml"
               : 'override_flag))
; (fun __caml_parser_env ->
    Obj.repr(
# 2541 "parsing/parser.mly"
                                                ( () )
# 12840 "parsing/parser.ml"
               : 'opt_bar))
; (fun __caml_parser_env ->
    Obj.repr(
# 2542 "parsing/parser.mly"
                                                ( () )
# 12846 "parsing/parser.ml"
               : 'opt_bar))
; (fun __caml_parser_env ->
    Obj.repr(
# 2545 "parsing/parser.mly"
                                                ( () )
# 12852 "parsing/parser.ml"
               : 'opt_semi))
; (fun __caml_parser_env ->
    Obj.repr(
# 2546 "parsing/parser.mly"
                                                ( () )
# 12858 "parsing/parser.ml"
               : 'opt_semi))
; (fun __caml_parser_env ->
    Obj.repr(
# 2549 "parsing/parser.mly"
                                                ( "-" )
# 12864 "parsing/parser.ml"
               : 'subtractive))
; (fun __caml_parser_env ->
    Obj.repr(
# 2550 "parsing/parser.mly"
                                                ( "-." )
# 12870 "parsing/parser.ml"
               : 'subtractive))
; (fun __caml_parser_env ->
    Obj.repr(
# 2553 "parsing/parser.mly"
                                                ( "+" )
# 12876 "parsing/parser.ml"
               : 'additive))
; (fun __caml_parser_env ->
    Obj.repr(
# 2554 "parsing/parser.mly"
                                                ( "+." )
# 12882 "parsing/parser.ml"
               : 'additive))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2560 "parsing/parser.mly"
           ( _1 )
# 12889 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
    Obj.repr(
# 2561 "parsing/parser.mly"
           ( _1 )
# 12896 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2562 "parsing/parser.mly"
        ( "and" )
# 12902 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2563 "parsing/parser.mly"
       ( "as" )
# 12908 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2564 "parsing/parser.mly"
           ( "assert" )
# 12914 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2565 "parsing/parser.mly"
          ( "begin" )
# 12920 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2566 "parsing/parser.mly"
          ( "class" )
# 12926 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2567 "parsing/parser.mly"
               ( "constraint" )
# 12932 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2568 "parsing/parser.mly"
       ( "do" )
# 12938 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2569 "parsing/parser.mly"
         ( "done" )
# 12944 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2570 "parsing/parser.mly"
           ( "downto" )
# 12950 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2571 "parsing/parser.mly"
         ( "else" )
# 12956 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2572 "parsing/parser.mly"
        ( "end" )
# 12962 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2573 "parsing/parser.mly"
              ( "exception" )
# 12968 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2574 "parsing/parser.mly"
             ( "external" )
# 12974 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2575 "parsing/parser.mly"
          ( "false" )
# 12980 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2576 "parsing/parser.mly"
        ( "for" )
# 12986 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2577 "parsing/parser.mly"
        ( "fun" )
# 12992 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2578 "parsing/parser.mly"
             ( "function" )
# 12998 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2579 "parsing/parser.mly"
            ( "functor" )
# 13004 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2580 "parsing/parser.mly"
       ( "if" )
# 13010 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2581 "parsing/parser.mly"
       ( "in" )
# 13016 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2582 "parsing/parser.mly"
            ( "include" )
# 13022 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2583 "parsing/parser.mly"
            ( "inherit" )
# 13028 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2584 "parsing/parser.mly"
                ( "initializer" )
# 13034 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2585 "parsing/parser.mly"
         ( "lazy" )
# 13040 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2586 "parsing/parser.mly"
        ( "let" )
# 13046 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2587 "parsing/parser.mly"
          ( "match" )
# 13052 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2588 "parsing/parser.mly"
           ( "method" )
# 13058 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2589 "parsing/parser.mly"
           ( "module" )
# 13064 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2590 "parsing/parser.mly"
            ( "mutable" )
# 13070 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2591 "parsing/parser.mly"
        ( "new" )
# 13076 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2592 "parsing/parser.mly"
           ( "nonrec" )
# 13082 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2593 "parsing/parser.mly"
           ( "object" )
# 13088 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2594 "parsing/parser.mly"
       ( "of" )
# 13094 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2595 "parsing/parser.mly"
         ( "open" )
# 13100 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2596 "parsing/parser.mly"
       ( "or" )
# 13106 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2597 "parsing/parser.mly"
            ( "private" )
# 13112 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2598 "parsing/parser.mly"
        ( "rec" )
# 13118 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2599 "parsing/parser.mly"
        ( "sig" )
# 13124 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2600 "parsing/parser.mly"
           ( "struct" )
# 13130 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2601 "parsing/parser.mly"
         ( "then" )
# 13136 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2602 "parsing/parser.mly"
       ( "to" )
# 13142 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2603 "parsing/parser.mly"
         ( "true" )
# 13148 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2604 "parsing/parser.mly"
        ( "try" )
# 13154 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2605 "parsing/parser.mly"
         ( "type" )
# 13160 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2606 "parsing/parser.mly"
        ( "val" )
# 13166 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2607 "parsing/parser.mly"
            ( "virtual" )
# 13172 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2608 "parsing/parser.mly"
         ( "when" )
# 13178 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2609 "parsing/parser.mly"
          ( "while" )
# 13184 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    Obj.repr(
# 2610 "parsing/parser.mly"
         ( "with" )
# 13190 "parsing/parser.ml"
               : 'single_attr_id))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'single_attr_id) in
    Obj.repr(
# 2615 "parsing/parser.mly"
                   ( mkloc _1 (symbol_rloc()) )
# 13197 "parsing/parser.ml"
               : 'attr_id))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'single_attr_id) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'attr_id) in
    Obj.repr(
# 2616 "parsing/parser.mly"
                               ( mkloc (_1 ^ "." ^ _3.txt) (symbol_rloc()))
# 13205 "parsing/parser.ml"
               : 'attr_id))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attr_id) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'payload) in
    Obj.repr(
# 2619 "parsing/parser.mly"
                                      ( (_2, _3) )
# 13213 "parsing/parser.ml"
               : 'attribute))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attr_id) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'payload) in
    Obj.repr(
# 2622 "parsing/parser.mly"
                                        ( (_2, _3) )
# 13221 "parsing/parser.ml"
               : 'post_item_attribute))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attr_id) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'payload) in
    Obj.repr(
# 2625 "parsing/parser.mly"
                                          ( (_2, _3) )
# 13229 "parsing/parser.ml"
               : 'floating_attribute))
; (fun __caml_parser_env ->
    Obj.repr(
# 2628 "parsing/parser.mly"
                 ( [] )
# 13235 "parsing/parser.ml"
               : 'post_item_attributes))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'post_item_attribute) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in
    Obj.repr(
# 2629 "parsing/parser.mly"
                                             ( _1 :: _2 )
# 13243 "parsing/parser.ml"
               : 'post_item_attributes))
; (fun __caml_parser_env ->
    Obj.repr(
# 2632 "parsing/parser.mly"
               ( [] )
# 13249 "parsing/parser.ml"
               : 'attributes))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'attribute) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in
    Obj.repr(
# 2633 "parsing/parser.mly"
                         ( _1 :: _2 )
# 13257 "parsing/parser.ml"
               : 'attributes))
; (fun __caml_parser_env ->
    Obj.repr(
# 2636 "parsing/parser.mly"
                 ( None, [] )
# 13263 "parsing/parser.ml"
               : 'ext_attributes))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'attribute) in
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in
    Obj.repr(
# 2637 "parsing/parser.mly"
                         ( None, _1 :: _2 )
# 13271 "parsing/parser.ml"
               : 'ext_attributes))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'attr_id) in
    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in
    Obj.repr(
# 2638 "parsing/parser.mly"
                               ( Some _2, _3 )
# 13279 "parsing/parser.ml"
               : 'ext_attributes))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attr_id) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'payload) in
    Obj.repr(
# 2641 "parsing/parser.mly"
                                           ( (_2, _3) )
# 13287 "parsing/parser.ml"
               : 'extension))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attr_id) in
    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'payload) in
    Obj.repr(
# 2644 "parsing/parser.mly"
                                                  ( (_2, _3) )
# 13295 "parsing/parser.ml"
               : 'item_extension))
; (fun __caml_parser_env ->
    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'structure) in
    Obj.repr(
# 2647 "parsing/parser.mly"
              ( PStr _1 )
# 13302 "parsing/parser.ml"
               : 'payload))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'signature) in
    Obj.repr(
# 2648 "parsing/parser.mly"
                    ( PSig _2 )
# 13309 "parsing/parser.ml"
               : 'payload))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in
    Obj.repr(
# 2649 "parsing/parser.mly"
                    ( PTyp _2 )
# 13316 "parsing/parser.ml"
               : 'payload))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in
    Obj.repr(
# 2650 "parsing/parser.mly"
                     ( PPat (_2, None) )
# 13323 "parsing/parser.ml"
               : 'payload))
; (fun __caml_parser_env ->
    let _2 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in
    let _4 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in
    Obj.repr(
# 2651 "parsing/parser.mly"
                                   ( PPat (_2, Some _4) )
# 13331 "parsing/parser.ml"
               : 'payload))
(* Entry implementation *)
; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0)))
(* Entry interface *)
; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0)))
(* Entry toplevel_phrase *)
; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0)))
(* Entry use_file *)
; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0)))
(* Entry parse_core_type *)
; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0)))
(* Entry parse_expression *)
; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0)))
(* Entry parse_pattern *)
; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0)))
|]
let yytables =
  { Parsing.actions=yyact;
    Parsing.transl_const=yytransl_const;
    Parsing.transl_block=yytransl_block;
    Parsing.lhs=yylhs;
    Parsing.len=yylen;
    Parsing.defred=yydefred;
    Parsing.dgoto=yydgoto;
    Parsing.sindex=yysindex;
    Parsing.rindex=yyrindex;
    Parsing.gindex=yygindex;
    Parsing.tablesize=yytablesize;
    Parsing.table=yytable;
    Parsing.check=yycheck;
    Parsing.error_function=parse_error;
    Parsing.names_const=yynames_const;
    Parsing.names_block=yynames_block }
let implementation (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) =
   (Parsing.yyparse yytables 1 lexfun lexbuf : Parsetree.structure)
let interface (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) =
   (Parsing.yyparse yytables 2 lexfun lexbuf : Parsetree.signature)
let toplevel_phrase (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) =
   (Parsing.yyparse yytables 3 lexfun lexbuf : Parsetree.toplevel_phrase)
let use_file (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) =
   (Parsing.yyparse yytables 4 lexfun lexbuf : Parsetree.toplevel_phrase list)
let parse_core_type (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) =
   (Parsing.yyparse yytables 5 lexfun lexbuf : Parsetree.core_type)
let parse_expression (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) =
   (Parsing.yyparse yytables 6 lexfun lexbuf : Parsetree.expression)
let parse_pattern (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) =
   (Parsing.yyparse yytables 7 lexfun lexbuf : Parsetree.pattern)
;;

end
module Lexer : sig 
#1 "lexer.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* The lexical analyzer *)

val init : unit -> unit
val token: Lexing.lexbuf -> Parser.token
val skip_hash_bang: Lexing.lexbuf -> unit

type directive_type 

type error =
  | Illegal_character of char
  | Illegal_escape of string
  | Unterminated_comment of Location.t
  | Unterminated_string
  | Unterminated_string_in_comment of Location.t * Location.t
  | Keyword_as_label of string
  | Invalid_literal of string
  | Invalid_directive of string * string option
  | Unterminated_paren_in_conditional
  | Unterminated_if
  | Unterminated_else 
  | Unexpected_token_in_conditional 
  | Expect_hash_then_in_conditional
  | Illegal_semver of string
  | Unexpected_directive
  | Conditional_expr_expected_type of directive_type * directive_type                           
;;

exception Error of error * Location.t

open Format

val report_error: formatter -> error -> unit
 (* Deprecated.  Use Location.{error_of_exn, report_error}. *)

val in_comment : unit -> bool;;
val in_string : unit -> bool;;


val print_warnings : bool ref
val handle_docstrings: bool ref
val comments : unit -> (string * Location.t) list
val token_with_comments : Lexing.lexbuf -> Parser.token

(*
  [set_preprocessor init preprocessor] registers [init] as the function
to call to initialize the preprocessor when the lexer is initialized,
and [preprocessor] a function that is called when a new token is needed
by the parser, as [preprocessor lexer lexbuf] where [lexer] is the
lexing function.

When a preprocessor is configured by calling [set_preprocessor], the lexer
changes its behavior to accept backslash-newline as a token-separating blank.
*)

val set_preprocessor :
  (unit -> unit) ->
  ((Lexing.lexbuf -> Parser.token) -> Lexing.lexbuf -> Parser.token) ->
  unit

(** semantic version predicate *)
val semver : Location.t ->   string -> string -> bool

val filter_directive_from_lexbuf : Lexing.lexbuf -> (int * int) list

val replace_directive_int : string -> int -> unit
val replace_directive_string : string -> string -> unit
val replace_directive_bool : string -> bool -> unit 
val remove_directive_built_in_value : string -> unit

(** @return false means failed to define *)
val define_key_value : string -> string -> bool
val list_variables : Format.formatter -> unit

end = struct
#1 "lexer.ml"
# 18 "parsing/lexer.mll"
 
open Lexing
open Misc
open Parser

type directive_value =
  | Dir_bool of bool 
  | Dir_float of float
  | Dir_int of int
  | Dir_string of string
  | Dir_null 

type directive_type = 
  | Dir_type_bool 
  | Dir_type_float 
  | Dir_type_int 
  | Dir_type_string 
  | Dir_type_null 

let type_of_directive x =
  match x with 
  | Dir_bool _ -> Dir_type_bool
  | Dir_float _ -> Dir_type_float
  | Dir_int _ -> Dir_type_int
  | Dir_string _ -> Dir_type_string
  | Dir_null -> Dir_type_null

let string_of_type_directive x = 
  match x with 
  | Dir_type_bool  -> "bool"
  | Dir_type_float  -> "float"
  | Dir_type_int  -> "int"
  | Dir_type_string  -> "string"
  | Dir_type_null -> "null"

type error =
  | Illegal_character of char
  | Illegal_escape of string
  | Unterminated_comment of Location.t
  | Unterminated_string
  | Unterminated_string_in_comment of Location.t * Location.t
  | Keyword_as_label of string
  | Invalid_literal of string
  | Invalid_directive of string * string option
  | Unterminated_paren_in_conditional
  | Unterminated_if
  | Unterminated_else 
  | Unexpected_token_in_conditional 
  | Expect_hash_then_in_conditional
  | Illegal_semver of string
  | Unexpected_directive 
  | Conditional_expr_expected_type of directive_type * directive_type
                           
;;

exception Error of error * Location.t;;

let assert_same_type  lexbuf x y = 
  let lhs = type_of_directive x in let rhs =  type_of_directive y  in
  if lhs <> rhs then 
    raise (Error(Conditional_expr_expected_type(lhs,rhs), Location.curr lexbuf))
  else y

let directive_built_in_values  =
  Hashtbl.create 51


let replace_directive_built_in_value k v = 
  Hashtbl.replace directive_built_in_values k v 

let remove_directive_built_in_value k  = 
  Hashtbl.replace directive_built_in_values k Dir_null

let replace_directive_int k v = 
  Hashtbl.replace directive_built_in_values k (Dir_int v)

let replace_directive_bool k v = 
  Hashtbl.replace directive_built_in_values k (Dir_bool v)

let replace_directive_string k v = 
  Hashtbl.replace directive_built_in_values k (Dir_string v)

let () =
  (* Note we use {!Config} instead of {!Sys} becasue 
     we want to overwrite in some cases with the 
     same stdlib
  *)
  let version = 
    Config.version (* so that it can be overridden*)
  in
  replace_directive_built_in_value "OCAML_VERSION" 
    (Dir_string version);
  replace_directive_built_in_value "OCAML_PATCH"
    (Dir_string 
       (match String.rindex version '+' with 
       | exception Not_found -> ""
       | i -> 
           String.sub version (i + 1)
             (String.length version - i - 1)))
  ;
  replace_directive_built_in_value "OS_TYPE" 
    (Dir_string Sys.os_type);
  replace_directive_built_in_value "BIG_ENDIAN" 
    (Dir_bool Sys.big_endian);
  replace_directive_built_in_value "WORD_SIZE" 
    (Dir_int Sys.word_size)

let find_directive_built_in_value k =
  Hashtbl.find directive_built_in_values k 

let iter_directive_built_in_value f = Hashtbl.iter f directive_built_in_values

(*
   {[
     # semver 0 "12";;
     - : int * int * int * string = (12, 0, 0, "");;
     # semver 0 "12.3";;
     - : int * int * int * string = (12, 3, 0, "");;
       semver 0 "12.3.10";;
     - : int * int * int * string = (12, 3, 10, "");;
     # semver 0 "12.3.10+x";;
     - : int * int * int * string = (12, 3, 10, "+x")
   ]}
*)    
let zero = Char.code '0' 
let dot = Char.code '.'
let semantic_version_parse str start  last_index = 
  let rec aux start  acc last_index =
    if start <= last_index then
      let c = Char.code (String.unsafe_get str start) in
      if c = dot then (acc, start + 1) (* consume [4.] instead of [4]*)
      else 
        let v =  c - zero in
        if v >=0 && v <= 9  then
          aux (start + 1) (acc * 10 + v) last_index
        else (acc , start)
    else (acc, start)
  in
  let major, major_end =  aux start 0 last_index  in
  let minor, minor_end = aux major_end 0 last_index in
  let patch, patch_end = aux minor_end 0 last_index in 
  let additional = String.sub str patch_end (last_index - patch_end  +1) in
  (major, minor, patch), additional

(** 
   {[
     semver Location.none "1.2.3" "~1.3.0" = false;;
     semver Location.none "1.2.3" "^1.3.0" = true ;;
     semver Location.none "1.2.3" ">1.3.0" = false ;;
     semver Location.none "1.2.3" ">=1.3.0" = false ;;
     semver Location.none "1.2.3" "<1.3.0" = true ;;
     semver Location.none "1.2.3" "<=1.3.0" = true ;;
   ]}
*)
let semver loc lhs str =
  let last_index = String.length str - 1 in 
  if last_index < 0 then raise (Error(Illegal_semver str, loc))
  else 
    let pred, ((major, minor, _patch) as version, _) = 
      let v = String.unsafe_get str 0 in 
      match v with
      | '>' -> 
          if last_index = 0 then raise (Error(Illegal_semver str, loc)) else 
          if String.unsafe_get str 1 = '=' then 
            `Ge, semantic_version_parse str 2 last_index
          else `Gt, semantic_version_parse str 1 last_index
      | '<' 
        ->
          if last_index = 0 then raise (Error(Illegal_semver str, loc)) else 
          if String.unsafe_get str 1 = '=' then 
            `Le, semantic_version_parse str 2 last_index
          else `Lt, semantic_version_parse str 1 last_index
      | '^' 
        -> `Compatible, semantic_version_parse str 1 last_index
      | '~' ->  `Approximate, semantic_version_parse str 1 last_index
      | _ -> `Exact, semantic_version_parse str 0 last_index 
    in 
    let ((l_major, l_minor, _l_patch) as lversion,_) =
      semantic_version_parse lhs 0 (String.length lhs - 1) in 
    match pred with 
    | `Ge -> lversion >= version 
    | `Gt -> lversion > version 
    | `Le -> lversion <= version
    | `Lt -> lversion < version 
    | `Approximate -> major = l_major && minor = l_minor 
    |  `Compatible -> major = l_major
    | `Exact -> lversion = version 


let pp_directive_value fmt (x : directive_value) =
  match x with
  | Dir_bool b -> Format.pp_print_bool fmt b
  | Dir_int b -> Format.pp_print_int fmt b
  | Dir_float b -> Format.pp_print_float fmt b
  | Dir_string s  -> Format.fprintf fmt "%S" s
  | Dir_null -> Format.pp_print_string fmt "null"    

let list_variables fmt = 
  iter_directive_built_in_value 
    (fun s  dir_value ->
       Format.fprintf
         fmt "@[%s@ %a@]@."
         s pp_directive_value dir_value
    )

let defined str =
  begin match  find_directive_built_in_value str with 
  |  Dir_null -> false 
  | _ ->  true
  | exception _ -> 
      try ignore @@ Sys.getenv str; true with _ ->  false 
  end

let query _loc str =
  begin match find_directive_built_in_value str with
  | Dir_null -> Dir_bool false
  | v -> v
  | exception Not_found ->
      begin match Sys.getenv str with 
      | v -> 
          begin 
            try Dir_bool (bool_of_string v) with 
              _ -> 
                begin 
                  try Dir_int (int_of_string v )
                  with 
                    _ -> 
                      begin try (Dir_float (float_of_string v)) 
                      with _ -> Dir_string v
                      end
                end
          end
      | exception Not_found -> 
          Dir_bool false
      end
  end


let define_key_value key v  =
  if String.length key > 0
      && Char.uppercase_ascii (key.[0]) = key.[0] then 
    begin 
      replace_directive_built_in_value key
      begin
        (* NEED Sync up across {!lexer.mll} {!bspp.ml} and here,
           TODO: put it in {!lexer.mll}
        *)
        try Dir_bool (bool_of_string v) with 
          _ -> 
          begin 
            try Dir_int (int_of_string v )
            with 
              _ -> 
              begin try (Dir_float (float_of_string v)) 
                with _ -> Dir_string v
              end
          end
      end;
    true
    end
  else false 

let cvt_int_literal s =
  - int_of_string ("-" ^ s)
  
let value_of_token loc (t : Parser.token)  = 
  match t with 
  | INT (i,None) -> Dir_int (cvt_int_literal i) 
  | STRING (s,_) -> Dir_string s 
  | FLOAT (s,None)  -> Dir_float (float_of_string s)
  | TRUE -> Dir_bool true
  | FALSE -> Dir_bool false
  | UIDENT s -> query loc s 
  | _ -> raise (Error (Unexpected_token_in_conditional, loc))


let directive_parse token_with_comments lexbuf =
  let look_ahead = ref None in
  let token () : Parser.token =
    let v = !look_ahead in
    match v with 
    | Some v -> 
        look_ahead := None ;
        v
    | None ->
       let rec skip () = 
        match token_with_comments lexbuf  with
        | COMMENT _ 
        | DOCSTRING _ 
        | EOL -> skip ()
        | EOF -> raise (Error (Unterminated_if, Location.curr lexbuf)) 
        | t -> t 
        in  skip ()
  in
  let push e =
    (* INVARIANT: only look at most one token *)
    assert (!look_ahead = None);
    look_ahead := Some e 
  in
  let rec
    token_op calc   ~no  lhs   =
    match token () with 
    | (LESS 
    | GREATER 
    | INFIXOP0 "<=" 
    | INFIXOP0 ">=" 
    | EQUAL
    | INFIXOP0 "<>" as op) ->
        let f =  
          match op with 
          | LESS -> (<) 
          | GREATER -> (>)
          | INFIXOP0 "<=" -> (<=)
          | EQUAL -> (=)
          | INFIXOP0 "<>" -> (<>) 
          | _ -> assert false
        in 
        let curr_loc = Location.curr lexbuf in 
        let rhs = value_of_token curr_loc (token ()) in 
        not calc ||
        f lhs (assert_same_type lexbuf lhs rhs)
    | INFIXOP0 "=~" -> 
        not calc ||
        begin match lhs with 
        | Dir_string s ->
            let curr_loc = Location.curr lexbuf in 
            let rhs = value_of_token curr_loc (token ()) in 
            begin match rhs with 
            | Dir_string rhs -> 
                semver curr_loc s rhs
            | _ -> 
                raise
                  (Error
                     ( Conditional_expr_expected_type
                         (Dir_type_string, type_of_directive lhs), Location.curr lexbuf))
            end
        | _ -> raise
                 (Error
                    ( Conditional_expr_expected_type
                        (Dir_type_string, type_of_directive lhs), Location.curr lexbuf))
        end
    | e -> no e 
  and
    parse_or calc : bool =
    parse_or_aux calc (parse_and calc)
  and  (* a || (b || (c || d))*)
    parse_or_aux calc v : bool =
    (* let l = v  in *)
    match token () with
    | BARBAR ->
        let b =   parse_or (calc && not v)  in
        v || b 
    | e -> push e ; v
  and parse_and calc = 
    parse_and_aux calc (parse_relation calc)
  and parse_and_aux calc v = (* a && (b && (c && d)) *)
    (* let l = v  in *)
    match token () with
    | AMPERAMPER ->
        let b =  parse_and (calc && v) in
        v && b
    | e -> push e ; v
  and parse_relation (calc : bool) : bool  =
    let curr_token = token () in
    let curr_loc = Location.curr lexbuf in
    match curr_token with
    | TRUE -> true 
    | FALSE -> false
    | UIDENT v ->
        let value_v = query curr_loc v in
        token_op calc 
          ~no:(fun e -> push e ;
                match value_v with 
                | Dir_bool b -> b 
                | _ -> 
                    let ty = type_of_directive value_v in
                    raise
                      (Error(Conditional_expr_expected_type (Dir_type_bool, ty),
                             curr_loc)))
          value_v
    | INT (v,None) -> 
      let num_v = cvt_int_literal v in 
      token_op calc
          ~no:(fun e -> 
                push e; 
                num_v <> 0
              )
          (Dir_int num_v)
    | FLOAT (v,None) -> 
        token_op calc
          ~no:(fun _e -> 
              raise (Error(Conditional_expr_expected_type(Dir_type_bool, Dir_type_float),
                           curr_loc)))
          (Dir_float (float_of_string v))
    | STRING (v,_) -> 
        token_op calc
          ~no:(fun _e ->
              raise (Error
                       (Conditional_expr_expected_type(Dir_type_bool, Dir_type_string),
                        curr_loc)))
          (Dir_string v)
    | LIDENT ("defined" | "undefined" as r) ->
        let t = token () in 
        let loc = Location.curr lexbuf in
        begin match t with
        | UIDENT s -> 
            not calc || 
            if r.[0] = 'u' then 
              not @@ defined s
            else defined s 
        | _ -> raise (Error (Unexpected_token_in_conditional, loc))
        end
    | LPAREN ->
        let v = parse_or calc in
        begin match token () with
        | RPAREN ->  v
        | _ -> raise (Error(Unterminated_paren_in_conditional, Location.curr lexbuf))
        end 

    | _ -> raise (Error (Unexpected_token_in_conditional, curr_loc))
  in
  let v = parse_or true in
  begin match token () with
  | THEN ->  v 
  | _ -> raise (Error (Expect_hash_then_in_conditional, Location.curr lexbuf))
  end


type dir_conditional =
  | Dir_if_true
  | Dir_if_false
  | Dir_out 

(* let string_of_dir_conditional (x : dir_conditional) = *)
(*   match x with  *)
(*   | Dir_if_true -> "Dir_if_true" *)
(*   | Dir_if_false -> "Dir_if_false" *)
(*   | Dir_out -> "Dir_out" *)

let is_elif (i : Parser.token ) =
  match i with
  | LIDENT "elif" -> true
  | _ -> false (* avoid polymorphic equal *)


(* The table of keywords *)

let keyword_table =
  create_hashtable 149 [
    "and", AND;
    "as", AS;
    "assert", ASSERT;
    "begin", BEGIN;
    "class", CLASS;
    "constraint", CONSTRAINT;
    "do", DO;
    "done", DONE;
    "downto", DOWNTO;
    "else", ELSE;
    "end", END;
    "exception", EXCEPTION;
    "external", EXTERNAL;
    "false", FALSE;
    "for", FOR;
    "fun", FUN;
    "function", FUNCTION;
    "functor", FUNCTOR;
    "if", IF;
    "in", IN;
    "include", INCLUDE;
    "inherit", INHERIT;
    "initializer", INITIALIZER;
    "lazy", LAZY;
    "let", LET;
    "match", MATCH;
    "method", METHOD;
    "module", MODULE;
    "mutable", MUTABLE;
    "new", NEW;
    "nonrec", NONREC;
    "object", OBJECT;
    "of", OF;
    "open", OPEN;
    "or", OR;
(*  "parser", PARSER; *)
    "private", PRIVATE;
    "rec", REC;
    "sig", SIG;
    "struct", STRUCT;
    "then", THEN;
    "to", TO;
    "true", TRUE;
    "try", TRY;
    "type", TYPE;
    "val", VAL;
    "virtual", VIRTUAL;
    "when", WHEN;
    "while", WHILE;
    "with", WITH;

    "lor", INFIXOP3("lor"); (* Should be INFIXOP2 *)
    "lxor", INFIXOP3("lxor"); (* Should be INFIXOP2 *)
    "mod", INFIXOP3("mod");
    "land", INFIXOP3("land");
    "lsl", INFIXOP4("lsl");
    "lsr", INFIXOP4("lsr");
    "asr", INFIXOP4("asr")
]

(* To buffer string literals *)

let string_buffer = Buffer.create 256
let reset_string_buffer () = Buffer.reset string_buffer
let get_stored_string () = Buffer.contents string_buffer

let store_string_char c = Buffer.add_char string_buffer c
let store_string_utf_8_uchar u = Buffer.add_utf_8_uchar string_buffer u
let store_string s = Buffer.add_string string_buffer s
let store_lexeme lexbuf = store_string (Lexing.lexeme lexbuf)

(* To store the position of the beginning of a string and comment *)
let string_start_loc = ref Location.none;;
let comment_start_loc = ref [];;
let in_comment () = !comment_start_loc <> [];;
let is_in_string = ref false
let in_string () = !is_in_string
let print_warnings = ref true
let if_then_else = ref Dir_out
let sharp_look_ahead = ref None
let update_if_then_else v = 
  (* Format.fprintf Format.err_formatter "@[update %s \n@]@." (string_of_dir_conditional v); *)
  if_then_else := v

(* Escaped chars are interpreted in strings unless they are in comments. *)
let store_escaped_char lexbuf c =
  if in_comment () then store_lexeme lexbuf else store_string_char c

let store_escaped_uchar lexbuf u =
  if in_comment () then store_lexeme lexbuf else store_string_utf_8_uchar u

let with_comment_buffer comment lexbuf =
  let start_loc = Location.curr lexbuf  in
  comment_start_loc := [start_loc];
  reset_string_buffer ();
  let end_loc = comment lexbuf in
  let s = get_stored_string () in
  reset_string_buffer ();
  let loc = { start_loc with Location.loc_end = end_loc.Location.loc_end } in
  s, loc

(* To translate escape sequences *)

let hex_digit_value d = (* assert (d in '0'..'9' 'a'..'f' 'A'..'F') *)
  let d = Char.code d in
  if d >= 97 then d - 87 else
  if d >= 65 then d - 55 else
  d - 48

let hex_num_value lexbuf ~first ~last =
  let rec loop acc i = match i > last with
  | true -> acc
  | false ->
      let value = hex_digit_value (Lexing.lexeme_char lexbuf i) in
      loop (16 * acc + value) (i + 1)
  in
  loop 0 first

let char_for_backslash = function
  | 'n' -> '\010'
  | 'r' -> '\013'
  | 'b' -> '\008'
  | 't' -> '\009'
  | c   -> c

let char_for_decimal_code lexbuf i =
  let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) +
           10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) +
                (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in
  if (c < 0 || c > 255) then
    if in_comment ()
    then 'x'
    else raise (Error(Illegal_escape (Lexing.lexeme lexbuf),
                      Location.curr lexbuf))
  else Char.chr c

let char_for_octal_code lexbuf i =
  let c = 64 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) +
           8 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) +
               (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in
  Char.chr c

let char_for_hexadecimal_code lexbuf i =
  let byte = hex_num_value lexbuf ~first:i ~last:(i+1) in
  Char.chr byte

let uchar_for_uchar_escape lexbuf =
  let err e =
    raise
      (Error (Illegal_escape (Lexing.lexeme lexbuf ^ e), Location.curr lexbuf))
  in
  let len = Lexing.lexeme_end lexbuf - Lexing.lexeme_start lexbuf in
  let first = 3 (* skip opening \u{ *) in
  let last = len - 2 (* skip closing } *) in
  let digit_count = last - first + 1 in
  match digit_count > 6 with
  | true -> err ", too many digits, expected 1 to 6 hexadecimal digits"
  | false ->
      let cp = hex_num_value lexbuf ~first ~last in
      if Uchar.is_valid cp then Uchar.unsafe_of_int cp else
      err (", " ^ Printf.sprintf "%X" cp ^ " is not a Unicode scalar value")

(* recover the name from a LABEL or OPTLABEL token *)

let get_label_name lexbuf =
  let s = Lexing.lexeme lexbuf in
  let name = String.sub s 1 (String.length s - 2) in
  if Hashtbl.mem keyword_table name then
    raise (Error(Keyword_as_label name, Location.curr lexbuf));
  name
;;

(* Update the current location with file name and line number. *)

let update_loc lexbuf file line absolute chars =
  let pos = lexbuf.lex_curr_p in
  let new_file = match file with
                 | None -> pos.pos_fname
                 | Some s -> s
  in
  lexbuf.lex_curr_p <- { pos with
    pos_fname = new_file;
    pos_lnum = if absolute then line else pos.pos_lnum + line;
    pos_bol = pos.pos_cnum - chars;
  }
;;

let preprocessor = ref None

let escaped_newlines = ref false

(* Warn about Latin-1 characters used in idents *)

let warn_latin1 lexbuf =
  Location.deprecated (Location.curr lexbuf)"ISO-Latin1 characters in identifiers"

let handle_docstrings = ref true
let comment_list = ref []

let add_comment com =
  comment_list := com :: !comment_list

let add_docstring_comment ds =
  let com =
    ("*" ^ Docstrings.docstring_body ds, Docstrings.docstring_loc ds)
  in
    add_comment com

let comments () = List.rev !comment_list

(* Error report *)

open Format

let report_error ppf = function
  | Illegal_character c ->
      fprintf ppf "Illegal character (%s)" (Char.escaped c)
  | Illegal_escape s ->
      fprintf ppf "Illegal backslash escape in string or character (%s)" s
  | Unterminated_comment _ ->
      fprintf ppf "Comment not terminated"
  | Unterminated_string ->
      fprintf ppf "String literal not terminated"
  | Unterminated_string_in_comment (_, loc) ->
      fprintf ppf "This comment contains an unterminated string literal@.\
                   %aString literal begins here"
              Location.print_error loc
  | Keyword_as_label kwd ->
      fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd
  | Invalid_literal s ->
      fprintf ppf "Invalid literal %s" s
  | Invalid_directive (dir, explanation) ->
      fprintf ppf "Invalid lexer directive %S" dir;
      begin match explanation with
        | None -> ()
        | Some expl -> fprintf ppf ": %s" expl
      end
  | Unterminated_if -> 
      fprintf ppf "#if not terminated"
  | Unterminated_else -> 
      fprintf ppf "#else not terminated"
  | Unexpected_directive -> fprintf ppf "Unexpected directive"
  | Unexpected_token_in_conditional -> 
      fprintf ppf "Unexpected token in conditional predicate"
  | Unterminated_paren_in_conditional ->
    fprintf ppf "Unterminated parens in conditional predicate"
  | Expect_hash_then_in_conditional -> 
      fprintf ppf "Expect `then` after conditional predicate"
  | Conditional_expr_expected_type (a,b) -> 
      fprintf ppf "Conditional expression type mismatch (%s,%s)" 
        (string_of_type_directive a )
        (string_of_type_directive b )
  | Illegal_semver s -> 
      fprintf ppf "Illegal semantic version string %s" s

let () =
  Location.register_error_of_exn
    (function
      | Error (err, loc) ->
          Some (Location.error_of_printer loc report_error err)
      | _ ->
          None
    )


# 717 "parsing/lexer.ml"
let __ocaml_lex_tables = {
  Lexing.lex_base =
   "\000\000\162\255\163\255\224\000\003\001\038\001\073\001\108\001\
    \143\001\186\255\178\001\215\001\194\255\091\000\252\001\031\002\
    \068\000\071\000\065\002\100\002\212\255\214\255\217\255\135\002\
    \230\002\009\003\088\000\255\000\039\003\236\255\123\003\207\003\
    \035\004\243\004\195\005\147\006\114\007\206\007\158\008\122\000\
    \254\255\001\000\005\000\255\255\006\000\007\000\125\009\155\009\
    \107\010\250\255\249\255\059\011\011\012\247\255\246\255\219\012\
    \047\013\131\013\215\013\043\014\127\014\211\014\039\015\123\015\
    \207\015\035\016\087\000\119\016\203\016\031\017\115\017\199\017\
    \108\000\192\255\235\255\007\003\034\018\106\000\107\000\011\000\
    \234\255\233\255\228\255\152\002\099\000\118\000\113\000\232\255\
    \128\000\147\000\231\255\224\000\003\001\148\000\230\255\110\004\
    \149\000\229\255\148\000\224\255\217\000\223\255\222\000\034\018\
    \222\255\073\018\101\005\009\003\221\255\012\000\014\001\080\001\
    \115\001\024\001\221\255\013\000\119\018\158\018\193\018\231\018\
    \010\019\209\255\204\255\205\255\206\255\202\255\045\019\154\000\
    \183\000\195\255\196\255\197\255\217\000\182\255\180\255\189\255\
    \080\019\185\255\187\255\115\019\150\019\185\019\220\019\130\005\
    \243\255\244\255\017\000\245\255\174\001\223\005\253\255\248\000\
    \249\000\255\255\254\255\252\255\005\006\238\019\003\001\004\001\
    \018\000\251\255\250\255\249\255\222\006\026\003\005\001\248\255\
    \036\003\008\001\247\255\066\008\020\001\246\255\059\001\234\001\
    \245\255\246\255\247\255\060\001\055\020\255\255\248\255\193\000\
    \233\008\038\001\133\004\253\255\073\001\094\001\113\001\143\004\
    \252\255\192\002\027\004\251\255\230\009\250\255\182\010\089\020\
    \249\255\129\001\130\001\252\255\085\007\254\255\255\255\146\001\
    \147\001\253\255\177\007\033\001\044\001\148\001\151\001\045\001\
    \153\001\044\001\019\000\255\255";
  Lexing.lex_backtrk =
   "\255\255\255\255\255\255\090\000\089\000\086\000\085\000\078\000\
    \076\000\255\255\067\000\064\000\255\255\057\000\056\000\054\000\
    \052\000\048\000\045\000\081\000\255\255\255\255\255\255\036\000\
    \035\000\042\000\040\000\039\000\062\000\255\255\014\000\014\000\
    \013\000\012\000\011\000\010\000\007\000\004\000\003\000\002\000\
    \255\255\093\000\093\000\255\255\255\255\255\255\084\000\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\018\000\
    \018\000\016\000\015\000\018\000\015\000\015\000\014\000\016\000\
    \015\000\016\000\255\255\017\000\017\000\014\000\014\000\016\000\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\027\000\027\000\027\000\027\000\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\028\000\255\255\029\000\255\255\030\000\088\000\
    \255\255\091\000\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\037\000\087\000\082\000\044\000\
    \047\000\255\255\255\255\255\255\255\255\255\255\055\000\074\000\
    \071\000\255\255\255\255\255\255\072\000\255\255\255\255\255\255\
    \065\000\255\255\255\255\083\000\077\000\080\000\079\000\255\255\
    \255\255\255\255\012\000\255\255\012\000\012\000\255\255\012\000\
    \012\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\010\000\010\000\255\255\255\255\007\000\
    \007\000\007\000\007\000\255\255\001\000\007\000\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\003\000\255\255\255\255\003\000\
    \255\255\255\255\255\255\002\000\255\255\255\255\001\000\255\255\
    \255\255\255\255\255\255\255\255";
  Lexing.lex_default =
   "\001\000\000\000\000\000\255\255\255\255\255\255\255\255\255\255\
    \255\255\000\000\255\255\255\255\000\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\000\000\000\000\000\000\255\255\
    \255\255\255\255\255\255\077\000\255\255\000\000\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \000\000\255\255\255\255\000\000\255\255\255\255\255\255\255\255\
    \255\255\000\000\000\000\255\255\255\255\000\000\000\000\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\000\000\000\000\255\255\082\000\255\255\255\255\255\255\
    \000\000\000\000\000\000\255\255\255\255\255\255\255\255\000\000\
    \255\255\255\255\000\000\255\255\255\255\255\255\000\000\255\255\
    \255\255\000\000\255\255\000\000\255\255\000\000\255\255\255\255\
    \000\000\255\255\110\000\255\255\000\000\255\255\110\000\111\000\
    \110\000\113\000\000\000\255\255\255\255\255\255\255\255\255\255\
    \255\255\000\000\000\000\000\000\000\000\000\000\255\255\255\255\
    \255\255\000\000\000\000\000\000\255\255\000\000\000\000\000\000\
    \255\255\000\000\000\000\255\255\255\255\255\255\255\255\144\000\
    \000\000\000\000\255\255\000\000\158\000\255\255\000\000\255\255\
    \255\255\000\000\000\000\000\000\255\255\255\255\255\255\255\255\
    \255\255\000\000\000\000\000\000\255\255\255\255\255\255\000\000\
    \255\255\255\255\000\000\255\255\255\255\000\000\255\255\176\000\
    \000\000\000\000\000\000\255\255\182\000\000\000\000\000\255\255\
    \255\255\255\255\255\255\000\000\255\255\255\255\255\255\255\255\
    \000\000\255\255\255\255\000\000\255\255\000\000\255\255\255\255\
    \000\000\255\255\203\000\000\000\255\255\000\000\000\000\255\255\
    \255\255\000\000\255\255\255\255\255\255\213\000\216\000\255\255\
    \216\000\255\255\255\255\000\000";
  Lexing.lex_trans =
   "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\039\000\040\000\040\000\039\000\041\000\045\000\043\000\
    \043\000\040\000\044\000\044\000\045\000\078\000\108\000\114\000\
    \079\000\109\000\115\000\145\000\159\000\219\000\174\000\160\000\
    \039\000\008\000\029\000\024\000\006\000\004\000\023\000\027\000\
    \026\000\021\000\025\000\007\000\020\000\019\000\018\000\003\000\
    \031\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\
    \030\000\030\000\017\000\016\000\015\000\014\000\010\000\036\000\
    \005\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\013\000\042\000\012\000\005\000\038\000\
    \022\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\028\000\011\000\009\000\037\000\125\000\
    \127\000\124\000\098\000\039\000\123\000\122\000\039\000\065\000\
    \065\000\065\000\065\000\065\000\065\000\065\000\065\000\065\000\
    \065\000\081\000\080\000\091\000\091\000\091\000\091\000\130\000\
    \087\000\129\000\039\000\128\000\071\000\071\000\071\000\071\000\
    \071\000\071\000\071\000\071\000\071\000\071\000\088\000\088\000\
    \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\
    \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\
    \089\000\089\000\090\000\094\000\097\000\099\000\100\000\134\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\131\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\132\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \002\000\003\000\101\000\102\000\003\000\003\000\003\000\101\000\
    \102\000\078\000\003\000\003\000\079\000\003\000\003\000\003\000\
    \092\000\092\000\092\000\092\000\092\000\092\000\092\000\092\000\
    \108\000\133\000\003\000\109\000\003\000\003\000\003\000\003\000\
    \003\000\154\000\114\000\153\000\003\000\115\000\255\255\003\000\
    \003\000\003\000\163\000\162\000\167\000\003\000\003\000\170\000\
    \003\000\003\000\003\000\093\000\093\000\093\000\093\000\093\000\
    \093\000\093\000\093\000\173\000\198\000\003\000\003\000\003\000\
    \003\000\003\000\003\000\003\000\212\000\145\000\178\000\005\000\
    \174\000\201\000\005\000\005\000\005\000\213\000\217\000\218\000\
    \005\000\005\000\188\000\005\000\005\000\005\000\193\000\193\000\
    \193\000\193\000\108\000\076\000\003\000\109\000\003\000\000\000\
    \005\000\003\000\005\000\005\000\005\000\005\000\005\000\000\000\
    \188\000\188\000\006\000\190\000\000\000\006\000\006\000\006\000\
    \000\000\000\000\113\000\006\000\006\000\000\000\006\000\006\000\
    \006\000\000\000\000\000\188\000\112\000\108\000\190\000\003\000\
    \109\000\003\000\000\000\006\000\005\000\006\000\006\000\006\000\
    \006\000\006\000\000\000\178\000\206\000\117\000\201\000\207\000\
    \117\000\117\000\117\000\112\000\000\000\111\000\117\000\117\000\
    \000\000\117\000\142\000\117\000\206\000\206\000\214\000\208\000\
    \208\000\215\000\005\000\215\000\005\000\000\000\117\000\006\000\
    \117\000\141\000\117\000\117\000\117\000\000\000\000\000\000\000\
    \139\000\000\000\000\000\139\000\139\000\139\000\000\000\000\000\
    \159\000\139\000\139\000\160\000\139\000\139\000\139\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\006\000\000\000\006\000\
    \000\000\139\000\117\000\139\000\140\000\139\000\139\000\139\000\
    \000\000\000\000\000\000\006\000\000\000\161\000\006\000\006\000\
    \006\000\000\000\000\000\000\000\006\000\006\000\000\000\006\000\
    \006\000\006\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \117\000\000\000\117\000\000\000\006\000\139\000\006\000\006\000\
    \006\000\006\000\006\000\000\000\178\000\000\000\000\000\179\000\
    \006\000\000\000\000\000\006\000\006\000\006\000\204\000\255\255\
    \000\000\006\000\006\000\000\000\006\000\006\000\006\000\000\000\
    \000\000\000\000\157\000\139\000\181\000\139\000\255\255\138\000\
    \006\000\006\000\000\000\006\000\006\000\006\000\006\000\006\000\
    \255\255\000\000\000\000\000\000\000\000\006\000\000\000\000\000\
    \006\000\006\000\006\000\000\000\000\000\000\000\006\000\006\000\
    \000\000\006\000\006\000\006\000\000\000\000\000\006\000\137\000\
    \006\000\000\000\000\000\000\000\135\000\006\000\006\000\000\000\
    \006\000\006\000\006\000\006\000\006\000\000\000\000\000\000\000\
    \006\000\000\000\000\000\006\000\006\000\006\000\180\000\000\000\
    \000\000\006\000\006\000\000\000\126\000\006\000\006\000\000\000\
    \255\255\000\000\000\000\136\000\000\000\006\000\000\000\000\000\
    \000\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\
    \000\000\000\000\120\000\000\000\000\000\120\000\120\000\120\000\
    \000\000\000\000\000\000\120\000\120\000\000\000\120\000\121\000\
    \120\000\000\000\000\000\255\255\000\000\000\000\000\000\000\000\
    \006\000\000\000\006\000\120\000\000\000\006\000\120\000\120\000\
    \120\000\120\000\205\000\000\000\000\000\117\000\000\000\000\000\
    \117\000\117\000\117\000\000\000\000\000\000\000\117\000\117\000\
    \000\000\117\000\118\000\117\000\255\255\000\000\000\000\255\255\
    \000\000\255\255\000\000\006\000\000\000\006\000\117\000\120\000\
    \117\000\117\000\119\000\117\000\117\000\000\000\000\000\000\000\
    \006\000\000\000\000\000\006\000\006\000\116\000\255\255\000\000\
    \000\000\006\000\006\000\000\000\006\000\006\000\006\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\120\000\000\000\120\000\
    \000\000\006\000\117\000\006\000\006\000\006\000\006\000\006\000\
    \095\000\095\000\095\000\095\000\095\000\095\000\095\000\095\000\
    \095\000\095\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\095\000\095\000\095\000\095\000\095\000\095\000\000\000\
    \117\000\000\000\117\000\000\000\000\000\006\000\000\000\000\000\
    \000\000\000\000\177\000\000\000\000\000\000\000\000\000\107\000\
    \194\000\194\000\194\000\194\000\194\000\194\000\194\000\194\000\
    \000\000\095\000\095\000\095\000\095\000\095\000\095\000\000\000\
    \000\000\000\000\000\000\006\000\000\000\006\000\107\000\105\000\
    \000\000\105\000\105\000\105\000\105\000\000\000\000\000\000\000\
    \105\000\105\000\107\000\105\000\105\000\105\000\106\000\106\000\
    \106\000\106\000\106\000\106\000\106\000\106\000\106\000\106\000\
    \105\000\000\000\105\000\105\000\105\000\105\000\105\000\000\000\
    \000\000\107\000\003\000\000\000\000\000\003\000\003\000\003\000\
    \000\000\000\000\104\000\103\000\003\000\000\000\003\000\003\000\
    \003\000\106\000\106\000\106\000\106\000\106\000\106\000\106\000\
    \106\000\106\000\106\000\003\000\105\000\003\000\003\000\003\000\
    \003\000\003\000\168\000\168\000\168\000\168\000\168\000\168\000\
    \168\000\168\000\168\000\168\000\169\000\169\000\169\000\169\000\
    \169\000\169\000\169\000\169\000\169\000\169\000\000\000\000\000\
    \000\000\000\000\105\000\073\000\105\000\000\000\075\000\003\000\
    \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\
    \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\
    \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\
    \075\000\075\000\000\000\074\000\000\000\003\000\075\000\003\000\
    \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\
    \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\
    \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\
    \075\000\075\000\055\000\074\000\000\000\000\000\000\000\000\000\
    \000\000\057\000\000\000\030\000\030\000\030\000\030\000\030\000\
    \030\000\030\000\030\000\030\000\030\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\055\000\055\000\055\000\055\000\
    \056\000\055\000\058\000\058\000\058\000\058\000\058\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\000\000\000\000\
    \000\000\000\000\030\000\000\000\055\000\055\000\055\000\055\000\
    \056\000\055\000\058\000\058\000\058\000\058\000\058\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\055\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\057\000\000\000\030\000\
    \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\
    \030\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \055\000\059\000\055\000\055\000\056\000\055\000\058\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\060\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\061\000\
    \058\000\058\000\000\000\000\000\000\000\000\000\030\000\000\000\
    \055\000\059\000\055\000\055\000\056\000\055\000\058\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\060\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\061\000\
    \058\000\058\000\032\000\195\000\195\000\195\000\195\000\195\000\
    \195\000\195\000\195\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\000\000\000\000\
    \000\000\000\000\032\000\000\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\096\000\096\000\
    \096\000\096\000\096\000\096\000\096\000\096\000\096\000\096\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\096\000\
    \096\000\096\000\096\000\096\000\096\000\191\000\191\000\191\000\
    \191\000\191\000\191\000\191\000\191\000\191\000\191\000\192\000\
    \192\000\192\000\192\000\192\000\192\000\192\000\192\000\192\000\
    \192\000\000\000\000\000\000\000\000\000\000\000\000\000\096\000\
    \096\000\096\000\096\000\096\000\096\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\000\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\033\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\033\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\033\000\033\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\033\000\033\000\033\000\000\000\000\000\
    \000\000\000\000\033\000\000\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\033\000\033\000\033\000\112\000\108\000\
    \000\000\000\000\109\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\112\000\000\000\111\000\
    \000\000\000\000\000\000\000\000\145\000\000\000\000\000\146\000\
    \000\000\000\000\000\000\000\000\000\000\106\000\106\000\106\000\
    \106\000\106\000\106\000\106\000\106\000\106\000\106\000\000\000\
    \000\000\000\000\000\000\000\000\150\000\000\000\000\000\000\000\
    \000\000\148\000\152\000\000\000\151\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\000\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\034\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\149\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\000\000\000\000\
    \000\000\000\000\034\000\000\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\156\000\000\000\
    \156\000\156\000\156\000\156\000\156\000\156\000\156\000\156\000\
    \156\000\156\000\156\000\156\000\156\000\156\000\156\000\156\000\
    \156\000\156\000\156\000\156\000\156\000\156\000\156\000\156\000\
    \156\000\156\000\000\000\155\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\156\000\255\255\156\000\156\000\
    \156\000\156\000\156\000\156\000\156\000\156\000\156\000\156\000\
    \156\000\156\000\156\000\156\000\156\000\156\000\156\000\156\000\
    \156\000\156\000\156\000\156\000\156\000\156\000\156\000\156\000\
    \000\000\155\000\147\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\000\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\035\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\000\000\000\000\
    \000\000\000\000\035\000\000\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\171\000\171\000\
    \171\000\171\000\171\000\171\000\171\000\171\000\171\000\171\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\171\000\
    \171\000\171\000\171\000\171\000\171\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\171\000\
    \171\000\171\000\171\000\171\000\171\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\000\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\000\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\046\000\000\000\000\000\046\000\046\000\
    \046\000\000\000\000\000\000\000\046\000\046\000\000\000\046\000\
    \046\000\046\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\046\000\000\000\046\000\046\000\
    \046\000\046\000\046\000\000\000\210\000\000\000\210\000\210\000\
    \210\000\210\000\210\000\210\000\210\000\210\000\210\000\210\000\
    \210\000\210\000\210\000\210\000\210\000\210\000\210\000\210\000\
    \210\000\210\000\210\000\210\000\210\000\210\000\210\000\210\000\
    \046\000\052\000\209\000\052\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\052\000\052\000\000\000\046\000\046\000\
    \046\000\000\000\046\000\046\000\046\000\000\000\000\000\000\000\
    \046\000\046\000\000\000\046\000\046\000\046\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \046\000\000\000\046\000\046\000\046\000\046\000\046\000\000\000\
    \210\000\000\000\210\000\210\000\210\000\210\000\210\000\210\000\
    \210\000\210\000\210\000\210\000\210\000\210\000\210\000\210\000\
    \210\000\210\000\210\000\210\000\210\000\210\000\210\000\210\000\
    \210\000\210\000\210\000\210\000\046\000\048\000\209\000\048\000\
    \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\
    \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\
    \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\
    \048\000\000\000\046\000\000\000\046\000\000\000\000\000\000\000\
    \000\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\000\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\172\000\172\000\172\000\172\000\172\000\172\000\
    \172\000\172\000\172\000\172\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\172\000\172\000\172\000\172\000\172\000\
    \172\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\172\000\172\000\172\000\172\000\172\000\
    \172\000\000\000\000\000\000\000\000\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\035\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\000\000\000\000\000\000\000\000\035\000\000\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\
    \196\000\196\000\196\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\196\000\196\000\196\000\196\000\196\000\196\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\196\000\196\000\196\000\196\000\196\000\196\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\000\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\000\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\046\000\000\000\
    \000\000\046\000\046\000\046\000\000\000\000\000\000\000\046\000\
    \046\000\000\000\046\000\046\000\046\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\046\000\
    \000\000\046\000\046\000\046\000\046\000\046\000\000\000\000\000\
    \000\000\000\000\047\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\050\000\000\000\000\000\
    \000\000\000\000\000\000\046\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\000\000\000\000\
    \000\000\046\000\047\000\046\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\197\000\197\000\
    \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\197\000\
    \197\000\197\000\197\000\197\000\197\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\197\000\
    \197\000\197\000\197\000\197\000\197\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\000\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\048\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\048\000\048\000\048\000\048\000\048\000\
    \048\000\048\000\048\000\048\000\048\000\049\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\048\000\048\000\048\000\048\000\
    \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\
    \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\
    \048\000\048\000\048\000\048\000\048\000\048\000\000\000\000\000\
    \000\000\000\000\048\000\000\000\048\000\048\000\048\000\048\000\
    \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\
    \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\
    \048\000\048\000\048\000\048\000\048\000\048\000\199\000\199\000\
    \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\199\000\
    \199\000\199\000\199\000\199\000\199\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\199\000\
    \199\000\199\000\199\000\199\000\199\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\000\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\051\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\054\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\000\000\000\000\
    \000\000\000\000\051\000\000\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\000\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\052\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\052\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\052\000\052\000\053\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\052\000\052\000\052\000\000\000\000\000\
    \000\000\000\000\052\000\000\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\052\000\052\000\052\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\000\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\055\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\000\000\000\000\
    \000\000\000\000\055\000\000\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\000\000\
    \000\000\000\000\072\000\000\000\072\000\000\000\000\000\071\000\
    \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\
    \071\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\000\000\000\000\000\000\000\000\055\000\000\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\057\000\057\000\057\000\057\000\057\000\
    \057\000\057\000\057\000\057\000\057\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\055\000\055\000\055\000\055\000\
    \056\000\055\000\067\000\067\000\067\000\067\000\067\000\067\000\
    \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\
    \067\000\067\000\067\000\067\000\067\000\067\000\000\000\000\000\
    \000\000\000\000\057\000\000\000\055\000\055\000\055\000\055\000\
    \056\000\055\000\067\000\067\000\067\000\067\000\067\000\067\000\
    \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\
    \067\000\067\000\067\000\067\000\067\000\067\000\055\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\000\000\000\000\000\000\000\000\055\000\000\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\070\000\070\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\000\000\000\000\
    \000\000\000\000\055\000\000\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\069\000\
    \069\000\069\000\069\000\069\000\069\000\069\000\069\000\055\000\
    \055\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\000\000\000\000\000\000\000\000\055\000\000\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\062\000\062\000\062\000\062\000\062\000\
    \062\000\062\000\062\000\062\000\062\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\062\000\062\000\062\000\062\000\
    \062\000\062\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\000\000\000\000\
    \000\000\000\000\055\000\000\000\062\000\062\000\062\000\062\000\
    \062\000\062\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\063\000\000\000\062\000\
    \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\
    \062\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \062\000\062\000\062\000\062\000\062\000\062\000\058\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\064\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\
    \058\000\058\000\000\000\000\000\000\000\000\000\062\000\000\000\
    \062\000\062\000\062\000\062\000\062\000\062\000\058\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\064\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\
    \058\000\058\000\055\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\063\000\063\000\063\000\063\000\063\000\
    \063\000\063\000\063\000\063\000\063\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\063\000\063\000\063\000\063\000\
    \063\000\063\000\067\000\067\000\067\000\067\000\067\000\067\000\
    \067\000\067\000\067\000\068\000\067\000\067\000\067\000\067\000\
    \067\000\067\000\067\000\067\000\067\000\067\000\000\000\000\000\
    \000\000\000\000\063\000\000\000\063\000\063\000\063\000\063\000\
    \063\000\063\000\067\000\067\000\067\000\067\000\067\000\067\000\
    \067\000\067\000\067\000\068\000\067\000\067\000\067\000\067\000\
    \067\000\067\000\067\000\067\000\067\000\067\000\055\000\000\000\
    \000\000\000\000\066\000\000\000\066\000\000\000\000\000\065\000\
    \065\000\065\000\065\000\065\000\065\000\065\000\065\000\065\000\
    \065\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\000\000\000\000\000\000\000\000\055\000\000\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\065\000\065\000\065\000\065\000\065\000\
    \065\000\065\000\065\000\065\000\065\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\067\000\067\000\067\000\067\000\067\000\067\000\
    \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\
    \067\000\067\000\067\000\067\000\067\000\067\000\000\000\000\000\
    \000\000\000\000\065\000\000\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\067\000\067\000\067\000\067\000\067\000\067\000\
    \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\
    \067\000\067\000\067\000\067\000\067\000\067\000\055\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\000\000\000\000\000\000\000\000\055\000\000\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\000\000\000\000\000\000\066\000\000\000\
    \066\000\000\000\000\000\065\000\065\000\065\000\065\000\065\000\
    \065\000\065\000\065\000\065\000\065\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\000\000\000\000\
    \000\000\000\000\055\000\000\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\069\000\
    \069\000\069\000\069\000\069\000\069\000\069\000\069\000\055\000\
    \055\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\058\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\
    \058\000\058\000\000\000\000\000\000\000\000\000\069\000\000\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\058\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\
    \058\000\058\000\055\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\070\000\070\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\058\000\058\000\058\000\058\000\058\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\000\000\000\000\
    \000\000\000\000\070\000\000\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\058\000\058\000\058\000\058\000\058\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\055\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\071\000\
    \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\
    \071\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\067\000\067\000\
    \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\
    \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\
    \067\000\067\000\000\000\000\000\000\000\000\000\071\000\000\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\067\000\067\000\
    \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\
    \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\
    \067\000\067\000\086\000\103\000\086\000\000\000\103\000\103\000\
    \103\000\086\000\000\000\000\000\103\000\103\000\000\000\103\000\
    \103\000\103\000\085\000\085\000\085\000\085\000\085\000\085\000\
    \085\000\085\000\085\000\085\000\103\000\000\000\103\000\103\000\
    \103\000\103\000\103\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\105\000\000\000\105\000\105\000\105\000\105\000\
    \000\000\000\000\000\000\105\000\105\000\000\000\105\000\105\000\
    \105\000\000\000\000\000\000\000\000\000\000\000\086\000\000\000\
    \103\000\000\000\000\000\105\000\086\000\105\000\105\000\105\000\
    \105\000\105\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \086\000\084\000\000\000\000\000\086\000\000\000\086\000\000\000\
    \006\000\000\000\083\000\006\000\006\000\006\000\103\000\000\000\
    \103\000\006\000\006\000\000\000\006\000\006\000\006\000\105\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\006\000\000\000\006\000\006\000\006\000\006\000\006\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\117\000\
    \000\000\000\000\117\000\117\000\117\000\105\000\000\000\105\000\
    \117\000\117\000\000\000\117\000\117\000\117\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\006\000\000\000\000\000\
    \117\000\000\000\117\000\117\000\117\000\117\000\117\000\000\000\
    \000\000\000\000\117\000\000\000\000\000\117\000\117\000\117\000\
    \000\000\000\000\000\000\117\000\117\000\000\000\117\000\117\000\
    \117\000\000\000\000\000\006\000\000\000\006\000\000\000\000\000\
    \000\000\000\000\000\000\117\000\117\000\117\000\117\000\117\000\
    \117\000\117\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \117\000\000\000\000\000\117\000\117\000\117\000\000\000\000\000\
    \000\000\117\000\117\000\000\000\117\000\117\000\117\000\000\000\
    \000\000\000\000\117\000\000\000\117\000\000\000\000\000\117\000\
    \000\000\117\000\255\255\117\000\117\000\117\000\117\000\117\000\
    \000\000\000\000\000\000\120\000\000\000\000\000\120\000\120\000\
    \120\000\000\000\000\000\000\000\120\000\120\000\000\000\120\000\
    \120\000\120\000\000\000\000\000\000\000\117\000\000\000\117\000\
    \000\000\000\000\000\000\000\000\120\000\117\000\120\000\120\000\
    \120\000\120\000\120\000\000\000\000\000\000\000\006\000\000\000\
    \000\000\006\000\006\000\006\000\000\000\000\000\000\000\006\000\
    \006\000\000\000\006\000\006\000\006\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\117\000\000\000\117\000\000\000\006\000\
    \120\000\006\000\006\000\006\000\006\000\006\000\000\000\000\000\
    \000\000\006\000\000\000\000\000\006\000\006\000\006\000\000\000\
    \000\000\000\000\006\000\006\000\000\000\006\000\006\000\006\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\120\000\000\000\
    \120\000\000\000\006\000\006\000\006\000\006\000\006\000\006\000\
    \006\000\000\000\000\000\000\000\139\000\000\000\000\000\139\000\
    \139\000\139\000\000\000\000\000\000\000\139\000\139\000\000\000\
    \139\000\139\000\139\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\006\000\000\000\006\000\000\000\139\000\006\000\139\000\
    \139\000\139\000\139\000\139\000\000\000\000\000\000\000\139\000\
    \000\000\000\000\139\000\139\000\139\000\000\000\000\000\000\000\
    \139\000\139\000\000\000\139\000\139\000\139\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\006\000\000\000\006\000\000\000\
    \139\000\139\000\139\000\139\000\139\000\139\000\139\000\000\000\
    \000\000\000\000\117\000\000\000\000\000\117\000\117\000\117\000\
    \000\000\000\000\000\000\117\000\117\000\000\000\117\000\117\000\
    \117\000\000\000\000\000\000\000\000\000\000\000\000\000\139\000\
    \000\000\139\000\000\000\117\000\139\000\117\000\117\000\117\000\
    \117\000\117\000\000\000\000\000\000\000\117\000\000\000\000\000\
    \117\000\117\000\117\000\000\000\000\000\000\000\117\000\117\000\
    \000\000\117\000\117\000\117\000\000\000\000\000\166\000\000\000\
    \166\000\000\000\139\000\000\000\139\000\166\000\117\000\117\000\
    \117\000\117\000\117\000\117\000\117\000\000\000\165\000\165\000\
    \165\000\165\000\165\000\165\000\165\000\165\000\165\000\165\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\117\000\000\000\117\000\
    \000\000\000\000\117\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\188\000\000\000\000\000\189\000\000\000\000\000\000\000\
    \000\000\000\000\166\000\000\000\000\000\000\000\000\000\000\000\
    \166\000\000\000\000\000\000\000\000\000\000\000\000\000\187\000\
    \117\000\187\000\117\000\000\000\166\000\000\000\187\000\000\000\
    \166\000\000\000\166\000\000\000\000\000\000\000\164\000\186\000\
    \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\
    \186\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\
    \199\000\199\000\199\000\187\000\000\000\000\000\000\000\000\000\
    \000\000\187\000\199\000\199\000\199\000\199\000\199\000\199\000\
    \000\000\000\000\000\000\000\000\000\000\187\000\185\000\000\000\
    \000\000\187\000\000\000\187\000\183\000\000\000\000\000\184\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\199\000\199\000\199\000\199\000\199\000\199\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\200\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\255\255\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000";
  Lexing.lex_check =
   "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\000\000\000\000\041\000\000\000\000\000\041\000\042\000\
    \044\000\045\000\042\000\044\000\045\000\079\000\109\000\115\000\
    \079\000\109\000\115\000\146\000\160\000\218\000\146\000\160\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\
    \013\000\017\000\026\000\039\000\017\000\017\000\039\000\066\000\
    \066\000\066\000\066\000\066\000\066\000\066\000\066\000\066\000\
    \066\000\077\000\078\000\084\000\084\000\084\000\084\000\013\000\
    \086\000\013\000\039\000\013\000\072\000\072\000\072\000\072\000\
    \072\000\072\000\072\000\072\000\072\000\072\000\085\000\085\000\
    \085\000\085\000\085\000\085\000\085\000\085\000\085\000\085\000\
    \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\
    \088\000\088\000\089\000\093\000\096\000\098\000\098\000\127\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\013\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\003\000\100\000\100\000\003\000\003\000\003\000\102\000\
    \102\000\027\000\003\000\003\000\027\000\003\000\003\000\003\000\
    \091\000\091\000\091\000\091\000\091\000\091\000\091\000\091\000\
    \110\000\132\000\003\000\110\000\003\000\003\000\003\000\003\000\
    \003\000\151\000\113\000\152\000\004\000\113\000\027\000\004\000\
    \004\000\004\000\158\000\159\000\166\000\004\000\004\000\169\000\
    \004\000\004\000\004\000\092\000\092\000\092\000\092\000\092\000\
    \092\000\092\000\092\000\172\000\183\000\004\000\003\000\004\000\
    \004\000\004\000\004\000\004\000\211\000\174\000\179\000\005\000\
    \174\000\179\000\005\000\005\000\005\000\212\000\215\000\217\000\
    \005\000\005\000\188\000\005\000\005\000\005\000\185\000\185\000\
    \185\000\185\000\111\000\027\000\003\000\111\000\003\000\255\255\
    \005\000\004\000\005\000\005\000\005\000\005\000\005\000\255\255\
    \189\000\188\000\006\000\189\000\255\255\006\000\006\000\006\000\
    \255\255\255\255\111\000\006\000\006\000\255\255\006\000\006\000\
    \006\000\255\255\255\255\190\000\112\000\112\000\190\000\004\000\
    \112\000\004\000\255\255\006\000\005\000\006\000\006\000\006\000\
    \006\000\006\000\255\255\201\000\202\000\007\000\201\000\202\000\
    \007\000\007\000\007\000\112\000\255\255\112\000\007\000\007\000\
    \255\255\007\000\007\000\007\000\207\000\208\000\213\000\207\000\
    \208\000\214\000\005\000\216\000\005\000\255\255\007\000\006\000\
    \007\000\007\000\007\000\007\000\007\000\255\255\255\255\255\255\
    \008\000\255\255\255\255\008\000\008\000\008\000\255\255\255\255\
    \148\000\008\000\008\000\148\000\008\000\008\000\008\000\255\255\
    \255\255\255\255\255\255\255\255\255\255\006\000\255\255\006\000\
    \255\255\008\000\007\000\008\000\008\000\008\000\008\000\008\000\
    \255\255\255\255\255\255\010\000\255\255\148\000\010\000\010\000\
    \010\000\255\255\255\255\255\255\010\000\010\000\255\255\010\000\
    \010\000\010\000\255\255\255\255\255\255\255\255\255\255\255\255\
    \007\000\255\255\007\000\255\255\010\000\008\000\010\000\010\000\
    \010\000\010\000\010\000\255\255\175\000\255\255\255\255\175\000\
    \011\000\255\255\255\255\011\000\011\000\011\000\202\000\027\000\
    \255\255\011\000\011\000\255\255\011\000\011\000\011\000\255\255\
    \255\255\255\255\148\000\008\000\175\000\008\000\110\000\010\000\
    \010\000\011\000\255\255\011\000\011\000\011\000\011\000\011\000\
    \113\000\255\255\255\255\255\255\255\255\014\000\255\255\255\255\
    \014\000\014\000\014\000\255\255\255\255\255\255\014\000\014\000\
    \255\255\014\000\014\000\014\000\255\255\255\255\010\000\010\000\
    \010\000\255\255\255\255\255\255\011\000\011\000\014\000\255\255\
    \014\000\014\000\014\000\014\000\014\000\255\255\255\255\255\255\
    \015\000\255\255\255\255\015\000\015\000\015\000\175\000\255\255\
    \255\255\015\000\015\000\255\255\015\000\015\000\015\000\255\255\
    \111\000\255\255\255\255\011\000\255\255\011\000\255\255\255\255\
    \255\255\015\000\014\000\015\000\015\000\015\000\015\000\015\000\
    \255\255\255\255\018\000\255\255\255\255\018\000\018\000\018\000\
    \255\255\255\255\255\255\018\000\018\000\255\255\018\000\018\000\
    \018\000\255\255\255\255\112\000\255\255\255\255\255\255\255\255\
    \014\000\255\255\014\000\018\000\255\255\015\000\018\000\018\000\
    \018\000\018\000\202\000\255\255\255\255\019\000\255\255\255\255\
    \019\000\019\000\019\000\255\255\255\255\255\255\019\000\019\000\
    \255\255\019\000\019\000\019\000\213\000\255\255\255\255\214\000\
    \255\255\216\000\255\255\015\000\255\255\015\000\019\000\018\000\
    \019\000\019\000\019\000\019\000\019\000\255\255\255\255\255\255\
    \023\000\255\255\255\255\023\000\023\000\023\000\148\000\255\255\
    \255\255\023\000\023\000\255\255\023\000\023\000\023\000\255\255\
    \255\255\255\255\255\255\255\255\255\255\018\000\255\255\018\000\
    \255\255\023\000\019\000\023\000\023\000\023\000\023\000\023\000\
    \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\
    \083\000\083\000\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\083\000\083\000\083\000\083\000\083\000\083\000\255\255\
    \019\000\255\255\019\000\255\255\255\255\023\000\255\255\255\255\
    \255\255\255\255\175\000\255\255\255\255\255\255\255\255\024\000\
    \193\000\193\000\193\000\193\000\193\000\193\000\193\000\193\000\
    \255\255\083\000\083\000\083\000\083\000\083\000\083\000\255\255\
    \255\255\255\255\255\255\023\000\255\255\023\000\024\000\024\000\
    \255\255\024\000\024\000\024\000\024\000\255\255\255\255\255\255\
    \024\000\024\000\107\000\024\000\024\000\024\000\024\000\024\000\
    \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\
    \024\000\255\255\024\000\024\000\024\000\024\000\024\000\255\255\
    \255\255\107\000\025\000\255\255\255\255\025\000\025\000\025\000\
    \255\255\255\255\025\000\025\000\025\000\255\255\025\000\025\000\
    \025\000\107\000\107\000\107\000\107\000\107\000\107\000\107\000\
    \107\000\107\000\107\000\025\000\024\000\025\000\025\000\025\000\
    \025\000\025\000\165\000\165\000\165\000\165\000\165\000\165\000\
    \165\000\165\000\165\000\165\000\168\000\168\000\168\000\168\000\
    \168\000\168\000\168\000\168\000\168\000\168\000\255\255\255\255\
    \255\255\255\255\024\000\028\000\024\000\255\255\075\000\025\000\
    \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\
    \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\
    \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\
    \075\000\075\000\255\255\075\000\255\255\025\000\028\000\025\000\
    \028\000\028\000\028\000\028\000\028\000\028\000\028\000\028\000\
    \028\000\028\000\028\000\028\000\028\000\028\000\028\000\028\000\
    \028\000\028\000\028\000\028\000\028\000\028\000\028\000\028\000\
    \028\000\028\000\030\000\028\000\255\255\255\255\255\255\255\255\
    \255\255\030\000\255\255\030\000\030\000\030\000\030\000\030\000\
    \030\000\030\000\030\000\030\000\030\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\030\000\030\000\030\000\030\000\
    \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\
    \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\
    \030\000\030\000\030\000\030\000\030\000\030\000\255\255\255\255\
    \255\255\255\255\030\000\255\255\030\000\030\000\030\000\030\000\
    \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\
    \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\
    \030\000\030\000\030\000\030\000\030\000\030\000\031\000\255\255\
    \255\255\255\255\255\255\255\255\255\255\031\000\255\255\031\000\
    \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\
    \031\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\
    \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\
    \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\
    \031\000\031\000\255\255\255\255\255\255\255\255\031\000\255\255\
    \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\
    \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\
    \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\
    \031\000\031\000\032\000\194\000\194\000\194\000\194\000\194\000\
    \194\000\194\000\194\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\255\255\255\255\
    \255\255\255\255\032\000\255\255\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\095\000\095\000\
    \095\000\095\000\095\000\095\000\095\000\095\000\095\000\095\000\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\095\000\
    \095\000\095\000\095\000\095\000\095\000\186\000\186\000\186\000\
    \186\000\186\000\186\000\186\000\186\000\186\000\186\000\191\000\
    \191\000\191\000\191\000\191\000\191\000\191\000\191\000\191\000\
    \191\000\255\255\255\255\255\255\255\255\255\255\255\255\095\000\
    \095\000\095\000\095\000\095\000\095\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\255\255\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\033\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\032\000\032\000\033\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\033\000\033\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\033\000\033\000\033\000\255\255\255\255\
    \255\255\255\255\033\000\255\255\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\033\000\033\000\033\000\106\000\106\000\
    \255\255\255\255\106\000\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\106\000\255\255\106\000\
    \255\255\255\255\255\255\255\255\143\000\255\255\255\255\143\000\
    \255\255\255\255\255\255\255\255\255\255\106\000\106\000\106\000\
    \106\000\106\000\106\000\106\000\106\000\106\000\106\000\255\255\
    \255\255\255\255\255\255\255\255\143\000\255\255\255\255\255\255\
    \255\255\143\000\143\000\255\255\143\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\033\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\255\255\033\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\034\000\033\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\143\000\255\255\255\255\
    \255\255\255\255\255\255\255\255\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\255\255\255\255\
    \255\255\255\255\034\000\255\255\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\149\000\255\255\
    \149\000\149\000\149\000\149\000\149\000\149\000\149\000\149\000\
    \149\000\149\000\149\000\149\000\149\000\149\000\149\000\149\000\
    \149\000\149\000\149\000\149\000\149\000\149\000\149\000\149\000\
    \149\000\149\000\255\255\149\000\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\156\000\106\000\156\000\156\000\
    \156\000\156\000\156\000\156\000\156\000\156\000\156\000\156\000\
    \156\000\156\000\156\000\156\000\156\000\156\000\156\000\156\000\
    \156\000\156\000\156\000\156\000\156\000\156\000\156\000\156\000\
    \255\255\156\000\143\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\255\255\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\035\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\255\255\255\255\
    \255\255\255\255\035\000\255\255\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\164\000\164\000\
    \164\000\164\000\164\000\164\000\164\000\164\000\164\000\164\000\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\164\000\
    \164\000\164\000\164\000\164\000\164\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\164\000\
    \164\000\164\000\164\000\164\000\164\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\255\255\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\255\255\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\036\000\255\255\255\255\036\000\036\000\
    \036\000\255\255\255\255\255\255\036\000\036\000\255\255\036\000\
    \036\000\036\000\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\036\000\255\255\036\000\036\000\
    \036\000\036\000\036\000\255\255\204\000\255\255\204\000\204\000\
    \204\000\204\000\204\000\204\000\204\000\204\000\204\000\204\000\
    \204\000\204\000\204\000\204\000\204\000\204\000\204\000\204\000\
    \204\000\204\000\204\000\204\000\204\000\204\000\204\000\204\000\
    \036\000\036\000\204\000\036\000\036\000\036\000\036\000\036\000\
    \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\
    \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\
    \036\000\036\000\036\000\036\000\036\000\255\255\036\000\037\000\
    \036\000\255\255\037\000\037\000\037\000\255\255\255\255\255\255\
    \037\000\037\000\255\255\037\000\037\000\037\000\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \037\000\255\255\037\000\037\000\037\000\037\000\037\000\255\255\
    \210\000\255\255\210\000\210\000\210\000\210\000\210\000\210\000\
    \210\000\210\000\210\000\210\000\210\000\210\000\210\000\210\000\
    \210\000\210\000\210\000\210\000\210\000\210\000\210\000\210\000\
    \210\000\210\000\210\000\210\000\037\000\037\000\210\000\037\000\
    \037\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\
    \037\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\
    \037\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\
    \037\000\255\255\037\000\255\255\037\000\255\255\255\255\255\255\
    \255\255\036\000\036\000\036\000\036\000\036\000\036\000\036\000\
    \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\
    \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\
    \036\000\255\255\036\000\036\000\036\000\036\000\036\000\036\000\
    \036\000\036\000\171\000\171\000\171\000\171\000\171\000\171\000\
    \171\000\171\000\171\000\171\000\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\171\000\171\000\171\000\171\000\171\000\
    \171\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\171\000\171\000\171\000\171\000\171\000\
    \171\000\255\255\255\255\255\255\255\255\037\000\037\000\037\000\
    \037\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\
    \037\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\
    \037\000\037\000\037\000\037\000\037\000\038\000\037\000\037\000\
    \037\000\037\000\037\000\037\000\037\000\037\000\038\000\038\000\
    \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\038\000\
    \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\
    \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\
    \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\
    \038\000\255\255\255\255\255\255\255\255\038\000\255\255\038\000\
    \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\
    \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\
    \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\
    \038\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\
    \184\000\184\000\184\000\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\184\000\184\000\184\000\184\000\184\000\184\000\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\184\000\184\000\184\000\184\000\184\000\184\000\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\038\000\038\000\
    \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\
    \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\
    \038\000\038\000\038\000\038\000\038\000\255\255\038\000\038\000\
    \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\
    \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\
    \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\
    \038\000\038\000\038\000\038\000\038\000\255\255\038\000\038\000\
    \038\000\038\000\038\000\038\000\038\000\038\000\046\000\255\255\
    \255\255\046\000\046\000\046\000\255\255\255\255\255\255\046\000\
    \046\000\255\255\046\000\046\000\046\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\046\000\
    \255\255\046\000\046\000\046\000\046\000\046\000\255\255\255\255\
    \255\255\255\255\047\000\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\255\255\255\255\
    \255\255\255\255\255\255\046\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\255\255\255\255\
    \255\255\046\000\047\000\046\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\196\000\196\000\
    \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\196\000\
    \196\000\196\000\196\000\196\000\196\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\196\000\
    \196\000\196\000\196\000\196\000\196\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\255\255\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\048\000\047\000\047\000\047\000\047\000\047\000\
    \047\000\047\000\047\000\048\000\048\000\048\000\048\000\048\000\
    \048\000\048\000\048\000\048\000\048\000\048\000\255\255\255\255\
    \255\255\255\255\255\255\255\255\048\000\048\000\048\000\048\000\
    \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\
    \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\
    \048\000\048\000\048\000\048\000\048\000\048\000\255\255\255\255\
    \255\255\255\255\048\000\255\255\048\000\048\000\048\000\048\000\
    \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\
    \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\
    \048\000\048\000\048\000\048\000\048\000\048\000\198\000\198\000\
    \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\198\000\
    \198\000\198\000\198\000\198\000\198\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\198\000\
    \198\000\198\000\198\000\198\000\198\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\048\000\048\000\048\000\048\000\048\000\
    \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\
    \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\
    \048\000\048\000\255\255\048\000\048\000\048\000\048\000\048\000\
    \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\
    \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\
    \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\
    \048\000\048\000\051\000\048\000\048\000\048\000\048\000\048\000\
    \048\000\048\000\048\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\255\255\255\255\
    \255\255\255\255\255\255\255\255\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\255\255\255\255\
    \255\255\255\255\051\000\255\255\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\255\255\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\052\000\051\000\051\000\051\000\051\000\051\000\
    \051\000\051\000\051\000\052\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\052\000\052\000\052\000\255\255\255\255\
    \255\255\255\255\255\255\255\255\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\052\000\052\000\052\000\255\255\255\255\
    \255\255\255\255\052\000\255\255\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\052\000\052\000\052\000\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\052\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\255\255\052\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\055\000\052\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\255\255\255\255\
    \255\255\255\255\055\000\255\255\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\
    \055\000\055\000\055\000\055\000\055\000\055\000\056\000\255\255\
    \255\255\255\255\056\000\255\255\056\000\255\255\255\255\056\000\
    \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\
    \056\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\
    \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\
    \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\
    \056\000\056\000\255\255\255\255\255\255\255\255\056\000\255\255\
    \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\
    \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\
    \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\
    \056\000\056\000\057\000\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\057\000\057\000\057\000\057\000\057\000\
    \057\000\057\000\057\000\057\000\057\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\057\000\057\000\057\000\057\000\
    \057\000\057\000\057\000\057\000\057\000\057\000\057\000\057\000\
    \057\000\057\000\057\000\057\000\057\000\057\000\057\000\057\000\
    \057\000\057\000\057\000\057\000\057\000\057\000\255\255\255\255\
    \255\255\255\255\057\000\255\255\057\000\057\000\057\000\057\000\
    \057\000\057\000\057\000\057\000\057\000\057\000\057\000\057\000\
    \057\000\057\000\057\000\057\000\057\000\057\000\057\000\057\000\
    \057\000\057\000\057\000\057\000\057\000\057\000\058\000\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\
    \058\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\
    \058\000\058\000\255\255\255\255\255\255\255\255\058\000\255\255\
    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\
    \058\000\058\000\059\000\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\059\000\059\000\059\000\059\000\059\000\
    \059\000\059\000\059\000\059\000\059\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\059\000\059\000\059\000\059\000\
    \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\
    \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\
    \059\000\059\000\059\000\059\000\059\000\059\000\255\255\255\255\
    \255\255\255\255\059\000\255\255\059\000\059\000\059\000\059\000\
    \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\
    \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\
    \059\000\059\000\059\000\059\000\059\000\059\000\060\000\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\060\000\
    \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\
    \060\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\
    \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\
    \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\
    \060\000\060\000\255\255\255\255\255\255\255\255\060\000\255\255\
    \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\
    \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\
    \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\
    \060\000\060\000\061\000\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\061\000\061\000\061\000\061\000\061\000\
    \061\000\061\000\061\000\061\000\061\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\061\000\061\000\061\000\061\000\
    \061\000\061\000\061\000\061\000\061\000\061\000\061\000\061\000\
    \061\000\061\000\061\000\061\000\061\000\061\000\061\000\061\000\
    \061\000\061\000\061\000\061\000\061\000\061\000\255\255\255\255\
    \255\255\255\255\061\000\255\255\061\000\061\000\061\000\061\000\
    \061\000\061\000\061\000\061\000\061\000\061\000\061\000\061\000\
    \061\000\061\000\061\000\061\000\061\000\061\000\061\000\061\000\
    \061\000\061\000\061\000\061\000\061\000\061\000\062\000\255\255\
    \255\255\255\255\255\255\255\255\255\255\062\000\255\255\062\000\
    \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\
    \062\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\
    \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\
    \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\
    \062\000\062\000\255\255\255\255\255\255\255\255\062\000\255\255\
    \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\
    \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\
    \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\
    \062\000\062\000\063\000\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\063\000\063\000\063\000\063\000\063\000\
    \063\000\063\000\063\000\063\000\063\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\063\000\063\000\063\000\063\000\
    \063\000\063\000\063\000\063\000\063\000\063\000\063\000\063\000\
    \063\000\063\000\063\000\063\000\063\000\063\000\063\000\063\000\
    \063\000\063\000\063\000\063\000\063\000\063\000\255\255\255\255\
    \255\255\255\255\063\000\255\255\063\000\063\000\063\000\063\000\
    \063\000\063\000\063\000\063\000\063\000\063\000\063\000\063\000\
    \063\000\063\000\063\000\063\000\063\000\063\000\063\000\063\000\
    \063\000\063\000\063\000\063\000\063\000\063\000\064\000\255\255\
    \255\255\255\255\064\000\255\255\064\000\255\255\255\255\064\000\
    \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\
    \064\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\
    \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\
    \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\
    \064\000\064\000\255\255\255\255\255\255\255\255\064\000\255\255\
    \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\
    \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\
    \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\
    \064\000\064\000\065\000\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\065\000\065\000\065\000\065\000\065\000\
    \065\000\065\000\065\000\065\000\065\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\065\000\065\000\065\000\065\000\
    \065\000\065\000\065\000\065\000\065\000\065\000\065\000\065\000\
    \065\000\065\000\065\000\065\000\065\000\065\000\065\000\065\000\
    \065\000\065\000\065\000\065\000\065\000\065\000\255\255\255\255\
    \255\255\255\255\065\000\255\255\065\000\065\000\065\000\065\000\
    \065\000\065\000\065\000\065\000\065\000\065\000\065\000\065\000\
    \065\000\065\000\065\000\065\000\065\000\065\000\065\000\065\000\
    \065\000\065\000\065\000\065\000\065\000\065\000\067\000\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\067\000\
    \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\
    \067\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\
    \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\
    \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\
    \067\000\067\000\255\255\255\255\255\255\255\255\067\000\255\255\
    \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\
    \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\
    \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\
    \067\000\067\000\068\000\255\255\255\255\255\255\068\000\255\255\
    \068\000\255\255\255\255\068\000\068\000\068\000\068\000\068\000\
    \068\000\068\000\068\000\068\000\068\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\068\000\068\000\068\000\068\000\
    \068\000\068\000\068\000\068\000\068\000\068\000\068\000\068\000\
    \068\000\068\000\068\000\068\000\068\000\068\000\068\000\068\000\
    \068\000\068\000\068\000\068\000\068\000\068\000\255\255\255\255\
    \255\255\255\255\068\000\255\255\068\000\068\000\068\000\068\000\
    \068\000\068\000\068\000\068\000\068\000\068\000\068\000\068\000\
    \068\000\068\000\068\000\068\000\068\000\068\000\068\000\068\000\
    \068\000\068\000\068\000\068\000\068\000\068\000\069\000\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\069\000\
    \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\
    \069\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\
    \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\
    \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\
    \069\000\069\000\255\255\255\255\255\255\255\255\069\000\255\255\
    \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\
    \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\
    \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\
    \069\000\069\000\070\000\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\070\000\070\000\070\000\070\000\070\000\
    \070\000\070\000\070\000\070\000\070\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\070\000\070\000\070\000\070\000\
    \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\
    \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\
    \070\000\070\000\070\000\070\000\070\000\070\000\255\255\255\255\
    \255\255\255\255\070\000\255\255\070\000\070\000\070\000\070\000\
    \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\
    \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\
    \070\000\070\000\070\000\070\000\070\000\070\000\071\000\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\071\000\
    \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\
    \071\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\
    \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\
    \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\
    \071\000\071\000\255\255\255\255\255\255\255\255\071\000\255\255\
    \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\
    \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\
    \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\
    \071\000\071\000\076\000\103\000\076\000\255\255\103\000\103\000\
    \103\000\076\000\255\255\255\255\103\000\103\000\255\255\103\000\
    \103\000\103\000\076\000\076\000\076\000\076\000\076\000\076\000\
    \076\000\076\000\076\000\076\000\103\000\255\255\103\000\103\000\
    \103\000\103\000\103\000\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\105\000\255\255\105\000\105\000\105\000\105\000\
    \255\255\255\255\255\255\105\000\105\000\255\255\105\000\105\000\
    \105\000\255\255\255\255\255\255\255\255\255\255\076\000\255\255\
    \103\000\255\255\255\255\105\000\076\000\105\000\105\000\105\000\
    \105\000\105\000\255\255\255\255\255\255\255\255\255\255\255\255\
    \076\000\076\000\255\255\255\255\076\000\255\255\076\000\255\255\
    \116\000\255\255\076\000\116\000\116\000\116\000\103\000\255\255\
    \103\000\116\000\116\000\255\255\116\000\116\000\116\000\105\000\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\116\000\255\255\116\000\116\000\116\000\116\000\116\000\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\117\000\
    \255\255\255\255\117\000\117\000\117\000\105\000\255\255\105\000\
    \117\000\117\000\255\255\117\000\117\000\117\000\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\116\000\255\255\255\255\
    \117\000\255\255\117\000\117\000\117\000\117\000\117\000\255\255\
    \255\255\255\255\118\000\255\255\255\255\118\000\118\000\118\000\
    \255\255\255\255\255\255\118\000\118\000\255\255\118\000\118\000\
    \118\000\255\255\255\255\116\000\255\255\116\000\255\255\255\255\
    \255\255\255\255\255\255\118\000\117\000\118\000\118\000\118\000\
    \118\000\118\000\255\255\255\255\255\255\255\255\255\255\255\255\
    \119\000\255\255\255\255\119\000\119\000\119\000\255\255\255\255\
    \255\255\119\000\119\000\255\255\119\000\119\000\119\000\255\255\
    \255\255\255\255\117\000\255\255\117\000\255\255\255\255\118\000\
    \255\255\119\000\076\000\119\000\119\000\119\000\119\000\119\000\
    \255\255\255\255\255\255\120\000\255\255\255\255\120\000\120\000\
    \120\000\255\255\255\255\255\255\120\000\120\000\255\255\120\000\
    \120\000\120\000\255\255\255\255\255\255\118\000\255\255\118\000\
    \255\255\255\255\255\255\255\255\120\000\119\000\120\000\120\000\
    \120\000\120\000\120\000\255\255\255\255\255\255\126\000\255\255\
    \255\255\126\000\126\000\126\000\255\255\255\255\255\255\126\000\
    \126\000\255\255\126\000\126\000\126\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\119\000\255\255\119\000\255\255\126\000\
    \120\000\126\000\126\000\126\000\126\000\126\000\255\255\255\255\
    \255\255\136\000\255\255\255\255\136\000\136\000\136\000\255\255\
    \255\255\255\255\136\000\136\000\255\255\136\000\136\000\136\000\
    \255\255\255\255\255\255\255\255\255\255\255\255\120\000\255\255\
    \120\000\255\255\136\000\126\000\136\000\136\000\136\000\136\000\
    \136\000\255\255\255\255\255\255\139\000\255\255\255\255\139\000\
    \139\000\139\000\255\255\255\255\255\255\139\000\139\000\255\255\
    \139\000\139\000\139\000\255\255\255\255\255\255\255\255\255\255\
    \255\255\126\000\255\255\126\000\255\255\139\000\136\000\139\000\
    \139\000\139\000\139\000\139\000\255\255\255\255\255\255\140\000\
    \255\255\255\255\140\000\140\000\140\000\255\255\255\255\255\255\
    \140\000\140\000\255\255\140\000\140\000\140\000\255\255\255\255\
    \255\255\255\255\255\255\255\255\136\000\255\255\136\000\255\255\
    \140\000\139\000\140\000\140\000\140\000\140\000\140\000\255\255\
    \255\255\255\255\141\000\255\255\255\255\141\000\141\000\141\000\
    \255\255\255\255\255\255\141\000\141\000\255\255\141\000\141\000\
    \141\000\255\255\255\255\255\255\255\255\255\255\255\255\139\000\
    \255\255\139\000\255\255\141\000\140\000\141\000\141\000\141\000\
    \141\000\141\000\255\255\255\255\255\255\142\000\255\255\255\255\
    \142\000\142\000\142\000\255\255\255\255\255\255\142\000\142\000\
    \255\255\142\000\142\000\142\000\255\255\255\255\157\000\255\255\
    \157\000\255\255\140\000\255\255\140\000\157\000\142\000\141\000\
    \142\000\142\000\142\000\142\000\142\000\255\255\157\000\157\000\
    \157\000\157\000\157\000\157\000\157\000\157\000\157\000\157\000\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\141\000\255\255\141\000\
    \255\255\255\255\142\000\255\255\255\255\255\255\255\255\255\255\
    \255\255\180\000\255\255\255\255\180\000\255\255\255\255\255\255\
    \255\255\255\255\157\000\255\255\255\255\255\255\255\255\255\255\
    \157\000\255\255\255\255\255\255\255\255\255\255\255\255\180\000\
    \142\000\180\000\142\000\255\255\157\000\255\255\180\000\255\255\
    \157\000\255\255\157\000\255\255\255\255\255\255\157\000\180\000\
    \180\000\180\000\180\000\180\000\180\000\180\000\180\000\180\000\
    \180\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\199\000\199\000\199\000\199\000\199\000\199\000\199\000\
    \199\000\199\000\199\000\180\000\255\255\255\255\255\255\255\255\
    \255\255\180\000\199\000\199\000\199\000\199\000\199\000\199\000\
    \255\255\255\255\255\255\255\255\255\255\180\000\180\000\255\255\
    \255\255\180\000\255\255\180\000\180\000\255\255\255\255\180\000\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\199\000\199\000\199\000\199\000\199\000\199\000\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\199\000\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\180\000\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255";
  Lexing.lex_base_code =
   "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\010\000\036\000\022\000\000\000\000\000\000\000\
    \005\000\000\000\039\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\002\000\005\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000";
  Lexing.lex_backtrk_code =
   "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\053\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000";
  Lexing.lex_default_code =
   "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\031\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000";
  Lexing.lex_trans_code =
   "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\001\000\000\000\050\000\050\000\000\000\009\000\050\000\
    \000\000\000\000\000\000\009\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \001\000\000\000\009\000\001\000\000\000\009\000\000\000\034\000\
    \000\000\000\000\009\000\000\000\012\000\001\000\000\000\000\000\
    \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\
    \004\000\004\000\017\000\017\000\017\000\017\000\017\000\017\000\
    \017\000\017\000\017\000\017\000\001\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\017\000\017\000\017\000\017\000\
    \017\000\017\000\017\000\017\000\017\000\017\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000";
  Lexing.lex_check_code =
   "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\024\000\111\000\180\000\189\000\111\000\112\000\190\000\
    \255\255\255\255\255\255\106\000\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \024\000\255\255\111\000\000\000\255\255\112\000\255\255\112\000\
    \255\255\255\255\106\000\255\255\106\000\107\000\255\255\255\255\
    \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\
    \024\000\024\000\106\000\106\000\106\000\106\000\106\000\106\000\
    \106\000\106\000\106\000\106\000\107\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\107\000\107\000\107\000\107\000\
    \107\000\107\000\107\000\107\000\107\000\107\000\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \111\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255";
  Lexing.lex_code =
   "\255\005\255\255\007\255\006\255\255\007\255\255\009\255\008\255\
    \255\006\255\007\255\255\004\255\000\005\001\006\002\007\255\009\
    \255\255\008\255\009\255\255\000\005\001\006\004\008\003\009\002\
    \007\255\001\255\255\000\001\255";
}

let rec token lexbuf =
  lexbuf.Lexing.lex_mem <- Array.make 10 (-1); __ocaml_lex_token_rec lexbuf 0
and __ocaml_lex_token_rec lexbuf __ocaml_lex_state =
  match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state lexbuf with
      | 0 ->
# 770 "parsing/lexer.mll"
                 (
      if not !escaped_newlines then
        raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0),
                     Location.curr lexbuf));
      update_loc lexbuf None 1 false 0;
      token lexbuf )
# 2358 "parsing/lexer.ml"

  | 1 ->
# 777 "parsing/lexer.mll"
      ( update_loc lexbuf None 1 false 0;
        EOL )
# 2364 "parsing/lexer.ml"

  | 2 ->
# 780 "parsing/lexer.mll"
      ( token lexbuf )
# 2369 "parsing/lexer.ml"

  | 3 ->
# 782 "parsing/lexer.mll"
      ( UNDERSCORE )
# 2374 "parsing/lexer.ml"

  | 4 ->
# 784 "parsing/lexer.mll"
      ( TILDE )
# 2379 "parsing/lexer.ml"

  | 5 ->
# 786 "parsing/lexer.mll"
      ( LABEL (get_label_name lexbuf) )
# 2384 "parsing/lexer.ml"

  | 6 ->
# 788 "parsing/lexer.mll"
      ( warn_latin1 lexbuf; LABEL (get_label_name lexbuf) )
# 2389 "parsing/lexer.ml"

  | 7 ->
# 790 "parsing/lexer.mll"
      ( QUESTION )
# 2394 "parsing/lexer.ml"

  | 8 ->
# 792 "parsing/lexer.mll"
      ( OPTLABEL (get_label_name lexbuf) )
# 2399 "parsing/lexer.ml"

  | 9 ->
# 794 "parsing/lexer.mll"
      ( warn_latin1 lexbuf; OPTLABEL (get_label_name lexbuf) )
# 2404 "parsing/lexer.ml"

  | 10 ->
# 796 "parsing/lexer.mll"
      ( let s = Lexing.lexeme lexbuf in
        try Hashtbl.find keyword_table s
        with Not_found -> LIDENT s )
# 2411 "parsing/lexer.ml"

  | 11 ->
# 800 "parsing/lexer.mll"
      ( warn_latin1 lexbuf; LIDENT (Lexing.lexeme lexbuf) )
# 2416 "parsing/lexer.ml"

  | 12 ->
# 802 "parsing/lexer.mll"
      ( UIDENT(Lexing.lexeme lexbuf) )
# 2421 "parsing/lexer.ml"

  | 13 ->
# 804 "parsing/lexer.mll"
      ( warn_latin1 lexbuf; UIDENT(Lexing.lexeme lexbuf) )
# 2426 "parsing/lexer.ml"

  | 14 ->
# 805 "parsing/lexer.mll"
                ( INT (Lexing.lexeme lexbuf, None) )
# 2431 "parsing/lexer.ml"

  | 15 ->
let
# 806 "parsing/lexer.mll"
                    lit
# 2437 "parsing/lexer.ml"
= Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos (lexbuf.Lexing.lex_curr_pos + -1)
and
# 806 "parsing/lexer.mll"
                                              modif
# 2442 "parsing/lexer.ml"
= Lexing.sub_lexeme_char lexbuf (lexbuf.Lexing.lex_curr_pos + -1) in
# 807 "parsing/lexer.mll"
      ( INT (lit, Some modif) )
# 2446 "parsing/lexer.ml"

  | 16 ->
# 809 "parsing/lexer.mll"
      ( FLOAT (Lexing.lexeme lexbuf, None) )
# 2451 "parsing/lexer.ml"

  | 17 ->
let
# 810 "parsing/lexer.mll"
                                            lit
# 2457 "parsing/lexer.ml"
= Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos (lexbuf.Lexing.lex_curr_pos + -1)
and
# 810 "parsing/lexer.mll"
                                                                      modif
# 2462 "parsing/lexer.ml"
= Lexing.sub_lexeme_char lexbuf (lexbuf.Lexing.lex_curr_pos + -1) in
# 811 "parsing/lexer.mll"
      ( FLOAT (lit, Some modif) )
# 2466 "parsing/lexer.ml"

  | 18 ->
# 813 "parsing/lexer.mll"
      ( raise (Error(Invalid_literal (Lexing.lexeme lexbuf),
                     Location.curr lexbuf)) )
# 2472 "parsing/lexer.ml"

  | 19 ->
# 816 "parsing/lexer.mll"
      ( reset_string_buffer();
        is_in_string := true;
        let string_start = lexbuf.lex_start_p in
        string_start_loc := Location.curr lexbuf;
        string lexbuf;
        is_in_string := false;
        lexbuf.lex_start_p <- string_start;
        STRING (get_stored_string(), None) )
# 2484 "parsing/lexer.ml"

  | 20 ->
# 825 "parsing/lexer.mll"
      ( reset_string_buffer();
        let delim = Lexing.lexeme lexbuf in
        let delim = String.sub delim 1 (String.length delim - 2) in
        is_in_string := true;
        let string_start = lexbuf.lex_start_p in
        string_start_loc := Location.curr lexbuf;
        quoted_string delim lexbuf;
        is_in_string := false;
        lexbuf.lex_start_p <- string_start;
        STRING (get_stored_string(), Some delim) )
# 2498 "parsing/lexer.ml"

  | 21 ->
# 836 "parsing/lexer.mll"
      ( update_loc lexbuf None 1 false 1;
        CHAR (Lexing.lexeme_char lexbuf 1) )
# 2504 "parsing/lexer.ml"

  | 22 ->
# 839 "parsing/lexer.mll"
      ( CHAR(Lexing.lexeme_char lexbuf 1) )
# 2509 "parsing/lexer.ml"

  | 23 ->
# 841 "parsing/lexer.mll"
      ( CHAR(char_for_backslash (Lexing.lexeme_char lexbuf 2)) )
# 2514 "parsing/lexer.ml"

  | 24 ->
# 843 "parsing/lexer.mll"
      ( CHAR(char_for_decimal_code lexbuf 2) )
# 2519 "parsing/lexer.ml"

  | 25 ->
# 845 "parsing/lexer.mll"
      ( CHAR(char_for_octal_code lexbuf 3) )
# 2524 "parsing/lexer.ml"

  | 26 ->
# 847 "parsing/lexer.mll"
      ( CHAR(char_for_hexadecimal_code lexbuf 3) )
# 2529 "parsing/lexer.ml"

  | 27 ->
# 849 "parsing/lexer.mll"
      ( let l = Lexing.lexeme lexbuf in
        let esc = String.sub l 1 (String.length l - 1) in
        raise (Error(Illegal_escape esc, Location.curr lexbuf))
      )
# 2537 "parsing/lexer.ml"

  | 28 ->
# 854 "parsing/lexer.mll"
      ( let s, loc = with_comment_buffer comment lexbuf in
        COMMENT (s, loc) )
# 2543 "parsing/lexer.ml"

  | 29 ->
# 857 "parsing/lexer.mll"
      ( let s, loc = with_comment_buffer comment lexbuf in
        if !handle_docstrings then
          DOCSTRING (Docstrings.docstring s loc)
        else
          COMMENT ("*" ^ s, loc)
      )
# 2553 "parsing/lexer.ml"

  | 30 ->
let
# 863 "parsing/lexer.mll"
                     stars
# 2559 "parsing/lexer.ml"
= Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_start_pos + 3) lexbuf.Lexing.lex_curr_pos in
# 864 "parsing/lexer.mll"
      ( let s, loc =
          with_comment_buffer
            (fun lexbuf ->
               store_string ("*" ^ stars);
               comment lexbuf)
            lexbuf
        in
        COMMENT (s, loc) )
# 2570 "parsing/lexer.ml"

  | 31 ->
# 873 "parsing/lexer.mll"
      ( if !print_warnings then
          Location.prerr_warning (Location.curr lexbuf) Warnings.Comment_start;
        let s, loc = with_comment_buffer comment lexbuf in
        COMMENT (s, loc) )
# 2578 "parsing/lexer.ml"

  | 32 ->
let
# 877 "parsing/lexer.mll"
                    stars
# 2584 "parsing/lexer.ml"
= Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_start_pos + 2) (lexbuf.Lexing.lex_curr_pos + -2) in
# 878 "parsing/lexer.mll"
      ( if !handle_docstrings && stars="" then
         (* (**) is an empty docstring *)
          DOCSTRING(Docstrings.docstring "" (Location.curr lexbuf))
        else
          COMMENT (stars, Location.curr lexbuf) )
# 2592 "parsing/lexer.ml"

  | 33 ->
# 884 "parsing/lexer.mll"
      ( let loc = Location.curr lexbuf in
        Location.prerr_warning loc Warnings.Comment_not_end;
        lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1;
        let curpos = lexbuf.lex_curr_p in
        lexbuf.lex_curr_p <- { curpos with pos_cnum = curpos.pos_cnum - 1 };
        STAR
      )
# 2603 "parsing/lexer.ml"

  | 34 ->
let
# 891 "parsing/lexer.mll"
                                    num
# 2609 "parsing/lexer.ml"
= Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) lexbuf.Lexing.lex_mem.(1)
and
# 892 "parsing/lexer.mll"
                                            name
# 2614 "parsing/lexer.ml"
= Lexing.sub_lexeme_opt lexbuf lexbuf.Lexing.lex_mem.(4) lexbuf.Lexing.lex_mem.(3)
and
# 892 "parsing/lexer.mll"
                                                             directive
# 2619 "parsing/lexer.ml"
= Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_mem.(2) in
# 894 "parsing/lexer.mll"
      (
        match int_of_string num with
        | exception _ ->
            (* PR#7165 *)
            let loc = Location.curr lexbuf in
            let explanation = "line number out of range" in
            let error = Invalid_directive (directive, Some explanation) in
            raise (Error (error, loc))
        | line_num ->
           (* Documentation says that the line number should be
              positive, but we have never guarded against this and it
              might have useful hackish uses. *)
            update_loc lexbuf name line_num true 0;
            token lexbuf
      )
# 2637 "parsing/lexer.ml"

  | 35 ->
# 909 "parsing/lexer.mll"
         ( HASH )
# 2642 "parsing/lexer.ml"

  | 36 ->
# 910 "parsing/lexer.mll"
         ( AMPERSAND )
# 2647 "parsing/lexer.ml"

  | 37 ->
# 911 "parsing/lexer.mll"
         ( AMPERAMPER )
# 2652 "parsing/lexer.ml"

  | 38 ->
# 912 "parsing/lexer.mll"
         ( BACKQUOTE )
# 2657 "parsing/lexer.ml"

  | 39 ->
# 913 "parsing/lexer.mll"
         ( QUOTE )
# 2662 "parsing/lexer.ml"

  | 40 ->
# 914 "parsing/lexer.mll"
         ( LPAREN )
# 2667 "parsing/lexer.ml"

  | 41 ->
# 915 "parsing/lexer.mll"
         ( RPAREN )
# 2672 "parsing/lexer.ml"

  | 42 ->
# 916 "parsing/lexer.mll"
         ( STAR )
# 2677 "parsing/lexer.ml"

  | 43 ->
# 917 "parsing/lexer.mll"
         ( COMMA )
# 2682 "parsing/lexer.ml"

  | 44 ->
# 918 "parsing/lexer.mll"
         ( MINUSGREATER )
# 2687 "parsing/lexer.ml"

  | 45 ->
# 919 "parsing/lexer.mll"
         ( DOT )
# 2692 "parsing/lexer.ml"

  | 46 ->
# 920 "parsing/lexer.mll"
         ( DOTDOT )
# 2697 "parsing/lexer.ml"

  | 47 ->
let
# 921 "parsing/lexer.mll"
                                      s
# 2703 "parsing/lexer.ml"
= Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_start_pos + 1) lexbuf.Lexing.lex_curr_pos in
# 921 "parsing/lexer.mll"
                                         ( DOTOP s )
# 2707 "parsing/lexer.ml"

  | 48 ->
# 922 "parsing/lexer.mll"
         ( COLON )
# 2712 "parsing/lexer.ml"

  | 49 ->
# 923 "parsing/lexer.mll"
         ( COLONCOLON )
# 2717 "parsing/lexer.ml"

  | 50 ->
# 924 "parsing/lexer.mll"
         ( COLONEQUAL )
# 2722 "parsing/lexer.ml"

  | 51 ->
# 925 "parsing/lexer.mll"
         ( COLONGREATER )
# 2727 "parsing/lexer.ml"

  | 52 ->
# 926 "parsing/lexer.mll"
         ( SEMI )
# 2732 "parsing/lexer.ml"

  | 53 ->
# 927 "parsing/lexer.mll"
         ( SEMISEMI )
# 2737 "parsing/lexer.ml"

  | 54 ->
# 928 "parsing/lexer.mll"
         ( LESS )
# 2742 "parsing/lexer.ml"

  | 55 ->
# 929 "parsing/lexer.mll"
         ( LESSMINUS )
# 2747 "parsing/lexer.ml"

  | 56 ->
# 930 "parsing/lexer.mll"
         ( EQUAL )
# 2752 "parsing/lexer.ml"

  | 57 ->
# 931 "parsing/lexer.mll"
         ( LBRACKET )
# 2757 "parsing/lexer.ml"

  | 58 ->
# 932 "parsing/lexer.mll"
         ( LBRACKETBAR )
# 2762 "parsing/lexer.ml"

  | 59 ->
# 933 "parsing/lexer.mll"
         ( LBRACKETLESS )
# 2767 "parsing/lexer.ml"

  | 60 ->
# 934 "parsing/lexer.mll"
         ( LBRACKETGREATER )
# 2772 "parsing/lexer.ml"

  | 61 ->
# 935 "parsing/lexer.mll"
         ( RBRACKET )
# 2777 "parsing/lexer.ml"

  | 62 ->
# 936 "parsing/lexer.mll"
         ( LBRACE )
# 2782 "parsing/lexer.ml"

  | 63 ->
# 937 "parsing/lexer.mll"
         ( LBRACELESS )
# 2787 "parsing/lexer.ml"

  | 64 ->
# 938 "parsing/lexer.mll"
         ( BAR )
# 2792 "parsing/lexer.ml"

  | 65 ->
# 939 "parsing/lexer.mll"
         ( BARBAR )
# 2797 "parsing/lexer.ml"

  | 66 ->
# 940 "parsing/lexer.mll"
         ( BARRBRACKET )
# 2802 "parsing/lexer.ml"

  | 67 ->
# 941 "parsing/lexer.mll"
         ( GREATER )
# 2807 "parsing/lexer.ml"

  | 68 ->
# 942 "parsing/lexer.mll"
         ( GREATERRBRACKET )
# 2812 "parsing/lexer.ml"

  | 69 ->
# 943 "parsing/lexer.mll"
         ( RBRACE )
# 2817 "parsing/lexer.ml"

  | 70 ->
# 944 "parsing/lexer.mll"
         ( GREATERRBRACE )
# 2822 "parsing/lexer.ml"

  | 71 ->
# 945 "parsing/lexer.mll"
         ( LBRACKETAT )
# 2827 "parsing/lexer.ml"

  | 72 ->
# 946 "parsing/lexer.mll"
           ( LBRACKETATAT )
# 2832 "parsing/lexer.ml"

  | 73 ->
# 947 "parsing/lexer.mll"
           ( LBRACKETATATAT )
# 2837 "parsing/lexer.ml"

  | 74 ->
# 948 "parsing/lexer.mll"
           ( LBRACKETPERCENT )
# 2842 "parsing/lexer.ml"

  | 75 ->
# 949 "parsing/lexer.mll"
           ( LBRACKETPERCENTPERCENT )
# 2847 "parsing/lexer.ml"

  | 76 ->
# 950 "parsing/lexer.mll"
         ( BANG )
# 2852 "parsing/lexer.ml"

  | 77 ->
# 951 "parsing/lexer.mll"
         ( INFIXOP0 "!=" )
# 2857 "parsing/lexer.ml"

  | 78 ->
# 952 "parsing/lexer.mll"
         ( PLUS )
# 2862 "parsing/lexer.ml"

  | 79 ->
# 953 "parsing/lexer.mll"
         ( PLUSDOT )
# 2867 "parsing/lexer.ml"

  | 80 ->
# 954 "parsing/lexer.mll"
         ( PLUSEQ )
# 2872 "parsing/lexer.ml"

  | 81 ->
# 955 "parsing/lexer.mll"
         ( MINUS )
# 2877 "parsing/lexer.ml"

  | 82 ->
# 956 "parsing/lexer.mll"
         ( MINUSDOT )
# 2882 "parsing/lexer.ml"

  | 83 ->
# 959 "parsing/lexer.mll"
            ( PREFIXOP(Lexing.lexeme lexbuf) )
# 2887 "parsing/lexer.ml"

  | 84 ->
# 961 "parsing/lexer.mll"
            ( PREFIXOP(Lexing.lexeme lexbuf) )
# 2892 "parsing/lexer.ml"

  | 85 ->
# 963 "parsing/lexer.mll"
            ( INFIXOP0(Lexing.lexeme lexbuf) )
# 2897 "parsing/lexer.ml"

  | 86 ->
# 965 "parsing/lexer.mll"
            ( INFIXOP1(Lexing.lexeme lexbuf) )
# 2902 "parsing/lexer.ml"

  | 87 ->
# 967 "parsing/lexer.mll"
            ( INFIXOP2(Lexing.lexeme lexbuf) )
# 2907 "parsing/lexer.ml"

  | 88 ->
# 969 "parsing/lexer.mll"
            ( INFIXOP4(Lexing.lexeme lexbuf) )
# 2912 "parsing/lexer.ml"

  | 89 ->
# 970 "parsing/lexer.mll"
            ( PERCENT )
# 2917 "parsing/lexer.ml"

  | 90 ->
# 972 "parsing/lexer.mll"
            ( INFIXOP3(Lexing.lexeme lexbuf) )
# 2922 "parsing/lexer.ml"

  | 91 ->
# 974 "parsing/lexer.mll"
            ( HASHOP(Lexing.lexeme lexbuf) )
# 2927 "parsing/lexer.ml"

  | 92 ->
# 975 "parsing/lexer.mll"
        (
    if !if_then_else <> Dir_out then
      if !if_then_else = Dir_if_true then
        raise (Error (Unterminated_if, Location.curr lexbuf))
      else raise (Error(Unterminated_else, Location.curr lexbuf))
    else 
      EOF

  )
# 2940 "parsing/lexer.ml"

  | 93 ->
# 985 "parsing/lexer.mll"
      ( raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0),
                     Location.curr lexbuf))
      )
# 2947 "parsing/lexer.ml"

  | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf;
      __ocaml_lex_token_rec lexbuf __ocaml_lex_state

and comment lexbuf =
   __ocaml_lex_comment_rec lexbuf 143
and __ocaml_lex_comment_rec lexbuf __ocaml_lex_state =
  match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with
      | 0 ->
# 991 "parsing/lexer.mll"
      ( comment_start_loc := (Location.curr lexbuf) :: !comment_start_loc;
        store_lexeme lexbuf;
        comment lexbuf
      )
# 2962 "parsing/lexer.ml"

  | 1 ->
# 996 "parsing/lexer.mll"
      ( match !comment_start_loc with
        | [] -> assert false
        | [_] -> comment_start_loc := []; Location.curr lexbuf
        | _ :: l -> comment_start_loc := l;
                  store_lexeme lexbuf;
                  comment lexbuf
       )
# 2973 "parsing/lexer.ml"

  | 2 ->
# 1004 "parsing/lexer.mll"
      (
        string_start_loc := Location.curr lexbuf;
        store_string_char '\"';
        is_in_string := true;
        begin try string lexbuf
        with Error (Unterminated_string, str_start) ->
          match !comment_start_loc with
          | [] -> assert false
          | loc :: _ ->
            let start = List.hd (List.rev !comment_start_loc) in
            comment_start_loc := [];
            raise (Error (Unterminated_string_in_comment (start, str_start),
                          loc))
        end;
        is_in_string := false;
        store_string_char '\"';
        comment lexbuf )
# 2994 "parsing/lexer.ml"

  | 3 ->
# 1022 "parsing/lexer.mll"
      (
        let delim = Lexing.lexeme lexbuf in
        let delim = String.sub delim 1 (String.length delim - 2) in
        string_start_loc := Location.curr lexbuf;
        store_lexeme lexbuf;
        is_in_string := true;
        begin try quoted_string delim lexbuf
        with Error (Unterminated_string, str_start) ->
          match !comment_start_loc with
          | [] -> assert false
          | loc :: _ ->
            let start = List.hd (List.rev !comment_start_loc) in
            comment_start_loc := [];
            raise (Error (Unterminated_string_in_comment (start, str_start),
                          loc))
        end;
        is_in_string := false;
        store_string_char '|';
        store_string delim;
        store_string_char '}';
        comment lexbuf )
# 3019 "parsing/lexer.ml"

  | 4 ->
# 1045 "parsing/lexer.mll"
      ( store_lexeme lexbuf; comment lexbuf )
# 3024 "parsing/lexer.ml"

  | 5 ->
# 1047 "parsing/lexer.mll"
      ( update_loc lexbuf None 1 false 1;
        store_lexeme lexbuf;
        comment lexbuf
      )
# 3032 "parsing/lexer.ml"

  | 6 ->
# 1052 "parsing/lexer.mll"
      ( store_lexeme lexbuf; comment lexbuf )
# 3037 "parsing/lexer.ml"

  | 7 ->
# 1054 "parsing/lexer.mll"
      ( store_lexeme lexbuf; comment lexbuf )
# 3042 "parsing/lexer.ml"

  | 8 ->
# 1056 "parsing/lexer.mll"
      ( store_lexeme lexbuf; comment lexbuf )
# 3047 "parsing/lexer.ml"

  | 9 ->
# 1058 "parsing/lexer.mll"
      ( store_lexeme lexbuf; comment lexbuf )
# 3052 "parsing/lexer.ml"

  | 10 ->
# 1060 "parsing/lexer.mll"
      ( match !comment_start_loc with
        | [] -> assert false
        | loc :: _ ->
          let start = List.hd (List.rev !comment_start_loc) in
          comment_start_loc := [];
          raise (Error (Unterminated_comment start, loc))
      )
# 3063 "parsing/lexer.ml"

  | 11 ->
# 1068 "parsing/lexer.mll"
      ( update_loc lexbuf None 1 false 0;
        store_lexeme lexbuf;
        comment lexbuf
      )
# 3071 "parsing/lexer.ml"

  | 12 ->
# 1073 "parsing/lexer.mll"
      ( store_lexeme lexbuf; comment lexbuf )
# 3076 "parsing/lexer.ml"

  | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf;
      __ocaml_lex_comment_rec lexbuf __ocaml_lex_state

and string lexbuf =
  lexbuf.Lexing.lex_mem <- Array.make 2 (-1); __ocaml_lex_string_rec lexbuf 175
and __ocaml_lex_string_rec lexbuf __ocaml_lex_state =
  match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state lexbuf with
      | 0 ->
# 1077 "parsing/lexer.mll"
      ( () )
# 3088 "parsing/lexer.ml"

  | 1 ->
let
# 1078 "parsing/lexer.mll"
                                  space
# 3094 "parsing/lexer.ml"
= Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) lexbuf.Lexing.lex_curr_pos in
# 1079 "parsing/lexer.mll"
      ( update_loc lexbuf None 1 false (String.length space);
        if in_comment () then store_lexeme lexbuf;
        string lexbuf
      )
# 3101 "parsing/lexer.ml"

  | 2 ->
# 1084 "parsing/lexer.mll"
      ( store_escaped_char lexbuf
                           (char_for_backslash(Lexing.lexeme_char lexbuf 1));
        string lexbuf )
# 3108 "parsing/lexer.ml"

  | 3 ->
# 1088 "parsing/lexer.mll"
      ( store_escaped_char lexbuf (char_for_decimal_code lexbuf 1);
         string lexbuf )
# 3114 "parsing/lexer.ml"

  | 4 ->
# 1091 "parsing/lexer.mll"
      ( store_escaped_char lexbuf (char_for_octal_code lexbuf 2);
         string lexbuf )
# 3120 "parsing/lexer.ml"

  | 5 ->
# 1094 "parsing/lexer.mll"
      ( store_escaped_char lexbuf (char_for_hexadecimal_code lexbuf 2);
         string lexbuf )
# 3126 "parsing/lexer.ml"

  | 6 ->
# 1097 "parsing/lexer.mll"
        ( store_escaped_uchar lexbuf (uchar_for_uchar_escape lexbuf);
          string lexbuf )
# 3132 "parsing/lexer.ml"

  | 7 ->
# 1100 "parsing/lexer.mll"
      ( if not (in_comment ()) then begin
(*  Should be an error, but we are very lax.
          raise (Error (Illegal_escape (Lexing.lexeme lexbuf),
                        Location.curr lexbuf))
*)
          let loc = Location.curr lexbuf in
          Location.prerr_warning loc Warnings.Illegal_backslash;
        end;
        store_lexeme lexbuf;
        string lexbuf
      )
# 3147 "parsing/lexer.ml"

  | 8 ->
# 1112 "parsing/lexer.mll"
      ( if not (in_comment ()) then
          Location.prerr_warning (Location.curr lexbuf) Warnings.Eol_in_string;
        update_loc lexbuf None 1 false 0;
        store_lexeme lexbuf;
        string lexbuf
      )
# 3157 "parsing/lexer.ml"

  | 9 ->
# 1119 "parsing/lexer.mll"
      ( is_in_string := false;
        raise (Error (Unterminated_string, !string_start_loc)) )
# 3163 "parsing/lexer.ml"

  | 10 ->
# 1122 "parsing/lexer.mll"
      ( store_string_char(Lexing.lexeme_char lexbuf 0);
        string lexbuf )
# 3169 "parsing/lexer.ml"

  | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf;
      __ocaml_lex_string_rec lexbuf __ocaml_lex_state

and quoted_string delim lexbuf =
   __ocaml_lex_quoted_string_rec delim lexbuf 202
and __ocaml_lex_quoted_string_rec delim lexbuf __ocaml_lex_state =
  match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with
      | 0 ->
# 1127 "parsing/lexer.mll"
      ( update_loc lexbuf None 1 false 0;
        store_lexeme lexbuf;
        quoted_string delim lexbuf
      )
# 3184 "parsing/lexer.ml"

  | 1 ->
# 1132 "parsing/lexer.mll"
      ( is_in_string := false;
        raise (Error (Unterminated_string, !string_start_loc)) )
# 3190 "parsing/lexer.ml"

  | 2 ->
# 1135 "parsing/lexer.mll"
      (
        let edelim = Lexing.lexeme lexbuf in
        let edelim = String.sub edelim 1 (String.length edelim - 2) in
        if delim = edelim then ()
        else (store_lexeme lexbuf; quoted_string delim lexbuf)
      )
# 3200 "parsing/lexer.ml"

  | 3 ->
# 1142 "parsing/lexer.mll"
      ( store_string_char(Lexing.lexeme_char lexbuf 0);
        quoted_string delim lexbuf )
# 3206 "parsing/lexer.ml"

  | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf;
      __ocaml_lex_quoted_string_rec delim lexbuf __ocaml_lex_state

and skip_hash_bang lexbuf =
   __ocaml_lex_skip_hash_bang_rec lexbuf 211
and __ocaml_lex_skip_hash_bang_rec lexbuf __ocaml_lex_state =
  match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with
      | 0 ->
# 1147 "parsing/lexer.mll"
       ( update_loc lexbuf None 3 false 0 )
# 3218 "parsing/lexer.ml"

  | 1 ->
# 1149 "parsing/lexer.mll"
       ( update_loc lexbuf None 1 false 0 )
# 3223 "parsing/lexer.ml"

  | 2 ->
# 1150 "parsing/lexer.mll"
       ( () )
# 3228 "parsing/lexer.ml"

  | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf;
      __ocaml_lex_skip_hash_bang_rec lexbuf __ocaml_lex_state

;;

# 1152 "parsing/lexer.mll"
 
  let at_bol lexbuf = 
    let pos = Lexing.lexeme_start_p lexbuf in 
    pos.pos_cnum = pos.pos_bol 

  let token_with_comments lexbuf =
    match !preprocessor with
    | None -> token lexbuf
    | Some (_init, preprocess) -> preprocess token lexbuf

  type newline_state =
    | NoLine (* There have been no blank lines yet. *)
    | NewLine
        (* There have been no blank lines, and the previous
           token was a newline. *)
    | BlankLine (* There have been blank lines. *)

  type doc_state =
    | Initial  (* There have been no docstrings yet *)
    | After of docstring list
        (* There have been docstrings, none of which were
           preceded by a blank line *)
    | Before of docstring list * docstring list * docstring list
        (* There have been docstrings, some of which were
           preceded by a blank line *)

  and docstring = Docstrings.docstring

  let interpret_directive lexbuf cont look_ahead = 
    let if_then_else = !if_then_else in
    begin match token_with_comments lexbuf, if_then_else with 
    |  IF, Dir_out  ->
        let rec skip_from_if_false () = 
          let token = token_with_comments lexbuf in
          if token = EOF then 
            raise (Error (Unterminated_if, Location.curr lexbuf)) else
          if token = HASH && at_bol lexbuf then 
            begin 
              let token = token_with_comments lexbuf in
              match token with
              | END -> 
                  begin
                    update_if_then_else Dir_out;
                    cont lexbuf
                  end
              | ELSE -> 
                  begin
                    update_if_then_else Dir_if_false;
                    cont lexbuf
                  end
              | IF ->
                  raise (Error (Unexpected_directive, Location.curr lexbuf))
              | _ -> 
                  if is_elif token &&
                     directive_parse token_with_comments lexbuf then
                    begin
                      update_if_then_else Dir_if_true;
                      cont lexbuf
                    end
                  else skip_from_if_false ()                               
            end
          else skip_from_if_false () in 
        if directive_parse token_with_comments lexbuf then
          begin 
            update_if_then_else Dir_if_true (* Next state: ELSE *);
            cont lexbuf
          end
        else
          skip_from_if_false ()
    | IF,  (Dir_if_false | Dir_if_true)->
        raise (Error(Unexpected_directive, Location.curr lexbuf))
    | LIDENT "elif", (Dir_if_false | Dir_out)
      -> (* when the predicate is false, it will continue eating `elif` *)
        raise (Error(Unexpected_directive, Location.curr lexbuf))
    | (LIDENT "elif" | ELSE as token), Dir_if_true ->           
        (* looking for #end, however, it can not see #if anymore *)
        let rec skip_from_if_true else_seen = 
          let token = token_with_comments lexbuf in
          if token = EOF then 
            raise (Error (Unterminated_else, Location.curr lexbuf)) else
          if token = HASH && at_bol lexbuf then 
            begin 
              let token = token_with_comments lexbuf in 
              match token with  
              | END -> 
                  begin
                    update_if_then_else Dir_out;
                    cont lexbuf
                  end  
              | IF ->  
                  raise (Error (Unexpected_directive, Location.curr lexbuf)) 
              | ELSE ->
                  if else_seen then 
                    raise (Error (Unexpected_directive, Location.curr lexbuf))
                  else 
                    skip_from_if_true true
              | _ ->
                  if else_seen && is_elif token then  
                    raise (Error (Unexpected_directive, Location.curr lexbuf))
                  else 
                    skip_from_if_true else_seen
            end
          else skip_from_if_true else_seen in 
        skip_from_if_true (token = ELSE)
    | ELSE, Dir_if_false 
    | ELSE, Dir_out -> 
        raise (Error(Unexpected_directive, Location.curr lexbuf))
    | END, (Dir_if_false | Dir_if_true ) -> 
        update_if_then_else  Dir_out;
        cont lexbuf
    | END,  Dir_out  -> 
        raise (Error(Unexpected_directive, Location.curr lexbuf))
    | token, (Dir_if_true | Dir_if_false | Dir_out) ->
        look_ahead token 
    end

  let token lexbuf =
    let post_pos = lexeme_end_p lexbuf in
    let attach lines docs pre_pos =
      let open Docstrings in
        match docs, lines with
        | Initial, _ -> ()
        | After a, (NoLine | NewLine) ->
            set_post_docstrings post_pos (List.rev a);
            set_pre_docstrings pre_pos a;
        | After a, BlankLine ->
            set_post_docstrings post_pos (List.rev a);
            set_pre_extra_docstrings pre_pos (List.rev a)
        | Before(a, f, b), (NoLine | NewLine) ->
            set_post_docstrings post_pos (List.rev a);
            set_post_extra_docstrings post_pos
              (List.rev_append f (List.rev b));
            set_floating_docstrings pre_pos (List.rev f);
            set_pre_extra_docstrings pre_pos (List.rev a);
            set_pre_docstrings pre_pos b
        | Before(a, f, b), BlankLine ->
            set_post_docstrings post_pos (List.rev a);
            set_post_extra_docstrings post_pos
              (List.rev_append f (List.rev b));
            set_floating_docstrings pre_pos
              (List.rev_append f (List.rev b));
            set_pre_extra_docstrings pre_pos (List.rev a)
    in
    let rec loop lines docs lexbuf =
      match token_with_comments lexbuf with
      | COMMENT (s, loc) ->
          add_comment (s, loc);
          let lines' =
            match lines with
            | NoLine -> NoLine
            | NewLine -> NoLine
            | BlankLine -> BlankLine
          in
          loop lines' docs lexbuf
      | EOL ->
          let lines' =
            match lines with
            | NoLine -> NewLine
            | NewLine -> BlankLine
            | BlankLine -> BlankLine
          in
          loop lines' docs lexbuf
      | HASH when at_bol lexbuf -> 
          interpret_directive lexbuf 
            (fun lexbuf -> loop lines docs lexbuf)
            (fun token -> sharp_look_ahead := Some token; HASH)            
      | DOCSTRING doc ->
          Docstrings.register doc;
          add_docstring_comment doc;
          let docs' =
            if Docstrings.docstring_body doc = "/*" then
              match docs with
              | Initial -> Before([], [doc], [])
              | After a -> Before (a, [doc], [])
              | Before(a, f, b) -> Before(a, doc :: b @ f, [])
            else
              match docs, lines with
              | Initial, (NoLine | NewLine) -> After [doc]
              | Initial, BlankLine -> Before([], [], [doc])
              | After a, (NoLine | NewLine) -> After (doc :: a)
              | After a, BlankLine -> Before (a, [], [doc])
              | Before(a, f, b), (NoLine | NewLine) -> Before(a, f, doc :: b)
              | Before(a, f, b), BlankLine -> Before(a, b @ f, [doc])
          in
          loop NoLine docs' lexbuf
      | tok ->
          attach lines docs (lexeme_start_p lexbuf);
          tok
    in
      match !sharp_look_ahead with
      | None -> 
          loop NoLine Initial lexbuf
      | Some token ->
          sharp_look_ahead := None ;
          token

  let init () =
    sharp_look_ahead := None;
    update_if_then_else  Dir_out;
    is_in_string := false;
    comment_start_loc := [];
    comment_list := [];
    match !preprocessor with
    | None -> ()
    | Some (init, _preprocess) -> init ()

  let rec filter_directive pos   acc lexbuf : (int * int ) list =
    match token_with_comments lexbuf with
    | HASH when at_bol lexbuf ->
        (* ^[start_pos]#if ... #then^[end_pos] *)
        let start_pos = Lexing.lexeme_start lexbuf in 
        interpret_directive lexbuf 
          (fun lexbuf -> 
             filter_directive 
               (Lexing.lexeme_end lexbuf)
               ((pos, start_pos) :: acc)
               lexbuf
          
          )
          (fun _token -> filter_directive pos acc lexbuf  )
    | EOF -> (pos, Lexing.lexeme_end lexbuf) :: acc
    | _ -> filter_directive pos  acc lexbuf

  let filter_directive_from_lexbuf lexbuf = 
    List.rev (filter_directive 0 [] lexbuf )

  let set_preprocessor init preprocess =
    escaped_newlines := true;
    preprocessor := Some (init, preprocess)


# 3467 "parsing/lexer.ml"

end
(** Interface as module  *)
module Outcometree
= struct
#1 "outcometree.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*      Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt          *)
(*                                                                        *)
(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Module [Outcometree]: results displayed by the toplevel *)

(* These types represent messages that the toplevel displays as normal
   results or errors. The real displaying is customisable using the hooks:
      [Toploop.print_out_value]
      [Toploop.print_out_type]
      [Toploop.print_out_sig_item]
      [Toploop.print_out_phrase] *)

type out_ident =
  | Oide_apply of out_ident * out_ident
  | Oide_dot of out_ident * string
  | Oide_ident of string

type out_string =
  | Ostr_string
  | Ostr_bytes

type out_attribute =
  { oattr_name: string }

type out_value =
  | Oval_array of out_value list
  | Oval_char of char
  | Oval_constr of out_ident * out_value list
  | Oval_ellipsis
  | Oval_float of float
  | Oval_int of int
  | Oval_int32 of int32
  | Oval_int64 of int64
  | Oval_nativeint of nativeint
  | Oval_list of out_value list
  | Oval_printer of (Format.formatter -> unit)
  | Oval_record of (out_ident * out_value) list
  | Oval_string of string * int * out_string (* string, size-to-print, kind *)
  | Oval_stuff of string
  | Oval_tuple of out_value list
  | Oval_variant of string * out_value option

type out_type =
  | Otyp_abstract
  | Otyp_open
  | Otyp_alias of out_type * string
  | Otyp_arrow of string * out_type * out_type
  | Otyp_class of bool * out_ident * out_type list
  | Otyp_constr of out_ident * out_type list
  | Otyp_manifest of out_type * out_type
  | Otyp_object of (string * out_type) list * bool option
  | Otyp_record of (string * bool * out_type) list
  | Otyp_stuff of string
  | Otyp_sum of (string * out_type list * out_type option) list
  | Otyp_tuple of out_type list
  | Otyp_var of bool * string
  | Otyp_variant of
      bool * out_variant * bool * (string list) option
  | Otyp_poly of string list * out_type
  | Otyp_module of string * string list * out_type list
  | Otyp_attribute of out_type * out_attribute

and out_variant =
  | Ovar_fields of (string * bool * out_type list) list
  | Ovar_typ of out_type

type out_class_type =
  | Octy_constr of out_ident * out_type list
  | Octy_arrow of string * out_type * out_class_type
  | Octy_signature of out_type option * out_class_sig_item list
and out_class_sig_item =
  | Ocsg_constraint of out_type * out_type
  | Ocsg_method of string * bool * bool * out_type
  | Ocsg_value of string * bool * bool * out_type

type out_module_type =
  | Omty_abstract
  | Omty_functor of string * out_module_type option * out_module_type
  | Omty_ident of out_ident
  | Omty_signature of out_sig_item list
  | Omty_alias of out_ident
and out_sig_item =
  | Osig_class of
      bool * string * (string * (bool * bool)) list * out_class_type *
        out_rec_status
  | Osig_class_type of
      bool * string * (string * (bool * bool)) list * out_class_type *
        out_rec_status
  | Osig_typext of out_extension_constructor * out_ext_status
  | Osig_modtype of string * out_module_type
  | Osig_module of string * out_module_type * out_rec_status
  | Osig_type of out_type_decl * out_rec_status
  | Osig_value of out_val_decl
  | Osig_ellipsis
and out_type_decl =
  { otype_name: string;
    otype_params: (string * (bool * bool)) list;
    otype_type: out_type;
    otype_private: Asttypes.private_flag;
    otype_immediate: bool;
    otype_unboxed: bool;
    otype_cstrs: (out_type * out_type) list }
and out_extension_constructor =
  { oext_name: string;
    oext_type_name: string;
    oext_type_params: string list;
    oext_args: out_type list;
    oext_ret_type: out_type option;
    oext_private: Asttypes.private_flag }
and out_type_extension =
  { otyext_name: string;
    otyext_params: string list;
    otyext_constructors: (string * out_type list * out_type option) list;
    otyext_private: Asttypes.private_flag }
and out_val_decl =
  { oval_name: string;
    oval_type: out_type;
    oval_prims: string list;
    oval_attributes: out_attribute list }
and out_rec_status =
  | Orec_not
  | Orec_first
  | Orec_next
and out_ext_status =
  | Oext_first
  | Oext_next
  | Oext_exception

type out_phrase =
  | Ophr_eval of out_value * out_type
  | Ophr_signature of (out_sig_item * out_value option) list
  | Ophr_exception of (exn * out_value)

end
module Oprint : sig 
#1 "oprint.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                   Projet Cristal, INRIA Rocquencourt                   *)
(*                                                                        *)
(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Format
open Outcometree


val out_ident : (formatter -> string -> unit) ref

val out_value : (formatter -> out_value -> unit) ref
val out_type : (formatter -> out_type -> unit) ref
val out_class_type : (formatter -> out_class_type -> unit) ref
val out_module_type : (formatter -> out_module_type -> unit) ref
val out_sig_item : (formatter -> out_sig_item -> unit) ref
val out_signature : (formatter -> out_sig_item list -> unit) ref
val out_type_extension : (formatter -> out_type_extension -> unit) ref
val out_phrase : (formatter -> out_phrase -> unit) ref

val parenthesized_ident : string -> bool

end = struct
#1 "oprint.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                   Projet Cristal, INRIA Rocquencourt                   *)
(*                                                                        *)
(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Format
open Outcometree

exception Ellipsis

let cautious f ppf arg =
  try f ppf arg with
    Ellipsis -> fprintf ppf "..."


let out_ident = ref pp_print_string


let print_lident ppf = function
  | "::" -> !out_ident ppf "(::)"
  | s -> !out_ident ppf s

let rec print_ident ppf =
  function
    Oide_ident s -> print_lident ppf s
  | Oide_dot (id, s) ->
      print_ident ppf id; pp_print_char ppf '.'; print_lident ppf s
  | Oide_apply (id1, id2) ->
      fprintf ppf "%a(%a)" print_ident id1 print_ident id2

let parenthesized_ident name =
  (List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"])
  ||
  (match name.[0] with
      'a'..'z' | 'A'..'Z' | '\223'..'\246' | '\248'..'\255' | '_' ->
        false
    | _ -> true)

let value_ident ppf name =
  if parenthesized_ident name then
    fprintf ppf "( %s )" name
  else
    pp_print_string ppf name

(* Values *)

let valid_float_lexeme s =
  let l = String.length s in
  let rec loop i =
    if i >= l then s ^ "." else
    match s.[i] with
    | '0' .. '9' | '-' -> loop (i+1)
    | _ -> s
  in loop 0

let float_repres f =
  match classify_float f with
    FP_nan -> "nan"
  | FP_infinite ->
      if f < 0.0 then "neg_infinity" else "infinity"
  | _ ->
      let float_val =
        let s1 = Printf.sprintf "%.12g" f in
        if f = float_of_string s1 then s1 else
        let s2 = Printf.sprintf "%.15g" f in
        if f = float_of_string s2 then s2 else
        Printf.sprintf "%.18g" f
      in valid_float_lexeme float_val

let parenthesize_if_neg ppf fmt v isneg =
  if isneg then pp_print_char ppf '(';
  fprintf ppf fmt v;
  if isneg then pp_print_char ppf ')'

let escape_string s =
  (* Escape only C0 control characters (bytes <= 0x1F), DEL(0x7F), '\\' and '"' *)
   let n = ref 0 in
  for i = 0 to String.length s - 1 do
    n := !n +
      (match String.unsafe_get s i with
       | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2
       | '\x00' .. '\x1F'
       | '\x7F' -> 4
       | _ -> 1)
  done;
  if !n = String.length s then s else begin
    let s' = Bytes.create !n in
    n := 0;
    for i = 0 to String.length s - 1 do
      begin match String.unsafe_get s i with
      | ('\"' | '\\') as c ->
          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n c
      | '\n' ->
          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'n'
      | '\t' ->
          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 't'
      | '\r' ->
          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'r'
      | '\b' ->
          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'b'
      | '\x00' .. '\x1F' | '\x7F' as c ->
          let a = Char.code c in
          Bytes.unsafe_set s' !n '\\';
          incr n;
          Bytes.unsafe_set s' !n (Char.chr (48 + a / 100));
          incr n;
          Bytes.unsafe_set s' !n (Char.chr (48 + (a / 10) mod 10));
          incr n;
          Bytes.unsafe_set s' !n (Char.chr (48 + a mod 10));
      | c -> Bytes.unsafe_set s' !n c
      end;
      incr n
    done;
    Bytes.to_string s'
  end


let print_out_string ppf s =
  let not_escaped =
    (* let the user dynamically choose if strings should be escaped: *)
    match Sys.getenv_opt "OCAMLTOP_UTF_8" with
    | None -> true
    | Some x ->
        match bool_of_string_opt x with
        | None -> true
        | Some f -> f in
  if not_escaped then
    fprintf ppf "\"%s\"" (escape_string s)
  else
    fprintf ppf "%S" s

let print_out_value ppf tree =
  let rec print_tree_1 ppf =
    function
    | Oval_constr (name, [param]) ->
        fprintf ppf "@[<1>%a@ %a@]" print_ident name print_constr_param param
    | Oval_constr (name, (_ :: _ as params)) ->
        fprintf ppf "@[<1>%a@ (%a)@]" print_ident name
          (print_tree_list print_tree_1 ",") params
    | Oval_variant (name, Some param) ->
        fprintf ppf "@[<2>`%s@ %a@]" name print_constr_param param
    | tree -> print_simple_tree ppf tree
  and print_constr_param ppf = function
    | Oval_int i -> parenthesize_if_neg ppf "%i" i (i < 0)
    | Oval_int32 i -> parenthesize_if_neg ppf "%lil" i (i < 0l)
    | Oval_int64 i -> parenthesize_if_neg ppf "%LiL" i (i < 0L)
    | Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i (i < 0n)
    | Oval_float f -> parenthesize_if_neg ppf "%s" (float_repres f) (f < 0.0)
    | Oval_string (_,_, Ostr_bytes) as tree ->
      pp_print_char ppf '(';
      print_simple_tree ppf tree;
      pp_print_char ppf ')';
    | tree -> print_simple_tree ppf tree
  and print_simple_tree ppf =
    function
      Oval_int i -> fprintf ppf "%i" i
    | Oval_int32 i -> fprintf ppf "%lil" i
    | Oval_int64 i -> fprintf ppf "%LiL" i
    | Oval_nativeint i -> fprintf ppf "%nin" i
    | Oval_float f -> pp_print_string ppf (float_repres f)
    | Oval_char c -> fprintf ppf "%C" c
    | Oval_string (s, maxlen, kind) ->
       begin try
         let len = String.length s in
         let s = if len > maxlen then String.sub s 0 maxlen else s in
         begin match kind with
         | Ostr_bytes -> fprintf ppf "Bytes.of_string %S" s
         | Ostr_string -> print_out_string ppf s
         end;
         (if len > maxlen then
            fprintf ppf
              "... (* string length %d; truncated *)" len
         )
          with
          Invalid_argument _ (* "String.create" *)-> fprintf ppf "<huge string>"
        end
    | Oval_list tl ->
        fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ";") tl
    | Oval_array tl ->
        fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl
    | Oval_constr (name, []) -> print_ident ppf name
    | Oval_variant (name, None) -> fprintf ppf "`%s" name
    | Oval_stuff s -> pp_print_string ppf s
    | Oval_record fel ->
        fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel
    | Oval_ellipsis -> raise Ellipsis
    | Oval_printer f -> f ppf
    | Oval_tuple tree_list ->
        fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list
    | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree
  and print_fields first ppf =
    function
      [] -> ()
    | (name, tree) :: fields ->
        if not first then fprintf ppf ";@ ";
        fprintf ppf "@[<1>%a@ =@ %a@]" print_ident name (cautious print_tree_1)
          tree;
        print_fields false ppf fields
  and print_tree_list print_item sep ppf tree_list =
    let rec print_list first ppf =
      function
        [] -> ()
      | tree :: tree_list ->
          if not first then fprintf ppf "%s@ " sep;
          print_item ppf tree;
          print_list false ppf tree_list
    in
    cautious (print_list true) ppf tree_list
  in
  cautious print_tree_1 ppf tree

let out_value = ref print_out_value

(* Types *)

let rec print_list_init pr sep ppf =
  function
    [] -> ()
  | a :: l -> sep ppf; pr ppf a; print_list_init pr sep ppf l

let rec print_list pr sep ppf =
  function
    [] -> ()
  | [a] -> pr ppf a
  | a :: l -> pr ppf a; sep ppf; print_list pr sep ppf l

let pr_present =
  print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ")

let pr_vars =
  print_list (fun ppf s -> fprintf ppf "'%s" s) (fun ppf -> fprintf ppf "@ ")

let rec print_out_type ppf =
  function
  | Otyp_alias (ty, s) ->
      fprintf ppf "@[%a@ as '%s@]" print_out_type ty s
  | Otyp_poly (sl, ty) ->
      fprintf ppf "@[<hov 2>%a.@ %a@]"
        pr_vars sl
        print_out_type ty
  | ty ->
      print_out_type_1 ppf ty

and print_out_type_1 ppf =
  function
    Otyp_arrow (lab, ty1, ty2) ->
      pp_open_box ppf 0;
      if lab <> "" then (pp_print_string ppf lab; pp_print_char ppf ':');
      print_out_type_2 ppf ty1;
      pp_print_string ppf " ->";
      pp_print_space ppf ();
      print_out_type_1 ppf ty2;
      pp_close_box ppf ()
  | ty -> print_out_type_2 ppf ty
and print_out_type_2 ppf =
  function
    Otyp_tuple tyl ->
      fprintf ppf "@[<0>%a@]" (print_typlist print_simple_out_type " *") tyl
  | ty -> print_simple_out_type ppf ty
and print_simple_out_type ppf =
  function
    Otyp_class (ng, id, tyl) ->
      fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "")
        print_ident id
         
  | Otyp_constr ( (Oide_dot (((Oide_dot (Oide_ident "Js", "Internal"))| (Oide_ident "Js_internal")),
                             ("fn" | "meth" as name )) as id) ,
                 ([Otyp_variant(_,Ovar_fields [ variant, _, tys], _,_); result] as tyl))
    ->
      (* Otyp_arrow*)
      let make tys result =
        if tys = [] then
          Otyp_arrow ("", Otyp_constr (Oide_ident "unit", []),result)
        else
            match tys with
          | [ Otyp_tuple tys as single] -> 
              if variant = "Arity_1" then
                Otyp_arrow ("", single, result)
              else 
                List.fold_right (fun x acc  -> Otyp_arrow("",x,acc) ) tys result
          | [single] ->
              Otyp_arrow ("", single, result)
          | _ -> 
              raise_notrace Not_found
      in
      begin match (make tys result) with
      | exception _ ->
          begin 
            pp_open_box ppf 0;
            print_typargs ppf tyl;
            print_ident ppf id;
            pp_close_box ppf ()
          end
      | res ->
          begin match name  with
          | "fn" -> 
              fprintf ppf "@[<0>(%a@ [@bs])@]" print_out_type_1 res
          | "meth" ->
              fprintf ppf "@[<0>(%a@ [@bs.meth])@]" print_out_type_1 res
          | _ -> assert false 
          end
      end
  | Otyp_constr ((Oide_dot ((Oide_dot (Oide_ident "Js", "Internal") | (Oide_ident "Js_internal")), "meth_callback" ) as id) ,
                 ([Otyp_variant(_,Ovar_fields [ variant, _, tys], _,_); result] as tyl))
    ->
      let make tys result =
          match tys with
          | [ Otyp_tuple tys as single ] -> 
              if variant = "Arity_1" then Otyp_arrow ("", single, result)
              else 
                List.fold_right (fun x acc  -> Otyp_arrow("",x,acc) ) tys result
          | [single] ->
              Otyp_arrow ("", single, result)
          | _ -> 
              raise_notrace Not_found
      in
      begin match (make tys result) with
      | exception _ ->
          begin 
            pp_open_box ppf 0;
            print_typargs ppf tyl;
            print_ident ppf id;
            pp_close_box ppf ()
          end
      | res ->
          fprintf ppf "@[<0>(%a@ [@bs.this])@]" print_out_type_1 res

      end
        
  | Otyp_constr (id, tyl) ->
      pp_open_box ppf 0;
      print_typargs ppf tyl;
      print_ident ppf id;
      pp_close_box ppf ()
  | Otyp_object (fields, rest) ->
      fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
  | Otyp_stuff s -> pp_print_string ppf s
  | Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s
  | Otyp_variant (non_gen, row_fields, closed, tags) ->
      let print_present ppf =
        function
          None | Some [] -> ()
        | Some l -> fprintf ppf "@;<1 -2>> @[<hov>%a@]" pr_present l
      in
      let print_fields ppf =
        function
          Ovar_fields fields ->
            print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ")
              ppf fields
        | Ovar_typ typ ->
           print_simple_out_type ppf typ
      in
      fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a ]@]" (if non_gen then "_" else "")
        (if closed then if tags = None then " " else "< "
         else if tags = None then "> " else "? ")
        print_fields row_fields
        print_present tags
  | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty ->
      pp_open_box ppf 1;
      pp_print_char ppf '(';
      print_out_type ppf ty;
      pp_print_char ppf ')';
      pp_close_box ppf ()
  | Otyp_abstract | Otyp_open
  | Otyp_sum _ | Otyp_manifest (_, _) -> ()
  | Otyp_record lbls -> print_record_decl ppf lbls
  | Otyp_module (p, n, tyl) ->
      fprintf ppf "@[<1>(module %s" p;
      let first = ref true in
      List.iter2
        (fun s t ->
          let sep = if !first then (first := false; "with") else "and" in
          fprintf ppf " %s type %s = %a" sep s print_out_type t
        )
        n tyl;
      fprintf ppf ")@]"
  | Otyp_attribute (t, attr) ->
      fprintf ppf "@[<1>(%a [@@%s])@]" print_out_type t attr.oattr_name
and print_record_decl ppf lbls =
  fprintf ppf "{%a@;<1 -2>}"
    (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls
and print_fields rest ppf =
  function
    [] ->
      begin match rest with
        Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "")
      | None -> ()
      end
  | [s, t] ->
      fprintf ppf "%s : %a" s print_out_type t;
      begin match rest with
        Some _ -> fprintf ppf ";@ "
      | None -> ()
      end;
      print_fields rest ppf []
  | (s, t) :: l ->
      fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l
and print_row_field ppf (l, opt_amp, tyl) =
  let pr_of ppf =
    if opt_amp then fprintf ppf " of@ &@ "
    else if tyl <> [] then fprintf ppf " of@ "
    else fprintf ppf ""
  in
  fprintf ppf "@[<hv 2>`%s%t%a@]" l pr_of (print_typlist print_out_type " &")
    tyl
and print_typlist print_elem sep ppf =
  function
    [] -> ()
  | [ty] -> print_elem ppf ty
  | ty :: tyl ->
      print_elem ppf ty;
      pp_print_string ppf sep;
      pp_print_space ppf ();
      print_typlist print_elem sep ppf tyl
and print_typargs ppf =
  function
    [] -> ()
  | [ty1] -> print_simple_out_type ppf ty1; pp_print_space ppf ()
  | tyl ->
      pp_open_box ppf 1;
      pp_print_char ppf '(';
      print_typlist print_out_type "," ppf tyl;
      pp_print_char ppf ')';
      pp_close_box ppf ();
      pp_print_space ppf ()
and print_out_label ppf (name, mut, arg) =
  fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name
    print_out_type arg

let out_type = ref print_out_type

(* Class types *)

let type_parameter ppf (ty, (co, cn)) =
  fprintf ppf "%s%s"
    (if not cn then "+" else if not co then "-" else "")
    (if ty = "_" then ty else "'"^ty)

let print_out_class_params ppf =
  function
    [] -> ()
  | tyl ->
      fprintf ppf "@[<1>[%a]@]@ "
        (print_list type_parameter (fun ppf -> fprintf ppf ", "))
        tyl

let rec print_out_class_type ppf =
  function
    Octy_constr (id, tyl) ->
      let pr_tyl ppf =
        function
          [] -> ()
        | tyl ->
            fprintf ppf "@[<1>[%a]@]@ " (print_typlist !out_type ",") tyl
      in
      fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id
  | Octy_arrow (lab, ty, cty) ->
      fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "")
        print_out_type_2 ty print_out_class_type cty
  | Octy_signature (self_ty, csil) ->
      let pr_param ppf =
        function
          Some ty -> fprintf ppf "@ @[(%a)@]" !out_type ty
        | None -> ()
      in
      fprintf ppf "@[<hv 2>@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty
        (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ "))
        csil
and print_out_class_sig_item ppf =
  function
    Ocsg_constraint (ty1, ty2) ->
      fprintf ppf "@[<2>constraint %a =@ %a@]" !out_type ty1
        !out_type ty2
  | Ocsg_method (name, priv, virt, ty) ->
      fprintf ppf "@[<2>method %s%s%s :@ %a@]"
        (if priv then "private " else "") (if virt then "virtual " else "")
        name !out_type ty
  | Ocsg_value (name, mut, vr, ty) ->
      fprintf ppf "@[<2>val %s%s%s :@ %a@]"
        (if mut then "mutable " else "")
        (if vr then "virtual " else "")
        name !out_type ty

let out_class_type = ref print_out_class_type

(* Signature *)

let out_module_type = ref (fun _ -> failwith "Oprint.out_module_type")
let out_sig_item = ref (fun _ -> failwith "Oprint.out_sig_item")
let out_signature = ref (fun _ -> failwith "Oprint.out_signature")
let out_type_extension = ref (fun _ -> failwith "Oprint.out_type_extension")

let rec print_out_functor funct ppf =
  function
    Omty_functor (_, None, mty_res) ->
      if funct then fprintf ppf "() %a" (print_out_functor true) mty_res
      else fprintf ppf "functor@ () %a" (print_out_functor true) mty_res
  | Omty_functor (name, Some mty_arg, mty_res) -> begin
      match name, funct with
      | "_", true ->
          fprintf ppf "->@ %a ->@ %a"
            print_out_module_type mty_arg (print_out_functor false) mty_res
      | "_", false ->
          fprintf ppf "%a ->@ %a"
            print_out_module_type mty_arg (print_out_functor false) mty_res
      | name, true ->
          fprintf ppf "(%s : %a) %a" name
            print_out_module_type mty_arg (print_out_functor true) mty_res
      | name, false ->
            fprintf ppf "functor@ (%s : %a) %a" name
              print_out_module_type mty_arg (print_out_functor true) mty_res
    end
  | m ->
      if funct then fprintf ppf "->@ %a" print_out_module_type m
      else print_out_module_type ppf m

and print_out_module_type ppf =
  function
    Omty_abstract -> ()
  | Omty_functor _ as t ->
      fprintf ppf "@[<2>%a@]" (print_out_functor false) t
  | Omty_ident id -> fprintf ppf "%a" print_ident id
  | Omty_signature sg ->
      fprintf ppf "@[<hv 2>sig@ %a@;<1 -2>end@]" !out_signature sg
  | Omty_alias id -> fprintf ppf "(module %a)" print_ident id
and print_out_signature ppf =
  function
    [] -> ()
  | [item] -> !out_sig_item ppf item
  | Osig_typext(ext, Oext_first) :: items ->
      (* Gather together the extension constructors *)
      let rec gather_extensions acc items =
        match items with
            Osig_typext(ext, Oext_next) :: items ->
              gather_extensions
                ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc)
                items
          | _ -> (List.rev acc, items)
      in
      let exts, items =
        gather_extensions
          [(ext.oext_name, ext.oext_args, ext.oext_ret_type)]
          items
      in
      let te =
        { otyext_name = ext.oext_type_name;
          otyext_params = ext.oext_type_params;
          otyext_constructors = exts;
          otyext_private = ext.oext_private }
      in
        fprintf ppf "%a@ %a" !out_type_extension te print_out_signature items
  | item :: items ->
      fprintf ppf "%a@ %a" !out_sig_item item print_out_signature items
and print_out_sig_item ppf =
  function
    Osig_class (vir_flag, name, params, clt, rs) ->
      fprintf ppf "@[<2>%s%s@ %a%s@ :@ %a@]"
        (if rs = Orec_next then "and" else "class")
        (if vir_flag then " virtual" else "") print_out_class_params params
        name !out_class_type clt
  | Osig_class_type (vir_flag, name, params, clt, rs) ->
      fprintf ppf "@[<2>%s%s@ %a%s@ =@ %a@]"
        (if rs = Orec_next then "and" else "class type")
        (if vir_flag then " virtual" else "") print_out_class_params params
        name !out_class_type clt
  | Osig_typext (ext, Oext_exception) ->
      fprintf ppf "@[<2>exception %a@]"
        print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type)
  | Osig_typext (ext, _es) ->
      print_out_extension_constructor ppf ext
  | Osig_modtype (name, Omty_abstract) ->
      fprintf ppf "@[<2>module type %s@]" name
  | Osig_modtype (name, mty) ->
      fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty
  | Osig_module (name, Omty_alias id, _) ->
      fprintf ppf "@[<2>module %s =@ %a@]" name print_ident id
  | Osig_module (name, mty, rs) ->
      fprintf ppf "@[<2>%s %s :@ %a@]"
        (match rs with Orec_not -> "module"
                     | Orec_first -> "module rec"
                     | Orec_next -> "and")
        name !out_module_type mty
  | Osig_type(td, rs) ->
        print_out_type_decl
          (match rs with
           | Orec_not   -> "type nonrec"
           | Orec_first -> "type"
           | Orec_next  -> "and")
          ppf td
  | Osig_value vd ->
      let kwd = if vd.oval_prims = [] then "val" else "external" in
      let pr_prims ppf =
        function
          [] -> ()
        | s :: sl ->
            fprintf ppf "@ = \"%s\"" s;
            List.iter (fun s ->
(* TODO: in general, we should print bs attributes, some attributes like
  bs.splice does need it *)

    let len = String.length s in
    if len >= 3 && s.[0] = 'B' && s.[1] = 'S' && s.[2] = ':' then
      fprintf ppf "@ \"BS-EXTERNAL\"" 
    else
      fprintf ppf "@ \"%s\"" s
                                  
              ) sl
      in
      fprintf ppf "@[<2>%s %a :@ %a%a%a@]" kwd value_ident vd.oval_name
        !out_type vd.oval_type pr_prims vd.oval_prims
        (fun ppf -> List.iter (fun a -> fprintf ppf "@ [@@@@%s]" a.oattr_name))
        vd.oval_attributes
  | Osig_ellipsis ->
      fprintf ppf "..."

and print_out_type_decl kwd ppf td =
  let print_constraints ppf =
    List.iter
      (fun (ty1, ty2) ->
         fprintf ppf "@ @[<2>constraint %a =@ %a@]" !out_type ty1
           !out_type ty2)
      td.otype_cstrs
  in
  let type_defined ppf =
    match td.otype_params with
      [] -> pp_print_string ppf td.otype_name
    | [param] -> fprintf ppf "@[%a@ %s@]" type_parameter param td.otype_name
    | _ ->
        fprintf ppf "@[(@[%a)@]@ %s@]"
          (print_list type_parameter (fun ppf -> fprintf ppf ",@ "))
          td.otype_params
          td.otype_name
  in
  let print_manifest ppf =
    function
      Otyp_manifest (ty, _) -> fprintf ppf " =@ %a" !out_type ty
    | _ -> ()
  in
  let print_name_params ppf =
    fprintf ppf "%s %t%a" kwd type_defined print_manifest td.otype_type
  in
  let ty =
    match td.otype_type with
      Otyp_manifest (_, ty) -> ty
    | _ -> td.otype_type
  in
  let print_private ppf = function
    Asttypes.Private -> fprintf ppf " private"
  | Asttypes.Public -> ()
  in
  let print_immediate ppf =
    if td.otype_immediate then fprintf ppf " [%@%@immediate]" else ()
  in
  let print_unboxed ppf =
    if td.otype_unboxed then fprintf ppf " [%@%@unboxed]" else ()
  in
  let print_out_tkind ppf = function
  | Otyp_abstract -> ()
  | Otyp_record lbls ->
      fprintf ppf " =%a %a"
        print_private td.otype_private
        print_record_decl lbls
  | Otyp_sum constrs ->
      fprintf ppf " =%a@;<1 2>%a"
        print_private td.otype_private
        (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs
  | Otyp_open ->
      fprintf ppf " =%a .."
        print_private td.otype_private
  | ty ->
      fprintf ppf " =%a@;<1 2>%a"
        print_private td.otype_private
        !out_type ty
  in
  fprintf ppf "@[<2>@[<hv 2>%t%a@]%t%t%t@]"
    print_name_params
    print_out_tkind ty
    print_constraints
    print_immediate
    print_unboxed

and print_out_constr ppf (name, tyl,ret_type_opt) =
  let name =
    match name with
    | "::" -> "(::)"   (* #7200 *)
    | s -> s
  in
  match ret_type_opt with
  | None ->
      begin match tyl with
      | [] ->
          pp_print_string ppf name
      | _ ->
          fprintf ppf "@[<2>%s of@ %a@]" name
            (print_typlist print_simple_out_type " *") tyl
      end
  | Some ret_type ->
      begin match tyl with
      | [] ->
          fprintf ppf "@[<2>%s :@ %a@]" name print_simple_out_type  ret_type
      | _ ->
          fprintf ppf "@[<2>%s :@ %a -> %a@]" name
            (print_typlist print_simple_out_type " *")
            tyl print_simple_out_type ret_type
      end

and print_out_extension_constructor ppf ext =
  let print_extended_type ppf =
    let print_type_parameter ppf ty =
      fprintf ppf "%s"
        (if ty = "_" then ty else "'"^ty)
    in
      match ext.oext_type_params with
        [] -> fprintf ppf "%s" ext.oext_type_name
      | [ty_param] ->
        fprintf ppf "@[%a@ %s@]"
          print_type_parameter
          ty_param
          ext.oext_type_name
      | _ ->
        fprintf ppf "@[(@[%a)@]@ %s@]"
          (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ "))
          ext.oext_type_params
          ext.oext_type_name
  in
  fprintf ppf "@[<hv 2>type %t +=%s@;<1 2>%a@]"
    print_extended_type
    (if ext.oext_private = Asttypes.Private then " private" else "")
    print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type)

and print_out_type_extension ppf te =
  let print_extended_type ppf =
    let print_type_parameter ppf ty =
      fprintf ppf "%s"
        (if ty = "_" then ty else "'"^ty)
    in
    match te.otyext_params with
      [] -> fprintf ppf "%s" te.otyext_name
    | [param] ->
      fprintf ppf "@[%a@ %s@]"
        print_type_parameter param
        te.otyext_name
    | _ ->
        fprintf ppf "@[(@[%a)@]@ %s@]"
          (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ "))
          te.otyext_params
          te.otyext_name
  in
  fprintf ppf "@[<hv 2>type %t +=%s@;<1 2>%a@]"
    print_extended_type
    (if te.otyext_private = Asttypes.Private then " private" else "")
    (print_list print_out_constr (fun ppf -> fprintf ppf "@ | "))
    te.otyext_constructors

let _ = out_module_type := print_out_module_type
let _ = out_signature := print_out_signature
let _ = out_sig_item := print_out_sig_item
let _ = out_type_extension := print_out_type_extension

(* Phrases *)

let print_out_exception ppf exn outv =
  match exn with
    Sys.Break -> fprintf ppf "Interrupted.@."
  | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@."
  | Stack_overflow ->
      fprintf ppf "Stack overflow during evaluation (looping recursion?).@."
  | _ -> fprintf ppf "@[Exception:@ %a.@]@." !out_value outv

let rec print_items ppf =
  function
    [] -> ()
  | (Osig_typext(ext, Oext_first), None) :: items ->
      (* Gather together extension constructors *)
      let rec gather_extensions acc items =
        match items with
            (Osig_typext(ext, Oext_next), None) :: items ->
              gather_extensions
                ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc)
                items
          | _ -> (List.rev acc, items)
      in
      let exts, items =
        gather_extensions
          [(ext.oext_name, ext.oext_args, ext.oext_ret_type)]
          items
      in
      let te =
        { otyext_name = ext.oext_type_name;
          otyext_params = ext.oext_type_params;
          otyext_constructors = exts;
          otyext_private = ext.oext_private }
      in
        fprintf ppf "@[%a@]" !out_type_extension te;
        if items <> [] then fprintf ppf "@ %a" print_items items
  | (tree, valopt) :: items ->
      begin match valopt with
        Some v ->
          fprintf ppf "@[<2>%a =@ %a@]" !out_sig_item tree
            !out_value v
      | None -> fprintf ppf "@[%a@]" !out_sig_item tree
      end;
      if items <> [] then fprintf ppf "@ %a" print_items items

let print_out_phrase ppf =
  function
    Ophr_eval (outv, ty) ->
      fprintf ppf "@[- : %a@ =@ %a@]@." !out_type ty !out_value outv
  | Ophr_signature [] -> ()
  | Ophr_signature items -> fprintf ppf "@[<v>%a@]@." print_items items
  | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv

let out_phrase = ref print_out_phrase

end
module Ext_buffer : sig 
#1 "ext_buffer.mli"
(***********************************************************************)
(*                                                                     *)
(*                                OCaml                                *)
(*                                                                     *)
(*  Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt   *)
(*                                                                     *)
(*  Copyright 1999 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the GNU Library General Public License, with    *)
(*  the special exception on linking described in file ../LICENSE.     *)
(*                                                                     *)
(***********************************************************************)

(** Extensible buffers.

   This module implements buffers that automatically expand
   as necessary.  It provides accumulative concatenation of strings
   in quasi-linear time (instead of quadratic time when strings are
   concatenated pairwise).
*)

(* BuckleScript customization: customized for efficient digest *)

type t
(** The abstract type of buffers. *)

val create : int -> t
(** [create n] returns a fresh buffer, initially empty.
   The [n] parameter is the initial size of the internal byte sequence
   that holds the buffer contents. That byte sequence is automatically
   reallocated when more than [n] characters are stored in the buffer,
   but shrinks back to [n] characters when [reset] is called.
   For best performance, [n] should be of the same order of magnitude
   as the number of characters that are expected to be stored in
   the buffer (for instance, 80 for a buffer that holds one output
   line).  Nothing bad will happen if the buffer grows beyond that
   limit, however. In doubt, take [n = 16] for instance.
   If [n] is not between 1 and {!Sys.max_string_length}, it will
   be clipped to that interval. *)

val contents : t -> string
(** Return a copy of the current contents of the buffer.
    The buffer itself is unchanged. *)

val length : t -> int
(** Return the number of characters currently contained in the buffer. *)

val is_empty : t -> bool

val clear : t -> unit
(** Empty the buffer. *)


val add_char : t -> char -> unit
(** [add_char b c] appends the character [c] at the end of the buffer [b]. *)

val add_string : t -> string -> unit
(** [add_string b s] appends the string [s] at the end of the buffer [b]. *)

val add_bytes : t -> bytes -> unit
(** [add_string b s] appends the string [s] at the end of the buffer [b].
    @since 4.02 *)

val add_substring : t -> string -> int -> int -> unit
(** [add_substring b s ofs len] takes [len] characters from offset
   [ofs] in string [s] and appends them at the end of the buffer [b]. *)

val add_subbytes : t -> bytes -> int -> int -> unit
(** [add_substring b s ofs len] takes [len] characters from offset
    [ofs] in byte sequence [s] and appends them at the end of the buffer [b].
    @since 4.02 *)

val add_buffer : t -> t -> unit
(** [add_buffer b1 b2] appends the current contents of buffer [b2]
   at the end of buffer [b1].  [b2] is not modified. *)    

val add_channel : t -> in_channel -> int -> unit
(** [add_channel b ic n] reads exactly [n] character from the
   input channel [ic] and stores them at the end of buffer [b].
   Raise [End_of_file] if the channel contains fewer than [n]
   characters. *)

val output_buffer : out_channel -> t -> unit
(** [output_buffer oc b] writes the current contents of buffer [b]
   on the output channel [oc]. *)   

val digest : t -> Digest.t   

val not_equal : 
  t -> 
  string -> 
  bool 

val add_int_1 :    
   t -> int -> unit 

val add_int_2 :    
   t -> int -> unit 

val add_int_3 :    
   t -> int -> unit 

val add_int_4 :    
   t -> int -> unit 

val add_string_char :    
   t -> 
   string ->
   char -> 
   unit

val add_char_string :    
   t -> 
   char -> 
   string -> 
   unit
end = struct
#1 "ext_buffer.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*    Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt    *)
(*                                                                        *)
(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Extensible buffers *)

type t =
 {mutable buffer : bytes;
  mutable position : int;
  mutable length : int;
  initial_buffer : bytes}

let create n =
 let n = if n < 1 then 1 else n in
 
 let n = if n > Sys.max_string_length then Sys.max_string_length else n in
 
 let s = Bytes.create n in
 {buffer = s; position = 0; length = n; initial_buffer = s}

let contents b = Bytes.sub_string b.buffer 0 b.position
let to_bytes b = Bytes.sub b.buffer 0 b.position 

let sub b ofs len =
  if ofs < 0 || len < 0 || ofs > b.position - len
  then invalid_arg "Ext_buffer.sub"
  else Bytes.sub_string b.buffer ofs len


let blit src srcoff dst dstoff len =
  if len < 0 || srcoff < 0 || srcoff > src.position - len
             || dstoff < 0 || dstoff > (Bytes.length dst) - len
  then invalid_arg "Ext_buffer.blit"
  else
    Bytes.unsafe_blit src.buffer srcoff dst dstoff len

let length b = b.position
let is_empty b = b.position = 0
let clear b = b.position <- 0

let reset b =
  b.position <- 0; b.buffer <- b.initial_buffer;
  b.length <- Bytes.length b.buffer

let resize b more =
  let len = b.length in
  let new_len = ref len in
  while b.position + more > !new_len do new_len := 2 * !new_len done;
   
  if !new_len > Sys.max_string_length then begin
    if b.position + more <= Sys.max_string_length
    then new_len := Sys.max_string_length
    else failwith "Ext_buffer.add: cannot grow buffer"
  end;
  
  let new_buffer = Bytes.create !new_len in
  (* PR#6148: let's keep using [blit] rather than [unsafe_blit] in
     this tricky function that is slow anyway. *)
  Bytes.blit b.buffer 0 new_buffer 0 b.position;
  b.buffer <- new_buffer;
  b.length <- !new_len  

let add_char b c =
  let pos = b.position in
  if pos >= b.length then resize b 1;
  Bytes.unsafe_set b.buffer pos c;
  b.position <- pos + 1  

let add_substring b s offset len =
  if offset < 0 || len < 0 || offset > String.length s - len
  then invalid_arg "Ext_buffer.add_substring/add_subbytes";
  let new_position = b.position + len in
  if new_position > b.length then resize b len;
  Bytes.blit_string s offset b.buffer b.position len;
  b.position <- new_position  


let add_subbytes b s offset len =
  add_substring b (Bytes.unsafe_to_string s) offset len

let add_string b s =
  let len = String.length s in
  let new_position = b.position + len in
  if new_position > b.length then resize b len;
  Bytes.blit_string s 0 b.buffer b.position len;
  b.position <- new_position  

(* TODO: micro-optimzie *)
let add_string_char b s c =
  let s_len = String.length s in
  let len = s_len + 1 in 
  let new_position = b.position + len in
  if new_position > b.length then resize b len;
  let b_buffer = b.buffer in 
  Bytes.blit_string s 0 b_buffer b.position s_len;
  Bytes.unsafe_set b_buffer (new_position - 1) c;
  b.position <- new_position 

let add_char_string b c s  =
  let s_len = String.length s in
  let len = s_len + 1 in 
  let new_position = b.position + len in
  if new_position > b.length then resize b len;
  let b_buffer = b.buffer in 
  let b_position = b.position in 
  Bytes.unsafe_set b_buffer b_position c ; 
  Bytes.blit_string s 0 b_buffer (b_position + 1) s_len;
  b.position <- new_position


let add_bytes b s = add_string b (Bytes.unsafe_to_string s)

let add_buffer b bs =
  add_subbytes b bs.buffer 0 bs.position

let add_channel b ic len =
  if len < 0 

    || len > Sys.max_string_length 

    then   (* PR#5004 *)
    invalid_arg "Ext_buffer.add_channel";
  if b.position + len > b.length then resize b len;
  really_input ic b.buffer b.position len;
  b.position <- b.position + len

let output_buffer oc b =
  output oc b.buffer 0 b.position  

external unsafe_string: bytes -> int -> int -> Digest.t = "caml_md5_string"

let digest b = 
  unsafe_string 
  b.buffer 0 b.position    

let rec not_equal_aux (b : bytes) (s : string) i len = 
    if i >= len then false
    else 
      (Bytes.unsafe_get b i 
      <>
      String.unsafe_get s i )
      || not_equal_aux b s (i + 1) len 

(** avoid a large copy *)
let not_equal  (b : t) (s : string) = 
  let b_len = b.position in 
  let s_len = String.length s in 
  b_len <> s_len 
  || not_equal_aux b.buffer s 0 s_len


(**
  It could be one byte, two bytes, three bytes and four bytes 
  TODO: inline for better performance
*)
let add_int_1 (b : t ) (x : int ) = 
  let c = (Char.unsafe_chr (x land 0xff)) in 
  let pos = b.position in
  if pos >= b.length then resize b 1;
  Bytes.unsafe_set b.buffer pos c;
  b.position <- pos + 1  
  
let add_int_2 (b : t ) (x : int ) = 
  let c1 = (Char.unsafe_chr (x land 0xff)) in 
  let c2 = (Char.unsafe_chr (x lsr 8 land 0xff)) in   
  let pos = b.position in
  if pos + 1 >= b.length then resize b 2;
  let b_buffer = b.buffer in 
  Bytes.unsafe_set b_buffer pos c1;
  Bytes.unsafe_set b_buffer (pos + 1) c2;
  b.position <- pos + 2

let add_int_3 (b : t ) (x : int ) = 
  let c1 = (Char.unsafe_chr (x land 0xff)) in 
  let c2 = (Char.unsafe_chr (x lsr 8 land 0xff)) in   
  let c3 = (Char.unsafe_chr (x lsr 16 land 0xff)) in
  let pos = b.position in
  if pos + 2 >= b.length then resize b 3;
  let b_buffer = b.buffer in 
  Bytes.unsafe_set b_buffer pos c1;
  Bytes.unsafe_set b_buffer (pos + 1) c2;
  Bytes.unsafe_set b_buffer (pos + 2) c3;
  b.position <- pos + 3


let add_int_4 (b : t ) (x : int ) = 
  let c1 = (Char.unsafe_chr (x land 0xff)) in 
  let c2 = (Char.unsafe_chr (x lsr 8 land 0xff)) in   
  let c3 = (Char.unsafe_chr (x lsr 16 land 0xff)) in
  let c4 = (Char.unsafe_chr (x lsr 24 land 0xff)) in
  let pos = b.position in
  if pos + 3 >= b.length then resize b 4;
  let b_buffer = b.buffer in 
  Bytes.unsafe_set b_buffer pos c1;
  Bytes.unsafe_set b_buffer (pos + 1) c2;
  Bytes.unsafe_set b_buffer (pos + 2) c3;
  Bytes.unsafe_set b_buffer (pos + 3) c4;
  b.position <- pos + 4




end
module Ext_char : sig 
#1 "ext_char.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






(** Extension to Standard char module, avoid locale sensitivity *)

val escaped : char -> string


val valid_hex : char -> bool

val is_lower_case : char -> bool

val uppercase_ascii : char -> char

val lowercase_ascii : char -> char
end = struct
#1 "ext_char.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)





(** {!Char.escaped} is locale sensitive in 4.02.3, fixed in the trunk,
    backport it here
 *)
 
let escaped = Char.escaped


let valid_hex x = 
    match x with 
    | '0' .. '9'
    | 'a' .. 'f'
    | 'A' .. 'F' -> true
    | _ -> false 



let is_lower_case c =
  (c >= 'a' && c <= 'z')
  || (c >= '\224' && c <= '\246')
  || (c >= '\248' && c <= '\254')    
let uppercase_ascii =

    Char.uppercase_ascii
      

let lowercase_ascii = 

    Char.lowercase_ascii
      

end
module Literals : sig 
#1 "literals.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






val js_array_ctor : string 
val js_type_number : string
val js_type_string : string
val js_type_object : string
val js_type_boolean : string
val js_undefined : string
val js_prop_length : string

val param : string
val partial_arg : string
val prim : string

(**temporary varaible used in {!Js_ast_util} *)
val tmp : string 

val create : string 
val runtime : string
val stdlib : string
val imul : string

val setter_suffix : string
val setter_suffix_len : int


val debugger : string
val raw_expr : string
val raw_stmt : string
val raw_function : string
val unsafe_downgrade : string
val fn_run : string
val method_run : string
val fn_method : string
val fn_mk : string

(** callback actually, not exposed to user yet *)
(* val js_fn_runmethod : string *)

val bs_deriving : string
val bs_deriving_dot : string
val bs_type : string

(** nodejs *)

val node_modules : string
val node_modules_length : int
val package_json : string
val bsconfig_json : string
val build_ninja : string

(* Name of the library file created for each external dependency. *)
val library_file : string

val suffix_a : string
val suffix_cmj : string
val suffix_cmo : string
val suffix_cma : string
val suffix_cmi : string
val suffix_cmx : string
val suffix_cmxa : string
val suffix_ml : string
val suffix_mlast : string 
val suffix_mlast_simple : string
val suffix_mliast : string
val suffix_reast : string
val suffix_reiast : string

val suffix_mliast_simple : string
val suffix_mlmap : string
val suffix_mll : string
val suffix_re : string
val suffix_rei : string 

val suffix_d : string
val suffix_js : string
val suffix_bs_js : string 
(* val suffix_re_js : string *)
val suffix_gen_js : string 
val suffix_gen_tsx: string

val suffix_tsx : string

val suffix_mli : string 
val suffix_cmt : string 
val suffix_cmti : string 

val commonjs : string 

val es6 : string 
val es6_global : string

val unused_attribute : string 
val dash_nostdlib : string

val reactjs_jsx_ppx_2_exe : string 
val reactjs_jsx_ppx_3_exe : string 

val native : string
val bytecode : string
val js : string

val node_sep : string 
val node_parent : string 
val node_current : string 
val gentype_import : string

val bsbuild_cache : string

val sourcedirs_meta : string
end = struct
#1 "literals.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)







let js_array_ctor = "Array"
let js_type_number = "number"
let js_type_string = "string"
let js_type_object = "object" 
let js_type_boolean = "boolean"
let js_undefined = "undefined"
let js_prop_length = "length"

let prim = "prim"
let param = "param"
let partial_arg = "partial_arg"
let tmp = "tmp"

let create = "create" (* {!Caml_exceptions.create}*)

let runtime = "runtime" (* runtime directory *)

let stdlib = "stdlib"

let imul = "imul" (* signed int32 mul *)

let setter_suffix = "#="
let setter_suffix_len = String.length setter_suffix

let debugger = "debugger"
let raw_expr = "raw_expr"
let raw_stmt = "raw_stmt"
let raw_function = "raw_function"
let unsafe_downgrade = "unsafe_downgrade"
let fn_run = "fn_run"
let method_run = "method_run"

let fn_method = "fn_method"
let fn_mk = "fn_mk"
(*let js_fn_runmethod = "js_fn_runmethod"*)

let bs_deriving = "bs.deriving"
let bs_deriving_dot = "bs.deriving."
let bs_type = "bs.type"


(** nodejs *)
let node_modules = "node_modules"
let node_modules_length = String.length "node_modules"
let package_json = "package.json"
let bsconfig_json = "bsconfig.json"
let build_ninja = "build.ninja"

(* Name of the library file created for each external dependency. *)
let library_file = "lib"

let suffix_a = ".a"
let suffix_cmj = ".cmj"
let suffix_cmo = ".cmo"
let suffix_cma = ".cma"
let suffix_cmi = ".cmi"
let suffix_cmx = ".cmx"
let suffix_cmxa = ".cmxa"
let suffix_mll = ".mll"
let suffix_ml = ".ml"
let suffix_mli = ".mli"
let suffix_re = ".re"
let suffix_rei = ".rei"
let suffix_mlmap = ".mlmap"

let suffix_cmt = ".cmt" 
let suffix_cmti = ".cmti" 
let suffix_mlast = ".mlast"
let suffix_mlast_simple = ".mlast_simple"
let suffix_mliast = ".mliast"
let suffix_reast = ".reast"
let suffix_reiast = ".reiast"
let suffix_mliast_simple = ".mliast_simple"
let suffix_d = ".d"
let suffix_js = ".js"
let suffix_bs_js = ".bs.js"
(* let suffix_re_js = ".re.js" *)
let suffix_gen_js = ".gen.js"
let suffix_gen_tsx = ".gen.tsx"
let suffix_tsx = ".tsx"

let commonjs = "commonjs" 

let es6 = "es6"
let es6_global = "es6-global"

let unused_attribute = "Unused attribute " 
let dash_nostdlib = "-nostdlib"

let reactjs_jsx_ppx_2_exe = "reactjs_jsx_ppx_2.exe"
let reactjs_jsx_ppx_3_exe  = "reactjs_jsx_ppx_3.exe"

let native = "native"
let bytecode = "bytecode"
let js = "js"



(** Used when produce node compatible paths *)
let node_sep = "/"
let node_parent = ".."
let node_current = "."

let gentype_import = "genType.import"

let bsbuild_cache = ".bsbuild"    

let sourcedirs_meta = ".sourcedirs.json"
end
module Ext_namespace : sig 
#1 "ext_namespace.mli"
(* Copyright (C) 2017- Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

(** [make ~ns:"Ns" "a" ]
    A typical example would return "a-Ns"
    Note the namespace comes from the output of [namespace_of_package_name]
*)
val make : 
  ?ns:string -> string -> string 

val try_split_module_name :
  string -> (string * string ) option



(* Note  we have to output uncapitalized file Name, 
   or at least be consistent, since by reading cmi file on Case insensitive OS, we don't really know it is `list.cmi` or `List.cmi`, so that `require (./list.js)` or `require(./List.js)`
   relevant issues: #1609, #913  

   #1933 when removing ns suffix, don't pass the bound
   of basename
*)
val change_ext_ns_suffix :  
  string -> 
  string ->
  string

type file_kind = 
  | Upper_js
  | Upper_bs
  | Little_js 
  | Little_bs 
  (** [js_name_of_modulename ~little A-Ns]
  *)
val js_name_of_modulename : 
  string -> 
  file_kind -> 
  string

(* TODO handle cases like 
   '@angular/core'
   its directory structure is like 
   {[
     @angular
     |-------- core
   ]}
*)
val is_valid_npm_package_name : string -> bool 

val namespace_of_package_name : string -> string

end = struct
#1 "ext_namespace.ml"

(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


(* Note the build system should check the validity of filenames
   espeically, it should not contain '-'
*)
let ns_sep_char = '-'
let ns_sep = "-"

let make ?ns cunit  = 
  match ns with 
  | None -> cunit
  | Some ns -> cunit ^ ns_sep ^ ns


let rec rindex_rec s i  =
  if i < 0 then i else
    let char = String.unsafe_get s i in
    if Ext_filename.is_dir_sep char  then -1 
    else if char = ns_sep_char then i 
    else
      rindex_rec s (i - 1) 

let change_ext_ns_suffix name ext =
  let i = rindex_rec name (String.length name - 1)  in 
  if i < 0 then name ^ ext
  else String.sub name 0 i ^ ext (* FIXME: micro-optimizaiton*)

let try_split_module_name name = 
  let len = String.length name in 
  let i = rindex_rec name (len - 1)  in 
  if i < 0 then None 
  else 
    Some (String.sub name (i+1) (len - i - 1),
          String.sub name 0 i )
type file_kind = 
  | Upper_js
  | Upper_bs
  | Little_js 
  | Little_bs


  
(* let js_name_of_basename bs_suffix s =   
  change_ext_ns_suffix  s 
  (if bs_suffix then Literals.suffix_bs_js else  Literals.suffix_js ) *)

let js_name_of_modulename s little = 
  match little with 
  | Little_js -> 
    change_ext_ns_suffix (Ext_string.uncapitalize_ascii s)  Literals.suffix_js
  | Little_bs -> 
    change_ext_ns_suffix (Ext_string.uncapitalize_ascii s)  Literals.suffix_bs_js
  | Upper_js ->
    change_ext_ns_suffix s  Literals.suffix_js
  | Upper_bs -> 
    change_ext_ns_suffix s  Literals.suffix_bs_js

(* https://docs.npmjs.com/files/package.json 
   Some rules:
   The name must be less than or equal to 214 characters. This includes the scope for scoped packages.
   The name can't start with a dot or an underscore.
   New packages must not have uppercase letters in the name.
   The name ends up being part of a URL, an argument on the command line, and a folder name. Therefore, the name can't contain any non-URL-safe characters.
*)
let is_valid_npm_package_name (s : string) = 
  let len = String.length s in 
  len <= 214 && (* magic number forced by npm *)
  len > 0 &&
  match String.unsafe_get s 0 with 
  | 'a' .. 'z' | '@' -> 
    Ext_string.for_all_from s 1 
      (fun x -> 
         match x with 
         |  'a'..'z' | '0'..'9' | '_' | '-' -> true
         | _ -> false )
  | _ -> false 


let namespace_of_package_name (s : string) : string = 
  let len = String.length s in 
  let buf = Ext_buffer.create len in 
  let add capital ch = 
    Ext_buffer.add_char buf 
      (if capital then 
         (Ext_char.uppercase_ascii ch)
       else ch) in    
  let rec aux capital off len =     
    if off >= len then ()
    else 
      let ch = String.unsafe_get s off in
      match ch with 
      | 'a' .. 'z' 
      | 'A' .. 'Z' 
      | '0' .. '9'
        ->
        add capital ch ; 
        aux false (off + 1) len 
      | '/'
      | '-' -> 
        aux true (off + 1) len 
      | _ -> aux capital (off+1) len
  in 
  aux true 0 len ;
  Ext_buffer.contents buf 

end
module Outcome_printer_ns : sig 
#1 "outcome_printer_ns.mli"
(* Copyright (C) 2017 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

(** This funciton is used to 
    reverse namespace printing to 
    avoid namespace leaking
*) 
 val out_ident :
  Format.formatter -> string -> unit 
end = struct
#1 "outcome_printer_ns.ml"
(* Copyright (C) 2017 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

let ps = Format.pp_print_string

let out_ident ppf s =
  ps ppf (
    match s with     
    | "Js_null" 
      ->   "Js.Null"
    | "Js_undefined" 
      ->  "Js.Undefined"
    | "Js_null_undefined"
      ->  "Js.Nullable"
    | "Js_exn"
      -> "Js.Exn"
    | "Js_array"
      -> "Js.Array"
    | "Js_string"
      -> "Js.String"
    | "Js_re" 
      -> "Js.Re"
    | "Js_promise"
      -> "Js.Promise"
    | "Js_date"
      -> "Js.Date"
    | "Js_dict"
      -> "Js.Dict"
    | "Js_global"
      -> "Js.Global"
    | "Js_json"
      -> "Js.Json"
    | "Js_math"
      -> "Js.Math"
    | "Js_obj"
      -> "Js.Obj"
    | "Js_typed_array"
      -> "Js.Typed_array"
    | "Js_types"
      -> "Js.Types"
    | "Js_float"
      -> "Js.Float"
    | "Js_int"
      -> "Js.Int"
    | "Js_option"
      -> "Js.Option"
    | "Js_result"
      ->  "Js.Result"
    |"Js_list"
      -> "Js.List"
    | "Js_vector"
      -> "Js.Vector"
(* Belt_libs  *)        
    | "Belt_Id" -> "Belt.Id"
    | "Belt_Array" -> "Belt.Array"

    | "Belt_SortArray" -> "Belt.SortArray"
    | "Belt_SortArrayInt" -> "Belt.SortArray.Int"
    | "Belt_SortArrayString" -> "Belt.SortArray.String"
      
    | "Belt_MutableQueue" -> "Belt.MutableQueue"
    | "Belt_MutableStack" -> "Belt.MutableStack"      
    | "Belt_List" -> "Belt.List"        
    | "Belt_Range" -> "Belt.Range"
      
    | "Belt_Set" -> "Belt.Set"
    | "Belt_SetInt" -> "Belt.Set.Int"
    | "Belt_SetString" -> "Belt.Set.String"

    | "Belt_Map" -> "Belt.Map"
    | "Belt_MapInt" -> "Belt.Map.Int"
    | "Belt_MapString" -> "Belt.Map.String"

    | "Belt_Option" -> "Belt.Option"

    | "Belt_MutableSet" -> "Belt.MutableSet"
    | "Belt_MutableSetInt" -> "Belt.MutableSet.Int"
    | "Belt_MutableSetString" -> "Belt.MutableSet.String"

    | "Belt_MutableMap" -> "Belt.MutableMap"
    | "Belt_MutableMapInt" -> "Belt.MutableMap.Int"
    | "Belt_MutableMapString" -> "Belt.MutableMap.String"
      
    | "Belt_HashSet" -> "Belt.HashSet"
    | "Belt_HashSetInt" -> "Belt.HashSet.Int"
    | "Belt_HashSetString" -> "Belt.HashSet.String"
      
    | "Belt_HashMap" -> "Belt.HashMap"
    | "Belt_HashMapString" -> "Belt.HashMap.String"
    | "Belt_HashMapInt" -> "Belt.HashMap.Int"
    | "Belt_Debug" -> "Belt.Debug"
    | s -> 
      (match Ext_namespace.try_split_module_name s with 
       | None -> s 
       | Some (ns,m)
         -> ns ^ "."^ m
      )
  )



end
module Bs_conditional_initial : sig 
#1 "bs_conditional_initial.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

(** This function set up built in compile time variables used in 
    conditional compilation so that 
    {[
        #if  BS then 
        #elif .. then 
        #end
    ]}
    Is understood, also make sure the playground do the same initialization. 
*)
val setup_env : unit -> unit


end = struct
#1 "bs_conditional_initial.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


let setup_env () =
  Clflags.compile_only := true;
  Clflags.bs_only := true;  
  Clflags.no_implicit_current_dir := true; 
  (* default true 
     otherwise [bsc -I sc src/hello.ml ] will include current directory to search path
  *)
  Clflags.assume_no_mli := Clflags.Mli_non_exists;
  Clflags.unsafe_string := false;
  Clflags.debug := true;
  Clflags.record_event_when_debug := false;
  Clflags.binary_annotations := true; 
  Clflags.transparent_modules := true;
  (* Turn on [-no-alias-deps] by default -- double check *)
  Oprint.out_ident := Outcome_printer_ns.out_ident;


  Lexer.replace_directive_bool "BS" true;
  Lexer.replace_directive_string "BS_VERSION"  Bs_version.version
  


end
module Ident : sig 
#1 "ident.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Identifiers (unique names) *)

type t = { stamp: int; name: string; mutable flags: int }

include Identifiable.S with type t := t
(* Notes:
   - [equal] compares identifiers by name
   - [compare x y] is 0 if [same x y] is true.
   - [compare] compares identifiers by binding location
*)


val create: string -> t
val create_persistent: string -> t
val create_predef_exn: string -> t
val rename: t -> t
val name: t -> string
val unique_name: t -> string
val unique_toplevel_name: t -> string
val persistent: t -> bool
val same: t -> t -> bool
        (* Compare identifiers by binding location.
           Two identifiers are the same either if they are both
           non-persistent and have been created by the same call to
           [new], or if they are both persistent and have the same
           name. *)
val compare: t -> t -> int
val hide: t -> t
        (* Return an identifier with same name as the given identifier,
           but stamp different from any stamp returned by new.
           When put in a 'a tbl, this identifier can only be looked
           up by name. *)

val make_global: t -> unit
val global: t -> bool
val is_predef_exn: t -> bool

val binding_time: t -> int
val current_time: unit -> int
val set_current_time: int -> unit
val reinit: unit -> unit

type 'a tbl
        (* Association tables from identifiers to type 'a. *)

val empty: 'a tbl
val add: t -> 'a -> 'a tbl -> 'a tbl
val find_same: t -> 'a tbl -> 'a
val find_name: string -> 'a tbl -> t * 'a
val find_all: string -> 'a tbl -> (t * 'a) list
val fold_name: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
val fold_all: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
val iter: (t -> 'a -> unit) -> 'a tbl -> unit


(* Idents for sharing keys *)

val make_key_generator : unit -> (t -> t)

end = struct
#1 "ident.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Format

type t = { stamp: int; name: string; mutable flags: int }

let global_flag = 1
let predef_exn_flag = 2

(* A stamp of 0 denotes a persistent identifier *)

let currentstamp = ref 0

let create s =
  incr currentstamp;
  { name = s; stamp = !currentstamp; flags = 0 }

let create_predef_exn s =
  incr currentstamp;
  { name = s; stamp = !currentstamp; flags = predef_exn_flag }

let create_persistent s =
  { name = s; stamp = 0; flags = global_flag }

let rename i =
  incr currentstamp;
  { i with stamp = !currentstamp }

let name i = i.name

let unique_name i = i.name ^ "_" ^ string_of_int i.stamp

let unique_toplevel_name i = i.name ^ "/" ^ string_of_int i.stamp

let persistent i = (i.stamp = 0)

let equal i1 i2 = i1.name = i2.name

let same i1 i2 = i1 = i2
  (* Possibly more efficient version (with a real compiler, at least):
       if i1.stamp <> 0
       then i1.stamp = i2.stamp
       else i2.stamp = 0 && i1.name = i2.name *)

let compare i1 i2 = Pervasives.compare i1 i2

let binding_time i = i.stamp

let current_time() = !currentstamp
let set_current_time t = currentstamp := max !currentstamp t

let reinit_level = ref (-1)

let reinit () =
  if !reinit_level < 0
  then reinit_level := !currentstamp
  else currentstamp := !reinit_level

let hide i =
  { i with stamp = -1 }

let make_global i =
  i.flags <- i.flags lor global_flag

let global i =
  (i.flags land global_flag) <> 0

let is_predef_exn i =
  (i.flags land predef_exn_flag) <> 0

let print ppf i =
  match i.stamp with
  | 0 -> fprintf ppf "%s!" i.name
  | -1 -> fprintf ppf "%s#" i.name
  | n -> fprintf ppf "%s/%i%s" i.name n (if global i then "g" else "")

type 'a tbl =
    Empty
  | Node of 'a tbl * 'a data * 'a tbl * int

and 'a data =
  { ident: t;
    data: 'a;
    previous: 'a data option }

let empty = Empty

(* Inline expansion of height for better speed
 * let height = function
 *     Empty -> 0
 *   | Node(_,_,_,h) -> h
 *)

let mknode l d r =
  let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h
  and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
  Node(l, d, r, (if hl >= hr then hl + 1 else hr + 1))

let balance l d r =
  let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h
  and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
  if hl > hr + 1 then
    match l with
    | Node (ll, ld, lr, _)
      when (match ll with Empty -> 0 | Node(_,_,_,h) -> h) >=
           (match lr with Empty -> 0 | Node(_,_,_,h) -> h) ->
        mknode ll ld (mknode lr d r)
    | Node (ll, ld, Node(lrl, lrd, lrr, _), _) ->
        mknode (mknode ll ld lrl) lrd (mknode lrr d r)
    | _ -> assert false
  else if hr > hl + 1 then
    match r with
    | Node (rl, rd, rr, _)
      when (match rr with Empty -> 0 | Node(_,_,_,h) -> h) >=
           (match rl with Empty -> 0 | Node(_,_,_,h) -> h) ->
        mknode (mknode l d rl) rd rr
    | Node (Node (rll, rld, rlr, _), rd, rr, _) ->
        mknode (mknode l d rll) rld (mknode rlr rd rr)
    | _ -> assert false
  else
    mknode l d r

let rec add id data = function
    Empty ->
      Node(Empty, {ident = id; data = data; previous = None}, Empty, 1)
  | Node(l, k, r, h) ->
      let c = compare id.name k.ident.name in
      if c = 0 then
        Node(l, {ident = id; data = data; previous = Some k}, r, h)
      else if c < 0 then
        balance (add id data l) k r
      else
        balance l k (add id data r)

let rec find_stamp s = function
    None ->
      raise Not_found
  | Some k ->
      if k.ident.stamp = s then k.data else find_stamp s k.previous

let rec find_same id = function
    Empty ->
      raise Not_found
  | Node(l, k, r, _) ->
      let c = compare id.name k.ident.name in
      if c = 0 then
        if id.stamp = k.ident.stamp
        then k.data
        else find_stamp id.stamp k.previous
      else
        find_same id (if c < 0 then l else r)

let rec find_name name = function
    Empty ->
      raise Not_found
  | Node(l, k, r, _) ->
      let c = compare name k.ident.name in
      if c = 0 then
        k.ident, k.data
      else
        find_name name (if c < 0 then l else r)

let rec get_all = function
  | None -> []
  | Some k -> (k.ident, k.data) :: get_all k.previous

let rec find_all name = function
    Empty ->
      []
  | Node(l, k, r, _) ->
      let c = compare name k.ident.name in
      if c = 0 then
        (k.ident, k.data) :: get_all k.previous
      else
        find_all name (if c < 0 then l else r)

let rec fold_aux f stack accu = function
    Empty ->
      begin match stack with
        [] -> accu
      | a :: l -> fold_aux f l accu a
      end
  | Node(l, k, r, _) ->
      fold_aux f (l :: stack) (f k accu) r

let fold_name f tbl accu = fold_aux (fun k -> f k.ident k.data) [] accu tbl

let rec fold_data f d accu =
  match d with
    None -> accu
  | Some k -> f k.ident k.data (fold_data f k.previous accu)

let fold_all f tbl accu =
  fold_aux (fun k -> fold_data f (Some k)) [] accu tbl

(* let keys tbl = fold_name (fun k _ accu -> k::accu) tbl [] *)

let rec iter f = function
    Empty -> ()
  | Node(l, k, r, _) ->
      iter f l; f k.ident k.data; iter f r

(* Idents for sharing keys *)

(* They should be 'totally fresh' -> neg numbers *)
let key_name = ""

let make_key_generator () =
  let c = ref 1 in
  fun id ->
    let stamp = !c in
    decr c ;
    { id with name = key_name; stamp = stamp; }

let compare x y =
  let c = x.stamp - y.stamp in
  if c <> 0 then c
  else
    let c = compare x.name y.name in
    if c <> 0 then c
    else
      compare x.flags y.flags

let output oc id = output_string oc (unique_name id)
let hash i = (Char.code i.name.[0]) lxor i.stamp

let original_equal = equal
include Identifiable.Make (struct
  type nonrec t = t
  let compare = compare
  let output = output
  let print = print
  let hash = hash
  let equal = same
end)
let equal = original_equal

end
module Path : sig 
#1 "path.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Access paths *)

type t =
    Pident of Ident.t
  | Pdot of t * string * int
  | Papply of t * t

val same: t -> t -> bool
val compare: t -> t -> int
val isfree: Ident.t -> t -> bool
val binding_time: t -> int
val flatten : t -> [ `Contains_apply | `Ok of Ident.t * string list ]

val nopos: int

val name: ?paren:(string -> bool) -> t -> string
    (* [paren] tells whether a path suffix needs parentheses *)
val head: t -> Ident.t

val heads: t -> Ident.t list

val last: t -> string

type typath =
  | Regular of t
  | Ext of t * string
  | LocalExt of Ident.t
  | Cstr of t * string

val constructor_typath: t -> typath
val is_constructor_typath: t -> bool

end = struct
#1 "path.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

type t =
    Pident of Ident.t
  | Pdot of t * string * int
  | Papply of t * t

let nopos = -1

let rec same p1 p2 =
  match (p1, p2) with
    (Pident id1, Pident id2) -> Ident.same id1 id2
  | (Pdot(p1, s1, _pos1), Pdot(p2, s2, _pos2)) -> s1 = s2 && same p1 p2
  | (Papply(fun1, arg1), Papply(fun2, arg2)) ->
       same fun1 fun2 && same arg1 arg2
  | (_, _) -> false

let rec compare p1 p2 =
  match (p1, p2) with
    (Pident id1, Pident id2) -> Ident.compare id1 id2
  | (Pdot(p1, s1, _pos1), Pdot(p2, s2, _pos2)) ->
      let h = compare p1 p2 in
      if h <> 0 then h else String.compare s1 s2
  | (Papply(fun1, arg1), Papply(fun2, arg2)) ->
      let h = compare fun1 fun2 in
      if h <> 0 then h else compare arg1 arg2
  | ((Pident _ | Pdot _), (Pdot _ | Papply _)) -> -1
  | ((Pdot _ | Papply _), (Pident _ | Pdot _)) -> 1

let rec isfree id = function
    Pident id' -> Ident.same id id'
  | Pdot(p, _s, _pos) -> isfree id p
  | Papply(p1, p2) -> isfree id p1 || isfree id p2

let rec binding_time = function
    Pident id -> Ident.binding_time id
  | Pdot(p, _s, _pos) -> binding_time p
  | Papply(p1, p2) -> max (binding_time p1) (binding_time p2)

let kfalse _ = false

let rec name ?(paren=kfalse) = function
    Pident id -> Ident.name id
  | Pdot(p, s, _pos) ->
      name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s
  | Papply(p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")"

let rec head = function
    Pident id -> id
  | Pdot(p, _s, _pos) -> head p
  | Papply _ -> assert false

let flatten =
  let rec flatten acc = function
    | Pident id -> `Ok (id, acc)
    | Pdot (p, s, _) -> flatten (s :: acc) p
    | Papply _ -> `Contains_apply
  in
  fun t -> flatten [] t

let heads p =
  let rec heads p acc = match p with
    | Pident id -> id :: acc
    | Pdot (p, _s, _pos) -> heads p acc
    | Papply(p1, p2) ->
        heads p1 (heads p2 acc)
  in heads p []

let rec last = function
  | Pident id -> Ident.name id
  | Pdot(_, s, _) -> s
  | Papply(_, p) -> last p

let is_uident s =
  assert (s <> "");
  match s.[0] with
  | 'A'..'Z' -> true
  | _ -> false

type typath =
  | Regular of t
  | Ext of t * string
  | LocalExt of Ident.t
  | Cstr of t * string

let constructor_typath = function
  | Pident id when is_uident (Ident.name id) -> LocalExt id
  | Pdot(ty_path, s, _) when is_uident s ->
      if is_uident (last ty_path) then Ext (ty_path, s)
      else Cstr (ty_path, s)
  | p -> Regular p

let is_constructor_typath p =
  match constructor_typath p with
  | Regular _ -> false
  | _ -> true

end
module Attr_helper : sig 
#1 "attr_helper.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                  Jeremie Dimino, Jane Street Europe                    *)
(*                                                                        *)
(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Helpers for attributes *)

open Asttypes
open Parsetree

type error =
  | Multiple_attributes of string
  | No_payload_expected of string

(** The [string list] argument of the following functions is a list of
    alternative names for the attribute we are looking for. For instance:

    {[
      ["foo"; "ocaml.foo"]
    ]} *)
val get_no_payload_attribute : string list -> attributes -> string loc option
val has_no_payload_attribute : string list -> attributes -> bool

exception Error of Location.t * error

val report_error: Format.formatter -> error -> unit

end = struct
#1 "attr_helper.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                  Jeremie Dimino, Jane Street Europe                    *)
(*                                                                        *)
(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Asttypes
open Parsetree

type error =
  | Multiple_attributes of string
  | No_payload_expected of string

exception Error of Location.t * error

let get_no_payload_attribute alt_names attrs =
  match List.filter (fun (n, _) -> List.mem n.txt alt_names) attrs with
  | [] -> None
  | [ (name, PStr []) ] -> Some name
  | [ (name, _) ] ->
    raise (Error (name.loc, No_payload_expected name.txt))
  | _ :: (name, _) :: _ ->
    raise (Error (name.loc, Multiple_attributes name.txt))

let has_no_payload_attribute alt_names attrs =
  match get_no_payload_attribute alt_names attrs with
  | None   -> false
  | Some _ -> true

open Format

let report_error ppf = function
  | Multiple_attributes name ->
    fprintf ppf "Too many `%s' attributes" name
  | No_payload_expected name ->
    fprintf ppf "Attribute `%s' does not accept a payload" name

let () =
  Location.register_error_of_exn
    (function
      | Error (loc, err) ->
        Some (Location.error_of_printer loc report_error err)
      | _ ->
        None
    )

end
module Primitive : sig 
#1 "primitive.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Description of primitive functions *)

type boxed_integer = Pnativeint | Pint32 | Pint64

(* Representation of arguments/result for the native code version
   of a primitive *)
type native_repr =
  | Same_as_ocaml_repr
  | Unboxed_float
  | Unboxed_integer of boxed_integer
  | Untagged_int

type description = private
  { prim_name: string;         (* Name of primitive  or C function *)
    prim_arity: int;           (* Number of arguments *)
    prim_alloc: bool;          (* Does it allocates or raise? *)
    prim_native_name: string;  (* Name of C function for the nat. code gen. *)
    prim_native_repr_args: native_repr list;
    prim_native_repr_res: native_repr }

(* Invariant [List.length d.prim_native_repr_args = d.prim_arity] *)

val simple
  :  name:string
  -> arity:int
  -> alloc:bool
  -> description

val make
  :  name:string
  -> alloc:bool
  -> native_name:string
  -> native_repr_args: native_repr list
  -> native_repr_res: native_repr
  -> description

val parse_declaration
  :  Parsetree.value_description
  -> native_repr_args:native_repr list
  -> native_repr_res:native_repr
  -> description

val print
  :  description
  -> Outcometree.out_val_decl
  -> Outcometree.out_val_decl

val native_name: description -> string
val byte_name: description -> string

type error =
  | Old_style_float_with_native_repr_attribute
  | Old_style_noalloc_with_noalloc_attribute
  | No_native_primitive_with_repr_attribute

exception Error of Location.t * error

end = struct
#1 "primitive.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Description of primitive functions *)

open Misc
open Parsetree

type boxed_integer = Pnativeint | Pint32 | Pint64

type native_repr =
  | Same_as_ocaml_repr
  | Unboxed_float
  | Unboxed_integer of boxed_integer
  | Untagged_int

type description =
  { prim_name: string;         (* Name of primitive  or C function *)
    prim_arity: int;           (* Number of arguments *)
    prim_alloc: bool;          (* Does it allocates or raise? *)
    prim_native_name: string;  (* Name of C function for the nat. code gen. *)
    prim_native_repr_args: native_repr list;
    prim_native_repr_res: native_repr }

type error =
  | Old_style_float_with_native_repr_attribute
  | Old_style_noalloc_with_noalloc_attribute
  | No_native_primitive_with_repr_attribute

exception Error of Location.t * error

let is_ocaml_repr = function
  | Same_as_ocaml_repr -> true
  | Unboxed_float
  | Unboxed_integer _
  | Untagged_int -> false

let is_unboxed = function
  | Same_as_ocaml_repr
  | Untagged_int -> false
  | Unboxed_float
  | Unboxed_integer _ -> true

let is_untagged = function
  | Untagged_int -> true
  | Same_as_ocaml_repr
  | Unboxed_float
  | Unboxed_integer _ -> false

let rec make_native_repr_args arity x =
  if arity = 0 then
    []
  else
    x :: make_native_repr_args (arity - 1) x

let simple ~name ~arity ~alloc =
  {prim_name = name;
   prim_arity = arity;
   prim_alloc = alloc;
   prim_native_name = "";
   prim_native_repr_args = make_native_repr_args arity Same_as_ocaml_repr;
   prim_native_repr_res = Same_as_ocaml_repr}

let make ~name ~alloc ~native_name ~native_repr_args ~native_repr_res =
  {prim_name = name;
   prim_arity = List.length native_repr_args;
   prim_alloc = alloc;
   prim_native_name = native_name;
   prim_native_repr_args = native_repr_args;
   prim_native_repr_res = native_repr_res}

let parse_declaration valdecl ~native_repr_args ~native_repr_res =
  let arity = List.length native_repr_args in
  let name, native_name, old_style_noalloc, old_style_float =
    match valdecl.pval_prim with
    | name :: "noalloc" :: name2 :: "float" :: _ -> (name, name2, true, true)
    | name :: "noalloc" :: name2 :: _ -> (name, name2, true, false)
    | name :: name2 :: "float" :: _ -> (name, name2, false, true)
    | name :: "noalloc" :: _ -> (name, "", true, false)
    | name :: name2 :: _ -> (name, name2, false, false)
    | name :: _ -> (name, "", false, false)
    | [] ->
        fatal_error "Primitive.parse_declaration"
  in
  let noalloc_attribute =
    Attr_helper.has_no_payload_attribute ["noalloc"; "ocaml.noalloc"]
      valdecl.pval_attributes
  in
  if old_style_float &&
     not (List.for_all is_ocaml_repr native_repr_args &&
          is_ocaml_repr native_repr_res) then
    raise (Error (valdecl.pval_loc,
                  Old_style_float_with_native_repr_attribute));
  if old_style_noalloc && noalloc_attribute then
    raise (Error (valdecl.pval_loc,
                  Old_style_noalloc_with_noalloc_attribute));
  (* The compiler used to assume "noalloc" with "float", we just make this
     explicit now (GPR#167): *)
  let old_style_noalloc = old_style_noalloc || old_style_float in
  if old_style_float then
    Location.deprecated valdecl.pval_loc
      "[@@unboxed] + [@@noalloc] should be used instead of \"float\""
  else if old_style_noalloc then
    Location.deprecated valdecl.pval_loc
      "[@@noalloc] should be used instead of \"noalloc\"";
  if native_name = "" &&
     not (List.for_all is_ocaml_repr native_repr_args &&
          is_ocaml_repr native_repr_res) then
    raise (Error (valdecl.pval_loc,
                  No_native_primitive_with_repr_attribute));
  let noalloc = old_style_noalloc || noalloc_attribute in
  let native_repr_args, native_repr_res =
    if old_style_float then
      (make_native_repr_args arity Unboxed_float, Unboxed_float)
    else
      (native_repr_args, native_repr_res)
  in
  {prim_name = name;
   prim_arity = arity;
   prim_alloc = not noalloc;
   prim_native_name = native_name;
   prim_native_repr_args = native_repr_args;
   prim_native_repr_res = native_repr_res}

open Outcometree

let rec add_native_repr_attributes ty attrs =
  match ty, attrs with
  | Otyp_arrow (label, a, b), attr_opt :: rest ->
    let b = add_native_repr_attributes b rest in
    let a =
      match attr_opt with
      | None -> a
      | Some attr -> Otyp_attribute (a, attr)
    in
    Otyp_arrow (label, a, b)
  | _, [Some attr] -> Otyp_attribute (ty, attr)
  | _ ->
    assert (List.for_all (fun x -> x = None) attrs);
    ty

let oattr_unboxed = { oattr_name = "unboxed" }
let oattr_untagged = { oattr_name = "untagged" }
let oattr_noalloc = { oattr_name = "noalloc" }

let print p osig_val_decl =
  let prims =
    if p.prim_native_name <> "" then
      [p.prim_name; p.prim_native_name]
    else
      [p.prim_name]
  in
  let for_all f =
    List.for_all f p.prim_native_repr_args && f p.prim_native_repr_res
  in
  let all_unboxed = for_all is_unboxed in
  let all_untagged = for_all is_untagged in
  let attrs = if p.prim_alloc then [] else [oattr_noalloc] in
  let attrs =
    if all_unboxed then
      oattr_unboxed :: attrs
    else if all_untagged then
      oattr_untagged :: attrs
    else
      attrs
  in
  let attr_of_native_repr = function
    | Same_as_ocaml_repr -> None
    | Unboxed_float
    | Unboxed_integer _ -> if all_unboxed then None else Some oattr_unboxed
    | Untagged_int -> if all_untagged then None else Some oattr_untagged
  in
  let type_attrs =
    List.map attr_of_native_repr p.prim_native_repr_args @
    [attr_of_native_repr p.prim_native_repr_res]
  in
  { osig_val_decl with
    oval_prims = prims;
    oval_type = add_native_repr_attributes osig_val_decl.oval_type type_attrs;
    oval_attributes = attrs }

let native_name p =
  if p.prim_native_name <> ""
  then p.prim_native_name
  else p.prim_name

let byte_name p =
  p.prim_name

let report_error ppf err =
  match err with
  | Old_style_float_with_native_repr_attribute ->
    Format.fprintf ppf "Cannot use \"float\" in conjunction with \
                        [%@unboxed]/[%@untagged]"
  | Old_style_noalloc_with_noalloc_attribute ->
    Format.fprintf ppf "Cannot use \"noalloc\" in conjunction with \
                        [%@%@noalloc]"
  | No_native_primitive_with_repr_attribute ->
    Format.fprintf ppf
      "The native code version of the primitive is mandatory when \
       attributes [%@untagged] or [%@unboxed] are present"

let () =
  Location.register_error_of_exn
    (function
      | Error (loc, err) ->
        Some (Location.error_of_printer loc report_error err)
      | _ ->
        None
    )

end
module Types : sig 
#1 "types.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** {0 Representation of types and declarations} *)

(** [Types] defines the representation of types and declarations (that is, the
    content of module signatures).

    CMI files are made of marshalled types.
*)

(** Asttypes exposes basic definitions shared both by Parsetree and Types. *)
open Asttypes

(** Type expressions for the core language.

    The [type_desc] variant defines all the possible type expressions one can
    find in OCaml. [type_expr] wraps this with some annotations.

    The [level] field tracks the level of polymorphism associated to a type,
    guiding the generalization algorithm.
    Put shortly, when referring to a type in a given environment, both the type
    and the environment have a level. If the type has an higher level, then it
    can be considered fully polymorphic (type variables will be printed as
    ['a]), otherwise it'll be weakly polymorphic, or non generalized (type
    variables printed as ['_a]).
    See [http://okmij.org/ftp/ML/generalization.html] for more information.

    Note about [type_declaration]: one should not make the confusion between
    [type_expr] and [type_declaration].

    [type_declaration] refers specifically to the [type] construct in OCaml
    language, where you create and name a new type or type alias.

    [type_expr] is used when you refer to existing types, e.g. when annotating
    the expected type of a value.

    Also, as the type system of OCaml is generative, a [type_declaration] can
    have the side-effect of introducing a new type constructor, different from
    all other known types.
    Whereas [type_expr] is a pure construct which allows referring to existing
    types.

    Note on mutability: TBD.
 *)
type type_expr =
  { mutable desc: type_desc;
    mutable level: int;
    id: int }

and type_desc =
  | Tvar of string option
  (** [Tvar (Some "a")] ==> ['a] or ['_a]
      [Tvar None]       ==> [_] *)

  | Tarrow of arg_label * type_expr * type_expr * commutable
  (** [Tarrow (Nolabel,      e1, e2, c)] ==> [e1    -> e2]
      [Tarrow (Labelled "l", e1, e2, c)] ==> [l:e1  -> e2]
      [Tarrow (Optional "l", e1, e2, c)] ==> [?l:e1 -> e2]

      See [commutable] for the last argument. *)

  | Ttuple of type_expr list
  (** [Ttuple [t1;...;tn]] ==> [(t1 * ... * tn)] *)

  | Tconstr of Path.t * type_expr list * abbrev_memo ref
  (** [Tconstr (`A.B.t', [t1;...;tn], _)] ==> [(t1,...,tn) A.B.t]
      The last parameter keep tracks of known expansions, see [abbrev_memo]. *)

  | Tobject of type_expr * (Path.t * type_expr list) option ref
  (** [Tobject (`f1:t1;...;fn: tn', `None')] ==> [< f1: t1; ...; fn: tn >]
      f1, fn are represented as a linked list of types using Tfield and Tnil
      constructors.

      [Tobject (_, `Some (`A.ct', [t1;...;tn]')] ==> [(t1, ..., tn) A.ct].
      where A.ct is the type of some class.

      There are also special cases for so-called "class-types", cf. [Typeclass]
      and [Ctype.set_object_name]:

        [Tobject (Tfield(_,_,...(Tfield(_,_,rv)...),
                         Some(`A.#ct`, [rv;t1;...;tn])]
             ==> [(t1, ..., tn) #A.ct]
        [Tobject (_, Some(`A.#ct`, [Tnil;t1;...;tn])] ==> [(t1, ..., tn) A.ct]

      where [rv] is the hidden row variable.
  *)

  | Tfield of string * field_kind * type_expr * type_expr
  (** [Tfield ("foo", Fpresent, t, ts)] ==> [<...; foo : t; ts>] *)

  | Tnil
  (** [Tnil] ==> [<...; >] *)

  | Tlink of type_expr
  (** Indirection used by unification engine. *)

  | Tsubst of type_expr         (* for copying *)
  (** [Tsubst] is used temporarily to store information in low-level
      functions manipulating representation of types, such as
      instantiation or copy.
      This constructor should not appear outside of these cases. *)

  | Tvariant of row_desc
  (** Representation of polymorphic variants, see [row_desc]. *)

  | Tunivar of string option
  (** Occurrence of a type variable introduced by a
      forall quantifier / [Tpoly]. *)

  | Tpoly of type_expr * type_expr list
  (** [Tpoly (ty,tyl)] ==> ['a1... 'an. ty],
      where 'a1 ... 'an are names given to types in tyl
      and occurrences of those types in ty. *)

  | Tpackage of Path.t * Longident.t list * type_expr list
  (** Type of a first-class module (a.k.a package). *)

(** [  `X | `Y ]       (row_closed = true)
    [< `X | `Y ]       (row_closed = true)
    [> `X | `Y ]       (row_closed = false)
    [< `X | `Y > `X ]  (row_closed = true)

    type t = [> `X ] as 'a      (row_more = Tvar a)
    type t = private [> `X ]    (row_more = Tconstr (t#row, [], ref Mnil)

    And for:

        let f = function `X -> `X -> | `Y -> `X

    the type of "f" will be a [Tarrow] whose lhs will (basically) be:

        Tvariant { row_fields = [("X", _)];
                   row_more   =
                     Tvariant { row_fields = [("Y", _)];
                                row_more   =
                                  Tvariant { row_fields = [];
                                             row_more   = _;
                                             _ };
                                _ };
                   _
                 }

*)
and row_desc =
    { row_fields: (label * row_field) list;
      row_more: type_expr;
      row_bound: unit; (* kept for compatibility *)
      row_closed: bool;
      row_fixed: bool;
      row_name: (Path.t * type_expr list) option }

and row_field =
    Rpresent of type_expr option
  | Reither of bool * type_expr list * bool * row_field option ref
        (* 1st true denotes a constant constructor *)
        (* 2nd true denotes a tag in a pattern matching, and
           is erased later *)
  | Rabsent

(** [abbrev_memo] allows one to keep track of different expansions of a type
    alias. This is done for performance purposes.

    For instance, when defining [type 'a pair = 'a * 'a], when one refers to an
    ['a pair], it is just a shortcut for the ['a * 'a] type.
    This expansion will be stored in the [abbrev_memo] of the corresponding
    [Tconstr] node.

    In practice, [abbrev_memo] behaves like list of expansions with a mutable
    tail.

    Note on marshalling: [abbrev_memo] must not appear in saved types.
    [Btype], with [cleanup_abbrev] and [memo], takes care of tracking and
    removing abbreviations.
*)
and abbrev_memo =
  | Mnil (** No known abbreviation *)

  | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo
  (** Found one abbreviation.
      A valid abbreviation should be at least as visible and reachable by the
      same path.
      The first expression is the abbreviation and the second the expansion. *)

  | Mlink of abbrev_memo ref
  (** Abbreviations can be found after this indirection *)

and field_kind =
    Fvar of field_kind option ref
  | Fpresent
  | Fabsent

(** [commutable] is a flag appended to every arrow type.

    When typing an application, if the type of the functional is
    known, its type is instantiated with [Cok] arrows, otherwise as
    [Clink (ref Cunknown)].

    When the type is not known, the application will be used to infer
    the actual type.  This is fragile in presence of labels where
    there is no principal type.

    Two incompatible applications relying on [Cunknown] arrows will
    trigger an error.

    let f g =
      g ~a:() ~b:();
      g ~b:() ~a:();

    Error: This function is applied to arguments
    in an order different from other calls.
    This is only allowed when the real type is known.
*)
and commutable =
    Cok
  | Cunknown
  | Clink of commutable ref

module TypeOps : sig
  type t = type_expr
  val compare : t -> t -> int
  val equal : t -> t -> bool
  val hash : t -> int
end

(* Maps of methods and instance variables *)

module Meths : Map.S with type key = string
module Vars  : Map.S with type key = string

(* Value descriptions *)

type value_description =
  { val_type: type_expr;                (* Type of the value *)
    val_kind: value_kind;
    val_loc: Location.t;
    val_attributes: Parsetree.attributes;
   }

and value_kind =
    Val_reg                             (* Regular value *)
  | Val_prim of Primitive.description   (* Primitive *)
  | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
  | Val_self of (Ident.t * type_expr) Meths.t ref *
                (Ident.t * mutable_flag * virtual_flag * type_expr) Vars.t ref *
                string * type_expr
                                        (* Self *)
  | Val_anc of (string * Ident.t) list * string
                                        (* Ancestor *)
  | Val_unbound                         (* Unbound variable *)

(* Variance *)

module Variance : sig
  type t
  type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv
  val null : t                          (* no occurrence *)
  val full : t                          (* strictly invariant *)
  val covariant : t                     (* strictly covariant *)
  val may_inv : t                       (* maybe invariant *)
  val union  : t -> t -> t
  val inter  : t -> t -> t
  val subset : t -> t -> bool
  val set : f -> bool -> t -> t
  val mem : f -> t -> bool
  val conjugate : t -> t                (* exchange positive and negative *)
  val get_upper : t -> bool * bool                  (* may_pos, may_neg   *)
  val get_lower : t -> bool * bool * bool * bool    (* pos, neg, inv, inj *)
end

(* Type definitions *)

type type_declaration =
  { type_params: type_expr list;
    type_arity: int;
    type_kind: type_kind;
    type_private: private_flag;
    type_manifest: type_expr option;
    type_variance: Variance.t list;
    (* covariant, contravariant, weakly contravariant, injective *)
    type_newtype_level: (int * int) option;
    (* definition level * expansion level *)
    type_loc: Location.t;
    type_attributes: Parsetree.attributes;
    type_immediate: bool; (* true iff type should not be a pointer *)
    type_unboxed: unboxed_status;
  }

and type_kind =
    Type_abstract
  | Type_record of label_declaration list  * record_representation
  | Type_variant of constructor_declaration list
  | Type_open

and record_representation =
    Record_regular                      (* All fields are boxed / tagged *)
  | Record_float                        (* All fields are floats *)
  | Record_unboxed of bool    (* Unboxed single-field record, inlined or not *)
  | Record_inlined of { tag : int ; name : string; num_nonconsts : int}              (* Inlined record *)
  | Record_extension                    (* Inlined record under extension *)

and label_declaration =
  {
    ld_id: Ident.t;
    ld_mutable: mutable_flag;
    ld_type: type_expr;
    ld_loc: Location.t;
    ld_attributes: Parsetree.attributes;
  }

and constructor_declaration =
  {
    cd_id: Ident.t;
    cd_args: constructor_arguments;
    cd_res: type_expr option;
    cd_loc: Location.t;
    cd_attributes: Parsetree.attributes;
  }

and constructor_arguments =
  | Cstr_tuple of type_expr list
  | Cstr_record of label_declaration list

and unboxed_status = private
  (* This type must be private in order to ensure perfect sharing of the
     four possible values. Otherwise, ocamlc.byte and ocamlc.opt produce
     different executables. *)
  {
    unboxed: bool;
    default: bool; (* True for unannotated unboxable types. *)
  }

val unboxed_false_default_false : unboxed_status
val unboxed_false_default_true : unboxed_status
val unboxed_true_default_false : unboxed_status
val unboxed_true_default_true : unboxed_status

type extension_constructor =
    {
      ext_type_path: Path.t;
      ext_type_params: type_expr list;
      ext_args: constructor_arguments;
      ext_ret_type: type_expr option;
      ext_private: private_flag;
      ext_loc: Location.t;
      ext_attributes: Parsetree.attributes;
    }

and type_transparence =
    Type_public      (* unrestricted expansion *)
  | Type_new         (* "new" type *)
  | Type_private     (* private type *)

(* Type expressions for the class language *)

module Concr : Set.S with type elt = string

type class_type =
    Cty_constr of Path.t * type_expr list * class_type
  | Cty_signature of class_signature
  | Cty_arrow of arg_label * type_expr * class_type

and class_signature =
  { csig_self: type_expr;
    csig_vars:
      (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
    csig_concr: Concr.t;
    csig_inher: (Path.t * type_expr list) list }

type class_declaration =
  { cty_params: type_expr list;
    mutable cty_type: class_type;
    cty_path: Path.t;
    cty_new: type_expr option;
    cty_variance: Variance.t list;
    cty_loc: Location.t;
    cty_attributes: Parsetree.attributes;
  }

type class_type_declaration =
  { clty_params: type_expr list;
    clty_type: class_type;
    clty_path: Path.t;
    clty_variance: Variance.t list;
    clty_loc: Location.t;
    clty_attributes: Parsetree.attributes;
  }

(* Type expressions for the module language *)

type module_type =
    Mty_ident of Path.t
  | Mty_signature of signature
  | Mty_functor of Ident.t * module_type option * module_type
  | Mty_alias of alias_presence * Path.t

and alias_presence =
  | Mta_present
  | Mta_absent

and signature = signature_item list

and signature_item =
    Sig_value of Ident.t * value_description
  | Sig_type of Ident.t * type_declaration * rec_status
  | Sig_typext of Ident.t * extension_constructor * ext_status
  | Sig_module of Ident.t * module_declaration * rec_status
  | Sig_modtype of Ident.t * modtype_declaration
  | Sig_class of Ident.t * class_declaration * rec_status
  | Sig_class_type of Ident.t * class_type_declaration * rec_status

and module_declaration =
  {
    md_type: module_type;
    md_attributes: Parsetree.attributes;
    md_loc: Location.t;
  }

and modtype_declaration =
  {
    mtd_type: module_type option;  (* None: abstract *)
    mtd_attributes: Parsetree.attributes;
    mtd_loc: Location.t;
  }

and rec_status =
    Trec_not                   (* first in a nonrecursive group *)
  | Trec_first                 (* first in a recursive group *)
  | Trec_next                  (* not first in a recursive/nonrecursive group *)

and ext_status =
    Text_first                     (* first constructor in an extension *)
  | Text_next                      (* not first constructor in an extension *)
  | Text_exception


(* Constructor and record label descriptions inserted held in typing
   environments *)

type constructor_description =
  { cstr_name: string;                  (* Constructor name *)
    cstr_res: type_expr;                (* Type of the result *)
    cstr_existentials: type_expr list;  (* list of existentials *)
    cstr_args: type_expr list;          (* Type of the arguments *)
    cstr_arity: int;                    (* Number of arguments *)
    cstr_tag: constructor_tag;          (* Tag for heap blocks *)
    cstr_consts: int;                   (* Number of constant constructors *)
    cstr_nonconsts: int;                (* Number of non-const constructors *)
    cstr_normal: int;                   (* Number of non generalized constrs *)
    cstr_generalized: bool;             (* Constrained return type? *)
    cstr_private: private_flag;         (* Read-only constructor? *)
    cstr_loc: Location.t;
    cstr_attributes: Parsetree.attributes;
    cstr_inlined: type_declaration option;
   }

and constructor_tag =
    Cstr_constant of int                (* Constant constructor (an int) *)
  | Cstr_block of int                   (* Regular constructor (a block) *)
  | Cstr_unboxed                        (* Constructor of an unboxed type *)
  | Cstr_extension of Path.t * bool     (* Extension constructor
                                           true if a constant false if a block*)

(* Constructors are the same *)
val equal_tag :  constructor_tag -> constructor_tag -> bool

(* Constructors may be the same, given potential rebinding *)
val may_equal_constr :
    constructor_description ->  constructor_description -> bool

type label_description =
  { lbl_name: string;                   (* Short name *)
    lbl_res: type_expr;                 (* Type of the result *)
    lbl_arg: type_expr;                 (* Type of the argument *)
    lbl_mut: mutable_flag;              (* Is this a mutable field? *)
    lbl_pos: int;                       (* Position in block *)
    lbl_all: label_description array;   (* All the labels in this type *)
    lbl_repres: record_representation;  (* Representation for this record *)
    lbl_private: private_flag;          (* Read-only field? *)
    lbl_loc: Location.t;
    lbl_attributes: Parsetree.attributes;
  }

end = struct
#1 "types.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Representation of types and declarations *)

open Asttypes

(* Type expressions for the core language *)

type type_expr =
  { mutable desc: type_desc;
    mutable level: int;
    id: int }

and type_desc =
    Tvar of string option
  | Tarrow of arg_label * type_expr * type_expr * commutable
  | Ttuple of type_expr list
  | Tconstr of Path.t * type_expr list * abbrev_memo ref
  | Tobject of type_expr * (Path.t * type_expr list) option ref
  | Tfield of string * field_kind * type_expr * type_expr
  | Tnil
  | Tlink of type_expr
  | Tsubst of type_expr         (* for copying *)
  | Tvariant of row_desc
  | Tunivar of string option
  | Tpoly of type_expr * type_expr list
  | Tpackage of Path.t * Longident.t list * type_expr list

and row_desc =
    { row_fields: (label * row_field) list;
      row_more: type_expr;
      row_bound: unit;
      row_closed: bool;
      row_fixed: bool;
      row_name: (Path.t * type_expr list) option }

and row_field =
    Rpresent of type_expr option
  | Reither of bool * type_expr list * bool * row_field option ref
        (* 1st true denotes a constant constructor *)
        (* 2nd true denotes a tag in a pattern matching, and
           is erased later *)
  | Rabsent

and abbrev_memo =
    Mnil
  | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo
  | Mlink of abbrev_memo ref

and field_kind =
    Fvar of field_kind option ref
  | Fpresent
  | Fabsent

and commutable =
    Cok
  | Cunknown
  | Clink of commutable ref

module TypeOps = struct
  type t = type_expr
  let compare t1 t2 = t1.id - t2.id
  let hash t = t.id
  let equal t1 t2 = t1 == t2
end

(* Maps of methods and instance variables *)

module OrderedString =
  struct type t = string let compare (x:t) y = compare x y end
module Meths = Map.Make(OrderedString)
module Vars = Meths

(* Value descriptions *)

type value_description =
  { val_type: type_expr;                (* Type of the value *)
    val_kind: value_kind;
    val_loc: Location.t;
    val_attributes: Parsetree.attributes;
 }

and value_kind =
    Val_reg                             (* Regular value *)
  | Val_prim of Primitive.description   (* Primitive *)
  | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
  | Val_self of (Ident.t * type_expr) Meths.t ref *
                (Ident.t * Asttypes.mutable_flag *
                 Asttypes.virtual_flag * type_expr) Vars.t ref *
                string * type_expr
                                        (* Self *)
  | Val_anc of (string * Ident.t) list * string
                                        (* Ancestor *)
  | Val_unbound                         (* Unbound variable *)

(* Variance *)

module Variance = struct
  type t = int
  type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv
  let single = function
    | May_pos -> 1
    | May_neg -> 2
    | May_weak -> 4
    | Inj -> 8
    | Pos -> 16
    | Neg -> 32
    | Inv -> 64
  let union v1 v2 = v1 lor v2
  let inter v1 v2 = v1 land v2
  let subset v1 v2 = (v1 land v2 = v1)
  let set x b v =
    if b then v lor single x else  v land (lnot (single x))
  let mem x = subset (single x)
  let null = 0
  let may_inv = 7
  let full = 127
  let covariant = single May_pos lor single Pos lor single Inj
  let swap f1 f2 v =
    let v' = set f1 (mem f2 v) v in set f2 (mem f1 v) v'
  let conjugate v = swap May_pos May_neg (swap Pos Neg v)
  let get_upper v = (mem May_pos v, mem May_neg v)
  let get_lower v = (mem Pos v, mem Neg v, mem Inv v, mem Inj v)
end

(* Type definitions *)

type type_declaration =
  { type_params: type_expr list;
    type_arity: int;
    type_kind: type_kind;
    type_private: private_flag;
    type_manifest: type_expr option;
    type_variance: Variance.t list;
    type_newtype_level: (int * int) option;
    type_loc: Location.t;
    type_attributes: Parsetree.attributes;
    type_immediate: bool;
    type_unboxed: unboxed_status;
 }

and type_kind =
    Type_abstract
  | Type_record of label_declaration list  * record_representation
  | Type_variant of constructor_declaration list
  | Type_open

and record_representation =
    Record_regular                      (* All fields are boxed / tagged *)
  | Record_float                        (* All fields are floats *)
  | Record_unboxed of bool    (* Unboxed single-field record, inlined or not *)
  | Record_inlined of {tag : int; name : string; num_nonconsts : int}               (* Inlined record *)
  | Record_extension                    (* Inlined record under extension *)

and label_declaration =
  {
    ld_id: Ident.t;
    ld_mutable: mutable_flag;
    ld_type: type_expr;
    ld_loc: Location.t;
    ld_attributes: Parsetree.attributes;
  }

and constructor_declaration =
  {
    cd_id: Ident.t;
    cd_args: constructor_arguments;
    cd_res: type_expr option;
    cd_loc: Location.t;
    cd_attributes: Parsetree.attributes;
  }

and constructor_arguments =
  | Cstr_tuple of type_expr list
  | Cstr_record of label_declaration list

and unboxed_status =
  {
    unboxed: bool;
    default: bool; (* False if the unboxed field was set from an attribute. *)
  }

let unboxed_false_default_false = {unboxed = false; default = false}
let unboxed_false_default_true = {unboxed = false; default = true}
let unboxed_true_default_false = {unboxed = true; default = false}
let unboxed_true_default_true = {unboxed = true; default = true}

type extension_constructor =
    { ext_type_path: Path.t;
      ext_type_params: type_expr list;
      ext_args: constructor_arguments;
      ext_ret_type: type_expr option;
      ext_private: private_flag;
      ext_loc: Location.t;
      ext_attributes: Parsetree.attributes; }

and type_transparence =
    Type_public      (* unrestricted expansion *)
  | Type_new         (* "new" type *)
  | Type_private     (* private type *)

(* Type expressions for the class language *)

module Concr = Set.Make(OrderedString)

type class_type =
    Cty_constr of Path.t * type_expr list * class_type
  | Cty_signature of class_signature
  | Cty_arrow of arg_label * type_expr * class_type

and class_signature =
  { csig_self: type_expr;
    csig_vars:
      (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
    csig_concr: Concr.t;
    csig_inher: (Path.t * type_expr list) list }

type class_declaration =
  { cty_params: type_expr list;
    mutable cty_type: class_type;
    cty_path: Path.t;
    cty_new: type_expr option;
    cty_variance: Variance.t list;
    cty_loc: Location.t;
    cty_attributes: Parsetree.attributes;
 }

type class_type_declaration =
  { clty_params: type_expr list;
    clty_type: class_type;
    clty_path: Path.t;
    clty_variance: Variance.t list;
    clty_loc: Location.t;
    clty_attributes: Parsetree.attributes;
  }

(* Type expressions for the module language *)

type module_type =
    Mty_ident of Path.t
  | Mty_signature of signature
  | Mty_functor of Ident.t * module_type option * module_type
  | Mty_alias of alias_presence * Path.t

and alias_presence =
  | Mta_present
  | Mta_absent

and signature = signature_item list

and signature_item =
    Sig_value of Ident.t * value_description
  | Sig_type of Ident.t * type_declaration * rec_status
  | Sig_typext of Ident.t * extension_constructor * ext_status
  | Sig_module of Ident.t * module_declaration * rec_status
  | Sig_modtype of Ident.t * modtype_declaration
  | Sig_class of Ident.t * class_declaration * rec_status
  | Sig_class_type of Ident.t * class_type_declaration * rec_status

and module_declaration =
  {
    md_type: module_type;
    md_attributes: Parsetree.attributes;
    md_loc: Location.t;
  }

and modtype_declaration =
  {
    mtd_type: module_type option;  (* Note: abstract *)
    mtd_attributes: Parsetree.attributes;
    mtd_loc: Location.t;
  }

and rec_status =
    Trec_not                   (* first in a nonrecursive group *)
  | Trec_first                 (* first in a recursive group *)
  | Trec_next                  (* not first in a recursive/nonrecursive group *)

and ext_status =
    Text_first                     (* first constructor of an extension *)
  | Text_next                      (* not first constructor of an extension *)
  | Text_exception                 (* an exception *)


(* Constructor and record label descriptions inserted held in typing
   environments *)

type constructor_description =
  { cstr_name: string;                  (* Constructor name *)
    cstr_res: type_expr;                (* Type of the result *)
    cstr_existentials: type_expr list;  (* list of existentials *)
    cstr_args: type_expr list;          (* Type of the arguments *)
    cstr_arity: int;                    (* Number of arguments *)
    cstr_tag: constructor_tag;          (* Tag for heap blocks *)
    cstr_consts: int;                   (* Number of constant constructors *)
    cstr_nonconsts: int;                (* Number of non-const constructors *)
    cstr_normal: int;                   (* Number of non generalized constrs *)
    cstr_generalized: bool;             (* Constrained return type? *)
    cstr_private: private_flag;         (* Read-only constructor? *)
    cstr_loc: Location.t;
    cstr_attributes: Parsetree.attributes;
    cstr_inlined: type_declaration option;
   }

and constructor_tag =
    Cstr_constant of int                (* Constant constructor (an int) *)
  | Cstr_block of int                   (* Regular constructor (a block) *)
  | Cstr_unboxed                        (* Constructor of an unboxed type *)
  | Cstr_extension of Path.t * bool     (* Extension constructor
                                           true if a constant false if a block*)

let equal_tag t1 t2 = 
  match (t1, t2) with
  | Cstr_constant i1, Cstr_constant i2 -> i2 = i1
  | Cstr_block i1, Cstr_block i2 -> i2 = i1
  | Cstr_unboxed, Cstr_unboxed -> true
  | Cstr_extension (path1, b1), Cstr_extension (path2, b2) -> 
      Path.same path1 path2 && b1 = b2
  | (Cstr_constant _|Cstr_block _|Cstr_unboxed|Cstr_extension _), _ -> false

let may_equal_constr c1 c2 = match c1.cstr_tag,c2.cstr_tag with
| Cstr_extension _,Cstr_extension _ -> c1.cstr_arity = c2.cstr_arity
| tag1,tag2 -> equal_tag tag1 tag2

type label_description =
  { lbl_name: string;                   (* Short name *)
    lbl_res: type_expr;                 (* Type of the result *)
    lbl_arg: type_expr;                 (* Type of the argument *)
    lbl_mut: mutable_flag;              (* Is this a mutable field? *)
    lbl_pos: int;                       (* Position in block *)
    lbl_all: label_description array;   (* All the labels in this type *)
    lbl_repres: record_representation;  (* Representation for this record *)
    lbl_private: private_flag;          (* Read-only field? *)
    lbl_loc: Location.t;
    lbl_attributes: Parsetree.attributes;
   }

end
module Cmi_format : sig 
#1 "cmi_format.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                   Fabrice Le Fessant, INRIA Saclay                     *)
(*                                                                        *)
(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

type pers_flags =
  | Rectypes
  | Deprecated of string
  | Opaque
  | Unsafe_string

type cmi_infos = {
    cmi_name : string;
    cmi_sign : Types.signature_item list;
    cmi_crcs : (string * Digest.t option) list;
    cmi_flags : pers_flags list;
}

(* write the magic + the cmi information *)
val output_cmi : string -> out_channel -> cmi_infos -> Digest.t

val create_cmi : ?check_exists:unit -> string -> cmi_infos -> Digest.t

(* read the cmi information (the magic is supposed to have already been read) *)
val input_cmi : in_channel -> cmi_infos

(* read a cmi from a filename, checking the magic *)
val read_cmi : string -> cmi_infos

(* Error report *)

type error =
    Not_an_interface of string
  | Wrong_version_interface of string * string
  | Corrupted_interface of string

exception Error of error

open Format

val report_error: formatter -> error -> unit

end = struct
#1 "cmi_format.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                   Fabrice Le Fessant, INRIA Saclay                     *)
(*                                                                        *)
(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

type pers_flags =
  | Rectypes
  | Deprecated of string
  | Opaque
  | Unsafe_string

type error =
    Not_an_interface of string
  | Wrong_version_interface of string * string
  | Corrupted_interface of string

exception Error of error

type cmi_infos = {
    cmi_name : string;
    cmi_sign : Types.signature_item list;
    cmi_crcs : (string * Digest.t option) list;
    cmi_flags : pers_flags list;
}

let input_cmi ic =
  let (name, sign) = input_value ic in
  let crcs = input_value ic in
  let flags = input_value ic in
  {
      cmi_name = name;
      cmi_sign = sign;
      cmi_crcs = crcs;
      cmi_flags = flags;
    }

let read_cmi filename =
  let ic = open_in_bin filename in
  try
    let buffer =
      really_input_string ic (String.length Config.cmi_magic_number)
    in
    if buffer <> Config.cmi_magic_number then begin
      close_in ic;
      let pre_len = String.length Config.cmi_magic_number - 3 in
      if String.sub buffer 0 pre_len
          = String.sub Config.cmi_magic_number 0 pre_len then
      begin
        let msg =
          if buffer < Config.cmi_magic_number then "an older" else "a newer" in
        raise (Error (Wrong_version_interface (filename, msg)))
      end else begin
        raise(Error(Not_an_interface filename))
      end
    end;
    let cmi = input_cmi ic in
    close_in ic;
    cmi
  with End_of_file | Failure _ ->
      close_in ic;
      raise(Error(Corrupted_interface(filename)))
    | Error e ->
      close_in ic;
      raise (Error e)

let output_cmi filename oc cmi =
(* beware: the provided signature must have been substituted for saving *)
  output_string oc Config.cmi_magic_number;
  output_value oc (cmi.cmi_name, cmi.cmi_sign);
  flush oc;
  let crc = Digest.file filename in
  let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in
  output_value oc crcs;
  output_value oc cmi.cmi_flags;
  crc


(* This function is also called by [save_cmt] as cmi_format is subset of 
       cmt_format, so dont close the channel yet
*)
let create_cmi ?check_exists filename (cmi : cmi_infos) =
  (* beware: the provided signature must have been substituted for saving *)
  let content = 
    Config.cmi_magic_number ^ Marshal.to_string  (cmi.cmi_name, cmi.cmi_sign) []
    (* checkout [output_value] in {!Pervasives} module *)
  in 
  let crc = Digest.string content in   
  let cmi_infos = 
    if check_exists <> None && Sys.file_exists filename then 
      Some (read_cmi filename)
    else None in   
  match cmi_infos with 
  | Some {cmi_name = _; cmi_sign = _; cmi_crcs = (old_name, Some old_crc)::rest ; cmi_flags} 
    (* TODO: design the cmi format so that we don't need read the whole cmi *)
    when 
      cmi.cmi_name = old_name &&
      crc = old_crc &&
      cmi.cmi_crcs = rest &&
      cmi_flags = cmi.cmi_flags -> 
      crc 
  | _ -> 
      let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in
      let oc = open_out_bin filename in 
      output_string oc content;
      output_value oc crcs;
      output_value oc cmi.cmi_flags;
      close_out oc; 
      crc



  
(* Error report *)

open Format

let report_error ppf = function
  | Not_an_interface filename ->
      fprintf ppf "%a@ is not a compiled interface"
        Location.print_filename filename
  | Wrong_version_interface (filename, older_newer) ->
      fprintf ppf
        "%a@ is not a compiled interface for this version of OCaml.@.\
         It seems to be for %s version of OCaml."
        Location.print_filename filename older_newer
  | Corrupted_interface filename ->
      fprintf ppf "Corrupted compiled interface@ %a"
        Location.print_filename filename

let () =
  Location.register_error_of_exn
    (function
      | Error err -> Some (Location.error_of_printer_file report_error err)
      | _ -> None
    )

end
module Ccomp : sig 
#1 "ccomp.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Compiling C files and building C libraries *)

val command: string -> int
val run_command: string -> unit
val compile_file: ?output:string -> ?opt:string -> string -> int
val create_archive: string -> string list -> int
val expand_libname: string -> string
val quote_files: string list -> string
val quote_optfile: string option -> string
(*val make_link_options: string list -> string*)

type link_mode =
  | Exe
  | Dll
  | MainDll
  | Partial

val call_linker: link_mode -> string -> string list -> string -> bool

end = struct
#1 "ccomp.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Compiling C files and building C libraries *)

let command cmdline =
  if !Clflags.verbose then begin
    prerr_string "+ ";
    prerr_string cmdline;
    prerr_newline()
  end;
  Sys.command cmdline

let run_command cmdline = ignore(command cmdline)

(* Build @responsefile to work around Windows limitations on
   command-line length *)
let build_diversion lst =
  let (responsefile, oc) = Filename.open_temp_file "camlresp" "" in
  List.iter (fun f -> Printf.fprintf oc "%s\n" f) lst;
  close_out oc;
  at_exit (fun () -> Misc.remove_file responsefile);
  "@" ^ responsefile

let quote_files lst =
  let lst = List.filter (fun f -> f <> "") lst in
  let quoted = List.map Filename.quote lst in
  let s = String.concat " " quoted in
  if String.length s >= 4096 && Sys.os_type = "Win32"
  then build_diversion quoted
  else s

let quote_prefixed pr lst =
  let lst = List.filter (fun f -> f <> "") lst in
  let lst = List.map (fun f -> pr ^ f) lst in
  quote_files lst

let quote_optfile = function
  | None -> ""
  | Some f -> Filename.quote f

let display_msvc_output file name =
  let c = open_in file in
  try
    let first = input_line c in
    if first <> Filename.basename name then
      print_string first;
    while true do
      print_string (input_line c)
    done
  with _ ->
    close_in c;
    Sys.remove file

let compile_file ?output ?(opt="") name =
  let (pipe, file) =
    if Config.ccomp_type = "msvc" && not !Clflags.verbose then
      try
        let (t, c) = Filename.open_temp_file "msvc" "stdout" in
        close_out c;
        (Printf.sprintf " > %s" (Filename.quote t), t)
      with _ ->
        ("", "")
    else
      ("", "") in
  let exit =
    command
      (Printf.sprintf
         "%s %s %s -c %s %s %s %s %s%s"
         (match !Clflags.c_compiler with
          | Some cc -> cc
          | None ->
              let (cflags, cppflags) =
                  if !Clflags.native_code
                  then (Config.ocamlopt_cflags, Config.ocamlopt_cppflags)
                  else (Config.ocamlc_cflags, Config.ocamlc_cppflags) in
              (String.concat " " [Config.c_compiler; cflags; cppflags]))
         (match output with
          | None -> ""
          | Some o -> Printf.sprintf "%s%s" Config.c_output_obj o)
         opt
         (if !Clflags.debug && Config.ccomp_type <> "msvc" then "-g" else "")
         (String.concat " " (List.rev !Clflags.all_ccopts))
         (quote_prefixed "-I" (List.rev !Clflags.include_dirs))
         (Clflags.std_include_flag "-I")
         (Filename.quote name)
         (* cl tediously includes the name of the C file as the first thing it
            outputs (in fairness, the tedious thing is that there's no switch to
            disable this behaviour). In the absence of the Unix module, use
            a temporary file to filter the output (cannot pipe the output to a
            filter because this removes the exit status of cl, which is wanted.
          *)
         pipe) in
  if pipe <> ""
  then display_msvc_output file name;
  exit

let macos_create_empty_archive ~quoted_archive =
  let result =
    command (Printf.sprintf "%s rc %s /dev/null" Config.ar quoted_archive)
  in
  if result <> 0 then result
  else
    let result =
      command (Printf.sprintf "%s %s 2> /dev/null" Config.ranlib quoted_archive)
    in
    if result <> 0 then result
    else
      command (Printf.sprintf "%s d %s /dev/null" Config.ar quoted_archive)

let create_archive archive file_list =
  Misc.remove_file archive;
  let quoted_archive = Filename.quote archive in
  match Config.ccomp_type with
    "msvc" ->
      command(Printf.sprintf "link /lib /nologo /out:%s %s"
                             quoted_archive (quote_files file_list))
  | _ ->
      assert(String.length Config.ar > 0);
      let is_macosx =
        match Config.system with
        | "macosx" -> true
        | _ -> false
      in
      if is_macosx && file_list = [] then  (* PR#6550 *)
        macos_create_empty_archive ~quoted_archive
      else
        let r1 =
          command(Printf.sprintf "%s rc %s %s"
                  Config.ar quoted_archive (quote_files file_list)) in
        if r1 <> 0 || String.length Config.ranlib = 0
        then r1
        else command(Config.ranlib ^ " " ^ quoted_archive)

let expand_libname name =
  if String.length name < 2 || String.sub name 0 2 <> "-l"
  then name
  else begin
    let libname =
      "lib" ^ String.sub name 2 (String.length name - 2) ^ Config.ext_lib in
    try
      Misc.find_in_path !Config.load_path libname
    with Not_found ->
      libname
  end

type link_mode =
  | Exe
  | Dll
  | MainDll
  | Partial

let remove_Wl cclibs =
  cclibs |> List.map (fun cclib ->
    (* -Wl,-foo,bar -> -foo bar *)
    if String.length cclib >= 4 && "-Wl," = String.sub cclib 0 4 then
      String.map (function ',' -> ' ' | c -> c)
                 (String.sub cclib 4 (String.length cclib - 4))
    else cclib)

let call_linker mode output_name files extra =
  let cmd =
    if mode = Partial then
      let l_prefix =
        match Config.ccomp_type with
        | "msvc" -> "/libpath:"
        | _ -> "-L"
      in
      Printf.sprintf "%s%s %s %s %s"
        Config.native_pack_linker
        (Filename.quote output_name)
        (quote_prefixed l_prefix !Config.load_path)
        (quote_files (remove_Wl files))
        extra
    else
      Printf.sprintf "%s -o %s %s %s %s %s %s %s"
        (match !Clflags.c_compiler, mode with
        | Some cc, _ -> cc
        | None, Exe -> Config.mkexe
        | None, Dll -> Config.mkdll
        | None, MainDll -> Config.mkmaindll
        | None, Partial -> assert false
        )
        (Filename.quote output_name)
        (if !Clflags.gprofile then Config.cc_profile else "")
        ""  (*(Clflags.std_include_flag "-I")*)
        (quote_prefixed "-L" !Config.load_path)
        (String.concat " " (List.rev !Clflags.all_ccopts))
        (quote_files files)
        extra
  in
  command cmd = 0

end
module Compenv : sig 
#1 "compenv.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*       Fabrice Le Fessant, EPI Gallium, INRIA Paris-Rocquencourt        *)
(*                                                                        *)
(*   Copyright 2013 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

val module_of_filename : Format.formatter -> string -> string -> string

val output_prefix : string -> string
val extract_output : string option -> string
val default_output : string option -> string

val print_version_and_library : string -> 'a
val print_version_string : unit -> 'a
val print_standard_library : unit -> 'a
val fatal : string -> 'a

val first_ccopts : string list ref
val first_ppx : string list ref
val first_include_dirs : string list ref
val last_include_dirs : string list ref
val implicit_modules : string list ref

(* function to call on plugin=XXX *)
val load_plugin : (string -> unit) ref

(* return the list of objfiles, after OCAMLPARAM and List.rev *)
val get_objfiles : with_ocamlparam:bool -> string list
val last_objfiles : string list ref
val first_objfiles : string list ref

type filename = string

type readenv_position =
  Before_args | Before_compile of filename | Before_link

val readenv : Format.formatter -> readenv_position -> unit

(* [is_unit_name name] returns true only if [name] can be used as a
   correct module name *)
val is_unit_name : string -> bool
(* [check_unit_name ppf filename name] prints a warning in [filename]
   on [ppf] if [name] should not be used as a module name. *)
val check_unit_name : Format.formatter -> string -> string -> unit

(* Deferred actions of the compiler, while parsing arguments *)

type deferred_action =
  | ProcessImplementation of string
  | ProcessInterface of string
  | ProcessCFile of string
  | ProcessOtherFile of string
  | ProcessObjects of string list
  | ProcessDLLs of string list

val c_object_of_filename : string -> string

val defer : deferred_action -> unit
val anonymous : string -> unit
val impl : string -> unit
val intf : string -> unit

val process_deferred_actions :
  Format.formatter *
  (Format.formatter -> string -> string -> unit) * (* compile implementation *)
  (Format.formatter -> string -> string -> unit) * (* compile interface *)
  string * (* ocaml module extension *)
  string -> (* ocaml library extension *)
  unit

end = struct
#1 "compenv.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*       Fabrice Le Fessant, EPI Gallium, INRIA Paris-Rocquencourt        *)
(*                                                                        *)
(*   Copyright 2013 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Clflags

let output_prefix name =
  let oname =
    match !output_name with
    | None -> name
    | Some n -> if !compile_only then (output_name := None; n) else name in
  Filename.remove_extension oname

let print_version_and_library compiler =
  Printf.printf "The OCaml %s, version " compiler;
  print_string Config.version; print_newline();
  print_string "Standard library directory: ";
  print_string Config.standard_library; print_newline();
  exit 0

let print_version_string () =
  print_string Config.version; print_newline(); exit 0

let print_standard_library () =
  print_string Config.standard_library; print_newline(); exit 0

let fatal err =
  prerr_endline err;
  exit 2

let extract_output = function
  | Some s -> s
  | None ->
      fatal "Please specify the name of the output file, using option -o"

let default_output = function
  | Some s -> s
  | None -> Config.default_executable_name

let implicit_modules = ref []
let first_include_dirs = ref []
let last_include_dirs = ref []
let first_ccopts = ref []
let last_ccopts = ref []
let first_ppx = ref []
let last_ppx = ref []
let first_objfiles = ref []
let last_objfiles = ref []

(* Check validity of module name *)
let is_unit_name name =
  try
    if name = "" then raise Exit;
    begin match name.[0] with
    | 'A'..'Z' -> ()
    | _ ->
       raise Exit;
    end;
    for i = 1 to String.length name - 1 do
      match name.[i] with
      | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '\'' -> ()
      | _ ->
         raise Exit;
    done;
    true
  with Exit -> false
;;

let check_unit_name ppf filename name =

    let _ = ppf in
    let _ = filename in
    let _ = name in 
    ()


(* Compute name of module from output file name *)
let module_of_filename ppf inputfile outputprefix =
  let basename = Filename.basename outputprefix in
  let name =
    try
      let pos = String.index basename '.' in
      String.sub basename 0 pos
    with Not_found -> basename
  in
  let name = String.capitalize_ascii name in
  check_unit_name ppf inputfile name;
  name
;;

type filename = string

type readenv_position =
  Before_args | Before_compile of filename | Before_link

(* Syntax of OCAMLPARAM: (name=VALUE,)* _ (,name=VALUE)*
   where VALUE should not contain ',' *)
exception SyntaxError of string

let parse_args s =
  let args = String.split_on_char ',' s in
  let rec iter is_after args before after =
    match args with
      [] ->
      if not is_after then
        raise (SyntaxError "no '_' separator found")
      else
      (List.rev before, List.rev after)
    | "_" :: _ when is_after -> raise (SyntaxError "too many '_' separators")
    | "_" :: tail -> iter true tail before after
    | arg :: tail ->
      let binding = try
        Misc.cut_at arg '='
      with Not_found ->
        raise (SyntaxError ("missing '=' in " ^ arg))
      in
      if is_after then
        iter is_after tail before (binding :: after)
      else
        iter is_after tail (binding :: before) after
  in
  iter false args [] []

let setter ppf f name options s =
  try
    let bool = match s with
      | "0" -> false
      | "1" -> true
      | _ -> raise Not_found
    in
    List.iter (fun b -> b := f bool) options
  with Not_found ->
    Location.print_warning Location.none ppf
      (Warnings.Bad_env_variable ("OCAMLPARAM",
                                  Printf.sprintf "bad value for %s" name))

let int_setter ppf name option s =
  try
    option := int_of_string s
  with _ ->
    Location.print_warning Location.none ppf
      (Warnings.Bad_env_variable
         ("OCAMLPARAM", Printf.sprintf "non-integer parameter for \"%s\"" name))

let int_option_setter ppf name option s =
  try
    option := Some (int_of_string s)
  with _ ->
    Location.print_warning Location.none ppf
      (Warnings.Bad_env_variable
         ("OCAMLPARAM", Printf.sprintf "non-integer parameter for \"%s\"" name))

(*
let float_setter ppf name option s =
  try
    option := float_of_string s
  with _ ->
    Location.print_warning Location.none ppf
      (Warnings.Bad_env_variable
         ("OCAMLPARAM", Printf.sprintf "non-float parameter for \"%s\"" name))
*)

let load_plugin = ref (fun _ -> ())

let check_bool ppf name s =
  match s with
  | "0" -> false
  | "1" -> true
  | _ ->
    Location.print_warning Location.none ppf
      (Warnings.Bad_env_variable ("OCAMLPARAM",
                                  Printf.sprintf "bad value for %s" name));
    false

(* 'can-discard=' specifies which arguments can be discarded without warning
   because they are not understood by some versions of OCaml. *)
let can_discard = ref []

let read_one_param ppf position name v =
  let set name options s =  setter ppf (fun b -> b) name options s in
  let clear name options s = setter ppf (fun b -> not b) name options s in
  match name with
  | "g" -> set "g" [ Clflags.debug ] v
  | "p" -> set "p" [ Clflags.gprofile ] v
  | "bin-annot" -> set "bin-annot" [ Clflags.binary_annotations ] v
  | "afl-instrument" -> set "afl-instrument" [ Clflags.afl_instrument ] v
  | "afl-inst-ratio" ->
      int_setter ppf "afl-inst-ratio" afl_inst_ratio v
  | "annot" -> set "annot" [ Clflags.annotations ] v
  | "absname" -> set "absname" [ Location.absname ] v
  | "compat-32" -> set "compat-32" [ bytecode_compatible_32 ] v
  | "noassert" -> set "noassert" [ noassert ] v
  | "noautolink" -> set "noautolink" [ no_auto_link ] v
  | "nostdlib" -> set "nostdlib" [ no_std_include ] v
  | "linkall" -> set "linkall" [ link_everything ] v
  | "nolabels" -> set "nolabels" [ classic ] v
  | "principal" -> set "principal"  [ principal ] v
  | "rectypes" -> set "rectypes" [ recursive_types ] v
  | "safe-string" -> clear "safe-string" [ unsafe_string ] v
  | "strict-sequence" -> set "strict-sequence" [ strict_sequence ] v
  | "strict-formats" -> set "strict-formats" [ strict_formats ] v
  | "thread" -> set "thread" [ use_threads ] v
  | "unboxed-types" -> set "unboxed-types" [ unboxed_types ] v
  | "unsafe" -> set "unsafe" [ fast ] v
  | "verbose" -> set "verbose" [ verbose ] v
  | "nopervasives" -> set "nopervasives" [ nopervasives ] v
  | "slash" -> set "slash" [ force_slash ] v (* for ocamldep *)
  | "keep-docs" -> set "keep-docs" [ Clflags.keep_docs ] v
  | "keep-locs" -> set "keep-locs" [ Clflags.keep_locs ] v

  | "compact" -> clear "compact" [ optimize_for_speed ] v
  | "no-app-funct" -> clear "no-app-funct" [ applicative_functors ] v
  | "nodynlink" -> clear "nodynlink" [ dlcode ] v
  | "short-paths" -> clear "short-paths" [ real_paths ] v
  | "trans-mod" -> set "trans-mod" [ transparent_modules ] v
  | "opaque" -> set "opaque" [ opaque ] v

  | "pp" -> preprocessor := Some v
  | "runtime-variant" -> runtime_variant := v
  | "cc" -> c_compiler := Some v

  | "clambda-checks" -> set "clambda-checks" [ clambda_checks ] v

  (* assembly sources *)
  |  "s" ->
    set "s" [ Clflags.keep_asm_file ; Clflags.keep_startup_file ] v
  |  "S" -> set "S" [ Clflags.keep_asm_file ] v
  |  "dstartup" -> set "dstartup" [ Clflags.keep_startup_file ] v

  (* warn-errors *)
  | "we" | "warn-error" -> Warnings.parse_options true v
  (* warnings *)
  |  "w"  ->               Warnings.parse_options false v
  (* warn-errors *)
  | "wwe" ->               Warnings.parse_options false v

  (* inlining *)
  | "inline" ->
      let module F = Float_arg_helper in
      begin match F.parse_no_error v inline_threshold with
      | F.Ok -> ()
      | F.Parse_failed exn ->
          let error =
            Printf.sprintf "bad syntax for \"inline\": %s"
              (Printexc.to_string exn)
          in
          Location.print_warning Location.none ppf
            (Warnings.Bad_env_variable ("OCAMLPARAM", error))
      end

  | "inline-toplevel" ->
    Int_arg_helper.parse v
      "Bad syntax in OCAMLPARAM for 'inline-toplevel'"
      inline_toplevel_threshold

  | "rounds" -> int_option_setter ppf "rounds" simplify_rounds v
  | "inline-max-unroll" ->
    Int_arg_helper.parse v "Bad syntax in OCAMLPARAM for 'inline-max-unroll'"
      inline_max_unroll
  | "inline-call-cost" ->
    Int_arg_helper.parse v
      "Bad syntax in OCAMLPARAM for 'inline-call-cost'"
      inline_call_cost
  | "inline-alloc-cost" ->
    Int_arg_helper.parse v
      "Bad syntax in OCAMLPARAM for 'inline-alloc-cost'"
      inline_alloc_cost
  | "inline-prim-cost" ->
    Int_arg_helper.parse v
      "Bad syntax in OCAMLPARAM for 'inline-prim-cost'"
      inline_prim_cost
  | "inline-branch-cost" ->
    Int_arg_helper.parse v
      "Bad syntax in OCAMLPARAM for 'inline-branch-cost'"
      inline_branch_cost
  | "inline-indirect-cost" ->
    Int_arg_helper.parse v
      "Bad syntax in OCAMLPARAM for 'inline-indirect-cost'"
      inline_indirect_cost
  | "inline-lifting-benefit" ->
    Int_arg_helper.parse v
      "Bad syntax in OCAMLPARAM for 'inline-lifting-benefit'"
      inline_lifting_benefit
  | "inline-branch-factor" ->
    Float_arg_helper.parse v
      "Bad syntax in OCAMLPARAM for 'inline-branch-factor'"
      inline_branch_factor
  | "inline-max-depth" ->
    Int_arg_helper.parse v
      "Bad syntax in OCAMLPARAM for 'inline-max-depth'"
      inline_max_depth

  | "Oclassic" ->
      set "Oclassic" [ classic_inlining ] v
  | "O2" ->
    if check_bool ppf "O2" v then begin
      default_simplify_rounds := 2;
      use_inlining_arguments_set o2_arguments;
      use_inlining_arguments_set ~round:0 o1_arguments
    end

  | "O3" ->
    if check_bool ppf "O3" v then begin
      default_simplify_rounds := 3;
      use_inlining_arguments_set o3_arguments;
      use_inlining_arguments_set ~round:1 o2_arguments;
      use_inlining_arguments_set ~round:0 o1_arguments
    end
  | "unbox-closures" ->
      set "unbox-closures" [ unbox_closures ] v
  | "unbox-closures-factor" ->
      int_setter ppf "unbox-closures-factor" unbox_closures_factor v
  | "remove-unused-arguments" ->
      set "remove-unused-arguments" [ remove_unused_arguments ] v

  | "inlining-report" ->
      if !native_code then
        set "inlining-report" [ inlining_report ] v

  | "flambda-verbose" ->
      set "flambda-verbose" [ dump_flambda_verbose ] v
  | "flambda-invariants" ->
      set "flambda-invariants" [ flambda_invariant_checks ] v

  (* color output *)
  | "color" ->
      begin match parse_color_setting v with
      | None ->
        Location.print_warning Location.none ppf
          (Warnings.Bad_env_variable ("OCAMLPARAM",
           "bad value for \"color\", \
            (expected \"auto\", \"always\" or \"never\")"))
      | Some setting -> color := Some setting
      end

  | "intf-suffix" -> Config.interface_suffix := v

  | "I" -> begin
      match position with
      | Before_args -> first_include_dirs := v :: !first_include_dirs
      | Before_link | Before_compile _ ->
        last_include_dirs := v :: !last_include_dirs
    end

  | "cclib" ->
    begin
      match position with
      | Before_compile _ -> ()
      | Before_link | Before_args ->
        ccobjs := Misc.rev_split_words v @ !ccobjs
    end

  | "ccopts" ->
    begin
      match position with
      | Before_link | Before_compile _ ->
        last_ccopts := v :: !last_ccopts
      | Before_args ->
        first_ccopts := v :: !first_ccopts
    end

  | "ppx" ->
    begin
      match position with
      | Before_link | Before_compile _ ->
        last_ppx := v :: !last_ppx
      | Before_args ->
        first_ppx := v :: !first_ppx
    end


  | "cmo" | "cma" ->
    if not !native_code then
    begin
      match position with
      | Before_link | Before_compile _ ->
        last_objfiles := v ::! last_objfiles
      | Before_args ->
        first_objfiles := v :: !first_objfiles
    end

  | "cmx" | "cmxa" ->
    if !native_code then
    begin
      match position with
      | Before_link | Before_compile _ ->
        last_objfiles := v ::! last_objfiles
      | Before_args ->
        first_objfiles := v :: !first_objfiles
    end

  | "pic" ->
    if !native_code then
      set "pic" [ pic_code ] v

  | "can-discard" ->
    can_discard := v ::!can_discard

  | "timings" | "profile" ->
     let if_on = if name = "timings" then [ `Time ] else Profile.all_columns in
     profile_columns := if check_bool ppf name v then if_on else []

  | "plugin" -> !load_plugin v

  | _ ->
    if not (List.mem name !can_discard) then begin
      can_discard := name :: !can_discard;
      Printf.eprintf
        "Warning: discarding value of variable %S in OCAMLPARAM\n%!"
        name
    end

let read_OCAMLPARAM ppf position =
  try
    let s = Sys.getenv "OCAMLPARAM" in
    let (before, after) =
      try
        parse_args s
      with SyntaxError s ->
         Location.print_warning Location.none ppf
           (Warnings.Bad_env_variable ("OCAMLPARAM", s));
         [],[]
    in
    List.iter (fun (name, v) -> read_one_param ppf position name v)
      (match position with
         Before_args -> before
       | Before_compile _ | Before_link -> after)
  with Not_found -> ()

(* OCAMLPARAM passed as file *)

type pattern =
  | Filename of string
  | Any

type file_option = {
  pattern : pattern;
  name : string;
  value : string;
}

let scan_line ic =
  Scanf.bscanf ic "%[0-9a-zA-Z_.*] : %[a-zA-Z_-] = %s "
    (fun pattern name value ->
       let pattern =
         match pattern with
         | "*" -> Any
         | _ -> Filename pattern
       in
       { pattern; name; value })

let load_config ppf filename =
  match open_in_bin filename with
  | exception e ->
      Location.print_error ppf (Location.in_file filename);
      Format.fprintf ppf "Cannot open file %s@." (Printexc.to_string e);
      raise Exit
  | ic ->
      let sic = Scanf.Scanning.from_channel ic in
      let rec read line_number line_start acc =
        match scan_line sic with
        | exception End_of_file ->
            close_in ic;
            acc
        | exception Scanf.Scan_failure error ->
            let position = Lexing.{
                pos_fname = filename;
                pos_lnum = line_number;
                pos_bol = line_start;
                pos_cnum = pos_in ic;
              }
            in
            let loc = Location.{
                loc_start = position;
                loc_end = position;
                loc_ghost = false;
              }
            in
            Location.print_error ppf loc;
            Format.fprintf ppf "Configuration file error %s@." error;
            close_in ic;
            raise Exit
        | line ->
            read (line_number + 1) (pos_in ic) (line :: acc)
      in
      let lines = read 0 0 [] in
      lines

let matching_filename filename { pattern } =
  match pattern with
  | Any -> true
  | Filename pattern ->
    let filename = String.lowercase_ascii filename in
    let pattern = String.lowercase_ascii pattern in
    filename = pattern

let apply_config_file ppf position =
  let config_file =
    Filename.concat Config.standard_library "ocaml_compiler_internal_params"
  in
  let config =
    if Sys.file_exists config_file then
      load_config ppf config_file
    else
      []
  in
  let config =
    match position with
    | Before_compile filename ->
      List.filter (matching_filename filename) config
    | Before_args | Before_link ->
      List.filter (fun { pattern } -> pattern = Any) config
  in
  List.iter (fun { name; value } -> read_one_param ppf position name value)
    config

let readenv ppf position =
  last_include_dirs := [];
  last_ccopts := [];
  last_ppx := [];
  last_objfiles := [];
  apply_config_file ppf position;
  read_OCAMLPARAM ppf position;
  all_ccopts := !last_ccopts @ !first_ccopts;
  all_ppx := !last_ppx @ !first_ppx

let get_objfiles ~with_ocamlparam =
  if with_ocamlparam then
    List.rev (!last_objfiles @ !objfiles @ !first_objfiles)
  else
    List.rev !objfiles






type deferred_action =
  | ProcessImplementation of string
  | ProcessInterface of string
  | ProcessCFile of string
  | ProcessOtherFile of string
  | ProcessObjects of string list
  | ProcessDLLs of string list

let c_object_of_filename name =
  Filename.chop_suffix (Filename.basename name) ".c" ^ Config.ext_obj

let process_action
    (ppf, implementation, interface, ocaml_mod_ext, ocaml_lib_ext) action =
  match action with
  | ProcessImplementation name ->
      readenv ppf (Before_compile name);
      let opref = output_prefix name in
      implementation ppf name opref;
      objfiles := (opref ^ ocaml_mod_ext) :: !objfiles
  | ProcessInterface name ->
      readenv ppf (Before_compile name);
      let opref = output_prefix name in
      interface ppf name opref;
      if !make_package then objfiles := (opref ^ ".cmi") :: !objfiles
  | ProcessCFile name ->
      readenv ppf (Before_compile name);
      Location.input_name := name;
      if Ccomp.compile_file name <> 0 then exit 2;
      ccobjs := c_object_of_filename name :: !ccobjs
  | ProcessObjects names ->
      ccobjs := names @ !ccobjs
  | ProcessDLLs names ->
      dllibs := names @ !dllibs
  | ProcessOtherFile name ->
      if Filename.check_suffix name ocaml_mod_ext
      || Filename.check_suffix name ocaml_lib_ext then
        objfiles := name :: !objfiles
      else if Filename.check_suffix name ".cmi" && !make_package then
        objfiles := name :: !objfiles
      else if Filename.check_suffix name Config.ext_obj
           || Filename.check_suffix name Config.ext_lib then
        ccobjs := name :: !ccobjs
      else if not !native_code && Filename.check_suffix name Config.ext_dll then
        dllibs := name :: !dllibs
      else
        raise(Arg.Bad("don't know what to do with " ^ name))


let action_of_file name =
  if Filename.check_suffix name ".ml"
  || Filename.check_suffix name ".mlt" then
    ProcessImplementation name
  else if Filename.check_suffix name !Config.interface_suffix then
    ProcessInterface name
  else if Filename.check_suffix name ".c" then
    ProcessCFile name
  else
    ProcessOtherFile name

let deferred_actions = ref []
let defer action =
  deferred_actions := action :: !deferred_actions

let anonymous filename = defer (action_of_file filename)
let impl filename = defer (ProcessImplementation filename)
let intf filename = defer (ProcessInterface filename)

let process_deferred_actions env =
  let final_output_name = !output_name in
  (* Make sure the intermediate products don't clash with the final one
     when we're invoked like: ocamlopt -o foo bar.c baz.ml. *)
  if not !compile_only then output_name := None;
  begin
    match final_output_name with
    | None -> ()
    | Some output_name ->
        if !compile_only then begin
          if List.filter (function
              | ProcessCFile name -> c_object_of_filename name <> output_name
              | _ -> false) !deferred_actions <> [] then
            fatal "Options -c and -o are incompatible when compiling C files";

          if List.length (List.filter (function
              | ProcessImplementation _
              | ProcessInterface _
              | _ -> false) !deferred_actions) > 1 then
            fatal "Options -c -o are incompatible with compiling multiple files"
        end;
  end;
  if !make_archive && List.exists (function
      | ProcessOtherFile name -> Filename.check_suffix name ".cmxa"
      | _ -> false) !deferred_actions then
    fatal "Option -a cannot be used with .cmxa input files.";
  List.iter (process_action env) (List.rev !deferred_actions);
  output_name := final_output_name;

end
module Ext_pervasives : sig 
#1 "ext_pervasives.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Extension to standard library [Pervavives] module, safe to open 
  *)

external reraise: exn -> 'a = "%reraise"

val finally : 
  'a ->
  clean:('a -> 'c) -> 
  ('a -> 'b) -> 'b

val try_it : (unit -> 'a) ->  unit 

val with_file_as_chan : string -> (out_channel -> 'a) -> 'a













external id : 'a -> 'a = "%identity"

(** Copied from {!Btype.hash_variant}:
    need sync up and add test case
 *)
val hash_variant : string -> int

val todo : string -> 'a

val nat_of_string_exn : string -> int

val parse_nat_of_string:
  string -> 
  int ref -> 
  int 
end = struct
#1 "ext_pervasives.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






external reraise: exn -> 'a = "%reraise"

let finally v ~clean:action f   = 
  match f v with
  | exception e -> 
      action v ;
      reraise e 
  | e ->  action v ; e 

let try_it f  =   
  try ignore (f ()) with _ -> ()

let with_file_as_chan filename f = 
  finally (open_out_bin filename) ~clean:close_out f 






external id : 'a -> 'a = "%identity"


let hash_variant s =
  let accu = ref 0 in
  for i = 0 to String.length s - 1 do
    accu := 223 * !accu + Char.code s.[i]
  done;
  (* reduce to 31 bits *)
  accu := !accu land (1 lsl 31 - 1);
  (* make it signed for 64 bits architectures *)
  if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu

let todo loc = 
  failwith (loc ^ " Not supported yet")




let rec int_of_string_aux s acc off len =  
  if off >= len then acc 
  else 
    let d = (Char.code (String.unsafe_get s off) - 48) in 
    if d >=0 && d <= 9 then 
      int_of_string_aux s (10*acc + d) (off + 1) len
    else -1 (* error *)

let nat_of_string_exn (s : string) = 
  let acc = int_of_string_aux s 0 0 (String.length s) in 
  if acc < 0 then invalid_arg s 
  else acc 


(** return index *)
let parse_nat_of_string (s : string) (cursor : int ref) =  
  let current = !cursor in 
  assert (current >= 0);
  let acc = ref 0 in 
  let s_len = String.length s in 
  let todo = ref true in 
  let cur = ref current in 
  while !todo && !cursor < s_len do 
    let d = Char.code (String.unsafe_get s !cur) - 48 in 
    if d >=0 && d <= 9 then begin 
      acc := 10* !acc + d;
      incr cur
    end else todo := false
  done ;
  cursor := !cur;
  !acc 
end
module Ext_io : sig 
#1 "ext_io.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

val load_file : string -> string

val rev_lines_of_file : string -> string list

val rev_lines_of_chann : in_channel -> string list

val write_file : string -> string -> unit

end = struct
#1 "ext_io.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


(** on 32 bit , there are 16M limitation *)
let load_file f =
  Ext_pervasives.finally (open_in_bin f) ~clean:close_in begin fun ic ->   
    let n = in_channel_length ic in
    let s = Bytes.create n in
    really_input ic s 0 n;
    Bytes.unsafe_to_string s
  end


let  rev_lines_of_chann chan = 
    let rec loop acc chan = 
      match input_line chan with
      | line -> loop (line :: acc) chan
      | exception End_of_file -> close_in chan ; acc in
    loop [] chan


let rev_lines_of_file file = 
  Ext_pervasives.finally 
    ~clean:close_in 
    (open_in_bin file) rev_lines_of_chann


let write_file f content = 
  Ext_pervasives.finally ~clean:close_out 
    (open_out_bin f)  begin fun oc ->   
    output_string oc content
  end

end
module Bs_exception : sig 
#1 "bs_exception.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type error =
  | Cmj_not_found of string
  | Js_not_found of string
  | Bs_cyclic_depends of string  list
  | Bs_duplicated_module of string * string
  | Bs_duplicate_exports of string (* gpr_974 *)
  | Bs_package_not_found of string                                                        
  | Bs_main_not_exist of string 
  | Bs_invalid_path of string
  | Missing_ml_dependency of string 
  | Dependency_script_module_dependent_not  of string
(*
TODO: In the futrue, we should refine dependency [bsb] 
should not rely on such exception, it should have its own exception handling
*)

(* exception Error of error *)

(* val report_error : Format.formatter -> error -> unit *)

val error : error -> 'a 

end = struct
#1 "bs_exception.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


type error =
  | Cmj_not_found of string
  | Js_not_found of string 
  | Bs_cyclic_depends of string  list
  | Bs_duplicated_module of string * string
  | Bs_duplicate_exports of string (* gpr_974 *)
  | Bs_package_not_found of string                            
  | Bs_main_not_exist of string 
  | Bs_invalid_path of string
  | Missing_ml_dependency of string 
  | Dependency_script_module_dependent_not  of string 
  (** TODO: we need add location handling *)    
exception Error of error

let error err = raise (Error err)

let report_error ppf = function
  | Dependency_script_module_dependent_not s
    -> 
    Format.fprintf ppf 
      "%s is compiled in script mode while its dependent is not"
      s
  | Missing_ml_dependency s -> 
    Format.fprintf ppf "Missing dependency %s in search path" s 
  | Cmj_not_found s ->
    Format.fprintf ppf "%s not found, it means either the module does not exist or it is a namespace" s
  | Js_not_found s -> 
    Format.fprintf ppf "%s not found, needed in script mode " s
  | Bs_cyclic_depends  str
    ->
    Format.fprintf ppf "Cyclic depends : @[%a@]"
      (Format.pp_print_list ~pp_sep:Format.pp_print_space
         Format.pp_print_string)
      str
  | Bs_duplicate_exports str -> 
    Format.fprintf ppf "%s are exported as twice" str 
  | Bs_duplicated_module (a,b)
    ->
    Format.fprintf ppf "The build system does not support two files with same names yet %s, %s" a b
  | Bs_main_not_exist main
    ->
    Format.fprintf ppf "File %s not found " main

  | Bs_package_not_found package
    ->
    Format.fprintf ppf "Package %s not found or %s/lib/ocaml does not exist or please set npm_config_prefix correctly"
      package package
  | Bs_invalid_path path
    ->  Format.pp_print_string ppf ("Invalid path: " ^ path )


let () =
  Location.register_error_of_exn
    (function
      | Error err
        -> Some (Location.error_of_printer_file report_error err)
      | _ -> None
    )

end
module Builtin_attributes : sig 
#1 "builtin_attributes.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                         Alain Frisch, LexiFi                           *)
(*                                                                        *)
(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Support for some of the builtin attributes:

   ocaml.deprecated
   ocaml.error
   ocaml.ppwarning
   ocaml.warning
   ocaml.warnerror
   ocaml.explicit_arity (for camlp4/camlp5)
   ocaml.warn_on_literal_pattern
   ocaml.deprecated_mutable
   ocaml.immediate
   ocaml.boxed / ocaml.unboxed
*)


val check_deprecated: Location.t -> Parsetree.attributes -> string -> unit
val check_deprecated_inclusion:
  def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes ->
  Parsetree.attributes -> string -> unit
val deprecated_of_attrs: Parsetree.attributes -> string option
val deprecated_of_sig: Parsetree.signature -> string option
val deprecated_of_str: Parsetree.structure -> string option

val check_deprecated_mutable:
    Location.t -> Parsetree.attributes -> string -> unit
val check_deprecated_mutable_inclusion:
  def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes ->
  Parsetree.attributes -> string -> unit

val error_of_extension: Parsetree.extension -> Location.error

val warning_attribute: ?ppwarning:bool -> Parsetree.attribute -> unit
  (** Apply warning settings from the specified attribute.
      "ocaml.warning"/"ocaml.warnerror" (and variants without the prefix)
      are processed and other attributes are ignored.

      Also implement ocaml.ppwarning (unless ~ppwarning:false is
      passed).
  *)

val warning_scope:
  ?ppwarning:bool ->
  Parsetree.attributes -> (unit -> 'a) -> 'a
  (** Execute a function in a new scope for warning settings.  This
      means that the effect of any call to [warning_attribute] during
      the execution of this function will be discarded after
      execution.

      The function also takes a list of attributes which are processed
      with [warning_attribute] in the fresh scope before the function
      is executed.
  *)

val warn_on_literal_pattern: Parsetree.attributes -> bool
val explicit_arity: Parsetree.attributes -> bool


val immediate: Parsetree.attributes -> bool

val has_unboxed: Parsetree.attributes -> bool
val has_boxed: Parsetree.attributes -> bool

end = struct
#1 "builtin_attributes.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                         Alain Frisch, LexiFi                           *)
(*                                                                        *)
(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Asttypes
open Parsetree

let string_of_cst = function
  | Pconst_string(s, _) -> Some s
  | _ -> None

let string_of_payload = function
  | PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant c},_)}] ->
      string_of_cst c
  | _ -> None

let string_of_opt_payload p =
  match string_of_payload p with
  | Some s -> s
  | None -> ""

let rec error_of_extension ext =
  match ext with
  | ({txt = ("ocaml.error"|"error") as txt; loc}, p) ->
    let rec sub_from inner =
      match inner with
      | {pstr_desc=Pstr_extension (ext, _)} :: rest ->
          error_of_extension ext :: sub_from rest
      | _ :: rest ->
          (Location.errorf ~loc
             "Invalid syntax for sub-error of extension '%s'." txt) ::
            sub_from rest
      | [] -> []
    in
    begin match p with
    | PStr [] -> raise Location.Already_displayed_error
    | PStr({pstr_desc=Pstr_eval
              ({pexp_desc=Pexp_constant(Pconst_string(msg,_))}, _)}::
           {pstr_desc=Pstr_eval
              ({pexp_desc=Pexp_constant(Pconst_string(if_highlight,_))}, _)}::
           inner) ->
        Location.error ~loc ~if_highlight ~sub:(sub_from inner) msg
    | PStr({pstr_desc=Pstr_eval
              ({pexp_desc=Pexp_constant(Pconst_string(msg,_))}, _)}::inner) ->
        Location.error ~loc ~sub:(sub_from inner) msg
    | _ -> Location.errorf ~loc "Invalid syntax for extension '%s'." txt
    end
  | ({txt; loc}, _) ->
      Location.errorf ~loc "Uninterpreted extension '%s'." txt

let cat s1 s2 =
  if s2 = "" then s1 else
 
    if Clflags.bs_vscode then s1 ^ " " ^ s2
    else s1 ^ "\n" ^ s2 
    

let rec deprecated_of_attrs = function
  | [] -> None
  | ({txt = "ocaml.deprecated"|"deprecated"; _}, p) :: _ ->
      Some (string_of_opt_payload p)
  | _ :: tl -> deprecated_of_attrs tl

let check_deprecated loc attrs s =
  match deprecated_of_attrs attrs with
  | None -> ()
  | Some txt -> Location.deprecated loc (cat s txt)

let check_deprecated_inclusion ~def ~use loc attrs1 attrs2 s =
  match deprecated_of_attrs attrs1, deprecated_of_attrs attrs2 with
  | None, _ | Some _, Some _ -> ()
  | Some txt, None -> Location.deprecated ~def ~use loc (cat s txt)

let rec deprecated_mutable_of_attrs = function
  | [] -> None
  | ({txt = "ocaml.deprecated_mutable"|"deprecated_mutable"; _}, p) :: _ ->
      Some (string_of_opt_payload p)
  | _ :: tl -> deprecated_mutable_of_attrs tl

let check_deprecated_mutable loc attrs s =
  match deprecated_mutable_of_attrs attrs with
  | None -> ()
  | Some txt ->
      Location.deprecated loc (Printf.sprintf "mutating field %s" (cat s txt))

let check_deprecated_mutable_inclusion ~def ~use loc attrs1 attrs2 s =
  match deprecated_mutable_of_attrs attrs1,
        deprecated_mutable_of_attrs attrs2
  with
  | None, _ | Some _, Some _ -> ()
  | Some txt, None ->
      Location.deprecated ~def ~use loc
        (Printf.sprintf "mutating field %s" (cat s txt))

let rec deprecated_of_sig = function
  | {psig_desc = Psig_attribute a} :: tl ->
      begin match deprecated_of_attrs [a] with
      | None -> deprecated_of_sig tl
      | Some _ as r -> r
      end
  | _ -> None


let rec deprecated_of_str = function
  | {pstr_desc = Pstr_attribute a} :: tl ->
      begin match deprecated_of_attrs [a] with
      | None -> deprecated_of_str tl
      | Some _ as r -> r
      end
  | _ -> None


let warning_attribute ?(ppwarning = true) =
  let process loc txt errflag payload =
    match string_of_payload payload with
    | Some s ->
        begin try Warnings.parse_options errflag s
        with Arg.Bad _ ->
          Location.prerr_warning loc
            (Warnings.Attribute_payload
               (txt, "Ill-formed list of warnings"))
        end
    | None ->
        Location.prerr_warning loc
          (Warnings.Attribute_payload
             (txt, "A single string literal is expected"))
  in
  function
  | ({txt = ("ocaml.warning"|"warning") as txt; loc}, payload) ->
      process loc txt false payload
  | ({txt = ("ocaml.warnerror"|"warnerror") as txt; loc}, payload) ->
      process loc txt true payload
  | {txt="ocaml.ppwarning"|"ppwarning"},
    PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant
                                   (Pconst_string (s, _))},_);
          pstr_loc}] when ppwarning ->
      Location.prerr_warning pstr_loc (Warnings.Preprocessor s)
  | _ ->
      ()

let warning_scope ?ppwarning attrs f =
  let prev = Warnings.backup () in
  try
    List.iter (warning_attribute ?ppwarning) (List.rev attrs);
    let ret = f () in
    Warnings.restore prev;
    ret
  with exn ->
    Warnings.restore prev;
    raise exn


let warn_on_literal_pattern =
  List.exists
    (function
      | ({txt="ocaml.warn_on_literal_pattern"|"warn_on_literal_pattern"; _}, _)
        -> true
      | _ -> false
    )

let explicit_arity =
  List.exists
    (function
      | ({txt="ocaml.explicit_arity"|"explicit_arity"; _}, _) -> true
      | _ -> false
    )

let immediate =
  List.exists
    (function
      | ({txt="ocaml.immediate"|"immediate"; _}, _) -> true
      | _ -> false
    )

(* The "ocaml.boxed (default)" and "ocaml.unboxed (default)"
   attributes cannot be input by the user, they are added by the
   compiler when applying the default setting. This is done to record
   in the .cmi the default used by the compiler when compiling the
   source file because the default can change between compiler
   invocations. *)

let check l (x, _) = List.mem x.txt l

let has_unboxed attr =
  List.exists (check ["ocaml.unboxed"; "unboxed"])
    attr

let has_boxed attr =
  List.exists (check ["ocaml.boxed"; "boxed"]) attr

end
module Depend : sig 
#1 "depend.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Module dependencies. *)

module StringSet : Set.S with type elt = string
module StringMap : Map.S with type key = string

type map_tree = Node of StringSet.t * bound_map
and  bound_map = map_tree StringMap.t
val make_leaf : string -> map_tree
val make_node : bound_map -> map_tree
val weaken_map : StringSet.t -> map_tree -> map_tree

val free_structure_names : StringSet.t ref

(* dependencies found by preprocessing tools (plugins) *)
val pp_deps : string list ref

val open_module : bound_map -> Longident.t -> bound_map

val add_use_file : bound_map -> Parsetree.toplevel_phrase list -> unit

val add_signature : bound_map -> Parsetree.signature -> unit

val add_implementation : bound_map -> Parsetree.structure -> unit

val add_implementation_binding : bound_map -> Parsetree.structure -> bound_map
val add_signature_binding : bound_map -> Parsetree.signature -> bound_map

end = struct
#1 "depend.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Asttypes
open Location
open Longident
open Parsetree

let pp_deps = ref []

module StringSet = Set.Make(struct type t = string let compare = compare end)
module StringMap = Map.Make(String)

(* Module resolution map *)
(* Node (set of imports for this path, map for submodules) *)
type map_tree = Node of StringSet.t * bound_map
and  bound_map = map_tree StringMap.t
let bound = Node (StringSet.empty, StringMap.empty)

(*let get_free (Node (s, _m)) = s*)
let get_map (Node (_s, m)) = m
let make_leaf s = Node (StringSet.singleton s, StringMap.empty)
let make_node m =  Node (StringSet.empty, m)
let rec weaken_map s (Node(s0,m0)) =
  Node (StringSet.union s s0, StringMap.map (weaken_map s) m0)
let rec collect_free (Node (s, m)) =
  StringMap.fold (fun _ n -> StringSet.union (collect_free n)) m s

(* Returns the imports required to access the structure at path p *)
(* Only raises Not_found if the head of p is not in the toplevel map *)
let rec lookup_free p m =
  match p with
    [] -> raise Not_found
  | s::p ->
      let Node (f, m') = StringMap.find s m  in
      try lookup_free p m' with Not_found -> f

(* Returns the node corresponding to the structure at path p *)
let rec lookup_map lid m =
  match lid with
    Lident s    -> StringMap.find s m
  | Ldot (l, s) -> StringMap.find s (get_map (lookup_map l m))
  | Lapply _    -> raise Not_found

(* Collect free module identifiers in the a.s.t. *)

let free_structure_names = ref StringSet.empty

let add_names s =
  free_structure_names := StringSet.union s !free_structure_names

let rec add_path bv ?(p=[]) = function
  | Lident s ->
      let free =
        try lookup_free (s::p) bv with Not_found -> StringSet.singleton s
      in
      (*StringSet.iter (fun s -> Printf.eprintf "%s " s) free;
        prerr_endline "";*)
      add_names free
  | Ldot(l, s) -> add_path bv ~p:(s::p) l
  | Lapply(l1, l2) -> add_path bv l1; add_path bv l2

let open_module bv lid =
  match lookup_map lid bv with
  | Node (s, m) ->
      add_names s;
      StringMap.fold StringMap.add m bv
  | exception Not_found ->
      add_path bv lid; bv

let add_parent bv lid =
  match lid.txt with
    Ldot(l, _s) -> add_path bv l
  | _ -> ()

let add = add_parent

let addmodule bv lid = add_path bv lid.txt

let handle_extension ext =
  match (fst ext).txt with
  | "error" | "ocaml.error" ->
    raise (Location.Error
             (Builtin_attributes.error_of_extension ext))
  | _ ->
    ()

let rec add_type bv ty =
  match ty.ptyp_desc with
    Ptyp_any -> ()
  | Ptyp_var _ -> ()
  | Ptyp_arrow(_, t1, t2) -> add_type bv t1; add_type bv t2
  | Ptyp_tuple tl -> List.iter (add_type bv) tl
  | Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl
  | Ptyp_object (fl, _) ->
      List.iter
       (function Otag (_, _, t) -> add_type bv t
         | Oinherit t -> add_type bv t) fl
  | Ptyp_class(c, tl) -> add bv c; List.iter (add_type bv) tl
  | Ptyp_alias(t, _) -> add_type bv t
  | Ptyp_variant(fl, _, _) ->
      List.iter
        (function Rtag(_,_,_,stl) -> List.iter (add_type bv) stl
          | Rinherit sty -> add_type bv sty)
        fl
  | Ptyp_poly(_, t) -> add_type bv t
  | Ptyp_package pt -> add_package_type bv pt
  | Ptyp_extension e -> handle_extension e

and add_package_type bv (lid, l) =
  add bv lid;
  List.iter (add_type bv) (List.map (fun (_, e) -> e) l)

let add_opt add_fn bv = function
    None -> ()
  | Some x -> add_fn bv x

let add_constructor_arguments bv = function
  | Pcstr_tuple l -> List.iter (add_type bv) l
  | Pcstr_record l -> List.iter (fun l -> add_type bv l.pld_type) l

let add_constructor_decl bv pcd =
  add_constructor_arguments bv pcd.pcd_args;
  Misc.may (add_type bv) pcd.pcd_res

let add_type_declaration bv td =
  List.iter
    (fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2)
    td.ptype_cstrs;
  add_opt add_type bv td.ptype_manifest;
  let add_tkind = function
    Ptype_abstract -> ()
  | Ptype_variant cstrs ->
      List.iter (add_constructor_decl bv) cstrs
  | Ptype_record lbls ->
      List.iter (fun pld -> add_type bv pld.pld_type) lbls
  | Ptype_open -> () in
  add_tkind td.ptype_kind

let add_extension_constructor bv ext =
  match ext.pext_kind with
    Pext_decl(args, rty) ->
      add_constructor_arguments bv args;
      Misc.may (add_type bv) rty
  | Pext_rebind lid -> add bv lid

let add_type_extension bv te =
  add bv te.ptyext_path;
  List.iter (add_extension_constructor bv) te.ptyext_constructors

let rec add_class_type bv cty =
  match cty.pcty_desc with
    Pcty_constr(l, tyl) ->
      add bv l; List.iter (add_type bv) tyl
  | Pcty_signature { pcsig_self = ty; pcsig_fields = fieldl } ->
      add_type bv ty;
      List.iter (add_class_type_field bv) fieldl
  | Pcty_arrow(_, ty1, cty2) ->
      add_type bv ty1; add_class_type bv cty2
  | Pcty_extension e -> handle_extension e
  | Pcty_open (_ovf, m, e) ->
      let bv = open_module bv m.txt in add_class_type bv e

and add_class_type_field bv pctf =
  match pctf.pctf_desc with
    Pctf_inherit cty -> add_class_type bv cty
  | Pctf_val(_, _, _, ty) -> add_type bv ty
  | Pctf_method(_, _, _, ty) -> add_type bv ty
  | Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
  | Pctf_attribute _ -> ()
  | Pctf_extension e -> handle_extension e

let add_class_description bv infos =
  add_class_type bv infos.pci_expr

let add_class_type_declaration = add_class_description

let pattern_bv = ref StringMap.empty

let rec add_pattern bv pat =
  match pat.ppat_desc with
    Ppat_any -> ()
  | Ppat_var _ -> ()
  | Ppat_alias(p, _) -> add_pattern bv p
  | Ppat_interval _
  | Ppat_constant _ -> ()
  | Ppat_tuple pl -> List.iter (add_pattern bv) pl
  | Ppat_construct(c, op) -> add bv c; add_opt add_pattern bv op
  | Ppat_record(pl, _) ->
      List.iter (fun (lbl, p) -> add bv lbl; add_pattern bv p) pl
  | Ppat_array pl -> List.iter (add_pattern bv) pl
  | Ppat_or(p1, p2) -> add_pattern bv p1; add_pattern bv p2
  | Ppat_constraint(p, ty) -> add_pattern bv p; add_type bv ty
  | Ppat_variant(_, op) -> add_opt add_pattern bv op
  | Ppat_type li -> add bv li
  | Ppat_lazy p -> add_pattern bv p
  | Ppat_unpack id -> pattern_bv := StringMap.add id.txt bound !pattern_bv
  | Ppat_open ( m, p) -> let bv = open_module bv m.txt in add_pattern bv p
  | Ppat_exception p -> add_pattern bv p
  | Ppat_extension e -> handle_extension e

let add_pattern bv pat =
  pattern_bv := bv;
  add_pattern bv pat;
  !pattern_bv

let rec add_expr bv exp =
  match exp.pexp_desc with
    Pexp_ident l -> add bv l
  | Pexp_constant _ -> ()
  | Pexp_let(rf, pel, e) ->
      let bv = add_bindings rf bv pel in add_expr bv e
  | Pexp_fun (_, opte, p, e) ->
      add_opt add_expr bv opte; add_expr (add_pattern bv p) e
  | Pexp_function pel ->
      add_cases bv pel
  | Pexp_apply(e, el) ->
      add_expr bv e; List.iter (fun (_,e) -> add_expr bv e) el
  | Pexp_match(e, pel) -> add_expr bv e; add_cases bv pel
  | Pexp_try(e, pel) -> add_expr bv e; add_cases bv pel
  | Pexp_tuple el -> List.iter (add_expr bv) el
  | Pexp_construct(c, opte) -> add bv c; add_opt add_expr bv opte
  | Pexp_variant(_, opte) -> add_opt add_expr bv opte
  | Pexp_record(lblel, opte) ->
      List.iter (fun (lbl, e) -> add bv lbl; add_expr bv e) lblel;
      add_opt add_expr bv opte
  | Pexp_field(e, fld) -> add_expr bv e; add bv fld
  | Pexp_setfield(e1, fld, e2) -> add_expr bv e1; add bv fld; add_expr bv e2
  | Pexp_array el -> List.iter (add_expr bv) el
  | Pexp_ifthenelse(e1, e2, opte3) ->
      add_expr bv e1; add_expr bv e2; add_opt add_expr bv opte3
  | Pexp_sequence(e1, e2) -> add_expr bv e1; add_expr bv e2
  | Pexp_while(e1, e2) -> add_expr bv e1; add_expr bv e2
  | Pexp_for( _, e1, e2, _, e3) ->
      add_expr bv e1; add_expr bv e2; add_expr bv e3
  | Pexp_coerce(e1, oty2, ty3) ->
      add_expr bv e1;
      add_opt add_type bv oty2;
      add_type bv ty3
  | Pexp_constraint(e1, ty2) ->
      add_expr bv e1;
      add_type bv ty2
  | Pexp_send(e, _m) -> add_expr bv e
  | Pexp_new li -> add bv li
  | Pexp_setinstvar(_v, e) -> add_expr bv e
  | Pexp_override sel -> List.iter (fun (_s, e) -> add_expr bv e) sel
  | Pexp_letmodule(id, m, e) ->
      let b = add_module_binding bv m in
      add_expr (StringMap.add id.txt b bv) e
  | Pexp_letexception(_, e) -> add_expr bv e
  | Pexp_assert (e) -> add_expr bv e
  | Pexp_lazy (e) -> add_expr bv e
  | Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t
  | Pexp_object { pcstr_self = pat; pcstr_fields = fieldl } ->
      let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl
  | Pexp_newtype (_, e) -> add_expr bv e
  | Pexp_pack m -> add_module bv m
  | Pexp_open (_ovf, m, e) ->
      let bv = open_module bv m.txt in add_expr bv e
  | Pexp_extension (({ txt = ("ocaml.extension_constructor"|
                              "extension_constructor"); _ },
                     PStr [item]) as e) ->
      begin match item.pstr_desc with
      | Pstr_eval ({ pexp_desc = Pexp_construct (c, None) }, _) -> add bv c
      | _ -> handle_extension e
      end
  | Pexp_extension e -> handle_extension e
  | Pexp_unreachable -> ()

and add_cases bv cases =
  List.iter (add_case bv) cases

and add_case bv {pc_lhs; pc_guard; pc_rhs} =
  let bv = add_pattern bv pc_lhs in
  add_opt add_expr bv pc_guard;
  add_expr bv pc_rhs

and add_bindings recf bv pel =
  let bv' = List.fold_left (fun bv x -> add_pattern bv x.pvb_pat) bv pel in
  let bv = if recf = Recursive then bv' else bv in
  List.iter (fun x -> add_expr bv x.pvb_expr) pel;
  bv'

and add_modtype bv mty =
  match mty.pmty_desc with
    Pmty_ident l -> add bv l
  | Pmty_alias l -> addmodule bv l
  | Pmty_signature s -> add_signature bv s
  | Pmty_functor(id, mty1, mty2) ->
      Misc.may (add_modtype bv) mty1;
      add_modtype (StringMap.add id.txt bound bv) mty2
  | Pmty_with(mty, cstrl) ->
      add_modtype bv mty;
      List.iter
        (function
          | Pwith_type (_, td) -> add_type_declaration bv td
          | Pwith_module (_, lid) -> addmodule bv lid
          | Pwith_typesubst (_, td) -> add_type_declaration bv td
          | Pwith_modsubst (_, lid) -> addmodule bv lid
        )
        cstrl
  | Pmty_typeof m -> add_module bv m
  | Pmty_extension e -> handle_extension e

and add_module_alias bv l =
  try
    add_parent bv l;
    lookup_map l.txt bv
  with Not_found ->
    match l.txt with
      Lident s -> make_leaf s
    | _ -> addmodule bv l; bound (* cannot delay *)

and add_modtype_binding bv mty =
  if not !Clflags.transparent_modules then add_modtype bv mty;
  match mty.pmty_desc with
    Pmty_alias l ->
      add_module_alias bv l
  | Pmty_signature s ->
      make_node (add_signature_binding bv s)
  | Pmty_typeof modl ->
      add_module_binding bv modl
  | _ ->
      if !Clflags.transparent_modules then add_modtype bv mty; bound

and add_signature bv sg =
  ignore (add_signature_binding bv sg)

and add_signature_binding bv sg =
  snd (List.fold_left add_sig_item (bv, StringMap.empty) sg)

and add_sig_item (bv, m) item =
  match item.psig_desc with
    Psig_value vd ->
      add_type bv vd.pval_type; (bv, m)
  | Psig_type (_, dcls) ->
      List.iter (add_type_declaration bv) dcls; (bv, m)
  | Psig_typext te ->
      add_type_extension bv te; (bv, m)
  | Psig_exception pext ->
      add_extension_constructor bv pext; (bv, m)
  | Psig_module pmd ->
      let m' = add_modtype_binding bv pmd.pmd_type in
      let add = StringMap.add pmd.pmd_name.txt m' in
      (add bv, add m)
  | Psig_recmodule decls ->
      let add =
        List.fold_right (fun pmd -> StringMap.add pmd.pmd_name.txt bound)
                        decls
      in
      let bv' = add bv and m' = add m in
      List.iter (fun pmd -> add_modtype bv' pmd.pmd_type) decls;
      (bv', m')
  | Psig_modtype x ->
      begin match x.pmtd_type with
        None -> ()
      | Some mty -> add_modtype bv mty
      end;
      (bv, m)
  | Psig_open od ->
      (open_module bv od.popen_lid.txt, m)
  | Psig_include incl ->
      let Node (s, m') = add_modtype_binding bv incl.pincl_mod in
      add_names s;
      let add = StringMap.fold StringMap.add m' in
      (add bv, add m)
  | Psig_class cdl ->
      List.iter (add_class_description bv) cdl; (bv, m)
  | Psig_class_type cdtl ->
      List.iter (add_class_type_declaration bv) cdtl; (bv, m)
  | Psig_attribute _ -> (bv, m)
  | Psig_extension (e, _) ->
      handle_extension e;
      (bv, m)

and add_module_binding bv modl =
  if not !Clflags.transparent_modules then add_module bv modl;
  match modl.pmod_desc with
    Pmod_ident l ->
      begin try
        add_parent bv l;
        lookup_map l.txt bv
      with Not_found ->
        match l.txt with
          Lident s -> make_leaf s
        | _ ->  addmodule bv l; bound
      end
  | Pmod_structure s ->
      make_node (snd (add_structure_binding bv s))
  | _ ->
      if !Clflags.transparent_modules then add_module bv modl; bound

and add_module bv modl =
  match modl.pmod_desc with
    Pmod_ident l -> addmodule bv l
  | Pmod_structure s -> ignore (add_structure bv s)
  | Pmod_functor(id, mty, modl) ->
      Misc.may (add_modtype bv) mty;
      add_module (StringMap.add id.txt bound bv) modl
  | Pmod_apply(mod1, mod2) ->
      add_module bv mod1; add_module bv mod2
  | Pmod_constraint(modl, mty) ->
      add_module bv modl; add_modtype bv mty
  | Pmod_unpack(e) ->
      add_expr bv e
  | Pmod_extension e ->
      handle_extension e

and add_structure bv item_list =
  let (bv, m) = add_structure_binding bv item_list in
  add_names (collect_free (make_node m));
  bv

and add_structure_binding bv item_list =
  List.fold_left add_struct_item (bv, StringMap.empty) item_list

and add_struct_item (bv, m) item : _ StringMap.t * _ StringMap.t =
  match item.pstr_desc with
    Pstr_eval (e, _attrs) ->
      add_expr bv e; (bv, m)
  | Pstr_value(rf, pel) ->
      let bv = add_bindings rf bv pel in (bv, m)
  | Pstr_primitive vd ->
      add_type bv vd.pval_type; (bv, m)
  | Pstr_type (_, dcls) ->
      List.iter (add_type_declaration bv) dcls; (bv, m)
  | Pstr_typext te ->
      add_type_extension bv te;
      (bv, m)
  | Pstr_exception pext ->
      add_extension_constructor bv pext; (bv, m)
  | Pstr_module x ->
      let b = add_module_binding bv x.pmb_expr in
      let add = StringMap.add x.pmb_name.txt b in
      (add bv, add m)
  | Pstr_recmodule bindings ->
      let add =
        List.fold_right (fun x -> StringMap.add x.pmb_name.txt bound) bindings
      in
      let bv' = add bv and m = add m in
      List.iter
        (fun x -> add_module bv' x.pmb_expr)
        bindings;
      (bv', m)
  | Pstr_modtype x ->
      begin match x.pmtd_type with
        None -> ()
      | Some mty -> add_modtype bv mty
      end;
      (bv, m)
  | Pstr_open od ->
      (open_module bv od.popen_lid.txt, m)
  | Pstr_class cdl ->
      List.iter (add_class_declaration bv) cdl; (bv, m)
  | Pstr_class_type cdtl ->
      List.iter (add_class_type_declaration bv) cdtl; (bv, m)
  | Pstr_include incl ->
      let Node (s, m') = add_module_binding bv incl.pincl_mod in
      add_names s;
      let add = StringMap.fold StringMap.add m' in
      (add bv, add m)
  | Pstr_attribute _ -> (bv, m)
  | Pstr_extension (e, _) ->
      handle_extension e;
      (bv, m)

and add_use_file bv top_phrs =
  ignore (List.fold_left add_top_phrase bv top_phrs)

and add_implementation bv l =
  if !Clflags.transparent_modules then
    ignore (add_structure_binding bv l)
  else ignore (add_structure bv l)

and add_implementation_binding bv l =
  snd (add_structure_binding bv l)

and add_top_phrase bv = function
  | Ptop_def str -> add_structure bv str
  | Ptop_dir (_, _) -> bv

and add_class_expr bv ce =
  match ce.pcl_desc with
    Pcl_constr(l, tyl) ->
      add bv l; List.iter (add_type bv) tyl
  | Pcl_structure { pcstr_self = pat; pcstr_fields = fieldl } ->
      let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl
  | Pcl_fun(_, opte, pat, ce) ->
      add_opt add_expr bv opte;
      let bv = add_pattern bv pat in add_class_expr bv ce
  | Pcl_apply(ce, exprl) ->
      add_class_expr bv ce; List.iter (fun (_,e) -> add_expr bv e) exprl
  | Pcl_let(rf, pel, ce) ->
      let bv = add_bindings rf bv pel in add_class_expr bv ce
  | Pcl_constraint(ce, ct) ->
      add_class_expr bv ce; add_class_type bv ct
  | Pcl_extension e -> handle_extension e
  | Pcl_open (_ovf, m, e) ->
      let bv = open_module bv m.txt in add_class_expr bv e

and add_class_field bv pcf =
  match pcf.pcf_desc with
    Pcf_inherit(_, ce, _) -> add_class_expr bv ce
  | Pcf_val(_, _, Cfk_concrete (_, e))
  | Pcf_method(_, _, Cfk_concrete (_, e)) -> add_expr bv e
  | Pcf_val(_, _, Cfk_virtual ty)
  | Pcf_method(_, _, Cfk_virtual ty) -> add_type bv ty
  | Pcf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
  | Pcf_initializer e -> add_expr bv e
  | Pcf_attribute _ -> ()
  | Pcf_extension e -> handle_extension e

and add_class_declaration bv decl =
  add_class_expr bv decl.pci_expr

end
module Ext_array : sig 
#1 "ext_array.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






(** Some utilities for {!Array} operations *)
val reverse_range : 'a array -> int -> int -> unit
val reverse_in_place : 'a array -> unit
val reverse : 'a array -> 'a array 
val reverse_of_list : 'a list -> 'a array

val filter : ('a -> bool) -> 'a array -> 'a array

val filter_map : ('a -> 'b option) -> 'a array -> 'b array

val range : int -> int -> int array

val map2i : (int -> 'a -> 'b -> 'c ) -> 'a array -> 'b array -> 'c array

val to_list_f : 
  'a array -> 
  ('a -> 'b) -> 
  'b list 

val to_list_map : ('a -> 'b option) -> 'a array -> 'b list 

val to_list_map_acc : 
  'a array -> 
  'b list -> 
  ('a -> 'b option) -> 
  'b list 

val of_list_map : 
  'a list -> 
  ('a -> 'b) -> 
  'b array 

val rfind_with_index : 'a array -> ('a -> 'b -> bool) -> 'b -> int


type 'a split = [ `No_split | `Split of 'a array * 'a array ]

val rfind_and_split : 
  'a array ->
  ('a -> 'b -> bool) ->
  'b -> 'a split

val find_and_split : 
  'a array ->
  ('a -> 'b -> bool) ->
  'b -> 'a split

val exists : ('a -> bool) -> 'a array -> bool 

val is_empty : 'a array -> bool 

val for_all2_no_exn : 
  'a array ->
  'b array -> 
  ('a -> 'b -> bool) -> 
  bool

val map :   
  'a array -> 
  ('a -> 'b) -> 
  'b array

val iter :
  'a array -> 
  ('a -> unit) -> 
  unit

val fold_left :   
  'b array -> 
  'a -> 
  ('a -> 'b -> 'a) ->   
  'a
end = struct
#1 "ext_array.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)





let reverse_range a i len =
  if len = 0 then ()
  else
    for k = 0 to (len-1)/2 do
      let t = Array.unsafe_get a (i+k) in
      Array.unsafe_set a (i+k) ( Array.unsafe_get a (i+len-1-k));
      Array.unsafe_set a (i+len-1-k) t;
    done


let reverse_in_place a =
  reverse_range a 0 (Array.length a)

let reverse a =
  let b_len = Array.length a in
  if b_len = 0 then [||] else  
    let b = Array.copy a in  
    for i = 0 to  b_len - 1 do
      Array.unsafe_set b i (Array.unsafe_get a (b_len - 1 -i )) 
    done;
    b  

let reverse_of_list =  function
  | [] -> [||]
  | hd::tl as l ->
    let len = List.length l in
    let a = Array.make len hd in
    let rec fill i = function
      | [] -> a
      | hd::tl -> Array.unsafe_set a (len - i - 2) hd; fill (i+1) tl in
    fill 0 tl

let filter f a =
  let arr_len = Array.length a in
  let rec aux acc i =
    if i = arr_len 
    then reverse_of_list acc 
    else
      let v = Array.unsafe_get a i in
      if f  v then 
        aux (v::acc) (i+1)
      else aux acc (i + 1) 
  in aux [] 0


let filter_map (f : _ -> _ option) a =
  let arr_len = Array.length a in
  let rec aux acc i =
    if i = arr_len 
    then reverse_of_list acc 
    else
      let v = Array.unsafe_get a i in
      match f  v with 
      | Some v -> 
        aux (v::acc) (i+1)
      | None -> 
        aux acc (i + 1) 
  in aux [] 0

let range from to_ =
  if from > to_ then invalid_arg "Ext_array.range"  
  else Array.init (to_ - from + 1) (fun i -> i + from)

let map2i f a b = 
  let len = Array.length a in 
  if len <> Array.length b then 
    invalid_arg "Ext_array.map2i"  
  else
    Array.mapi (fun i a -> f i  a ( Array.unsafe_get b i )) a 

let rec tolist_f_aux a f  i res =
  if i < 0 then res else
    let v = Array.unsafe_get a i in
    tolist_f_aux a f  (i - 1)
      (f v :: res)
       
let to_list_f a f = tolist_f_aux a f (Array.length a  - 1) []

let rec tolist_aux a f  i res =
  if i < 0 then res else
    let v = Array.unsafe_get a i in
    tolist_aux a f  (i - 1)
      (match f v with
       | Some v -> v :: res
       | None -> res) 

let to_list_map f a = 
  tolist_aux a f (Array.length a - 1) []

let to_list_map_acc a acc f = 
  tolist_aux a f (Array.length a - 1) acc


let of_list_map a f = 
  match a with 
  | [] -> [||]
  | [a0] -> 
    let b0 = f a0 in
    [|b0|]
  | [a0;a1] -> 
    let b0 = f a0 in  
    let b1 = f a1 in 
    [|b0;b1|]
  | [a0;a1;a2] -> 
    let b0 = f a0 in  
    let b1 = f a1 in 
    let b2 = f a2 in  
    [|b0;b1;b2|]
  | [a0;a1;a2;a3] -> 
    let b0 = f a0 in  
    let b1 = f a1 in 
    let b2 = f a2 in  
    let b3 = f a3 in 
    [|b0;b1;b2;b3|]
  | [a0;a1;a2;a3;a4] -> 
    let b0 = f a0 in  
    let b1 = f a1 in 
    let b2 = f a2 in  
    let b3 = f a3 in 
    let b4 = f a4 in 
    [|b0;b1;b2;b3;b4|]

  | a0::a1::a2::a3::a4::tl -> 
    let b0 = f a0 in  
    let b1 = f a1 in 
    let b2 = f a2 in  
    let b3 = f a3 in 
    let b4 = f a4 in 
    let len = List.length tl + 5 in 
    let arr = Array.make len b0  in
    Array.unsafe_set arr 1 b1 ;  
    Array.unsafe_set arr 2 b2 ;
    Array.unsafe_set arr 3 b3 ; 
    Array.unsafe_set arr 4 b4 ; 
    let rec fill i = function
      | [] -> arr 
      | hd :: tl -> 
        Array.unsafe_set arr i (f hd); 
        fill (i + 1) tl in 
    fill 5 tl

(**
   {[
     # rfind_with_index [|1;2;3|] (=) 2;;
     - : int = 1
               # rfind_with_index [|1;2;3|] (=) 1;;
     - : int = 0
               # rfind_with_index [|1;2;3|] (=) 3;;
     - : int = 2
               # rfind_with_index [|1;2;3|] (=) 4;;
     - : int = -1
   ]}
*)
let rfind_with_index arr cmp v = 
  let len = Array.length arr in 
  let rec aux i = 
    if i < 0 then i
    else if  cmp (Array.unsafe_get arr i) v then i
    else aux (i - 1) in 
  aux (len - 1)

type 'a split = [ `No_split | `Split of 'a array * 'a array ]
let rfind_and_split arr cmp v : _ split = 
  let i = rfind_with_index arr cmp v in 
  if  i < 0 then 
    `No_split 
  else 
    `Split (Array.sub arr 0 i , Array.sub arr  (i + 1 ) (Array.length arr - i - 1 ))


let find_with_index arr cmp v = 
  let len  = Array.length arr in 
  let rec aux i len = 
    if i >= len then -1 
    else if cmp (Array.unsafe_get arr i ) v then i 
    else aux (i + 1) len in 
  aux 0 len

let find_and_split arr cmp v : _ split = 
  let i = find_with_index arr cmp v in 
  if i < 0 then 
    `No_split
  else
    `Split (Array.sub arr 0 i, Array.sub arr (i + 1 ) (Array.length arr - i - 1))        

(** TODO: available since 4.03, use {!Array.exists} *)

let exists p a =
  let n = Array.length a in
  let rec loop i =
    if i = n then false
    else if p (Array.unsafe_get a i) then true
    else loop (succ i) in
  loop 0


let is_empty arr =
  Array.length arr = 0


let rec unsafe_loop index len p xs ys  = 
  if index >= len then true
  else 
    p 
      (Array.unsafe_get xs index)
      (Array.unsafe_get ys index) &&
    unsafe_loop (succ index) len p xs ys 

let for_all2_no_exn xs ys p = 
  let len_xs = Array.length xs in 
  let len_ys = Array.length ys in 
  len_xs = len_ys &&    
  unsafe_loop 0 len_xs p xs ys


let map a f =
  let open Array in 
  let l = length a in
  if l = 0 then [||] else begin
    let r = make l (f(unsafe_get a 0)) in
    for i = 1 to l - 1 do
      unsafe_set r i (f(unsafe_get a i))
    done;
    r
  end

let iter a f =
  let open Array in 
  for i = 0 to length a - 1 do f(unsafe_get a i) done


  let fold_left a x f =
    let open Array in 
    let r = ref x in    
    for i = 0 to length a - 1 do
      r := f !r (unsafe_get a i)
    done;
    !r
  
end
module Ext_format : sig 
#1 "ext_format.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Simplified wrapper module for the standard library [Format] module. 
  *) 

type t = private Format.formatter

val string : t -> string -> unit

val break : t -> unit

val break1 : t -> unit

val space :  t -> unit

val group : t -> int -> (unit -> 'a) -> 'a
(** [group] will record current indentation 
    and indent futher
 *)

val vgroup : t -> int -> (unit -> 'a) -> 'a

val paren : t -> (unit -> 'a) -> 'a

val paren_group : t -> int -> (unit -> 'a) -> 'a

val brace_group : t -> int -> (unit -> 'a) -> 'a

val brace_vgroup : t -> int -> (unit -> 'a) -> 'a

val bracket_group : t -> int -> (unit -> 'a) -> 'a

val newline : t -> unit

val to_out_channel : out_channel -> t

val flush : t -> unit -> unit

val pp_print_queue :
  ?pp_sep:(Format.formatter -> unit -> unit) ->
  (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a Queue.t -> unit

end = struct
#1 "ext_format.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








open Format

type t = formatter

let string = pp_print_string

let break = fun fmt -> pp_print_break fmt 0 0

let break1 =
  fun fmt -> pp_print_break fmt 0 1 

let space  fmt  = 
  pp_print_break fmt 1 0

let vgroup fmt indent u = 
  pp_open_vbox fmt indent; 
  let v = u () in
  pp_close_box fmt ();
  v

let group fmt indent u = 
  pp_open_hovbox fmt indent; 
  let v = u () in
  pp_close_box fmt ();
  v
  
let paren fmt u = 
  string fmt "(";
  let v = u () in
  string fmt ")";
  v

let brace fmt u = 
  string fmt "{";
  (* break1 fmt ; *)
  let v = u () in
  string fmt "}";
  v 

let bracket fmt u = 
  string fmt "[";
  let v = u () in
  string fmt "]";
  v 

let paren_group st n action = 
  group st n (fun _ -> paren st action)

let brace_group st n action = 
  group st n (fun _ -> brace st action )

let brace_vgroup st n action = 
  vgroup st n (fun _ -> 
    string st "{";
    pp_print_break st 0 2;
    let v = vgroup st 0 action in
    pp_print_break st 0 0;
    string st "}";
    v
              )
let bracket_group st n action = 
  group st n (fun _ -> bracket st action)

let newline fmt = pp_print_newline fmt ()

let to_out_channel = formatter_of_out_channel

(* let non_breaking_space  fmt = string fmt " " *)
(* let set_needed_space_function _ _ = () *)
let flush = pp_print_flush

let list = pp_print_list

let rec pp_print_queue ?(pp_sep = pp_print_cut) pp_v ppf q =
  Queue.iter (fun q -> pp_v ppf q ;  pp_sep ppf ()) q 

end
module Ext_fmt
= struct
#1 "ext_fmt.ml"


let with_file_as_pp filename f = 
  Ext_pervasives.finally (open_out_bin filename) ~clean:close_out
    (fun chan -> 
      let fmt = Format.formatter_of_out_channel chan in
      let v = f  fmt in
      Format.pp_print_flush fmt ();
      v
    ) 



let failwithf ~loc fmt = Format.ksprintf (fun s -> failwith (loc ^ s))
    fmt
    
let invalid_argf fmt = Format.ksprintf invalid_arg fmt


end
module Ext_sys : sig 
#1 "ext_sys.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


(* Not used yet *)
(* val is_directory_no_exn : string -> bool *)


val is_windows_or_cygwin : bool 

val getenv_opt : 
  string -> 
  string option 
end = struct
#1 "ext_sys.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

(** TODO: not exported yet, wait for Windows Fix*)
let is_directory_no_exn f = 
  try Sys.is_directory f with _ -> false 


let is_windows_or_cygwin = Sys.win32 || Sys.cygwin


let getenv_opt = Sys.getenv_opt

end
module Ext_path : sig 
#1 "ext_path.mli"
(* Copyright (C) 2017 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type t 


(** Js_output is node style, which means 
    separator is only '/'

    if the path contains 'node_modules', 
    [node_relative_path] will discard its prefix and 
    just treat it as a library instead
*)
val simple_convert_node_path_to_os_path : string -> string



(**
   [combine path1 path2]
   1. add some simplifications when concatenating
   2. when [path2] is absolute, return [path2]
*)  
val combine : 
  string -> 
  string -> 
  string    



(**
   {[
     get_extension "a.txt" = ".txt"
       get_extension "a" = ""
   ]}
*)





val node_rebase_file :
  from:string -> 
  to_:string ->
  string -> 
  string 

(** 
   TODO: could be highly optimized
   if [from] and [to] resolve to the same path, a zero-length string is returned 
   Given that two paths are directory

   A typical use case is 
   {[
     Filename.concat 
       (rel_normalized_absolute_path cwd (Filename.dirname a))
       (Filename.basename a)
   ]}
*)
val rel_normalized_absolute_path : from:string -> string -> string 


val normalize_absolute_path : string -> string 


val absolute_cwd_path : string -> string 

(** [concat dirname filename]
    The same as {!Filename.concat} except a tiny optimization 
    for current directory simplification
*)
val concat : string -> string -> string 

val check_suffix_case : 
  string -> string -> bool



(* It is lazy so that it will not hit errors when in script mode *)
val package_dir : string Lazy.t

end = struct
#1 "ext_path.ml"
(* Copyright (C) 2017 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type t = 
  | File of string 
  | Dir of string 


let simple_convert_node_path_to_os_path =
  if Sys.unix then fun x -> x 
  else if Sys.win32 || Sys.cygwin then 
    Ext_string.replace_slash_backward 
  else failwith ("Unknown OS : " ^ Sys.os_type)


let cwd = lazy (Sys.getcwd())

let split_by_sep_per_os : string -> string list = 
  if Ext_sys.is_windows_or_cygwin then 
  fun x -> 
    (* on Windows, we can still accept -bs-package-output lib/js *)
    Ext_string.split_by 
      (fun x -> match x with |'/' |'\\' -> true | _ -> false) x
  else 
  fun x -> Ext_string.split x '/'

(** example
    {[
      "/bb/mbigc/mbig2899/bgit/bucklescript/jscomp/stdlib/external/pervasives.cmj"
        "/bb/mbigc/mbig2899/bgit/bucklescript/jscomp/stdlib/ocaml_array.ml"
    ]}

    The other way
    {[

      "/bb/mbigc/mbig2899/bgit/bucklescript/jscomp/stdlib/ocaml_array.ml"
        "/bb/mbigc/mbig2899/bgit/bucklescript/jscomp/stdlib/external/pervasives.cmj"
    ]}
    {[
      "/bb/mbigc/mbig2899/bgit/bucklescript/jscomp/stdlib//ocaml_array.ml"
    ]}
    {[
      /a/b
      /c/d
    ]}
*)
let node_relative_path 
    ~from:(file_or_dir_2 : t )
    (file_or_dir_1 : t) 
  = 
  let relevant_dir1 = 
    match file_or_dir_1 with 
    | Dir x -> x 
    | File file1 ->  Filename.dirname file1 in
  let relevant_dir2 = 
    match file_or_dir_2 with 
    | Dir x -> x 
    | File file2 -> Filename.dirname file2  in
  let dir1 = split_by_sep_per_os relevant_dir1 in
  let dir2 = split_by_sep_per_os relevant_dir2 in
  let rec go (dir1 : string list) (dir2 : string list) = 
    match dir1, dir2 with 
    | "." :: xs, ys -> go xs ys 
    | xs , "." :: ys -> go xs ys 
    | x::xs , y :: ys when x = y
      -> go xs ys 
    | _, _ -> 
      Ext_list.map_append  dir2  dir1  (fun _ ->  Literals.node_parent)
  in
  match go dir1 dir2 with
  | (x :: _ ) as ys when x = Literals.node_parent -> 
    String.concat Literals.node_sep ys
  | ys -> 
    String.concat Literals.node_sep  
    @@ Literals.node_current :: ys


let node_concat ~dir base =
  dir ^ Literals.node_sep ^ base 

let node_rebase_file ~from ~to_ file = 
  
  node_concat
    ~dir:(
      if from = to_ then Literals.node_current
      else node_relative_path ~from:(Dir from) (Dir to_)) 
    file
    
    
(***
   {[
     Filename.concat "." "";;
     "./"
   ]}
*)
let combine path1 path2 =  
  if Filename.is_relative path2 then
    if Ext_string.is_empty path2 then 
      path1
    else 
    if path1 = Filename.current_dir_name then 
      path2
    else
    if path2 = Filename.current_dir_name 
    then path1
    else
      Filename.concat path1 path2 
  else
    path2








let (//) x y =
  if x = Filename.current_dir_name then y
  else if y = Filename.current_dir_name then x 
  else Filename.concat x y 

(**
   {[
     split_aux "//ghosg//ghsogh/";;
     - : string * string list = ("/", ["ghosg"; "ghsogh"])
   ]}
   Note that 
   {[
     Filename.dirname "/a/" = "/"
       Filename.dirname "/a/b/" = Filename.dirname "/a/b" = "/a"
   ]}
   Special case:
   {[
     basename "//" = "/"
       basename "///"  = "/"
   ]}
   {[
     basename "" =  "."
       basename "" = "."
       dirname "" = "."
       dirname "" =  "."
   ]}  
*)
let split_aux p =
  let rec go p acc =
    let dir = Filename.dirname p in
    if dir = p then dir, acc
    else
      let new_path = Filename.basename p in 
      if Ext_string.equal new_path Filename.dir_sep then 
        go dir acc 
        (* We could do more path simplification here
           leave to [rel_normalized_absolute_path]
        *)
      else 
        go dir (new_path :: acc)

  in go p []





(** 
   TODO: optimization
   if [from] and [to] resolve to the same path, a zero-length string is returned 

   This function is useed in [es6-global] and 
   [amdjs-global] format and tailored for `rollup`
*)
let rel_normalized_absolute_path ~from to_ =
  let root1, paths1 = split_aux from in 
  let root2, paths2 = split_aux to_ in 
  if root1 <> root2 then root2
  else
    let rec go xss yss =
      match xss, yss with 
      | x::xs, y::ys -> 
        if Ext_string.equal x  y then go xs ys 
        else if x = Filename.current_dir_name then go xs yss 
        else if y = Filename.current_dir_name then go xss ys
        else 
          let start = 
            Ext_list.fold_left xs Ext_string.parent_dir_lit (fun acc  _  -> acc // Ext_string.parent_dir_lit )
          in 
          Ext_list.fold_left yss start (fun acc v -> acc // v)
      | [], [] -> Ext_string.empty
      | [], y::ys -> Ext_list.fold_left ys y (fun acc x -> acc // x) 
      | x::xs, [] ->
        Ext_list.fold_left xs Ext_string.parent_dir_lit (fun acc _ -> acc // Ext_string.parent_dir_lit )
     in
    let v =  go paths1 paths2  in 

    if Ext_string.is_empty v then  Literals.node_current
    else 
    if
      v = "."
      || v = ".."
      || Ext_string.starts_with v "./"  
      || Ext_string.starts_with v "../" 
    then v 
    else "./" ^ v 

(*TODO: could be hgighly optimized later 
  {[
    normalize_absolute_path "/gsho/./..";;

    normalize_absolute_path "/a/b/../c../d/e/f";;

    normalize_absolute_path "/gsho/./..";;

    normalize_absolute_path "/gsho/./../..";;

    normalize_absolute_path "/a/b/c/d";;

    normalize_absolute_path "/a/b/c/d/";;

    normalize_absolute_path "/a/";;

    normalize_absolute_path "/a";;
  ]}
*)
(** See tests in {!Ounit_path_tests} *)
let normalize_absolute_path x =
  let drop_if_exist xs =
    match xs with 
    | [] -> []
    | _ :: xs -> xs in 
  let rec normalize_list acc paths =
    match paths with 
    | [] -> acc 
    | x :: xs -> 
      if Ext_string.equal x Ext_string.current_dir_lit then 
        normalize_list acc xs 
      else if Ext_string.equal x Ext_string.parent_dir_lit then 
        normalize_list (drop_if_exist acc ) xs 
      else   
        normalize_list (x::acc) xs 
  in
  let root, paths = split_aux x in
  let rev_paths =  normalize_list [] paths in 
  let rec go acc rev_paths =
    match rev_paths with 
    | [] -> Filename.concat root acc 
    | last::rest ->  go (Filename.concat last acc ) rest  in 
  match rev_paths with 
  | [] -> root 
  | last :: rest -> go last rest 




let absolute_path cwd s = 
  let process s = 
    let s = 
      if Filename.is_relative s then
        Lazy.force cwd // s 
      else s in
    (* Now simplify . and .. components *)
    let rec aux s =
      let base,dir  = Filename.basename s, Filename.dirname s  in
      if dir = s then dir
      else if base = Filename.current_dir_name then aux dir
      else if base = Filename.parent_dir_name then Filename.dirname (aux dir)
      else aux dir // base
    in aux s  in 
  process s 

let absolute_cwd_path s = 
  absolute_path cwd  s 

let absolute cwd s =   
  match s with 
  | File x -> File (absolute_path cwd x )
  | Dir x -> Dir (absolute_path cwd x)

let concat dirname filename =
  if filename = Filename.current_dir_name then dirname
  else if dirname = Filename.current_dir_name then filename
  else Filename.concat dirname filename
  

let check_suffix_case =
  Ext_string.ends_with

(* Input must be absolute directory *)
let rec find_root_filename ~cwd filename   = 
  if Sys.file_exists ( Filename.concat cwd  filename) then cwd
  else 
    let cwd' = Filename.dirname cwd in 
    if String.length cwd' < String.length cwd then  
      find_root_filename ~cwd:cwd'  filename 
    else 
      Ext_fmt.failwithf 
        ~loc:__LOC__
        "%s not found from %s" filename cwd


let find_package_json_dir cwd  = 
  find_root_filename ~cwd  Literals.bsconfig_json

let package_dir = lazy (find_package_json_dir (Lazy.force cwd))

end
module Ext_ref : sig 
#1 "ext_ref.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

(** [non_exn_protect ref value f] assusme [f()] 
    would not raise
*)

val non_exn_protect : 'a ref -> 'a -> (unit -> 'b) -> 'b
val protect : 'a ref -> 'a -> (unit -> 'b) -> 'b

val protect2 : 'a ref -> 'b ref -> 'a -> 'b -> (unit -> 'c) -> 'c

(** [non_exn_protect2 refa refb va vb f ]
    assume [f ()] would not raise
*)
val non_exn_protect2 : 'a ref -> 'b ref -> 'a -> 'b -> (unit -> 'c) -> 'c

val protect_list : ('a ref * 'a) list -> (unit -> 'b) -> 'b

end = struct
#1 "ext_ref.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

let non_exn_protect r v body = 
  let old = !r in
  r := v;
  let res = body() in
  r := old;
  res

let protect r v body =
  let old = !r in
  try
    r := v;
    let res = body() in
    r := old;
    res
  with x ->
    r := old;
    raise x

let non_exn_protect2 r1 r2 v1 v2 body = 
  let old1 = !r1 in
  let old2 = !r2 in  
  r1 := v1;
  r2 := v2;
  let res = body() in
  r1 := old1;
  r2 := old2;
  res

let protect2 r1 r2 v1 v2 body =
  let old1 = !r1 in
  let old2 = !r2 in  
  try
    r1 := v1;
    r2 := v2;
    let res = body() in
    r1 := old1;
    r2 := old2;
    res
  with x ->
    r1 := old1;
    r2 := old2;
    raise x

let protect_list rvs body = 
  let olds =  Ext_list.map  rvs (fun (x,y) -> !x) in 
  let () = List.iter (fun (x,y) -> x:=y) rvs in 
  try 
    let res = body () in 
    List.iter2 (fun (x,_) old -> x := old) rvs olds;
    res 
  with e -> 
    List.iter2 (fun (x,_) old -> x := old) rvs olds;
    raise e 

end
module Ml_binary : sig 
#1 "ml_binary.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



type _ kind = 
  | Ml : Parsetree.structure kind 
  | Mli : Parsetree.signature kind


val read_ast : 'a kind -> in_channel -> 'a 

val write_ast :
   'a kind -> string -> 'a -> out_channel -> unit
end = struct
#1 "ml_binary.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


type _ kind = 
  | Ml : Parsetree.structure kind 
  | Mli : Parsetree.signature kind

(** [read_ast kind ic] assume [ic] channel is 
    in the right position *)
let read_ast (type t ) (kind : t  kind) ic : t  =
  let magic =
    match kind with 
    | Ml -> Config.ast_impl_magic_number
    | Mli -> Config.ast_intf_magic_number in 
  let buffer = really_input_string ic (String.length magic) in
  assert(buffer = magic); (* already checked by apply_rewriter *)
  Location.input_name := input_value ic;
  input_value ic 

let write_ast (type t) (kind : t kind) 
    (fname : string)
    (pt : t) oc = 
  let magic = 
    match kind with 
    | Ml -> Config.ast_impl_magic_number
    | Mli -> Config.ast_intf_magic_number in
  output_string oc magic ;
  output_value oc fname;
  output_value oc pt
end
module Bs_hash_stubs
= struct
#1 "bs_hash_stubs.ml"

 (* not suporting nested if here..*)
external hash_string :  string -> int = "caml_bs_hash_string" [@@noalloc];;

external hash_string_int :  string -> int  -> int = "caml_bs_hash_string_and_int" [@@noalloc];;

external hash_string_small_int :  string -> int  -> int = "caml_bs_hash_string_and_small_int" [@@noalloc];;

external hash_stamp_and_name : int -> string -> int = "caml_bs_hash_stamp_and_name" [@@noalloc];;

external hash_small_int : int -> int = "caml_bs_hash_small_int" [@@noalloc];;

external hash_int :  int  -> int = "caml_bs_hash_int" [@@noalloc];;

external string_length_based_compare : string -> string -> int  = "caml_string_length_based_compare" [@@noalloc];;


external    
    int_unsafe_blit : 
    int array -> int -> int array -> int -> int -> unit = "caml_int_array_blit" [@@noalloc];;
  
    

end
module Ext_util : sig 
#1 "ext_util.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


 
val power_2_above : int -> int -> int


val stats_to_string : Hashtbl.statistics -> string 
end = struct
#1 "ext_util.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

(**
   {[
     (power_2_above 16 63 = 64)
       (power_2_above 16 76 = 128)
   ]}
*)
let rec power_2_above x n =
  if x >= n then x
  else if x * 2 > Sys.max_array_length then x
  else power_2_above (x * 2) n


let stats_to_string ({num_bindings; num_buckets; max_bucket_length; bucket_histogram} : Hashtbl.statistics) = 
  Printf.sprintf 
    "bindings: %d,buckets: %d, longest: %d, hist:[%s]" 
    num_bindings 
    num_buckets 
    max_bucket_length
    (String.concat "," (Array.to_list (Array.map string_of_int bucket_histogram)))
end
module Hashtbl_gen
= struct
#1 "hashtbl_gen.ml"
(***********************************************************************)
(*                                                                     *)
(*                                OCaml                                *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the GNU Library General Public License, with    *)
(*  the special exception on linking described in file ../LICENSE.     *)
(*                                                                     *)
(***********************************************************************)

(* Hash tables *)



module type S = sig 
  type key
  type 'a t
  val create: int -> 'a t
  val clear: 'a t -> unit
  val reset: 'a t -> unit
  val copy: 'a t -> 'a t
  val add: 'a t -> key -> 'a -> unit
  val modify_or_init: 'a t -> key -> ('a -> unit) -> (unit -> 'a) -> unit 
  val remove: 'a t -> key -> unit
  val find_exn: 'a t -> key -> 'a
  val find_all: 'a t -> key -> 'a list
  val find_opt: 'a t -> key  -> 'a option
  
  (** return the key found in the hashtbl.
    Use case: when you find the key existed in hashtbl, 
    you want to use the one stored in the hashtbl. 
    (they are semantically equivlanent, but may have other information different) 
   *)
  val find_key_opt: 'a t -> key -> key option 

  val find_default: 'a t -> key -> 'a -> 'a 

  val replace: 'a t -> key -> 'a -> unit
  val mem: 'a t -> key -> bool
  val iter: 'a t -> (key -> 'a -> unit) -> unit
  val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
  val length: 'a t -> int
  val stats: 'a t -> Hashtbl.statistics
  val to_list : 'a t -> (key -> 'a -> 'c) -> 'c list
  val of_list2: key list -> 'a list -> 'a t
end

(* We do dynamic hashing, and resize the table and rehash the elements
   when buckets become too long. *)

type ('a, 'b) t =
  { mutable size: int;                        (* number of entries *)
    mutable data: ('a, 'b) bucketlist array;  (* the buckets *)
    mutable seed: int;                        (* for randomization *)
    initial_size: int;                        (* initial array size *)
  }

and ('a, 'b) bucketlist =
  | Empty
  | Cons of 'a * 'b * ('a, 'b) bucketlist


let create  initial_size =
  let s = Ext_util.power_2_above 16 initial_size in
  { initial_size = s; size = 0; seed = 0; data = Array.make s Empty }

let clear h =
  h.size <- 0;
  let len = Array.length h.data in
  for i = 0 to len - 1 do
    h.data.(i) <- Empty
  done

let reset h =
  h.size <- 0;
  h.data <- Array.make h.initial_size Empty


let copy h = { h with data = Array.copy h.data }

let length h = h.size

let resize indexfun h =
  let odata = h.data in
  let osize = Array.length odata in
  let nsize = osize * 2 in
  if nsize < Sys.max_array_length then begin
    let ndata = Array.make nsize Empty in
    h.data <- ndata;          (* so that indexfun sees the new bucket count *)
    let rec insert_bucket = function
        Empty -> ()
      | Cons(key, data, rest) ->
        insert_bucket rest; (* preserve original order of elements *)
        let nidx = indexfun h key in
        ndata.(nidx) <- Cons(key, data, ndata.(nidx)) in
    for i = 0 to osize - 1 do
      insert_bucket (Array.unsafe_get odata i)
    done
  end



let iter h f =
  let rec do_bucket = function
    | Empty ->
      ()
    | Cons(k, d, rest) ->
      f k d; do_bucket rest in
  let d = h.data in
  for i = 0 to Array.length d - 1 do
    do_bucket (Array.unsafe_get d i)
  done

let to_list h f =
  let rec do_bucket bucket acc =
    match bucket with 
    | Empty ->
      acc
    | Cons(k, d, rest) ->
      do_bucket rest (f k d :: acc) in
  let d = h.data in
  let acc = ref [] in
  for i = 0 to Array.length d - 1 do
    acc := do_bucket (Array.unsafe_get d i) !acc
  done;
  !acc

let fold f h init =
  let rec do_bucket b accu =
    match b with
      Empty ->
      accu
    | Cons(k, d, rest) ->
      do_bucket rest (f k d accu) in
  let d = h.data in
  let accu = ref init in
  for i = 0 to Array.length d - 1 do
    accu := do_bucket d.(i) !accu
  done;
  !accu

let rec bucket_length accu = function
  | Empty -> accu
  | Cons(_, _, rest) -> bucket_length (accu + 1) rest

let stats h =
  let mbl =
    Ext_array.fold_left h.data 0 (fun m b -> max m (bucket_length 0 b)) in
  let histo = Array.make (mbl + 1) 0 in
  Ext_array.iter h.data
    (fun b ->
       let l = bucket_length 0 b in
       histo.(l) <- histo.(l) + 1)
    ;
  {Hashtbl.
    num_bindings = h.size;
    num_buckets = Array.length h.data;
    max_bucket_length = mbl;
    bucket_histogram = histo }



let rec small_bucket_mem eq key (lst : _ bucketlist) =
  match lst with 
  | Empty -> false 
  | Cons(k1,_,rest1) -> 
    eq  key k1 ||
    match rest1 with
    | Empty -> false 
    | Cons(k2,_,rest2) -> 
      eq key k2  || 
      match rest2 with 
      | Empty -> false 
      | Cons(k3,_,rest3) -> 
        eq key k3  ||
        small_bucket_mem eq key rest3 


let rec small_bucket_opt eq key (lst : _ bucketlist) : _ option =
  match lst with 
  | Empty -> None 
  | Cons(k1,d1,rest1) -> 
    if eq  key k1 then Some d1 else 
      match rest1 with
      | Empty -> None 
      | Cons(k2,d2,rest2) -> 
        if eq key k2 then Some d2 else 
          match rest2 with 
          | Empty -> None 
          | Cons(k3,d3,rest3) -> 
            if eq key k3  then Some d3 else 
              small_bucket_opt eq key rest3 


let rec small_bucket_key_opt eq key (lst : _ bucketlist) : _ option =
  match lst with 
  | Empty -> None 
  | Cons(k1,d1,rest1) -> 
    if eq  key k1 then Some k1 else 
      match rest1 with
      | Empty -> None 
      | Cons(k2,d2,rest2) -> 
        if eq key k2 then Some k2 else 
          match rest2 with 
          | Empty -> None 
          | Cons(k3,d3,rest3) -> 
            if eq key k3  then Some k3 else 
              small_bucket_key_opt eq key rest3


let rec small_bucket_default eq key default (lst : _ bucketlist) =
  match lst with 
  | Empty -> default 
  | Cons(k1,d1,rest1) -> 
    if eq  key k1 then  d1 else 
      match rest1 with
      | Empty -> default 
      | Cons(k2,d2,rest2) -> 
        if eq key k2 then  d2 else 
          match rest2 with 
          | Empty -> default 
          | Cons(k3,d3,rest3) -> 
            if eq key k3  then  d3 else 
              small_bucket_default eq key default rest3 

end
module String_hashtbl : sig 
#1 "string_hashtbl.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


include Hashtbl_gen.S with type key = string




end = struct
#1 "string_hashtbl.ml"
# 9 "ext/hashtbl.cppo.ml"
type key = string
type 'a t = (key, 'a)  Hashtbl_gen.t 
let key_index (h : _ t ) (key : key) =
  (Bs_hash_stubs.hash_string  key ) land (Array.length h.data - 1)
let eq_key = Ext_string.equal 

# 33 "ext/hashtbl.cppo.ml"
type ('a, 'b) bucketlist = ('a,'b) Hashtbl_gen.bucketlist
let create = Hashtbl_gen.create
let clear = Hashtbl_gen.clear
let reset = Hashtbl_gen.reset
let copy = Hashtbl_gen.copy
let iter = Hashtbl_gen.iter
let to_list = Hashtbl_gen.to_list
let fold = Hashtbl_gen.fold
let length = Hashtbl_gen.length
let stats = Hashtbl_gen.stats



let add (h : _ t) key info =
  let i = key_index h key in
  let h_data = h.data in   
  Array.unsafe_set h_data i (Cons(key, info, (Array.unsafe_get h_data i)));
  h.size <- h.size + 1;
  if h.size > Array.length h_data lsl 1 then Hashtbl_gen.resize key_index h

(* after upgrade to 4.04 we should provide an efficient [replace_or_init] *)
let modify_or_init (h : _ t) key modf default =
  let rec find_bucket (bucketlist : _ bucketlist)  =
    match bucketlist with
    | Cons(k,i,next) ->
      if eq_key k key then begin modf i; false end
      else find_bucket next 
    | Empty -> true in
  let i = key_index h key in 
  let h_data = h.data in 
  if find_bucket (Array.unsafe_get h_data i) then
    begin 
      Array.unsafe_set h_data i  (Cons(key,default (), Array.unsafe_get h_data i));
      h.size <- h.size + 1 ;
      if h.size > Array.length h_data lsl 1 then Hashtbl_gen.resize key_index h 
    end


let rec remove_bucket key (h : _ t) (bucketlist : _ bucketlist) : _ bucketlist = 
  match bucketlist with  
  | Empty ->
    Empty
  | Cons(k, i, next) ->
    if eq_key k key 
    then begin h.size <- h.size - 1; next end
    else Cons(k, i, remove_bucket key h next) 

let remove (h : _ t ) key =
  let i = key_index h key in
  let h_data = h.data in 
  let old_h_szie = h.size in 
  let new_bucket = remove_bucket key h (Array.unsafe_get h_data i) in  
  if old_h_szie <> h.size then 
    Array.unsafe_set h_data i  new_bucket

let rec find_rec key (bucketlist : _ bucketlist) = match bucketlist with  
  | Empty ->
    raise Not_found
  | Cons(k, d, rest) ->
    if eq_key key k then d else find_rec key rest

let find_exn (h : _ t) key =
  match Array.unsafe_get h.data (key_index h key) with
  | Empty -> raise Not_found
  | Cons(k1, d1, rest1) ->
    if eq_key key k1 then d1 else
      match rest1 with
      | Empty -> raise Not_found
      | Cons(k2, d2, rest2) ->
        if eq_key key k2 then d2 else
          match rest2 with
          | Empty -> raise Not_found
          | Cons(k3, d3, rest3) ->
            if eq_key key k3  then d3 else find_rec key rest3

let find_opt (h : _ t) key =
  Hashtbl_gen.small_bucket_opt eq_key key (Array.unsafe_get h.data (key_index h key))

let find_key_opt (h : _ t) key =
  Hashtbl_gen.small_bucket_key_opt eq_key key (Array.unsafe_get h.data (key_index h key))
  
let find_default (h : _ t) key default = 
  Hashtbl_gen.small_bucket_default eq_key key default (Array.unsafe_get h.data (key_index h key))
let find_all (h : _ t) key =
  let rec find_in_bucket (bucketlist : _ bucketlist) = match bucketlist with 
    | Empty ->
      []
    | Cons(k, d, rest) ->
      if eq_key k key 
      then d :: find_in_bucket rest
      else find_in_bucket rest in
  find_in_bucket (Array.unsafe_get h.data (key_index h key))

let replace h key info =
  let rec replace_bucket (bucketlist : _ bucketlist) : _ bucketlist = match bucketlist with 
    | Empty ->
      raise_notrace Not_found
    | Cons(k, i, next) ->
      if eq_key k key
      then Cons(key, info, next)
      else Cons(k, i, replace_bucket next) in
  let i = key_index h key in
  let h_data = h.data in 
  let l = Array.unsafe_get h_data i in
  try
    Array.unsafe_set h_data i  (replace_bucket l)
  with Not_found ->
    begin 
      Array.unsafe_set h_data i (Cons(key, info, l));
      h.size <- h.size + 1;
      if h.size > Array.length h_data lsl 1 then Hashtbl_gen.resize key_index h;
    end 

let mem (h : _ t) key =
  let rec mem_in_bucket (bucketlist : _ bucketlist) = match bucketlist with 
    | Empty ->
      false
    | Cons(k, d, rest) ->
      eq_key k key  || mem_in_bucket rest in
  mem_in_bucket (Array.unsafe_get h.data (key_index h key))


let of_list2 ks vs = 
  let len = List.length ks in 
  let map = create len in 
  List.iter2 (fun k v -> add map k v) ks vs ; 
  map


end
module Map_gen
= struct
#1 "map_gen.ml"
(***********************************************************************)
(*                                                                     *)
(*                                OCaml                                *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the GNU Library General Public License, with    *)
(*  the special exception on linking described in file ../LICENSE.     *)
(*                                                                     *)
(***********************************************************************)
(** adapted from stdlib *)

type ('key,'a) t =
  | Empty
  | Node of ('key,'a) t * 'key * 'a * ('key,'a) t * int

type ('key,'a) enumeration =
  | End
  | More of 'key * 'a * ('key,'a) t * ('key, 'a) enumeration

let rec cardinal_aux acc  = function
  | Empty -> acc 
  | Node (l,_,_,r, _) -> 
    cardinal_aux  (cardinal_aux (acc + 1)  r ) l 

let cardinal s = cardinal_aux 0 s 

let rec bindings_aux accu = function
  | Empty -> accu
  | Node(l, v, d, r, _) -> bindings_aux ((v, d) :: bindings_aux accu r) l

let bindings s =
  bindings_aux [] s

  
let rec fill_array_aux (s : _ t) i arr : int =    
  match s with 
  | Empty -> i 
  | Node (l,k,v,r,_) -> 
    let inext = fill_array_aux l i arr in 
    Array.unsafe_set arr inext (k,v);
    fill_array_aux r (inext + 1) arr 

let to_sorted_array (s : ('key,'a) t)  : ('key * 'a ) array =    
  match s with 
  | Empty -> [||]
  | Node(l,k,v,r,_) -> 
    let len = 
      cardinal_aux (cardinal_aux 1 r) l in 
    let arr =
      Array.make len (k,v) in  
    ignore (fill_array_aux s 0 arr : int);
    arr 
let rec keys_aux accu = function
    Empty -> accu
  | Node(l, v, _, r, _) -> keys_aux (v :: keys_aux accu r) l

let keys s = keys_aux [] s



let rec cons_enum m e =
  match m with
    Empty -> e
  | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e))


let height = function
  | Empty -> 0
  | Node(_,_,_,_,h) -> h

let create l x d r =
  let hl = height l and hr = height r in
  Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))

let singleton x d = Node(Empty, x, d, Empty, 1)

let bal l x d r =
  let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
  let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
  if hl > hr + 2 then begin
    match l with
      Empty -> invalid_arg "Map.bal"
    | Node(ll, lv, ld, lr, _) ->
      if height ll >= height lr then
        create ll lv ld (create lr x d r)
      else begin
        match lr with
          Empty -> invalid_arg "Map.bal"
        | Node(lrl, lrv, lrd, lrr, _)->
          create (create ll lv ld lrl) lrv lrd (create lrr x d r)
      end
  end else if hr > hl + 2 then begin
    match r with
      Empty -> invalid_arg "Map.bal"
    | Node(rl, rv, rd, rr, _) ->
      if height rr >= height rl then
        create (create l x d rl) rv rd rr
      else begin
        match rl with
          Empty -> invalid_arg "Map.bal"
        | Node(rll, rlv, rld, rlr, _) ->
          create (create l x d rll) rlv rld (create rlr rv rd rr)
      end
  end else
    Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))

let empty = Empty

let is_empty = function Empty -> true | _ -> false

let rec min_binding_exn = function
    Empty -> raise Not_found
  | Node(Empty, x, d, r, _) -> (x, d)
  | Node(l, x, d, r, _) -> min_binding_exn l

let choose = min_binding_exn

let rec max_binding_exn = function
    Empty -> raise Not_found
  | Node(l, x, d, Empty, _) -> (x, d)
  | Node(l, x, d, r, _) -> max_binding_exn r

let rec remove_min_binding = function
    Empty -> invalid_arg "Map.remove_min_elt"
  | Node(Empty, x, d, r, _) -> r
  | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r

let merge t1 t2 =
  match (t1, t2) with
    (Empty, t) -> t
  | (t, Empty) -> t
  | (_, _) ->
    let (x, d) = min_binding_exn t2 in
    bal t1 x d (remove_min_binding t2)


let rec iter x f = match x with 
    Empty -> ()
  | Node(l, v, d, r, _) ->
    iter l f; f v d; iter r f

let rec map x f = match x with
    Empty ->
    Empty
  | Node(l, v, d, r, h) ->
    let l' = map l f in
    let d' = f d in
    let r' = map r f in
    Node(l', v, d', r', h)

let rec mapi x f = match x with
    Empty ->
    Empty
  | Node(l, v, d, r, h) ->
    let l' = mapi l f in
    let d' = f v d in
    let r' = mapi r f in
    Node(l', v, d', r', h)

let rec fold m accu f =
  match m with
    Empty -> accu
  | Node(l, v, d, r, _) ->
    fold r (f v d (fold l accu f)) f 

let rec for_all x p = match x with 
    Empty -> true
  | Node(l, v, d, r, _) -> p v d && for_all l p && for_all r p

let rec exists x p = match x with
    Empty -> false
  | Node(l, v, d, r, _) -> p v d || exists l p || exists r p

(* Beware: those two functions assume that the added k is *strictly*
   smaller (or bigger) than all the present keys in the tree; it
   does not test for equality with the current min (or max) key.

   Indeed, they are only used during the "join" operation which
   respects this precondition.
*)

let rec add_min_binding k v = function
  | Empty -> singleton k v
  | Node (l, x, d, r, h) ->
    bal (add_min_binding k v l) x d r

let rec add_max_binding k v = function
  | Empty -> singleton k v
  | Node (l, x, d, r, h) ->
    bal l x d (add_max_binding k v r)

(* Same as create and bal, but no assumptions are made on the
   relative heights of l and r. *)

let rec join l v d r =
  match (l, r) with
    (Empty, _) -> add_min_binding v d r
  | (_, Empty) -> add_max_binding v d l
  | (Node(ll, lv, ld, lr, lh), Node(rl, rv, rd, rr, rh)) ->
    if lh > rh + 2 then bal ll lv ld (join lr v d r) else
    if rh > lh + 2 then bal (join l v d rl) rv rd rr else
      create l v d r

(* Merge two trees l and r into one.
   All elements of l must precede the elements of r.
   No assumption on the heights of l and r. *)

let concat t1 t2 =
  match (t1, t2) with
    (Empty, t) -> t
  | (t, Empty) -> t
  | (_, _) ->
    let (x, d) = min_binding_exn t2 in
    join t1 x d (remove_min_binding t2)

let concat_or_join t1 v d t2 =
  match d with
  | Some d -> join t1 v d t2
  | None -> concat t1 t2

let rec filter x p = match x with
    Empty -> Empty
  | Node(l, v, d, r, _) ->
    (* call [p] in the expected left-to-right order *)
    let l' = filter l p in
    let pvd = p v d in
    let r' = filter r p in
    if pvd then join l' v d r' else concat l' r'

let rec partition x p = match x with
    Empty -> (Empty, Empty)
  | Node(l, v, d, r, _) ->
    (* call [p] in the expected left-to-right order *)
    let (lt, lf) = partition l p in
    let pvd = p v d in
    let (rt, rf) = partition r p in
    if pvd
    then (join lt v d rt, concat lf rf)
    else (concat lt rt, join lf v d rf)

let compare compare_key cmp_val m1 m2 =
  let rec compare_aux e1  e2 =
    match (e1, e2) with
      (End, End) -> 0
    | (End, _)  -> -1
    | (_, End) -> 1
    | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
      let c = compare_key v1 v2 in
      if c <> 0 then c else
        let c = cmp_val d1 d2 in
        if c <> 0 then c else
          compare_aux (cons_enum r1 e1) (cons_enum r2 e2)
  in compare_aux (cons_enum m1 End) (cons_enum m2 End)

let equal compare_key cmp m1 m2 =
  let rec equal_aux e1 e2 =
    match (e1, e2) with
      (End, End) -> true
    | (End, _)  -> false
    | (_, End) -> false
    | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
      compare_key v1 v2 = 0 && cmp d1 d2 &&
      equal_aux (cons_enum r1 e1) (cons_enum r2 e2)
  in equal_aux (cons_enum m1 End) (cons_enum m2 End)



    
module type S =
  sig
    type key
    type +'a t
    val empty: 'a t
    val compare_key: key -> key -> int 
    val is_empty: 'a t -> bool
    val mem: 'a t -> key -> bool
    val to_sorted_array : 
      'a t -> (key * 'a ) array
    val add: 'a t -> key -> 'a -> 'a t
    (** [add x y m] 
        If [x] was already bound in [m], its previous binding disappears. *)
    val adjust: 'a t -> key -> ('a option->  'a) ->  'a t 
    (** [adjust acc k replace ] if not exist [add (replace None ], otherwise 
        [add k v (replace (Some old))]
    *)
    val singleton: key -> 'a -> 'a t

    val remove: 'a t -> key -> 'a t
    (** [remove x m] returns a map containing the same bindings as
       [m], except for [x] which is unbound in the returned map. *)

    val merge:
         'a t -> 'b t ->
         (key -> 'a option -> 'b option -> 'c option) ->  'c t
    (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1]
        and of [m2]. The presence of each such binding, and the corresponding
        value, is determined with the function [f].
        @since 3.12.0
     *)

    val disjoint_merge : 'a t -> 'a t -> 'a t
     (* merge two maps, will raise if they have the same key *)
    val compare: 'a t -> 'a t -> ('a -> 'a -> int) -> int
    (** Total ordering between maps.  The first argument is a total ordering
        used to compare data associated with equal keys in the two maps. *)

    val equal: 'a t -> 'a t -> ('a -> 'a -> bool) ->  bool

    val iter: 'a t -> (key -> 'a -> unit) ->  unit
    (** [iter f m] applies [f] to all bindings in map [m].
        The bindings are passed to [f] in increasing order. *)

    val fold: 'a t -> 'b -> (key -> 'a -> 'b -> 'b) -> 'b
    (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)],
       where [k1 ... kN] are the keys of all bindings in [m]
       (in increasing order) *)

    val for_all: 'a t -> (key -> 'a -> bool) -> bool
    (** [for_all p m] checks if all the bindings of the map.
        order unspecified
     *)

    val exists: 'a t -> (key -> 'a -> bool) -> bool
    (** [exists p m] checks if at least one binding of the map
        satisfy the predicate [p]. 
        order unspecified
     *)

    val filter: 'a t -> (key -> 'a -> bool) -> 'a t
    (** [filter p m] returns the map with all the bindings in [m]
        that satisfy predicate [p].
        order unspecified
     *)

    val partition: 'a t -> (key -> 'a -> bool) ->  'a t * 'a t
    (** [partition p m] returns a pair of maps [(m1, m2)], where
        [m1] contains all the bindings of [s] that satisfy the
        predicate [p], and [m2] is the map with all the bindings of
        [s] that do not satisfy [p].
     *)

    val cardinal: 'a t -> int
    (** Return the number of bindings of a map. *)

    val bindings: 'a t -> (key * 'a) list
    (** Return the list of all bindings of the given map.
       The returned list is sorted in increasing order with respect
       to the ordering *)
    val keys : 'a t -> key list 
    (* Increasing order *)

    val min_binding_exn: 'a t -> (key * 'a)
    (** raise [Not_found] if the map is empty. *)

    val max_binding_exn: 'a t -> (key * 'a)
    (** Same as {!Map.S.min_binding} *)

    val choose: 'a t -> (key * 'a)
    (** Return one binding of the given map, or raise [Not_found] if
       the map is empty. Which binding is chosen is unspecified,
       but equal bindings will be chosen for equal maps.
     *)

    val split: 'a t -> key -> 'a t * 'a option * 'a t
    (** [split x m] returns a triple [(l, data, r)], where
          [l] is the map with all the bindings of [m] whose key
        is strictly less than [x];
          [r] is the map with all the bindings of [m] whose key
        is strictly greater than [x];
          [data] is [None] if [m] contains no binding for [x],
          or [Some v] if [m] binds [v] to [x].
        @since 3.12.0
     *)

    val find_exn: 'a t -> key ->  'a
    (** [find x m] returns the current binding of [x] in [m],
       or raises [Not_found] if no such binding exists. *)
    val find_opt:  'a t ->  key ->'a option
    val find_default: 'a t -> key  ->  'a  -> 'a 
    val map: 'a t -> ('a -> 'b) -> 'b t
    (** [map f m] returns a map with same domain as [m], where the
       associated value [a] of all bindings of [m] has been
       replaced by the result of the application of [f] to [a].
       The bindings are passed to [f] in increasing order
       with respect to the ordering over the type of the keys. *)

    val mapi: 'a t ->  (key -> 'a -> 'b) -> 'b t
    (** Same as {!Map.S.map}, but the function receives as arguments both the
       key and the associated value for each binding of the map. *)

    val of_list : (key * 'a) list -> 'a t 
    val of_array : (key * 'a ) array -> 'a t 
    val add_list : (key * 'b) list -> 'b t -> 'b t

  end

end
module String_map : sig 
#1 "string_map.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


include Map_gen.S with type key = string

end = struct
#1 "string_map.ml"

# 2 "ext/map.cppo.ml"
(* we don't create [map_poly], since some operations require raise an exception which carries [key] *)


  
# 10 "ext/map.cppo.ml"
  type key = string 
  let compare_key = Ext_string.compare

# 22 "ext/map.cppo.ml"
type 'a t = (key,'a) Map_gen.t
exception Duplicate_key of key 

let empty = Map_gen.empty 
let is_empty = Map_gen.is_empty
let iter = Map_gen.iter
let fold = Map_gen.fold
let for_all = Map_gen.for_all 
let exists = Map_gen.exists 
let singleton = Map_gen.singleton 
let cardinal = Map_gen.cardinal
let bindings = Map_gen.bindings
let to_sorted_array = Map_gen.to_sorted_array
let keys = Map_gen.keys
let choose = Map_gen.choose 
let partition = Map_gen.partition 
let filter = Map_gen.filter 
let map = Map_gen.map 
let mapi = Map_gen.mapi
let bal = Map_gen.bal 
let height = Map_gen.height 
let max_binding_exn = Map_gen.max_binding_exn
let min_binding_exn = Map_gen.min_binding_exn


let rec add (tree : _ Map_gen.t as 'a) x data  : 'a = match tree with 
  | Empty ->
    Node(Empty, x, data, Empty, 1)
  | Node(l, v, d, r, h) ->
    let c = compare_key x v in
    if c = 0 then
      Node(l, x, data, r, h)
    else if c < 0 then
      bal (add l x data ) v d r
    else
      bal l v d (add r x data )


let rec adjust (tree : _ Map_gen.t as 'a) x replace  : 'a = 
  match tree with 
  | Empty ->
    Node(Empty, x, replace None, Empty, 1)
  | Node(l, v, d, r, h) ->
    let c = compare_key x v in
    if c = 0 then
      Node(l, x, replace  (Some d) , r, h)
    else if c < 0 then
      bal (adjust l x  replace ) v d r
    else
      bal l v d (adjust r x  replace )


let rec find_exn (tree : _ Map_gen.t ) x = match tree with 
  | Empty ->
    raise Not_found
  | Node(l, v, d, r, _) ->
    let c = compare_key x v in
    if c = 0 then d
    else find_exn (if c < 0 then l else r) x

let rec find_opt (tree : _ Map_gen.t ) x = match tree with 
  | Empty -> None 
  | Node(l, v, d, r, _) ->
    let c = compare_key x v in
    if c = 0 then Some d
    else find_opt (if c < 0 then l else r) x

let rec find_default (tree : _ Map_gen.t ) x  default     = match tree with 
  | Empty -> default  
  | Node(l, v, d, r, _) ->
    let c = compare_key x v in
    if c = 0 then  d
    else find_default (if c < 0 then l else r) x default

let rec mem (tree : _ Map_gen.t )  x= match tree with 
  | Empty ->
    false
  | Node(l, v, d, r, _) ->
    let c = compare_key x v in
    c = 0 || mem (if c < 0 then l else r) x 

let rec remove (tree : _ Map_gen.t as 'a) x : 'a = match tree with 
  | Empty ->
    Empty
  | Node(l, v, d, r, h) ->
    let c = compare_key x v in
    if c = 0 then
      Map_gen.merge l r
    else if c < 0 then
      bal (remove l x) v d r
    else
      bal l v d (remove r x )


let rec split (tree : _ Map_gen.t as 'a) x : 'a * _ option * 'a  = match tree with 
  | Empty ->
    (Empty, None, Empty)
  | Node(l, v, d, r, _) ->
    let c = compare_key x v in
    if c = 0 then (l, Some d, r)
    else if c < 0 then
      let (ll, pres, rl) = split l x in (ll, pres, Map_gen.join rl v d r)
    else
      let (lr, pres, rr) = split r x in (Map_gen.join l v d lr, pres, rr)

let rec merge (s1 : _ Map_gen.t) (s2  : _ Map_gen.t) f  : _ Map_gen.t =
  match (s1, s2) with
  | (Empty, Empty) -> Empty
  | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 ->
    let (l2, d2, r2) = split s2 v1 in
    Map_gen.concat_or_join (merge l1 l2 f) v1 (f v1 (Some d1) d2) (merge r1 r2 f)
  | (_, Node (l2, v2, d2, r2, h2)) ->
    let (l1, d1, r1) = split s1 v2 in
    Map_gen.concat_or_join (merge l1 l2 f) v2 (f v2 d1 (Some d2)) (merge r1 r2 f)
  | _ ->
    assert false

let rec disjoint_merge  (s1 : _ Map_gen.t) (s2  : _ Map_gen.t) : _ Map_gen.t =
  match (s1, s2) with
  | (Empty, Empty) -> Empty
  | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 ->
    begin match split s2 v1 with 
    | l2, None, r2 -> 
      Map_gen.join (disjoint_merge  l1 l2) v1 d1 (disjoint_merge r1 r2)
    | _, Some _, _ ->
      raise (Duplicate_key  v1)
    end        
  | (_, Node (l2, v2, d2, r2, h2)) ->
    begin match  split s1 v2 with 
    | (l1, None, r1) -> 
      Map_gen.join (disjoint_merge  l1 l2) v2 d2 (disjoint_merge  r1 r2)
    | (_, Some _, _) -> 
      raise (Duplicate_key v2)
    end
  | _ ->
    assert false



let compare m1 m2 cmp = Map_gen.compare compare_key cmp m1 m2

let equal m1 m2 cmp = Map_gen.equal compare_key cmp m1 m2 

let add_list (xs : _ list ) init = 
  Ext_list.fold_left xs init (fun  acc (k,v) -> add acc k v )

let of_list xs = add_list xs empty

let of_array xs = 
  Ext_array.fold_left xs empty (fun acc (k,v) -> add acc k v ) 

end
module Ast_extract : sig 
#1 "ast_extract.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)









module String_set = Depend.StringSet

val read_parse_and_extract : 'a Ml_binary.kind -> 'a -> String_set.t

type ('a,'b) t 

val sort_files_by_dependencies :
  domain:String_set.t -> String_set.t String_map.t -> string Queue.t


val sort :
  ('a -> Parsetree.structure) ->
  ('b -> Parsetree.signature) ->
  ('a, 'b) t String_map.t -> string Queue.t  



(**
   [build fmt files parse_implementation parse_interface]
   Given a list of files return an ast table 
*)
val collect_ast_map :
  Format.formatter ->
  string list ->
  (Format.formatter -> string -> 'a) ->
  (Format.formatter -> string -> 'b) ->
  ('a, 'b) t String_map.t

type dir_spec = 
  { dir : string ;
    mutable  excludes : string list 
  }

(** If the genereated queue is empty, it means 
    1. The main module  does not exist (does not exist due to typo)
    2. It does exist but not in search path
    The order matters from head to tail 
*)
val collect_from_main :
  ?extra_dirs:dir_spec list -> 
  ?excludes : string list -> 
  ?alias_map: string String_hashtbl.t ->
  Format.formatter ->
  (Format.formatter -> string -> 'a) ->
  (Format.formatter -> string -> 'b) ->
  ('a -> Parsetree.structure) ->
  ('b -> Parsetree.signature) ->
  string -> ('a, 'b) t String_map.t * string Queue.t

val build_queue :
  Format.formatter ->
  string Queue.t ->
  ('b, 'c) t String_map.t ->
  (Format.formatter -> string -> string -> 'b -> unit) ->
  (Format.formatter -> string -> string -> 'c -> unit) -> unit
  
val handle_queue :
  Format.formatter ->
  string Queue.t ->
  ('a, 'b) t String_map.t ->
  (string -> string -> 'a -> unit) ->
  (string -> string -> 'b  -> unit) ->
  (string -> string -> string -> 'b -> 'a -> unit) -> unit


val build_lazy_queue :
  Format.formatter ->
  string Queue.t ->
  (Parsetree.structure lazy_t, Parsetree.signature lazy_t) t String_map.t ->
  (Format.formatter -> string -> string -> Parsetree.structure -> unit) ->
  (Format.formatter -> string -> string -> Parsetree.signature -> unit) -> unit  



end = struct
#1 "ast_extract.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type module_name = private string

module String_set = Depend.StringSet

(* FIXME: [Clflags.open_modules] seems not to be properly used *)
 
module SMap = Depend.StringMap
let bound_vars = SMap.empty 


type 'a kind = 'a Ml_binary.kind 


let read_parse_and_extract (type t) (k : t kind) (ast : t) : String_set.t =
  Depend.free_structure_names := String_set.empty;
  Ext_ref.protect Clflags.transparent_modules false begin fun _ -> 
  List.iter
    (fun modname  ->

       ignore @@ 
       
       Depend.open_module bound_vars (Longident.Lident modname))
    (!Clflags.open_modules);
  (match k with
   | Ml_binary.Ml  -> Depend.add_implementation bound_vars ast
   | Ml_binary.Mli  -> Depend.add_signature bound_vars ast  ); 
  !Depend.free_structure_names
  end

type ('a,'b) ast_info =
  | Ml of
      string * (* sourcefile *)
      'a *
      string (* opref *)      
  | Mli of string * (* sourcefile *)
           'b *
           string (* opref *)
  | Ml_mli of
      string * (* sourcefile *)
      'a *
      string  * (* opref1 *)
      string * (* sourcefile *)      
      'b *
      string (* opref2*)

type ('a,'b) t =
  { module_name : string ; ast_info : ('a,'b) ast_info }


(* only visit nodes that are currently in the domain *)
(* https://en.wikipedia.org/wiki/Topological_sorting *)
(* dfs   *)
let sort_files_by_dependencies ~(domain : String_set.t) (dependency_graph : String_set.t String_map.t) : 
  string Queue.t =
  let next current =
    String_map.find_exn  dependency_graph current in    
  let worklist = ref domain in
  let result = Queue.create () in
  let rec visit (visiting : String_set.t) path (current : string) =
    let next_path = current :: path in 
    if String_set.mem current visiting then
      Bs_exception.error (Bs_cyclic_depends next_path)
    else if String_set.mem current !worklist then
      begin
        let next_set = String_set.add current visiting in         
        next current |>        
        String_set.iter
          (fun node ->
             if  String_map.mem dependency_graph node then
               visit next_set next_path node)
        ;
        worklist := String_set.remove  current !worklist;
        Queue.push current result ;
      end in        
  while not (String_set.is_empty !worklist) do 
    visit String_set.empty []  (String_set.choose !worklist)
  done;
  if Js_config.get_diagnose () then
    Format.fprintf Format.err_formatter
      "Order: @[%a@]@."    
      (Ext_format.pp_print_queue
         ~pp_sep:Format.pp_print_space
         Format.pp_print_string)
      result ;       
  result
;;



let sort  project_ml project_mli (ast_table : _ t String_map.t) = 
  let domain =
    String_map.fold ast_table String_set.empty 
      (fun k _ acc -> String_set.add k acc)
  in
  let h =
    String_map.map ast_table
      (fun
        ({ast_info})
        ->
          match ast_info with
          | Ml (_, ast,  _)
            ->
            read_parse_and_extract Ml (project_ml ast)            
          | Mli (_, ast, _)
            ->
            read_parse_and_extract Mli (project_mli ast)
          | Ml_mli (_, impl, _, _, intf, _)
            ->
            String_set.union
              (read_parse_and_extract Ml (project_ml impl))
              (read_parse_and_extract Mli (project_mli intf))              
      ) in    
  sort_files_by_dependencies  ~domain h

(** same as {!Ocaml_parse.check_suffix} but does not care with [-c -o] option*)
let check_suffix  name  = 
  if Ext_path.check_suffix_case name ".ml" then 
    `Ml,
    Ext_filename.chop_extension_maybe  name 
  else if Ext_path.check_suffix_case name !Config.interface_suffix then 
    `Mli,   Ext_filename.chop_extension_maybe  name 
  else 
    raise(Arg.Bad("don't know what to do with " ^ name))


let collect_ast_map ppf files parse_implementation parse_interface  =
  Ext_list.fold_left files String_map.empty
    (fun acc source_file ->
      match check_suffix source_file with
      | `Ml, opref ->
        let module_name = Ext_filename.module_name source_file in
        begin match String_map.find_exn acc module_name with
          | exception Not_found ->
            String_map.add acc module_name
              {ast_info =
                 (Ml (source_file, parse_implementation
                        ppf source_file, opref));
               module_name ;
              } 
          | {ast_info = (Ml (source_file2, _, _)
                        | Ml_mli(source_file2, _, _,_,_,_))} ->
            Bs_exception.error
              (Bs_duplicated_module (source_file, source_file2))
          | {ast_info =  Mli (source_file2, intf, opref2)}
            ->
            String_map.add acc module_name
              {ast_info =
                 Ml_mli (source_file,
                         parse_implementation ppf source_file,
                         opref,
                         source_file2,
                         intf,
                         opref2
                        );
               module_name} 
        end
      | `Mli, opref ->
        let module_name = Ext_filename.module_name source_file in
        begin match String_map.find_exn acc module_name with
          | exception Not_found ->
            String_map.add acc module_name
              {ast_info = (Mli (source_file, parse_interface
                                  ppf source_file, opref));
               module_name } 
          | {ast_info =
               (Mli (source_file2, _, _) |
                Ml_mli(_,_,_,source_file2,_,_)) } ->
            Bs_exception.error
              (Bs_duplicated_module (source_file, source_file2))
          | {ast_info = Ml (source_file2, impl, opref2)}
            ->
            String_map.add acc module_name
              {ast_info =
                 Ml_mli
                   (source_file2,
                    impl,
                    opref2,
                    source_file,
                    parse_interface ppf source_file,
                    opref
                   );
               module_name} 
        end
    ) 
;;
type dir_spec = 
  { dir : string ;
    mutable  excludes : string list 
  }

let collect_from_main 
    ?(extra_dirs=[])
    ?(excludes=[])
    ?alias_map
    (ppf : Format.formatter)
    parse_implementation
    parse_interface
    project_impl 
    project_intf 
    main_module =
  let files = 
    Ext_list.fold_left extra_dirs [] (fun acc dir_spec -> 
        let  dirname, excludes = 
          match dir_spec with 
          | { dir =  dirname; excludes = dir_excludes} ->
            (*   dirname, excludes *)
            (* | `Dir_with_excludes (dirname, dir_excludes) -> *)
            dirname,
             (Ext_list.flat_map_append 
              dir_excludes  excludes
              (fun x -> [x ^ ".ml" ; x ^ ".mli" ])
              ) 
        in 
        Ext_array.fold_left (Sys.readdir dirname) acc (fun acc source_file -> 
            if (Ext_string.ends_with source_file ".ml" ||
                Ext_string.ends_with source_file ".mli" )
            && (* not_excluded source_file *) (not (Ext_list.mem_string excludes source_file ))
            then 
              (Filename.concat dirname source_file) :: acc else acc
          ) )
  in
  let ast_table = collect_ast_map ppf files parse_implementation parse_interface in 
  let visited = String_hashtbl.create 31 in
  let result = Queue.create () in  
  let next module_name : String_set.t =
    let module_set = 
      match String_map.find_exn ast_table module_name with
      | exception _ -> String_set.empty
      | {ast_info = Ml (_,  impl, _)} ->
        read_parse_and_extract Ml (project_impl impl)
      | {ast_info = Mli (_,  intf,_)} ->
        read_parse_and_extract Mli (project_intf intf)
      | {ast_info = Ml_mli(_, impl, _, _,  intf, _)}
        -> 
        String_set.union
          (read_parse_and_extract Ml (project_impl impl))
          (read_parse_and_extract Mli (project_intf intf))
    in 
    match alias_map with 
    | None -> module_set 
    | Some map -> 
      String_set.fold (fun x acc -> String_set.add (String_hashtbl.find_default map x x) acc  ) module_set String_set.empty
  in
  let rec visit visiting path current =
    if String_set.mem current visiting  then
      Bs_exception.error (Bs_cyclic_depends (current::path))
    else
    if not (String_hashtbl.mem visited current)
    && String_map.mem ast_table current then
      begin
        String_set.iter
          (visit
             (String_set.add current visiting)
             (current::path))
          (next current) ;
        Queue.push current result;
        String_hashtbl.add visited current ();
      end in
  visit (String_set.empty) [] main_module ;
  ast_table, result   


let build_queue ppf queue
    (ast_table : _ t String_map.t)
    after_parsing_impl
    after_parsing_sig    
  =
  queue
  |> Queue.iter
    (fun modname -> 
       match String_map.find_exn ast_table modname  with
       | {ast_info = Ml(source_file,ast, opref)}
         -> 
         after_parsing_impl ppf source_file 
           opref ast 
       | {ast_info = Mli (source_file,ast,opref) ; }  
         ->
         after_parsing_sig ppf source_file 
           opref ast 
       | {ast_info = Ml_mli(source_file1,impl,opref1,source_file2,intf,opref2)}
         -> 
         after_parsing_sig ppf source_file1 opref1 intf ;
         after_parsing_impl ppf source_file2 opref2 impl
       | exception Not_found -> assert false 
    )


let handle_queue 
  ppf 
  queue ast_table 
  decorate_module_only 
  decorate_interface_only 
  decorate_module = 
  queue 
  |> Queue.iter
    (fun base ->
       match (String_map.find_exn ast_table base ).ast_info with
       | exception Not_found -> assert false
       | Ml (ml_name,  ml_content, _)
         ->
         decorate_module_only  base ml_name ml_content
       | Mli (mli_name , mli_content, _) ->
         decorate_interface_only base  mli_name mli_content
       | Ml_mli (ml_name, ml_content, _, mli_name,   mli_content, _)
         ->
         decorate_module  base mli_name ml_name mli_content ml_content

    )



let build_lazy_queue ppf queue (ast_table : _ t String_map.t)
    after_parsing_impl
    after_parsing_sig    
  =
  queue |> Queue.iter (fun modname -> 
      match String_map.find_exn ast_table modname  with
      | {ast_info = Ml(source_file,lazy ast, opref)}
        -> 
        after_parsing_impl ppf source_file opref ast 
      | {ast_info = Mli (source_file,lazy ast,opref) ; }  
        ->
        after_parsing_sig ppf source_file opref ast 
      | {ast_info = Ml_mli(source_file1,lazy impl,opref1,source_file2,lazy intf,opref2)}
        -> 
        after_parsing_sig ppf source_file1 opref1 intf ;
        after_parsing_impl ppf source_file2 opref2 impl
      | exception Not_found -> assert false 
    )


end
module Binary_ast : sig 
#1 "binary_ast.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


val read_ast : 'a Ml_binary.kind -> string -> 'a 


val magic_sep_char : char

(**
   Check out {!Bsb_depfile_gen} for set decoding
   The [.ml] file can be recognized as an ast directly, the format
   is
   {
   magic number;
   filename;
   ast
   }
   when [fname] is "-" it means the file is from an standard input or pipe.
   An empty name would marshallized.

   Use case cat - | fan -printer -impl -
   redirect the standard input to fan
 *)
val write_ast : sourcefile:string -> output:string -> 'a Ml_binary.kind -> 'a -> unit


end = struct
#1 "binary_ast.ml"

(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

 (** Synced up with module {!Bsb_helper_depfile_gen} *)
module String_set = Ast_extract.String_set



let read_ast (type t ) (kind : t  Ml_binary.kind) fn : t  =
  let ic = open_in_bin fn in
  try
    let dep_size = input_binary_int ic in 
    seek_in  ic (pos_in ic + dep_size) ; 
    let ast = Ml_binary.read_ast kind ic in 
    close_in ic;
    ast
  with exn ->
    close_in ic;
    raise exn

let magic_sep_char = '\n'
(*
   Reasons that we don't [output_value] the set:
   1. for performance , easy skipping and calcuate the length 
   2. cut dependency, otherwise its type is {!Ast_extract.String_set.t}
*)      
let write_ast (type t) ~(sourcefile : string) ~output (kind : t Ml_binary.kind) ( pt : t) : unit =
  let oc = open_out_bin output in 
  let output_set = Ast_extract.read_parse_and_extract kind pt in
  let buf = Ext_buffer.create 1000 in

  Ext_buffer.add_char buf magic_sep_char;  
  String_set.iter (fun s ->
      if s <> "" && s.[0] <> '*' then begin (* filter *predef* *)
        Ext_buffer.add_string_char buf s magic_sep_char; 
      end
    ) output_set ;  
  output_binary_int oc (Ext_buffer.length buf);  
  Ext_buffer.output_buffer oc buf;
  Ml_binary.write_ast kind sourcefile pt oc;
  close_out oc 


end
module Btype : sig 
#1 "btype.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Basic operations on core types *)

open Asttypes
open Types

(**** Sets, maps and hashtables of types ****)

module TypeSet  : Set.S with type elt = type_expr
module TypeMap  : Map.S with type key = type_expr
module TypeHash : Hashtbl.S with type key = type_expr

(**** Levels ****)

val generic_level: int

val newty2: int -> type_desc -> type_expr
        (* Create a type *)
val newgenty: type_desc -> type_expr
        (* Create a generic type *)
val newgenvar: ?name:string -> unit -> type_expr
        (* Return a fresh generic variable *)

(* Use Tsubst instead
val newmarkedvar: int -> type_expr
        (* Return a fresh marked variable *)
val newmarkedgenvar: unit -> type_expr
        (* Return a fresh marked generic variable *)
*)

(**** Types ****)

val is_Tvar: type_expr -> bool
val is_Tunivar: type_expr -> bool
val is_Tconstr: type_expr -> bool
val dummy_method: label
val default_mty: module_type option -> module_type

val repr: type_expr -> type_expr
        (* Return the canonical representative of a type. *)

val field_kind_repr: field_kind -> field_kind
        (* Return the canonical representative of an object field
           kind. *)

val commu_repr: commutable -> commutable
        (* Return the canonical representative of a commutation lock *)

(**** polymorphic variants ****)

val row_repr: row_desc -> row_desc
        (* Return the canonical representative of a row description *)
val row_field_repr: row_field -> row_field
val row_field: label -> row_desc -> row_field
        (* Return the canonical representative of a row field *)
val row_more: row_desc -> type_expr
        (* Return the extension variable of the row *)
val row_fixed: row_desc -> bool
        (* Return whether the row should be treated as fixed or not *)
val static_row: row_desc -> bool
        (* Return whether the row is static or not *)
val hash_variant: label -> int
        (* Hash function for variant tags *)

val proxy: type_expr -> type_expr
        (* Return the proxy representative of the type: either itself
           or a row variable *)

(**** Utilities for private abbreviations with fixed rows ****)
val row_of_type: type_expr -> type_expr
val has_constr_row: type_expr -> bool
val is_row_name: string -> bool
val is_constr_row: allow_ident:bool -> type_expr -> bool

(**** Utilities for type traversal ****)

val iter_type_expr: (type_expr -> unit) -> type_expr -> unit
        (* Iteration on types *)
val iter_row: (type_expr -> unit) -> row_desc -> unit
        (* Iteration on types in a row *)
val iter_abbrev: (type_expr -> unit) -> abbrev_memo -> unit
        (* Iteration on types in an abbreviation list *)

type type_iterators =
  { it_signature: type_iterators -> signature -> unit;
    it_signature_item: type_iterators -> signature_item -> unit;
    it_value_description: type_iterators -> value_description -> unit;
    it_type_declaration: type_iterators -> type_declaration -> unit;
    it_extension_constructor: type_iterators -> extension_constructor -> unit;
    it_module_declaration: type_iterators -> module_declaration -> unit;
    it_modtype_declaration: type_iterators -> modtype_declaration -> unit;
    it_class_declaration: type_iterators -> class_declaration -> unit;
    it_class_type_declaration: type_iterators -> class_type_declaration -> unit;
    it_module_type: type_iterators -> module_type -> unit;
    it_class_type: type_iterators -> class_type -> unit;
    it_type_kind: type_iterators -> type_kind -> unit;
    it_do_type_expr: type_iterators -> type_expr -> unit;
    it_type_expr: type_iterators -> type_expr -> unit;
    it_path: Path.t -> unit; }
val type_iterators: type_iterators
        (* Iteration on arbitrary type information.
           [it_type_expr] calls [mark_type_node] to avoid loops. *)
val unmark_iterators: type_iterators
        (* Unmark any structure containing types. See [unmark_type] below. *)

val copy_type_desc:
    ?keep_names:bool -> (type_expr -> type_expr) -> type_desc -> type_desc
        (* Copy on types *)
val copy_row:
    (type_expr -> type_expr) ->
    bool -> row_desc -> bool -> type_expr -> row_desc
val copy_kind: field_kind -> field_kind

val save_desc: type_expr -> type_desc -> unit
        (* Save a type description *)
val dup_kind: field_kind option ref -> unit
        (* Save a None field_kind, and make it point to a fresh Fvar *)
val cleanup_types: unit -> unit
        (* Restore type descriptions *)

val lowest_level: int
        (* Marked type: ty.level < lowest_level *)
val pivot_level: int
        (* Type marking: ty.level <- pivot_level - ty.level *)
val mark_type: type_expr -> unit
        (* Mark a type *)
val mark_type_node: type_expr -> unit
        (* Mark a type node (but not its sons) *)
val mark_type_params: type_expr -> unit
        (* Mark the sons of a type node *)
val unmark_type: type_expr -> unit
val unmark_type_decl: type_declaration -> unit
val unmark_extension_constructor: extension_constructor -> unit
val unmark_class_type: class_type -> unit
val unmark_class_signature: class_signature -> unit
        (* Remove marks from a type *)

(**** Memorization of abbreviation expansion ****)

val find_expans: private_flag -> Path.t -> abbrev_memo -> type_expr option
        (* Look up a memorized abbreviation *)
val cleanup_abbrev: unit -> unit
        (* Flush the cache of abbreviation expansions.
           When some types are saved (using [output_value]), this
           function MUST be called just before. *)
val memorize_abbrev:
        abbrev_memo ref ->
        private_flag -> Path.t -> type_expr -> type_expr -> unit
        (* Add an expansion in the cache *)
val forget_abbrev:
        abbrev_memo ref -> Path.t -> unit
        (* Remove an abbreviation from the cache *)

(**** Utilities for labels ****)

val is_optional : arg_label -> bool
val label_name : arg_label -> label

(* Returns the label name with first character '?' or '~' as appropriate. *)
val prefixed_label_name : arg_label -> label

val extract_label :
    label -> (arg_label * 'a) list ->
    arg_label * 'a * (arg_label * 'a) list * (arg_label * 'a) list
    (* actual label, value, before list, after list *)

(**** Utilities for backtracking ****)

type snapshot
        (* A snapshot for backtracking *)
val snapshot: unit -> snapshot
        (* Make a snapshot for later backtracking. Costs nothing *)
val backtrack: snapshot -> unit
        (* Backtrack to a given snapshot. Only possible if you have
           not already backtracked to a previous snapshot.
           Calls [cleanup_abbrev] internally *)
val undo_compress: snapshot -> unit
        (* Backtrack only path compression. Only meaningful if you have
           not already backtracked to a previous snapshot.
           Does not call [cleanup_abbrev] *)

(* Functions to use when modifying a type (only Ctype?) *)
val link_type: type_expr -> type_expr -> unit
        (* Set the desc field of [t1] to [Tlink t2], logging the old
           value if there is an active snapshot *)
val set_level: type_expr -> int -> unit
val set_name:
    (Path.t * type_expr list) option ref ->
    (Path.t * type_expr list) option -> unit
val set_row_field: row_field option ref -> row_field -> unit
val set_univar: type_expr option ref -> type_expr -> unit
val set_kind: field_kind option ref -> field_kind -> unit
val set_commu: commutable ref -> commutable -> unit
val set_typeset: TypeSet.t ref -> TypeSet.t -> unit
        (* Set references, logging the old value *)
val log_type: type_expr -> unit
        (* Log the old value of a type, before modifying it by hand *)

(**** Forward declarations ****)
val print_raw: (Format.formatter -> type_expr -> unit) ref

val iter_type_expr_kind: (type_expr -> unit) -> (type_kind -> unit)

val iter_type_expr_cstr_args: (type_expr -> unit) ->
  (constructor_arguments -> unit)
val map_type_expr_cstr_args: (type_expr -> type_expr) ->
  (constructor_arguments -> constructor_arguments)

end = struct
#1 "btype.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Basic operations on core types *)

open Misc
open Asttypes
open Types

(**** Sets, maps and hashtables of types ****)

module TypeSet = Set.Make(TypeOps)
module TypeMap = Map.Make (TypeOps)
module TypeHash = Hashtbl.Make(TypeOps)

(**** Forward declarations ****)

let print_raw =
  ref (fun _ -> assert false : Format.formatter -> type_expr -> unit)

(**** Type level management ****)

let generic_level = 100000000

(* Used to mark a type during a traversal. *)
let lowest_level = 0
let pivot_level = 2 * lowest_level - 1
    (* pivot_level - lowest_level < lowest_level *)

(**** Some type creators ****)

let new_id = ref (-1)

let newty2 level desc  =
  incr new_id; { desc; level; id = !new_id }
let newgenty desc      = newty2 generic_level desc
let newgenvar ?name () = newgenty (Tvar name)
(*
let newmarkedvar level =
  incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id }
let newmarkedgenvar () =
  incr new_id;
  { desc = Tvar; level = pivot_level - generic_level; id = !new_id }
*)

(**** Check some types ****)

let is_Tvar = function {desc=Tvar _} -> true | _ -> false
let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false
let is_Tconstr = function {desc=Tconstr _} -> true | _ -> false

let dummy_method = "*dummy method*"
let default_mty = function
    Some mty -> mty
  | None -> Mty_signature []

(**** Definitions for backtracking ****)

type change =
    Ctype of type_expr * type_desc
  | Ccompress of type_expr * type_desc * type_desc
  | Clevel of type_expr * int
  | Cname of
      (Path.t * type_expr list) option ref * (Path.t * type_expr list) option
  | Crow of row_field option ref * row_field option
  | Ckind of field_kind option ref * field_kind option
  | Ccommu of commutable ref * commutable
  | Cuniv of type_expr option ref * type_expr option
  | Ctypeset of TypeSet.t ref * TypeSet.t

type changes =
    Change of change * changes ref
  | Unchanged
  | Invalid

let trail = Weak.create 1

let log_change ch =
  match Weak.get trail 0 with None -> ()
  | Some r ->
      let r' = ref Unchanged in
      r := Change (ch, r');
      Weak.set trail 0 (Some r')

(**** Representative of a type ****)

let rec field_kind_repr =
  function
    Fvar {contents = Some kind} -> field_kind_repr kind
  | kind                        -> kind

let rec repr_link compress t d =
 function
   {desc = Tlink t' as d'} ->
     repr_link true t d' t'
 | {desc = Tfield (_, k, _, t') as d'} when field_kind_repr k = Fabsent ->
     repr_link true t d' t'
 | t' ->
     if compress then begin
       log_change (Ccompress (t, t.desc, d)); t.desc <- d
     end;
     t'

let repr t =
  match t.desc with
   Tlink t' as d ->
     repr_link false t d t'
 | Tfield (_, k, _, t') as d when field_kind_repr k = Fabsent ->
     repr_link false t d t'
 | _ -> t

let rec commu_repr = function
    Clink r when !r <> Cunknown -> commu_repr !r
  | c -> c

let rec row_field_repr_aux tl = function
    Reither(_, tl', _, {contents = Some fi}) ->
      row_field_repr_aux (tl@tl') fi
  | Reither(c, tl', m, r) ->
      Reither(c, tl@tl', m, r)
  | Rpresent (Some _) when tl <> [] ->
      Rpresent (Some (List.hd tl))
  | fi -> fi

let row_field_repr fi = row_field_repr_aux [] fi

let rec rev_concat l ll =
  match ll with
    [] -> l
  | l'::ll -> rev_concat (l'@l) ll

let rec row_repr_aux ll row =
  match (repr row.row_more).desc with
  | Tvariant row' ->
      let f = row.row_fields in
      row_repr_aux (if f = [] then ll else f::ll) row'
  | _ ->
      if ll = [] then row else
      {row with row_fields = rev_concat row.row_fields ll}

let row_repr row = row_repr_aux [] row

let rec row_field tag row =
  let rec find = function
    | (tag',f) :: fields ->
        if tag = tag' then row_field_repr f else find fields
    | [] ->
        match repr row.row_more with
        | {desc=Tvariant row'} -> row_field tag row'
        | _ -> Rabsent
  in find row.row_fields

let rec row_more row =
  match repr row.row_more with
  | {desc=Tvariant row'} -> row_more row'
  | ty -> ty

let row_fixed row =
  let row = row_repr row in
  row.row_fixed ||
  match (repr row.row_more).desc with
    Tvar _ | Tnil -> false
  | Tunivar _ | Tconstr _ -> true
  | _ -> assert false

let static_row row =
  let row = row_repr row in
  row.row_closed &&
  List.for_all
    (fun (_,f) -> match row_field_repr f with Reither _ -> false | _ -> true)
    row.row_fields

let hash_variant s =
  let accu = ref 0 in
  for i = 0 to String.length s - 1 do
    accu := 223 * !accu + Char.code s.[i]
  done;
  (* reduce to 31 bits *)
  accu := !accu land (1 lsl 31 - 1);
  (* make it signed for 64 bits architectures *)
  if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu

let proxy ty =
  let ty0 = repr ty in
  match ty0.desc with
  | Tvariant row when not (static_row row) ->
      row_more row
  | Tobject (ty, _) ->
      let rec proxy_obj ty =
        match ty.desc with
          Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty
        | Tvar _ | Tunivar _ | Tconstr _ -> ty
        | Tnil -> ty0
        | _ -> assert false
      in proxy_obj ty
  | _ -> ty0

(**** Utilities for fixed row private types ****)

let row_of_type t = 
  match (repr t).desc with
    Tobject(t,_) ->
      let rec get_row t =
        let t = repr t in
        match t.desc with
          Tfield(_,_,_,t) -> get_row t
        | _ -> t
      in get_row t
  | Tvariant row ->
      row_more row
  | _ ->
      t

let has_constr_row t =
  not (is_Tconstr t) && is_Tconstr (row_of_type t)

let is_row_name s =
  let l = String.length s in
  if l < 4 then false else String.sub s (l-4) 4 = "#row"

let is_constr_row ~allow_ident t =
  match t.desc with
    Tconstr (Path.Pident id, _, _) when allow_ident ->
      is_row_name (Ident.name id)
  | Tconstr (Path.Pdot (_, s, _), _, _) -> is_row_name s
  | _ -> false


                  (**********************************)
                  (*  Utilities for type traversal  *)
                  (**********************************)

let rec iter_row f row =
  List.iter
    (fun (_, fi) ->
      match row_field_repr fi with
      | Rpresent(Some ty) -> f ty
      | Reither(_, tl, _, _) -> List.iter f tl
      | _ -> ())
    row.row_fields;
  match (repr row.row_more).desc with
    Tvariant row -> iter_row f row
  | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ | Tnil ->
      Misc.may (fun (_,l) -> List.iter f l) row.row_name
  | _ -> assert false

let iter_type_expr f ty =
  match ty.desc with
    Tvar _              -> ()
  | Tarrow (_, ty1, ty2, _) -> f ty1; f ty2
  | Ttuple l            -> List.iter f l
  | Tconstr (_, l, _)   -> List.iter f l
  | Tobject(ty, {contents = Some (_, p)})
                        -> f ty; List.iter f p
  | Tobject (ty, _)     -> f ty
  | Tvariant row        -> iter_row f row; f (row_more row)
  | Tfield (_, _, ty1, ty2) -> f ty1; f ty2
  | Tnil                -> ()
  | Tlink ty            -> f ty
  | Tsubst ty           -> f ty
  | Tunivar _           -> ()
  | Tpoly (ty, tyl)     -> f ty; List.iter f tyl
  | Tpackage (_, _, l)  -> List.iter f l

let rec iter_abbrev f = function
    Mnil                   -> ()
  | Mcons(_, _, ty, ty', rem) -> f ty; f ty'; iter_abbrev f rem
  | Mlink rem              -> iter_abbrev f !rem

type type_iterators =
  { it_signature: type_iterators -> signature -> unit;
    it_signature_item: type_iterators -> signature_item -> unit;
    it_value_description: type_iterators -> value_description -> unit;
    it_type_declaration: type_iterators -> type_declaration -> unit;
    it_extension_constructor: type_iterators -> extension_constructor -> unit;
    it_module_declaration: type_iterators -> module_declaration -> unit;
    it_modtype_declaration: type_iterators -> modtype_declaration -> unit;
    it_class_declaration: type_iterators -> class_declaration -> unit;
    it_class_type_declaration: type_iterators -> class_type_declaration -> unit;
    it_module_type: type_iterators -> module_type -> unit;
    it_class_type: type_iterators -> class_type -> unit;
    it_type_kind: type_iterators -> type_kind -> unit;
    it_do_type_expr: type_iterators -> type_expr -> unit;
    it_type_expr: type_iterators -> type_expr -> unit;
    it_path: Path.t -> unit; }

let iter_type_expr_cstr_args f = function
  | Cstr_tuple tl -> List.iter f tl
  | Cstr_record lbls -> List.iter (fun d -> f d.ld_type) lbls

let map_type_expr_cstr_args f = function
  | Cstr_tuple tl -> Cstr_tuple (List.map f tl)
  | Cstr_record lbls ->
      Cstr_record (List.map (fun d -> {d with ld_type=f d.ld_type}) lbls)

let iter_type_expr_kind f = function
  | Type_abstract -> ()
  | Type_variant cstrs ->
      List.iter
        (fun cd ->
           iter_type_expr_cstr_args f cd.cd_args;
           Misc.may f cd.cd_res
        )
        cstrs
  | Type_record(lbls, _) ->
      List.iter (fun d -> f d.ld_type) lbls
  | Type_open ->
      ()


let type_iterators =
  let it_signature it =
    List.iter (it.it_signature_item it)
  and it_signature_item it = function
      Sig_value (_, vd)     -> it.it_value_description it vd
    | Sig_type (_, td, _)   -> it.it_type_declaration it td
    | Sig_typext (_, td, _) -> it.it_extension_constructor it td
    | Sig_module (_, md, _) -> it.it_module_declaration it md
    | Sig_modtype (_, mtd)  -> it.it_modtype_declaration it mtd
    | Sig_class (_, cd, _)  -> it.it_class_declaration it cd
    | Sig_class_type (_, ctd, _) -> it.it_class_type_declaration it ctd
  and it_value_description it vd =
    it.it_type_expr it vd.val_type
  and it_type_declaration it td =
    List.iter (it.it_type_expr it) td.type_params;
    may (it.it_type_expr it) td.type_manifest;
    it.it_type_kind it td.type_kind
  and it_extension_constructor it td =
    it.it_path td.ext_type_path;
    List.iter (it.it_type_expr it) td.ext_type_params;
    iter_type_expr_cstr_args (it.it_type_expr it) td.ext_args;
    may (it.it_type_expr it) td.ext_ret_type
  and it_module_declaration it md =
    it.it_module_type it md.md_type
  and it_modtype_declaration it mtd =
    may (it.it_module_type it) mtd.mtd_type
  and it_class_declaration it cd =
    List.iter (it.it_type_expr it) cd.cty_params;
    it.it_class_type it cd.cty_type;
    may (it.it_type_expr it) cd.cty_new;
    it.it_path cd.cty_path
  and it_class_type_declaration it ctd =
    List.iter (it.it_type_expr it) ctd.clty_params;
    it.it_class_type it ctd.clty_type;
    it.it_path ctd.clty_path
  and it_module_type it = function
      Mty_ident p
    | Mty_alias(_, p) -> it.it_path p
    | Mty_signature sg -> it.it_signature it sg
    | Mty_functor (_, mto, mt) ->
        may (it.it_module_type it) mto;
        it.it_module_type it mt
  and it_class_type it = function
      Cty_constr (p, tyl, cty) ->
        it.it_path p;
        List.iter (it.it_type_expr it) tyl;
        it.it_class_type it cty
    | Cty_signature cs ->
        it.it_type_expr it cs.csig_self;
        Vars.iter (fun _ (_,_,ty) -> it.it_type_expr it ty) cs.csig_vars;
        List.iter
          (fun (p, tl) -> it.it_path p; List.iter (it.it_type_expr it) tl)
          cs.csig_inher
    | Cty_arrow  (_, ty, cty) ->
        it.it_type_expr it ty;
        it.it_class_type it cty
  and it_type_kind it kind =
    iter_type_expr_kind (it.it_type_expr it) kind
  and it_do_type_expr it ty =
    iter_type_expr (it.it_type_expr it) ty;
    match ty.desc with
      Tconstr (p, _, _)
    | Tobject (_, {contents=Some (p, _)})
    | Tpackage (p, _, _) ->
        it.it_path p
    | Tvariant row ->
        may (fun (p,_) -> it.it_path p) (row_repr row).row_name
    | _ -> ()
  and it_path _p = ()
  in
  { it_path; it_type_expr = it_do_type_expr; it_do_type_expr;
    it_type_kind; it_class_type; it_module_type;
    it_signature; it_class_type_declaration; it_class_declaration;
    it_modtype_declaration; it_module_declaration; it_extension_constructor;
    it_type_declaration; it_value_description; it_signature_item; }

let copy_row f fixed row keep more =
  let fields = List.map
      (fun (l, fi) -> l,
        match row_field_repr fi with
        | Rpresent(Some ty) -> Rpresent(Some(f ty))
        | Reither(c, tl, m, e) ->
            let e = if keep then e else ref None in
            let m = if row.row_fixed then fixed else m in
            let tl = List.map f tl in
            Reither(c, tl, m, e)
        | _ -> fi)
      row.row_fields in
  let name =
    match row.row_name with None -> None
    | Some (path, tl) -> Some (path, List.map f tl) in
  { row_fields = fields; row_more = more;
    row_bound = (); row_fixed = row.row_fixed && fixed;
    row_closed = row.row_closed; row_name = name; }

let rec copy_kind = function
    Fvar{contents = Some k} -> copy_kind k
  | Fvar _   -> Fvar (ref None)
  | Fpresent -> Fpresent
  | Fabsent  -> assert false

let copy_commu c =
  if commu_repr c = Cok then Cok else Clink (ref Cunknown)

(* Since univars may be used as row variables, we need to do some
   encoding during substitution *)
let rec norm_univar ty =
  match ty.desc with
    Tunivar _ | Tsubst _ -> ty
  | Tlink ty           -> norm_univar ty
  | Ttuple (ty :: _)   -> norm_univar ty
  | _                  -> assert false

let rec copy_type_desc ?(keep_names=false) f = function
    Tvar _ as ty        -> if keep_names then ty else Tvar None
  | Tarrow (p, ty1, ty2, c)-> Tarrow (p, f ty1, f ty2, copy_commu c)
  | Ttuple l            -> Ttuple (List.map f l)
  | Tconstr (p, l, _)   -> Tconstr (p, List.map f l, ref Mnil)
  | Tobject(ty, {contents = Some (p, tl)})
                        -> Tobject (f ty, ref (Some(p, List.map f tl)))
  | Tobject (ty, _)     -> Tobject (f ty, ref None)
  | Tvariant _          -> assert false (* too ambiguous *)
  | Tfield (p, k, ty1, ty2) -> (* the kind is kept shared *)
      Tfield (p, field_kind_repr k, f ty1, f ty2)
  | Tnil                -> Tnil
  | Tlink ty            -> copy_type_desc f ty.desc
  | Tsubst _            -> assert false
  | Tunivar _ as ty     -> ty (* always keep the name *)
  | Tpoly (ty, tyl)     ->
      let tyl = List.map (fun x -> norm_univar (f x)) tyl in
      Tpoly (f ty, tyl)
  | Tpackage (p, n, l)  -> Tpackage (p, n, List.map f l)

(* Utilities for copying *)

let saved_desc = ref []
  (* Saved association of generic nodes with their description. *)

let save_desc ty desc =
  saved_desc := (ty, desc)::!saved_desc

let saved_kinds = ref [] (* duplicated kind variables *)
let new_kinds = ref []   (* new kind variables *)
let dup_kind r =
  (match !r with None -> () | Some _ -> assert false);
  if not (List.memq r !new_kinds) then begin
    saved_kinds := r :: !saved_kinds;
    let r' = ref None in
    new_kinds := r' :: !new_kinds;
    r := Some (Fvar r')
  end

(* Restored type descriptions. *)
let cleanup_types () =
  List.iter (fun (ty, desc) -> ty.desc <- desc) !saved_desc;
  List.iter (fun r -> r := None) !saved_kinds;
  saved_desc := []; saved_kinds := []; new_kinds := []

(* Mark a type. *)
let rec mark_type ty =
  let ty = repr ty in
  if ty.level >= lowest_level then begin
    ty.level <- pivot_level - ty.level;
    iter_type_expr mark_type ty
  end

let mark_type_node ty =
  let ty = repr ty in
  if ty.level >= lowest_level then begin
    ty.level <- pivot_level - ty.level;
  end

let mark_type_params ty =
  iter_type_expr mark_type ty

let type_iterators =
  let it_type_expr it ty =
    let ty = repr ty in
    if ty.level >= lowest_level then begin
      mark_type_node ty;
      it.it_do_type_expr it ty;
    end
  in
  {type_iterators with it_type_expr}


(* Remove marks from a type. *)
let rec unmark_type ty =
  let ty = repr ty in
  if ty.level < lowest_level then begin
    ty.level <- pivot_level - ty.level;
    iter_type_expr unmark_type ty
  end

let unmark_iterators =
  let it_type_expr _it ty = unmark_type ty in
  {type_iterators with it_type_expr}

let unmark_type_decl decl =
  unmark_iterators.it_type_declaration unmark_iterators decl

let unmark_extension_constructor ext =
  List.iter unmark_type ext.ext_type_params;
  iter_type_expr_cstr_args unmark_type ext.ext_args;
  Misc.may unmark_type ext.ext_ret_type

let unmark_class_signature sign =
  unmark_type sign.csig_self;
  Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars

let unmark_class_type cty =
  unmark_iterators.it_class_type unmark_iterators cty


                  (*******************************************)
                  (*  Memorization of abbreviation expansion *)
                  (*******************************************)

(* Search whether the expansion has been memorized. *)

let lte_public p1 p2 =  (* Private <= Public *)
  match p1, p2 with
  | Private, _ | _, Public -> true
  | Public, Private -> false

let rec find_expans priv p1 = function
    Mnil -> None
  | Mcons (priv', p2, _ty0, ty, _)
    when lte_public priv priv' && Path.same p1 p2 -> Some ty
  | Mcons (_, _, _, _, rem)   -> find_expans priv p1 rem
  | Mlink {contents = rem} -> find_expans priv p1 rem

(* debug: check for cycles in abbreviation. only works with -principal
let rec check_expans visited ty =
  let ty = repr ty in
  assert (not (List.memq ty visited));
  match ty.desc with
    Tconstr (path, args, abbrev) ->
      begin match find_expans path !abbrev with
        Some ty' -> check_expans (ty :: visited) ty'
      | None -> ()
      end
  | _ -> ()
*)

let memo = ref []
        (* Contains the list of saved abbreviation expansions. *)

let cleanup_abbrev () =
        (* Remove all memorized abbreviation expansions. *)
  List.iter (fun abbr -> abbr := Mnil) !memo;
  memo := []

let memorize_abbrev mem priv path v v' =
        (* Memorize the expansion of an abbreviation. *)
  mem := Mcons (priv, path, v, v', !mem);
  (* check_expans [] v; *)
  memo := mem :: !memo

let rec forget_abbrev_rec mem path =
  match mem with
    Mnil ->
      assert false
  | Mcons (_, path', _, _, rem) when Path.same path path' ->
      rem
  | Mcons (priv, path', v, v', rem) ->
      Mcons (priv, path', v, v', forget_abbrev_rec rem path)
  | Mlink mem' ->
      mem' := forget_abbrev_rec !mem' path;
      raise Exit

let forget_abbrev mem path =
  try mem := forget_abbrev_rec !mem path with Exit -> ()

(* debug: check for invalid abbreviations
let rec check_abbrev_rec = function
    Mnil -> true
  | Mcons (_, ty1, ty2, rem) ->
      repr ty1 != repr ty2
  | Mlink mem' ->
      check_abbrev_rec !mem'

let check_memorized_abbrevs () =
  List.for_all (fun mem -> check_abbrev_rec !mem) !memo
*)

                  (**********************************)
                  (*  Utilities for labels          *)
                  (**********************************)

let is_optional = function Optional _ -> true | _ -> false

let label_name = function
    Nolabel -> ""
  | Labelled s
  | Optional s -> s

let prefixed_label_name = function
    Nolabel -> ""
  | Labelled s -> "~" ^ s
  | Optional s -> "?" ^ s

let rec extract_label_aux hd l = function
    [] -> raise Not_found
  | (l',t as p) :: ls ->
      if label_name l' = l then (l', t, List.rev hd, ls)
      else extract_label_aux (p::hd) l ls

let extract_label l ls = extract_label_aux [] l ls


                  (**********************************)
                  (*  Utilities for backtracking    *)
                  (**********************************)

let undo_change = function
    Ctype  (ty, desc) -> ty.desc <- desc
  | Ccompress  (ty, desc, _) -> ty.desc <- desc
  | Clevel (ty, level) -> ty.level <- level
  | Cname  (r, v) -> r := v
  | Crow   (r, v) -> r := v
  | Ckind  (r, v) -> r := v
  | Ccommu (r, v) -> r := v
  | Cuniv  (r, v) -> r := v
  | Ctypeset (r, v) -> r := v

type snapshot = changes ref * int
let last_snapshot = ref 0

let log_type ty =
  if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc))
let link_type ty ty' =
  log_type ty;
  let desc = ty.desc in
  ty.desc <- Tlink ty';
  (* Name is a user-supplied name for this unification variable (obtained
   * through a type annotation for instance). *)
  match desc, ty'.desc with
    Tvar name, Tvar name' ->
      begin match name, name' with
      | Some _, None ->  log_type ty'; ty'.desc <- Tvar name
      | None, Some _ ->  ()
      | Some _, Some _ ->
          if ty.level < ty'.level then (log_type ty'; ty'.desc <- Tvar name)
      | None, None   ->  ()
      end
  | _ -> ()
  (* ; assert (check_memorized_abbrevs ()) *)
  (*  ; check_expans [] ty' *)
let set_level ty level =
  if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level));
  ty.level <- level
let set_univar rty ty =
  log_change (Cuniv (rty, !rty)); rty := Some ty
let set_name nm v =
  log_change (Cname (nm, !nm)); nm := v
let set_row_field e v =
  log_change (Crow (e, !e)); e := Some v
let set_kind rk k =
  log_change (Ckind (rk, !rk)); rk := Some k
let set_commu rc c =
  log_change (Ccommu (rc, !rc)); rc := c
let set_typeset rs s =
  log_change (Ctypeset (rs, !rs)); rs := s

let snapshot () =
  let old = !last_snapshot in
  last_snapshot := !new_id;
  match Weak.get trail 0 with Some r -> (r, old)
  | None ->
      let r = ref Unchanged in
      Weak.set trail 0 (Some r);
      (r, old)

let rec rev_log accu = function
    Unchanged -> accu
  | Invalid -> assert false
  | Change (ch, next) ->
      let d = !next in
      next := Invalid;
      rev_log (ch::accu) d

let backtrack (changes, old) =
  match !changes with
    Unchanged -> last_snapshot := old
  | Invalid -> failwith "Btype.backtrack"
  | Change _ as change ->
      cleanup_abbrev ();
      let backlog = rev_log [] change in
      List.iter undo_change backlog;
      changes := Unchanged;
      last_snapshot := old;
      Weak.set trail 0 (Some changes)

let rec rev_compress_log log r =
  match !r with
    Unchanged | Invalid ->
      log
  | Change (Ccompress _, next) ->
      rev_compress_log (r::log) next
  | Change (_, next) ->
      rev_compress_log log next

let undo_compress (changes, _old) =
  match !changes with
    Unchanged
  | Invalid -> ()
  | Change _ ->
      let log = rev_compress_log [] changes in
      List.iter
        (fun r -> match !r with
          Change (Ccompress (ty, desc, d), next) when ty.desc == d ->
            ty.desc <- desc; r := !next
        | _ -> ())
        log

end
module Consistbl : sig 
#1 "consistbl.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Consistency tables: for checking consistency of module CRCs *)

type t

val create: unit -> t

val clear: t -> unit

val check: t -> string -> Digest.t -> string -> unit
      (* [check tbl name crc source]
           checks consistency of ([name], [crc]) with infos previously
           stored in [tbl].  If no CRC was previously associated with
           [name], record ([name], [crc]) in [tbl].
           [source] is the name of the file from which the information
           comes from.  This is used for error reporting. *)

val check_noadd: t -> string -> Digest.t -> string -> unit
      (* Same as [check], but raise [Not_available] if no CRC was previously
           associated with [name]. *)

val set: t -> string -> Digest.t -> string -> unit
      (* [set tbl name crc source] forcefully associates [name] with
         [crc] in [tbl], even if [name] already had a different CRC
         associated with [name] in [tbl]. *)

val source: t -> string -> string
      (* [source tbl name] returns the file name associated with [name]
         if the latter has an associated CRC in [tbl].
         Raise [Not_found] otherwise. *)

val extract: string list -> t -> (string * Digest.t option) list
      (* [extract tbl names] returns an associative list mapping each string
         in [names] to the CRC associated with it in [tbl]. If no CRC is
         associated with a name then it is mapped to [None]. *)

val filter: (string -> bool) -> t -> unit
      (* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs
         such that [pred name] is [false]. *)

exception Inconsistency of string * string * string
      (* Raised by [check] when a CRC mismatch is detected.
         First string is the name of the compilation unit.
         Second string is the source that caused the inconsistency.
         Third string is the source that set the CRC. *)

exception Not_available of string
      (* Raised by [check_noadd] when a name doesn't have an associated CRC. *)

end = struct
#1 "consistbl.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Consistency tables: for checking consistency of module CRCs *)

type t = (string, Digest.t * string) Hashtbl.t

let create () = Hashtbl.create 13

let clear = Hashtbl.clear

exception Inconsistency of string * string * string

exception Not_available of string

let check tbl name crc source =
  try
    let (old_crc, old_source) = Hashtbl.find tbl name in
    if crc <> old_crc then raise(Inconsistency(name, source, old_source))
  with Not_found ->
    Hashtbl.add tbl name (crc, source)

let check_noadd tbl name crc source =
  try
    let (old_crc, old_source) = Hashtbl.find tbl name in
    if crc <> old_crc then raise(Inconsistency(name, source, old_source))
  with Not_found ->
    raise (Not_available name)

let set tbl name crc source = Hashtbl.add tbl name (crc, source)

let source tbl name = snd (Hashtbl.find tbl name)

let extract l tbl =
  let l = List.sort_uniq String.compare l in
  List.fold_left
    (fun assc name ->
       try
         let (crc, _) = Hashtbl.find tbl name in
           (name, Some crc) :: assc
       with Not_found ->
         (name, None) :: assc)
    [] l

let filter p tbl =
  let to_remove = ref [] in
  Hashtbl.iter
    (fun name _ ->
      if not (p name) then to_remove := name :: !to_remove)
    tbl;
  List.iter
    (fun name ->
       while Hashtbl.mem tbl name do Hashtbl.remove tbl name done)
    !to_remove

end
module Datarepr : sig 
#1 "datarepr.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Compute constructor and label descriptions from type declarations,
   determining their representation. *)

open Types

val constructor_has_optional_shape:
  Types.constructor_description -> bool

val extension_descr:
  Path.t -> extension_constructor -> constructor_description

val labels_of_type:
  Path.t -> type_declaration ->
  (Ident.t * label_description) list
val constructors_of_type:
  Path.t -> type_declaration ->
  (Ident.t * constructor_description) list


exception Constr_not_found

val find_constr_by_tag:
  constructor_tag -> constructor_declaration list ->
    constructor_declaration

val constructor_existentials :
    constructor_arguments -> type_expr option -> type_expr list * type_expr list
(** Takes [cd_args] and [cd_res] from a [constructor_declaration] and
    returns:
    - the types of the constructor's arguments
    - the existential variables introduced by the constructor
 *)


(* Set the polymorphic variant row_name field *)
val set_row_name : type_declaration -> Path.t -> unit

end = struct
#1 "datarepr.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Compute constructor and label descriptions from type declarations,
   determining their representation. *)

open Asttypes
open Types
open Btype

(* Simplified version of Ctype.free_vars *)
let free_vars ?(param=false) ty =
  let ret = ref TypeSet.empty in
  let rec loop ty =
    let ty = repr ty in
    if ty.level >= lowest_level then begin
      ty.level <- pivot_level - ty.level;
      match ty.desc with
      | Tvar _ ->
          ret := TypeSet.add ty !ret
      | Tvariant row ->
          let row = row_repr row in
          iter_row loop row;
          if not (static_row row) then begin
            match row.row_more.desc with
            | Tvar _ when param -> ret := TypeSet.add ty !ret
            | _ -> loop row.row_more
          end
      (* XXX: What about Tobject ? *)
      | _ ->
          iter_type_expr loop ty
    end
  in
  loop ty;
  unmark_type ty;
  !ret

let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil))

let constructor_existentials cd_args cd_res =
  let tyl =
    match cd_args with
    | Cstr_tuple l -> l
    | Cstr_record l -> List.map (fun l -> l.ld_type) l
  in
  let existentials =
    match cd_res with
    | None -> []
    | Some type_ret ->
        let arg_vars_set = free_vars (newgenty (Ttuple tyl)) in
        let res_vars = free_vars type_ret in
        TypeSet.elements (TypeSet.diff arg_vars_set res_vars)
  in
  (tyl, existentials)

let constructor_args priv cd_args cd_res path rep =
  let tyl, existentials = constructor_existentials cd_args cd_res in
  match cd_args with
  | Cstr_tuple l -> existentials, l, None
  | Cstr_record lbls ->
      let arg_vars_set = free_vars ~param:true (newgenty (Ttuple tyl)) in
      let type_params = TypeSet.elements arg_vars_set in
      let type_unboxed =
        match rep with
        | Record_unboxed _ -> unboxed_true_default_false
        | _ -> unboxed_false_default_false
      in
      let tdecl =
        {
          type_params;
          type_arity = List.length type_params;
          type_kind = Type_record (lbls, rep);
          type_private = priv;
          type_manifest = None;
          type_variance = List.map (fun _ -> Variance.full) type_params;
          type_newtype_level = None;
          type_loc = Location.none;
          type_attributes = [];
          type_immediate = false;
          type_unboxed;
        }
      in
      existentials,
      [ newgenconstr path type_params ],
      Some tdecl

let internal_optional = "internal.optional"
  
let optional_shape : Parsetree.attribute =
  {txt = internal_optional ; loc = Location.none}, Parsetree.PStr []

let constructor_has_optional_shape ({cstr_attributes = attrs} : constructor_description) =
  List.exists (fun (x,_) -> x.txt = internal_optional) attrs


let constructor_descrs ty_path decl cstrs =
  let ty_res = newgenconstr ty_path decl.type_params in
  let num_consts = ref 0 and num_nonconsts = ref 0  and num_normal = ref 0 in
  List.iter
    (fun {cd_args; cd_res; _} ->
      if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts;
      if cd_res = None then incr num_normal)
    cstrs;
  let rec describe_constructors idx_const idx_nonconst = function
      [] -> []
    | {cd_id; cd_args; cd_res; cd_loc; cd_attributes} :: rem ->
        let ty_res =
          match cd_res with
          | Some ty_res' -> ty_res'
          | None -> ty_res
        in
        let (tag, descr_rem) =
          match cd_args with
          | _ when decl.type_unboxed.unboxed ->
            assert (rem = []);
            (Cstr_unboxed, [])
          | Cstr_tuple [] -> (Cstr_constant idx_const,
                   describe_constructors (idx_const+1) idx_nonconst rem)
          | _  -> (Cstr_block idx_nonconst,
                   describe_constructors idx_const (idx_nonconst+1) rem) in
        let cstr_name = Ident.name cd_id in
        let existentials, cstr_args, cstr_inlined =
          let representation =
            if decl.type_unboxed.unboxed
            then Record_unboxed true
            else Record_inlined {tag = idx_nonconst; name = cstr_name; num_nonconsts = !num_nonconsts}
          in
          constructor_args decl.type_private cd_args cd_res
            (Path.Pdot (ty_path, cstr_name, Path.nopos)) representation
        in
        let cstr =
          { cstr_name;
            cstr_res = ty_res;
            cstr_existentials = existentials;
            cstr_args;
            cstr_arity = List.length cstr_args;
            cstr_tag = tag;
            cstr_consts = !num_consts;
            cstr_nonconsts = !num_nonconsts;
            cstr_normal = !num_normal;
            cstr_private = decl.type_private;
            cstr_generalized = cd_res <> None;
            cstr_loc = cd_loc;
            cstr_attributes = cd_attributes;
            cstr_inlined;
          } in
        (cd_id, cstr) :: descr_rem in
  let result = describe_constructors 0 0 cstrs in 
  match result with
  | (
    [ ({Ident.name = "None"} as a_id, ({cstr_args = []} as a_descr) )  ;
      ({Ident.name = "Some"} as b_id, ({ cstr_args = [_]} as b_descr))
    ] |
    [ ({Ident.name = "Some"} as a_id, ({cstr_args = [_]} as a_descr) )  ;
      ({Ident.name = "None"} as b_id, ({ cstr_args = []} as b_descr))
    ]
   )
    ->
      [
        (a_id, {a_descr with
                   cstr_attributes =
                     optional_shape :: a_descr.cstr_attributes});
        (b_id, {b_descr with
                   cstr_attributes =
                     optional_shape :: b_descr.cstr_attributes
                  })
      ]
  | _ -> result        

let extension_descr path_ext ext =
  let ty_res =
    match ext.ext_ret_type with
        Some type_ret -> type_ret
      | None -> newgenconstr ext.ext_type_path ext.ext_type_params
  in
  let existentials, cstr_args, cstr_inlined =
    constructor_args ext.ext_private ext.ext_args ext.ext_ret_type
      path_ext Record_extension
  in
    { cstr_name = Path.last path_ext;
      cstr_res = ty_res;
      cstr_existentials = existentials;
      cstr_args;
      cstr_arity = List.length cstr_args;
      cstr_tag = Cstr_extension(path_ext, cstr_args = []);
      cstr_consts = -1;
      cstr_nonconsts = -1;
      cstr_private = ext.ext_private;
      cstr_normal = -1;
      cstr_generalized = ext.ext_ret_type <> None;
      cstr_loc = ext.ext_loc;
      cstr_attributes = ext.ext_attributes;
      cstr_inlined;
    }

let none = {desc = Ttuple []; level = -1; id = -1}
                                        (* Clearly ill-formed type *)
let dummy_label =
  { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable;
    lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular;
    lbl_private = Public;
    lbl_loc = Location.none;
    lbl_attributes = [];
  }

let label_descrs ty_res lbls repres priv =
  let all_labels = Array.make (List.length lbls) dummy_label in
  let rec describe_labels num = function
      [] -> []
    | l :: rest ->
        let lbl =
          { lbl_name = Ident.name l.ld_id;
            lbl_res = ty_res;
            lbl_arg = l.ld_type;
            lbl_mut = l.ld_mutable;
            lbl_pos = num;
            lbl_all = all_labels;
            lbl_repres = repres;
            lbl_private = priv;
            lbl_loc = l.ld_loc;
            lbl_attributes = l.ld_attributes;
          } in
        all_labels.(num) <- lbl;
        (l.ld_id, lbl) :: describe_labels (num+1) rest in
  describe_labels 0 lbls

exception Constr_not_found

let rec find_constr tag num_const num_nonconst = function
    [] ->
      raise Constr_not_found
  | {cd_args = Cstr_tuple []; _} as c  :: rem ->
      if tag = Cstr_constant num_const
      then c
      else find_constr tag (num_const + 1) num_nonconst rem
  | c :: rem ->
      if tag = Cstr_block num_nonconst || tag = Cstr_unboxed
      then c
      else find_constr tag num_const (num_nonconst + 1) rem

let find_constr_by_tag tag cstrlist =
  find_constr tag 0 0 cstrlist

let constructors_of_type ty_path decl =
  match decl.type_kind with
  | Type_variant cstrs -> constructor_descrs ty_path decl cstrs
  | Type_record _ | Type_abstract | Type_open -> []

let labels_of_type ty_path decl =
  match decl.type_kind with
  | Type_record(labels, rep) ->
      label_descrs (newgenconstr ty_path decl.type_params)
        labels rep decl.type_private
  | Type_variant _ | Type_abstract | Type_open -> []

(* Set row_name in Env, cf. GPR#1204/1329 *)
let set_row_name decl path =
  match decl.type_manifest with
    None -> ()
  | Some ty ->
      let ty = repr ty in
      match ty.desc with
        Tvariant row when static_row row ->
          let row = {(row_repr row) with
                     row_name = Some (path, decl.type_params)} in
          ty.desc <- Tvariant row
      | _ -> ()

end
module Predef : sig 
#1 "predef.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Predefined type constructors (with special typing rules in typecore) *)

open Types

val type_int: type_expr
val type_char: type_expr
val type_string: type_expr
val type_bytes: type_expr
val type_float: type_expr
val type_bool: type_expr
val type_unit: type_expr
val type_exn: type_expr
val type_array: type_expr -> type_expr
val type_list: type_expr -> type_expr
val type_option: type_expr -> type_expr
val type_nativeint: type_expr
val type_int32: type_expr
val type_int64: type_expr
val type_lazy_t: type_expr -> type_expr
val type_extension_constructor:type_expr
val type_floatarray:type_expr

val path_int: Path.t
val path_char: Path.t
val path_string: Path.t
val path_bytes: Path.t
val path_float: Path.t
val path_bool: Path.t
val path_unit: Path.t
val path_exn: Path.t
val path_array: Path.t
val path_list: Path.t
val path_option: Path.t
val path_nativeint: Path.t
val path_int32: Path.t
val path_int64: Path.t
val path_lazy_t: Path.t
val path_extension_constructor: Path.t
val path_floatarray: Path.t

val path_match_failure: Path.t
val path_assert_failure : Path.t
val path_undefined_recursive_module : Path.t

(* To build the initial environment. Since there is a nasty mutual
   recursion between predef and env, we break it by parameterizing
   over Env.t, Env.add_type and Env.add_extension. *)

val build_initial_env:
  (Ident.t -> type_declaration -> 'a -> 'a) ->
  (Ident.t -> extension_constructor -> 'a -> 'a) ->
  'a -> 'a * 'a

(* To initialize linker tables *)

val builtin_values: (string * Ident.t) list
val builtin_idents: (string * Ident.t) list

(** All predefined exceptions, exposed as [Ident.t] for flambda (for
    building value approximations).
    The [Ident.t] for division by zero is also exported explicitly
    so flambda can generate code to raise it. *)
val ident_division_by_zero: Ident.t
val all_predef_exns : Ident.t list

val type_is_builtin_path_but_option : Path.t -> bool

end = struct
#1 "predef.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Predefined type constructors (with special typing rules in typecore) *)

open Path
open Types
open Btype

let builtin_idents = ref []

let wrap create s =
  let id = create s in
  builtin_idents := (s, id) :: !builtin_idents;
  id

let ident_create = wrap Ident.create
let ident_create_predef_exn = wrap Ident.create_predef_exn

let ident_int = ident_create "int"
and ident_char = ident_create "char"
and ident_bytes = ident_create "bytes"
and ident_float = ident_create "float"
and ident_bool = ident_create "bool"
and ident_unit = ident_create "unit"
and ident_exn = ident_create "exn"
and ident_array = ident_create "array"
and ident_list = ident_create "list"
and ident_option = ident_create "option"
and ident_nativeint = ident_create "nativeint"
and ident_int32 = ident_create "int32"
and ident_int64 = ident_create "int64"
and ident_lazy_t = ident_create "lazy_t"
and ident_string = ident_create "string"
and ident_extension_constructor = ident_create "extension_constructor"
and ident_floatarray = ident_create "floatarray"

let type_is_builtin_path_but_option (p : Path.t) =
  match p with
  | Pident {Ident.stamp} ->
      stamp >= ident_int.Ident.stamp
      && stamp  <= ident_floatarray.Ident.stamp
      && (stamp <> ident_option.Ident.stamp)
  | _ -> false

let path_int = Pident ident_int
and path_char = Pident ident_char
and path_bytes = Pident ident_bytes
and path_float = Pident ident_float
and path_bool = Pident ident_bool
and path_unit = Pident ident_unit
and path_exn = Pident ident_exn
and path_array = Pident ident_array
and path_list = Pident ident_list
and path_option = Pident ident_option
and path_nativeint = Pident ident_nativeint
and path_int32 = Pident ident_int32
and path_int64 = Pident ident_int64
and path_lazy_t = Pident ident_lazy_t
and path_string = Pident ident_string
and path_extension_constructor = Pident ident_extension_constructor
and path_floatarray = Pident ident_floatarray

let type_int = newgenty (Tconstr(path_int, [], ref Mnil))
and type_char = newgenty (Tconstr(path_char, [], ref Mnil))
and type_bytes = newgenty (Tconstr(path_bytes, [], ref Mnil))
and type_float = newgenty (Tconstr(path_float, [], ref Mnil))
and type_bool = newgenty (Tconstr(path_bool, [], ref Mnil))
and type_unit = newgenty (Tconstr(path_unit, [], ref Mnil))
and type_exn = newgenty (Tconstr(path_exn, [], ref Mnil))
and type_array t = newgenty (Tconstr(path_array, [t], ref Mnil))
and type_list t = newgenty (Tconstr(path_list, [t], ref Mnil))
and type_option t = newgenty (Tconstr(path_option, [t], ref Mnil))
and type_nativeint = newgenty (Tconstr(path_nativeint, [], ref Mnil))
and type_int32 = newgenty (Tconstr(path_int32, [], ref Mnil))
and type_int64 = newgenty (Tconstr(path_int64, [], ref Mnil))
and type_lazy_t t = newgenty (Tconstr(path_lazy_t, [t], ref Mnil))
and type_string = newgenty (Tconstr(path_string, [], ref Mnil))
and type_extension_constructor =
      newgenty (Tconstr(path_extension_constructor, [], ref Mnil))
and type_floatarray = newgenty (Tconstr(path_floatarray, [], ref Mnil))

let ident_match_failure = ident_create_predef_exn "Match_failure"
and ident_out_of_memory = ident_create_predef_exn "Out_of_memory"
and ident_invalid_argument = ident_create_predef_exn "Invalid_argument"
and ident_failure = ident_create_predef_exn "Failure"
and ident_not_found = ident_create_predef_exn "Not_found"
and ident_sys_error = ident_create_predef_exn "Sys_error"
and ident_end_of_file = ident_create_predef_exn "End_of_file"
and ident_division_by_zero = ident_create_predef_exn "Division_by_zero"
and ident_stack_overflow = ident_create_predef_exn "Stack_overflow"
and ident_sys_blocked_io = ident_create_predef_exn "Sys_blocked_io"
and ident_assert_failure = ident_create_predef_exn "Assert_failure"
and ident_undefined_recursive_module =
        ident_create_predef_exn "Undefined_recursive_module"

let all_predef_exns = [
  ident_match_failure;
  ident_out_of_memory;
  ident_invalid_argument;
  ident_failure;
  ident_not_found;
  ident_sys_error;
  ident_end_of_file;
  ident_division_by_zero;
  ident_stack_overflow;
  ident_sys_blocked_io;
  ident_assert_failure;
  ident_undefined_recursive_module;
]

let path_match_failure = Pident ident_match_failure
and path_assert_failure = Pident ident_assert_failure
and path_undefined_recursive_module = Pident ident_undefined_recursive_module

let decl_abstr =
  {type_params = [];
   type_arity = 0;
   type_kind = Type_abstract;
   type_loc = Location.none;
   type_private = Asttypes.Public;
   type_manifest = None;
   type_variance = [];
   type_newtype_level = None;
   type_attributes = [];
   type_immediate = false;
   type_unboxed = unboxed_false_default_false;
  }

let decl_abstr_imm = {decl_abstr with type_immediate = true}

let cstr id args =
  {
    cd_id = id;
    cd_args = Cstr_tuple args;
    cd_res = None;
    cd_loc = Location.none;
    cd_attributes = [];
  }

let ident_false = ident_create "false"
and ident_true = ident_create "true"
and ident_void = ident_create "()"
and ident_nil = ident_create "[]"
and ident_cons = ident_create "::"
and ident_none = ident_create "None"
and ident_some = ident_create "Some"
let common_initial_env add_type add_extension empty_env =
  let decl_bool =
    {decl_abstr with
     type_kind = Type_variant([cstr ident_false []; cstr ident_true []]);
     type_immediate = true}
  and decl_unit =
    {decl_abstr with
     type_kind = Type_variant([cstr ident_void []]);
     type_immediate = true}
  and decl_exn =
    {decl_abstr with
     type_kind = Type_open}
  and decl_array =
    let tvar = newgenvar() in
    {decl_abstr with
     type_params = [tvar];
     type_arity = 1;
     type_variance = [Variance.full]}
  and decl_list =
    let tvar = newgenvar() in
    {decl_abstr with
     type_params = [tvar];
     type_arity = 1;
     type_kind =
     Type_variant([cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]]);
     type_variance = [Variance.covariant]}
  and decl_option =
    let tvar = newgenvar() in
    {decl_abstr with
     type_params = [tvar];
     type_arity = 1;
     type_kind = Type_variant([cstr ident_none []; cstr ident_some [tvar]]);
     type_variance = [Variance.covariant]}
  and decl_lazy_t =
    let tvar = newgenvar() in
    {decl_abstr with
     type_params = [tvar];
     type_arity = 1;
     type_variance = [Variance.covariant]}
  in

  let add_extension id l =
    add_extension id
      { ext_type_path = path_exn;
        ext_type_params = [];
        ext_args = Cstr_tuple l;
        ext_ret_type = None;
        ext_private = Asttypes.Public;
        ext_loc = Location.none;
        ext_attributes = [{Asttypes.txt="ocaml.warn_on_literal_pattern";
                           loc=Location.none},
                          Parsetree.PStr[]] }
  in
  add_extension ident_match_failure
                         [newgenty (Ttuple[type_string; type_int; type_int])] (
  add_extension ident_out_of_memory [] (
  add_extension ident_stack_overflow [] (
  add_extension ident_invalid_argument [type_string] (
  add_extension ident_failure [type_string] (
  add_extension ident_not_found [] (
  add_extension ident_sys_blocked_io [] (
  add_extension ident_sys_error [type_string] (
  add_extension ident_end_of_file [] (
  add_extension ident_division_by_zero [] (
  add_extension ident_assert_failure
                         [newgenty (Ttuple[type_string; type_int; type_int])] (
  add_extension ident_undefined_recursive_module
                         [newgenty (Ttuple[type_string; type_int; type_int])] (
  add_type ident_int64 decl_abstr (
  add_type ident_int32 decl_abstr (
  add_type ident_nativeint decl_abstr (
  add_type ident_lazy_t decl_lazy_t (
  add_type ident_option decl_option (
  add_type ident_list decl_list (
  add_type ident_array decl_array (
  add_type ident_exn decl_exn (
  add_type ident_unit decl_unit (
  add_type ident_bool decl_bool (
  add_type ident_float decl_abstr (
  add_type ident_string decl_abstr (
  add_type ident_char decl_abstr_imm (
  add_type ident_int decl_abstr_imm (
  add_type ident_extension_constructor decl_abstr (
  add_type ident_floatarray decl_abstr (
    empty_env))))))))))))))))))))))))))))

let build_initial_env add_type add_exception empty_env =
  let common = common_initial_env add_type add_exception empty_env in
  let safe_string = add_type ident_bytes decl_abstr common in
  let decl_bytes_unsafe = {decl_abstr with type_manifest = Some type_string} in
  let unsafe_string = add_type ident_bytes decl_bytes_unsafe common in
  (safe_string, unsafe_string)

let builtin_values =
  List.map (fun id -> Ident.make_global id; (Ident.name id, id))
      [ident_match_failure; ident_out_of_memory; ident_stack_overflow;
       ident_invalid_argument;
       ident_failure; ident_not_found; ident_sys_error; ident_end_of_file;
       ident_division_by_zero; ident_sys_blocked_io;
       ident_assert_failure; ident_undefined_recursive_module ]

(* Start non-predef identifiers at 1000.  This way, more predefs can
   be defined in this file (above!) without breaking .cmi
   compatibility. *)

let _ = Ident.set_current_time 999
let builtin_idents = List.rev !builtin_idents

end
module Ast_mapper : sig 
#1 "ast_mapper.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                         Alain Frisch, LexiFi                           *)
(*                                                                        *)
(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** The interface of a -ppx rewriter

  A -ppx rewriter is a program that accepts a serialized abstract syntax
  tree and outputs another, possibly modified, abstract syntax tree.
  This module encapsulates the interface between the compiler and
  the -ppx rewriters, handling such details as the serialization format,
  forwarding of command-line flags, and storing state.

  {!mapper} allows to implement AST rewriting using open recursion.
  A typical mapper would be based on {!default_mapper}, a deep
  identity mapper, and will fall back on it for handling the syntax it
  does not modify. For example:

  {[
open Asttypes
open Parsetree
open Ast_mapper

let test_mapper argv =
  { default_mapper with
    expr = fun mapper expr ->
      match expr with
      | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} ->
        Ast_helper.Exp.constant (Const_int 42)
      | other -> default_mapper.expr mapper other; }

let () =
  register "ppx_test" test_mapper]}

  This -ppx rewriter, which replaces [[%test]] in expressions with
  the constant [42], can be compiled using
  [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml].

  *)

open Parsetree

(** {1 A generic Parsetree mapper} *)

type mapper = {
  attribute: mapper -> attribute -> attribute;
  attributes: mapper -> attribute list -> attribute list;
  case: mapper -> case -> case;
  cases: mapper -> case list -> case list;
  class_declaration: mapper -> class_declaration -> class_declaration;
  class_description: mapper -> class_description -> class_description;
  class_expr: mapper -> class_expr -> class_expr;
  class_field: mapper -> class_field -> class_field;
  class_signature: mapper -> class_signature -> class_signature;
  class_structure: mapper -> class_structure -> class_structure;
  class_type: mapper -> class_type -> class_type;
  class_type_declaration: mapper -> class_type_declaration
                          -> class_type_declaration;
  class_type_field: mapper -> class_type_field -> class_type_field;
  constructor_declaration: mapper -> constructor_declaration
                           -> constructor_declaration;
  expr: mapper -> expression -> expression;
  extension: mapper -> extension -> extension;
  extension_constructor: mapper -> extension_constructor
                         -> extension_constructor;
  include_declaration: mapper -> include_declaration -> include_declaration;
  include_description: mapper -> include_description -> include_description;
  label_declaration: mapper -> label_declaration -> label_declaration;
  location: mapper -> Location.t -> Location.t;
  module_binding: mapper -> module_binding -> module_binding;
  module_declaration: mapper -> module_declaration -> module_declaration;
  module_expr: mapper -> module_expr -> module_expr;
  module_type: mapper -> module_type -> module_type;
  module_type_declaration: mapper -> module_type_declaration
                           -> module_type_declaration;
  open_description: mapper -> open_description -> open_description;
  pat: mapper -> pattern -> pattern;
  payload: mapper -> payload -> payload;
  signature: mapper -> signature -> signature;
  signature_item: mapper -> signature_item -> signature_item;
  structure: mapper -> structure -> structure;
  structure_item: mapper -> structure_item -> structure_item;
  typ: mapper -> core_type -> core_type;
  type_declaration: mapper -> type_declaration -> type_declaration;
  type_extension: mapper -> type_extension -> type_extension;
  type_kind: mapper -> type_kind -> type_kind;
  value_binding: mapper -> value_binding -> value_binding;
  value_description: mapper -> value_description -> value_description;
  with_constraint: mapper -> with_constraint -> with_constraint;
}
(** A mapper record implements one "method" per syntactic category,
    using an open recursion style: each method takes as its first
    argument the mapper to be applied to children in the syntax
    tree. *)

val default_mapper: mapper
(** A default mapper, which implements a "deep identity" mapping. *)

(** {1 Apply mappers to compilation units} *)

val tool_name: unit -> string
(** Can be used within a ppx preprocessor to know which tool is
    calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"],
    ["ocaml"], ...  Some global variables that reflect command-line
    options are automatically synchronized between the calling tool
    and the ppx preprocessor: {!Clflags.include_dirs},
    {!Config.load_path}, {!Clflags.open_modules}, {!Clflags.for_package},
    {!Clflags.debug}. *)


val apply: source:string -> target:string -> mapper -> unit
(** Apply a mapper (parametrized by the unit name) to a dumped
    parsetree found in the [source] file and put the result in the
    [target] file. The [structure] or [signature] field of the mapper
    is applied to the implementation or interface.  *)

val run_main: (string list -> mapper) -> unit
(** Entry point to call to implement a standalone -ppx rewriter from a
    mapper, parametrized by the command line arguments.  The current
    unit name can be obtained from {!Location.input_name}.  This
    function implements proper error reporting for uncaught
    exceptions. *)

(** {1 Registration API} *)

val register_function: (string -> (string list -> mapper) -> unit) ref

val register: string -> (string list -> mapper) -> unit
(** Apply the [register_function].  The default behavior is to run the
    mapper immediately, taking arguments from the process command
    line.  This is to support a scenario where a mapper is linked as a
    stand-alone executable.

    It is possible to overwrite the [register_function] to define
    "-ppx drivers", which combine several mappers in a single process.
    Typically, a driver starts by defining [register_function] to a
    custom implementation, then lets ppx rewriters (linked statically
    or dynamically) register themselves, and then run all or some of
    them.  It is also possible to have -ppx drivers apply rewriters to
    only specific parts of an AST.

    The first argument to [register] is a symbolic name to be used by
    the ppx driver.  *)


(** {1 Convenience functions to write mappers} *)

val map_opt: ('a -> 'b) -> 'a option -> 'b option

val extension_of_error: Location.error -> extension
(** Encode an error into an 'ocaml.error' extension node which can be
    inserted in a generated Parsetree.  The compiler will be
    responsible for reporting the error. *)

val attribute_of_warning: Location.t -> string -> attribute
(** Encode a warning message into an 'ocaml.ppwarning' attribute which can be
    inserted in a generated Parsetree.  The compiler will be
    responsible for reporting the warning. *)

(** {1 Helper functions to call external mappers} *)

val add_ppx_context_str:
    tool_name:string -> Parsetree.structure -> Parsetree.structure
(** Extract information from the current environment and encode it
    into an attribute which is prepended to the list of structure
    items in order to pass the information to an external
    processor. *)

val add_ppx_context_sig:
    tool_name:string -> Parsetree.signature -> Parsetree.signature
(** Same as [add_ppx_context_str], but for signatures. *)

val drop_ppx_context_str:
    restore:bool -> Parsetree.structure -> Parsetree.structure
(** Drop the ocaml.ppx.context attribute from a structure.  If
    [restore] is true, also restore the associated data in the current
    process. *)

val drop_ppx_context_sig:
    restore:bool -> Parsetree.signature -> Parsetree.signature
(** Same as [drop_ppx_context_str], but for signatures. *)

(** {1 Cookies} *)

(** Cookies are used to pass information from a ppx processor to
    a further invocation of itself, when called from the OCaml
    toplevel (or other tools that support cookies). *)

val set_cookie: string -> Parsetree.expression -> unit
val get_cookie: string -> Parsetree.expression option

end = struct
#1 "ast_mapper.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                         Alain Frisch, LexiFi                           *)
(*                                                                        *)
(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* A generic Parsetree mapping class *)

(*
[@@@ocaml.warning "+9"]
  (* Ensure that record patterns don't miss any field. *)
*)


open Parsetree
open Ast_helper
open Location

type mapper = {
  attribute: mapper -> attribute -> attribute;
  attributes: mapper -> attribute list -> attribute list;
  case: mapper -> case -> case;
  cases: mapper -> case list -> case list;
  class_declaration: mapper -> class_declaration -> class_declaration;
  class_description: mapper -> class_description -> class_description;
  class_expr: mapper -> class_expr -> class_expr;
  class_field: mapper -> class_field -> class_field;
  class_signature: mapper -> class_signature -> class_signature;
  class_structure: mapper -> class_structure -> class_structure;
  class_type: mapper -> class_type -> class_type;
  class_type_declaration: mapper -> class_type_declaration
                          -> class_type_declaration;
  class_type_field: mapper -> class_type_field -> class_type_field;
  constructor_declaration: mapper -> constructor_declaration
                           -> constructor_declaration;
  expr: mapper -> expression -> expression;
  extension: mapper -> extension -> extension;
  extension_constructor: mapper -> extension_constructor
                         -> extension_constructor;
  include_declaration: mapper -> include_declaration -> include_declaration;
  include_description: mapper -> include_description -> include_description;
  label_declaration: mapper -> label_declaration -> label_declaration;
  location: mapper -> Location.t -> Location.t;
  module_binding: mapper -> module_binding -> module_binding;
  module_declaration: mapper -> module_declaration -> module_declaration;
  module_expr: mapper -> module_expr -> module_expr;
  module_type: mapper -> module_type -> module_type;
  module_type_declaration: mapper -> module_type_declaration
                           -> module_type_declaration;
  open_description: mapper -> open_description -> open_description;
  pat: mapper -> pattern -> pattern;
  payload: mapper -> payload -> payload;
  signature: mapper -> signature -> signature;
  signature_item: mapper -> signature_item -> signature_item;
  structure: mapper -> structure -> structure;
  structure_item: mapper -> structure_item -> structure_item;
  typ: mapper -> core_type -> core_type;
  type_declaration: mapper -> type_declaration -> type_declaration;
  type_extension: mapper -> type_extension -> type_extension;
  type_kind: mapper -> type_kind -> type_kind;
  value_binding: mapper -> value_binding -> value_binding;
  value_description: mapper -> value_description -> value_description;
  with_constraint: mapper -> with_constraint -> with_constraint;
}

let map_fst f (x, y) = (f x, y)
let map_snd f (x, y) = (x, f y)
let map_tuple f1 f2 (x, y) = (f1 x, f2 y)
let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
let map_opt f = function None -> None | Some x -> Some (f x)

let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}

module T = struct
  (* Type expressions for the core language *)

  let row_field sub = function
    | Rtag (l, attrs, b, tl) ->
        Rtag (map_loc sub l, sub.attributes sub attrs,
              b, List.map (sub.typ sub) tl)
    | Rinherit t -> Rinherit (sub.typ sub t)

  let object_field sub = function
    | Otag (l, attrs, t) ->
        Otag (map_loc sub l, sub.attributes sub attrs, sub.typ sub t)
    | Oinherit t -> Oinherit (sub.typ sub t)

  let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
    let open Typ in
    let loc = sub.location sub loc in
    let attrs = sub.attributes sub attrs in
    match desc with
    | Ptyp_any -> any ~loc ~attrs ()
    | Ptyp_var s -> var ~loc ~attrs s
    | Ptyp_arrow (lab, t1, t2) ->
        arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
    | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
    | Ptyp_constr (lid, tl) ->
        constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
    | Ptyp_object (l, o) ->
        object_ ~loc ~attrs (List.map (object_field sub) l) o
    | Ptyp_class (lid, tl) ->
        class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
    | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s
    | Ptyp_variant (rl, b, ll) ->
        variant ~loc ~attrs (List.map (row_field sub) rl) b ll
    | Ptyp_poly (sl, t) -> poly ~loc ~attrs
                             (List.map (map_loc sub) sl) (sub.typ sub t)
    | Ptyp_package (lid, l) ->
        package ~loc ~attrs (map_loc sub lid)
          (List.map (map_tuple (map_loc sub) (sub.typ sub)) l)
    | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x)

  let map_type_declaration sub
      {ptype_name; ptype_params; ptype_cstrs;
       ptype_kind;
       ptype_private;
       ptype_manifest;
       ptype_attributes;
       ptype_loc} =
    Type.mk (map_loc sub ptype_name)
      ~params:(List.map (map_fst (sub.typ sub)) ptype_params)
      ~priv:ptype_private
      ~cstrs:(List.map
                (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub))
                ptype_cstrs)
      ~kind:(sub.type_kind sub ptype_kind)
      ?manifest:(map_opt (sub.typ sub) ptype_manifest)
      ~loc:(sub.location sub ptype_loc)
      ~attrs:(sub.attributes sub ptype_attributes)

  let map_type_kind sub = function
    | Ptype_abstract -> Ptype_abstract
    | Ptype_variant l ->
        Ptype_variant (List.map (sub.constructor_declaration sub) l)
    | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l)
    | Ptype_open -> Ptype_open

  let map_constructor_arguments sub = function
    | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l)
    | Pcstr_record l ->
        Pcstr_record (List.map (sub.label_declaration sub) l)

  let map_type_extension sub
      {ptyext_path; ptyext_params;
       ptyext_constructors;
       ptyext_private;
       ptyext_attributes} =
    Te.mk
      (map_loc sub ptyext_path)
      (List.map (sub.extension_constructor sub) ptyext_constructors)
      ~params:(List.map (map_fst (sub.typ sub)) ptyext_params)
      ~priv:ptyext_private
      ~attrs:(sub.attributes sub ptyext_attributes)

  let map_extension_constructor_kind sub = function
      Pext_decl(ctl, cto) ->
        Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto)
    | Pext_rebind li ->
        Pext_rebind (map_loc sub li)

  let map_extension_constructor sub
      {pext_name;
       pext_kind;
       pext_loc;
       pext_attributes} =
    Te.constructor
      (map_loc sub pext_name)
      (map_extension_constructor_kind sub pext_kind)
      ~loc:(sub.location sub pext_loc)
      ~attrs:(sub.attributes sub pext_attributes)

end

module CT = struct
  (* Type expressions for the class language *)

  let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} =
    let open Cty in
    let loc = sub.location sub loc in
    let attrs = sub.attributes sub attrs in
    match desc with
    | Pcty_constr (lid, tys) ->
        constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
    | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x)
    | Pcty_arrow (lab, t, ct) ->
        arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct)
    | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x)
    | Pcty_open (ovf, lid, ct) ->
        open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_type sub ct)

  let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
    =
    let open Ctf in
    let loc = sub.location sub loc in
    let attrs = sub.attributes sub attrs in
    match desc with
    | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct)
    | Pctf_val (s, m, v, t) ->
        val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t)
    | Pctf_method (s, p, v, t) ->
        method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t)
    | Pctf_constraint (t1, t2) ->
        constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
    | Pctf_attribute x -> attribute ~loc (sub.attribute sub x)
    | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x)

  let map_signature sub {pcsig_self; pcsig_fields} =
    Csig.mk
      (sub.typ sub pcsig_self)
      (List.map (sub.class_type_field sub) pcsig_fields)
end

module MT = struct
  (* Type expressions for the module language *)

  let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} =
    let open Mty in
    let loc = sub.location sub loc in
    let attrs = sub.attributes sub attrs in
    match desc with
    | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
    | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s)
    | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg)
    | Pmty_functor (s, mt1, mt2) ->
        functor_ ~loc ~attrs (map_loc sub s)
          (Misc.may_map (sub.module_type sub) mt1)
          (sub.module_type sub mt2)
    | Pmty_with (mt, l) ->
        with_ ~loc ~attrs (sub.module_type sub mt)
          (List.map (sub.with_constraint sub) l)
    | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me)
    | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x)

  let map_with_constraint sub = function
    | Pwith_type (lid, d) ->
        Pwith_type (map_loc sub lid, sub.type_declaration sub d)
    | Pwith_module (lid, lid2) ->
        Pwith_module (map_loc sub lid, map_loc sub lid2)
    | Pwith_typesubst (lid, d) ->
        Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d)
    | Pwith_modsubst (s, lid) ->
        Pwith_modsubst (map_loc sub s, map_loc sub lid)

  let map_signature_item sub {psig_desc = desc; psig_loc = loc} =
    let open Sig in
    let loc = sub.location sub loc in
    match desc with
    | Psig_value vd -> value ~loc (sub.value_description sub vd)
    | Psig_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l)
    | Psig_typext te -> type_extension ~loc (sub.type_extension sub te)
    | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed)
    | Psig_module x -> module_ ~loc (sub.module_declaration sub x)
    | Psig_recmodule l ->
        rec_module ~loc (List.map (sub.module_declaration sub) l)
    | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
    | Psig_open x -> open_ ~loc (sub.open_description sub x)
    | Psig_include x -> include_ ~loc (sub.include_description sub x)
    | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l)
    | Psig_class_type l ->
        class_type ~loc (List.map (sub.class_type_declaration sub) l)
    | Psig_extension (x, attrs) ->
        extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs)
    | Psig_attribute x -> attribute ~loc (sub.attribute sub x)
end


module M = struct
  (* Value expressions for the module language *)

  let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
    let open Mod in
    let loc = sub.location sub loc in
    let attrs = sub.attributes sub attrs in
    match desc with
    | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x)
    | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str)
    | Pmod_functor (arg, arg_ty, body) ->
        functor_ ~loc ~attrs (map_loc sub arg)
          (Misc.may_map (sub.module_type sub) arg_ty)
          (sub.module_expr sub body)
    | Pmod_apply (m1, m2) ->
        apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2)
    | Pmod_constraint (m, mty) ->
        constraint_ ~loc ~attrs (sub.module_expr sub m)
                    (sub.module_type sub mty)
    | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e)
    | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x)

  let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
    let open Str in
    let loc = sub.location sub loc in
    match desc with
    | Pstr_eval (x, attrs) ->
        eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x)
    | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs)
    | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd)
    | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l)
    | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te)
    | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed)
    | Pstr_module x -> module_ ~loc (sub.module_binding sub x)
    | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l)
    | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
    | Pstr_open x -> open_ ~loc (sub.open_description sub x)
    | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l)
    | Pstr_class_type l ->
        class_type ~loc (List.map (sub.class_type_declaration sub) l)
    | Pstr_include x -> include_ ~loc (sub.include_declaration sub x)
    | Pstr_extension (x, attrs) ->
        extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs)
    | Pstr_attribute x -> attribute ~loc (sub.attribute sub x)
end

module E = struct
  (* Value expressions for the core language *)

  let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
    let open Exp in
    let loc = sub.location sub loc in
    let attrs = sub.attributes sub attrs in
    match desc with
    | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
    | Pexp_constant x -> constant ~loc ~attrs x
    | Pexp_let (r, vbs, e) ->
        let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
          (sub.expr sub e)
    | Pexp_fun (lab, def, p, e) ->
        fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p)
          (sub.expr sub e)
    | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel)
    | Pexp_apply (e, l) ->
        apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l)
    | Pexp_match (e, pel) ->
        match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
    | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
    | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el)
    | Pexp_construct (lid, arg) ->
        construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg)
    | Pexp_variant (lab, eo) ->
        variant ~loc ~attrs lab (map_opt (sub.expr sub) eo)
    | Pexp_record (l, eo) ->
        record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l)
          (map_opt (sub.expr sub) eo)
    | Pexp_field (e, lid) ->
        field ~loc ~attrs (sub.expr sub e) (map_loc sub lid)
    | Pexp_setfield (e1, lid, e2) ->
        setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid)
          (sub.expr sub e2)
    | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el)
    | Pexp_ifthenelse (e1, e2, e3) ->
        ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
          (map_opt (sub.expr sub) e3)
    | Pexp_sequence (e1, e2) ->
        sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
    | Pexp_while (e1, e2) ->
        while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
    | Pexp_for (p, e1, e2, d, e3) ->
        for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d
          (sub.expr sub e3)
    | Pexp_coerce (e, t1, t2) ->
        coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1)
          (sub.typ sub t2)
    | Pexp_constraint (e, t) ->
        constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t)
    | Pexp_send (e, s) ->
        send ~loc ~attrs (sub.expr sub e) (map_loc sub s)
    | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid)
    | Pexp_setinstvar (s, e) ->
        setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e)
    | Pexp_override sel ->
        override ~loc ~attrs
          (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel)
    | Pexp_letmodule (s, me, e) ->
        letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me)
          (sub.expr sub e)
    | Pexp_letexception (cd, e) ->
        letexception ~loc ~attrs
          (sub.extension_constructor sub cd)
          (sub.expr sub e)
    | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e)
    | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e)
    | Pexp_poly (e, t) ->
        poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t)
    | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls)
    | Pexp_newtype (s, e) ->
        newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e)
    | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me)
    | Pexp_open (ovf, lid, e) ->
        open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e)
    | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x)
    | Pexp_unreachable -> unreachable ~loc ~attrs ()
end

module P = struct
  (* Patterns *)

  let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} =
    let open Pat in
    let loc = sub.location sub loc in
    let attrs = sub.attributes sub attrs in
    match desc with
    | Ppat_any -> any ~loc ~attrs ()
    | Ppat_var s -> var ~loc ~attrs (map_loc sub s)
    | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s)
    | Ppat_constant c -> constant ~loc ~attrs c
    | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2
    | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl)
    | Ppat_construct (l, p) ->
        construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p)
    | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p)
    | Ppat_record (lpl, cf) ->
        record ~loc ~attrs
               (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf
    | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl)
    | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2)
    | Ppat_constraint (p, t) ->
        constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t)
    | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s)
    | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p)
    | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s)
    | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p)
    | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p)
    | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x)
end

module CE = struct
  (* Value expressions for the class language *)

  let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} =
    let open Cl in
    let loc = sub.location sub loc in
    let attrs = sub.attributes sub attrs in
    match desc with
    | Pcl_constr (lid, tys) ->
        constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
    | Pcl_structure s ->
        structure ~loc ~attrs (sub.class_structure sub s)
    | Pcl_fun (lab, e, p, ce) ->
        fun_ ~loc ~attrs lab
          (map_opt (sub.expr sub) e)
          (sub.pat sub p)
          (sub.class_expr sub ce)
    | Pcl_apply (ce, l) ->
        apply ~loc ~attrs (sub.class_expr sub ce)
          (List.map (map_snd (sub.expr sub)) l)
    | Pcl_let (r, vbs, ce) ->
        let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
          (sub.class_expr sub ce)
    | Pcl_constraint (ce, ct) ->
        constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct)
    | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x)
    | Pcl_open (ovf, lid, ce) ->
        open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_expr sub ce)

  let map_kind sub = function
    | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e)
    | Cfk_virtual t -> Cfk_virtual (sub.typ sub t)

  let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
    let open Cf in
    let loc = sub.location sub loc in
    let attrs = sub.attributes sub attrs in
    match desc with
    | Pcf_inherit (o, ce, s) ->
        inherit_ ~loc ~attrs o (sub.class_expr sub ce)
          (map_opt (map_loc sub) s)
    | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k)
    | Pcf_method (s, p, k) ->
        method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k)
    | Pcf_constraint (t1, t2) ->
        constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
    | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e)
    | Pcf_attribute x -> attribute ~loc (sub.attribute sub x)
    | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x)

  let map_structure sub {pcstr_self; pcstr_fields} =
    {
      pcstr_self = sub.pat sub pcstr_self;
      pcstr_fields = List.map (sub.class_field sub) pcstr_fields;
    }

  let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr;
                         pci_loc; pci_attributes} =
    Ci.mk
     ~virt:pci_virt
     ~params:(List.map (map_fst (sub.typ sub)) pl)
      (map_loc sub pci_name)
      (f pci_expr)
      ~loc:(sub.location sub pci_loc)
      ~attrs:(sub.attributes sub pci_attributes)
end

(* Now, a generic AST mapper, to be extended to cover all kinds and
   cases of the OCaml grammar.  The default behavior of the mapper is
   the identity. *)

let default_mapper =
  {
    structure = (fun this l -> List.map (this.structure_item this) l);
    structure_item = M.map_structure_item;
    module_expr = M.map;
    signature = (fun this l -> List.map (this.signature_item this) l);
    signature_item = MT.map_signature_item;
    module_type = MT.map;
    with_constraint = MT.map_with_constraint;
    class_declaration =
      (fun this -> CE.class_infos this (this.class_expr this));
    class_expr = CE.map;
    class_field = CE.map_field;
    class_structure = CE.map_structure;
    class_type = CT.map;
    class_type_field = CT.map_field;
    class_signature = CT.map_signature;
    class_type_declaration =
      (fun this -> CE.class_infos this (this.class_type this));
    class_description =
      (fun this -> CE.class_infos this (this.class_type this));
    type_declaration = T.map_type_declaration;
    type_kind = T.map_type_kind;
    typ = T.map;
    type_extension = T.map_type_extension;
    extension_constructor = T.map_extension_constructor;
    value_description =
      (fun this {pval_name; pval_type; pval_prim; pval_loc;
                 pval_attributes} ->
        Val.mk
          (map_loc this pval_name)
          (this.typ this pval_type)
          ~attrs:(this.attributes this pval_attributes)
          ~loc:(this.location this pval_loc)
          ~prim:pval_prim
      );

    pat = P.map;
    expr = E.map;

    module_declaration =
      (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} ->
         Md.mk
           (map_loc this pmd_name)
           (this.module_type this pmd_type)
           ~attrs:(this.attributes this pmd_attributes)
           ~loc:(this.location this pmd_loc)
      );

    module_type_declaration =
      (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} ->
         Mtd.mk
           (map_loc this pmtd_name)
           ?typ:(map_opt (this.module_type this) pmtd_type)
           ~attrs:(this.attributes this pmtd_attributes)
           ~loc:(this.location this pmtd_loc)
      );

    module_binding =
      (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} ->
         Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr)
           ~attrs:(this.attributes this pmb_attributes)
           ~loc:(this.location this pmb_loc)
      );


    open_description =
      (fun this {popen_lid; popen_override; popen_attributes; popen_loc} ->
         Opn.mk (map_loc this popen_lid)
           ~override:popen_override
           ~loc:(this.location this popen_loc)
           ~attrs:(this.attributes this popen_attributes)
      );


    include_description =
      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
         Incl.mk (this.module_type this pincl_mod)
           ~loc:(this.location this pincl_loc)
           ~attrs:(this.attributes this pincl_attributes)
      );

    include_declaration =
      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
         Incl.mk (this.module_expr this pincl_mod)
           ~loc:(this.location this pincl_loc)
           ~attrs:(this.attributes this pincl_attributes)
      );


    value_binding =
      (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} ->
         Vb.mk
           (this.pat this pvb_pat)
           (this.expr this pvb_expr)
           ~loc:(this.location this pvb_loc)
           ~attrs:(this.attributes this pvb_attributes)
      );


    constructor_declaration =
      (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} ->
        Type.constructor
          (map_loc this pcd_name)
          ~args:(T.map_constructor_arguments this pcd_args)
          ?res:(map_opt (this.typ this) pcd_res)
          ~loc:(this.location this pcd_loc)
          ~attrs:(this.attributes this pcd_attributes)
      );

    label_declaration =
      (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} ->
         Type.field
           (map_loc this pld_name)
           (this.typ this pld_type)
           ~mut:pld_mutable
           ~loc:(this.location this pld_loc)
           ~attrs:(this.attributes this pld_attributes)
      );

    cases = (fun this l -> List.map (this.case this) l);
    case =
      (fun this {pc_lhs; pc_guard; pc_rhs} ->
         {
           pc_lhs = this.pat this pc_lhs;
           pc_guard = map_opt (this.expr this) pc_guard;
           pc_rhs = this.expr this pc_rhs;
         }
      );



    location = (fun _this l -> l);

    extension = (fun this (s, e) -> (map_loc this s, this.payload this e));
    attribute = (fun this (s, e) -> (map_loc this s, this.payload this e));
    attributes = (fun this l -> List.map (this.attribute this) l);
    payload =
      (fun this -> function
         | PStr x -> PStr (this.structure this x)
         | PSig x -> PSig (this.signature this x)
         | PTyp x -> PTyp (this.typ this x)
         | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)
      );
  }

let rec extension_of_error {loc; msg; if_highlight; sub} =
  { loc; txt = "ocaml.error" },
  PStr ([Str.eval (Exp.constant (Pconst_string (msg, None)));
         Str.eval (Exp.constant (Pconst_string (if_highlight, None)))] @
        (List.map (fun ext -> Str.extension (extension_of_error ext)) sub))

let attribute_of_warning loc s =
  { loc; txt = "ocaml.ppwarning" },
  PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, None)))])

module StringMap = Map.Make(struct
    type t = string
    let compare = compare
end)

let cookies = ref StringMap.empty

let get_cookie k =
  try Some (StringMap.find k !cookies)
  with Not_found -> None

let set_cookie k v =
  cookies := StringMap.add k v !cookies

let tool_name_ref = ref "_none_"

let tool_name () = !tool_name_ref


module PpxContext = struct
  open Longident
  open Asttypes
  open Ast_helper

  let lid name = { txt = Lident name; loc = Location.none }

  let make_string x = Exp.constant (Pconst_string (x, None))

  let make_bool x =
    if x
    then Exp.construct (lid "true") None
    else Exp.construct (lid "false") None

  let rec make_list f lst =
    match lst with
    | x :: rest ->
      Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest]))
    | [] ->
      Exp.construct (lid "[]") None

  let make_pair f1 f2 (x1, x2) =
    Exp.tuple [f1 x1; f2 x2]

  let make_option f opt =
    match opt with
    | Some x -> Exp.construct (lid "Some") (Some (f x))
    | None   -> Exp.construct (lid "None") None

  let get_cookies () =
    lid "cookies",
    make_list (make_pair make_string (fun x -> x))
      (StringMap.bindings !cookies)

  let mk fields =
    { txt = "ocaml.ppx.context"; loc = Location.none },
    Parsetree.PStr [Str.eval (Exp.record fields None)]

  let make ~tool_name () =
    let fields =
      [
        lid "tool_name",    make_string tool_name;
        lid "include_dirs", make_list make_string !Clflags.include_dirs;
        lid "load_path",    make_list make_string !Config.load_path;
        lid "open_modules", make_list make_string !Clflags.open_modules;
        lid "for_package",  make_option make_string !Clflags.for_package;
        lid "debug",        make_bool !Clflags.debug;
        lid "use_threads",  make_bool !Clflags.use_threads;
        lid "use_vmthreads", make_bool !Clflags.use_vmthreads;
        get_cookies ()
      ]
    in
    mk fields

  let get_fields = function
    | PStr [{pstr_desc = Pstr_eval
                 ({ pexp_desc = Pexp_record (fields, None) }, [])}] ->
        fields
    | _ ->
        raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax"

  let restore fields =
    let field name payload =
      let rec get_string = function
        | { pexp_desc = Pexp_constant (Pconst_string (str, None)) } -> str
        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
                             { %s }] string syntax" name
      and get_bool pexp =
        match pexp with
        | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"},
                                       None)} ->
            true
        | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"},
                                       None)} ->
            false
        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
                             { %s }] bool syntax" name
      and get_list elem = function
        | {pexp_desc =
             Pexp_construct ({txt = Longident.Lident "::"},
                             Some {pexp_desc = Pexp_tuple [exp; rest]}) } ->
            elem exp :: get_list elem rest
        | {pexp_desc =
             Pexp_construct ({txt = Longident.Lident "[]"}, None)} ->
            []
        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
                             { %s }] list syntax" name
      and get_pair f1 f2 = function
        | {pexp_desc = Pexp_tuple [e1; e2]} ->
            (f1 e1, f2 e2)
        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
                             { %s }] pair syntax" name
      and get_option elem = function
        | { pexp_desc =
              Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } ->
            Some (elem exp)
        | { pexp_desc =
              Pexp_construct ({ txt = Longident.Lident "None" }, None) } ->
            None
        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
                             { %s }] option syntax" name
      in
      match name with
      | "tool_name" ->
          tool_name_ref := get_string payload
      | "include_dirs" ->
          Clflags.include_dirs := get_list get_string payload
      | "load_path" ->
          Config.load_path := get_list get_string payload
      | "open_modules" ->
          Clflags.open_modules := get_list get_string payload
      | "for_package" ->
          Clflags.for_package := get_option get_string payload
      | "debug" ->
          Clflags.debug := get_bool payload
      | "use_threads" ->
          Clflags.use_threads := get_bool payload
      | "use_vmthreads" ->
          Clflags.use_vmthreads := get_bool payload
      | "cookies" ->
          let l = get_list (get_pair get_string (fun x -> x)) payload in
          cookies :=
            List.fold_left
              (fun s (k, v) -> StringMap.add k v s) StringMap.empty
              l
      | _ ->
          ()
    in
    List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields

  let update_cookies fields =
    let fields =
      List.filter
        (function ({txt=Lident "cookies"}, _) -> false | _ -> true)
        fields
    in
    fields @ [get_cookies ()]
end

let ppx_context = PpxContext.make

let extension_of_exn exn =
  match error_of_exn exn with
  | Some (`Ok error) -> extension_of_error error
  | Some `Already_displayed -> { loc = Location.none; txt = "ocaml.error" }, PStr []
  | None -> raise exn


let apply_lazy ~source ~target mapper =
  let implem ast =
    let fields, ast =
      match ast with
      | {pstr_desc = Pstr_attribute ({txt = "ocaml.ppx.context"}, x)} :: l ->
          PpxContext.get_fields x, l
      | _ -> [], ast
    in
    PpxContext.restore fields;
    let ast =
      try
        let mapper = mapper () in
        mapper.structure mapper ast
      with exn ->
        [{pstr_desc = Pstr_extension (extension_of_exn exn, []);
          pstr_loc  = Location.none}]
    in
    let fields = PpxContext.update_cookies fields in
    Str.attribute (PpxContext.mk fields) :: ast
  in
  let iface ast =
    let fields, ast =
      match ast with
      | {psig_desc = Psig_attribute ({txt = "ocaml.ppx.context"}, x)} :: l ->
          PpxContext.get_fields x, l
      | _ -> [], ast
    in
    PpxContext.restore fields;
    let ast =
      try
        let mapper = mapper () in
        mapper.signature mapper ast
      with exn ->
        [{psig_desc = Psig_extension (extension_of_exn exn, []);
          psig_loc  = Location.none}]
    in
    let fields = PpxContext.update_cookies fields in
    Sig.attribute (PpxContext.mk fields) :: ast
  in

  let ic = open_in_bin source in
  let magic =
    really_input_string ic (String.length Config.ast_impl_magic_number)
  in

  let rewrite transform =
    Location.input_name := input_value ic;
    let ast = input_value ic in
    close_in ic;
    let ast = transform ast in
    let oc = open_out_bin target in
    output_string oc magic;
    output_value oc !Location.input_name;
    output_value oc ast;
    close_out oc
  and fail () =
    close_in ic;
    failwith "Ast_mapper: OCaml version mismatch or malformed input";
  in

  if magic = Config.ast_impl_magic_number then
    rewrite (implem : structure -> structure)
  else if magic = Config.ast_intf_magic_number then
    rewrite (iface : signature -> signature)
  else fail ()

let drop_ppx_context_str ~restore = function
  | {pstr_desc = Pstr_attribute({Location.txt = "ocaml.ppx.context"}, a)}
    :: items ->
      if restore then
        PpxContext.restore (PpxContext.get_fields a);
      items
  | items -> items

let drop_ppx_context_sig ~restore = function
  | {psig_desc = Psig_attribute({Location.txt = "ocaml.ppx.context"}, a)}
    :: items ->
      if restore then
        PpxContext.restore (PpxContext.get_fields a);
      items
  | items -> items

let add_ppx_context_str ~tool_name ast =
  Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast

let add_ppx_context_sig ~tool_name ast =
  Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast


let apply ~source ~target mapper =
  apply_lazy ~source ~target (fun () -> mapper)

let run_main mapper =
  try
    let a = Sys.argv in
    let n = Array.length a in
    if n > 2 then
      let mapper () =
        try mapper (Array.to_list (Array.sub a 1 (n - 3)))
        with exn ->
          (* PR#6463 *)
          let f _ _ = raise exn in
          {default_mapper with structure = f; signature = f}
      in
      apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper
    else begin
      Printf.eprintf "Usage: %s [extra_args] <infile> <outfile>\n%!"
                     Sys.executable_name;
      exit 2
    end
  with exn ->
    prerr_endline (Printexc.to_string exn);
    exit 2

let register_function = ref (fun _name f -> run_main f)
let register name f = !register_function name f

end
module Tbl : sig 
#1 "tbl.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Association tables from any ordered type to any type.
   We use the generic ordering to compare keys. *)

type ('k, 'v) t

val empty: ('k, 'v) t
val add: 'k -> 'v -> ('k, 'v) t -> ('k, 'v) t
val find: 'k -> ('k, 'v) t -> 'v
val find_str: string -> (string, 'v) t -> 'v
val mem: 'k -> ('k, 'v) t -> bool
val remove: 'k -> ('k,  'v) t -> ('k, 'v) t
val iter: ('k -> 'v -> unit) -> ('k, 'v) t -> unit
val map: ('k -> 'v1 -> 'v2) -> ('k, 'v1) t -> ('k, 'v2) t
val fold: ('k -> 'v -> 'acc -> 'acc) -> ('k, 'v) t -> 'acc -> 'acc

open Format

val print: (formatter -> 'k -> unit) -> (formatter -> 'v -> unit) ->
           formatter -> ('k, 'v) t -> unit

end = struct
#1 "tbl.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

type ('k, 'v) t =
    Empty
  | Node of ('k, 'v) t * 'k * 'v * ('k, 'v) t * int

let empty = Empty

let height = function
    Empty -> 0
  | Node(_,_,_,_,h) -> h

let create l x d r =
  let hl = height l and hr = height r in
  Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))

let bal l x d r =
  let hl = height l and hr = height r in
  if hl > hr + 1 then
    match l with
    | Node (ll, lv, ld, lr, _) when height ll >= height lr ->
        create ll lv ld (create lr x d r)
    | Node (ll, lv, ld, Node (lrl, lrv, lrd, lrr, _), _) ->
        create (create ll lv ld lrl) lrv lrd (create lrr x d r)
    | _ -> assert false
  else if hr > hl + 1 then
    match r with
    | Node (rl, rv, rd, rr, _) when height rr >= height rl ->
        create (create l x d rl) rv rd rr
    | Node (Node (rll, rlv, rld, rlr, _), rv, rd, rr, _) ->
        create (create l x d rll) rlv rld (create rlr rv rd rr)
    | _ -> assert false
  else
    create l x d r

let rec add x data = function
    Empty ->
      Node(Empty, x, data, Empty, 1)
  | Node(l, v, d, r, h) ->
      let c = compare x v in
      if c = 0 then
        Node(l, x, data, r, h)
      else if c < 0 then
        bal (add x data l) v d r
      else
        bal l v d (add x data r)

let rec find x = function
    Empty ->
      raise Not_found
  | Node(l, v, d, r, _) ->
      let c = compare x v in
      if c = 0 then d
      else find x (if c < 0 then l else r)

let rec find_str (x : string) = function
    Empty ->
      raise Not_found
  | Node(l, v, d, r, _) ->
      let c = compare x v in
      if c = 0 then d
      else find_str x (if c < 0 then l else r)

let rec mem x = function
    Empty -> false
  | Node(l, v, _d, r, _) ->
      let c = compare x v in
      c = 0 || mem x (if c < 0 then l else r)

let rec merge t1 t2 =
  match (t1, t2) with
    (Empty, t) -> t
  | (t, Empty) -> t
  | (Node(l1, v1, d1, r1, _h1), Node(l2, v2, d2, r2, _h2)) ->
      bal l1 v1 d1 (bal (merge r1 l2) v2 d2 r2)

let rec remove x = function
    Empty ->
      Empty
  | Node(l, v, d, r, _h) ->
      let c = compare x v in
      if c = 0 then
        merge l r
      else if c < 0 then
        bal (remove x l) v d r
      else
        bal l v d (remove x r)

let rec iter f = function
    Empty -> ()
  | Node(l, v, d, r, _) ->
      iter f l; f v d; iter f r

let rec map f = function
    Empty -> Empty
  | Node(l, v, d, r, h) -> Node(map f l, v, f v d, map f r, h)

let rec fold f m accu =
  match m with
  | Empty -> accu
  | Node(l, v, d, r, _) ->
      fold f r (f v d (fold f l accu))

open Format

let print print_key print_data ppf tbl =
  let print_tbl ppf tbl =
    iter (fun k d -> fprintf ppf "@[<2>%a ->@ %a;@]@ " print_key k print_data d)
      tbl in
  fprintf ppf "@[<hv 2>[[%a]]@]" print_tbl tbl

end
module Subst : sig 
#1 "subst.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Substitutions *)

open Types

type t

(*
   Substitutions are used to translate a type from one context to
   another.  This requires substituting paths for identifiers, and
   possibly also lowering the level of non-generic variables so that
   they are inferior to the maximum level of the new context.

   Substitutions can also be used to create a "clean" copy of a type.
   Indeed, non-variable node of a type are duplicated, with their
   levels set to generic level.  That way, the resulting type is
   well-formed (decreasing levels), even if the original one was not.
*)

val identity: t

val add_type: Ident.t -> Path.t -> t -> t
val add_type_path: Path.t -> Path.t -> t -> t
val add_type_function:
  Path.t -> params:type_expr list -> body:type_expr -> t -> t
val add_module: Ident.t -> Path.t -> t -> t
val add_module_path: Path.t -> Path.t -> t -> t
val add_modtype: Ident.t -> module_type -> t -> t
val for_saving: t -> t
val reset_for_saving: unit -> unit

val module_path: t -> Path.t -> Path.t
val type_path: t -> Path.t -> Path.t

val type_expr: t -> type_expr -> type_expr
val class_type: t -> class_type -> class_type
val value_description: t -> value_description -> value_description
val type_declaration: t -> type_declaration -> type_declaration
val extension_constructor:
        t -> extension_constructor -> extension_constructor
val class_declaration: t -> class_declaration -> class_declaration
val cltype_declaration: t -> class_type_declaration -> class_type_declaration
val modtype: t -> module_type -> module_type
val signature: t -> signature -> signature
val modtype_declaration: t -> modtype_declaration -> modtype_declaration
val module_declaration: t -> module_declaration -> module_declaration
val typexp : t -> Types.type_expr -> Types.type_expr
val class_signature: t -> class_signature -> class_signature

(* Composition of substitutions:
     apply (compose s1 s2) x = apply s2 (apply s1 x) *)
val compose: t -> t -> t

(* A forward reference to be filled in ctype.ml. *)
val ctype_apply_env_empty:
  (type_expr list -> type_expr -> type_expr list -> type_expr) ref

end = struct
#1 "subst.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Substitutions *)

open Misc
open Path
open Types
open Btype

type type_replacement =
  | Path of Path.t
  | Type_function of { params : type_expr list; body : type_expr }

module PathMap = Map.Make(Path)

type t =
  { types: type_replacement PathMap.t;
    modules: Path.t PathMap.t;
    modtypes: (Ident.t, module_type) Tbl.t;
    for_saving: bool;
  }

let identity =
  { types = PathMap.empty;
    modules = PathMap.empty;
    modtypes = Tbl.empty;
    for_saving = false;
  }

let add_type_path id p s = { s with types = PathMap.add id (Path p) s.types }
let add_type id p s = add_type_path (Pident id) p s

let add_type_function id ~params ~body s =
  { s with types = PathMap.add id (Type_function { params; body }) s.types }

let add_module_path id p s = { s with modules = PathMap.add id p s.modules }
let add_module id p s = add_module_path (Pident id) p s

let add_modtype id ty s = { s with modtypes = Tbl.add id ty s.modtypes }

let for_saving s = { s with for_saving = true }

let loc s x =
  if s.for_saving && not !Clflags.keep_locs then Location.none else x

let remove_loc =
  let open Ast_mapper in
  {default_mapper with location = (fun _this _loc -> Location.none)}

let is_not_doc = function
  | ({Location.txt = "ocaml.doc"}, _) -> false
  | ({Location.txt = "ocaml.text"}, _) -> false
  | ({Location.txt = "doc"}, _) -> false
  | ({Location.txt = "text"}, _) -> false
  | _ -> true

let attrs s x =
  let x =
    if s.for_saving && not !Clflags.keep_docs then
      List.filter is_not_doc x
    else x
  in
    if s.for_saving && not !Clflags.keep_locs
    then remove_loc.Ast_mapper.attributes remove_loc x
    else x

let rec module_path s path =
  try PathMap.find path s.modules
  with Not_found ->
    match path with
    | Pident _ -> path
    | Pdot(p, n, pos) ->
       Pdot(module_path s p, n, pos)
    | Papply(p1, p2) ->
       Papply(module_path s p1, module_path s p2)

let modtype_path s = function
    Pident id as p ->
      begin try
        match Tbl.find id s.modtypes with
          | Mty_ident p -> p
          | _ -> fatal_error "Subst.modtype_path"
      with Not_found -> p end
  | Pdot(p, n, pos) ->
      Pdot(module_path s p, n, pos)
  | Papply _ ->
      fatal_error "Subst.modtype_path"

let type_path s path =
  match PathMap.find path s.types with
  | Path p -> p
  | Type_function _ -> assert false
  | exception Not_found ->
     match path with
     | Pident _ -> path
     | Pdot(p, n, pos) ->
        Pdot(module_path s p, n, pos)
     | Papply _ ->
        fatal_error "Subst.type_path"

let type_path s p =
  match Path.constructor_typath p with
  | Regular p -> type_path s p
  | Cstr (ty_path, cstr) -> Pdot(type_path s ty_path, cstr, nopos)
  | LocalExt _ -> type_path s p
  | Ext (p, cstr) -> Pdot(module_path s p, cstr, nopos)

let to_subst_by_type_function s p =
  match PathMap.find p s.types with
  | Path _ -> false
  | Type_function _ -> true
  | exception Not_found -> false

(* Special type ids for saved signatures *)

let new_id = ref (-1)
let reset_for_saving () = new_id := -1

let newpersty desc =
  decr new_id;
  { desc = desc; level = generic_level; id = !new_id }

(* ensure that all occurrences of 'Tvar None' are physically shared *)
let tvar_none = Tvar None
let tunivar_none = Tunivar None
let norm = function
  | Tvar None -> tvar_none
  | Tunivar None -> tunivar_none
  | d -> d

let ctype_apply_env_empty = ref (fun _ -> assert false)

(* Similar to [Ctype.nondep_type_rec]. *)
let rec typexp s ty =
  let ty = repr ty in
  match ty.desc with
    Tvar _ | Tunivar _ as desc ->
      if s.for_saving || ty.id < 0 then
        let ty' =
          if s.for_saving then newpersty (norm desc)
          else newty2 ty.level desc
        in
        save_desc ty desc; ty.desc <- Tsubst ty'; ty'
      else ty
  | Tsubst ty ->
      ty
  | Tfield (m, k, _t1, _t2) when not s.for_saving && m = dummy_method
      && field_kind_repr k <> Fabsent && (repr ty).level < generic_level ->
      (* do not copy the type of self when it is not generalized *)
      ty
(* cannot do it, since it would omit substitution
  | Tvariant row when not (static_row row) ->
      ty
*)
  | _ ->
    let desc = ty.desc in
    save_desc ty desc;
    let tm = row_of_type ty in
    let has_fixed_row =
      not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm in
    (* Make a stub *)
    let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in
    ty.desc <- Tsubst ty';
    ty'.desc <-
      begin if has_fixed_row then
        match tm.desc with (* PR#7348 *)
          Tconstr (Pdot(m,i,pos), tl, _abbrev) ->
            let i' = String.sub i 0 (String.length i - 4) in
            Tconstr(type_path s (Pdot(m,i',pos)), tl, ref Mnil)
        | _ -> assert false
      else match desc with
      | Tconstr (p, args, _abbrev) ->
         let args = List.map (typexp s) args in
         begin match PathMap.find p s.types with
         | exception Not_found -> Tconstr(type_path s p, args, ref Mnil)
         | Path _ -> Tconstr(type_path s p, args, ref Mnil)
         | Type_function { params; body } ->
            (!ctype_apply_env_empty params body args).desc
         end
      | Tpackage(p, n, tl) ->
          Tpackage(modtype_path s p, n, List.map (typexp s) tl)
      | Tobject (t1, name) ->
          Tobject (typexp s t1,
                 ref (match !name with
                        None -> None
                      | Some (p, tl) ->
                         if to_subst_by_type_function s p
                         then None
                         else Some (type_path s p, List.map (typexp s) tl)))
      | Tvariant row ->
          let row = row_repr row in
          let more = repr row.row_more in
          (* We must substitute in a subtle way *)
          (* Tsubst takes a tuple containing the row var and the variant *)
          begin match more.desc with
            Tsubst {desc = Ttuple [_;ty2]} ->
              (* This variant type has been already copied *)
              ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *)
              Tlink ty2
          | _ ->
              let dup =
                s.for_saving || more.level = generic_level || static_row row ||
                match more.desc with Tconstr _ -> true | _ -> false in
              (* Various cases for the row variable *)
              let more' =
                match more.desc with
                  Tsubst ty -> ty
                | Tconstr _ | Tnil -> typexp s more
                | Tunivar _ | Tvar _ ->
                    save_desc more more.desc;
                    if s.for_saving then newpersty (norm more.desc) else
                    if dup && is_Tvar more then newgenty more.desc else more
                | _ -> assert false
              in
              (* Register new type first for recursion *)
              more.desc <- Tsubst(newgenty(Ttuple[more';ty']));
              (* Return a new copy *)
              let row =
                copy_row (typexp s) true row (not dup) more' in
              match row.row_name with
              | Some (p, tl) ->
                 Tvariant {row with row_name =
                                      if to_subst_by_type_function s p
                                      then None
                                      else Some (type_path s p, tl)}
              | None ->
                  Tvariant row
          end
      | Tfield(_label, kind, _t1, t2) when field_kind_repr kind = Fabsent ->
          Tlink (typexp s t2)
      | _ -> copy_type_desc (typexp s) desc
      end;
    ty'

(*
   Always make a copy of the type. If this is not done, type levels
   might not be correct.
*)
let type_expr s ty =
  let ty' = typexp s ty in
  cleanup_types ();
  ty'

let label_declaration s l =
  {
    ld_id = l.ld_id;
    ld_mutable = l.ld_mutable;
    ld_type = typexp s l.ld_type;
    ld_loc = loc s l.ld_loc;
    ld_attributes = attrs s l.ld_attributes;
  }

let constructor_arguments s = function
  | Cstr_tuple l ->
      Cstr_tuple (List.map (typexp s) l)
  | Cstr_record l ->
      Cstr_record (List.map (label_declaration s) l)

let constructor_declaration s c =
  {
    cd_id = c.cd_id;
    cd_args = constructor_arguments s c.cd_args;
    cd_res = may_map (typexp s) c.cd_res;
    cd_loc = loc s c.cd_loc;
    cd_attributes = attrs s c.cd_attributes;
  }

let type_declaration s decl =
  let decl =
    { type_params = List.map (typexp s) decl.type_params;
      type_arity = decl.type_arity;
      type_kind =
        begin match decl.type_kind with
          Type_abstract -> Type_abstract
        | Type_variant cstrs ->
            Type_variant (List.map (constructor_declaration s) cstrs)
        | Type_record(lbls, rep) ->
            Type_record (List.map (label_declaration s) lbls, rep)
        | Type_open -> Type_open
        end;
      type_manifest =
        begin
          match decl.type_manifest with
            None -> None
          | Some ty -> Some(typexp s ty)
        end;
      type_private = decl.type_private;
      type_variance = decl.type_variance;
      type_newtype_level = None;
      type_loc = loc s decl.type_loc;
      type_attributes = attrs s decl.type_attributes;
      type_immediate = decl.type_immediate;
      type_unboxed = decl.type_unboxed;
    }
  in
  cleanup_types ();
  decl

let class_signature s sign =
  { csig_self = typexp s sign.csig_self;
    csig_vars =
      Vars.map (function (m, v, t) -> (m, v, typexp s t)) sign.csig_vars;
    csig_concr = sign.csig_concr;
    csig_inher =
      List.map (fun (p, tl) -> (type_path s p, List.map (typexp s) tl))
        sign.csig_inher;
  }

let rec class_type s =
  function
    Cty_constr (p, tyl, cty) ->
      Cty_constr (type_path s p, List.map (typexp s) tyl, class_type s cty)
  | Cty_signature sign ->
      Cty_signature (class_signature s sign)
  | Cty_arrow (l, ty, cty) ->
      Cty_arrow (l, typexp s ty, class_type s cty)

let class_declaration s decl =
  let decl =
    { cty_params = List.map (typexp s) decl.cty_params;
      cty_variance = decl.cty_variance;
      cty_type = class_type s decl.cty_type;
      cty_path = type_path s decl.cty_path;
      cty_new =
        begin match decl.cty_new with
          None    -> None
        | Some ty -> Some (typexp s ty)
        end;
      cty_loc = loc s decl.cty_loc;
      cty_attributes = attrs s decl.cty_attributes;
    }
  in
  (* Do not clean up if saving: next is cltype_declaration *)
  if not s.for_saving then cleanup_types ();
  decl

let cltype_declaration s decl =
  let decl =
    { clty_params = List.map (typexp s) decl.clty_params;
      clty_variance = decl.clty_variance;
      clty_type = class_type s decl.clty_type;
      clty_path = type_path s decl.clty_path;
      clty_loc = loc s decl.clty_loc;
      clty_attributes = attrs s decl.clty_attributes;
    }
  in
  (* Do clean up even if saving: type_declaration may be recursive *)
  cleanup_types ();
  decl

let class_type s cty =
  let cty = class_type s cty in
  cleanup_types ();
  cty

let value_description s descr =
  { val_type = type_expr s descr.val_type;
    val_kind = descr.val_kind;
    val_loc = loc s descr.val_loc;
    val_attributes = attrs s descr.val_attributes;
   }

let extension_constructor s ext =
  let ext =
    { ext_type_path = type_path s ext.ext_type_path;
      ext_type_params = List.map (typexp s) ext.ext_type_params;
      ext_args = constructor_arguments s ext.ext_args;
      ext_ret_type = may_map (typexp s) ext.ext_ret_type;
      ext_private = ext.ext_private;
      ext_attributes = attrs s ext.ext_attributes;
      ext_loc = if s.for_saving then Location.none else ext.ext_loc; }
  in
    cleanup_types ();
    ext

let rec rename_bound_idents s idents = function
    [] -> (List.rev idents, s)
  | Sig_type(id, _, _) :: sg ->
      let id' = Ident.rename id in
      rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg
  | Sig_module(id, _, _) :: sg ->
      let id' = Ident.rename id in
      rename_bound_idents (add_module id (Pident id') s) (id' :: idents) sg
  | Sig_modtype(id, _) :: sg ->
      let id' = Ident.rename id in
      rename_bound_idents (add_modtype id (Mty_ident(Pident id')) s)
                          (id' :: idents) sg
  | (Sig_class(id, _, _) | Sig_class_type(id, _, _)) :: sg ->
      (* cheat and pretend they are types cf. PR#6650 *)
      let id' = Ident.rename id in
      rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg
  | (Sig_value(id, _) | Sig_typext(id, _, _)) :: sg ->
      let id' = Ident.rename id in
      rename_bound_idents s (id' :: idents) sg

let rec modtype s = function
    Mty_ident p as mty ->
      begin match p with
        Pident id ->
          begin try Tbl.find id s.modtypes with Not_found -> mty end
      | Pdot(p, n, pos) ->
          Mty_ident(Pdot(module_path s p, n, pos))
      | Papply _ ->
          fatal_error "Subst.modtype"
      end
  | Mty_signature sg ->
      Mty_signature(signature s sg)
  | Mty_functor(id, arg, res) ->
      let id' = Ident.rename id in
      Mty_functor(id', may_map (modtype s) arg,
                       modtype (add_module id (Pident id') s) res)
  | Mty_alias(pres, p) ->
      Mty_alias(pres, module_path s p)

and signature s sg =
  (* Components of signature may be mutually recursive (e.g. type declarations
     or class and type declarations), so first build global renaming
     substitution... *)
  let (new_idents, s') = rename_bound_idents s [] sg in
  (* ... then apply it to each signature component in turn *)
  List.map2 (signature_component s') sg new_idents

and signature_component s comp newid =
  match comp with
    Sig_value(_id, d) ->
      Sig_value(newid, value_description s d)
  | Sig_type(_id, d, rs) ->
      Sig_type(newid, type_declaration s d, rs)
  | Sig_typext(_id, ext, es) ->
      Sig_typext(newid, extension_constructor s ext, es)
  | Sig_module(_id, d, rs) ->
      Sig_module(newid, module_declaration s d, rs)
  | Sig_modtype(_id, d) ->
      Sig_modtype(newid, modtype_declaration s d)
  | Sig_class(_id, d, rs) ->
      Sig_class(newid, class_declaration s d, rs)
  | Sig_class_type(_id, d, rs) ->
      Sig_class_type(newid, cltype_declaration s d, rs)

and module_declaration s decl =
  {
    md_type = modtype s decl.md_type;
    md_attributes = attrs s decl.md_attributes;
    md_loc = loc s decl.md_loc;
  }

and modtype_declaration s decl  =
  {
    mtd_type = may_map (modtype s) decl.mtd_type;
    mtd_attributes = attrs s decl.mtd_attributes;
    mtd_loc = loc s decl.mtd_loc;
  }

(* For every binding k |-> d of m1, add k |-> f d to m2
   and return resulting merged map. *)

let merge_tbls f m1 m2 =
  Tbl.fold (fun k d accu -> Tbl.add k (f d) accu) m1 m2

let merge_path_maps f m1 m2 =
  PathMap.fold (fun k d accu -> PathMap.add k (f d) accu) m1 m2

let type_replacement s = function
  | Path p -> Path (type_path s p)
  | Type_function { params; body } ->
     let params = List.map (typexp s) params in
     let body = typexp s body in
     Type_function { params; body }

(* Composition of substitutions:
     apply (compose s1 s2) x = apply s2 (apply s1 x) *)

let compose s1 s2 =
  { types = merge_path_maps (type_replacement s2) s1.types s2.types;
    modules = merge_path_maps (module_path s2) s1.modules s2.modules;
    modtypes = merge_tbls (modtype s2) s1.modtypes s2.modtypes;
    for_saving = s1.for_saving || s2.for_saving;
  }

end
module Env : sig 
#1 "env.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Environment handling *)

open Types

module PathMap : Map.S with type key = Path.t
                        and type 'a t = 'a Map.Make(Path).t

type summary =
    Env_empty
  | Env_value of summary * Ident.t * value_description
  | Env_type of summary * Ident.t * type_declaration
  | Env_extension of summary * Ident.t * extension_constructor
  | Env_module of summary * Ident.t * module_declaration
  | Env_modtype of summary * Ident.t * modtype_declaration
  | Env_class of summary * Ident.t * class_declaration
  | Env_cltype of summary * Ident.t * class_type_declaration
  | Env_open of summary * Path.t
  | Env_functor_arg of summary * Ident.t
  | Env_constraints of summary * type_declaration PathMap.t
  | Env_copy_types of summary * string list

type t

val empty: t
val initial_safe_string: t
val initial_unsafe_string: t
val diff: t -> t -> Ident.t list
val copy_local: from:t -> t -> t

type type_descriptions =
    constructor_description list * label_description list

(* For short-paths *)
type iter_cont
val iter_types:
    (Path.t -> Path.t * (type_declaration * type_descriptions) -> unit) ->
    t -> iter_cont
val run_iter_cont: iter_cont list -> (Path.t * iter_cont) list
val same_types: t -> t -> bool
val used_persistent: unit -> Concr.t
val find_shadowed_types: Path.t -> t -> Path.t list
val without_cmis: ('a -> 'b) -> 'a -> 'b
        (* [without_cmis f arg] applies [f] to [arg], but does not
           allow opening cmis during its execution *)

(* Lookup by paths *)

val find_value: Path.t -> t -> value_description
val find_type: Path.t -> t -> type_declaration
val find_type_descrs: Path.t -> t -> type_descriptions
val find_module: Path.t -> t -> module_declaration
val find_modtype: Path.t -> t -> modtype_declaration
val find_class: Path.t -> t -> class_declaration
val find_cltype: Path.t -> t -> class_type_declaration

val find_type_expansion:
    Path.t -> t -> type_expr list * type_expr * int option
val find_type_expansion_opt:
    Path.t -> t -> type_expr list * type_expr * int option
(* Find the manifest type information associated to a type for the sake
   of the compiler's type-based optimisations. *)
val find_modtype_expansion: Path.t -> t -> module_type
val add_functor_arg: Ident.t -> t -> t
val is_functor_arg: Path.t -> t -> bool
val normalize_path: Location.t option -> t -> Path.t -> Path.t
(* Normalize the path to a concrete value or module.
   If the option is None, allow returning dangling paths.
   Otherwise raise a Missing_module error, and may add forgotten
   head as required global. *)
val normalize_path_prefix: Location.t option -> t -> Path.t -> Path.t
(* Only normalize the prefix part of the path *)
val reset_required_globals: unit -> unit
val get_required_globals: unit -> Ident.t list
val add_required_global: Ident.t -> unit

val has_local_constraints: t -> bool
val add_gadt_instance_level: int -> t -> t
val gadt_instance_level: t -> type_expr -> int option
val add_gadt_instances: t -> int -> type_expr list -> unit
val add_gadt_instance_chain: t -> int -> type_expr -> unit

(* Lookup by long identifiers *)

(* ?loc is used to report 'deprecated module' warnings *)

val lookup_value:
  ?loc:Location.t -> Longident.t -> t -> Path.t * value_description
val lookup_constructor:
  ?loc:Location.t -> Longident.t -> t -> constructor_description
val lookup_all_constructors:
  ?loc:Location.t ->
  Longident.t -> t -> (constructor_description * (unit -> unit)) list
val lookup_label:
  ?loc:Location.t -> Longident.t -> t -> label_description
val lookup_all_labels:
  ?loc:Location.t ->
  Longident.t -> t -> (label_description * (unit -> unit)) list
val lookup_type:
  ?loc:Location.t -> Longident.t -> t -> Path.t
  (* Since 4.04, this function no longer returns [type_description].
     To obtain it, you should either call [Env.find_type], or replace
     it by [Typetexp.find_type] *)
val lookup_module:
  load:bool -> ?loc:Location.t -> Longident.t -> t -> Path.t
val lookup_modtype:
  ?loc:Location.t -> Longident.t -> t -> Path.t * modtype_declaration
val lookup_class:
  ?loc:Location.t -> Longident.t -> t -> Path.t * class_declaration
val lookup_cltype:
  ?loc:Location.t -> Longident.t -> t -> Path.t * class_type_declaration

val copy_types: string list -> t -> t
  (* Used only in Typecore.duplicate_ident_types. *)

exception Recmodule
  (* Raise by lookup_module when the identifier refers
     to one of the modules of a recursive definition
     during the computation of its approximation (see #5965). *)

(* Insertion by identifier *)

val add_value:
    ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t
val add_type: check:bool -> Ident.t -> type_declaration -> t -> t
val add_extension: check:bool -> Ident.t -> extension_constructor -> t -> t
val add_module: ?arg:bool -> Ident.t -> module_type -> t -> t
val add_module_declaration: ?arg:bool -> check:bool -> Ident.t ->
  module_declaration -> t -> t
val add_modtype: Ident.t -> modtype_declaration -> t -> t
val add_class: Ident.t -> class_declaration -> t -> t
val add_cltype: Ident.t -> class_type_declaration -> t -> t
val add_local_constraint: Path.t -> type_declaration -> int -> t -> t
val add_local_type: Path.t -> type_declaration -> t -> t

(* Insertion of all fields of a signature. *)

val add_item: signature_item -> t -> t
val add_signature: signature -> t -> t

(* Insertion of all fields of a signature, relative to the given path.
   Used to implement open. Returns None if the path refers to a functor,
   not a structure. *)
val open_signature:
    ?used_slot:bool ref ->
    ?loc:Location.t -> ?toplevel:bool -> Asttypes.override_flag -> Path.t ->
      t -> t option

val open_pers_signature: string -> t -> t

(* Insertion by name *)

val enter_value:
    ?check:(string -> Warnings.t) ->
    string -> value_description -> t -> Ident.t * t
val enter_type: string -> type_declaration -> t -> Ident.t * t
val enter_extension: string -> extension_constructor -> t -> Ident.t * t
val enter_module: ?arg:bool -> string -> module_type -> t -> Ident.t * t
val enter_module_declaration:
    ?arg:bool -> Ident.t -> module_declaration -> t -> t
val enter_modtype: string -> modtype_declaration -> t -> Ident.t * t
val enter_class: string -> class_declaration -> t -> Ident.t * t
val enter_cltype: string -> class_type_declaration -> t -> Ident.t * t

(* Initialize the cache of in-core module interfaces. *)
val reset_cache: unit -> unit

(* To be called before each toplevel phrase. *)
val reset_cache_toplevel: unit -> unit

(* Remember the name of the current compilation unit. *)
val set_unit_name: string -> unit
val get_unit_name: unit -> string

(* Read, save a signature to/from a file *)

val read_signature: string -> string -> signature
        (* Arguments: module name, file name. Results: signature. *)
val save_signature:
  ?check_exists:unit ->
  deprecated:string option -> signature -> string -> string -> Cmi_format.cmi_infos
        (* Arguments: signature, module name, file name. *)
val save_signature_with_imports:
  ?check_exists:unit -> 
  deprecated:string option ->
  signature -> string -> string -> (string * Digest.t option) list
  -> Cmi_format.cmi_infos
        (* Arguments: signature, module name, file name,
           imported units with their CRCs. *)

(* Return the CRC of the interface of the given compilation unit *)

val crc_of_unit: string -> Digest.t

(* Return the set of compilation units imported, with their CRC *)

val imports: unit -> (string * Digest.t option) list

(* [is_imported_opaque md] returns true if [md] is an opaque imported module  *)
val is_imported_opaque: string -> bool

(* Direct access to the table of imported compilation units with their CRC *)

val crc_units: Consistbl.t
val add_import: string -> unit

(* Summaries -- compact representation of an environment, to be
   exported in debugging information. *)

val summary: t -> summary

(* Return an equivalent environment where all fields have been reset,
   except the summary. The initial environment can be rebuilt from the
   summary, using Envaux.env_of_only_summary. *)

val keep_only_summary : t -> t
val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t

(* Error report *)

type error =
  | Illegal_renaming of string * string * string
  | Inconsistent_import of string * string * string
  | Need_recursive_types of string * string
  | Depend_on_unsafe_string_unit of string * string
  | Missing_module of Location.t * Path.t * Path.t
  | Illegal_value_name of Location.t * string

exception Error of error

open Format

val report_error: formatter -> error -> unit


val mark_value_used: t -> string -> value_description -> unit
val mark_module_used: t -> string -> Location.t -> unit
val mark_type_used: t -> string -> type_declaration -> unit

type constructor_usage = Positive | Pattern | Privatize
val mark_constructor_used:
    constructor_usage -> t -> string -> type_declaration -> string -> unit
val mark_constructor:
    constructor_usage -> t -> string -> constructor_description -> unit
val mark_extension_used:
    constructor_usage -> t -> extension_constructor -> string -> unit

val in_signature: bool -> t -> t
val implicit_coercion: t -> t

val is_in_signature: t -> bool

val set_value_used_callback:
    string -> value_description -> (unit -> unit) -> unit
val set_type_used_callback:
    string -> type_declaration -> ((unit -> unit) -> unit) -> unit

(* Forward declaration to break mutual recursion with Includemod. *)
val check_modtype_inclusion:
      (loc:Location.t -> t -> module_type -> Path.t -> module_type -> unit) ref
(* Forward declaration to break mutual recursion with Typecore. *)
val add_delayed_check_forward: ((unit -> unit) -> unit) ref
(* Forward declaration to break mutual recursion with Mtype. *)
val strengthen:
    (aliasable:bool -> t -> module_type -> Path.t -> module_type) ref
(* Forward declaration to break mutual recursion with Ctype. *)
val same_constr: (t -> type_expr -> type_expr -> bool) ref

(** Folding over all identifiers (for analysis purpose) *)

val fold_values:
  (string -> Path.t -> value_description -> 'a -> 'a) ->
  Longident.t option -> t -> 'a -> 'a
val fold_types:
  (string -> Path.t -> type_declaration * type_descriptions -> 'a -> 'a) ->
  Longident.t option -> t -> 'a -> 'a
val fold_constructors:
  (constructor_description -> 'a -> 'a) ->
  Longident.t option -> t -> 'a -> 'a
val fold_labels:
  (label_description -> 'a -> 'a) ->
  Longident.t option -> t -> 'a -> 'a

(** Persistent structures are only traversed if they are already loaded. *)
val fold_modules:
  (string -> Path.t -> module_declaration -> 'a -> 'a) ->
  Longident.t option -> t -> 'a -> 'a

val fold_modtypes:
  (string -> Path.t -> modtype_declaration -> 'a -> 'a) ->
  Longident.t option -> t -> 'a -> 'a
val fold_classs:
  (string -> Path.t -> class_declaration -> 'a -> 'a) ->
  Longident.t option -> t -> 'a -> 'a
val fold_cltypes:
  (string -> Path.t -> class_type_declaration -> 'a -> 'a) ->
  Longident.t option -> t -> 'a -> 'a

(** Utilities *)
val scrape_alias: t -> module_type -> module_type
val check_value_name: string -> Location.t -> unit

module Persistent_signature : sig
  type t =
    { filename : string; (** Name of the file containing the signature. *)
      cmi : Cmi_format.cmi_infos }

  (** Function used to load a persistent signature. The default is to look for
      the .cmi file in the load path. This function can be overridden to load
      it from memory, for instance to build a self-contained toplevel. *)
  val load : (unit_name:string -> t option) ref
end

end = struct
#1 "env.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Environment handling *)

open Cmi_format
open Config
open Misc
open Asttypes
open Longident
open Path
open Types
open Btype

let add_delayed_check_forward = ref (fun _ -> assert false)

let value_declarations : ((string * Location.t), (unit -> unit)) Hashtbl.t =
  Hashtbl.create 16
    (* This table is used to usage of value declarations.  A declaration is
       identified with its name and location.  The callback attached to a
       declaration is called whenever the value is used explicitly
       (lookup_value) or implicitly (inclusion test between signatures,
       cf Includemod.value_descriptions). *)

let type_declarations = Hashtbl.create 16
let module_declarations = Hashtbl.create 16

type constructor_usage = Positive | Pattern | Privatize
type constructor_usages =
    {
     mutable cu_positive: bool;
     mutable cu_pattern: bool;
     mutable cu_privatize: bool;
    }
let add_constructor_usage cu = function
  | Positive -> cu.cu_positive <- true
  | Pattern -> cu.cu_pattern <- true
  | Privatize -> cu.cu_privatize <- true
let constructor_usages () =
  {cu_positive = false; cu_pattern = false; cu_privatize = false}

let used_constructors :
    (string * Location.t * string, (constructor_usage -> unit)) Hashtbl.t
  = Hashtbl.create 16

let prefixed_sg = Hashtbl.create 113

type error =
  | Illegal_renaming of string * string * string
  | Inconsistent_import of string * string * string
  | Need_recursive_types of string * string
  | Depend_on_unsafe_string_unit of string * string
  | Missing_module of Location.t * Path.t * Path.t
  | Illegal_value_name of Location.t * string

exception Error of error

let error err = raise (Error err)

module EnvLazy : sig
  type ('a,'b) t

  type log

  val force : ('a -> 'b) -> ('a,'b) t -> 'b
  val create : 'a -> ('a,'b) t
  val get_arg : ('a,'b) t -> 'a option

  (* [force_logged log f t] is equivalent to [force f t] but if [f] returns [None] then
     [t] is recorded in [log]. [backtrack log] will then reset all the recorded [t]s back
     to their original state. *)
  val log : unit -> log
  val force_logged : log -> ('a -> 'b option) -> ('a,'b option) t -> 'b option
  val backtrack : log -> unit

end  = struct

  type ('a,'b) t = ('a,'b) eval ref

  and ('a,'b) eval =
    | Done of 'b
    | Raise of exn
    | Thunk of 'a

  type undo =
    | Nil
    | Cons : ('a, 'b) t * 'a * undo -> undo

  type log = undo ref

  let force f x =
    match !x with
    | Done x -> x
    | Raise e -> raise e
    | Thunk e ->
        match f e with
        | y ->
          x := Done y;
          y
        | exception e ->
          x := Raise e;
          raise e

  let get_arg x =
    match !x with Thunk a -> Some a | _ -> None

  let create x =
    ref (Thunk x)

  let log () =
    ref Nil

  let force_logged log f x =
    match !x with
    | Done x -> x
    | Raise e -> raise e
    | Thunk e ->
      match f e with
      | None ->
          x := Done None;
          log := Cons(x, e, !log);
          None
      | Some _ as y ->
          x := Done y;
          y
      | exception e ->
          x := Raise e;
          raise e

  let backtrack log =
    let rec loop = function
      | Nil -> ()
      | Cons(x, e, rest) ->
          x := Thunk e;
          loop rest
    in
    loop !log

end

module PathMap = Map.Make(Path)

type summary =
    Env_empty
  | Env_value of summary * Ident.t * value_description
  | Env_type of summary * Ident.t * type_declaration
  | Env_extension of summary * Ident.t * extension_constructor
  | Env_module of summary * Ident.t * module_declaration
  | Env_modtype of summary * Ident.t * modtype_declaration
  | Env_class of summary * Ident.t * class_declaration
  | Env_cltype of summary * Ident.t * class_type_declaration
  | Env_open of summary * Path.t
  | Env_functor_arg of summary * Ident.t
  | Env_constraints of summary * type_declaration PathMap.t
  | Env_copy_types of summary * string list

module TycompTbl =
  struct
    (** This module is used to store components of types (i.e. labels
        and constructors).  We keep a representation of each nested
        "open" and the set of local bindings between each of them. *)

    type 'a t = {
      current: 'a Ident.tbl;
      (** Local bindings since the last open. *)

      opened: 'a opened option;
      (** Symbolic representation of the last (innermost) open, if any. *)
    }

    and 'a opened = {
      components: (string, 'a list) Tbl.t;
      (** Components from the opened module. We keep a list of
          bindings for each name, as in comp_labels and
          comp_constrs. *)

      using: (string -> ('a * 'a) option -> unit) option;
      (** A callback to be applied when a component is used from this
          "open".  This is used to detect unused "opens".  The
          arguments are used to detect shadowing. *)

      next: 'a t;
      (** The table before opening the module. *)
    }

    let empty = { current = Ident.empty; opened = None }

    let add id x tbl =
      {tbl with current = Ident.add id x tbl.current}

    let add_open slot wrap components next =
      let using =
        match slot with
        | None -> None
        | Some f -> Some (fun s x -> f s (wrap x))
      in
      {
        current = Ident.empty;
        opened = Some {using; components; next};
      }

    let rec find_same id tbl =
      try Ident.find_same id tbl.current
      with Not_found as exn ->
        begin match tbl.opened with
        | Some {next; _} -> find_same id next
        | None -> raise exn
        end

    let nothing = fun () -> ()

    let mk_callback rest name desc = function
      | None -> nothing
      | Some f ->
          (fun () ->
             match rest with
             | [] -> f name None
             | (hidden, _) :: _ -> f name (Some (desc, hidden))
          )

    let rec find_all name tbl =
      List.map (fun (_id, desc) -> desc, nothing)
        (Ident.find_all name tbl.current) @
      match tbl.opened with
      | None -> []
      | Some {using; next; components} ->
          let rest = find_all name next in
          match Tbl.find_str name components with
          | exception Not_found -> rest
          | opened ->
              List.map
                (fun desc -> desc, mk_callback rest name desc using)
                opened
              @ rest

    let rec fold_name f tbl acc =
      let acc = Ident.fold_name (fun _id d -> f d) tbl.current acc in
      match tbl.opened with
      | Some {using = _; next; components} ->
          acc
          |> Tbl.fold
            (fun _name -> List.fold_right (fun desc -> f desc))
            components
          |> fold_name f next
      | None ->
          acc

    let rec local_keys tbl acc =
      let acc = Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc in
      match tbl.opened with
      | Some o -> local_keys o.next acc
      | None -> acc

    let diff_keys is_local tbl1 tbl2 =
      let keys2 = local_keys tbl2 [] in
      List.filter
        (fun id ->
           is_local (find_same id tbl2) &&
           try ignore (find_same id tbl1); false
           with Not_found -> true)
        keys2

  end


module IdTbl =
  struct
    (** This module is used to store all kinds of components except
        (labels and constructors) in environments.  We keep a
        representation of each nested "open" and the set of local
        bindings between each of them. *)


    type 'a t = {
      current: 'a Ident.tbl;
      (** Local bindings since the last open *)

      opened: 'a opened option;
      (** Symbolic representation of the last (innermost) open, if any. *)
    }

    and 'a opened = {
      root: Path.t;
      (** The path of the opened module, to be prefixed in front of
          its local names to produce a valid path in the current
          environment. *)

      components: (string, 'a * int) Tbl.t;
      (** Components from the opened module. *)

      using: (string -> ('a * 'a) option -> unit) option;
      (** A callback to be applied when a component is used from this
          "open".  This is used to detect unused "opens".  The
          arguments are used to detect shadowing. *)

      next: 'a t;
      (** The table before opening the module. *)
    }

    let empty = { current = Ident.empty; opened = None }

    let add id x tbl =
      {tbl with current = Ident.add id x tbl.current}

    let add_open slot wrap root components next =
      let using =
        match slot with
        | None -> None
        | Some f -> Some (fun s x -> f s (wrap x))
      in
      {
        current = Ident.empty;
        opened = Some {using; root; components; next};
      }

    let rec find_same id tbl =
      try Ident.find_same id tbl.current
      with Not_found as exn ->
        begin match tbl.opened with
        | Some {next; _} -> find_same id next
        | None -> raise exn
        end

    let rec find_name mark name tbl =
      try
        let (id, desc) = Ident.find_name name tbl.current in
        Pident id, desc
      with Not_found as exn ->
        begin match tbl.opened with
        | Some {using; root; next; components} ->
            begin try
              let (descr, pos) = Tbl.find_str name components in
              let res = Pdot (root, name, pos), descr in
              if mark then begin match using with
              | None -> ()
              | Some f ->
                  begin try f name (Some (snd (find_name false name next), snd res))
                  with Not_found -> f name None
                  end
              end;
              res
            with Not_found ->
              find_name mark name next
            end
        | None ->
            raise exn
        end

    let find_name name tbl = find_name true name tbl

    let rec update name f tbl =
      try
        let (id, desc) = Ident.find_name name tbl.current in
        let new_desc = f desc in
        {tbl with current = Ident.add id new_desc tbl.current}
      with Not_found ->
        begin match tbl.opened with
        | Some {root; using; next; components} ->
            begin try
              let (desc, pos) = Tbl.find_str name components in
              let new_desc = f desc in
              let components = Tbl.add name (new_desc, pos) components in
              {tbl with opened = Some {root; using; next; components}}
            with Not_found ->
              let next = update name f next in
              {tbl with opened = Some {root; using; next; components}}
            end
        | None ->
            tbl
        end



    let rec find_all name tbl =
      List.map (fun (id, desc) -> Pident id, desc) (Ident.find_all name tbl.current) @
      match tbl.opened with
      | None -> []
      | Some {root; using = _; next; components} ->
          try
            let (desc, pos) = Tbl.find_str name components in
            (Pdot (root, name, pos), desc) :: find_all name next
          with Not_found ->
            find_all name next

    let rec fold_name f tbl acc =
      let acc = Ident.fold_name (fun id d -> f (Ident.name id) (Pident id, d)) tbl.current acc in
      match tbl.opened with
      | Some {root; using = _; next; components} ->
          acc
          |> Tbl.fold
            (fun name (desc, pos) -> f name (Pdot (root, name, pos), desc))
            components
          |> fold_name f next
      | None ->
          acc

    let rec local_keys tbl acc =
      let acc = Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc in
      match tbl.opened with
      | Some o -> local_keys o.next acc
      | None -> acc


    let rec iter f tbl =
      Ident.iter (fun id desc -> f id (Pident id, desc)) tbl.current;
      match tbl.opened with
      | Some {root; using = _; next; components} ->
          Tbl.iter
            (fun s (x, pos) -> f (Ident.hide (Ident.create s) (* ??? *)) (Pdot (root, s, pos), x))
            components;
          iter f next
      | None -> ()

    let diff_keys tbl1 tbl2 =
      let keys2 = local_keys tbl2 [] in
      List.filter
        (fun id ->
           try ignore (find_same id tbl1); false
           with Not_found -> true)
        keys2


  end

type type_descriptions =
    constructor_description list * label_description list

let in_signature_flag = 0x01
let implicit_coercion_flag = 0x02

type t = {
  values: value_description IdTbl.t;
  constrs: constructor_description TycompTbl.t;
  labels: label_description TycompTbl.t;
  types: (type_declaration * type_descriptions) IdTbl.t;
  modules: (Subst.t * module_declaration, module_declaration) EnvLazy.t IdTbl.t;
  modtypes: modtype_declaration IdTbl.t;
  components: module_components IdTbl.t;
  classes: class_declaration IdTbl.t;
  cltypes: class_type_declaration IdTbl.t;
  functor_args: unit Ident.tbl;
  summary: summary;
  local_constraints: type_declaration PathMap.t;
  gadt_instances: (int * TypeSet.t ref) list;
  flags: int;
}

and module_components =
  {
    deprecated: string option;
    loc: Location.t;
    comps:
      (t * Subst.t * Path.t * Types.module_type, module_components_repr option)
        EnvLazy.t;
  }

and module_components_repr =
    Structure_comps of structure_components
  | Functor_comps of functor_components

and 'a comp_tbl = (string, ('a * int)) Tbl.t

and structure_components = {
  mutable comp_values: value_description comp_tbl;
  mutable comp_constrs: (string, constructor_description list) Tbl.t;
  mutable comp_labels: (string, label_description list) Tbl.t;
  mutable comp_types: (type_declaration * type_descriptions) comp_tbl;
  mutable comp_modules:
   (Subst.t * module_declaration, module_declaration) EnvLazy.t comp_tbl;
  mutable comp_modtypes: modtype_declaration comp_tbl;
  mutable comp_components: module_components comp_tbl;
  mutable comp_classes: class_declaration comp_tbl;
  mutable comp_cltypes: class_type_declaration comp_tbl;
}

and functor_components = {
  fcomp_param: Ident.t;                 (* Formal parameter *)
  fcomp_arg: module_type option;        (* Argument signature *)
  fcomp_res: module_type;               (* Result signature *)
  fcomp_cache: (Path.t, module_components) Hashtbl.t;  (* For memoization *)
  fcomp_subst_cache: (Path.t, module_type) Hashtbl.t
}

let copy_local ~from env =
  { env with
    local_constraints = from.local_constraints;
    gadt_instances = from.gadt_instances;
    flags = from.flags }

let same_constr = ref (fun _ _ _ -> assert false)

(* Helper to decide whether to report an identifier shadowing
   by some 'open'. For labels and constructors, we do not report
   if the two elements are from the same re-exported declaration.

   Later, one could also interpret some attributes on value and
   type declarations to silence the shadowing warnings. *)

let check_shadowing env = function
  | `Constructor (Some (c1, c2))
    when not (!same_constr env c1.cstr_res c2.cstr_res) ->
      Some "constructor"
  | `Label (Some (l1, l2))
    when not (!same_constr env l1.lbl_res l2.lbl_res) ->
      Some "label"
  | `Value (Some _) -> Some "value"
  | `Type (Some _) -> Some "type"
  | `Module (Some _) | `Component (Some _) -> Some "module"
  | `Module_type (Some _) -> Some "module type"
  | `Class (Some _) -> Some "class"
  | `Class_type (Some _) -> Some "class type"
  | `Constructor _ | `Label _
  | `Value None | `Type None | `Module None | `Module_type None
  | `Class None | `Class_type None | `Component None ->
      None

let subst_modtype_maker (subst, md) =
  if subst == Subst.identity then md
  else {md with md_type = Subst.modtype subst md.md_type}

let empty = {
  values = IdTbl.empty; constrs = TycompTbl.empty;
  labels = TycompTbl.empty; types = IdTbl.empty;
  modules = IdTbl.empty; modtypes = IdTbl.empty;
  components = IdTbl.empty; classes = IdTbl.empty;
  cltypes = IdTbl.empty;
  summary = Env_empty; local_constraints = PathMap.empty; gadt_instances = [];
  flags = 0;
  functor_args = Ident.empty;
 }

let in_signature b env =
  let flags =
    if b then env.flags lor in_signature_flag
    else env.flags land (lnot in_signature_flag)
  in
  {env with flags}

let implicit_coercion env =
  {env with flags = env.flags lor implicit_coercion_flag}

let is_in_signature env = env.flags land in_signature_flag <> 0
let is_implicit_coercion env = env.flags land implicit_coercion_flag <> 0

let is_ident = function
    Pident _ -> true
  | Pdot _ | Papply _ -> false

let is_local_ext = function
  | {cstr_tag = Cstr_extension(p, _)} -> is_ident p
  | _ -> false

let diff env1 env2 =
  IdTbl.diff_keys env1.values env2.values @
  TycompTbl.diff_keys is_local_ext env1.constrs env2.constrs @
  IdTbl.diff_keys env1.modules env2.modules @
  IdTbl.diff_keys env1.classes env2.classes

type can_load_cmis =
  | Can_load_cmis
  | Cannot_load_cmis of EnvLazy.log

let can_load_cmis = ref Can_load_cmis

let without_cmis f x =
  let log = EnvLazy.log () in
  let res =
    Misc.(protect_refs
            [R (can_load_cmis, Cannot_load_cmis log)]
            (fun () -> f x))
  in
  EnvLazy.backtrack log;
  res

(* Forward declarations *)

let components_of_module' =
  ref ((fun ~deprecated:_ ~loc:_ _env _sub _path _mty -> assert false) :
         deprecated:string option -> loc:Location.t -> t -> Subst.t ->
       Path.t -> module_type ->
       module_components)
let components_of_module_maker' =
  ref ((fun (_env, _sub, _path, _mty) -> assert false) :
          t * Subst.t * Path.t * module_type -> module_components_repr option)
let components_of_functor_appl' =
  ref ((fun _f _env _p1 _p2 -> assert false) :
          functor_components -> t -> Path.t -> Path.t -> module_components)
let check_modtype_inclusion =
  (* to be filled with Includemod.check_modtype_inclusion *)
  ref ((fun ~loc:_ _env _mty1 _path1 _mty2 -> assert false) :
          loc:Location.t -> t -> module_type -> Path.t -> module_type -> unit)
let strengthen =
  (* to be filled with Mtype.strengthen *)
  ref ((fun ~aliasable:_ _env _mty _path -> assert false) :
         aliasable:bool -> t -> module_type -> Path.t -> module_type)

let md md_type =
  {md_type; md_attributes=[]; md_loc=Location.none}

let get_components_opt c =
  match !can_load_cmis with
  | Can_load_cmis ->
    EnvLazy.force !components_of_module_maker' c.comps
  | Cannot_load_cmis log ->
    EnvLazy.force_logged log !components_of_module_maker' c.comps

let empty_structure =
  Structure_comps {
    comp_values = Tbl.empty;
    comp_constrs = Tbl.empty;
    comp_labels = Tbl.empty;
    comp_types = Tbl.empty;
    comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
    comp_components = Tbl.empty; comp_classes = Tbl.empty;
    comp_cltypes = Tbl.empty }

let get_components c =
  match get_components_opt c with
  | None -> empty_structure
  | Some c -> c

(* The name of the compilation unit currently compiled.
   "" if outside a compilation unit. *)

let current_unit = ref ""

(* Persistent structure descriptions *)

type pers_struct =
  { ps_name: string;
    ps_sig: signature Lazy.t;
    ps_comps: module_components;
    ps_crcs: (string * Digest.t option) list;
    ps_filename: string;
    ps_flags: pers_flags list }

let persistent_structures =
  (Hashtbl.create 17 : (string, pers_struct option) Hashtbl.t)

(* Consistency between persistent structures *)

let crc_units = Consistbl.create()

module StringSet =
  Set.Make(struct type t = string let compare = String.compare end)

let imported_units = ref StringSet.empty

let add_import s =
  imported_units := StringSet.add s !imported_units

let imported_opaque_units = ref StringSet.empty

let add_imported_opaque s =
  imported_opaque_units := StringSet.add s !imported_opaque_units

let clear_imports () =
  Consistbl.clear crc_units;
  imported_units := StringSet.empty;
  imported_opaque_units := StringSet.empty

let check_consistency ps =
  try
    List.iter
      (fun (name, crco) ->
         match crco with
            None -> ()
          | Some crc ->
              add_import name;
              Consistbl.check crc_units name crc ps.ps_filename)
      ps.ps_crcs;
  with Consistbl.Inconsistency(name, source, auth) ->
    error (Inconsistent_import(name, auth, source))

(* Reading persistent structures from .cmi files *)

let save_pers_struct crc ps =
  let modname = ps.ps_name in
  Hashtbl.add persistent_structures modname (Some ps);
  List.iter
    (function
        | Rectypes -> ()
        | Deprecated _ -> ()
        | Unsafe_string -> ()
        | Opaque -> add_imported_opaque modname)
    ps.ps_flags;
  Consistbl.set crc_units modname crc ps.ps_filename;
  add_import modname

module Persistent_signature = struct
  type t =
    { filename : string;
      cmi : Cmi_format.cmi_infos }

  let load = ref (fun ~unit_name ->
    match find_in_path_uncap !load_path (unit_name ^ ".cmi") with
    | filename -> Some { filename; cmi = read_cmi filename }
    | exception Not_found -> None)
end

let acknowledge_pers_struct check modname
      { Persistent_signature.filename; cmi } =
  let name = cmi.cmi_name in
  let sign = cmi.cmi_sign in
  let crcs = cmi.cmi_crcs in
  let flags = cmi.cmi_flags in
  let deprecated =
    List.fold_left (fun acc -> function Deprecated s -> Some s | _ -> acc) None
      flags
  in
  let comps =
      !components_of_module' ~deprecated ~loc:Location.none
        empty Subst.identity
                             (Pident(Ident.create_persistent name))
                             (Mty_signature sign)
  in
  let ps = { ps_name = name;
             ps_sig = lazy (Subst.signature Subst.identity sign);
             ps_comps = comps;
             ps_crcs = crcs;
             ps_filename = filename;
             ps_flags = flags;
           } in
  if ps.ps_name <> modname then
    error (Illegal_renaming(modname, ps.ps_name, filename));

  List.iter
    (function
        | Rectypes ->
            if not !Clflags.recursive_types then
              error (Need_recursive_types(ps.ps_name, !current_unit))
        | Unsafe_string ->
            if Config.safe_string then
              error (Depend_on_unsafe_string_unit (ps.ps_name, !current_unit));
        | Deprecated _ -> ()
        | Opaque -> add_imported_opaque modname)
    ps.ps_flags;
  if check then check_consistency ps;
  Hashtbl.add persistent_structures modname (Some ps);
  ps

let read_pers_struct check modname filename =
  add_import modname;
  let cmi = read_cmi filename in
  acknowledge_pers_struct check modname
    { Persistent_signature.filename; cmi }

let find_pers_struct check name =
  if name = "*predef*" then raise Not_found;
  match Hashtbl.find persistent_structures name with
  | Some ps -> ps
  | None -> raise Not_found
  | exception Not_found ->
    match !can_load_cmis with
    | Cannot_load_cmis _ -> raise Not_found
    | Can_load_cmis ->
        let ps =
          match !Persistent_signature.load ~unit_name:name with
          | Some ps -> ps
          | None ->
            Hashtbl.add persistent_structures name None;
            raise Not_found
        in
        add_import name;
        acknowledge_pers_struct check name ps

(* Emits a warning if there is no valid cmi for name *)
let check_pers_struct name =
  try
    ignore (find_pers_struct false name)
  with
  | Not_found ->
      let warn = Warnings.No_cmi_file(name, None) in
        Location.prerr_warning Location.none warn
  | Cmi_format.Error err ->
      let msg = Format.asprintf "%a" Cmi_format.report_error err in
      let warn = Warnings.No_cmi_file(name, Some msg) in
        Location.prerr_warning Location.none warn
  | Error err ->
      let msg =
        match err with
        | Illegal_renaming(name, ps_name, filename) ->
            Format.asprintf
              " %a@ contains the compiled interface for @ \
               %s when %s was expected"
              Location.print_filename filename ps_name name
        | Inconsistent_import _ -> assert false
        | Need_recursive_types(name, _) ->
            Format.sprintf
              "%s uses recursive types"
              name
        | Depend_on_unsafe_string_unit (name, _) ->
            Printf.sprintf "%s uses -unsafe-string"
              name
        | Missing_module _ -> assert false
        | Illegal_value_name _ -> assert false
      in
      let warn = Warnings.No_cmi_file(name, Some msg) in
        Location.prerr_warning Location.none warn

let read_pers_struct modname filename =
  read_pers_struct true modname filename

let find_pers_struct name =
  find_pers_struct true name

let check_pers_struct name =
  if not (Hashtbl.mem persistent_structures name) then begin
    (* PR#6843: record the weak dependency ([add_import]) regardless of
       whether the check succeeds, to help make builds more
       deterministic. *)
    add_import name;
    if (Warnings.is_active (Warnings.No_cmi_file("", None))) then
      !add_delayed_check_forward
        (fun () -> check_pers_struct name)
  end

let reset_cache () =
  current_unit := "";
  Hashtbl.clear persistent_structures;
  clear_imports ();
  Hashtbl.clear value_declarations;
  Hashtbl.clear type_declarations;
  Hashtbl.clear module_declarations;
  Hashtbl.clear used_constructors;
  Hashtbl.clear prefixed_sg

let reset_cache_toplevel () =
  (* Delete 'missing cmi' entries from the cache. *)
  let l =
    Hashtbl.fold
      (fun name r acc -> if r = None then name :: acc else acc)
      persistent_structures []
  in
  List.iter (Hashtbl.remove persistent_structures) l;
  Hashtbl.clear value_declarations;
  Hashtbl.clear type_declarations;
  Hashtbl.clear module_declarations;
  Hashtbl.clear used_constructors;
  Hashtbl.clear prefixed_sg


let set_unit_name name =
  current_unit := name

let get_unit_name () =
  !current_unit

(* Lookup by identifier *)

let rec find_module_descr path env =
  match path with
    Pident id ->
      begin try
        IdTbl.find_same id env.components
      with Not_found ->
        if Ident.persistent id && not (Ident.name id = !current_unit)
        then (find_pers_struct (Ident.name id)).ps_comps
        else raise Not_found
      end
  | Pdot(p, s, _pos) ->
      begin match get_components (find_module_descr p env) with
        Structure_comps c ->
          let (descr, _pos) = Tbl.find_str s c.comp_components in
          descr
      | Functor_comps _ ->
         raise Not_found
      end
  | Papply(p1, p2) ->
      begin match get_components (find_module_descr p1 env) with
        Functor_comps f ->
          !components_of_functor_appl' f env p1 p2
      | Structure_comps _ ->
          raise Not_found
      end

let find proj1 proj2 path env =
  match path with
    Pident id ->
      IdTbl.find_same id (proj1 env)
  | Pdot(p, s, _pos) ->
      begin match get_components (find_module_descr p env) with
        Structure_comps c ->
          let (data, _pos) = Tbl.find_str s (proj2 c) in data
      | Functor_comps _ ->
          raise Not_found
      end
  | Papply _ ->
      raise Not_found

let find_value =
  find (fun env -> env.values) (fun sc -> sc.comp_values)
and find_type_full =
  find (fun env -> env.types) (fun sc -> sc.comp_types)
and find_modtype =
  find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes)
and find_class =
  find (fun env -> env.classes) (fun sc -> sc.comp_classes)
and find_cltype =
  find (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)

let type_of_cstr path = function
  | {cstr_inlined = Some d; _} ->
      (d, ([], List.map snd (Datarepr.labels_of_type path d)))
  | _ ->
      assert false

let find_type_full path env =
  match Path.constructor_typath path with
  | Regular p ->
      (try (PathMap.find p env.local_constraints, ([], []))
       with Not_found -> find_type_full p env)
  | Cstr (ty_path, s) ->
      let (_, (cstrs, _)) =
        try find_type_full ty_path env
        with Not_found -> assert false
      in
      let cstr =
        try List.find (fun cstr -> cstr.cstr_name = s) cstrs
        with Not_found -> assert false
      in
      type_of_cstr path cstr
  | LocalExt id ->
      let cstr =
        try TycompTbl.find_same id env.constrs
        with Not_found -> assert false
      in
      type_of_cstr path cstr
  | Ext (mod_path, s) ->
      let comps =
        try find_module_descr mod_path env
        with Not_found -> assert false
      in
      let comps =
        match get_components comps with
        | Structure_comps c -> c
        | Functor_comps _ -> assert false
      in
      let exts =
        List.filter
          (function {cstr_tag=Cstr_extension _} -> true | _ -> false)
          (try Tbl.find_str s comps.comp_constrs
           with Not_found -> assert false)
      in
      match exts with
      | [cstr] -> type_of_cstr path cstr
      | _ -> assert false

let find_type p env =
  fst (find_type_full p env)
let find_type_descrs p env =
  snd (find_type_full p env)

let find_module ~alias path env =
  match path with
    Pident id ->
      begin try
        let data = IdTbl.find_same id env.modules in
        EnvLazy.force subst_modtype_maker data
      with Not_found ->
        if Ident.persistent id && not (Ident.name id = !current_unit) then
          let ps = find_pers_struct (Ident.name id) in
          md (Mty_signature(Lazy.force ps.ps_sig))
        else raise Not_found
      end
  | Pdot(p, s, _pos) ->
      begin match get_components (find_module_descr p env) with
        Structure_comps c ->
          let (data, _pos) = Tbl.find_str s c.comp_modules in
          EnvLazy.force subst_modtype_maker data
      | Functor_comps _ ->
          raise Not_found
      end
  | Papply(p1, p2) ->
      let desc1 = find_module_descr p1 env in
      begin match get_components desc1 with
        Functor_comps f ->
          md begin match f.fcomp_res with
          | Mty_alias _ as mty -> mty
          | mty ->
              if alias then mty else
              try
                Hashtbl.find f.fcomp_subst_cache p2
              with Not_found ->
                let mty =
                  Subst.modtype
                    (Subst.add_module f.fcomp_param p2 Subst.identity)
                    f.fcomp_res in
                Hashtbl.add f.fcomp_subst_cache p2 mty;
                mty
          end
      | Structure_comps _ ->
          raise Not_found
      end

let required_globals = ref []
let reset_required_globals () = required_globals := []
let get_required_globals () = !required_globals
let add_required_global id =
  if Ident.global id && not !Clflags.transparent_modules
  && not (List.exists (Ident.same id) !required_globals)
  then required_globals := id :: !required_globals

let rec normalize_path lax env path =
  let path =
    match path with
      Pdot(p, s, pos) ->
        Pdot(normalize_path lax env p, s, pos)
    | Papply(p1, p2) ->
        Papply(normalize_path lax env p1, normalize_path true env p2)
    | _ -> path
  in
  try match find_module ~alias:true path env with
    {md_type=Mty_alias(_, path1)} ->
      let path' = normalize_path lax env path1 in
      if lax || !Clflags.transparent_modules then path' else
      let id = Path.head path in
      if Ident.global id && not (Ident.same id (Path.head path'))
      then add_required_global id;
      path'
  | _ -> path
  with Not_found when lax
  || (match path with Pident id -> not (Ident.persistent id) | _ -> true) ->
      path

let normalize_path oloc env path =
  try normalize_path (oloc = None) env path
  with Not_found ->
    match oloc with None -> assert false
    | Some loc ->
        raise (Error(Missing_module(loc, path, normalize_path true env path)))

let normalize_path_prefix oloc env path =
  match path with
    Pdot(p, s, pos) ->
      Pdot(normalize_path oloc env p, s, pos)
  | Pident _ ->
      path
  | Papply _ ->
      assert false


let find_module = find_module ~alias:false

(* Find the manifest type associated to a type when appropriate:
   - the type should be public or should have a private row,
   - the type should have an associated manifest type. *)
let find_type_expansion path env =
  let decl = find_type path env in
  match decl.type_manifest with
  | Some body when decl.type_private = Public
              || decl.type_kind <> Type_abstract
              || Btype.has_constr_row body ->
                  (decl.type_params, body, may_map snd decl.type_newtype_level)
  (* The manifest type of Private abstract data types without
     private row are still considered unknown to the type system.
     Hence, this case is caught by the following clause that also handles
     purely abstract data types without manifest type definition. *)
  | _ -> raise Not_found

(* Find the manifest type information associated to a type, i.e.
   the necessary information for the compiler's type-based optimisations.
   In particular, the manifest type associated to a private abstract type
   is revealed for the sake of compiler's type-based optimisations. *)
let find_type_expansion_opt path env =
  let decl = find_type path env in
  match decl.type_manifest with
  (* The manifest type of Private abstract data types can still get
     an approximation using their manifest type. *)
  | Some body -> (decl.type_params, body, may_map snd decl.type_newtype_level)
  | _ -> raise Not_found

let find_modtype_expansion path env =
  match (find_modtype path env).mtd_type with
  | None -> raise Not_found
  | Some mty -> mty

let rec is_functor_arg path env =
  match path with
    Pident id ->
      begin try Ident.find_same id env.functor_args; true
      with Not_found -> false
      end
  | Pdot (p, _s, _) -> is_functor_arg p env
  | Papply _ -> true

(* Lookup by name *)

exception Recmodule

let report_deprecated ?loc p deprecated =
  match loc, deprecated with
  | Some loc, Some txt ->
      let txt = if txt = "" then "" else "\n" ^ txt in
      Location.deprecated loc (Printf.sprintf "module %s%s" (Path.name p) txt)
  | _ -> ()

let mark_module_used env name loc =
  if not (is_implicit_coercion env) then
    try Hashtbl.find module_declarations (name, loc) ()
    with Not_found -> ()

let rec lookup_module_descr_aux ?loc lid env =
  match lid with
    Lident s ->
      begin try
        IdTbl.find_name s env.components
      with Not_found ->
        if s = !current_unit then raise Not_found;
        let ps = find_pers_struct s in
        (Pident(Ident.create_persistent s), ps.ps_comps)
      end
  | Ldot(l, s) ->
      let (p, descr) = lookup_module_descr ?loc l env in
      begin match get_components descr with
        Structure_comps c ->
          let (descr, pos) = Tbl.find_str s c.comp_components in
          (Pdot(p, s, pos), descr)
      | Functor_comps _ ->
          raise Not_found
      end
  | Lapply(l1, l2) ->
      let (p1, desc1) = lookup_module_descr ?loc l1 env in
      let p2 = lookup_module ~load:true ?loc l2 env in
      let {md_type=mty2} = find_module p2 env in
      begin match get_components desc1 with
        Functor_comps f ->
          let loc = match loc with Some l -> l | None -> Location.none in
          Misc.may (!check_modtype_inclusion ~loc env mty2 p2) f.fcomp_arg;
          (Papply(p1, p2), !components_of_functor_appl' f env p1 p2)
      | Structure_comps _ ->
          raise Not_found
      end

and lookup_module_descr ?loc lid env =
  let (p, comps) as res = lookup_module_descr_aux ?loc lid env in
  mark_module_used env (Path.last p) comps.loc;
(*
  Format.printf "USE module %s at %a@." (Path.last p)
    Location.print comps.loc;
*)
  report_deprecated ?loc p comps.deprecated;
  res

and lookup_module ~load ?loc lid env : Path.t =
  match lid with
    Lident s ->
      begin try
        let (p, data) = IdTbl.find_name s env.modules in
        let {md_loc; md_attributes; md_type} =
          EnvLazy.force subst_modtype_maker data
        in
        mark_module_used env s md_loc;
        begin match md_type with
        | Mty_ident (Path.Pident id) when Ident.name id = "#recmod#" ->
          (* see #5965 *)
          raise Recmodule
        | _ -> ()
        end;
        report_deprecated ?loc p
          (Builtin_attributes.deprecated_of_attrs md_attributes);
        p
      with Not_found ->
        if s = !current_unit then raise Not_found;
        let p = Pident(Ident.create_persistent s) in
        if !Clflags.transparent_modules && not load then check_pers_struct s
        else begin
          let ps = find_pers_struct s in
          report_deprecated ?loc p ps.ps_comps.deprecated
        end;
        p
      end
  | Ldot(l, s) ->
      let (p, descr) = lookup_module_descr ?loc l env in
      begin match get_components descr with
        Structure_comps c ->
          let (_data, pos) = Tbl.find_str s c.comp_modules in
          let (comps, _) = Tbl.find_str s c.comp_components in
          mark_module_used env s comps.loc;
          let p = Pdot(p, s, pos) in
          report_deprecated ?loc p comps.deprecated;
          p
      | Functor_comps _ ->
          raise Not_found
      end
  | Lapply(l1, l2) ->
      let (p1, desc1) = lookup_module_descr ?loc l1 env in
      let p2 = lookup_module ~load:true ?loc l2 env in
      let {md_type=mty2} = find_module p2 env in
      let p = Papply(p1, p2) in
      begin match get_components desc1 with
        Functor_comps f ->
          let loc = match loc with Some l -> l | None -> Location.none in
          Misc.may (!check_modtype_inclusion ~loc env mty2 p2) f.fcomp_arg;
          p
      | Structure_comps _ ->
          raise Not_found
      end

let lookup proj1 proj2 ?loc lid env =
  match lid with
    Lident s ->
      IdTbl.find_name s (proj1 env)
  | Ldot(l, s) ->
      let (p, desc) = lookup_module_descr ?loc l env in
      begin match get_components desc with
        Structure_comps c ->
          let (data, pos) = Tbl.find_str s (proj2 c) in
          (Pdot(p, s, pos), data)
      | Functor_comps _ ->
          raise Not_found
      end
  | Lapply _ ->
      raise Not_found

let lookup_all_simple proj1 proj2 shadow ?loc lid env =
  match lid with
    Lident s ->
      let xl = TycompTbl.find_all s (proj1 env) in
      let rec do_shadow =
        function
        | [] -> []
        | ((x, f) :: xs) ->
            (x, f) ::
              (do_shadow (List.filter (fun (y, _) -> not (shadow x y)) xs))
      in
        do_shadow xl
  | Ldot(l, s) ->
      let (_p, desc) = lookup_module_descr ?loc l env in
      begin match get_components desc with
        Structure_comps c ->
          let comps =
            try Tbl.find_str s (proj2 c) with Not_found -> []
          in
          List.map
            (fun data -> (data, (fun () -> ())))
            comps
      | Functor_comps _ ->
          raise Not_found
      end
  | Lapply _ ->
      raise Not_found

let has_local_constraints env = not (PathMap.is_empty env.local_constraints)

let cstr_shadow cstr1 cstr2 =
  match cstr1.cstr_tag, cstr2.cstr_tag with
  | Cstr_extension _, Cstr_extension _ -> true
  | _ -> false

let lbl_shadow _lbl1 _lbl2 = false

let lookup_value =
  lookup (fun env -> env.values) (fun sc -> sc.comp_values)
let lookup_all_constructors =
  lookup_all_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
    cstr_shadow
let lookup_all_labels =
  lookup_all_simple (fun env -> env.labels) (fun sc -> sc.comp_labels)
    lbl_shadow
let lookup_type =
  lookup (fun env -> env.types) (fun sc -> sc.comp_types)
let lookup_modtype =
  lookup (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes)
let lookup_class =
  lookup (fun env -> env.classes) (fun sc -> sc.comp_classes)
let lookup_cltype =
  lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)

let copy_types l env =
  let f desc = {desc with val_type = Subst.type_expr Subst.identity desc.val_type} in
  let values = List.fold_left (fun env s -> IdTbl.update s f env) env.values l in
  {env with values; summary = Env_copy_types (env.summary, l)}

let mark_value_used env name vd =
  if not (is_implicit_coercion env) then
    try Hashtbl.find value_declarations (name, vd.val_loc) ()
    with Not_found -> ()

let mark_type_used env name vd =
  if not (is_implicit_coercion env) then
    try Hashtbl.find type_declarations (name, vd.type_loc) ()
    with Not_found -> ()

let mark_constructor_used usage env name vd constr =
  if not (is_implicit_coercion env) then
    try Hashtbl.find used_constructors (name, vd.type_loc, constr) usage
    with Not_found -> ()

let mark_extension_used usage env ext name =
  if not (is_implicit_coercion env) then
    let ty_name = Path.last ext.ext_type_path in
    try Hashtbl.find used_constructors (ty_name, ext.ext_loc, name) usage
    with Not_found -> ()

let set_value_used_callback name vd callback =
  let key = (name, vd.val_loc) in
  try
    let old = Hashtbl.find value_declarations key in
    Hashtbl.replace value_declarations key (fun () -> old (); callback ())
      (* this is to support cases like:
               let x = let x = 1 in x in x
         where the two declarations have the same location
         (e.g. resulting from Camlp4 expansion of grammar entries) *)
  with Not_found ->
    Hashtbl.add value_declarations key callback

let set_type_used_callback name td callback =
  let loc = td.type_loc in
  if loc.Location.loc_ghost then ()
  else let key = (name, loc) in
  let old =
    try Hashtbl.find type_declarations key
    with Not_found -> assert false
  in
  Hashtbl.replace type_declarations key (fun () -> callback old)

let lookup_value ?loc lid env =
  let (_, desc) as r = lookup_value ?loc lid env in
  mark_value_used env (Longident.last lid) desc;
  r

let lookup_type ?loc lid env =
  let (path, (decl, _)) = lookup_type ?loc lid env in
  mark_type_used env (Longident.last lid) decl;
  path

let mark_type_path env path =
  try
    let decl = find_type path env in
    mark_type_used env (Path.last path) decl
  with Not_found -> ()

let ty_path t =
  match repr t with
  | {desc=Tconstr(path, _, _)} -> path
  | _ -> assert false

let lookup_constructor ?loc lid env =
  match lookup_all_constructors ?loc lid env with
    [] -> raise Not_found
  | (desc, use) :: _ ->
      mark_type_path env (ty_path desc.cstr_res);
      use ();
      desc

let is_lident = function
    Lident _ -> true
  | _ -> false

let lookup_all_constructors ?loc lid env =
  try
    let cstrs = lookup_all_constructors ?loc lid env in
    let wrap_use desc use () =
      mark_type_path env (ty_path desc.cstr_res);
      use ()
    in
    List.map (fun (cstr, use) -> (cstr, wrap_use cstr use)) cstrs
  with
    Not_found when is_lident lid -> []

let mark_constructor usage env name desc =
  if not (is_implicit_coercion env)
  then match desc.cstr_tag with
  | Cstr_extension _ ->
      begin
        let ty_path = ty_path desc.cstr_res in
        let ty_name = Path.last ty_path in
        try Hashtbl.find used_constructors (ty_name, desc.cstr_loc, name) usage
        with Not_found -> ()
      end
  | _ ->
      let ty_path = ty_path desc.cstr_res in
      let ty_decl = try find_type ty_path env with Not_found -> assert false in
      let ty_name = Path.last ty_path in
      mark_constructor_used usage env ty_name ty_decl name

let lookup_label ?loc lid env =
  match lookup_all_labels ?loc lid env with
    [] -> raise Not_found
  | (desc, use) :: _ ->
      mark_type_path env (ty_path desc.lbl_res);
      use ();
      desc

let lookup_all_labels ?loc lid env =
  try
    let lbls = lookup_all_labels ?loc lid env in
    let wrap_use desc use () =
      mark_type_path env (ty_path desc.lbl_res);
      use ()
    in
    List.map (fun (lbl, use) -> (lbl, wrap_use lbl use)) lbls
  with
    Not_found when is_lident lid -> []

let lookup_class ?loc lid env =
  let (_, desc) as r = lookup_class ?loc lid env in
  (* special support for Typeclass.unbound_class *)
  if Path.name desc.cty_path = "" then ignore (lookup_type ?loc lid env)
  else mark_type_path env desc.cty_path;
  r

let lookup_cltype ?loc lid env =
  let (_, desc) as r = lookup_cltype ?loc lid env in
  if Path.name desc.clty_path = "" then ignore (lookup_type ?loc lid env)
  else mark_type_path env desc.clty_path;
  mark_type_path env desc.clty_path;
  r

(* Iter on an environment (ignoring the body of functors and
   not yet evaluated structures) *)

type iter_cont = unit -> unit
let iter_env_cont = ref []

let rec scrape_alias_for_visit env mty =
  match mty with
  | Mty_alias(_, Pident id)
    when Ident.persistent id
      && not (Hashtbl.mem persistent_structures (Ident.name id)) -> false
  | Mty_alias(_, path) -> (* PR#6600: find_module may raise Not_found *)
      begin try scrape_alias_for_visit env (find_module path env).md_type
      with Not_found -> false
      end
  | _ -> true

let iter_env proj1 proj2 f env () =
  IdTbl.iter (fun id x -> f (Pident id) x) (proj1 env);
  let rec iter_components path path' mcomps =
    let cont () =
      let visit =
        match EnvLazy.get_arg mcomps.comps with
        | None -> true
        | Some (env, _sub, _path, mty) -> scrape_alias_for_visit env mty
      in
      if not visit then () else
      match get_components mcomps with
        Structure_comps comps ->
          Tbl.iter
            (fun s (d, n) -> f (Pdot (path, s, n)) (Pdot (path', s, n), d))
            (proj2 comps);
          Tbl.iter
            (fun s (c, n) ->
              iter_components (Pdot (path, s, n)) (Pdot (path', s, n)) c)
            comps.comp_components
      | Functor_comps _ -> ()
    in iter_env_cont := (path, cont) :: !iter_env_cont
  in
  Hashtbl.iter
    (fun s pso ->
      match pso with None -> ()
      | Some ps ->
          let id = Pident (Ident.create_persistent s) in
          iter_components id id ps.ps_comps)
    persistent_structures;
  IdTbl.iter
    (fun id (path, comps) -> iter_components (Pident id) path comps)
    env.components

let run_iter_cont l =
  iter_env_cont := [];
  List.iter (fun c -> c ()) l;
  let cont = List.rev !iter_env_cont in
  iter_env_cont := [];
  cont

let iter_types f = iter_env (fun env -> env.types) (fun sc -> sc.comp_types) f

let same_types env1 env2 =
  env1.types == env2.types && env1.components == env2.components

let used_persistent () =
  let r = ref Concr.empty in
  Hashtbl.iter (fun s pso -> if pso != None then r := Concr.add s !r)
    persistent_structures;
  !r

let find_all_comps proj s (p,mcomps) =
  match get_components mcomps with
    Functor_comps _ -> []
  | Structure_comps comps ->
      try let (c,n) = Tbl.find_str s (proj comps) in [Pdot(p,s,n), c]
      with Not_found -> []

let rec find_shadowed_comps path env =
  match path with
    Pident id ->
      IdTbl.find_all (Ident.name id) env.components
  | Pdot (p, s, _) ->
      let l = find_shadowed_comps p env in
      let l' =
        List.map (find_all_comps (fun comps -> comps.comp_components) s) l in
      List.flatten l'
  | Papply _ -> []

let find_shadowed proj1 proj2 path env =
  match path with
    Pident id ->
      IdTbl.find_all (Ident.name id) (proj1 env)
  | Pdot (p, s, _) ->
      let l = find_shadowed_comps p env in
      let l' = List.map (find_all_comps proj2 s) l in
      List.flatten l'
  | Papply _ -> []

let find_shadowed_types path env =
  List.map fst
    (find_shadowed
       (fun env -> env.types) (fun comps -> comps.comp_types) path env)


(* GADT instance tracking *)

let add_gadt_instance_level lv env =
  {env with
   gadt_instances = (lv, ref TypeSet.empty) :: env.gadt_instances}

let is_Tlink = function {desc = Tlink _} -> true | _ -> false

let gadt_instance_level env t =
  let rec find_instance = function
      [] -> None
    | (lv, r) :: rem ->
        if TypeSet.exists is_Tlink !r then
          (* Should we use set_typeset ? *)
          r := TypeSet.fold (fun ty -> TypeSet.add (repr ty)) !r TypeSet.empty;
        if TypeSet.mem t !r then Some lv else find_instance rem
  in find_instance env.gadt_instances

let add_gadt_instances env lv tl =
  let r =
    try List.assoc lv env.gadt_instances with Not_found -> assert false in
  (* Format.eprintf "Added";
  List.iter (fun ty -> Format.eprintf "@ %a" !Btype.print_raw ty) tl;
  Format.eprintf "@."; *)
  set_typeset r (List.fold_right TypeSet.add tl !r)

(* Only use this after expand_head! *)
let add_gadt_instance_chain env lv t =
  let r =
    try List.assoc lv env.gadt_instances with Not_found -> assert false in
  let rec add_instance t =
    let t = repr t in
    if not (TypeSet.mem t !r) then begin
      (* Format.eprintf "@ %a" !Btype.print_raw t; *)
      set_typeset r (TypeSet.add t !r);
      match t.desc with
        Tconstr (p, _, memo) ->
          may add_instance (find_expans Private p !memo)
      | _ -> ()
    end
  in
  (* Format.eprintf "Added chain"; *)
  add_instance t
  (* Format.eprintf "@." *)

(* Expand manifest module type names at the top of the given module type *)

let rec scrape_alias env ?path mty =
  match mty, path with
    Mty_ident p, _ ->
      begin try
        scrape_alias env (find_modtype_expansion p env) ?path
      with Not_found ->
        mty
      end
  | Mty_alias(_, path), _ ->
      begin try
        scrape_alias env (find_module path env).md_type ~path
      with Not_found ->
        (*Location.prerr_warning Location.none
          (Warnings.No_cmi_file (Path.name path));*)
        mty
      end
  | mty, Some path ->
      !strengthen ~aliasable:true env mty path
  | _ -> mty

let scrape_alias env mty = scrape_alias env mty

(* Given a signature and a root path, prefix all idents in the signature
   by the root path and build the corresponding substitution. *)

let rec prefix_idents root pos sub = function
    [] -> ([], sub)
  | Sig_value(id, decl) :: rem ->
      let p = Pdot(root, Ident.name id, pos) in
      let nextpos = match decl.val_kind with Val_prim _ -> pos | _ -> pos+1 in
      let (pl, final_sub) = prefix_idents root nextpos sub rem in
      (p::pl, final_sub)
  | Sig_type(id, _, _) :: rem ->
      let p = Pdot(root, Ident.name id, nopos) in
      let (pl, final_sub) =
        prefix_idents root pos (Subst.add_type id p sub) rem in
      (p::pl, final_sub)
  | Sig_typext(id, _, _) :: rem ->
      let p = Pdot(root, Ident.name id, pos) in
      (* we extend the substitution in case of an inlined record *)
      let (pl, final_sub) =
        prefix_idents root (pos+1) (Subst.add_type id p sub) rem in
      (p::pl, final_sub)
  | Sig_module(id, _, _) :: rem ->
      let p = Pdot(root, Ident.name id, pos) in
      let (pl, final_sub) =
        prefix_idents root (pos+1) (Subst.add_module id p sub) rem in
      (p::pl, final_sub)
  | Sig_modtype(id, _) :: rem ->
      let p = Pdot(root, Ident.name id, nopos) in
      let (pl, final_sub) =
        prefix_idents root pos
                      (Subst.add_modtype id (Mty_ident p) sub) rem in
      (p::pl, final_sub)
  | Sig_class(id, _, _) :: rem ->
      (* pretend this is a type, cf. PR#6650 *)
      let p = Pdot(root, Ident.name id, pos) in
      let (pl, final_sub) =
        prefix_idents root (pos + 1) (Subst.add_type id p sub) rem in
      (p::pl, final_sub)
  | Sig_class_type(id, _, _) :: rem ->
      let p = Pdot(root, Ident.name id, nopos) in
      let (pl, final_sub) =
        prefix_idents root pos (Subst.add_type id p sub) rem in
      (p::pl, final_sub)

let prefix_idents root sub sg =
  if sub = Subst.identity then
    let sgs =
      try
        Hashtbl.find prefixed_sg root
      with Not_found ->
        let sgs = ref [] in
        Hashtbl.add prefixed_sg root sgs;
        sgs
    in
    try
      List.assq sg !sgs
    with Not_found ->
      let r = prefix_idents root 0 sub sg in
      sgs := (sg, r) :: !sgs;
      r
  else
    prefix_idents root 0 sub sg

(* Compute structure descriptions *)

let add_to_tbl id decl tbl =
  let decls =
    try Tbl.find_str id tbl with Not_found -> [] in
  Tbl.add id (decl :: decls) tbl

let rec components_of_module ~deprecated ~loc env sub path mty =
  {
    deprecated;
    loc;
    comps = EnvLazy.create (env, sub, path, mty)
  }

and components_of_module_maker (env, sub, path, mty) =
  match scrape_alias env mty with
    Mty_signature sg ->
      let c =
        { comp_values = Tbl.empty;
          comp_constrs = Tbl.empty;
          comp_labels = Tbl.empty; comp_types = Tbl.empty;
          comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
          comp_components = Tbl.empty; comp_classes = Tbl.empty;
          comp_cltypes = Tbl.empty } in
      let pl, sub = prefix_idents path sub sg in
      let env = ref env in
      let pos = ref 0 in
      List.iter2 (fun item path ->
        match item with
          Sig_value(id, decl) ->
            let decl' = Subst.value_description sub decl in
            c.comp_values <-
              Tbl.add (Ident.name id) (decl', !pos) c.comp_values;
            begin match decl.val_kind with
              Val_prim _ -> () | _ -> incr pos
            end
        | Sig_type(id, decl, _) ->
            let decl' = Subst.type_declaration sub decl in
            Datarepr.set_row_name decl' (Subst.type_path sub (Path.Pident id));
            let constructors =
              List.map snd (Datarepr.constructors_of_type path decl') in
            let labels =
              List.map snd (Datarepr.labels_of_type path decl') in
            c.comp_types <-
              Tbl.add (Ident.name id)
                ((decl', (constructors, labels)), nopos)
                  c.comp_types;
            List.iter
              (fun descr ->
                c.comp_constrs <-
                  add_to_tbl descr.cstr_name descr c.comp_constrs)
              constructors;
            List.iter
              (fun descr ->
                c.comp_labels <-
                  add_to_tbl descr.lbl_name descr c.comp_labels)
              labels;
            env := store_type_infos id decl !env
        | Sig_typext(id, ext, _) ->
            let ext' = Subst.extension_constructor sub ext in
            let descr = Datarepr.extension_descr path ext' in
            c.comp_constrs <-
              add_to_tbl (Ident.name id) descr c.comp_constrs;
            incr pos
        | Sig_module(id, md, _) ->
            let md' = EnvLazy.create (sub, md) in
            c.comp_modules <-
              Tbl.add (Ident.name id) (md', !pos) c.comp_modules;
            let deprecated =
              Builtin_attributes.deprecated_of_attrs md.md_attributes
            in
            let comps =
              components_of_module ~deprecated ~loc:md.md_loc !env sub path
                md.md_type
            in
            c.comp_components <-
              Tbl.add (Ident.name id) (comps, !pos) c.comp_components;
            env := store_module ~check:false id md !env;
            incr pos
        | Sig_modtype(id, decl) ->
            let decl' = Subst.modtype_declaration sub decl in
            c.comp_modtypes <-
              Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes;
            env := store_modtype id decl !env
        | Sig_class(id, decl, _) ->
            let decl' = Subst.class_declaration sub decl in
            c.comp_classes <-
              Tbl.add (Ident.name id) (decl', !pos) c.comp_classes;
            incr pos
        | Sig_class_type(id, decl, _) ->
            let decl' = Subst.cltype_declaration sub decl in
            c.comp_cltypes <-
              Tbl.add (Ident.name id) (decl', !pos) c.comp_cltypes)
        sg pl;
        Some (Structure_comps c)
  | Mty_functor(param, ty_arg, ty_res) ->
        Some (Functor_comps {
          fcomp_param = param;
          (* fcomp_arg and fcomp_res must be prefixed eagerly, because
             they are interpreted in the outer environment *)
          fcomp_arg = may_map (Subst.modtype sub) ty_arg;
          fcomp_res = Subst.modtype sub ty_res;
          fcomp_cache = Hashtbl.create 17;
          fcomp_subst_cache = Hashtbl.create 17 })
  | Mty_ident _
  | Mty_alias _ -> None

(* Insertion of bindings by identifier + path *)

and check_usage loc id warn tbl =
  if not loc.Location.loc_ghost && Warnings.is_active (warn "") then begin
    let name = Ident.name id in
    let key = (name, loc) in
    if Hashtbl.mem tbl key then ()
    else let used = ref false in
    Hashtbl.add tbl key (fun () -> used := true);
    if not (name = "" || name.[0] = '_' || name.[0] = '#')
    then
      !add_delayed_check_forward
        (fun () -> if not !used then Location.prerr_warning loc (warn name))
  end;

and check_value_name name loc =
  (* Note: we could also check here general validity of the
     identifier, to protect against bad identifiers forged by -pp or
     -ppx preprocessors. *)
  if !Clflags.bs_only && name = "|." then raise (Error(Illegal_value_name(loc, name)))  
  else if String.length name > 0 && (name.[0] = '#') then
    for i = 1 to String.length name - 1 do
      if name.[i] = '#' then
        raise (Error(Illegal_value_name(loc, name)))
    done


and store_value ?check id decl env =
  check_value_name (Ident.name id) decl.val_loc;
  may (fun f -> check_usage decl.val_loc id f value_declarations) check;
  { env with
    values = IdTbl.add id decl env.values;
    summary = Env_value(env.summary, id, decl) }

and store_type ~check id info env =
  let loc = info.type_loc in
  if check then
    check_usage loc id (fun s -> Warnings.Unused_type_declaration s)
      type_declarations;
  let path = Pident id in
  let constructors = Datarepr.constructors_of_type path info in
  let labels = Datarepr.labels_of_type path info in
  let descrs = (List.map snd constructors, List.map snd labels) in

  if check && not loc.Location.loc_ghost &&
    Warnings.is_active (Warnings.Unused_constructor ("", false, false))
  then begin
    let ty = Ident.name id in
    List.iter
      begin fun (_, {cstr_name = c; _}) ->
        let k = (ty, loc, c) in
        if not (Hashtbl.mem used_constructors k) then
          let used = constructor_usages () in
          Hashtbl.add used_constructors k (add_constructor_usage used);
          if not (ty = "" || ty.[0] = '_')
          then !add_delayed_check_forward
              (fun () ->
                if not (is_in_signature env) && not used.cu_positive then
                  Location.prerr_warning loc
                    (Warnings.Unused_constructor
                       (c, used.cu_pattern, used.cu_privatize)))
      end
      constructors
  end;
  { env with
    constrs =
      List.fold_right
        (fun (id, descr) constrs -> TycompTbl.add id descr constrs)
        constructors
        env.constrs;
    labels =
      List.fold_right
        (fun (id, descr) labels -> TycompTbl.add id descr labels)
        labels
        env.labels;
    types =
      IdTbl.add id (info, descrs) env.types;
    summary = Env_type(env.summary, id, info) }

and store_type_infos id info env =
  (* Simplified version of store_type that doesn't compute and store
     constructor and label infos, but simply record the arity and
     manifest-ness of the type.  Used in components_of_module to
     keep track of type abbreviations (e.g. type t = float) in the
     computation of label representations. *)
  { env with
    types = IdTbl.add id (info,([],[]))
        env.types;
    summary = Env_type(env.summary, id, info) }

and store_extension ~check id ext env =
  let loc = ext.ext_loc in
  if check && not loc.Location.loc_ghost &&
    Warnings.is_active (Warnings.Unused_extension ("", false, false, false))
  then begin
    let is_exception = Path.same ext.ext_type_path Predef.path_exn in
    let ty = Path.last ext.ext_type_path in
    let n = Ident.name id in
    let k = (ty, loc, n) in
    if not (Hashtbl.mem used_constructors k) then begin
      let used = constructor_usages () in
      Hashtbl.add used_constructors k (add_constructor_usage used);
      !add_delayed_check_forward
        (fun () ->
          if not (is_in_signature env) && not used.cu_positive then
            Location.prerr_warning loc
              (Warnings.Unused_extension
                 (n, is_exception, used.cu_pattern, used.cu_privatize)
              )
        )
    end;
  end;
  { env with
    constrs = TycompTbl.add id
                (Datarepr.extension_descr (Pident id) ext)
                env.constrs;
    summary = Env_extension(env.summary, id, ext) }

and store_module ~check id md env =
  let loc = md.md_loc in
  if check then
    check_usage loc id (fun s -> Warnings.Unused_module s)
      module_declarations;

  let deprecated = Builtin_attributes.deprecated_of_attrs md.md_attributes in
  { env with
    modules = IdTbl.add id (EnvLazy.create (Subst.identity, md)) env.modules;
    components =
      IdTbl.add id
        (components_of_module ~deprecated ~loc:md.md_loc
           env Subst.identity (Pident id) md.md_type)
        env.components;
    summary = Env_module(env.summary, id, md) }

and store_modtype id info env =
  { env with
    modtypes = IdTbl.add id info env.modtypes;
    summary = Env_modtype(env.summary, id, info) }

and store_class id desc env =
  { env with
    classes = IdTbl.add id desc env.classes;
    summary = Env_class(env.summary, id, desc) }

and store_cltype id desc env =
  { env with
    cltypes = IdTbl.add id desc env.cltypes;
    summary = Env_cltype(env.summary, id, desc) }

(* Compute the components of a functor application in a path. *)

let components_of_functor_appl f env p1 p2 =
  try
    Hashtbl.find f.fcomp_cache p2
  with Not_found ->
    let p = Papply(p1, p2) in
    let sub = Subst.add_module f.fcomp_param p2 Subst.identity in
    let mty = Subst.modtype sub f.fcomp_res in
    let comps = components_of_module ~deprecated:None ~loc:Location.none
        (*???*)
        env Subst.identity p mty in
    Hashtbl.add f.fcomp_cache p2 comps;
    comps

(* Define forward functions *)

let _ =
  components_of_module' := components_of_module;
  components_of_functor_appl' := components_of_functor_appl;
  components_of_module_maker' := components_of_module_maker

(* Insertion of bindings by identifier *)

let add_functor_arg id env =
  {env with
   functor_args = Ident.add id () env.functor_args;
   summary = Env_functor_arg (env.summary, id)}

let add_value ?check id desc env =
  store_value ?check id desc env

let add_type ~check id info env =
  store_type ~check id info env

and add_extension ~check id ext env =
  store_extension ~check id ext env

and add_module_declaration ?(arg=false) ~check id md env =
  let env = store_module ~check id md env in
  if arg then add_functor_arg id env else env

and add_modtype id info env =
  store_modtype id info env

and add_class id ty env =
  store_class id ty env

and add_cltype id ty env =
  store_cltype id ty env

let add_module ?arg id mty env =
  add_module_declaration ~check:false ?arg id (md mty) env

let add_local_type path info env =
  { env with
    local_constraints = PathMap.add path info env.local_constraints }

let add_local_constraint path info elv env =
  match info with
    {type_manifest = Some _; type_newtype_level = Some (lv, _)} ->
      (* elv is the expansion level, lv is the definition level *)
      let info = {info with type_newtype_level = Some (lv, elv)} in
      add_local_type path info env
  | _ -> assert false


(* Insertion of bindings by name *)

let enter store_fun name data env =
  let id = Ident.create name in (id, store_fun id data env)

let enter_value ?check = enter (store_value ?check)
and enter_type = enter (store_type ~check:true)
and enter_extension = enter (store_extension ~check:true)
and enter_module_declaration ?arg id md env =
  add_module_declaration ?arg ~check:true id md env
  (* let (id, env) = enter store_module name md env in
  (id, add_functor_arg ?arg id env) *)
and enter_modtype = enter store_modtype
and enter_class = enter store_class
and enter_cltype = enter store_cltype

let enter_module ?arg s mty env =
  let id = Ident.create s in
  (id, enter_module_declaration ?arg id (md mty) env)

(* Insertion of all components of a signature *)

let add_item comp env =
  match comp with
    Sig_value(id, decl)     -> add_value id decl env
  | Sig_type(id, decl, _)   -> add_type ~check:false id decl env
  | Sig_typext(id, ext, _)  -> add_extension ~check:false id ext env
  | Sig_module(id, md, _)   -> add_module_declaration ~check:false id md env
  | Sig_modtype(id, decl)   -> add_modtype id decl env
  | Sig_class(id, decl, _)  -> add_class id decl env
  | Sig_class_type(id, decl, _) -> add_cltype id decl env

let rec add_signature sg env =
  match sg with
    [] -> env
  | comp :: rem -> add_signature rem (add_item comp env)

(* Open a signature path *)

let add_components slot root env0 comps =
  let add_l w comps env0 =
    TycompTbl.add_open slot w comps env0
  in

  let add w comps env0 = IdTbl.add_open slot w root comps env0 in

  let constrs =
    add_l (fun x -> `Constructor x) comps.comp_constrs env0.constrs
  in
  let labels =
    add_l (fun x -> `Label x) comps.comp_labels env0.labels
  in

  let values =
    add (fun x -> `Value x) comps.comp_values env0.values
  in
  let types =
    add (fun x -> `Type x) comps.comp_types env0.types
  in
  let modtypes =
    add (fun x -> `Module_type x) comps.comp_modtypes env0.modtypes
  in
  let classes =
    add (fun x -> `Class x) comps.comp_classes env0.classes
  in
  let cltypes =
    add (fun x -> `Class_type x) comps.comp_cltypes env0.cltypes
  in
  let components =
    add (fun x -> `Component x) comps.comp_components env0.components
  in

  let modules =
    add (fun x -> `Module x) comps.comp_modules env0.modules
  in

  { env0 with
    summary = Env_open(env0.summary, root);
    constrs;
    labels;
    values;
    types;
    modtypes;
    classes;
    cltypes;
    components;
    modules;
  }

let open_signature slot root env0 =
  match get_components (find_module_descr root env0) with
  | Functor_comps _ -> None
  | Structure_comps comps -> Some (add_components slot root env0 comps)


(* Open a signature from a file *)

let open_pers_signature name env =
  match open_signature None (Pident(Ident.create_persistent name)) env with
  | Some env -> env
  | None -> assert false (* a compilation unit cannot refer to a functor *)

let open_signature
    ?(used_slot = ref false)
    ?(loc = Location.none) ?(toplevel = false) ovf root env =
  if not toplevel && ovf = Asttypes.Fresh && not loc.Location.loc_ghost
     && (Warnings.is_active (Warnings.Unused_open "")
         || Warnings.is_active (Warnings.Open_shadow_identifier ("", ""))
         || Warnings.is_active (Warnings.Open_shadow_label_constructor ("","")))
  then begin
    let used = used_slot in
    !add_delayed_check_forward
      (fun () ->
         if not !used then begin
           used := true;
           Location.prerr_warning loc (Warnings.Unused_open (Path.name root))
         end
      );
    let shadowed = ref [] in
    let slot s b =
      begin match check_shadowing env b with
      | Some kind when not (List.mem (kind, s) !shadowed) ->
          shadowed := (kind, s) :: !shadowed;
          let w =
            match kind with
            | "label" | "constructor" ->
                Warnings.Open_shadow_label_constructor (kind, s)
            | _ -> Warnings.Open_shadow_identifier (kind, s)
          in
          Location.prerr_warning loc w
      | _ -> ()
      end;
      used := true
    in
    open_signature (Some slot) root env
  end
  else open_signature None root env

(* Read a signature from a file *)

let read_signature modname filename =
  let ps = read_pers_struct modname filename in
  Lazy.force ps.ps_sig

(* Return the CRC of the interface of the given compilation unit *)

let crc_of_unit name =
  let ps = find_pers_struct name in
  let crco =
    try
      List.assoc name ps.ps_crcs
    with Not_found ->
      assert false
  in
    match crco with
      None -> assert false
    | Some crc -> crc

(* Return the list of imported interfaces with their CRCs *)

let imports () =
   
  let dont_record_crc_unit = !Clflags.dont_record_crc_unit in 
  match dont_record_crc_unit with 
  | None -> Consistbl.extract (StringSet.elements !imported_units) crc_units
  | Some x -> 
    Consistbl.extract 
      (StringSet.fold 
      (fun m acc -> if m = x then acc else m::acc) 
      !imported_units []) crc_units

(* Returns true if [s] is an opaque imported module  *)
let is_imported_opaque s =
  StringSet.mem s !imported_opaque_units

(* Save a signature to a file *)

let save_signature_with_imports ?check_exists ~deprecated sg modname filename imports =
  (*prerr_endline filename;
  List.iter (fun (name, crc) -> prerr_endline name) imports;*)
  Btype.cleanup_abbrev ();
  Subst.reset_for_saving ();
  let sg = Subst.signature (Subst.for_saving Subst.identity) sg in
  let flags =
    List.concat [
      if !Clflags.recursive_types then [Cmi_format.Rectypes] else [];
      if !Clflags.opaque then [Cmi_format.Opaque] else [];
      (if !Clflags.unsafe_string then [Cmi_format.Unsafe_string] else []);
      (match deprecated with Some s -> [Deprecated s] | None -> []);
    ]
  in
  try
    let cmi = {
      cmi_name = modname;
      cmi_sign = sg;
      cmi_crcs = imports;
      cmi_flags = flags;
    } in
    let crc =

      create_cmi ?check_exists filename cmi in

    (* Enter signature in persistent table so that imported_unit()
       will also return its crc *)
    let comps =
      components_of_module ~deprecated ~loc:Location.none
        empty Subst.identity
        (Pident(Ident.create_persistent modname)) (Mty_signature sg) in
    let ps =
      { ps_name = modname;
        ps_sig = lazy (Subst.signature Subst.identity sg);
        ps_comps = comps;
        ps_crcs = (cmi.cmi_name, Some crc) :: imports;
        ps_filename = filename;
        ps_flags = cmi.cmi_flags;
      } in
    save_pers_struct crc ps;
    cmi
  with exn ->
    remove_file filename;
    raise exn

let save_signature ?check_exists ~deprecated sg modname filename =
  save_signature_with_imports ?check_exists ~deprecated sg modname filename (imports())

(* Folding on environments *)

let find_all proj1 proj2 f lid env acc =
  match lid with
    | None ->
      IdTbl.fold_name
        (fun name (p, data) acc -> f name p data acc)
        (proj1 env) acc
    | Some l ->
      let p, desc = lookup_module_descr l env in
      begin match get_components desc with
          Structure_comps c ->
            Tbl.fold
              (fun s (data, pos) acc -> f s (Pdot (p, s, pos)) data acc)
              (proj2 c) acc
        | Functor_comps _ ->
            acc
      end

let find_all_simple_list proj1 proj2 f lid env acc =
  match lid with
    | None ->
      TycompTbl.fold_name
        (fun data acc -> f data acc)
        (proj1 env) acc
    | Some l ->
      let (_p, desc) = lookup_module_descr l env in
      begin match get_components desc with
          Structure_comps c ->
            Tbl.fold
              (fun _s comps acc ->
                match comps with
                  [] -> acc
                | data :: _ ->
                  f data acc)
              (proj2 c) acc
        | Functor_comps _ ->
            acc
      end

let fold_modules f lid env acc =
  match lid with
    | None ->
      let acc =
        IdTbl.fold_name
          (fun name (p, data) acc ->
             let data = EnvLazy.force subst_modtype_maker data in
             f name p data acc
          )
          env.modules
          acc
      in
      Hashtbl.fold
        (fun name ps acc ->
          match ps with
              None -> acc
            | Some ps ->
              f name (Pident(Ident.create_persistent name))
                     (md (Mty_signature (Lazy.force ps.ps_sig))) acc)
        persistent_structures
        acc
    | Some l ->
      let p, desc = lookup_module_descr l env in
      begin match get_components desc with
          Structure_comps c ->
            Tbl.fold
              (fun s (data, pos) acc ->
                f s (Pdot (p, s, pos))
                    (EnvLazy.force subst_modtype_maker data) acc)
              c.comp_modules
              acc
        | Functor_comps _ ->
            acc
      end

let fold_values f =
  find_all (fun env -> env.values) (fun sc -> sc.comp_values) f
and fold_constructors f =
  find_all_simple_list (fun env -> env.constrs) (fun sc -> sc.comp_constrs) f
and fold_labels f =
  find_all_simple_list (fun env -> env.labels) (fun sc -> sc.comp_labels) f
and fold_types f =
  find_all (fun env -> env.types) (fun sc -> sc.comp_types) f
and fold_modtypes f =
  find_all (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) f
and fold_classs f =
  find_all (fun env -> env.classes) (fun sc -> sc.comp_classes) f
and fold_cltypes f =
  find_all (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) f


(* Make the initial environment *)
let (initial_safe_string, initial_unsafe_string) =
  Predef.build_initial_env
    (add_type ~check:false)
    (add_extension ~check:false)
    empty

(* Return the environment summary *)

let summary env =
  if PathMap.is_empty env.local_constraints then env.summary
  else Env_constraints (env.summary, env.local_constraints)

let last_env = ref empty
let last_reduced_env = ref empty

let keep_only_summary env =
  if !last_env == env then !last_reduced_env
  else begin
    let new_env =
      {
       empty with
       summary = env.summary;
       local_constraints = env.local_constraints;
       flags = env.flags;
      }
    in
    last_env := env;
    last_reduced_env := new_env;
    new_env
  end


let env_of_only_summary env_from_summary env =
  let new_env = env_from_summary env.summary Subst.identity in
  { new_env with
    local_constraints = env.local_constraints;
    flags = env.flags;
  }

(* Error report *)

open Format

let report_error ppf = function
  | Illegal_renaming(modname, ps_name, filename) -> fprintf ppf
      "Wrong file naming: %a@ contains the compiled interface for @ \
       %s when %s was expected"
      Location.print_filename filename ps_name modname
  | Inconsistent_import(name, source1, source2) -> fprintf ppf
      "@[<hov>The files %a@ and %a@ \
              make inconsistent assumptions@ over interface %s@]"
      Location.print_filename source1 Location.print_filename source2 name
  | Need_recursive_types(import, export) ->
      fprintf ppf
        "@[<hov>Unit %s imports from %s, which uses recursive types.@ %s@]"
        export import "The compilation flag -rectypes is required"
  | Depend_on_unsafe_string_unit(import, export) ->
      fprintf ppf
        "@[<hov>Unit %s imports from %s, compiled with -unsafe-string.@ %s@]"
        export import "This compiler has been configured in strict \
                       safe-string mode (-force-safe-string)"
  | Missing_module(_, path1, path2) ->
      fprintf ppf "@[@[<hov>";
      if Path.same path1 path2 then
        fprintf ppf "Internal path@ %s@ is dangling." (Path.name path1)
      else
        fprintf ppf "Internal path@ %s@ expands to@ %s@ which is dangling."
          (Path.name path1) (Path.name path2);
      fprintf ppf "@]@ @[%s@ %s@ %s.@]@]"
        "The compiled interface for module" (Ident.name (Path.head path2))
        "was not found"
  | Illegal_value_name(_loc, name) ->
      fprintf ppf "'%s' is not a valid value identifier."
        name

let () =
  Location.register_error_of_exn
    (function
      | Error (Missing_module (loc, _, _)
              | Illegal_value_name (loc, _)
               as err) when loc <> Location.none ->
          Some (Location.error_of_printer loc report_error err)
      | Error err -> Some (Location.error_of_printer_file report_error err)
      | _ -> None
    )

end
(** Interface as module  *)
module Annot
= struct
#1 "annot.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Data types for annotations (Stypes.ml) *)

type call = Tail | Stack | Inline;;

type ident =
  | Iref_internal of Location.t (* defining occurrence *)
  | Iref_external
  | Idef of Location.t          (* scope *)
;;

end
module Typedtree : sig 
#1 "typedtree.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Abstract syntax tree after typing *)


(** By comparison with {!Parsetree}:
    - Every {!Longindent.t} is accompanied by a resolved {!Path.t}.

*)

open Asttypes
open Types

(* Value expressions for the core language *)

type partial = Partial | Total

(** {1 Extension points} *)

type attribute = Parsetree.attribute
type attributes = attribute list

(** {1 Core language} *)

type pattern =
  { pat_desc: pattern_desc;
    pat_loc: Location.t;
    pat_extra : (pat_extra * Location.t * attributes) list;
    pat_type: type_expr;
    mutable pat_env: Env.t;
    pat_attributes: attributes;
   }

and pat_extra =
  | Tpat_constraint of core_type
        (** P : T          { pat_desc = P
                           ; pat_extra = (Tpat_constraint T, _, _) :: ... }
         *)
  | Tpat_type of Path.t * Longident.t loc
        (** #tconst        { pat_desc = disjunction
                           ; pat_extra = (Tpat_type (P, "tconst"), _, _) :: ...}

                           where [disjunction] is a [Tpat_or _] representing the
                           branches of [tconst].
         *)
  | Tpat_open of Path.t * Longident.t loc * Env.t
  | Tpat_unpack
        (** (module P)     { pat_desc  = Tpat_var "P"
                           ; pat_extra = (Tpat_unpack, _, _) :: ... }
         *)

and pattern_desc =
    Tpat_any
        (** _ *)
  | Tpat_var of Ident.t * string loc
        (** x *)
  | Tpat_alias of pattern * Ident.t * string loc
        (** P as a *)
  | Tpat_constant of constant
        (** 1, 'a', "true", 1.0, 1l, 1L, 1n *)
  | Tpat_tuple of pattern list
        (** (P1, ..., Pn)

            Invariant: n >= 2
         *)
  | Tpat_construct of
      Longident.t loc * constructor_description * pattern list
        (** C                []
            C P              [P]
            C (P1, ..., Pn)  [P1; ...; Pn]
          *)
  | Tpat_variant of label * pattern option * row_desc ref
        (** `A             (None)
            `A P           (Some P)

            See {!Types.row_desc} for an explanation of the last parameter.
         *)
  | Tpat_record of
      (Longident.t loc * label_description * pattern) list *
        closed_flag
        (** { l1=P1; ...; ln=Pn }     (flag = Closed)
            { l1=P1; ...; ln=Pn; _}   (flag = Open)

            Invariant: n > 0
         *)
  | Tpat_array of pattern list
        (** [| P1; ...; Pn |] *)
  | Tpat_or of pattern * pattern * row_desc option
        (** P1 | P2

            [row_desc] = [Some _] when translating [Ppat_type _],
                         [None] otherwise.
         *)
  | Tpat_lazy of pattern
        (** lazy P *)

and expression =
  { exp_desc: expression_desc;
    exp_loc: Location.t;
    exp_extra: (exp_extra * Location.t * attributes) list;
    exp_type: type_expr;
    exp_env: Env.t;
    exp_attributes: attributes;
   }

and exp_extra =
  | Texp_constraint of core_type
        (** E : T *)
  | Texp_coerce of core_type option * core_type
        (** E :> T           [Texp_coerce (None, T)]
            E : T0 :> T      [Texp_coerce (Some T0, T)]
         *)
  | Texp_open of override_flag * Path.t * Longident.t loc * Env.t
        (** let open[!] M in    [Texp_open (!, P, M, env)]
                                where [env] is the environment after opening [P]
         *)
  | Texp_poly of core_type option
        (** Used for method bodies. *)
  | Texp_newtype of string
        (** fun (type t) ->  *)

and expression_desc =
    Texp_ident of Path.t * Longident.t loc * Types.value_description
        (** x
            M.x
         *)
  | Texp_constant of constant
        (** 1, 'a', "true", 1.0, 1l, 1L, 1n *)
  | Texp_let of rec_flag * value_binding list * expression
        (** let P1 = E1 and ... and Pn = EN in E       (flag = Nonrecursive)
            let rec P1 = E1 and ... and Pn = EN in E   (flag = Recursive)
         *)
  | Texp_function of { arg_label : arg_label; param : Ident.t;
      cases : case list; partial : partial; }
        (** [Pexp_fun] and [Pexp_function] both translate to [Texp_function].
            See {!Parsetree} for more details.

            [param] is the identifier that is to be used to name the
            parameter of the function.

            partial =
              [Partial] if the pattern match is partial
              [Total] otherwise.
         *)
  | Texp_apply of expression * (arg_label * expression option) list
        (** E0 ~l1:E1 ... ~ln:En

            The expression can be None if the expression is abstracted over
            this argument. It currently appears when a label is applied.

            For example:
            let f x ~y = x + y in
            f ~y:3

            The resulting typedtree for the application is:
            Texp_apply (Texp_ident "f/1037",
                        [(Nolabel, None);
                         (Labelled "y", Some (Texp_constant Const_int 3))
                        ])
         *)
  | Texp_match of expression * case list * case list * partial
        (** match E0 with
            | P1 -> E1
            | P2 -> E2
            | exception P3 -> E3

            [Texp_match (E0, [(P1, E1); (P2, E2)], [(P3, E3)], _)]
         *)
  | Texp_try of expression * case list
        (** try E with P1 -> E1 | ... | PN -> EN *)
  | Texp_tuple of expression list
        (** (E1, ..., EN) *)
  | Texp_construct of
      Longident.t loc * constructor_description * expression list
        (** C                []
            C E              [E]
            C (E1, ..., En)  [E1;...;En]
         *)
  | Texp_variant of label * expression option
  | Texp_record of {
      fields : ( Types.label_description * record_label_definition ) array;
      representation : Types.record_representation;
      extended_expression : expression option;
    }
        (** { l1=P1; ...; ln=Pn }           (extended_expression = None)
            { E0 with l1=P1; ...; ln=Pn }   (extended_expression = Some E0)

            Invariant: n > 0

            If the type is { l1: t1; l2: t2 }, the expression
            { E0 with t2=P2 } is represented as
            Texp_record
              { fields = [| l1, Kept t1; l2 Override P2 |]; representation;
                extended_expression = Some E0 }
        *)
  | Texp_field of expression * Longident.t loc * label_description
  | Texp_setfield of
      expression * Longident.t loc * label_description * expression
  | Texp_array of expression list
  | Texp_ifthenelse of expression * expression * expression option
  | Texp_sequence of expression * expression
  | Texp_while of expression * expression
  | Texp_for of
      Ident.t * Parsetree.pattern * expression * expression * direction_flag *
        expression
  | Texp_send of expression * meth * expression option
  | Texp_new of Path.t * Longident.t loc * Types.class_declaration
  | Texp_instvar of Path.t * Path.t * string loc
  | Texp_setinstvar of Path.t * Path.t * string loc * expression
  | Texp_override of Path.t * (Path.t * string loc * expression) list
  | Texp_letmodule of Ident.t * string loc * module_expr * expression
  | Texp_letexception of extension_constructor * expression
  | Texp_assert of expression
  | Texp_lazy of expression
  | Texp_object of class_structure * string list
  | Texp_pack of module_expr
  | Texp_unreachable
  | Texp_extension_constructor of Longident.t loc * Path.t

and meth =
    Tmeth_name of string
  | Tmeth_val of Ident.t

and case =
    {
     c_lhs: pattern;
     c_guard: expression option;
     c_rhs: expression;
    }

and record_label_definition =
  | Kept of Types.type_expr
  | Overridden of Longident.t loc * expression

(* Value expressions for the class language *)

and class_expr =
    {
     cl_desc: class_expr_desc;
     cl_loc: Location.t;
     cl_type: Types.class_type;
     cl_env: Env.t;
     cl_attributes: attributes;
    }

and class_expr_desc =
    Tcl_ident of Path.t * Longident.t loc * core_type list
  | Tcl_structure of class_structure
  | Tcl_fun of
      arg_label * pattern * (Ident.t * string loc * expression) list
      * class_expr * partial
  | Tcl_apply of class_expr * (arg_label * expression option) list
  | Tcl_let of rec_flag * value_binding list *
                  (Ident.t * string loc * expression) list * class_expr
  | Tcl_constraint of
      class_expr * class_type option * string list * string list * Concr.t
  (* Visible instance variables, methods and concrete methods *)
  | Tcl_open of override_flag * Path.t * Longident.t loc * Env.t * class_expr

and class_structure =
  {
   cstr_self: pattern;
   cstr_fields: class_field list;
   cstr_type: Types.class_signature;
   cstr_meths: Ident.t Meths.t;
  }

and class_field =
   {
    cf_desc: class_field_desc;
    cf_loc: Location.t;
    cf_attributes: attributes;
  }

and class_field_kind =
  | Tcfk_virtual of core_type
  | Tcfk_concrete of override_flag * expression

and class_field_desc =
    Tcf_inherit of
      override_flag * class_expr * string option * (string * Ident.t) list *
        (string * Ident.t) list
    (* Inherited instance variables and concrete methods *)
  | Tcf_val of string loc * mutable_flag * Ident.t * class_field_kind * bool
  | Tcf_method of string loc * private_flag * class_field_kind
  | Tcf_constraint of core_type * core_type
  | Tcf_initializer of expression
  | Tcf_attribute of attribute

(* Value expressions for the module language *)

and module_expr =
  { mod_desc: module_expr_desc;
    mod_loc: Location.t;
    mod_type: Types.module_type;
    mod_env: Env.t;
    mod_attributes: attributes;
   }

(** Annotations for [Tmod_constraint]. *)
and module_type_constraint =
  | Tmodtype_implicit
  (** The module type constraint has been synthesized during typechecking. *)
  | Tmodtype_explicit of module_type
  (** The module type was in the source file. *)

and module_expr_desc =
    Tmod_ident of Path.t * Longident.t loc
  | Tmod_structure of structure
  | Tmod_functor of Ident.t * string loc * module_type option * module_expr
  | Tmod_apply of module_expr * module_expr * module_coercion
  | Tmod_constraint of
      module_expr * Types.module_type * module_type_constraint * module_coercion
    (** ME          (constraint = Tmodtype_implicit)
        (ME : MT)   (constraint = Tmodtype_explicit MT)
     *)
  | Tmod_unpack of expression * Types.module_type

and structure = {
  str_items : structure_item list;
  str_type : Types.signature;
  str_final_env : Env.t;
}

and structure_item =
  { str_desc : structure_item_desc;
    str_loc : Location.t;
    str_env : Env.t
  }

and structure_item_desc =
    Tstr_eval of expression * attributes
  | Tstr_value of rec_flag * value_binding list
  | Tstr_primitive of value_description
  | Tstr_type of rec_flag * type_declaration list
  | Tstr_typext of type_extension
  | Tstr_exception of extension_constructor
  | Tstr_module of module_binding
  | Tstr_recmodule of module_binding list
  | Tstr_modtype of module_type_declaration
  | Tstr_open of open_description
  | Tstr_class of (class_declaration * string list) list
  | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list
  | Tstr_include of include_declaration
  | Tstr_attribute of attribute

and module_binding =
    {
     mb_id: Ident.t;
     mb_name: string loc;
     mb_expr: module_expr;
     mb_attributes: attributes;
     mb_loc: Location.t;
    }

and value_binding =
  {
    vb_pat: pattern;
    vb_expr: expression;
    vb_attributes: attributes;
    vb_loc: Location.t;
  }

and module_coercion =
    Tcoerce_none
  | Tcoerce_structure of (int * module_coercion) list *
                         (Ident.t * int * module_coercion) list
  | Tcoerce_functor of module_coercion * module_coercion
  | Tcoerce_primitive of primitive_coercion
  | Tcoerce_alias of Path.t * module_coercion

and module_type =
  { mty_desc: module_type_desc;
    mty_type : Types.module_type;
    mty_env : Env.t;
    mty_loc: Location.t;
    mty_attributes: attributes;
   }

and module_type_desc =
    Tmty_ident of Path.t * Longident.t loc
  | Tmty_signature of signature
  | Tmty_functor of Ident.t * string loc * module_type option * module_type
  | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list
  | Tmty_typeof of module_expr
  | Tmty_alias of Path.t * Longident.t loc

and primitive_coercion =
  {
    pc_desc: Primitive.description;
    pc_type: type_expr;
    pc_env: Env.t;
    pc_loc : Location.t;
     
    pc_id : Ident.t;
    
  }

and signature = {
  sig_items : signature_item list;
  sig_type : Types.signature;
  sig_final_env : Env.t;
}

and signature_item =
  { sig_desc: signature_item_desc;
    sig_env : Env.t; (* BINANNOT ADDED *)
    sig_loc: Location.t }

and signature_item_desc =
    Tsig_value of value_description
  | Tsig_type of rec_flag * type_declaration list
  | Tsig_typext of type_extension
  | Tsig_exception of extension_constructor
  | Tsig_module of module_declaration
  | Tsig_recmodule of module_declaration list
  | Tsig_modtype of module_type_declaration
  | Tsig_open of open_description
  | Tsig_include of include_description
  | Tsig_class of class_description list
  | Tsig_class_type of class_type_declaration list
  | Tsig_attribute of attribute

and module_declaration =
    {
     md_id: Ident.t;
     md_name: string loc;
     md_type: module_type;
     md_attributes: attributes;
     md_loc: Location.t;
    }

and module_type_declaration =
    {
     mtd_id: Ident.t;
     mtd_name: string loc;
     mtd_type: module_type option;
     mtd_attributes: attributes;
     mtd_loc: Location.t;
    }

and open_description =
    {
     open_path: Path.t;
     open_txt: Longident.t loc;
     open_override: override_flag;
     open_loc: Location.t;
     open_attributes: attribute list;
    }

and 'a include_infos =
    {
     incl_mod: 'a;
     incl_type: Types.signature;
     incl_loc: Location.t;
     incl_attributes: attribute list;
    }

and include_description = module_type include_infos

and include_declaration = module_expr include_infos

and with_constraint =
    Twith_type of type_declaration
  | Twith_module of Path.t * Longident.t loc
  | Twith_typesubst of type_declaration
  | Twith_modsubst of Path.t * Longident.t loc

and core_type =
  { mutable ctyp_desc : core_type_desc;
      (** mutable because of [Typeclass.declare_method] *)
    mutable ctyp_type : type_expr;
      (** mutable because of [Typeclass.declare_method] *)
    ctyp_env : Env.t; (* BINANNOT ADDED *)
    ctyp_loc : Location.t;
    ctyp_attributes: attributes;
   }

and core_type_desc =
    Ttyp_any
  | Ttyp_var of string
  | Ttyp_arrow of arg_label * core_type * core_type
  | Ttyp_tuple of core_type list
  | Ttyp_constr of Path.t * Longident.t loc * core_type list
  | Ttyp_object of object_field list * closed_flag
  | Ttyp_class of Path.t * Longident.t loc * core_type list
  | Ttyp_alias of core_type * string
  | Ttyp_variant of row_field list * closed_flag * label list option
  | Ttyp_poly of string list * core_type
  | Ttyp_package of package_type

and package_type = {
  pack_path : Path.t;
  pack_fields : (Longident.t loc * core_type) list;
  pack_type : Types.module_type;
  pack_txt : Longident.t loc;
}

and row_field =
    Ttag of string loc * attributes * bool * core_type list
  | Tinherit of core_type

and object_field =
  | OTtag of string loc * attributes * core_type
  | OTinherit of core_type

and value_description =
  { val_id: Ident.t;
    val_name: string loc;
    val_desc: core_type;
    val_val: Types.value_description;
    val_prim: string list;
    val_loc: Location.t;
    val_attributes: attributes;
    }

and type_declaration =
  {
    typ_id: Ident.t;
    typ_name: string loc;
    typ_params: (core_type * variance) list;
    typ_type: Types.type_declaration;
    typ_cstrs: (core_type * core_type * Location.t) list;
    typ_kind: type_kind;
    typ_private: private_flag;
    typ_manifest: core_type option;
    typ_loc: Location.t;
    typ_attributes: attributes;
   }

and type_kind =
    Ttype_abstract
  | Ttype_variant of constructor_declaration list
  | Ttype_record of label_declaration list
  | Ttype_open

and label_declaration =
    {
     ld_id: Ident.t;
     ld_name: string loc;
     ld_mutable: mutable_flag;
     ld_type: core_type;
     ld_loc: Location.t;
     ld_attributes: attributes;
    }

and constructor_declaration =
    {
     cd_id: Ident.t;
     cd_name: string loc;
     cd_args: constructor_arguments;
     cd_res: core_type option;
     cd_loc: Location.t;
     cd_attributes: attributes;
    }

and constructor_arguments =
  | Cstr_tuple of core_type list
  | Cstr_record of label_declaration list

and type_extension =
  {
    tyext_path: Path.t;
    tyext_txt: Longident.t loc;
    tyext_params: (core_type * variance) list;
    tyext_constructors: extension_constructor list;
    tyext_private: private_flag;
    tyext_attributes: attributes;
  }

and extension_constructor =
  {
    ext_id: Ident.t;
    ext_name: string loc;
    ext_type : Types.extension_constructor;
    ext_kind : extension_constructor_kind;
    ext_loc : Location.t;
    ext_attributes: attributes;
  }

and extension_constructor_kind =
    Text_decl of constructor_arguments * core_type option
  | Text_rebind of Path.t * Longident.t loc

and class_type =
    {
     cltyp_desc: class_type_desc;
     cltyp_type: Types.class_type;
     cltyp_env: Env.t;
     cltyp_loc: Location.t;
     cltyp_attributes: attributes;
    }

and class_type_desc =
    Tcty_constr of Path.t * Longident.t loc * core_type list
  | Tcty_signature of class_signature
  | Tcty_arrow of arg_label * core_type * class_type
  | Tcty_open of override_flag * Path.t * Longident.t loc * Env.t * class_type

and class_signature = {
    csig_self : core_type;
    csig_fields : class_type_field list;
    csig_type : Types.class_signature;
  }

and class_type_field = {
    ctf_desc: class_type_field_desc;
    ctf_loc: Location.t;
    ctf_attributes: attributes;
  }

and class_type_field_desc =
  | Tctf_inherit of class_type
  | Tctf_val of (string * mutable_flag * virtual_flag * core_type)
  | Tctf_method of (string * private_flag * virtual_flag * core_type)
  | Tctf_constraint of (core_type * core_type)
  | Tctf_attribute of attribute

and class_declaration =
  class_expr class_infos

and class_description =
  class_type class_infos

and class_type_declaration =
  class_type class_infos

and 'a class_infos =
  { ci_virt: virtual_flag;
    ci_params: (core_type * variance) list;
    ci_id_name : string loc;
    ci_id_class: Ident.t;
    ci_id_class_type : Ident.t;
    ci_id_object : Ident.t;
    ci_id_typehash : Ident.t;
    ci_expr: 'a;
    ci_decl: Types.class_declaration;
    ci_type_decl : Types.class_type_declaration;
    ci_loc: Location.t;
    ci_attributes: attributes;
   }

(* Auxiliary functions over the a.s.t. *)

val iter_pattern_desc: (pattern -> unit) -> pattern_desc -> unit
val map_pattern_desc: (pattern -> pattern) -> pattern_desc -> pattern_desc

val let_bound_idents: value_binding list -> Ident.t list
val rev_let_bound_idents: value_binding list -> Ident.t list

val let_bound_idents_with_loc:
    value_binding list -> (Ident.t * string loc) list

(** Alpha conversion of patterns *)
val alpha_pat: (Ident.t * Ident.t) list -> pattern -> pattern

val mknoloc: 'a -> 'a Asttypes.loc
val mkloc: 'a -> Location.t -> 'a Asttypes.loc

val pat_bound_idents: pattern -> Ident.t list

end = struct
#1 "typedtree.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Abstract syntax tree after typing *)

open Misc
open Asttypes
open Types

(* Value expressions for the core language *)

type partial = Partial | Total

type attribute = Parsetree.attribute
type attributes = attribute list

type pattern =
  { pat_desc: pattern_desc;
    pat_loc: Location.t;
    pat_extra : (pat_extra * Location.t * attribute list) list;
    pat_type: type_expr;
    mutable pat_env: Env.t;
    pat_attributes: attribute list;
   }

and pat_extra =
  | Tpat_constraint of core_type
  | Tpat_type of Path.t * Longident.t loc
  | Tpat_open of Path.t * Longident.t loc * Env.t
  | Tpat_unpack

and pattern_desc =
    Tpat_any
  | Tpat_var of Ident.t * string loc
  | Tpat_alias of pattern * Ident.t * string loc
  | Tpat_constant of constant
  | Tpat_tuple of pattern list
  | Tpat_construct of
      Longident.t loc * constructor_description * pattern list
  | Tpat_variant of label * pattern option * row_desc ref
  | Tpat_record of
      (Longident.t loc * label_description * pattern) list *
        closed_flag
  | Tpat_array of pattern list
  | Tpat_or of pattern * pattern * row_desc option
  | Tpat_lazy of pattern

and expression =
  { exp_desc: expression_desc;
    exp_loc: Location.t;
    exp_extra: (exp_extra * Location.t * attribute list) list;
    exp_type: type_expr;
    exp_env: Env.t;
    exp_attributes: attribute list;
   }

and exp_extra =
  | Texp_constraint of core_type
  | Texp_coerce of core_type option * core_type
  | Texp_open of override_flag * Path.t * Longident.t loc * Env.t
  | Texp_poly of core_type option
  | Texp_newtype of string

and expression_desc =
    Texp_ident of Path.t * Longident.t loc * Types.value_description
  | Texp_constant of constant
  | Texp_let of rec_flag * value_binding list * expression
  | Texp_function of { arg_label : arg_label; param : Ident.t;
      cases : case list; partial : partial; }
  | Texp_apply of expression * (arg_label * expression option) list
  | Texp_match of expression * case list * case list * partial
  | Texp_try of expression * case list
  | Texp_tuple of expression list
  | Texp_construct of
      Longident.t loc * constructor_description * expression list
  | Texp_variant of label * expression option
  | Texp_record of {
      fields : ( Types.label_description * record_label_definition ) array;
      representation : Types.record_representation;
      extended_expression : expression option;
    }
  | Texp_field of expression * Longident.t loc * label_description
  | Texp_setfield of
      expression * Longident.t loc * label_description * expression
  | Texp_array of expression list
  | Texp_ifthenelse of expression * expression * expression option
  | Texp_sequence of expression * expression
  | Texp_while of expression * expression
  | Texp_for of
      Ident.t * Parsetree.pattern * expression * expression * direction_flag *
        expression
  | Texp_send of expression * meth * expression option
  | Texp_new of Path.t * Longident.t loc * Types.class_declaration
  | Texp_instvar of Path.t * Path.t * string loc
  | Texp_setinstvar of Path.t * Path.t * string loc * expression
  | Texp_override of Path.t * (Path.t * string loc * expression) list
  | Texp_letmodule of Ident.t * string loc * module_expr * expression
  | Texp_letexception of extension_constructor * expression
  | Texp_assert of expression
  | Texp_lazy of expression
  | Texp_object of class_structure * string list
  | Texp_pack of module_expr
  | Texp_unreachable
  | Texp_extension_constructor of Longident.t loc * Path.t

and meth =
    Tmeth_name of string
  | Tmeth_val of Ident.t

and case =
    {
     c_lhs: pattern;
     c_guard: expression option;
     c_rhs: expression;
    }

and record_label_definition =
  | Kept of Types.type_expr
  | Overridden of Longident.t loc * expression

(* Value expressions for the class language *)

and class_expr =
    {
     cl_desc: class_expr_desc;
     cl_loc: Location.t;
     cl_type: Types.class_type;
     cl_env: Env.t;
     cl_attributes: attribute list;
    }

and class_expr_desc =
    Tcl_ident of Path.t * Longident.t loc * core_type list
  | Tcl_structure of class_structure
  | Tcl_fun of
      arg_label * pattern * (Ident.t * string loc * expression) list
      * class_expr * partial
  | Tcl_apply of class_expr * (arg_label * expression option) list
  | Tcl_let of rec_flag * value_binding list *
                  (Ident.t * string loc * expression) list * class_expr
  | Tcl_constraint of
      class_expr * class_type option * string list * string list * Concr.t
    (* Visible instance variables, methods and concrete methods *)
  | Tcl_open of override_flag * Path.t * Longident.t loc * Env.t * class_expr

and class_structure =
  {
   cstr_self: pattern;
   cstr_fields: class_field list;
   cstr_type: Types.class_signature;
   cstr_meths: Ident.t Meths.t;
  }

and class_field =
   {
    cf_desc: class_field_desc;
    cf_loc: Location.t;
    cf_attributes: attribute list;
  }

and class_field_kind =
  | Tcfk_virtual of core_type
  | Tcfk_concrete of override_flag * expression

and class_field_desc =
    Tcf_inherit of
      override_flag * class_expr * string option * (string * Ident.t) list *
        (string * Ident.t) list
    (* Inherited instance variables and concrete methods *)
  | Tcf_val of string loc * mutable_flag * Ident.t * class_field_kind * bool
  | Tcf_method of string loc * private_flag * class_field_kind
  | Tcf_constraint of core_type * core_type
  | Tcf_initializer of expression
  | Tcf_attribute of attribute

(* Value expressions for the module language *)

and module_expr =
  { mod_desc: module_expr_desc;
    mod_loc: Location.t;
    mod_type: Types.module_type;
    mod_env: Env.t;
    mod_attributes: attribute list;
   }

and module_type_constraint =
  Tmodtype_implicit
| Tmodtype_explicit of module_type

and module_expr_desc =
    Tmod_ident of Path.t * Longident.t loc
  | Tmod_structure of structure
  | Tmod_functor of Ident.t * string loc * module_type option * module_expr
  | Tmod_apply of module_expr * module_expr * module_coercion
  | Tmod_constraint of
      module_expr * Types.module_type * module_type_constraint * module_coercion
  | Tmod_unpack of expression * Types.module_type

and structure = {
  str_items : structure_item list;
  str_type : Types.signature;
  str_final_env : Env.t;
}

and structure_item =
  { str_desc : structure_item_desc;
    str_loc : Location.t;
    str_env : Env.t
  }

and structure_item_desc =
    Tstr_eval of expression * attributes
  | Tstr_value of rec_flag * value_binding list
  | Tstr_primitive of value_description
  | Tstr_type of rec_flag * type_declaration list
  | Tstr_typext of type_extension
  | Tstr_exception of extension_constructor
  | Tstr_module of module_binding
  | Tstr_recmodule of module_binding list
  | Tstr_modtype of module_type_declaration
  | Tstr_open of open_description
  | Tstr_class of (class_declaration * string list) list
  | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list
  | Tstr_include of include_declaration
  | Tstr_attribute of attribute

and module_binding =
    {
     mb_id: Ident.t;
     mb_name: string loc;
     mb_expr: module_expr;
     mb_attributes: attribute list;
     mb_loc: Location.t;
    }

and value_binding =
  {
    vb_pat: pattern;
    vb_expr: expression;
    vb_attributes: attributes;
    vb_loc: Location.t;
  }

and module_coercion =
    Tcoerce_none
  | Tcoerce_structure of (int * module_coercion) list *
                         (Ident.t * int * module_coercion) list
  | Tcoerce_functor of module_coercion * module_coercion
  | Tcoerce_primitive of primitive_coercion
  | Tcoerce_alias of Path.t * module_coercion

and module_type =
  { mty_desc: module_type_desc;
    mty_type : Types.module_type;
    mty_env : Env.t;
    mty_loc: Location.t;
    mty_attributes: attribute list;
   }

and module_type_desc =
    Tmty_ident of Path.t * Longident.t loc
  | Tmty_signature of signature
  | Tmty_functor of Ident.t * string loc * module_type option * module_type
  | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list
  | Tmty_typeof of module_expr
  | Tmty_alias of Path.t * Longident.t loc

(* Keep primitive type information for type-based lambda-code specialization *)
and primitive_coercion =
  {
    pc_desc: Primitive.description;
    pc_type: type_expr;
    pc_env: Env.t;
    pc_loc : Location.t;
     
    pc_id : Ident.t;

  }

and signature = {
  sig_items : signature_item list;
  sig_type : Types.signature;
  sig_final_env : Env.t;
}

and signature_item =
  { sig_desc: signature_item_desc;
    sig_env : Env.t; (* BINANNOT ADDED *)
    sig_loc: Location.t }

and signature_item_desc =
    Tsig_value of value_description
  | Tsig_type of rec_flag * type_declaration list
  | Tsig_typext of type_extension
  | Tsig_exception of extension_constructor
  | Tsig_module of module_declaration
  | Tsig_recmodule of module_declaration list
  | Tsig_modtype of module_type_declaration
  | Tsig_open of open_description
  | Tsig_include of include_description
  | Tsig_class of class_description list
  | Tsig_class_type of class_type_declaration list
  | Tsig_attribute of attribute

and module_declaration =
    {
     md_id: Ident.t;
     md_name: string loc;
     md_type: module_type;
     md_attributes: attribute list;
     md_loc: Location.t;
    }

and module_type_declaration =
    {
     mtd_id: Ident.t;
     mtd_name: string loc;
     mtd_type: module_type option;
     mtd_attributes: attribute list;
     mtd_loc: Location.t;
    }

and open_description =
    {
     open_path: Path.t;
     open_txt: Longident.t loc;
     open_override: override_flag;
     open_loc: Location.t;
     open_attributes: attribute list;
    }

and 'a include_infos =
    {
     incl_mod: 'a;
     incl_type: Types.signature;
     incl_loc: Location.t;
     incl_attributes: attribute list;
    }

and include_description = module_type include_infos

and include_declaration = module_expr include_infos

and with_constraint =
    Twith_type of type_declaration
  | Twith_module of Path.t * Longident.t loc
  | Twith_typesubst of type_declaration
  | Twith_modsubst of Path.t * Longident.t loc

and core_type =
(* mutable because of [Typeclass.declare_method] *)
  { mutable ctyp_desc : core_type_desc;
    mutable ctyp_type : type_expr;
    ctyp_env : Env.t; (* BINANNOT ADDED *)
    ctyp_loc : Location.t;
    ctyp_attributes: attribute list;
   }

and core_type_desc =
    Ttyp_any
  | Ttyp_var of string
  | Ttyp_arrow of arg_label * core_type * core_type
  | Ttyp_tuple of core_type list
  | Ttyp_constr of Path.t * Longident.t loc * core_type list
  | Ttyp_object of object_field list * closed_flag
  | Ttyp_class of Path.t * Longident.t loc * core_type list
  | Ttyp_alias of core_type * string
  | Ttyp_variant of row_field list * closed_flag * label list option
  | Ttyp_poly of string list * core_type
  | Ttyp_package of package_type

and package_type = {
  pack_path : Path.t;
  pack_fields : (Longident.t loc * core_type) list;
  pack_type : Types.module_type;
  pack_txt : Longident.t loc;
}

and row_field =
    Ttag of string loc * attributes * bool * core_type list
  | Tinherit of core_type

and object_field =
  | OTtag of string loc * attributes * core_type
  | OTinherit of core_type

and value_description =
  { val_id: Ident.t;
    val_name: string loc;
    val_desc: core_type;
    val_val: Types.value_description;
    val_prim: string list;
    val_loc: Location.t;
    val_attributes: attribute list;
    }

and type_declaration =
  { typ_id: Ident.t;
    typ_name: string loc;
    typ_params: (core_type * variance) list;
    typ_type: Types.type_declaration;
    typ_cstrs: (core_type * core_type * Location.t) list;
    typ_kind: type_kind;
    typ_private: private_flag;
    typ_manifest: core_type option;
    typ_loc: Location.t;
    typ_attributes: attribute list;
   }

and type_kind =
    Ttype_abstract
  | Ttype_variant of constructor_declaration list
  | Ttype_record of label_declaration list
  | Ttype_open

and label_declaration =
    {
     ld_id: Ident.t;
     ld_name: string loc;
     ld_mutable: mutable_flag;
     ld_type: core_type;
     ld_loc: Location.t;
     ld_attributes: attribute list;
    }

and constructor_declaration =
    {
     cd_id: Ident.t;
     cd_name: string loc;
     cd_args: constructor_arguments;
     cd_res: core_type option;
     cd_loc: Location.t;
     cd_attributes: attribute list;
    }

and constructor_arguments =
  | Cstr_tuple of core_type list
  | Cstr_record of label_declaration list

and type_extension =
  {
    tyext_path: Path.t;
    tyext_txt: Longident.t loc;
    tyext_params: (core_type * variance) list;
    tyext_constructors: extension_constructor list;
    tyext_private: private_flag;
    tyext_attributes: attribute list;
  }

and extension_constructor =
  {
    ext_id: Ident.t;
    ext_name: string loc;
    ext_type: Types.extension_constructor;
    ext_kind: extension_constructor_kind;
    ext_loc: Location.t;
    ext_attributes: attribute list;
  }

and extension_constructor_kind =
    Text_decl of constructor_arguments * core_type option
  | Text_rebind of Path.t * Longident.t loc

and class_type =
    {
     cltyp_desc: class_type_desc;
     cltyp_type: Types.class_type;
     cltyp_env: Env.t;
     cltyp_loc: Location.t;
     cltyp_attributes: attribute list;
    }

and class_type_desc =
    Tcty_constr of Path.t * Longident.t loc * core_type list
  | Tcty_signature of class_signature
  | Tcty_arrow of arg_label * core_type * class_type
  | Tcty_open of override_flag * Path.t * Longident.t loc * Env.t * class_type

and class_signature = {
    csig_self: core_type;
    csig_fields: class_type_field list;
    csig_type: Types.class_signature;
  }

and class_type_field = {
    ctf_desc: class_type_field_desc;
    ctf_loc: Location.t;
    ctf_attributes: attribute list;
  }

and class_type_field_desc =
  | Tctf_inherit of class_type
  | Tctf_val of (string * mutable_flag * virtual_flag * core_type)
  | Tctf_method of (string * private_flag * virtual_flag * core_type)
  | Tctf_constraint of (core_type * core_type)
  | Tctf_attribute of attribute

and class_declaration =
  class_expr class_infos

and class_description =
  class_type class_infos

and class_type_declaration =
  class_type class_infos

and 'a class_infos =
  { ci_virt: virtual_flag;
    ci_params: (core_type * variance) list;
    ci_id_name: string loc;
    ci_id_class: Ident.t;
    ci_id_class_type: Ident.t;
    ci_id_object: Ident.t;
    ci_id_typehash: Ident.t;
    ci_expr: 'a;
    ci_decl: Types.class_declaration;
    ci_type_decl: Types.class_type_declaration;
    ci_loc: Location.t;
    ci_attributes: attribute list;
   }

(* Auxiliary functions over the a.s.t. *)

let iter_pattern_desc f = function
  | Tpat_alias(p, _, _) -> f p
  | Tpat_tuple patl -> List.iter f patl
  | Tpat_construct(_, _, patl) -> List.iter f patl
  | Tpat_variant(_, pat, _) -> may f pat
  | Tpat_record (lbl_pat_list, _) ->
      List.iter (fun (_, _, pat) -> f pat) lbl_pat_list
  | Tpat_array patl -> List.iter f patl
  | Tpat_or(p1, p2, _) -> f p1; f p2
  | Tpat_lazy p -> f p
  | Tpat_any
  | Tpat_var _
  | Tpat_constant _ -> ()

let map_pattern_desc f d =
  match d with
  | Tpat_alias (p1, id, s) ->
      Tpat_alias (f p1, id, s)
  | Tpat_tuple pats ->
      Tpat_tuple (List.map f pats)
  | Tpat_record (lpats, closed) ->
      Tpat_record (List.map (fun (lid, l,p) -> lid, l, f p) lpats, closed)
  | Tpat_construct (lid, c,pats) ->
      Tpat_construct (lid, c, List.map f pats)
  | Tpat_array pats ->
      Tpat_array (List.map f pats)
  | Tpat_lazy p1 -> Tpat_lazy (f p1)
  | Tpat_variant (x1, Some p1, x2) ->
      Tpat_variant (x1, Some (f p1), x2)
  | Tpat_or (p1,p2,path) ->
      Tpat_or (f p1, f p2, path)
  | Tpat_var _
  | Tpat_constant _
  | Tpat_any
  | Tpat_variant (_,None,_) -> d

(* List the identifiers bound by a pattern or a let *)

let idents = ref([]: (Ident.t * string loc) list)

let rec bound_idents pat =
  match pat.pat_desc with
  | Tpat_var (id,s) -> idents := (id,s) :: !idents
  | Tpat_alias(p, id, s ) ->
      bound_idents p; idents := (id,s) :: !idents
  | Tpat_or(p1, _, _) ->
      (* Invariant : both arguments binds the same variables *)
      bound_idents p1
  | d -> iter_pattern_desc bound_idents d

let pat_bound_idents pat =
  idents := [];
  bound_idents pat;
  let res = !idents in
  idents := [];
  List.map fst res

let rev_let_bound_idents_with_loc bindings =
  idents := [];
  List.iter (fun vb -> bound_idents vb.vb_pat) bindings;
  let res = !idents in idents := []; res

let let_bound_idents_with_loc pat_expr_list =
  List.rev(rev_let_bound_idents_with_loc pat_expr_list)

let rev_let_bound_idents pat = List.map fst (rev_let_bound_idents_with_loc pat)
let let_bound_idents pat = List.map  fst (let_bound_idents_with_loc pat)

let alpha_var env id = List.assoc id env

let rec alpha_pat env p = match p.pat_desc with
| Tpat_var (id, s) -> (* note the ``Not_found'' case *)
    {p with pat_desc =
     try Tpat_var (alpha_var env id, s) with
     | Not_found -> Tpat_any}
| Tpat_alias (p1, id, s) ->
    let new_p =  alpha_pat env p1 in
    begin try
      {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)}
    with
    | Not_found -> new_p
    end
| d ->
    {p with pat_desc = map_pattern_desc (alpha_pat env) d}

let mkloc = Location.mkloc
let mknoloc = Location.mknoloc

end
module Tast_mapper : sig 
#1 "tast_mapper.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                        Alain Frisch, LexiFi                            *)
(*                                                                        *)
(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Asttypes
open Typedtree

(** {1 A generic Typedtree mapper} *)

type mapper =
  {
    case: mapper -> case -> case;
    cases: mapper -> case list -> case list;
    class_declaration: mapper -> class_declaration -> class_declaration;
    class_description: mapper -> class_description -> class_description;
    class_expr: mapper -> class_expr -> class_expr;
    class_field: mapper -> class_field -> class_field;
    class_signature: mapper -> class_signature -> class_signature;
    class_structure: mapper -> class_structure -> class_structure;
    class_type: mapper -> class_type -> class_type;
    class_type_declaration: mapper -> class_type_declaration ->
      class_type_declaration;
    class_type_field: mapper -> class_type_field -> class_type_field;
    env: mapper -> Env.t -> Env.t;
    expr: mapper -> expression -> expression;
    extension_constructor: mapper -> extension_constructor ->
      extension_constructor;
    module_binding: mapper -> module_binding -> module_binding;
    module_coercion: mapper -> module_coercion -> module_coercion;
    module_declaration: mapper -> module_declaration -> module_declaration;
    module_expr: mapper -> module_expr -> module_expr;
    module_type: mapper -> module_type -> module_type;
    module_type_declaration:
      mapper -> module_type_declaration -> module_type_declaration;
    package_type: mapper -> package_type -> package_type;
    pat: mapper -> pattern -> pattern;
    row_field: mapper -> row_field -> row_field;
    object_field: mapper -> object_field -> object_field;
    signature: mapper -> signature -> signature;
    signature_item: mapper -> signature_item -> signature_item;
    structure: mapper -> structure -> structure;
    structure_item: mapper -> structure_item -> structure_item;
    typ: mapper -> core_type -> core_type;
    type_declaration: mapper -> type_declaration -> type_declaration;
    type_declarations: mapper -> (rec_flag * type_declaration list) ->
      (rec_flag * type_declaration list);
    type_extension: mapper -> type_extension -> type_extension;
    type_kind: mapper -> type_kind -> type_kind;
    value_binding: mapper -> value_binding -> value_binding;
    value_bindings: mapper -> (rec_flag * value_binding list) ->
      (rec_flag * value_binding list);
    value_description: mapper -> value_description -> value_description;
    with_constraint: mapper -> with_constraint -> with_constraint;
  }


val default: mapper

end = struct
#1 "tast_mapper.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                        Alain Frisch, LexiFi                            *)
(*                                                                        *)
(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Asttypes
open Typedtree

(* TODO: add 'methods' for location, attribute, extension,
   open_description, include_declaration, include_description *)

type mapper =
  {
    case: mapper -> case -> case;
    cases: mapper -> case list -> case list;
    class_declaration: mapper -> class_declaration -> class_declaration;
    class_description: mapper -> class_description -> class_description;
    class_expr: mapper -> class_expr -> class_expr;
    class_field: mapper -> class_field -> class_field;
    class_signature: mapper -> class_signature -> class_signature;
    class_structure: mapper -> class_structure -> class_structure;
    class_type: mapper -> class_type -> class_type;
    class_type_declaration: mapper -> class_type_declaration ->
      class_type_declaration;
    class_type_field: mapper -> class_type_field -> class_type_field;
    env: mapper -> Env.t -> Env.t;
    expr: mapper -> expression -> expression;
    extension_constructor: mapper -> extension_constructor ->
      extension_constructor;
    module_binding: mapper -> module_binding -> module_binding;
    module_coercion: mapper -> module_coercion -> module_coercion;
    module_declaration: mapper -> module_declaration -> module_declaration;
    module_expr: mapper -> module_expr -> module_expr;
    module_type: mapper -> module_type -> module_type;
    module_type_declaration:
      mapper -> module_type_declaration -> module_type_declaration;
    package_type: mapper -> package_type -> package_type;
    pat: mapper -> pattern -> pattern;
    row_field: mapper -> row_field -> row_field;
    object_field: mapper -> object_field -> object_field;
    signature: mapper -> signature -> signature;
    signature_item: mapper -> signature_item -> signature_item;
    structure: mapper -> structure -> structure;
    structure_item: mapper -> structure_item -> structure_item;
    typ: mapper -> core_type -> core_type;
    type_declaration: mapper -> type_declaration -> type_declaration;
    type_declarations: mapper -> (rec_flag * type_declaration list) ->
      (rec_flag * type_declaration list);
    type_extension: mapper -> type_extension -> type_extension;
    type_kind: mapper -> type_kind -> type_kind;
    value_binding: mapper -> value_binding -> value_binding;
    value_bindings: mapper -> (rec_flag * value_binding list) ->
      (rec_flag * value_binding list);
    value_description: mapper -> value_description -> value_description;
    with_constraint: mapper -> with_constraint -> with_constraint;
  }

let id x = x
let tuple2 f1 f2 (x, y) = (f1 x, f2 y)
let tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
let opt f = function None -> None | Some x -> Some (f x)

let structure sub {str_items; str_type; str_final_env} =
  {
    str_items = List.map (sub.structure_item sub) str_items;
    str_final_env = sub.env sub str_final_env;
    str_type;
  }

let class_infos sub f x =
  {x with
   ci_params = List.map (tuple2 (sub.typ sub) id) x.ci_params;
   ci_expr = f x.ci_expr;
  }

let module_type_declaration sub x =
  let mtd_type = opt (sub.module_type sub) x.mtd_type in
  {x with mtd_type}

let module_declaration sub x =
  let md_type = sub.module_type sub x.md_type in
  {x with md_type}

let include_infos f x = {x with incl_mod = f x.incl_mod}

let class_type_declaration sub x =
  class_infos sub (sub.class_type sub) x

let class_declaration sub x =
  class_infos sub (sub.class_expr sub) x

let structure_item sub {str_desc; str_loc; str_env} =
  let str_env = sub.env sub str_env in
  let str_desc =
    match str_desc with
    | Tstr_eval (exp, attrs) -> Tstr_eval (sub.expr sub exp, attrs)
    | Tstr_value (rec_flag, list) ->
        let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in
        Tstr_value (rec_flag, list)
    | Tstr_primitive v -> Tstr_primitive (sub.value_description sub v)
    | Tstr_type (rec_flag, list) ->
        let (rec_flag, list) = sub.type_declarations sub (rec_flag, list) in
        Tstr_type (rec_flag, list)
    | Tstr_typext te -> Tstr_typext (sub.type_extension sub te)
    | Tstr_exception ext -> Tstr_exception (sub.extension_constructor sub ext)
    | Tstr_module mb -> Tstr_module (sub.module_binding sub mb)
    | Tstr_recmodule list ->
        Tstr_recmodule (List.map (sub.module_binding sub) list)
    | Tstr_modtype x -> Tstr_modtype (sub.module_type_declaration sub x)
    | Tstr_class list ->
        Tstr_class
          (List.map (tuple2 (sub.class_declaration sub) id) list)
    | Tstr_class_type list ->
        Tstr_class_type
          (List.map (tuple3 id id (sub.class_type_declaration sub)) list)
    | Tstr_include incl ->
        Tstr_include (include_infos (sub.module_expr sub) incl)
    | Tstr_open _
    | Tstr_attribute _ as d -> d
  in
  {str_desc; str_env; str_loc}

let value_description sub x =
  let val_desc = sub.typ sub x.val_desc in
  {x with val_desc}

let label_decl sub x =
  let ld_type = sub.typ sub x.ld_type in
  {x with ld_type}

let constructor_args sub = function
  | Cstr_tuple l -> Cstr_tuple (List.map (sub.typ sub) l)
  | Cstr_record l -> Cstr_record (List.map (label_decl sub) l)

let constructor_decl sub cd =
  let cd_args = constructor_args sub cd.cd_args in
  let cd_res = opt (sub.typ sub) cd.cd_res in
  {cd with cd_args; cd_res}

let type_kind sub = function
  | Ttype_abstract -> Ttype_abstract
  | Ttype_variant list -> Ttype_variant (List.map (constructor_decl sub) list)
  | Ttype_record list -> Ttype_record (List.map (label_decl sub) list)
  | Ttype_open -> Ttype_open

let type_declaration sub x =
  let typ_cstrs =
    List.map
      (tuple3 (sub.typ sub) (sub.typ sub) id)
      x.typ_cstrs
  in
  let typ_kind = sub.type_kind sub x.typ_kind in
  let typ_manifest = opt (sub.typ sub) x.typ_manifest in
  let typ_params = List.map (tuple2 (sub.typ sub) id) x.typ_params in
  {x with typ_cstrs; typ_kind; typ_manifest; typ_params}

let type_declarations sub (rec_flag, list) =
  (rec_flag, List.map (sub.type_declaration sub) list)

let type_extension sub x =
  let tyext_params = List.map (tuple2 (sub.typ sub) id) x.tyext_params in
  let tyext_constructors =
    List.map (sub.extension_constructor sub) x.tyext_constructors
  in
  {x with tyext_constructors; tyext_params}

let extension_constructor sub x =
  let ext_kind =
    match x.ext_kind with
      Text_decl(ctl, cto) ->
        Text_decl(constructor_args sub ctl, opt (sub.typ sub) cto)
    | Text_rebind _ as d -> d
  in
  {x with ext_kind}

let pat sub x =
  let extra = function
    | Tpat_type _
    | Tpat_unpack as d -> d
    | Tpat_open (path,loc,env) ->  Tpat_open (path, loc, sub.env sub env)
    | Tpat_constraint ct -> Tpat_constraint (sub.typ sub ct)
  in
  let pat_env = sub.env sub x.pat_env in
  let pat_extra = List.map (tuple3 extra id id) x.pat_extra in
  let pat_desc =
    match x.pat_desc with
    | Tpat_any
    | Tpat_var _
    | Tpat_constant _ as d -> d
    | Tpat_tuple l -> Tpat_tuple (List.map (sub.pat sub) l)
    | Tpat_construct (loc, cd, l) ->
        Tpat_construct (loc, cd, List.map (sub.pat sub) l)
    | Tpat_variant (l, po, rd) -> Tpat_variant (l, opt (sub.pat sub) po, rd)
    | Tpat_record (l, closed) ->
        Tpat_record (List.map (tuple3 id id (sub.pat sub)) l, closed)
    | Tpat_array l -> Tpat_array (List.map (sub.pat sub) l)
    | Tpat_or (p1, p2, rd) ->
        Tpat_or (sub.pat sub p1, sub.pat sub p2, rd)
    | Tpat_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, s)
    | Tpat_lazy p -> Tpat_lazy (sub.pat sub p)
  in
  {x with pat_extra; pat_desc; pat_env}

let expr sub x =
  let extra = function
    | Texp_constraint cty ->
        Texp_constraint (sub.typ sub cty)
    | Texp_coerce (cty1, cty2) ->
        Texp_coerce (opt (sub.typ sub) cty1, sub.typ sub cty2)
    | Texp_open (ovf, path, loc, env) ->
        Texp_open (ovf, path, loc, sub.env sub env)
    | Texp_newtype _ as d -> d
    | Texp_poly cto -> Texp_poly (opt (sub.typ sub) cto)
  in
  let exp_extra = List.map (tuple3 extra id id) x.exp_extra in
  let exp_env = sub.env sub x.exp_env in
  let exp_desc =
    match x.exp_desc with
    | Texp_ident _
    | Texp_constant _ as d -> d
    | Texp_let (rec_flag, list, exp) ->
        let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in
        Texp_let (rec_flag, list, sub.expr sub exp)
    | Texp_function { arg_label; param; cases; partial; } ->
        Texp_function { arg_label; param; cases = sub.cases sub cases;
          partial; }
    | Texp_apply (exp, list) ->
        Texp_apply (
          sub.expr sub exp,
          List.map (tuple2 id (opt (sub.expr sub))) list
        )
    | Texp_match (exp, cases, exn_cases, p) ->
        Texp_match (
          sub.expr sub exp,
          sub.cases sub cases,
          sub.cases sub exn_cases,
          p
        )
    | Texp_try (exp, cases) ->
        Texp_try (
          sub.expr sub exp,
          sub.cases sub cases
        )
    | Texp_tuple list ->
        Texp_tuple (List.map (sub.expr sub) list)
    | Texp_construct (lid, cd, args) ->
        Texp_construct (lid, cd, List.map (sub.expr sub) args)
    | Texp_variant (l, expo) ->
        Texp_variant (l, opt (sub.expr sub) expo)
    | Texp_record { fields; representation; extended_expression } ->
        let fields = Array.map (function
            | label, Kept t -> label, Kept t
            | label, Overridden (lid, exp) ->
                label, Overridden (lid, sub.expr sub exp))
            fields
        in
        Texp_record {
          fields; representation;
          extended_expression = opt (sub.expr sub) extended_expression;
        }
    | Texp_field (exp, lid, ld) ->
        Texp_field (sub.expr sub exp, lid, ld)
    | Texp_setfield (exp1, lid, ld, exp2) ->
        Texp_setfield (
          sub.expr sub exp1,
          lid,
          ld,
          sub.expr sub exp2
        )
    | Texp_array list ->
        Texp_array (List.map (sub.expr sub) list)
    | Texp_ifthenelse (exp1, exp2, expo) ->
        Texp_ifthenelse (
          sub.expr sub exp1,
          sub.expr sub exp2,
          opt (sub.expr sub) expo
        )
    | Texp_sequence (exp1, exp2) ->
        Texp_sequence (
          sub.expr sub exp1,
          sub.expr sub exp2
        )
    | Texp_while (exp1, exp2) ->
        Texp_while (
          sub.expr sub exp1,
          sub.expr sub exp2
        )
    | Texp_for (id, p, exp1, exp2, dir, exp3) ->
        Texp_for (
          id,
          p,
          sub.expr sub exp1,
          sub.expr sub exp2,
          dir,
          sub.expr sub exp3
        )
    | Texp_send (exp, meth, expo) ->
        Texp_send
          (
            sub.expr sub exp,
            meth,
            opt (sub.expr sub) expo
          )
    | Texp_new _
    | Texp_instvar _ as d -> d
    | Texp_setinstvar (path1, path2, id, exp) ->
        Texp_setinstvar (
          path1,
          path2,
          id,
          sub.expr sub exp
        )
    | Texp_override (path, list) ->
        Texp_override (
          path,
          List.map (tuple3 id id (sub.expr sub)) list
        )
    | Texp_letmodule (id, s, mexpr, exp) ->
        Texp_letmodule (
          id,
          s,
          sub.module_expr sub mexpr,
          sub.expr sub exp
        )
    | Texp_letexception (cd, exp) ->
        Texp_letexception (
          sub.extension_constructor sub cd,
          sub.expr sub exp
        )
    | Texp_assert exp ->
        Texp_assert (sub.expr sub exp)
    | Texp_lazy exp ->
        Texp_lazy (sub.expr sub exp)
    | Texp_object (cl, sl) ->
        Texp_object (sub.class_structure sub cl, sl)
    | Texp_pack mexpr ->
        Texp_pack (sub.module_expr sub mexpr)
    | Texp_unreachable ->
        Texp_unreachable
    | Texp_extension_constructor _ as e ->
        e
  in
  {x with exp_extra; exp_desc; exp_env}


let package_type sub x =
  let pack_fields = List.map (tuple2 id (sub.typ sub)) x.pack_fields in
  {x with pack_fields}

let signature sub x =
  let sig_final_env = sub.env sub x.sig_final_env in
  let sig_items = List.map (sub.signature_item sub) x.sig_items in
  {x with sig_items; sig_final_env}

let signature_item sub x =
  let sig_env = sub.env sub x.sig_env in
  let sig_desc =
    match x.sig_desc with
    | Tsig_value v ->
        Tsig_value (sub.value_description sub v)
    | Tsig_type (rec_flag, list) ->
        let (rec_flag, list) = sub.type_declarations sub (rec_flag, list) in
        Tsig_type (rec_flag, list)
    | Tsig_typext te ->
        Tsig_typext (sub.type_extension sub te)
    | Tsig_exception ext ->
        Tsig_exception (sub.extension_constructor sub ext)
    | Tsig_module x ->
        Tsig_module (sub.module_declaration sub x)
    | Tsig_recmodule list ->
        Tsig_recmodule (List.map (sub.module_declaration sub) list)
    | Tsig_modtype x ->
        Tsig_modtype (sub.module_type_declaration sub x)
    | Tsig_include incl ->
        Tsig_include (include_infos (sub.module_type sub) incl)
    | Tsig_class list ->
        Tsig_class (List.map (sub.class_description sub) list)
    | Tsig_class_type list ->
        Tsig_class_type
          (List.map (sub.class_type_declaration sub) list)
    | Tsig_open _
    | Tsig_attribute _ as d -> d
  in
  {x with sig_desc; sig_env}

let class_description sub x =
  class_infos sub (sub.class_type sub) x

let module_type sub x =
  let mty_env = sub.env sub x.mty_env in
  let mty_desc =
    match x.mty_desc with
    | Tmty_ident _
    | Tmty_alias _ as d -> d
    | Tmty_signature sg -> Tmty_signature (sub.signature sub sg)
    | Tmty_functor (id, s, mtype1, mtype2) ->
        Tmty_functor (
          id,
          s,
          opt (sub.module_type sub) mtype1,
          sub.module_type sub mtype2
        )
    | Tmty_with (mtype, list) ->
        Tmty_with (
          sub.module_type sub mtype,
          List.map (tuple3 id id (sub.with_constraint sub)) list
        )
    | Tmty_typeof mexpr ->
        Tmty_typeof (sub.module_expr sub mexpr)
  in
  {x with mty_desc; mty_env}

let with_constraint sub = function
  | Twith_type decl -> Twith_type (sub.type_declaration sub decl)
  | Twith_typesubst decl -> Twith_typesubst (sub.type_declaration sub decl)
  | Twith_module _
  | Twith_modsubst _ as d -> d

let module_coercion sub = function
  | Tcoerce_none -> Tcoerce_none
  | Tcoerce_functor (c1,c2) ->
      Tcoerce_functor (sub.module_coercion sub c1, sub.module_coercion sub c2)
  | Tcoerce_alias (p, c1) ->
      Tcoerce_alias (p, sub.module_coercion sub c1)
  | Tcoerce_structure (l1, l2) ->
      let l1' = List.map (fun (i,c) -> i, sub.module_coercion sub c) l1 in
      let l2' =
        List.map (fun (id,i,c) -> id, i, sub.module_coercion sub c) l2
      in
      Tcoerce_structure (l1', l2')
  | Tcoerce_primitive pc ->
      Tcoerce_primitive {pc with pc_env = sub.env sub pc.pc_env}

let module_expr sub x =
  let mod_env = sub.env sub x.mod_env in
  let mod_desc =
    match x.mod_desc with
    | Tmod_ident _ as d -> d
    | Tmod_structure st -> Tmod_structure (sub.structure sub st)
    | Tmod_functor (id, s, mtype, mexpr) ->
        Tmod_functor (
          id,
          s,
          opt (sub.module_type sub) mtype,
          sub.module_expr sub mexpr
        )
    | Tmod_apply (mexp1, mexp2, c) ->
        Tmod_apply (
          sub.module_expr sub mexp1,
          sub.module_expr sub mexp2,
          sub.module_coercion sub c
        )
    | Tmod_constraint (mexpr, mt, Tmodtype_implicit, c) ->
        Tmod_constraint (sub.module_expr sub mexpr, mt, Tmodtype_implicit,
                         sub.module_coercion sub c)
    | Tmod_constraint (mexpr, mt, Tmodtype_explicit mtype, c) ->
        Tmod_constraint (
          sub.module_expr sub mexpr,
          mt,
          Tmodtype_explicit (sub.module_type sub mtype),
          sub.module_coercion sub c
        )
    | Tmod_unpack (exp, mty) ->
        Tmod_unpack
          (
            sub.expr sub exp,
            mty
          )
  in
  {x with mod_desc; mod_env}

let module_binding sub x =
  let mb_expr = sub.module_expr sub x.mb_expr in
  {x with mb_expr}

let class_expr sub x =
  let cl_env = sub.env sub x.cl_env in
  let cl_desc =
    match x.cl_desc with
    | Tcl_constraint (cl, clty, vals, meths, concrs) ->
        Tcl_constraint (
          sub.class_expr sub cl,
          opt (sub.class_type sub) clty,
          vals,
          meths,
          concrs
        )
    | Tcl_structure clstr ->
        Tcl_structure (sub.class_structure sub clstr)
    | Tcl_fun (label, pat, priv, cl, partial) ->
        Tcl_fun (
          label,
          sub.pat sub pat,
          List.map (tuple3 id id (sub.expr sub)) priv,
          sub.class_expr sub cl,
          partial
        )
    | Tcl_apply (cl, args) ->
        Tcl_apply (
          sub.class_expr sub cl,
          List.map (tuple2 id (opt (sub.expr sub))) args
        )
    | Tcl_let (rec_flag, value_bindings, ivars, cl) ->
        let (rec_flag, value_bindings) =
          sub.value_bindings sub (rec_flag, value_bindings)
        in
        Tcl_let (
          rec_flag,
          value_bindings,
          List.map (tuple3 id id (sub.expr sub)) ivars,
          sub.class_expr sub cl
        )
    | Tcl_ident (path, lid, tyl) ->
        Tcl_ident (path, lid, List.map (sub.typ sub) tyl)
    | Tcl_open (ovf, p, lid, env, e) ->
        Tcl_open (ovf, p, lid, sub.env sub env, sub.class_expr sub e)
  in
  {x with cl_desc; cl_env}

let class_type sub x =
  let cltyp_env = sub.env sub x.cltyp_env in
  let cltyp_desc =
    match x.cltyp_desc with
    | Tcty_signature csg -> Tcty_signature (sub.class_signature sub csg)
    | Tcty_constr (path, lid, list) ->
        Tcty_constr (
          path,
          lid,
          List.map (sub.typ sub) list
        )
    | Tcty_arrow (label, ct, cl) ->
        Tcty_arrow
          (label,
           sub.typ sub ct,
           sub.class_type sub cl
          )
    | Tcty_open (ovf, p, lid, env, e) ->
        Tcty_open (ovf, p, lid, sub.env sub env, sub.class_type sub e)
  in
  {x with cltyp_desc; cltyp_env}

let class_signature sub x =
  let csig_self = sub.typ sub x.csig_self in
  let csig_fields = List.map (sub.class_type_field sub) x.csig_fields in
  {x with csig_self; csig_fields}

let class_type_field sub x =
  let ctf_desc =
    match x.ctf_desc with
    | Tctf_inherit ct ->
        Tctf_inherit (sub.class_type sub ct)
    | Tctf_val (s, mut, virt, ct) ->
        Tctf_val (s, mut, virt, sub.typ sub ct)
    | Tctf_method (s, priv, virt, ct) ->
        Tctf_method (s, priv, virt, sub.typ sub ct)
    | Tctf_constraint  (ct1, ct2) ->
        Tctf_constraint (sub.typ sub ct1, sub.typ sub ct2)
    | Tctf_attribute _ as d -> d
  in
  {x with ctf_desc}

let typ sub x =
  let ctyp_env = sub.env sub x.ctyp_env in
  let ctyp_desc =
    match x.ctyp_desc with
    | Ttyp_any
    | Ttyp_var _ as d -> d
    | Ttyp_arrow (label, ct1, ct2) ->
        Ttyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2)
    | Ttyp_tuple list -> Ttyp_tuple (List.map (sub.typ sub) list)
    | Ttyp_constr (path, lid, list) ->
        Ttyp_constr (path, lid, List.map (sub.typ sub) list)
    | Ttyp_object (list, closed) ->
        Ttyp_object ((List.map (sub.object_field sub) list), closed)
    | Ttyp_class (path, lid, list) ->
        Ttyp_class
          (path,
           lid,
           List.map (sub.typ sub) list
          )
    | Ttyp_alias (ct, s) ->
        Ttyp_alias (sub.typ sub ct, s)
    | Ttyp_variant (list, closed, labels) ->
        Ttyp_variant (List.map (sub.row_field sub) list, closed, labels)
    | Ttyp_poly (sl, ct) ->
        Ttyp_poly (sl, sub.typ sub ct)
    | Ttyp_package pack ->
        Ttyp_package (sub.package_type sub pack)
  in
  {x with ctyp_desc; ctyp_env}

let class_structure sub x =
  let cstr_self = sub.pat sub x.cstr_self in
  let cstr_fields = List.map (sub.class_field sub) x.cstr_fields in
  {x with cstr_self; cstr_fields}

let row_field sub = function
  | Ttag (label, attrs, b, list) ->
      Ttag (label, attrs, b, List.map (sub.typ sub) list)
  | Tinherit ct -> Tinherit (sub.typ sub ct)

let object_field sub = function
  | OTtag (label, attrs, ct) ->
      OTtag (label, attrs, (sub.typ sub ct))
  | OTinherit ct -> OTinherit (sub.typ sub ct)

let class_field_kind sub = function
  | Tcfk_virtual ct -> Tcfk_virtual (sub.typ sub ct)
  | Tcfk_concrete (ovf, e) -> Tcfk_concrete (ovf, sub.expr sub e)

let class_field sub x =
  let cf_desc =
    match x.cf_desc with
    | Tcf_inherit (ovf, cl, super, vals, meths) ->
        Tcf_inherit (ovf, sub.class_expr sub cl, super, vals, meths)
    | Tcf_constraint (cty, cty') ->
        Tcf_constraint (
          sub.typ sub cty,
          sub.typ sub cty'
        )
    | Tcf_val (s, mf, id, k, b) ->
        Tcf_val (s, mf, id, class_field_kind sub k, b)
    | Tcf_method (s, priv, k) ->
        Tcf_method (s, priv, class_field_kind sub k)
    | Tcf_initializer exp ->
        Tcf_initializer (sub.expr sub exp)
    | Tcf_attribute _ as d -> d
  in
  {x with cf_desc}

let value_bindings sub (rec_flag, list) =
  (rec_flag, List.map (sub.value_binding sub) list)

let cases sub l =
  List.map (sub.case sub) l

let case sub {c_lhs; c_guard; c_rhs} =
  {
    c_lhs = sub.pat sub c_lhs;
    c_guard = opt (sub.expr sub) c_guard;
    c_rhs = sub.expr sub c_rhs;
  }

let value_binding sub x =
  let vb_pat = sub.pat sub x.vb_pat in
  let vb_expr = sub.expr sub x.vb_expr in
  {x with vb_pat; vb_expr}

let env _sub x = x

let default =
  {
    case;
    cases;
    class_declaration;
    class_description;
    class_expr;
    class_field;
    class_signature;
    class_structure;
    class_type;
    class_type_declaration;
    class_type_field;
    env;
    expr;
    extension_constructor;
    module_binding;
    module_coercion;
    module_declaration;
    module_expr;
    module_type;
    module_type_declaration;
    package_type;
    pat;
    row_field;
    object_field;
    signature;
    signature_item;
    structure;
    structure_item;
    typ;
    type_declaration;
    type_declarations;
    type_extension;
    type_kind;
    value_binding;
    value_bindings;
    value_description;
    with_constraint;
  }

end
module Cmt_format : sig 
#1 "cmt_format.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                   Fabrice Le Fessant, INRIA Saclay                     *)
(*                                                                        *)
(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** cmt and cmti files format. *)

(** The layout of a cmt file is as follows:
      <cmt> := \{<cmi>\} <cmt magic> \{cmt infos\} \{<source info>\}
    where <cmi> is the cmi file format:
      <cmi> := <cmi magic> <cmi info>.
    More precisely, the optional <cmi> part must be present if and only if
    the file is:
    - a cmti, or
    - a cmt, for a ml file which has no corresponding mli (hence no
    corresponding cmti).

    Thus, we provide a common reading function for cmi and cmt(i)
    files which returns an option for each of the three parts: cmi
    info, cmt info, source info. *)

open Typedtree

type binary_annots =
  | Packed of Types.signature * string list
  | Implementation of structure
  | Interface of signature
  | Partial_implementation of binary_part array
  | Partial_interface of binary_part array

and binary_part =
  | Partial_structure of structure
  | Partial_structure_item of structure_item
  | Partial_expression of expression
  | Partial_pattern of pattern
  | Partial_class_expr of class_expr
  | Partial_signature of signature
  | Partial_signature_item of signature_item
  | Partial_module_type of module_type

type cmt_infos = {
  cmt_modname : string;
  cmt_annots : binary_annots;
  cmt_value_dependencies :
    (Types.value_description * Types.value_description) list;
  cmt_comments : (string * Location.t) list;
  cmt_args : string array;
  cmt_sourcefile : string option;
  cmt_builddir : string;
  cmt_loadpath : string list;
  cmt_source_digest : string option;
  cmt_initial_env : Env.t;
  cmt_imports : (string * Digest.t option) list;
  cmt_interface_digest : Digest.t option;
  cmt_use_summaries : bool;
}

type error =
    Not_a_typedtree of string

exception Error of error

(** [read filename] opens filename, and extract both the cmi_infos, if
    it exists, and the cmt_infos, if it exists. Thus, it can be used
    with .cmi, .cmt and .cmti files.

    .cmti files always contain a cmi_infos at the beginning. .cmt files
    only contain a cmi_infos at the beginning if there is no associated
    .cmti file.
*)
val read : string -> Cmi_format.cmi_infos option * cmt_infos option

val read_cmt : string -> cmt_infos
val read_cmi : string -> Cmi_format.cmi_infos

(** [save_cmt filename modname binary_annots sourcefile initial_env cmi]
    writes a cmt(i) file.  *)
val save_cmt :
  string ->  (* filename.cmt to generate *)
  string ->  (* module name *)
  binary_annots ->
  string option ->  (* source file *)
  Env.t -> (* initial env *)
  Cmi_format.cmi_infos option -> (* if a .cmi was generated *)
  unit

(* Miscellaneous functions *)

val read_magic_number : in_channel -> string

val clear: unit -> unit

val add_saved_type : binary_part -> unit
val get_saved_types : unit -> binary_part list
val set_saved_types : binary_part list -> unit

val record_value_dependency:
  Types.value_description -> Types.value_description -> unit


(*

  val is_magic_number : string -> bool
  val read : in_channel -> Env.cmi_infos option * t
  val write_magic_number : out_channel -> unit
  val write : out_channel -> t -> unit

  val find : string list -> string -> string
  val read_signature : 'a -> string -> Types.signature * 'b list * 'c list

*)

end = struct
#1 "cmt_format.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                   Fabrice Le Fessant, INRIA Saclay                     *)
(*                                                                        *)
(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Cmi_format
open Typedtree

(* Note that in Typerex, there is an awful hack to save a cmt file
   together with the interface file that was generated by ocaml (this
   is because the installed version of ocaml might differ from the one
   integrated in Typerex).
*)



let read_magic_number ic =
  let len_magic_number = String.length Config.cmt_magic_number in
  really_input_string ic len_magic_number

type binary_annots =
  | Packed of Types.signature * string list
  | Implementation of structure
  | Interface of signature
  | Partial_implementation of binary_part array
  | Partial_interface of binary_part array

and binary_part =
| Partial_structure of structure
| Partial_structure_item of structure_item
| Partial_expression of expression
| Partial_pattern of pattern
| Partial_class_expr of class_expr
| Partial_signature of signature
| Partial_signature_item of signature_item
| Partial_module_type of module_type

type cmt_infos = {
  cmt_modname : string;
  cmt_annots : binary_annots;
  cmt_value_dependencies :
    (Types.value_description * Types.value_description) list;
  cmt_comments : (string * Location.t) list;
  cmt_args : string array;
  cmt_sourcefile : string option;
  cmt_builddir : string;
  cmt_loadpath : string list;
  cmt_source_digest : Digest.t option;
  cmt_initial_env : Env.t;
  cmt_imports : (string * Digest.t option) list;
  cmt_interface_digest : Digest.t option;
  cmt_use_summaries : bool;
}

type error =
    Not_a_typedtree of string

let need_to_clear_env =
  try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false
  with Not_found -> true

let keep_only_summary = Env.keep_only_summary

open Tast_mapper

let cenv =
  {Tast_mapper.default with env = fun _sub env -> keep_only_summary env}

let clear_part = function
  | Partial_structure s -> Partial_structure (cenv.structure cenv s)
  | Partial_structure_item s ->
      Partial_structure_item (cenv.structure_item cenv s)
  | Partial_expression e -> Partial_expression (cenv.expr cenv e)
  | Partial_pattern p -> Partial_pattern (cenv.pat cenv p)
  | Partial_class_expr ce -> Partial_class_expr (cenv.class_expr cenv ce)
  | Partial_signature s -> Partial_signature (cenv.signature cenv s)
  | Partial_signature_item s ->
      Partial_signature_item (cenv.signature_item cenv s)
  | Partial_module_type s -> Partial_module_type (cenv.module_type cenv s)

let clear_env binary_annots =
  if need_to_clear_env then
    match binary_annots with
    | Implementation s -> Implementation (cenv.structure cenv s)
    | Interface s -> Interface (cenv.signature cenv s)
    | Packed _ -> binary_annots
    | Partial_implementation array ->
        Partial_implementation (Array.map clear_part array)
    | Partial_interface array ->
        Partial_interface (Array.map clear_part array)

  else binary_annots

exception Error of error

let input_cmt ic = (input_value ic : cmt_infos)

let output_cmt oc cmt =
  output_string oc Config.cmt_magic_number;
  output_value oc (cmt : cmt_infos)

let read filename =
(*  Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *)
  let ic = open_in_bin filename in
  try
    let magic_number = read_magic_number ic in
    let cmi, cmt =
      if magic_number = Config.cmt_magic_number then
        None, Some (input_cmt ic)
      else if magic_number = Config.cmi_magic_number then
        let cmi = Cmi_format.input_cmi ic in
        let cmt = try
                    let magic_number = read_magic_number ic in
                    if magic_number = Config.cmt_magic_number then
                      let cmt = input_cmt ic in
                      Some cmt
                    else None
          with _ -> None
        in
        Some cmi, cmt
      else
        raise(Cmi_format.Error(Cmi_format.Not_an_interface filename))
    in
    close_in ic;
(*    Printf.fprintf stderr "Cmt_format.read done\n%!"; *)
    cmi, cmt
  with e ->
    close_in ic;
    raise e

let read_cmt filename =
  match read filename with
      _, None -> raise (Error (Not_a_typedtree filename))
    | _, Some cmt -> cmt

let read_cmi filename =
  match read filename with
      None, _ ->
        raise (Cmi_format.Error (Cmi_format.Not_an_interface filename))
    | Some cmi, _ -> cmi

let saved_types = ref []
let value_deps = ref []

let clear () =
  saved_types := [];
  value_deps := []

let add_saved_type b = saved_types := b :: !saved_types
let get_saved_types () = !saved_types
let set_saved_types l = saved_types := l

let record_value_dependency vd1 vd2 =
  if vd1.Types.val_loc <> vd2.Types.val_loc then
    value_deps := (vd1, vd2) :: !value_deps

let save_cmt filename modname binary_annots sourcefile initial_env cmi =
  if !Clflags.binary_annotations && not !Clflags.print_types then begin
    Misc.output_to_file_via_temporary
       ~mode:[Open_binary] filename
       (fun temp_file_name oc ->
         let this_crc =
           match cmi with
           | None -> None
           | Some cmi -> Some (output_cmi temp_file_name oc cmi)
         in
         let source_digest = Misc.may_map Digest.file sourcefile in
         let cmt = {
           cmt_modname = modname;
           cmt_annots = clear_env binary_annots;
           cmt_value_dependencies = !value_deps;
           cmt_comments = Lexer.comments ();
           cmt_args = Sys.argv;
           cmt_sourcefile = sourcefile;
           cmt_builddir =  Sys.getcwd ();
           cmt_loadpath = !Config.load_path;
           cmt_source_digest = source_digest;
           cmt_initial_env = if need_to_clear_env then
               keep_only_summary initial_env else initial_env;
           cmt_imports = List.sort compare (Env.imports ());
           cmt_interface_digest = this_crc;
           cmt_use_summaries = need_to_clear_env;
         } in
         output_cmt oc cmt)

    (* TODO: does not make sense to do post-proccesing for [Partial_implementaiton]*)
  ; match !Clflags.bs_gentype with
    | None -> ()
    | Some cmd -> ignore (Sys.command (cmd ^ " -cmt-add " ^ filename ^ (match sourcefile with None -> "" | Some sourcefile -> ":" ^ sourcefile)))

  end;
  clear ()

end
module Ctype : sig 
#1 "ctype.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Operations on core types *)

open Asttypes
open Types

exception Unify of (type_expr * type_expr) list
exception Tags of label * label
exception Subtype of
        (type_expr * type_expr) list * (type_expr * type_expr) list
exception Cannot_expand
exception Cannot_apply
exception Recursive_abbrev
exception Unification_recursive_abbrev of (type_expr * type_expr) list

val init_def: int -> unit
        (* Set the initial variable level *)
val begin_def: unit -> unit
        (* Raise the variable level by one at the beginning of a definition. *)
val end_def: unit -> unit
        (* Lower the variable level by one at the end of a definition *)
val begin_class_def: unit -> unit
val raise_nongen_level: unit -> unit
val reset_global_level: unit -> unit
        (* Reset the global level before typing an expression *)
val increase_global_level: unit -> int
val restore_global_level: int -> unit
        (* This pair of functions is only used in Typetexp *)
type levels =
    { current_level: int; nongen_level: int; global_level: int;
      saved_level: (int * int) list; }
val save_levels: unit -> levels
val set_levels: levels -> unit

val newty: type_desc -> type_expr
val newvar: ?name:string -> unit -> type_expr
val newvar2: ?name:string -> int -> type_expr
        (* Return a fresh variable *)
val new_global_var: ?name:string -> unit -> type_expr
        (* Return a fresh variable, bound at toplevel
           (as type variables ['a] in type constraints). *)
val newobj: type_expr -> type_expr
val newconstr: Path.t -> type_expr list -> type_expr
val none: type_expr
        (* A dummy type expression *)

val repr: type_expr -> type_expr
        (* Return the canonical representative of a type. *)

val object_fields: type_expr -> type_expr
val flatten_fields:
        type_expr -> (string * field_kind * type_expr) list * type_expr
        (* Transform a field type into a list of pairs label-type *)
        (* The fields are sorted *)
val associate_fields:
        (string * field_kind * type_expr) list ->
        (string * field_kind * type_expr) list ->
        (string * field_kind * type_expr * field_kind * type_expr) list *
        (string * field_kind * type_expr) list *
        (string * field_kind * type_expr) list
val opened_object: type_expr -> bool
val close_object: type_expr -> unit
val row_variable: type_expr -> type_expr
        (* Return the row variable of an open object type *)
val set_object_name:
        Ident.t -> type_expr -> type_expr list -> type_expr -> unit
val remove_object_name: type_expr -> unit
val hide_private_methods: type_expr -> unit
val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr
val lid_of_path: ?hash:string -> Path.t -> Longident.t

val sort_row_fields: (label * row_field) list -> (label * row_field) list
val merge_row_fields:
        (label * row_field) list -> (label * row_field) list ->
        (label * row_field) list * (label * row_field) list *
        (label * row_field * row_field) list
val filter_row_fields:
        bool -> (label * row_field) list -> (label * row_field) list

val generalize: type_expr -> unit
        (* Generalize in-place the given type *)
val generalize_expansive: Env.t -> type_expr -> unit
        (* Generalize the covariant part of a type, making
           contravariant branches non-generalizable *)
val generalize_global: type_expr -> unit
        (* Generalize the structure of a type, lowering variables
           to !global_level *)
val generalize_structure: type_expr -> unit
        (* Same, but variables are only lowered to !current_level *)
val generalize_spine: type_expr -> unit
        (* Special function to generalize a method during inference *)
val correct_levels: type_expr -> type_expr
        (* Returns a copy with decreasing levels *)
val limited_generalize: type_expr -> type_expr -> unit
        (* Only generalize some part of the type
           Make the remaining of the type non-generalizable *)

val instance: ?partial:bool -> Env.t -> type_expr -> type_expr
        (* Take an instance of a type scheme *)
        (* partial=None  -> normal
           partial=false -> newvar() for non generic subterms
           partial=true  -> newty2 ty.level Tvar for non generic subterms *)
val instance_def: type_expr -> type_expr
        (* use defaults *)
val generic_instance: Env.t -> type_expr -> type_expr
        (* Same as instance, but new nodes at generic_level *)
val instance_list: Env.t -> type_expr list -> type_expr list
        (* Take an instance of a list of type schemes *)
val instance_constructor:
        ?in_pattern:Env.t ref * int ->
        constructor_description -> type_expr list * type_expr
        (* Same, for a constructor *)
val instance_parameterized_type:
        ?keep_names:bool ->
        type_expr list -> type_expr -> type_expr list * type_expr
val instance_parameterized_type_2:
        type_expr list -> type_expr list -> type_expr ->
        type_expr list * type_expr list * type_expr
val instance_declaration: type_declaration -> type_declaration
val instance_class:
        type_expr list -> class_type -> type_expr list * class_type
val instance_poly:
        ?keep_names:bool ->
        bool -> type_expr list -> type_expr -> type_expr list * type_expr
        (* Take an instance of a type scheme containing free univars *)
val instance_label:
        bool -> label_description -> type_expr list * type_expr * type_expr
        (* Same, for a label *)
val apply:
        Env.t -> type_expr list -> type_expr -> type_expr list -> type_expr
        (* [apply [p1...pN] t [a1...aN]] match the arguments [ai] to
        the parameters [pi] and returns the corresponding instance of
        [t]. Exception [Cannot_apply] is raised in case of failure. *)

val expand_head_once: Env.t -> type_expr -> type_expr
val expand_head: Env.t -> type_expr -> type_expr
val try_expand_once_opt: Env.t -> type_expr -> type_expr
val expand_head_opt: Env.t -> type_expr -> type_expr
(** The compiler's own version of [expand_head] necessary for type-based
    optimisations. *)

val full_expand: Env.t -> type_expr -> type_expr
val extract_concrete_typedecl:
        Env.t -> type_expr -> Path.t * Path.t * type_declaration
        (* Return the original path of the types, and the first concrete
           type declaration found expanding it.
           Raise [Not_found] if none appears or not a type constructor. *)

val enforce_constraints: Env.t -> type_expr -> unit

val unify: Env.t -> type_expr -> type_expr -> unit
        (* Unify the two types given. Raise [Unify] if not possible. *)
val unify_gadt: newtype_level:int -> Env.t ref -> type_expr -> type_expr -> unit
        (* Unify the two types given and update the environment with the
           local constraints. Raise [Unify] if not possible. *)
val unify_var: Env.t -> type_expr -> type_expr -> unit
        (* Same as [unify], but allow free univars when first type
           is a variable. *)
val with_passive_variants: ('a -> 'b) -> ('a -> 'b)
        (* Call [f] in passive_variants mode, for exhaustiveness check. *)
val filter_arrow: Env.t -> type_expr -> arg_label -> type_expr * type_expr
        (* A special case of unification (with l:'a -> 'b). *)
val filter_method: Env.t -> string -> private_flag -> type_expr -> type_expr
        (* A special case of unification (with {m : 'a; 'b}). *)
val check_filter_method: Env.t -> string -> private_flag -> type_expr -> unit
        (* A special case of unification (with {m : 'a; 'b}), returning unit. *)
val occur_in: Env.t -> type_expr -> type_expr -> bool
val deep_occur: type_expr -> type_expr -> bool
val filter_self_method:
        Env.t -> string -> private_flag -> (Ident.t * type_expr) Meths.t ref ->
        type_expr -> Ident.t * type_expr
val moregeneral: Env.t -> bool -> type_expr -> type_expr -> bool
        (* Check if the first type scheme is more general than the second. *)

val rigidify: type_expr -> type_expr list
        (* "Rigidify" a type and return its type variable *)
val all_distinct_vars: Env.t -> type_expr list -> bool
        (* Check those types are all distinct type variables *)
val matches: Env.t -> type_expr -> type_expr -> bool
        (* Same as [moregeneral false], implemented using the two above
           functions and backtracking. Ignore levels *)

type class_match_failure =
    CM_Virtual_class
  | CM_Parameter_arity_mismatch of int * int
  | CM_Type_parameter_mismatch of Env.t * (type_expr * type_expr) list
  | CM_Class_type_mismatch of Env.t * class_type * class_type
  | CM_Parameter_mismatch of Env.t * (type_expr * type_expr) list
  | CM_Val_type_mismatch of string * Env.t * (type_expr * type_expr) list
  | CM_Meth_type_mismatch of string * Env.t * (type_expr * type_expr) list
  | CM_Non_mutable_value of string
  | CM_Non_concrete_value of string
  | CM_Missing_value of string
  | CM_Missing_method of string
  | CM_Hide_public of string
  | CM_Hide_virtual of string * string
  | CM_Public_method of string
  | CM_Private_method of string
  | CM_Virtual_method of string
val match_class_types:
    ?trace:bool -> Env.t -> class_type -> class_type -> class_match_failure list
        (* Check if the first class type is more general than the second. *)
val equal: Env.t -> bool -> type_expr list -> type_expr list -> bool
        (* [equal env [x1...xn] tau [y1...yn] sigma]
           checks whether the parameterized types
           [/\x1.../\xn.tau] and [/\y1.../\yn.sigma] are equivalent. *)
val match_class_declarations:
        Env.t -> type_expr list -> class_type -> type_expr list ->
        class_type -> class_match_failure list
        (* Check if the first class type is more general than the second. *)

val enlarge_type: Env.t -> type_expr -> type_expr * bool
        (* Make a type larger, flag is true if some pruning had to be done *)
val subtype: Env.t -> type_expr -> type_expr -> unit -> unit
        (* [subtype env t1 t2] checks that [t1] is a subtype of [t2].
           It accumulates the constraints the type variables must
           enforce and returns a function that enforces this
           constraints. *)

val nondep_type: Env.t -> Ident.t -> type_expr -> type_expr
        (* Return a type equivalent to the given type but without
           references to the given module identifier. Raise [Not_found]
           if no such type exists. *)
val nondep_type_decl:
        Env.t -> Ident.t -> Ident.t -> bool -> type_declaration ->
        type_declaration
        (* Same for type declarations. *)
val nondep_extension_constructor:
        Env.t -> Ident.t -> extension_constructor ->
        extension_constructor
          (* Same for extension constructor *)
val nondep_class_declaration:
        Env.t -> Ident.t -> class_declaration -> class_declaration
        (* Same for class declarations. *)
val nondep_cltype_declaration:
        Env.t -> Ident.t -> class_type_declaration -> class_type_declaration
        (* Same for class type declarations. *)
(*val correct_abbrev: Env.t -> Path.t -> type_expr list -> type_expr -> unit*)
val cyclic_abbrev: Env.t -> Ident.t -> type_expr -> bool
val is_contractive: Env.t -> Path.t -> bool
val normalize_type: Env.t -> type_expr -> unit

val closed_schema: Env.t -> type_expr -> bool
        (* Check whether the given type scheme contains no non-generic
           type variables *)

val free_variables: ?env:Env.t -> type_expr -> type_expr list
        (* If env present, then check for incomplete definitions too *)
val closed_type_decl: type_declaration -> type_expr option
val closed_extension_constructor: extension_constructor -> type_expr option
type closed_class_failure =
    CC_Method of type_expr * bool * string * type_expr
  | CC_Value of type_expr * bool * string * type_expr
val closed_class:
        type_expr list -> class_signature -> closed_class_failure option
        (* Check whether all type variables are bound *)

val unalias: type_expr -> type_expr
val signature_of_class_type: class_type -> class_signature
val self_type: class_type -> type_expr
val class_type_arity: class_type -> int
val arity: type_expr -> int
        (* Return the arity (as for curried functions) of the given type. *)

val collapse_conj_params: Env.t -> type_expr list -> unit
        (* Collapse conjunctive types in class parameters *)

val get_current_level: unit -> int
val wrap_trace_gadt_instances: Env.t -> ('a -> 'b) -> 'a -> 'b
val reset_reified_var_counter: unit -> unit

val maybe_pointer_type : Env.t -> type_expr -> bool
       (* True if type is possibly pointer, false if definitely not a pointer *)

(* Stubs *)
val package_subtype :
    (Env.t -> Path.t -> Longident.t list -> type_expr list ->
      Path.t -> Longident.t list -> type_expr list -> bool) ref

end = struct
#1 "ctype.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Operations on core types *)

open Misc
open Asttypes
open Types
open Btype

(*
   Type manipulation after type inference
   ======================================
   If one wants to manipulate a type after type inference (for
   instance, during code generation or in the debugger), one must
   first make sure that the type levels are correct, using the
   function [correct_levels]. Then, this type can be correctly
   manipulated by [apply], [expand_head] and [moregeneral].
*)

(*
   General notes
   =============
   - As much sharing as possible should be kept : it makes types
     smaller and better abbreviated.
     When necessary, some sharing can be lost. Types will still be
     printed correctly (+++ TO DO...), and abbreviations defined by a
     class do not depend on sharing thanks to constrained
     abbreviations. (Of course, even if some sharing is lost, typing
     will still be correct.)
   - All nodes of a type have a level : that way, one know whether a
     node need to be duplicated or not when instantiating a type.
   - Levels of a type are decreasing (generic level being considered
     as greatest).
   - The level of a type constructor is superior to the binding
     time of its path.
   - Recursive types without limitation should be handled (even if
     there is still an occur check). This avoid treating specially the
     case for objects, for instance. Furthermore, the occur check
     policy can then be easily changed.
*)

(**** Errors ****)

exception Unify of (type_expr * type_expr) list

exception Tags of label * label

let () =
  Location.register_error_of_exn
    (function
      | Tags (l, l') ->
          Some
            Location.
              (errorf ~loc:(in_file !input_name)
                 "In this program,@ variant constructors@ `%s and `%s@ \
                  have the same hash value.@ Change one of them." l l'
              )
      | _ -> None
    )

exception Subtype of
        (type_expr * type_expr) list * (type_expr * type_expr) list

exception Cannot_expand

exception Cannot_apply

exception Recursive_abbrev

(* GADT: recursive abbrevs can appear as a result of local constraints *)
exception Unification_recursive_abbrev of (type_expr * type_expr) list

(**** Type level management ****)

let current_level = ref 0
let nongen_level = ref 0
let global_level = ref 1
let saved_level = ref []

type levels =
    { current_level: int; nongen_level: int; global_level: int;
      saved_level: (int * int) list; }
let save_levels () =
  { current_level = !current_level;
    nongen_level = !nongen_level;
    global_level = !global_level;
    saved_level = !saved_level }
let set_levels l =
  current_level := l.current_level;
  nongen_level := l.nongen_level;
  global_level := l.global_level;
  saved_level := l.saved_level

let get_current_level () = !current_level
let init_def level = current_level := level; nongen_level := level
let begin_def () =
  saved_level := (!current_level, !nongen_level) :: !saved_level;
  incr current_level; nongen_level := !current_level
let begin_class_def () =
  saved_level := (!current_level, !nongen_level) :: !saved_level;
  incr current_level
let raise_nongen_level () =
  saved_level := (!current_level, !nongen_level) :: !saved_level;
  nongen_level := !current_level
let end_def () =
  let (cl, nl) = List.hd !saved_level in
  saved_level := List.tl !saved_level;
  current_level := cl; nongen_level := nl

let reset_global_level () =
  global_level := !current_level + 1
let increase_global_level () =
  let gl = !global_level in
  global_level := !current_level;
  gl
let restore_global_level gl =
  global_level := gl

(**** Whether a path points to an object type (with hidden row variable) ****)
let is_object_type path =
  let name =
    match path with Path.Pident id -> Ident.name id
    | Path.Pdot(_, s,_) -> s
    | Path.Papply _ -> assert false
  in name.[0] = '#'

(**** Control tracing of GADT instances *)

let trace_gadt_instances = ref false
let check_trace_gadt_instances env =
  not !trace_gadt_instances && Env.has_local_constraints env &&
  (trace_gadt_instances := true; cleanup_abbrev (); true)

let reset_trace_gadt_instances b =
  if b then trace_gadt_instances := false

let wrap_trace_gadt_instances env f x =
  let b = check_trace_gadt_instances env in
  let y = f x in
  reset_trace_gadt_instances b;
  y

(**** Abbreviations without parameters ****)
(* Shall reset after generalizing *)

let simple_abbrevs = ref Mnil

let proper_abbrevs path tl abbrev =
  if tl <> [] || !trace_gadt_instances || !Clflags.principal ||
     is_object_type path
  then abbrev
  else simple_abbrevs

(**** Some type creators ****)

(* Re-export generic type creators *)

let newty2             = Btype.newty2
let newty desc         = newty2 !current_level desc

let newvar ?name ()         = newty2 !current_level (Tvar name)
let newvar2 ?name level     = newty2 level (Tvar name)
let new_global_var ?name () = newty2 !global_level (Tvar name)

let newobj fields      = newty (Tobject (fields, ref None))

let newconstr path tyl = newty (Tconstr (path, tyl, ref Mnil))

let none = newty (Ttuple [])                (* Clearly ill-formed type *)

(**** Representative of a type ****)

(* Re-export repr *)
let repr = repr

(**** Type maps ****)

module TypePairs =
  Hashtbl.Make (struct
    type t = type_expr * type_expr
    let equal (t1, t1') (t2, t2') = (t1 == t2) && (t1' == t2')
    let hash (t, t') = t.id + 93 * t'.id
 end)


(**** unification mode ****)

type unification_mode =
  | Expression (* unification in expression *)
  | Pattern (* unification in pattern which may add local constraints *)

let umode = ref Expression
let generate_equations = ref false
let assume_injective = ref false

let set_mode_pattern ~generate ~injective f =
  let old_unification_mode = !umode
  and old_gen = !generate_equations
  and old_inj = !assume_injective in
  try
    umode := Pattern;
    generate_equations := generate;
    assume_injective := injective;
    let ret = f () in
    umode := old_unification_mode;
    generate_equations := old_gen;
    assume_injective := old_inj;
    ret
  with e ->
    umode := old_unification_mode;
    generate_equations := old_gen;
    assume_injective := old_inj;
    raise e

(*** Checks for type definitions ***)

let in_current_module = function
  | Path.Pident _ -> true
  | Path.Pdot _ | Path.Papply _ -> false

let in_pervasives p =
  in_current_module p &&
  try ignore (Env.find_type p Env.initial_safe_string); true
  with Not_found -> false

let is_datatype decl=
  match decl.type_kind with
    Type_record _ | Type_variant _ | Type_open -> true
  | Type_abstract -> false


                  (**********************************************)
                  (*  Miscellaneous operations on object types  *)
                  (**********************************************)

(* Note:
   We need to maintain some invariants:
   * cty_self must be a Tobject
   * ...
*)

(**** Object field manipulation. ****)

let object_fields ty =
  match (repr ty).desc with
    Tobject (fields, _) -> fields
  | _                   -> assert false

let flatten_fields ty =
  let rec flatten l ty =
    let ty = repr ty in
    match ty.desc with
      Tfield(s, k, ty1, ty2) ->
        flatten ((s, k, ty1)::l) ty2
    | _ ->
        (l, ty)
  in
    let (l, r) = flatten [] ty in
    (List.sort (fun (n, _, _) (n', _, _) -> compare n n') l, r)

let build_fields level =
  List.fold_right
    (fun (s, k, ty1) ty2 -> newty2 level (Tfield(s, k, ty1, ty2)))

let associate_fields fields1 fields2 =
  let rec associate p s s' =
    function
      (l, []) ->
        (List.rev p, (List.rev s) @ l, List.rev s')
    | ([], l') ->
        (List.rev p, List.rev s, (List.rev s') @ l')
    | ((n, k, t)::r, (n', k', t')::r') when n = n' ->
        associate ((n, k, t, k', t')::p) s s' (r, r')
    | ((n, k, t)::r, ((n', _k', _t')::_ as l')) when n < n' ->
        associate p ((n, k, t)::s) s' (r, l')
    | (((_n, _k, _t)::_ as l), (n', k', t')::r') (* when n > n' *) ->
        associate p s ((n', k', t')::s') (l, r')
  in
  associate [] [] [] (fields1, fields2)

(**** Check whether an object is open ****)

(* +++ The abbreviation should eventually be expanded *)
let rec object_row ty =
  let ty = repr ty in
  match ty.desc with
    Tobject (t, _)     -> object_row t
  | Tfield(_, _, _, t) -> object_row t
  | _ -> ty

let opened_object ty =
  match (object_row ty).desc with
  | Tvar _  | Tunivar _ | Tconstr _ -> true
  | _                               -> false

let concrete_object ty =
  match (object_row ty).desc with
  | Tvar _             -> false
  | _                  -> true

(**** Close an object ****)

let close_object ty =
  let rec close ty =
    let ty = repr ty in
    match ty.desc with
      Tvar _ ->
        link_type ty (newty2 ty.level Tnil)
    | Tfield(_, _, _, ty') -> close ty'
    | _                    -> assert false
  in
  match (repr ty).desc with
    Tobject (ty, _)   -> close ty
  | _                 -> assert false

(**** Row variable of an object type ****)

let row_variable ty =
  let rec find ty =
    let ty = repr ty in
    match ty.desc with
      Tfield (_, _, _, ty) -> find ty
    | Tvar _               -> ty
    | _                    -> assert false
  in
  match (repr ty).desc with
    Tobject (fi, _) -> find fi
  | _               -> assert false

(**** Object name manipulation ****)
(* +++ Bientot obsolete *)

let set_object_name id rv params ty =
  match (repr ty).desc with
    Tobject (_fi, nm) ->
      set_name nm (Some (Path.Pident id, rv::params))
  | _ ->
      assert false

let remove_object_name ty =
  match (repr ty).desc with
    Tobject (_, nm)   -> set_name nm None
  | Tconstr (_, _, _) -> ()
  | _                 -> fatal_error "Ctype.remove_object_name"

(**** Hiding of private methods ****)

let hide_private_methods ty =
  match (repr ty).desc with
    Tobject (fi, nm) ->
      nm := None;
      let (fl, _) = flatten_fields fi in
      List.iter
        (function (_, k, _) ->
          match field_kind_repr k with
            Fvar r -> set_kind r Fabsent
          | _      -> ())
        fl
  | _ ->
      assert false


                              (*******************************)
                              (*  Operations on class types  *)
                              (*******************************)


let rec signature_of_class_type =
  function
    Cty_constr (_, _, cty) -> signature_of_class_type cty
  | Cty_signature sign     -> sign
  | Cty_arrow (_, _, cty)   -> signature_of_class_type cty

let self_type cty =
  repr (signature_of_class_type cty).csig_self

let rec class_type_arity =
  function
    Cty_constr (_, _, cty) ->  class_type_arity cty
  | Cty_signature _        ->  0
  | Cty_arrow (_, _, cty)    ->  1 + class_type_arity cty


                  (*******************************************)
                  (*  Miscellaneous operations on row types  *)
                  (*******************************************)

let sort_row_fields = List.sort (fun (p,_) (q,_) -> compare p q)

let rec merge_rf r1 r2 pairs fi1 fi2 =
  match fi1, fi2 with
    (l1,f1 as p1)::fi1', (l2,f2 as p2)::fi2' ->
      if l1 = l2 then merge_rf r1 r2 ((l1,f1,f2)::pairs) fi1' fi2' else
      if l1 < l2 then merge_rf (p1::r1) r2 pairs fi1' fi2 else
      merge_rf r1 (p2::r2) pairs fi1 fi2'
  | [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs)
  | _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs)

let merge_row_fields fi1 fi2 =
  match fi1, fi2 with
    [], _ | _, [] -> (fi1, fi2, [])
  | [p1], _ when not (List.mem_assoc (fst p1) fi2) -> (fi1, fi2, [])
  | _, [p2] when not (List.mem_assoc (fst p2) fi1) -> (fi1, fi2, [])
  | _ -> merge_rf [] [] [] (sort_row_fields fi1) (sort_row_fields fi2)

let rec filter_row_fields erase = function
    [] -> []
  | (_l,f as p)::fi ->
      let fi = filter_row_fields erase fi in
      match row_field_repr f with
        Rabsent -> fi
      | Reither(_,_,false,e) when erase -> set_row_field e Rabsent; fi
      | _ -> p :: fi

                    (**************************************)
                    (*  Check genericity of type schemes  *)
                    (**************************************)


exception Non_closed of type_expr * bool

let free_variables = ref []
let really_closed = ref None

let rec free_vars_rec real ty =
  let ty = repr ty in
  if ty.level >= lowest_level then begin
    ty.level <- pivot_level - ty.level;
    begin match ty.desc, !really_closed with
      Tvar _, _ ->
        free_variables := (ty, real) :: !free_variables
    | Tconstr (path, tl, _), Some env ->
        begin try
          let (_, body, _) = Env.find_type_expansion path env in
          if (repr body).level <> generic_level then
            free_variables := (ty, real) :: !free_variables
        with Not_found -> ()
        end;
        List.iter (free_vars_rec true) tl
(* Do not count "virtual" free variables
    | Tobject(ty, {contents = Some (_, p)}) ->
        free_vars_rec false ty; List.iter (free_vars_rec true) p
*)
    | Tobject (ty, _), _ ->
        free_vars_rec false ty
    | Tfield (_, _, ty1, ty2), _ ->
        free_vars_rec true ty1; free_vars_rec false ty2
    | Tvariant row, _ ->
        let row = row_repr row in
        iter_row (free_vars_rec true) row;
        if not (static_row row) then free_vars_rec false row.row_more
    | _    ->
        iter_type_expr (free_vars_rec true) ty
    end;
  end

let free_vars ?env ty =
  free_variables := [];
  really_closed := env;
  free_vars_rec true ty;
  let res = !free_variables in
  free_variables := [];
  really_closed := None;
  res

let free_variables ?env ty =
  let tl = List.map fst (free_vars ?env ty) in
  unmark_type ty;
  tl

let closed_type ty =
  match free_vars ty with
      []           -> ()
  | (v, real) :: _ -> raise (Non_closed (v, real))

let closed_parameterized_type params ty =
  List.iter mark_type params;
  let ok =
    try closed_type ty; true with Non_closed _ -> false in
  List.iter unmark_type params;
  unmark_type ty;
  ok

let closed_type_decl decl =
  try
    List.iter mark_type decl.type_params;
    begin match decl.type_kind with
      Type_abstract ->
        ()
    | Type_variant v ->
        List.iter
          (fun {cd_args; cd_res; _} ->
            match cd_res with
            | Some _ -> ()
            | None ->
                match cd_args with
                | Cstr_tuple l ->  List.iter closed_type l
                | Cstr_record l -> List.iter (fun l -> closed_type l.ld_type) l
          )
          v
    | Type_record(r, _rep) ->
        List.iter (fun l -> closed_type l.ld_type) r
    | Type_open -> ()
    end;
    begin match decl.type_manifest with
      None    -> ()
    | Some ty -> closed_type ty
    end;
    unmark_type_decl decl;
    None
  with Non_closed (ty, _) ->
    unmark_type_decl decl;
    Some ty

let closed_extension_constructor ext =
  try
    List.iter mark_type ext.ext_type_params;
    begin match ext.ext_ret_type with
    | Some _ -> ()
    | None -> iter_type_expr_cstr_args closed_type ext.ext_args
    end;
    unmark_extension_constructor ext;
    None
  with Non_closed (ty, _) ->
    unmark_extension_constructor ext;
    Some ty

type closed_class_failure =
    CC_Method of type_expr * bool * string * type_expr
  | CC_Value of type_expr * bool * string * type_expr

exception CCFailure of closed_class_failure

let closed_class params sign =
  let ty = object_fields (repr sign.csig_self) in
  let (fields, rest) = flatten_fields ty in
  List.iter mark_type params;
  mark_type rest;
  List.iter
    (fun (lab, _, ty) -> if lab = dummy_method then mark_type ty)
    fields;
  try
    mark_type_node (repr sign.csig_self);
    List.iter
      (fun (lab, kind, ty) ->
        if field_kind_repr kind = Fpresent then
        try closed_type ty with Non_closed (ty0, real) ->
          raise (CCFailure (CC_Method (ty0, real, lab, ty))))
      fields;
    mark_type_params (repr sign.csig_self);
    List.iter unmark_type params;
    unmark_class_signature sign;
    None
  with CCFailure reason ->
    mark_type_params (repr sign.csig_self);
    List.iter unmark_type params;
    unmark_class_signature sign;
    Some reason


                            (**********************)
                            (*  Type duplication  *)
                            (**********************)


(* Duplicate a type, preserving only type variables *)
let duplicate_type ty =
  Subst.type_expr Subst.identity ty

(* Same, for class types *)
let duplicate_class_type ty =
  Subst.class_type Subst.identity ty


                         (*****************************)
                         (*  Type level manipulation  *)
                         (*****************************)

(*
   It would be a bit more efficient to remove abbreviation expansions
   rather than generalizing them: these expansions will usually not be
   used anymore. However, this is not possible in the general case, as
   [expand_abbrev] (via [subst]) requires these expansions to be
   preserved. Does it worth duplicating this code ?
*)
let rec generalize ty =
  let ty = repr ty in
  if (ty.level > !current_level) && (ty.level <> generic_level) then begin
    set_level ty generic_level;
    begin match ty.desc with
      Tconstr (_, _, abbrev) ->
        iter_abbrev generalize !abbrev
    | _ -> ()
    end;
    iter_type_expr generalize ty
  end

let generalize ty =
  simple_abbrevs := Mnil;
  generalize ty

(* Generalize the structure and lower the variables *)

let rec generalize_structure var_level ty =
  let ty = repr ty in
  if ty.level <> generic_level then begin
    if is_Tvar ty && ty.level > var_level then
      set_level ty var_level
    else if
      ty.level > !current_level &&
      match ty.desc with
        Tconstr (p, _, abbrev) ->
          not (is_object_type p) && (abbrev := Mnil; true)
      | _ -> true
    then begin
      set_level ty generic_level;
      iter_type_expr (generalize_structure var_level) ty
    end
  end

let generalize_structure var_level ty =
  simple_abbrevs := Mnil;
  generalize_structure var_level ty

(* Generalize the spine of a function, if the level >= !current_level *)

let rec generalize_spine ty =
  let ty = repr ty in
  if ty.level < !current_level || ty.level = generic_level then () else
  match ty.desc with
    Tarrow (_, ty1, ty2, _) ->
      set_level ty generic_level;
      generalize_spine ty1;
      generalize_spine ty2;
  | Tpoly (ty', _) ->
      set_level ty generic_level;
      generalize_spine ty'
  | Ttuple tyl
  | Tpackage (_, _, tyl) ->
      set_level ty generic_level;
      List.iter generalize_spine tyl
  | Tconstr (p, tyl, memo) when not (is_object_type p) ->
      set_level ty generic_level;
      memo := Mnil;
      List.iter generalize_spine tyl
  | _ -> ()

let forward_try_expand_once = (* Forward declaration *)
  ref (fun _env _ty -> raise Cannot_expand)

(*
   Lower the levels of a type (assume [level] is not
   [generic_level]).
*)
(*
    The level of a type constructor must be greater than its binding
    time. That way, a type constructor cannot escape the scope of its
    definition, as would be the case in
      let x = ref []
      module M = struct type t let _ = (x : t list ref) end
    (without this constraint, the type system would actually be unsound.)
*)
let get_level env p =
  try
    match (Env.find_type p env).type_newtype_level with
      | None -> Path.binding_time p
      | Some (x, _) -> x
  with
    | Not_found ->
      (* no newtypes in predef *)
      Path.binding_time p

let rec normalize_package_path env p =
  let t =
    try (Env.find_modtype p env).mtd_type
    with Not_found -> None
  in
  match t with
  | Some (Mty_ident p) -> normalize_package_path env p
  | Some (Mty_signature _ | Mty_functor _ | Mty_alias _) | None ->
      match p with
        Path.Pdot (p1, s, n) ->
          (* For module aliases *)
          let p1' = Env.normalize_path None env p1 in
          if Path.same p1 p1' then p else
          normalize_package_path env (Path.Pdot (p1', s, n))
      | _ -> p

let rec update_level env level expand ty =
  let ty = repr ty in
  if ty.level > level then begin
    begin match Env.gadt_instance_level env ty with
      Some lv -> if level < lv then raise (Unify [(ty, newvar2 level)])
    | None -> ()
    end;
    match ty.desc with
      Tconstr(p, _tl, _abbrev) when level < get_level env p ->
        (* Try first to replace an abbreviation by its expansion. *)
        begin try
          (* if is_newtype env p then raise Cannot_expand; *)
          link_type ty (!forward_try_expand_once env ty);
          update_level env level expand ty
        with Cannot_expand ->
          (* +++ Levels should be restored... *)
          (* Format.printf "update_level: %i < %i@." level (get_level env p); *)
          if level < get_level env p then raise (Unify [(ty, newvar2 level)]);
          iter_type_expr (update_level env level expand) ty
        end
    | Tconstr(_, _ :: _, _) when expand ->
        begin try
          link_type ty (!forward_try_expand_once env ty);
          update_level env level expand ty
        with Cannot_expand ->
          set_level ty level;
          iter_type_expr (update_level env level expand) ty
        end          
    | Tpackage (p, nl, tl) when level < Path.binding_time p ->
        let p' = normalize_package_path env p in
        if Path.same p p' then raise (Unify [(ty, newvar2 level)]);
        log_type ty; ty.desc <- Tpackage (p', nl, tl);
        update_level env level expand ty
    | Tobject(_, ({contents=Some(p, _tl)} as nm))
      when level < get_level env p ->
        set_name nm None;
        update_level env level expand ty
    | Tvariant row ->
        let row = row_repr row in
        begin match row.row_name with
        | Some (p, _tl) when level < get_level env p ->
            log_type ty;
            ty.desc <- Tvariant {row with row_name = None}
        | _ -> ()
        end;
        set_level ty level;
        iter_type_expr (update_level env level expand) ty
    | Tfield(lab, _, ty1, _)
      when lab = dummy_method && (repr ty1).level > level ->
        raise (Unify [(ty1, newvar2 level)])
    | _ ->
        set_level ty level;
        (* XXX what about abbreviations in Tconstr ? *)
        iter_type_expr (update_level env level expand) ty
  end

(* First try without expanding, then expand everything,
   to avoid combinatorial blow-up *)
let update_level env level ty =
  let ty = repr ty in
  if ty.level > level then begin
    let snap = snapshot () in
    try
      update_level env level false ty
    with Unify _ ->
      backtrack snap;
      update_level env level true ty
  end

(* Generalize and lower levels of contravariant branches simultaneously *)

let rec generalize_expansive env var_level visited ty =
  let ty = repr ty in
  if ty.level = generic_level || ty.level <= var_level then () else
  if not (Hashtbl.mem visited ty.id) then begin
    Hashtbl.add visited ty.id ();
    match ty.desc with
      Tconstr (path, tyl, abbrev) ->
        let variance =
          try (Env.find_type path env).type_variance
          with Not_found -> List.map (fun _ -> Variance.may_inv) tyl in
        abbrev := Mnil;
        List.iter2
          (fun v t ->
            if Variance.(mem May_weak v)
            then generalize_structure var_level t
            else generalize_expansive env var_level visited t)
          variance tyl
    | Tpackage (_, _, tyl) ->
        List.iter (generalize_structure var_level) tyl
    | Tarrow (_, t1, t2, _) ->
        generalize_structure var_level t1;
        generalize_expansive env var_level visited t2
    | _ ->
        iter_type_expr (generalize_expansive env var_level visited) ty
  end

let generalize_expansive env ty =
  simple_abbrevs := Mnil;
  try
    generalize_expansive env !nongen_level (Hashtbl.create 7) ty
  with Unify ([_, ty'] as tr) ->
    raise (Unify ((ty, ty') :: tr))

let generalize_global ty = generalize_structure !global_level ty
let generalize_structure ty = generalize_structure !current_level ty

(* Correct the levels of type [ty]. *)
let correct_levels ty =
  duplicate_type ty

(* Only generalize the type ty0 in ty *)
let limited_generalize ty0 ty =
  let ty0 = repr ty0 in

  let graph = Hashtbl.create 17 in
  let idx = ref lowest_level in
  let roots = ref [] in

  let rec inverse pty ty =
    let ty = repr ty in
    if (ty.level > !current_level) || (ty.level = generic_level) then begin
      decr idx;
      Hashtbl.add graph !idx (ty, ref pty);
      if (ty.level = generic_level) || (ty == ty0) then
        roots := ty :: !roots;
      set_level ty !idx;
      iter_type_expr (inverse [ty]) ty
    end else if ty.level < lowest_level then begin
      let (_, parents) = Hashtbl.find graph ty.level in
      parents := pty @ !parents
    end

  and generalize_parents ty =
    let idx = ty.level in
    if idx <> generic_level then begin
      set_level ty generic_level;
      List.iter generalize_parents !(snd (Hashtbl.find graph idx));
      (* Special case for rows: must generalize the row variable *)
      match ty.desc with
        Tvariant row ->
          let more = row_more row in
          let lv = more.level in
          if (lv < lowest_level || lv > !current_level)
          && lv <> generic_level then set_level more generic_level
      | _ -> ()
    end
  in

  inverse [] ty;
  if ty0.level < lowest_level then
    iter_type_expr (inverse []) ty0;
  List.iter generalize_parents !roots;
  Hashtbl.iter
    (fun _ (ty, _) ->
       if ty.level <> generic_level then set_level ty !current_level)
    graph


(* Compute statically the free univars of all nodes in a type *)
(* This avoids doing it repeatedly during instantiation *)

type inv_type_expr =
    { inv_type : type_expr;
      mutable inv_parents : inv_type_expr list }

let rec inv_type hash pty ty =
  let ty = repr ty in
  try
    let inv = TypeHash.find hash ty in
    inv.inv_parents <- pty @ inv.inv_parents
  with Not_found ->
    let inv = { inv_type = ty; inv_parents = pty } in
    TypeHash.add hash ty inv;
    iter_type_expr (inv_type hash [inv]) ty

let compute_univars ty =
  let inverted = TypeHash.create 17 in
  inv_type inverted [] ty;
  let node_univars = TypeHash.create 17 in
  let rec add_univar univ inv =
    match inv.inv_type.desc with
      Tpoly (_ty, tl) when List.memq univ (List.map repr tl) -> ()
    | _ ->
        try
          let univs = TypeHash.find node_univars inv.inv_type in
          if not (TypeSet.mem univ !univs) then begin
            univs := TypeSet.add univ !univs;
            List.iter (add_univar univ) inv.inv_parents
          end
        with Not_found ->
          TypeHash.add node_univars inv.inv_type (ref(TypeSet.singleton univ));
          List.iter (add_univar univ) inv.inv_parents
  in
  TypeHash.iter (fun ty inv -> if is_Tunivar ty then add_univar ty inv)
    inverted;
  fun ty ->
    try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty


                              (*******************)
                              (*  Instantiation  *)
                              (*******************)


let rec find_repr p1 =
  function
    Mnil ->
      None
  | Mcons (Public, p2, ty, _, _) when Path.same p1 p2 ->
      Some ty
  | Mcons (_, _, _, _, rem) ->
      find_repr p1 rem
  | Mlink {contents = rem} ->
      find_repr p1 rem

(*
   Generic nodes are duplicated, while non-generic nodes are left
   as-is.
   During instantiation, the description of a generic node is first
   replaced by a link to a stub ([Tsubst (newvar ())]). Once the
   copy is made, it replaces the stub.
   After instantiation, the description of generic node, which was
   stored by [save_desc], must be put back, using [cleanup_types].
*)

let abbreviations = ref (ref Mnil)
  (* Abbreviation memorized. *)

(* partial: we may not wish to copy the non generic types
   before we call type_pat *)
let rec copy ?env ?partial ?keep_names ty =
  let copy = copy ?env ?partial ?keep_names in
  let ty = repr ty in
  match ty.desc with
    Tsubst ty -> ty
  | _ ->
    if ty.level <> generic_level && partial = None then ty else
    (* We only forget types that are non generic and do not contain
       free univars *)
    let forget =
      if ty.level = generic_level then generic_level else
      match partial with
        None -> assert false
      | Some (free_univars, keep) ->
          if TypeSet.is_empty (free_univars ty) then
            if keep then ty.level else !current_level
          else generic_level
    in
    if forget <> generic_level then newty2 forget (Tvar None) else
    let desc = ty.desc in
    save_desc ty desc;
    let t = newvar() in          (* Stub *)
    begin match env with
      Some env when Env.has_local_constraints env ->
        begin match Env.gadt_instance_level env ty with
          Some lv -> Env.add_gadt_instances env lv [t]
        | None -> ()
        end
    | _ -> ()
    end;
    ty.desc <- Tsubst t;
    t.desc <-
      begin match desc with
      | Tconstr (p, tl, _) ->
          let abbrevs = proper_abbrevs p tl !abbreviations in
          begin match find_repr p !abbrevs with
            Some ty when repr ty != t ->
              Tlink ty
          | _ ->
          (*
             One must allocate a new reference, so that abbrevia-
             tions belonging to different branches of a type are
             independent.
             Moreover, a reference containing a [Mcons] must be
             shared, so that the memorized expansion of an abbrevi-
             ation can be released by changing the content of just
             one reference.
          *)
              Tconstr (p, List.map copy tl,
                       ref (match !(!abbreviations) with
                              Mcons _ -> Mlink !abbreviations
                            | abbrev  -> abbrev))
          end
      | Tvariant row0 ->
          let row = row_repr row0 in
          let more = repr row.row_more in
          (* We must substitute in a subtle way *)
          (* Tsubst takes a tuple containing the row var and the variant *)
          begin match more.desc with
            Tsubst {desc = Ttuple [_;ty2]} ->
              (* This variant type has been already copied *)
              ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *)
              Tlink ty2
          | _ ->
              (* If the row variable is not generic, we must keep it *)
              let keep = more.level <> generic_level in
              let more' =
                match more.desc with
                  Tsubst ty -> ty
                | Tconstr _ | Tnil ->
                    if keep then save_desc more more.desc;
                    copy more
                | Tvar _ | Tunivar _ ->
                    save_desc more more.desc;
                    if keep then more else newty more.desc
                |  _ -> assert false
              in
              let row =
                match repr more' with (* PR#6163 *)
                  {desc=Tconstr _} when not row.row_fixed ->
                    {row with row_fixed = true}
                | _ -> row
              in
              (* Open row if partial for pattern and contains Reither *)
              let more', row =
                match partial with
                  Some (free_univars, false) ->
                    let more' =
                      if more.id != more'.id then more' else
                      let lv = if keep then more.level else !current_level in
                      newty2 lv (Tvar None)
                    in
                    let not_reither (_, f) =
                      match row_field_repr f with
                        Reither _ -> false
                      | _ -> true
                    in
                    if row.row_closed && not row.row_fixed
                    && TypeSet.is_empty (free_univars ty)
                    && not (List.for_all not_reither row.row_fields) then
                      (more',
                       {row_fields = List.filter not_reither row.row_fields;
                        row_more = more'; row_bound = ();
                        row_closed = false; row_fixed = false; row_name = None})
                    else (more', row)
                | _ -> (more', row)
              in
              (* Register new type first for recursion *)
              more.desc <- Tsubst(newgenty(Ttuple[more';t]));
              (* Return a new copy *)
              Tvariant (copy_row copy true row keep more')
          end
      | Tfield (_p, k, _ty1, ty2) ->
          begin match field_kind_repr k with
            Fabsent  -> Tlink (copy ty2)
          | Fpresent -> copy_type_desc copy desc
          | Fvar r ->
              dup_kind r;
              copy_type_desc copy desc
          end
      | Tobject (ty1, _) when partial <> None ->
          Tobject (copy ty1, ref None)
      | _ -> copy_type_desc ?keep_names copy desc
      end;
    t

let simple_copy t = copy t

(**** Variants of instantiations ****)

let gadt_env env =
  if Env.has_local_constraints env
  then Some env
  else None

let instance ?partial env sch =
  let env = gadt_env env in
  let partial =
    match partial with
      None -> None
    | Some keep -> Some (compute_univars sch, keep)
  in
  let ty = copy ?env ?partial sch in
  cleanup_types ();
  ty

let instance_def sch =
  let ty = copy sch in
  cleanup_types ();
  ty

let generic_instance env sch =
  let old = !current_level in
  current_level := generic_level;
  let ty = instance env sch in
  current_level := old;
  ty

let instance_list env schl =
  let env = gadt_env env in
  let tyl = List.map (fun t -> copy ?env t) schl in
  cleanup_types ();
  tyl

let reified_var_counter = ref Vars.empty
let reset_reified_var_counter () =
  reified_var_counter := Vars.empty

(* names given to new type constructors.
   Used for existential types and
   local constraints *)
let get_new_abstract_name s =
  let index =
    try Vars.find s !reified_var_counter + 1
    with Not_found -> 0 in
  reified_var_counter := Vars.add s index !reified_var_counter;
  if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s else
  Printf.sprintf "%s%d" s index

let new_declaration newtype manifest =
  {
    type_params = [];
    type_arity = 0;
    type_kind = Type_abstract;
    type_private = Public;
    type_manifest = manifest;
    type_variance = [];
    type_newtype_level = newtype;
    type_loc = Location.none;
    type_attributes = [];
    type_immediate = false;
    type_unboxed = unboxed_false_default_false;
  }

let instance_constructor ?in_pattern cstr =
  begin match in_pattern with
  | None -> ()
  | Some (env, newtype_lev) ->
      let process existential =
        let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in
        let name =
          match repr existential with
            {desc = Tvar (Some name)} -> "$" ^ cstr.cstr_name ^ "_'" ^ name
          | _ -> "$" ^ cstr.cstr_name
        in
        let path = Path.Pident (Ident.create (get_new_abstract_name name)) in
        let new_env = Env.add_local_type path decl !env in
        env := new_env;
        let to_unify = newty (Tconstr (path,[],ref Mnil)) in
        let tv = copy existential in
        assert (is_Tvar tv);
        link_type tv to_unify
      in
      List.iter process cstr.cstr_existentials
  end;
  let ty_res = copy cstr.cstr_res in
  let ty_args = List.map simple_copy  cstr.cstr_args in
  cleanup_types ();
  (ty_args, ty_res)

let instance_parameterized_type ?keep_names sch_args sch =
  let ty_args = List.map (fun t -> copy ?keep_names t) sch_args in
  let ty = copy sch in
  cleanup_types ();
  (ty_args, ty)

let instance_parameterized_type_2 sch_args sch_lst sch =
  let ty_args = List.map simple_copy sch_args in
  let ty_lst = List.map simple_copy sch_lst in
  let ty = copy sch in
  cleanup_types ();
  (ty_args, ty_lst, ty)

let map_kind f = function
  | Type_abstract -> Type_abstract
  | Type_open -> Type_open
  | Type_variant cl ->
      Type_variant (
        List.map
          (fun c ->
             {c with
              cd_args = map_type_expr_cstr_args f c.cd_args;
              cd_res = may_map f c.cd_res
             })
          cl)
  | Type_record (fl, rr) ->
      Type_record (
        List.map
          (fun l ->
             {l with ld_type = f l.ld_type}
          ) fl, rr)


let instance_declaration decl =
  let decl =
    {decl with type_params = List.map simple_copy decl.type_params;
     type_manifest = may_map simple_copy decl.type_manifest;
     type_kind = map_kind simple_copy decl.type_kind;
    }
  in
  cleanup_types ();
  decl

let instance_class params cty =
  let rec copy_class_type =
    function
      Cty_constr (path, tyl, cty) ->
        Cty_constr (path, List.map simple_copy tyl, copy_class_type cty)
    | Cty_signature sign ->
        Cty_signature
          {csig_self = copy sign.csig_self;
           csig_vars =
             Vars.map (function (m, v, ty) -> (m, v, copy ty)) sign.csig_vars;
           csig_concr = sign.csig_concr;
           csig_inher =
             List.map (fun (p,tl) -> (p, List.map simple_copy tl))
               sign.csig_inher}
    | Cty_arrow (l, ty, cty) ->
        Cty_arrow (l, copy ty, copy_class_type cty)
  in
  let params' = List.map simple_copy params in
  let cty' = copy_class_type cty in
  cleanup_types ();
  (params', cty')

(**** Instantiation for types with free universal variables ****)

let rec diff_list l1 l2 =
  if l1 == l2 then [] else
  match l1 with [] -> invalid_arg "Ctype.diff_list"
  | a :: l1 -> a :: diff_list l1 l2

let conflicts free bound =
  let bound = List.map repr bound in
  TypeSet.exists (fun t -> List.memq (repr t) bound) free

let delayed_copy = ref []
    (* copying to do later *)

(* Copy without sharing until there are no free univars left *)
(* all free univars must be included in [visited]            *)
let rec copy_sep fixed free bound visited ty =
  let ty = repr ty in
  let univars = free ty in
  if TypeSet.is_empty univars then
    if ty.level <> generic_level then ty else
    let t = newvar () in
    delayed_copy :=
      lazy (t.desc <- Tlink (copy ty))
      :: !delayed_copy;
    t
  else try
    let t, bound_t = List.assq ty visited in
    let dl = if is_Tunivar ty then [] else diff_list bound bound_t in
    if dl <> [] && conflicts univars dl then raise Not_found;
    t
  with Not_found -> begin
    let t = newvar() in          (* Stub *)
    let visited =
      match ty.desc with
        Tarrow _ | Ttuple _ | Tvariant _ | Tconstr _ | Tobject _ | Tpackage _ ->
          (ty,(t,bound)) :: visited
      | _ -> visited in
    let copy_rec = copy_sep fixed free bound visited in
    t.desc <-
      begin match ty.desc with
      | Tvariant row0 ->
          let row = row_repr row0 in
          let more = repr row.row_more in
          (* We shall really check the level on the row variable *)
          let keep = is_Tvar more && more.level <> generic_level in
          let more' = copy_rec more in
          let fixed' = fixed && is_Tvar (repr more') in
          let row = copy_row copy_rec fixed' row keep more' in
          Tvariant row
      | Tpoly (t1, tl) ->
          let tl = List.map repr tl in
          let tl' = List.map (fun t -> newty t.desc) tl in
          let bound = tl @ bound in
          let visited =
            List.map2 (fun ty t -> ty,(t,bound)) tl tl' @ visited in
          Tpoly (copy_sep fixed free bound visited t1, tl')
      | _ -> copy_type_desc copy_rec ty.desc
      end;
    t
  end

let instance_poly ?(keep_names=false) fixed univars sch =
  let univars = List.map repr univars in
  let copy_var ty =
    match ty.desc with
      Tunivar name -> if keep_names then newty (Tvar name) else newvar ()
    | _ -> assert false
  in
  let vars = List.map copy_var univars in
  let pairs = List.map2 (fun u v -> u, (v, [])) univars vars in
  delayed_copy := [];
  let ty = copy_sep fixed (compute_univars sch) [] pairs sch in
  List.iter Lazy.force !delayed_copy;
  delayed_copy := [];
  cleanup_types ();
  vars, ty

let instance_label fixed lbl =
  let ty_res = copy lbl.lbl_res in
  let vars, ty_arg =
    match repr lbl.lbl_arg with
      {desc = Tpoly (ty, tl)} ->
        instance_poly fixed tl ty
    | _ ->
        [], copy lbl.lbl_arg
  in
  cleanup_types ();
  (vars, ty_arg, ty_res)

(**** Instantiation with parameter substitution ****)

let unify' = (* Forward declaration *)
  ref (fun _env _ty1 _ty2 -> raise (Unify []))

let subst env level priv abbrev ty params args body =
  if List.length params <> List.length args then raise (Unify []);
  let old_level = !current_level in
  current_level := level;
  try
    let body0 = newvar () in          (* Stub *)
    begin match ty with
      None      -> ()
    | Some ({desc = Tconstr (path, tl, _)} as ty) ->
        let abbrev = proper_abbrevs path tl abbrev in
        memorize_abbrev abbrev priv path ty body0
    | _ ->
        assert false
    end;
    abbreviations := abbrev;
    let (params', body') = instance_parameterized_type params body in
    abbreviations := ref Mnil;
    !unify' env body0 body';
    List.iter2 (!unify' env) params' args;
    current_level := old_level;
    body'
  with Unify _ as exn ->
    current_level := old_level;
    raise exn

(*
   Only the shape of the type matters, not whether it is generic or
   not. [generic_level] might be somewhat slower, but it ensures
   invariants on types are enforced (decreasing levels), and we don't
   care about efficiency here.
*)
let apply env params body args =
  try
    subst env generic_level Public (ref Mnil) None params args body
  with
    Unify _ -> raise Cannot_apply

let () = Subst.ctype_apply_env_empty := apply Env.empty

                              (****************************)
                              (*  Abbreviation expansion  *)
                              (****************************)

(*
   If the environment has changed, memorized expansions might not
   be correct anymore, and so we flush the cache. This is safe but
   quite pessimistic: it would be enough to flush the cache when a
   type or module definition is overridden in the environment.
*)
let previous_env = ref Env.empty
(*let string_of_kind = function Public -> "public" | Private -> "private"*)
let check_abbrev_env env =
  if env != !previous_env then begin
    (* prerr_endline "cleanup expansion cache"; *)
    cleanup_abbrev ();
    previous_env := env
  end


(* Expand an abbreviation. The expansion is memorized. *)
(*
   Assume the level is greater than the path binding time of the
   expanded abbreviation.
*)
(*
   An abbreviation expansion will fail in either of these cases:
   1. The type constructor does not correspond to a manifest type.
   2. The type constructor is defined in an external file, and this
      file is not in the path (missing -I options).
   3. The type constructor is not in the "local" environment. This can
      happens when a non-generic type variable has been instantiated
      afterwards to the not yet defined type constructor. (Actually,
      this cannot happen at the moment due to the strong constraints
      between type levels and constructor binding time.)
   4. The expansion requires the expansion of another abbreviation,
      and this other expansion fails.
*)
let expand_abbrev_gen kind find_type_expansion env ty =
  check_abbrev_env env;
  match ty with
    {desc = Tconstr (path, args, abbrev); level = level} ->
      let lookup_abbrev = proper_abbrevs path args abbrev in
      begin match find_expans kind path !lookup_abbrev with
        Some ty' ->
          (* prerr_endline
            ("found a "^string_of_kind kind^" expansion for "^Path.name path);*)
          if level <> generic_level then
            begin try
              update_level env level ty'
            with Unify _ ->
              (* XXX This should not happen.
                 However, levels are not correctly restored after a
                 typing error *)
              ()
            end;
          let ty' = repr ty' in
          (* assert (ty != ty'); *) (* PR#7324 *)
          ty'
      | None ->
          match find_type_expansion path env with
          | exception Not_found ->
            (* another way to expand is to normalize the path itself *)
            let path' = Env.normalize_path None env path in
            if Path.same path path' then raise Cannot_expand
            else newty2 level (Tconstr (path', args, abbrev))
          | (params, body, lv) ->
            (* prerr_endline
              ("add a "^string_of_kind kind^" expansion for "^Path.name path);*)
            let ty' = subst env level kind abbrev (Some ty) params args body in
            (* For gadts, remember type as non exportable *)
            (* The ambiguous level registered for ty' should be the highest *)
            if !trace_gadt_instances then begin
              match max lv (Env.gadt_instance_level env ty) with
                None -> ()
              | Some lv ->
                  if level < lv then raise (Unify [(ty, newvar2 level)]);
                  Env.add_gadt_instances env lv [ty; ty']
            end;
            ty'
      end
  | _ ->
      assert false

(* Expand respecting privacy *)
let expand_abbrev env ty =
  expand_abbrev_gen Public Env.find_type_expansion env ty

(* Expand once the head of a type *)
let expand_head_once env ty =
  try expand_abbrev env (repr ty) with Cannot_expand -> assert false

(* Check whether a type can be expanded *)
let safe_abbrev env ty =
  let snap = Btype.snapshot () in
  try ignore (expand_abbrev env ty); true
  with Cannot_expand | Unify _ ->
    Btype.backtrack snap;
    false

(* Expand the head of a type once.
   Raise Cannot_expand if the type cannot be expanded.
   May raise Unify, if a recursion was hidden in the type. *)
let try_expand_once env ty =
  let ty = repr ty in
  match ty.desc with
    Tconstr _ -> repr (expand_abbrev env ty)
  | _ -> raise Cannot_expand

(* This one only raises Cannot_expand *)
let try_expand_safe env ty =
  let snap = Btype.snapshot () in
  try try_expand_once env ty
  with Unify _ ->
    Btype.backtrack snap; raise Cannot_expand

(* Fully expand the head of a type. *)
let rec try_expand_head try_once env ty =
  let ty' = try_once env ty in
  try try_expand_head try_once env ty'
  with Cannot_expand -> ty'

let try_expand_head try_once env ty =
  let ty' = try_expand_head try_once env ty in
  begin match Env.gadt_instance_level env ty' with
    None -> ()
  | Some lv -> Env.add_gadt_instance_chain env lv ty
  end;
  ty'

(* Unsafe full expansion, may raise Unify. *)
let expand_head_unif env ty =
  try try_expand_head try_expand_once env ty with Cannot_expand -> repr ty

(* Safe version of expand_head, never fails *)
let expand_head env ty =
  try try_expand_head try_expand_safe env ty with Cannot_expand -> repr ty

let _ = forward_try_expand_once := try_expand_safe


(* Expand until we find a non-abstract type declaration *)

let rec extract_concrete_typedecl env ty =
  let ty = repr ty in
  match ty.desc with
    Tconstr (p, _, _) ->
      let decl = Env.find_type p env in
      if decl.type_kind <> Type_abstract then (p, p, decl) else
      let ty =
        try try_expand_once env ty with Cannot_expand -> raise Not_found
      in
      let (_, p', decl) = extract_concrete_typedecl env ty in
        (p, p', decl)
  | _ -> raise Not_found

(* Implementing function [expand_head_opt], the compiler's own version of
   [expand_head] used for type-based optimisations.
   [expand_head_opt] uses [Env.find_type_expansion_opt] to access the
   manifest type information of private abstract data types which is
   normally hidden to the type-checker out of the implementation module of
   the private abbreviation. *)

let expand_abbrev_opt =
  expand_abbrev_gen Private Env.find_type_expansion_opt

let try_expand_once_opt env ty =
  let ty = repr ty in
  match ty.desc with
    Tconstr _ -> repr (expand_abbrev_opt env ty)
  | _ -> raise Cannot_expand

let rec try_expand_head_opt env ty =
  let ty' = try_expand_once_opt env ty in
  begin try
    try_expand_head_opt env ty'
  with Cannot_expand ->
    ty'
  end

let expand_head_opt env ty =
  let snap = Btype.snapshot () in
  try try_expand_head_opt env ty
  with Cannot_expand | Unify _ -> (* expand_head shall never fail *)
    Btype.backtrack snap;
    repr ty

(* Make sure that the type parameters of the type constructor [ty]
   respect the type constraints *)
let enforce_constraints env ty =
  match ty with
    {desc = Tconstr (path, args, _abbrev); level = level} ->
      begin try
        let decl = Env.find_type path env in
        ignore
          (subst env level Public (ref Mnil) None decl.type_params args
             (newvar2 level))
      with Not_found -> ()
      end
  | _ ->
      assert false

(* Recursively expand the head of a type.
   Also expand #-types. *)
let full_expand env ty =
  let ty = repr (expand_head env ty) in
  match ty.desc with
    Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar (repr v) ->
      newty2 ty.level (Tobject (fi, ref None))
  | _ ->
      ty

(*
   Check whether the abbreviation expands to a well-defined type.
   During the typing of a class, abbreviations for correspondings
   types expand to non-generic types.
*)
let generic_abbrev env path =
  try
    let (_, body, _) = Env.find_type_expansion path env in
    (repr body).level = generic_level
  with
    Not_found ->
      false

let generic_private_abbrev env path =
  try
    match Env.find_type path env with
      {type_kind = Type_abstract;
       type_private = Private;
       type_manifest = Some body} ->
         (repr body).level = generic_level
    | _ -> false
  with Not_found -> false

let is_contractive env p =
  try
    let decl = Env.find_type p env in
    in_pervasives p && decl.type_manifest = None || is_datatype decl
  with Not_found -> false


                              (*****************)
                              (*  Occur check  *)
                              (*****************)


exception Occur

let rec occur_rec env allow_recursive visited ty0 = function
  | {desc=Tlink ty} ->
      occur_rec env allow_recursive visited ty0 ty
  | ty ->
  if ty == ty0  then raise Occur;
  match ty.desc with
    Tconstr(p, _tl, _abbrev) ->
      if allow_recursive && is_contractive env p then () else
      begin try
        if TypeSet.mem ty visited then raise Occur;
        let visited = TypeSet.add ty visited in
        iter_type_expr (occur_rec env allow_recursive visited ty0) ty
      with Occur -> try
        let ty' = try_expand_head try_expand_once env ty in
        (* This call used to be inlined, but there seems no reason for it.
           Message was referring to change in rev. 1.58 of the CVS repo. *)
        occur_rec env allow_recursive visited ty0 ty'
      with Cannot_expand ->
        raise Occur
      end
  | Tobject _ | Tvariant _ ->
      ()
  | _ ->
      if allow_recursive ||  TypeSet.mem ty visited then () else begin
        let visited = TypeSet.add ty visited in
        iter_type_expr (occur_rec env allow_recursive visited ty0) ty
      end

let type_changed = ref false (* trace possible changes to the studied type *)

let merge r b = if b then r := true

let occur env ty0 ty =
  let allow_recursive = !Clflags.recursive_types || !umode = Pattern  in
  let old = !type_changed in
  try
    while
      type_changed := false;
      occur_rec env allow_recursive TypeSet.empty ty0 ty;
      !type_changed
    do () (* prerr_endline "changed" *) done;
    merge type_changed old
  with exn ->
    merge type_changed old;
    raise (match exn with Occur -> Unify [] | _ -> exn)

let occur_in env ty0 t =
  try occur env ty0 t; false with Unify _ -> true

(* Check that a local constraint is well-founded *)
(* PR#6405: not needed since we allow recursion and work on normalized types *)
(* PR#6992: we actually need it for contractiveness *)
(* This is a simplified version of occur, only for the rectypes case *)

let rec local_non_recursive_abbrev strict visited env p ty =
  (*Format.eprintf "@[Check %s =@ %a@]@." (Path.name p) !Btype.print_raw ty;*)
  let ty = repr ty in
  if not (List.memq ty visited) then begin
    match ty.desc with
      Tconstr(p', args, _abbrev) ->
        if Path.same p p' then raise Occur;
        if not strict && is_contractive env p' then () else
        let visited = ty :: visited in
        begin try
          (* try expanding, since [p] could be hidden *)
          local_non_recursive_abbrev strict visited env p
            (try_expand_head try_expand_once env ty)
        with Cannot_expand ->
          let params =
            try (Env.find_type p' env).type_params
            with Not_found -> args
          in
          List.iter2
            (fun tv ty ->
              let strict = strict || not (is_Tvar (repr tv)) in
              local_non_recursive_abbrev strict visited env p ty)
            params args
        end
    | _ ->
        if strict then (* PR#7374 *)
          let visited = ty :: visited in
          iter_type_expr (local_non_recursive_abbrev true visited env p) ty
  end

let local_non_recursive_abbrev env p ty =
  try (* PR#7397: need to check trace_gadt_instances *)
    wrap_trace_gadt_instances env
      (local_non_recursive_abbrev false [] env p) ty;
    true
  with Occur -> false


                   (*****************************)
                   (*  Polymorphic Unification  *)
                   (*****************************)

(* Since we cannot duplicate universal variables, unification must
   be done at meta-level, using bindings in univar_pairs *)
let rec unify_univar t1 t2 = function
    (cl1, cl2) :: rem ->
      let find_univ t cl =
        try
          let (_, r) = List.find (fun (t',_) -> t == repr t') cl in
          Some r
        with Not_found -> None
      in
      begin match find_univ t1 cl1, find_univ t2 cl2 with
        Some {contents=Some t'2}, Some _ when t2 == repr t'2 ->
          ()
      | Some({contents=None} as r1), Some({contents=None} as r2) ->
          set_univar r1 t2; set_univar r2 t1
      | None, None ->
          unify_univar t1 t2 rem
      | _ ->
          raise (Unify [])
      end
  | [] -> raise (Unify [])

(* Test the occurrence of free univars in a type *)
(* that's way too expensive. Must do some kind of caching *)
let occur_univar env ty =
  let visited = ref TypeMap.empty in
  let rec occur_rec bound ty =
    let ty = repr ty in
    if ty.level >= lowest_level &&
      if TypeSet.is_empty bound then
        (ty.level <- pivot_level - ty.level; true)
      else try
        let bound' = TypeMap.find ty !visited in
        if TypeSet.exists (fun x -> not (TypeSet.mem x bound)) bound' then
          (visited := TypeMap.add ty (TypeSet.inter bound bound') !visited;
           true)
        else false
      with Not_found ->
        visited := TypeMap.add ty bound !visited;
        true
    then
      match ty.desc with
        Tunivar _ ->
          if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar ()])
      | Tpoly (ty, tyl) ->
          let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in
          occur_rec bound  ty
      | Tconstr (_, [], _) -> ()
      | Tconstr (p, tl, _) ->
          begin try
            let td = Env.find_type p env in
            List.iter2
              (fun t v ->
                if Variance.(mem May_pos v || mem May_neg v)
                then occur_rec bound t)
              tl td.type_variance
          with Not_found ->
            List.iter (occur_rec bound) tl
          end
      | _ -> iter_type_expr (occur_rec bound) ty
  in
  try
    occur_rec TypeSet.empty ty; unmark_type ty
  with exn ->
    unmark_type ty; raise exn

(* Grouping univars by families according to their binders *)
let add_univars =
  List.fold_left (fun s (t,_) -> TypeSet.add (repr t) s)

let get_univar_family univar_pairs univars =
  if univars = [] then TypeSet.empty else
  let insert s = function
      cl1, (_::_ as cl2) ->
        if List.exists (fun (t1,_) -> TypeSet.mem (repr t1) s) cl1 then
          add_univars s cl2
        else s
    | _ -> s
  in
  let s = List.fold_right TypeSet.add univars TypeSet.empty in
  List.fold_left insert s univar_pairs

(* Whether a family of univars escapes from a type *)
let univars_escape env univar_pairs vl ty =
  let family = get_univar_family univar_pairs vl in
  let visited = ref TypeSet.empty in
  let rec occur t =
    let t = repr t in
    if TypeSet.mem t !visited then () else begin
      visited := TypeSet.add t !visited;
      match t.desc with
        Tpoly (t, tl) ->
          if List.exists (fun t -> TypeSet.mem (repr t) family) tl then ()
          else occur t
      | Tunivar _ ->
          if TypeSet.mem t family then raise Occur
      | Tconstr (_, [], _) -> ()
      | Tconstr (p, tl, _) ->
          begin try
            let td = Env.find_type p env in
            List.iter2
              (fun t v ->
                if Variance.(mem May_pos v || mem May_neg v) then occur t)
              tl td.type_variance
          with Not_found ->
            List.iter occur tl
          end
      | _ ->
          iter_type_expr occur t
    end
  in
  try occur ty; false with Occur -> true

(* Wrapper checking that no variable escapes and updating univar_pairs *)
let enter_poly env univar_pairs t1 tl1 t2 tl2 f =
  let old_univars = !univar_pairs in
  let known_univars =
    List.fold_left (fun s (cl,_) -> add_univars s cl)
      TypeSet.empty old_univars
  in
  let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
  if List.exists (fun t -> TypeSet.mem t known_univars) tl1 &&
    univars_escape env old_univars tl1 (newty(Tpoly(t2,tl2)))
  || List.exists (fun t -> TypeSet.mem t known_univars) tl2 &&
    univars_escape env old_univars tl2 (newty(Tpoly(t1,tl1)))
  then raise (Unify []);
  let cl1 = List.map (fun t -> t, ref None) tl1
  and cl2 = List.map (fun t -> t, ref None) tl2 in
  univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars;
  try let res = f t1 t2 in univar_pairs := old_univars; res
  with exn -> univar_pairs := old_univars; raise exn

let univar_pairs = ref []


                              (*****************)
                              (*  Unification  *)
                              (*****************)



let rec has_cached_expansion p abbrev =
  match abbrev with
    Mnil                   -> false
  | Mcons(_, p', _, _, rem)   -> Path.same p p' || has_cached_expansion p rem
  | Mlink rem              -> has_cached_expansion p !rem

(**** Transform error trace ****)
(* +++ Move it to some other place ? *)

let expand_trace env trace =
  List.fold_right
    (fun (t1, t2) rem ->
       (repr t1, full_expand env t1)::(repr t2, full_expand env t2)::rem)
    trace []

(* build a dummy variant type *)
let mkvariant fields closed =
  newgenty
    (Tvariant
       {row_fields = fields; row_closed = closed; row_more = newvar();
        row_bound = (); row_fixed = false; row_name = None })

(**** Unification ****)

(* Return whether [t0] occurs in [ty]. Objects are also traversed. *)
let deep_occur t0 ty =
  let rec occur_rec ty =
    let ty = repr ty in
    if ty.level >= lowest_level then begin
      if ty == t0 then raise Occur;
      ty.level <- pivot_level - ty.level;
      iter_type_expr occur_rec ty
    end
  in
  try
    occur_rec ty; unmark_type ty; false
  with Occur ->
    unmark_type ty; true

(*
   1. When unifying two non-abbreviated types, one type is made a link
      to the other. When unifying an abbreviated type with a
      non-abbreviated type, the non-abbreviated type is made a link to
      the other one. When unifying to abbreviated types, these two
      types are kept distincts, but they are made to (temporally)
      expand to the same type.
   2. Abbreviations with at least one parameter are systematically
      expanded. The overhead does not seem too high, and that way
      abbreviations where some parameters does not appear in the
      expansion, such as ['a t = int], are correctly handled. In
      particular, for this example, unifying ['a t] with ['b t] keeps
      ['a] and ['b] distincts. (Is it really important ?)
   3. Unifying an abbreviation ['a t = 'a] with ['a] should not yield
      ['a t as 'a]. Indeed, the type variable would otherwise be lost.
      This problem occurs for abbreviations expanding to a type
      variable, but also to many other constrained abbreviations (for
      instance, [(< x : 'a > -> unit) t = <x : 'a>]). The solution is
      that, if an abbreviation is unified with some subpart of its
      parameters, then the parameter actually does not get
      abbreviated.  It would be possible to check whether some
      information is indeed lost, but it probably does not worth it.
*)

let newtype_level = ref None

let get_newtype_level () =
  match !newtype_level with
  | None -> assert false
  | Some x -> x

(* a local constraint can be added only if the rhs
   of the constraint does not contain any Tvars.
   They need to be removed using this function *)
let reify env t =
  let newtype_level = get_newtype_level () in
  let create_fresh_constr lev name =
    let decl = new_declaration (Some (newtype_level, newtype_level)) None in
    let name = match name with Some s -> "$'"^s | _ -> "$" in
    let path = Path.Pident (Ident.create (get_new_abstract_name name)) in
    let new_env = Env.add_local_type path decl !env in
    let t = newty2 lev (Tconstr (path,[],ref Mnil))  in
    env := new_env;
    t
  in
  let visited = ref TypeSet.empty in
  let rec iterator ty =
    let ty = repr ty in
    if TypeSet.mem ty !visited then () else begin
      visited := TypeSet.add ty !visited;
      match ty.desc with
        Tvar o ->
          let t = create_fresh_constr ty.level o in
          link_type ty t;
          if ty.level < newtype_level then
            raise (Unify [t, newvar2 ty.level])
      | Tvariant r ->
          let r = row_repr r in
          if not (static_row r) then begin
            if r.row_fixed then iterator (row_more r) else
            let m = r.row_more in
            match m.desc with
              Tvar o ->
                let t = create_fresh_constr m.level o in
                let row =
                  {r with row_fields=[]; row_fixed=true; row_more = t} in
                link_type m (newty2 m.level (Tvariant row));
                if m.level < newtype_level then
                  raise (Unify [t, newvar2 m.level])
            | _ -> assert false
          end;
          iter_row iterator r
      | Tconstr (p, _, _) when is_object_type p ->
          iter_type_expr iterator (full_expand !env ty)
      | _ ->
          iter_type_expr iterator ty
    end
  in
  iterator t

let is_newtype env p =
  try
    let decl = Env.find_type p env in
    decl.type_newtype_level <> None &&
    decl.type_kind = Type_abstract &&
    decl.type_private = Public
  with Not_found -> false

let non_aliasable p decl =
  (* in_pervasives p ||  (subsumed by in_current_module) *)
  in_current_module p && decl.type_newtype_level = None

let is_instantiable env p =
  try
    let decl = Env.find_type p env in
    decl.type_kind = Type_abstract &&
    decl.type_private = Public &&
    decl.type_arity = 0 &&
    decl.type_manifest = None &&
    not (non_aliasable p decl)
  with Not_found -> false


(* PR#7113: -safe-string should be a global property *)
let compatible_paths p1 p2 =
  let open Predef in
  Path.same p1 p2 ||
  Path.same p1 path_bytes && Path.same p2 path_string ||
  Path.same p1 path_string && Path.same p2 path_bytes

(* Check for datatypes carefully; see PR#6348 *)
let rec expands_to_datatype env ty =
  let ty = repr ty in
  match ty.desc with
    Tconstr (p, _, _) ->
      begin try
        is_datatype (Env.find_type p env) ||
        expands_to_datatype env (try_expand_once env ty)
      with Not_found | Cannot_expand -> false
      end
  | _ -> false

(* mcomp type_pairs subst env t1 t2 does not raise an
   exception if it is possible that t1 and t2 are actually
   equal, assuming the types in type_pairs are equal and
   that the mapping subst holds.
   Assumes that both t1 and t2 do not contain any tvars
   and that both their objects and variants are closed
 *)

let rec mcomp type_pairs env t1 t2 =
  if t1 == t2 then () else
  let t1 = repr t1 in
  let t2 = repr t2 in
  if t1 == t2 then () else
  match (t1.desc, t2.desc) with
  | (Tvar _, _)
  | (_, Tvar _)  ->
      ()
  | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
      ()
  | _ ->
      let t1' = expand_head_opt env t1 in
      let t2' = expand_head_opt env t2 in
      (* Expansion may have changed the representative of the types... *)
      let t1' = repr t1' and t2' = repr t2' in
      if t1' == t2' then () else
      begin try TypePairs.find type_pairs (t1', t2')
      with Not_found ->
        TypePairs.add type_pairs (t1', t2') ();
        match (t1'.desc, t2'.desc) with
          (Tvar _, Tvar _) -> assert false
        | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _))
          when l1 = l2 || not (is_optional l1 || is_optional l2) ->
            mcomp type_pairs env t1 t2;
            mcomp type_pairs env u1 u2;
        | (Ttuple tl1, Ttuple tl2) ->
            mcomp_list type_pairs env tl1 tl2
        | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) ->
            mcomp_type_decl type_pairs env p1 p2 tl1 tl2
        | (Tconstr (p, _, _), _) | (_, Tconstr (p, _, _)) ->
            begin try
              let decl = Env.find_type p env in
              if non_aliasable p decl || is_datatype decl then raise (Unify [])
            with Not_found -> ()
            end
        (*
        | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when n1 = n2 ->
            mcomp_list type_pairs env tl1 tl2
        *)
        | (Tpackage _, Tpackage _) -> ()
        | (Tvariant row1, Tvariant row2) ->
            mcomp_row type_pairs env row1 row2
        | (Tobject (fi1, _), Tobject (fi2, _)) ->
            mcomp_fields type_pairs env fi1 fi2
        | (Tfield _, Tfield _) ->       (* Actually unused *)
            mcomp_fields type_pairs env t1' t2'
        | (Tnil, Tnil) ->
            ()
        | (Tpoly (t1, []), Tpoly (t2, [])) ->
            mcomp type_pairs env t1 t2
        | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
            enter_poly env univar_pairs t1 tl1 t2 tl2
              (mcomp type_pairs env)
        | (Tunivar _, Tunivar _) ->
            unify_univar t1' t2' !univar_pairs
        | (_, _) ->
            raise (Unify [])
      end

and mcomp_list type_pairs env tl1 tl2 =
  if List.length tl1 <> List.length tl2 then
    raise (Unify []);
  List.iter2 (mcomp type_pairs env) tl1 tl2

and mcomp_fields type_pairs env ty1 ty2 =
  if not (concrete_object ty1 && concrete_object ty2) then assert false;
  let (fields2, rest2) = flatten_fields ty2 in
  let (fields1, rest1) = flatten_fields ty1 in
  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
  let has_present =
    List.exists (fun (_, k, _) -> field_kind_repr k = Fpresent) in
  mcomp type_pairs env rest1 rest2;
  if has_present miss1  && (object_row ty2).desc = Tnil
  || has_present miss2  && (object_row ty1).desc = Tnil then raise (Unify []);
  List.iter
    (function (_n, k1, t1, k2, t2) ->
       mcomp_kind k1 k2;
       mcomp type_pairs env t1 t2)
    pairs

and mcomp_kind k1 k2 =
  let k1 = field_kind_repr k1 in
  let k2 = field_kind_repr k2 in
  match k1, k2 with
    (Fpresent, Fabsent)
  | (Fabsent, Fpresent) -> raise (Unify [])
  | _                   -> ()

and mcomp_row type_pairs env row1 row2 =
  let row1 = row_repr row1 and row2 = row_repr row2 in
  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
  let cannot_erase (_,f) =
    match row_field_repr f with
      Rpresent _ -> true
    | Rabsent | Reither _ -> false
  in
  if row1.row_closed && List.exists cannot_erase r2
  || row2.row_closed && List.exists cannot_erase r1 then raise (Unify []);
  List.iter
    (fun (_,f1,f2) ->
      match row_field_repr f1, row_field_repr f2 with
      | Rpresent None, (Rpresent (Some _) | Reither (_, _::_, _, _) | Rabsent)
      | Rpresent (Some _), (Rpresent None | Reither (true, _, _, _) | Rabsent)
      | (Reither (_, _::_, _, _) | Rabsent), Rpresent None
      | (Reither (true, _, _, _) | Rabsent), Rpresent (Some _) ->
          raise (Unify [])
      | Rpresent(Some t1), Rpresent(Some t2) ->
          mcomp type_pairs env t1 t2
      | Rpresent(Some t1), Reither(false, tl2, _, _) ->
          List.iter (mcomp type_pairs env t1) tl2
      | Reither(false, tl1, _, _), Rpresent(Some t2) ->
          List.iter (mcomp type_pairs env t2) tl1
      | _ -> ())
    pairs

and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 =
  try
    let decl = Env.find_type p1 env in
    let decl' = Env.find_type p2 env in
    if compatible_paths p1 p2 then begin
      let inj =
        try List.map Variance.(mem Inj) (Env.find_type p1 env).type_variance
        with Not_found -> List.map (fun _ -> false) tl1
      in
      List.iter2
        (fun i (t1,t2) -> if i then mcomp type_pairs env t1 t2)
        inj (List.combine tl1 tl2)
    end else if non_aliasable p1 decl && non_aliasable p2 decl' then
      raise (Unify [])
    else
      match decl.type_kind, decl'.type_kind with
      | Type_record (lst,r), Type_record (lst',r') when r = r' ->
          mcomp_list type_pairs env tl1 tl2;
          mcomp_record_description type_pairs env lst lst'
      | Type_variant v1, Type_variant v2 ->
          mcomp_list type_pairs env tl1 tl2;
          mcomp_variant_description type_pairs env v1 v2
      | Type_open, Type_open ->
          mcomp_list type_pairs env tl1 tl2
      | Type_abstract, Type_abstract -> ()
      | Type_abstract, _ when not (non_aliasable p1 decl)-> ()
      | _, Type_abstract when not (non_aliasable p2 decl') -> ()
      | _ -> raise (Unify [])
  with Not_found -> ()

and mcomp_type_option type_pairs env t t' =
  match t, t' with
    None, None -> ()
  | Some t, Some t' -> mcomp type_pairs env t t'
  | _ -> raise (Unify [])

and mcomp_variant_description type_pairs env xs ys =
  let rec iter = fun x y ->
    match x, y with
    | c1 :: xs, c2 :: ys   ->
      mcomp_type_option type_pairs env c1.cd_res c2.cd_res;
      begin match c1.cd_args, c2.cd_args with
      | Cstr_tuple l1, Cstr_tuple l2 -> mcomp_list type_pairs env l1 l2
      | Cstr_record l1, Cstr_record l2 ->
          mcomp_record_description type_pairs env l1 l2
      | _ -> raise (Unify [])
      end;
     if Ident.name c1.cd_id = Ident.name c2.cd_id
      then iter xs ys
      else raise (Unify [])
    | [],[] -> ()
    | _ -> raise (Unify [])
  in
  iter xs ys

and mcomp_record_description type_pairs env =
  let rec iter x y =
    match x, y with
    | l1 :: xs, l2 :: ys ->
        mcomp type_pairs env l1.ld_type l2.ld_type;
        if Ident.name l1.ld_id = Ident.name l2.ld_id &&
           l1.ld_mutable = l2.ld_mutable
        then iter xs ys
        else raise (Unify [])
    | [], [] -> ()
    | _ -> raise (Unify [])
  in
  iter

let mcomp env t1 t2 =
  mcomp (TypePairs.create 4) env t1 t2

(* Real unification *)

let find_lowest_level ty =
  let lowest = ref generic_level in
  let rec find ty =
    let ty = repr ty in
    if ty.level >= lowest_level then begin
      if ty.level < !lowest then lowest := ty.level;
      ty.level <- pivot_level - ty.level;
      iter_type_expr find ty
    end
  in find ty; unmark_type ty; !lowest

let find_newtype_level env path =
  try match (Env.find_type path env).type_newtype_level with
    Some x -> x
  | None -> raise Not_found
  with Not_found -> let lev = Path.binding_time path in (lev, lev)

let add_gadt_equation env source destination =
  if local_non_recursive_abbrev !env source destination then begin
    let destination = duplicate_type destination in
    let source_lev = find_newtype_level !env source in
    let decl = new_declaration (Some source_lev) (Some destination) in
    let newtype_level = get_newtype_level () in
    env := Env.add_local_constraint source decl newtype_level !env;
    cleanup_abbrev ()
  end

let unify_eq_set = TypePairs.create 11

let order_type_pair t1 t2 =
  if t1.id <= t2.id then (t1, t2) else (t2, t1)

let add_type_equality t1 t2 =
  TypePairs.add unify_eq_set (order_type_pair t1 t2) ()

let eq_package_path env p1 p2 =
  Path.same p1 p2 ||
  Path.same (normalize_package_path env p1) (normalize_package_path env p2)

let nondep_type' = ref (fun _ _ _ -> assert false)
let package_subtype = ref (fun _ _ _ _ _ _ _ -> assert false)

let rec concat_longident lid1 =
  let open Longident in
  function
    Lident s -> Ldot (lid1, s)
  | Ldot (lid2, s) -> Ldot (concat_longident lid1 lid2, s)
  | Lapply (lid2, lid) -> Lapply (concat_longident lid1 lid2, lid)

let nondep_instance env level id ty =
  let ty = !nondep_type' env id ty in
  if level = generic_level then duplicate_type ty else
  let old = !current_level in
  current_level := level;
  let ty = instance env ty in
  current_level := old;
  ty

(* Find the type paths nl1 in the module type mty2, and add them to the
   list (nl2, tl2). raise Not_found if impossible *)
let complete_type_list ?(allow_absent=false) env nl1 lv2 mty2 nl2 tl2 =
  let id2 = Ident.create "Pkg" in
  let env' = Env.add_module id2 mty2 env in
  let rec complete nl1 ntl2 =
    match nl1, ntl2 with
      [], _ -> ntl2
    | n :: nl, (n2, _ as nt2) :: ntl' when n >= n2 ->
        nt2 :: complete (if n = n2 then nl else nl1) ntl'
    | n :: nl, _ ->
        try
          let path =
            Env.lookup_type (concat_longident (Longident.Lident "Pkg") n) env'
          in
          match Env.find_type path env' with
            {type_arity = 0; type_kind = Type_abstract;
             type_private = Public; type_manifest = Some t2} ->
               (n, nondep_instance env' lv2 id2 t2) :: complete nl ntl2
          | {type_arity = 0; type_kind = Type_abstract;
             type_private = Public; type_manifest = None} when allow_absent ->
               complete nl ntl2
          | _ -> raise Exit
        with
        | Not_found when allow_absent -> complete nl ntl2
        | Exit -> raise Not_found
  in
  complete nl1 (List.combine nl2 tl2)

(* raise Not_found rather than Unify if the module types are incompatible *)
let unify_package env unify_list lv1 p1 n1 tl1 lv2 p2 n2 tl2 =
  let ntl2 = complete_type_list env n1 lv2 (Mty_ident p2) n2 tl2
  and ntl1 = complete_type_list env n2 lv1 (Mty_ident p1) n1 tl1 in
  unify_list (List.map snd ntl1) (List.map snd ntl2);
  if eq_package_path env p1 p2
  || !package_subtype env p1 n1 tl1 p2 n2 tl2
  && !package_subtype env p2 n2 tl2 p1 n1 tl1 then () else raise Not_found


(* force unification in Reither when one side has a non-conjunctive type *)
let rigid_variants = ref false

(* drop not force unification in Reither, even in fixed case
   (not sound, only use it when checking exhaustiveness) *)
let passive_variants = ref false
let with_passive_variants f x =
  if !passive_variants then f x else
  match passive_variants := true; f x with
  | r           -> passive_variants := false; r
  | exception e -> passive_variants := false; raise e

let unify_eq t1 t2 =
  t1 == t2 ||
  match !umode with
  | Expression -> false
  | Pattern ->
      try TypePairs.find unify_eq_set (order_type_pair t1 t2); true
      with Not_found -> false

let unify1_var env t1 t2 =
  assert (is_Tvar t1);
  occur env t1 t2;
  occur_univar env t2;
  let d1 = t1.desc in
  link_type t1 t2;
  try
    update_level env t1.level t2
  with Unify _ as e ->
    t1.desc <- d1;
    raise e

let rec unify (env:Env.t ref) t1 t2 =
  (* First step: special cases (optimizations) *)
  if t1 == t2 then () else
  let t1 = repr t1 in
  let t2 = repr t2 in
  if unify_eq t1 t2 then () else
  let reset_tracing = check_trace_gadt_instances !env in

  try
    type_changed := true;
    begin match (t1.desc, t2.desc) with
      (Tvar _, Tconstr _) when deep_occur t1 t2 ->
        unify2 env t1 t2
    | (Tconstr _, Tvar _) when deep_occur t2 t1 ->
        unify2 env t1 t2
    | (Tvar _, _) ->
        unify1_var !env t1 t2
    | (_, Tvar _) ->
        unify1_var !env t2 t1
    | (Tunivar _, Tunivar _) ->
        unify_univar t1 t2 !univar_pairs;
        update_level !env t1.level t2;
        link_type t1 t2
    | (Tconstr (p1, [], a1), Tconstr (p2, [], a2))
          when Path.same p1 p2 (* && actual_mode !env = Old *)
            (* This optimization assumes that t1 does not expand to t2
               (and conversely), so we fall back to the general case
               when any of the types has a cached expansion. *)
            && not (has_cached_expansion p1 !a1
                 || has_cached_expansion p2 !a2) ->
        update_level !env t1.level t2;
        link_type t1 t2
    | (Tconstr (p1, [], _), Tconstr (p2, [], _))
      when Env.has_local_constraints !env
      && is_newtype !env p1 && is_newtype !env p2 ->
        (* Do not use local constraints more than necessary *)
        begin try
          if find_newtype_level !env p1 < find_newtype_level !env p2 then
            unify env t1 (try_expand_once !env t2)
          else
            unify env (try_expand_once !env t1) t2
        with Cannot_expand ->
          unify2 env t1 t2
        end
    | _ ->
        unify2 env t1 t2
    end;
    reset_trace_gadt_instances reset_tracing;
  with Unify trace ->
    reset_trace_gadt_instances reset_tracing;
    raise (Unify ((t1, t2)::trace))

and unify2 env t1 t2 =
  (* Second step: expansion of abbreviations *)
  (* Expansion may change the representative of the types. *)
  ignore (expand_head_unif !env t1);
  ignore (expand_head_unif !env t2);
  let t1' = expand_head_unif !env t1 in
  let t2' = expand_head_unif !env t2 in
  let lv = min t1'.level t2'.level in
  update_level !env lv t2;
  update_level !env lv t1;
  if unify_eq t1' t2' then () else

  let t1 = repr t1 and t2 = repr t2 in
  if !trace_gadt_instances then begin
    (* All types in chains already have the same ambiguity levels *)
    let ilevel t =
      match Env.gadt_instance_level !env t with None -> 0 | Some lv -> lv in
    let lv1 = ilevel t1 and lv2 = ilevel t2 in
    if lv1 > lv2 then Env.add_gadt_instance_chain !env lv1 t2 else
    if lv2 > lv1 then Env.add_gadt_instance_chain !env lv2 t1
  end;
  let t1, t2 =
    if !Clflags.principal
    && (find_lowest_level t1' < lv || find_lowest_level t2' < lv) then
      (* Expand abbreviations hiding a lower level *)
      (* Should also do it for parameterized types, after unification... *)
      (match t1.desc with Tconstr (_, [], _) -> t1' | _ -> t1),
      (match t2.desc with Tconstr (_, [], _) -> t2' | _ -> t2)
    else (t1, t2)
  in
  if unify_eq t1 t1' || not (unify_eq t2 t2') then
    unify3 env t1 t1' t2 t2'
  else
    try unify3 env t2 t2' t1 t1' with Unify trace ->
      raise (Unify (List.map (fun (x, y) -> (y, x)) trace))

and unify3 env t1 t1' t2 t2' =
  (* Third step: truly unification *)
  (* Assumes either [t1 == t1'] or [t2 != t2'] *)
  let d1 = t1'.desc and d2 = t2'.desc in
  let create_recursion = (t2 != t2') && (deep_occur t1' t2) in

  begin match (d1, d2) with (* handle vars and univars specially *)
    (Tunivar _, Tunivar _) ->
      unify_univar t1' t2' !univar_pairs;
      link_type t1' t2'
  | (Tvar _, _) ->
      occur !env t1' t2;
      occur_univar !env t2;
      link_type t1' t2;
  | (_, Tvar _) ->
      occur !env t2' t1;
      occur_univar !env t1;
      link_type t2' t1;
  | (Tfield _, Tfield _) -> (* special case for GADTs *)
      unify_fields env t1' t2'
  | _ ->
    begin match !umode with
    | Expression ->
        occur !env t1' t2';
        link_type t1' t2
    | Pattern ->
        add_type_equality t1' t2'
    end;
    try
      begin match (d1, d2) with
        (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2 ||
        (!Clflags.classic || !umode = Pattern) &&
        not (is_optional l1 || is_optional l2) ->
          unify  env t1 t2; unify env  u1 u2;
          begin match commu_repr c1, commu_repr c2 with
            Clink r, c2 -> set_commu r c2
          | c1, Clink r -> set_commu r c1
          | _ -> ()
          end
      | (Ttuple tl1, Ttuple tl2) ->
          unify_list env tl1 tl2
      | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 ->
          if !umode = Expression || not !generate_equations then
            unify_list env tl1 tl2
          else if !assume_injective then
            set_mode_pattern ~generate:true ~injective:false
                             (fun () -> unify_list env tl1 tl2)
          else if in_current_module p1 (* || in_pervasives p1 *)
                  || List.exists (expands_to_datatype !env) [t1'; t1; t2] then
            unify_list env tl1 tl2
          else
            let inj =
              try List.map Variance.(mem Inj)
                    (Env.find_type p1 !env).type_variance
              with Not_found -> List.map (fun _ -> false) tl1
            in
            List.iter2
              (fun i (t1, t2) ->
                if i then unify env t1 t2 else
                set_mode_pattern ~generate:false ~injective:false
                  begin fun () ->
                    let snap = snapshot () in
                    try unify env t1 t2 with Unify _ ->
                      backtrack snap;
                      reify env t1; reify env t2
                  end)
              inj (List.combine tl1 tl2)
      | (Tconstr (path,[],_),
         Tconstr (path',[],_))
        when is_instantiable !env path && is_instantiable !env path'
        && !generate_equations ->
          let source, destination =
            if find_newtype_level !env path > find_newtype_level !env path'
            then  path , t2'
            else  path', t1'
          in
          add_gadt_equation env source destination
      | (Tconstr (path,[],_), _)
        when is_instantiable !env path && !generate_equations ->
          reify env t2';
          add_gadt_equation env path t2'
      | (_, Tconstr (path,[],_))
        when is_instantiable !env path && !generate_equations ->
          reify env t1';
          add_gadt_equation env path t1'
      | (Tconstr (_,_,_), _) | (_, Tconstr (_,_,_)) when !umode = Pattern ->
          reify env t1';
          reify env t2';
          if !generate_equations then mcomp !env t1' t2'
      | (Tobject (fi1, nm1), Tobject (fi2, _)) ->
          unify_fields env fi1 fi2;
          (* Type [t2'] may have been instantiated by [unify_fields] *)
          (* XXX One should do some kind of unification... *)
          begin match (repr t2').desc with
            Tobject (_, {contents = Some (_, va::_)}) when
              (match (repr va).desc with
                Tvar _|Tunivar _|Tnil -> true | _ -> false) -> ()
          | Tobject (_, nm2) -> set_name nm2 !nm1
          | _ -> ()
          end
      | (Tvariant row1, Tvariant row2) ->
          if !umode = Expression then
            unify_row env row1 row2
          else begin
            let snap = snapshot () in
            try unify_row env row1 row2
            with Unify _ ->
              backtrack snap;
              reify env t1';
              reify env t2';
              if !generate_equations then mcomp !env t1' t2'
          end
      | (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) ->
          begin match field_kind_repr kind with
            Fvar r when f <> dummy_method ->
              set_kind r Fabsent;
              if d2 = Tnil then unify env rem t2'
              else unify env (newty2 rem.level Tnil) rem
          | _      -> raise (Unify [])
          end
      | (Tnil, Tnil) ->
          ()
      | (Tpoly (t1, []), Tpoly (t2, [])) ->
          unify env t1 t2
      | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
          enter_poly !env univar_pairs t1 tl1 t2 tl2 (unify env)
      | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) ->
          begin try
            unify_package !env (unify_list env)
              t1.level p1 n1 tl1 t2.level p2 n2 tl2
          with Not_found ->
            if !umode = Expression then raise (Unify []);
            List.iter (reify env) (tl1 @ tl2);
            (* if !generate_equations then List.iter2 (mcomp !env) tl1 tl2 *)
          end
      | (_, _) ->
          raise (Unify [])
      end;
      (* XXX Commentaires + changer "create_recursion"
         ||| Comments + change "create_recursion" *)
      if create_recursion then
        match t2.desc with
          Tconstr (p, tl, abbrev) ->
            forget_abbrev abbrev p;
            let t2'' = expand_head_unif !env t2 in
            if not (closed_parameterized_type tl t2'') then
              link_type (repr t2) (repr t2')
        | _ ->
            () (* t2 has already been expanded by update_level *)
    with Unify trace ->
      t1'.desc <- d1;
      raise (Unify trace)
  end

and unify_list env tl1 tl2 =
  if List.length tl1 <> List.length tl2 then
    raise (Unify []);
  List.iter2 (unify env) tl1 tl2

(* Build a fresh row variable for unification *)
and make_rowvar level use1 rest1 use2 rest2  =
  let set_name ty name =
    match ty.desc with
      Tvar None -> log_type ty; ty.desc <- Tvar name
    | _ -> ()
  in
  let name =
    match rest1.desc, rest2.desc with
      Tvar (Some _ as name1), Tvar (Some _ as name2) ->
        if rest1.level <= rest2.level then name1 else name2
    | Tvar (Some _ as name), _ ->
        if use2 then set_name rest2 name; name
    | _, Tvar (Some _ as name) ->
        if use1 then set_name rest2 name; name
    | _ -> None
  in
  if use1 then rest1 else
  if use2 then rest2 else newvar2 ?name level

and unify_fields env ty1 ty2 =          (* Optimization *)
  let (fields1, rest1) = flatten_fields ty1
  and (fields2, rest2) = flatten_fields ty2 in
  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
  let l1 = (repr ty1).level and l2 = (repr ty2).level in
  let va = make_rowvar (min l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in
  let d1 = rest1.desc and d2 = rest2.desc in
  try
    unify env (build_fields l1 miss1 va) rest2;
    unify env rest1 (build_fields l2 miss2 va);
    List.iter
      (fun (n, k1, t1, k2, t2) ->
        unify_kind k1 k2;
        try
          if !trace_gadt_instances then update_level !env va.level t1;
          unify env t1 t2
        with Unify trace ->
          raise (Unify ((newty (Tfield(n, k1, t1, newty Tnil)),
                         newty (Tfield(n, k2, t2, newty Tnil)))::trace)))
      pairs
  with exn ->
    log_type rest1; rest1.desc <- d1;
    log_type rest2; rest2.desc <- d2;
    raise exn

and unify_kind k1 k2 =
  let k1 = field_kind_repr k1 in
  let k2 = field_kind_repr k2 in
  if k1 == k2 then () else
  match k1, k2 with
    (Fvar r, (Fvar _ | Fpresent)) -> set_kind r k2
  | (Fpresent, Fvar r)            -> set_kind r k1
  | (Fpresent, Fpresent)          -> ()
  | _                             -> assert false

and unify_row env row1 row2 =
  let row1 = row_repr row1 and row2 = row_repr row2 in
  let rm1 = row_more row1 and rm2 = row_more row2 in
  if unify_eq rm1 rm2 then () else
  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
  if r1 <> [] && r2 <> [] then begin
    let ht = Hashtbl.create (List.length r1) in
    List.iter (fun (l,_) -> Hashtbl.add ht (hash_variant l) l) r1;
    List.iter
      (fun (l,_) ->
        try raise (Tags(l, Hashtbl.find ht (hash_variant l)))
        with Not_found -> ())
      r2
  end;
  let fixed1 = row_fixed row1 and fixed2 = row_fixed row2 in
  let more =
    if fixed1 then rm1 else
    if fixed2 then rm2 else
    newty2 (min rm1.level rm2.level) (Tvar None) in
  let fixed = fixed1 || fixed2
  and closed = row1.row_closed || row2.row_closed in
  let keep switch =
    List.for_all
      (fun (_,f1,f2) ->
        let f1, f2 = switch f1 f2 in
        row_field_repr f1 = Rabsent || row_field_repr f2 <> Rabsent)
      pairs
  in
  let empty fields =
    List.for_all (fun (_,f) -> row_field_repr f = Rabsent) fields in
  (* Check whether we are going to build an empty type *)
  if closed && (empty r1 || row2.row_closed) && (empty r2 || row1.row_closed)
  && List.for_all
      (fun (_,f1,f2) ->
        row_field_repr f1 = Rabsent || row_field_repr f2 = Rabsent)
      pairs
  then raise (Unify [mkvariant [] true, mkvariant [] true]);
  let name =
    if row1.row_name <> None && (row1.row_closed || empty r2) &&
      (not row2.row_closed || keep (fun f1 f2 -> f1, f2) && empty r1)
    then row1.row_name
    else if row2.row_name <> None && (row2.row_closed || empty r1) &&
      (not row1.row_closed || keep (fun f1 f2 -> f2, f1) && empty r2)
    then row2.row_name
    else None
  in
  let row0 = {row_fields = []; row_more = more; row_bound = ();
              row_closed = closed; row_fixed = fixed; row_name = name} in
  let set_more row rest =
    let rest =
      if closed then
        filter_row_fields row.row_closed rest
      else rest in
    if rest <> [] && (row.row_closed || row_fixed row)
    || closed && row_fixed row && not row.row_closed then begin
      let t1 = mkvariant [] true and t2 = mkvariant rest false in
      raise (Unify [if row == row1 then (t1,t2) else (t2,t1)])
    end;
    (* The following test is not principal... should rather use Tnil *)
    let rm = row_more row in
    (*if !trace_gadt_instances && rm.desc = Tnil then () else*)
    if !trace_gadt_instances then
      update_level !env rm.level (newgenty (Tvariant row));
    if row_fixed row then
      if more == rm then () else
      if is_Tvar rm then link_type rm more else unify env rm more
    else
      let ty = newgenty (Tvariant {row0 with row_fields = rest}) in
      update_level !env rm.level ty;
      link_type rm ty
  in
  let md1 = rm1.desc and md2 = rm2.desc in
  begin try
    set_more row2 r1;
    set_more row1 r2;
    List.iter
      (fun (l,f1,f2) ->
        try unify_row_field env fixed1 fixed2 more l f1 f2
        with Unify trace ->
          raise (Unify ((mkvariant [l,f1] true,
                         mkvariant [l,f2] true) :: trace)))
      pairs;
    if static_row row1 then begin
      let rm = row_more row1 in
      if is_Tvar rm then link_type rm (newty2 rm.level Tnil)
    end
  with exn ->
    log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn
  end

and unify_row_field env fixed1 fixed2 more l f1 f2 =
  let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
  if f1 == f2 then () else
  match f1, f2 with
    Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2
  | Rpresent None, Rpresent None -> ()
  | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) ->
      if e1 == e2 then () else
      if (fixed1 || fixed2) && not (c1 || c2)
      && List.length tl1 = List.length tl2 then begin
        (* PR#7496 *)
        let f = Reither (c1 || c2, [], m1 || m2, ref None) in
        set_row_field e1 f; set_row_field e2 f;
        List.iter2 (unify env) tl1 tl2
      end
      else let redo =
        not !passive_variants &&
        (m1 || m2 || fixed1 || fixed2 ||
         !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) &&
        begin match tl1 @ tl2 with [] -> false
        | t1 :: tl ->
            if c1 || c2 then raise (Unify []);
            List.iter (unify env t1) tl;
            !e1 <> None || !e2 <> None
        end in
      if redo then unify_row_field env fixed1 fixed2 more l f1 f2 else
      let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
      let rec remq tl = function [] -> []
        | ty :: tl' ->
            if List.memq ty tl then remq tl tl' else ty :: remq tl tl'
      in
      let tl2' = remq tl2 tl1 and tl1' = remq tl1 tl2 in
      (* PR#6744 *)
      let split_univars =
        List.partition
          (fun ty -> try occur_univar !env ty; true with Unify _ -> false) in
      let (tl1',tlu1) = split_univars tl1'
      and (tl2',tlu2) = split_univars tl2' in
      begin match tlu1, tlu2 with
        [], [] -> ()
      | (tu1::tlu1), _ :: _ ->
          (* Attempt to merge all the types containing univars *)
          if not !passive_variants then
          List.iter (unify env tu1) (tlu1@tlu2)
      | (tu::_, []) | ([], tu::_) -> occur_univar !env tu
      end;
      (* Is this handling of levels really principal? *)
      List.iter (update_level !env (repr more).level) (tl1' @ tl2');
      let e = ref None in
      let f1' = Reither(c1 || c2, tl1', m1 || m2, e)
      and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in
      set_row_field e1 f1'; set_row_field e2 f2';
  | Reither(_, _, false, e1), Rabsent when not fixed1 -> set_row_field e1 f2
  | Rabsent, Reither(_, _, false, e2) when not fixed2 -> set_row_field e2 f1
  | Rabsent, Rabsent -> ()
  | Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 ->
      set_row_field e1 f2;
      update_level !env (repr more).level t2;
      (try List.iter (fun t1 -> unify env t1 t2) tl
      with exn -> e1 := None; raise exn)
  | Rpresent(Some t1), Reither(false, tl, _, e2) when not fixed2 ->
      set_row_field e2 f1;
      update_level !env (repr more).level t1;
      (try List.iter (unify env t1) tl
      with exn -> e2 := None; raise exn)
  | Reither(true, [], _, e1), Rpresent None when not fixed1 ->
      set_row_field e1 f2
  | Rpresent None, Reither(true, [], _, e2) when not fixed2 ->
      set_row_field e2 f1
  | _ -> raise (Unify [])


let unify env ty1 ty2 =
  let snap = Btype.snapshot () in
  try
    unify env ty1 ty2
  with
    Unify trace ->
      undo_compress snap;
      raise (Unify (expand_trace !env trace))
  | Recursive_abbrev ->
      undo_compress snap;
      raise (Unification_recursive_abbrev (expand_trace !env [(ty1,ty2)]))

let unify_gadt ~newtype_level:lev (env:Env.t ref) ty1 ty2 =
  try
    univar_pairs := [];
    newtype_level := Some lev;
    set_mode_pattern ~generate:true ~injective:true
                     (fun () -> unify env ty1 ty2);
    newtype_level := None;
    TypePairs.clear unify_eq_set;
  with e ->
    newtype_level := None;
    TypePairs.clear unify_eq_set;
    raise e

let unify_var env t1 t2 =
  let t1 = repr t1 and t2 = repr t2 in
  if t1 == t2 then () else
  match t1.desc, t2.desc with
    Tvar _, Tconstr _ when deep_occur t1 t2 ->
      unify (ref env) t1 t2
  | Tvar _, _ ->
      let reset_tracing = check_trace_gadt_instances env in
      begin try
        occur env t1 t2;
        update_level env t1.level t2;
        link_type t1 t2;
        reset_trace_gadt_instances reset_tracing;
      with Unify trace ->
        reset_trace_gadt_instances reset_tracing;
        let expanded_trace = expand_trace env ((t1,t2)::trace) in
        raise (Unify expanded_trace)
      end
  | _ ->
      unify (ref env) t1 t2

let _ = unify' := unify_var

let unify_pairs env ty1 ty2 pairs =
  univar_pairs := pairs;
  unify env ty1 ty2

let unify env ty1 ty2 =
  unify_pairs (ref env) ty1 ty2 []



(**** Special cases of unification ****)

let expand_head_trace env t =
  let reset_tracing = check_trace_gadt_instances env in
  let t = expand_head_unif env t in
  reset_trace_gadt_instances reset_tracing;
  t

(*
   Unify [t] and [l:'a -> 'b]. Return ['a] and ['b].
   In label mode, label mismatch is accepted when
   (1) the requested label is ""
   (2) the original label is not optional
*)

let filter_arrow env t l =
  let t = expand_head_trace env t in
  match t.desc with
    Tvar _ ->
      let lv = t.level in
      let t1 = newvar2 lv and t2 = newvar2 lv in
      let t' = newty2 lv (Tarrow (l, t1, t2, Cok)) in
      link_type t t';
      (t1, t2)
  | Tarrow(l', t1, t2, _)
    when l = l' || !Clflags.classic && l = Nolabel && not (is_optional l') ->
      (t1, t2)
  | _ ->
      raise (Unify [])

(* Used by [filter_method]. *)
let rec filter_method_field env name priv ty =
  let ty = expand_head_trace env ty in
  match ty.desc with
    Tvar _ ->
      let level = ty.level in
      let ty1 = newvar2 level and ty2 = newvar2 level in
      let ty' = newty2 level (Tfield (name,
                                      begin match priv with
                                        Private -> Fvar (ref None)
                                      | Public  -> Fpresent
                                      end,
                                      ty1, ty2))
      in
      link_type ty ty';
      ty1
  | Tfield(n, kind, ty1, ty2) ->
      let kind = field_kind_repr kind in
      if (n = name) && (kind <> Fabsent) then begin
        if priv = Public then
          unify_kind kind Fpresent;
        ty1
      end else
        filter_method_field env name priv ty2
  | _ ->
      raise (Unify [])

(* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *)
let filter_method env name priv ty =
  let ty = expand_head_trace env ty in
  match ty.desc with
    Tvar _ ->
      let ty1 = newvar () in
      let ty' = newobj ty1 in
      update_level env ty.level ty';
      link_type ty ty';
      filter_method_field env name priv ty1
  | Tobject(f, _) ->
      filter_method_field env name priv f
  | _ ->
      raise (Unify [])

let check_filter_method env name priv ty =
  ignore(filter_method env name priv ty)

let filter_self_method env lab priv meths ty =
  let ty' = filter_method env lab priv ty in
  try
    Meths.find lab !meths
  with Not_found ->
    let pair = (Ident.create lab, ty') in
    meths := Meths.add lab pair !meths;
    pair


                        (***********************************)
                        (*  Matching between type schemes  *)
                        (***********************************)

(*
   Update the level of [ty]. First check that the levels of generic
   variables from the subject are not lowered.
*)
let moregen_occur env level ty =
  let rec occur ty =
    let ty = repr ty in
    if ty.level > level then begin
      if is_Tvar ty && ty.level >= generic_level - 1 then raise Occur;
      ty.level <- pivot_level - ty.level;
      match ty.desc with
        Tvariant row when static_row row ->
          iter_row occur row
      | _ ->
          iter_type_expr occur ty
    end
  in
  begin try
    occur ty; unmark_type ty
  with Occur ->
    unmark_type ty; raise (Unify [])
  end;
  (* also check for free univars *)
  occur_univar env ty;
  update_level env level ty

let may_instantiate inst_nongen t1 =
  if inst_nongen then t1.level <> generic_level - 1
                 else t1.level =  generic_level

let rec moregen inst_nongen type_pairs env t1 t2 =
  if t1 == t2 then () else
  let t1 = repr t1 in
  let t2 = repr t2 in
  if t1 == t2 then () else

  try
    match (t1.desc, t2.desc) with
      (Tvar _, _) when may_instantiate inst_nongen t1 ->
        moregen_occur env t1.level t2;
        occur env t1 t2;
        link_type t1 t2
    | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
        ()
    | _ ->
        let t1' = expand_head env t1 in
        let t2' = expand_head env t2 in
        (* Expansion may have changed the representative of the types... *)
        let t1' = repr t1' and t2' = repr t2' in
        if t1' == t2' then () else
        begin try
          TypePairs.find type_pairs (t1', t2')
        with Not_found ->
          TypePairs.add type_pairs (t1', t2') ();
          match (t1'.desc, t2'.desc) with
            (Tvar _, _) when may_instantiate inst_nongen t1' ->
              moregen_occur env t1'.level t2;
              link_type t1' t2
          | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
            || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
              moregen inst_nongen type_pairs env t1 t2;
              moregen inst_nongen type_pairs env u1 u2
          | (Ttuple tl1, Ttuple tl2) ->
              moregen_list inst_nongen type_pairs env tl1 tl2
          | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
                when Path.same p1 p2 ->
              moregen_list inst_nongen type_pairs env tl1 tl2
          | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) ->
              begin try
                unify_package env (moregen_list inst_nongen type_pairs env)
                  t1'.level p1 n1 tl1 t2'.level p2 n2 tl2
              with Not_found -> raise (Unify [])
              end
          | (Tvariant row1, Tvariant row2) ->
              moregen_row inst_nongen type_pairs env row1 row2
          | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) ->
              moregen_fields inst_nongen type_pairs env fi1 fi2
          | (Tfield _, Tfield _) ->           (* Actually unused *)
              moregen_fields inst_nongen type_pairs env t1' t2'
          | (Tnil, Tnil) ->
              ()
          | (Tpoly (t1, []), Tpoly (t2, [])) ->
              moregen inst_nongen type_pairs env t1 t2
          | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
              enter_poly env univar_pairs t1 tl1 t2 tl2
                (moregen inst_nongen type_pairs env)
          | (Tunivar _, Tunivar _) ->
              unify_univar t1' t2' !univar_pairs
          | (_, _) ->
              raise (Unify [])
        end
  with Unify trace ->
    raise (Unify ((t1, t2)::trace))

and moregen_list inst_nongen type_pairs env tl1 tl2 =
  if List.length tl1 <> List.length tl2 then
    raise (Unify []);
  List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2

and moregen_fields inst_nongen type_pairs env ty1 ty2 =
  let (fields1, rest1) = flatten_fields ty1
  and (fields2, rest2) = flatten_fields ty2 in
  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
  if miss1 <> [] then raise (Unify []);
  moregen inst_nongen type_pairs env rest1
    (build_fields (repr ty2).level miss2 rest2);
  List.iter
    (fun (n, k1, t1, k2, t2) ->
       moregen_kind k1 k2;
       try moregen inst_nongen type_pairs env t1 t2 with Unify trace ->
         raise (Unify ((newty (Tfield(n, k1, t1, rest2)),
                        newty (Tfield(n, k2, t2, rest2)))::trace)))
    pairs

and moregen_kind k1 k2 =
  let k1 = field_kind_repr k1 in
  let k2 = field_kind_repr k2 in
  if k1 == k2 then () else
  match k1, k2 with
    (Fvar r, (Fvar _ | Fpresent))  -> set_kind r k2
  | (Fpresent, Fpresent)           -> ()
  | _                              -> raise (Unify [])

and moregen_row inst_nongen type_pairs env row1 row2 =
  let row1 = row_repr row1 and row2 = row_repr row2 in
  let rm1 = repr row1.row_more and rm2 = repr row2.row_more in
  if rm1 == rm2 then () else
  let may_inst =
    is_Tvar rm1 && may_instantiate inst_nongen rm1 || rm1.desc = Tnil in
  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
  let r1, r2 =
    if row2.row_closed then
      filter_row_fields may_inst r1, filter_row_fields false r2
    else r1, r2
  in
  if r1 <> [] || row1.row_closed && (not row2.row_closed || r2 <> [])
  then raise (Unify []);
  begin match rm1.desc, rm2.desc with
    Tunivar _, Tunivar _ ->
      unify_univar rm1 rm2 !univar_pairs
  | Tunivar _, _ | _, Tunivar _ ->
      raise (Unify [])
  | _ when static_row row1 -> ()
  | _ when may_inst ->
      let ext =
        newgenty (Tvariant {row2 with row_fields = r2; row_name = None})
      in
      moregen_occur env rm1.level ext;
      link_type rm1 ext
  | Tconstr _, Tconstr _ ->
      moregen inst_nongen type_pairs env rm1 rm2
  | _ -> raise (Unify [])
  end;
  List.iter
    (fun (_l,f1,f2) ->
      let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
      if f1 == f2 then () else
      match f1, f2 with
        Rpresent(Some t1), Rpresent(Some t2) ->
          moregen inst_nongen type_pairs env t1 t2
      | Rpresent None, Rpresent None -> ()
      | Reither(false, tl1, _, e1), Rpresent(Some t2) when may_inst ->
          set_row_field e1 f2;
          List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1
      | Reither(c1, tl1, _, e1), Reither(c2, tl2, m2, e2) ->
          if e1 != e2 then begin
            if c1 && not c2 then raise(Unify []);
            set_row_field e1 (Reither (c2, [], m2, e2));
            if List.length tl1 = List.length tl2 then
              List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2
            else match tl2 with
              t2 :: _ ->
                List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2)
                  tl1
            | [] ->
                if tl1 <> [] then raise (Unify [])
          end
      | Reither(true, [], _, e1), Rpresent None when may_inst ->
          set_row_field e1 f2
      | Reither(_, _, _, e1), Rabsent when may_inst ->
          set_row_field e1 f2
      | Rabsent, Rabsent -> ()
      | _ -> raise (Unify []))
    pairs

(* Must empty univar_pairs first *)
let moregen inst_nongen type_pairs env patt subj =
  univar_pairs := [];
  moregen inst_nongen type_pairs env patt subj

(*
   Non-generic variable can be instantiated only if [inst_nongen] is
   true. So, [inst_nongen] should be set to false if the subject might
   contain non-generic variables (and we do not want them to be
   instantiated).
   Usually, the subject is given by the user, and the pattern
   is unimportant.  So, no need to propagate abbreviations.
*)
let moregeneral env inst_nongen pat_sch subj_sch =
  let old_level = !current_level in
  current_level := generic_level - 1;
  (*
     Generic variables are first duplicated with [instance].  So,
     their levels are lowered to [generic_level - 1].  The subject is
     then copied with [duplicate_type].  That way, its levels won't be
     changed.
  *)
  let subj = duplicate_type (instance env subj_sch) in
  current_level := generic_level;
  (* Duplicate generic variables *)
  let patt = instance env pat_sch in
  let res =
    try moregen inst_nongen (TypePairs.create 13) env patt subj; true with
      Unify _ -> false
  in
  current_level := old_level;
  res


(* Alternative approach: "rigidify" a type scheme,
   and check validity after unification *)
(* Simpler, no? *)

let rec rigidify_rec vars ty =
  let ty = repr ty in
  if ty.level >= lowest_level then begin
    ty.level <- pivot_level - ty.level;
    match ty.desc with
    | Tvar _ ->
        if not (List.memq ty !vars) then vars := ty :: !vars
    | Tvariant row ->
        let row = row_repr row in
        let more = repr row.row_more in
        if is_Tvar more && not (row_fixed row) then begin
          let more' = newty2 more.level more.desc in
          let row' = {row with row_fixed=true; row_fields=[]; row_more=more'}
          in link_type more (newty2 ty.level (Tvariant row'))
        end;
        iter_row (rigidify_rec vars) row;
        (* only consider the row variable if the variant is not static *)
        if not (static_row row) then rigidify_rec vars (row_more row)
    | _ ->
        iter_type_expr (rigidify_rec vars) ty
  end

let rigidify ty =
  let vars = ref [] in
  rigidify_rec vars ty;
  unmark_type ty;
  !vars

let all_distinct_vars env vars =
  let tyl = ref [] in
  List.for_all
    (fun ty ->
      let ty = expand_head env ty in
      if List.memq ty !tyl then false else
      (tyl := ty :: !tyl; is_Tvar ty))
    vars

let matches env ty ty' =
  let snap = snapshot () in
  let vars = rigidify ty in
  cleanup_abbrev ();
  let ok =
    try unify env ty ty'; all_distinct_vars env vars
    with Unify _ -> false
  in
  backtrack snap;
  ok


                 (*********************************************)
                 (*  Equivalence between parameterized types  *)
                 (*********************************************)

let expand_head_rigid env ty =
  let old = !rigid_variants in
  rigid_variants := true;
  let ty' = expand_head env ty in
  rigid_variants := old; ty'

let normalize_subst subst =
  if List.exists
      (function {desc=Tlink _}, _ | _, {desc=Tlink _} -> true | _ -> false)
      !subst
  then subst := List.map (fun (t1,t2) -> repr t1, repr t2) !subst

let rec eqtype rename type_pairs subst env t1 t2 =
  if t1 == t2 then () else
  let t1 = repr t1 in
  let t2 = repr t2 in
  if t1 == t2 then () else

  try
    match (t1.desc, t2.desc) with
      (Tvar _, Tvar _) when rename ->
        begin try
          normalize_subst subst;
          if List.assq t1 !subst != t2 then raise (Unify [])
        with Not_found ->
          if List.exists (fun (_, t) -> t == t2) !subst then raise (Unify []);
          subst := (t1, t2) :: !subst
        end
    | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
        ()
    | _ ->
        let t1' = expand_head_rigid env t1 in
        let t2' = expand_head_rigid env t2 in
        (* Expansion may have changed the representative of the types... *)
        let t1' = repr t1' and t2' = repr t2' in
        if t1' == t2' then () else
        begin try
          TypePairs.find type_pairs (t1', t2')
        with Not_found ->
          TypePairs.add type_pairs (t1', t2') ();
          match (t1'.desc, t2'.desc) with
            (Tvar _, Tvar _) when rename ->
              begin try
                normalize_subst subst;
                if List.assq t1' !subst != t2' then raise (Unify [])
              with Not_found ->
                if List.exists (fun (_, t) -> t == t2') !subst
                then raise (Unify []);
                subst := (t1', t2') :: !subst
              end
          | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
            || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
              eqtype rename type_pairs subst env t1 t2;
              eqtype rename type_pairs subst env u1 u2;
          | (Ttuple tl1, Ttuple tl2) ->
              eqtype_list rename type_pairs subst env tl1 tl2
          | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
                when Path.same p1 p2 ->
              eqtype_list rename type_pairs subst env tl1 tl2
          | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) ->
              begin try
                unify_package env (eqtype_list rename type_pairs subst env)
                  t1'.level p1 n1 tl1 t2'.level p2 n2 tl2
              with Not_found -> raise (Unify [])
              end
          | (Tvariant row1, Tvariant row2) ->
              eqtype_row rename type_pairs subst env row1 row2
          | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) ->
              eqtype_fields rename type_pairs subst env fi1 fi2
          | (Tfield _, Tfield _) ->       (* Actually unused *)
              eqtype_fields rename type_pairs subst env t1' t2'
          | (Tnil, Tnil) ->
              ()
          | (Tpoly (t1, []), Tpoly (t2, [])) ->
              eqtype rename type_pairs subst env t1 t2
          | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
              enter_poly env univar_pairs t1 tl1 t2 tl2
                (eqtype rename type_pairs subst env)
          | (Tunivar _, Tunivar _) ->
              unify_univar t1' t2' !univar_pairs
          | (_, _) ->
              raise (Unify [])
        end
  with Unify trace ->
    raise (Unify ((t1, t2)::trace))

and eqtype_list rename type_pairs subst env tl1 tl2 =
  if List.length tl1 <> List.length tl2 then
    raise (Unify []);
  List.iter2 (eqtype rename type_pairs subst env) tl1 tl2

and eqtype_fields rename type_pairs subst env ty1 ty2 =
  let (fields1, rest1) = flatten_fields ty1 in
  let (fields2, rest2) = flatten_fields ty2 in
  (* First check if same row => already equal *)
  let same_row =
    rest1 == rest2 || TypePairs.mem type_pairs (rest1,rest2) ||
    (rename && List.mem (rest1, rest2) !subst)
  in
  if same_row then () else
  (* Try expansion, needed when called from Includecore.type_manifest *)
  match expand_head_rigid env rest2 with
    {desc=Tobject(ty2,_)} -> eqtype_fields rename type_pairs subst env ty1 ty2
  | _ ->
  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
  eqtype rename type_pairs subst env rest1 rest2;
  if (miss1 <> []) || (miss2 <> []) then raise (Unify []);
  List.iter
    (function (n, k1, t1, k2, t2) ->
       eqtype_kind k1 k2;
       try eqtype rename type_pairs subst env t1 t2 with Unify trace ->
         raise (Unify ((newty (Tfield(n, k1, t1, rest2)),
                        newty (Tfield(n, k2, t2, rest2)))::trace)))
    pairs

and eqtype_kind k1 k2 =
  let k1 = field_kind_repr k1 in
  let k2 = field_kind_repr k2 in
  match k1, k2 with
    (Fvar _, Fvar _)
  | (Fpresent, Fpresent) -> ()
  | _                    -> raise (Unify [])

and eqtype_row rename type_pairs subst env row1 row2 =
  (* Try expansion, needed when called from Includecore.type_manifest *)
  match expand_head_rigid env (row_more row2) with
    {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2
  | _ ->
  let row1 = row_repr row1 and row2 = row_repr row2 in
  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
  if row1.row_closed <> row2.row_closed
  || not row1.row_closed && (r1 <> [] || r2 <> [])
  || filter_row_fields false (r1 @ r2) <> []
  then raise (Unify []);
  if not (static_row row1) then
    eqtype rename type_pairs subst env row1.row_more row2.row_more;
  List.iter
    (fun (_,f1,f2) ->
      match row_field_repr f1, row_field_repr f2 with
        Rpresent(Some t1), Rpresent(Some t2) ->
          eqtype rename type_pairs subst env t1 t2
      | Reither(c1, [], _, _), Reither(c2, [], _, _) when c1 = c2 ->
          ()
      | Reither(c1, t1::tl1, _, _), Reither(c2, t2::tl2, _, _) when c1 = c2 ->
          eqtype rename type_pairs subst env t1 t2;
          if List.length tl1 = List.length tl2 then
            (* if same length allow different types (meaning?) *)
            List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
          else begin
            (* otherwise everything must be equal *)
            List.iter (eqtype rename type_pairs subst env t1) tl2;
            List.iter (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1
          end
      | Rpresent None, Rpresent None -> ()
      | Rabsent, Rabsent -> ()
      | _ -> raise (Unify []))
    pairs

(* Must empty univar_pairs first *)
let eqtype_list rename type_pairs subst env tl1 tl2 =
  univar_pairs := [];
  let snap = Btype.snapshot () in
  try eqtype_list rename type_pairs subst env tl1 tl2; backtrack snap
  with exn -> backtrack snap; raise exn

let eqtype rename type_pairs subst env t1 t2 =
  eqtype_list rename type_pairs subst env [t1] [t2]

(* Two modes: with or without renaming of variables *)
let equal env rename tyl1 tyl2 =
  try
    eqtype_list rename (TypePairs.create 11) (ref []) env tyl1 tyl2; true
  with
    Unify _ -> false


                          (*************************)
                          (*  Class type matching  *)
                          (*************************)


type class_match_failure =
    CM_Virtual_class
  | CM_Parameter_arity_mismatch of int * int
  | CM_Type_parameter_mismatch of Env.t * (type_expr * type_expr) list
  | CM_Class_type_mismatch of Env.t * class_type * class_type
  | CM_Parameter_mismatch of Env.t * (type_expr * type_expr) list
  | CM_Val_type_mismatch of string * Env.t * (type_expr * type_expr) list
  | CM_Meth_type_mismatch of string * Env.t * (type_expr * type_expr) list
  | CM_Non_mutable_value of string
  | CM_Non_concrete_value of string
  | CM_Missing_value of string
  | CM_Missing_method of string
  | CM_Hide_public of string
  | CM_Hide_virtual of string * string
  | CM_Public_method of string
  | CM_Private_method of string
  | CM_Virtual_method of string

exception Failure of class_match_failure list

let rec moregen_clty trace type_pairs env cty1 cty2 =
  try
    match cty1, cty2 with
      Cty_constr (_, _, cty1), _ ->
        moregen_clty true type_pairs env cty1 cty2
    | _, Cty_constr (_, _, cty2) ->
        moregen_clty true type_pairs env cty1 cty2
    | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') when l1 = l2 ->
        begin try moregen true type_pairs env ty1 ty2 with Unify trace ->
          raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)])
        end;
        moregen_clty false type_pairs env cty1' cty2'
    | Cty_signature sign1, Cty_signature sign2 ->
        let ty1 = object_fields (repr sign1.csig_self) in
        let ty2 = object_fields (repr sign2.csig_self) in
        let (fields1, _rest1) = flatten_fields ty1
        and (fields2, _rest2) = flatten_fields ty2 in
        let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in
        List.iter
          (fun (lab, _k1, t1, _k2, t2) ->
            begin try moregen true type_pairs env t1 t2 with Unify trace ->
              raise (Failure [CM_Meth_type_mismatch
                                 (lab, env, expand_trace env trace)])
           end)
        pairs;
      Vars.iter
        (fun lab (_mut, _v, ty) ->
           let (_mut', _v', ty') = Vars.find lab sign1.csig_vars in
           try moregen true type_pairs env ty' ty with Unify trace ->
             raise (Failure [CM_Val_type_mismatch
                                (lab, env, expand_trace env trace)]))
        sign2.csig_vars
  | _ ->
      raise (Failure [])
  with
    Failure error when trace || error = [] ->
      raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error))

let match_class_types ?(trace=true) env pat_sch subj_sch =
  let type_pairs = TypePairs.create 53 in
  let old_level = !current_level in
  current_level := generic_level - 1;
  (*
     Generic variables are first duplicated with [instance].  So,
     their levels are lowered to [generic_level - 1].  The subject is
     then copied with [duplicate_type].  That way, its levels won't be
     changed.
  *)
  let (_, subj_inst) = instance_class [] subj_sch in
  let subj = duplicate_class_type subj_inst in
  current_level := generic_level;
  (* Duplicate generic variables *)
  let (_, patt) = instance_class [] pat_sch in
  let res =
    let sign1 = signature_of_class_type patt in
    let sign2 = signature_of_class_type subj in
    let t1 = repr sign1.csig_self in
    let t2 = repr sign2.csig_self in
    TypePairs.add type_pairs (t1, t2) ();
    let (fields1, rest1) = flatten_fields (object_fields t1)
    and (fields2, rest2) = flatten_fields (object_fields t2) in
    let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
    let error =
      List.fold_right
        (fun (lab, k, _) err ->
           let err =
             let k = field_kind_repr k in
             begin match k with
               Fvar r -> set_kind r Fabsent; err
             | _      -> CM_Hide_public lab::err
             end
           in
           if Concr.mem lab sign1.csig_concr then err
           else CM_Hide_virtual ("method", lab) :: err)
        miss1 []
    in
    let missing_method = List.map (fun (m, _, _) -> m) miss2 in
    let error =
      (List.map (fun m -> CM_Missing_method m) missing_method) @ error
    in
    (* Always succeeds *)
    moregen true type_pairs env rest1 rest2;
    let error =
      List.fold_right
        (fun (lab, k1, _t1, k2, _t2) err ->
           try moregen_kind k1 k2; err with
             Unify _ -> CM_Public_method lab::err)
        pairs error
    in
    let error =
      Vars.fold
        (fun lab (mut, vr, _ty) err ->
          try
            let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in
            if mut = Mutable && mut' <> Mutable then
              CM_Non_mutable_value lab::err
            else if vr = Concrete && vr' <> Concrete then
              CM_Non_concrete_value lab::err
            else
              err
          with Not_found ->
            CM_Missing_value lab::err)
        sign2.csig_vars error
    in
    let error =
      Vars.fold
        (fun lab (_,vr,_) err ->
          if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then
            CM_Hide_virtual ("instance variable", lab) :: err
          else err)
        sign1.csig_vars error
    in
    let error =
      List.fold_right
        (fun e l ->
           if List.mem e missing_method then l else CM_Virtual_method e::l)
        (Concr.elements (Concr.diff sign2.csig_concr sign1.csig_concr))
        error
    in
    match error with
      [] ->
        begin try
          moregen_clty trace type_pairs env patt subj;
          []
        with
          Failure r -> r
        end
    | error ->
        CM_Class_type_mismatch (env, patt, subj)::error
  in
  current_level := old_level;
  res

let rec equal_clty trace type_pairs subst env cty1 cty2 =
  try
    match cty1, cty2 with
      Cty_constr (_, _, cty1), Cty_constr (_, _, cty2) ->
        equal_clty true type_pairs subst env cty1 cty2
    | Cty_constr (_, _, cty1), _ ->
        equal_clty true type_pairs subst env cty1 cty2
    | _, Cty_constr (_, _, cty2) ->
        equal_clty true type_pairs subst env cty1 cty2
    | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') when l1 = l2 ->
        begin try eqtype true type_pairs subst env ty1 ty2 with Unify trace ->
          raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)])
        end;
        equal_clty false type_pairs subst env cty1' cty2'
    | Cty_signature sign1, Cty_signature sign2 ->
        let ty1 = object_fields (repr sign1.csig_self) in
        let ty2 = object_fields (repr sign2.csig_self) in
        let (fields1, _rest1) = flatten_fields ty1
        and (fields2, _rest2) = flatten_fields ty2 in
        let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in
        List.iter
          (fun (lab, _k1, t1, _k2, t2) ->
             begin try eqtype true type_pairs subst env t1 t2 with
               Unify trace ->
                 raise (Failure [CM_Meth_type_mismatch
                                    (lab, env, expand_trace env trace)])
             end)
          pairs;
        Vars.iter
          (fun lab (_, _, ty) ->
             let (_, _, ty') = Vars.find lab sign1.csig_vars in
             try eqtype true type_pairs subst env ty' ty with Unify trace ->
               raise (Failure [CM_Val_type_mismatch
                                  (lab, env, expand_trace env trace)]))
          sign2.csig_vars
    | _ ->
        raise
          (Failure (if trace then []
                    else [CM_Class_type_mismatch (env, cty1, cty2)]))
  with
    Failure error when trace ->
      raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error))

let match_class_declarations env patt_params patt_type subj_params subj_type =
  let type_pairs = TypePairs.create 53 in
  let subst = ref [] in
  let sign1 = signature_of_class_type patt_type in
  let sign2 = signature_of_class_type subj_type in
  let t1 = repr sign1.csig_self in
  let t2 = repr sign2.csig_self in
  TypePairs.add type_pairs (t1, t2) ();
  let (fields1, rest1) = flatten_fields (object_fields t1)
  and (fields2, rest2) = flatten_fields (object_fields t2) in
  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
  let error =
    List.fold_right
      (fun (lab, k, _) err ->
        let err =
          let k = field_kind_repr k in
          begin match k with
            Fvar _ -> err
          | _      -> CM_Hide_public lab::err
          end
        in
        if Concr.mem lab sign1.csig_concr then err
        else CM_Hide_virtual ("method", lab) :: err)
      miss1 []
  in
  let missing_method = List.map (fun (m, _, _) -> m) miss2 in
  let error =
    (List.map (fun m -> CM_Missing_method m) missing_method) @ error
  in
  (* Always succeeds *)
  eqtype true type_pairs subst env rest1 rest2;
  let error =
    List.fold_right
      (fun (lab, k1, _t1, k2, _t2) err ->
        let k1 = field_kind_repr k1 in
        let k2 = field_kind_repr k2 in
        match k1, k2 with
          (Fvar _, Fvar _)
        | (Fpresent, Fpresent) -> err
        | (Fvar _, Fpresent)   -> CM_Private_method lab::err
        | (Fpresent, Fvar _)  -> CM_Public_method lab::err
        | _                    -> assert false)
      pairs error
  in
  let error =
    Vars.fold
      (fun lab (mut, vr, _ty) err ->
         try
           let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in
           if mut = Mutable && mut' <> Mutable then
             CM_Non_mutable_value lab::err
           else if vr = Concrete && vr' <> Concrete then
             CM_Non_concrete_value lab::err
           else
             err
         with Not_found ->
           CM_Missing_value lab::err)
      sign2.csig_vars error
  in
  let error =
    Vars.fold
      (fun lab (_,vr,_) err ->
        if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then
          CM_Hide_virtual ("instance variable", lab) :: err
        else err)
      sign1.csig_vars error
  in
  let error =
    List.fold_right
      (fun e l ->
        if List.mem e missing_method then l else CM_Virtual_method e::l)
      (Concr.elements (Concr.diff sign2.csig_concr sign1.csig_concr))
      error
  in
  match error with
    [] ->
      begin try
        let lp = List.length patt_params in
        let ls = List.length subj_params in
        if lp  <> ls then
          raise (Failure [CM_Parameter_arity_mismatch (lp, ls)]);
        List.iter2 (fun p s ->
          try eqtype true type_pairs subst env p s with Unify trace ->
            raise (Failure [CM_Type_parameter_mismatch
                               (env, expand_trace env trace)]))
          patt_params subj_params;
     (* old code: equal_clty false type_pairs subst env patt_type subj_type; *)
        equal_clty false type_pairs subst env
          (Cty_signature sign1) (Cty_signature sign2);
        (* Use moregeneral for class parameters, need to recheck everything to
           keeps relationships (PR#4824) *)
        let clty_params =
          List.fold_right (fun ty cty -> Cty_arrow (Labelled "*",ty,cty)) in
        match_class_types ~trace:false env
          (clty_params patt_params patt_type)
          (clty_params subj_params subj_type)
      with
        Failure r -> r
      end
  | error ->
      error


                              (***************)
                              (*  Subtyping  *)
                              (***************)


(**** Build a subtype of a given type. ****)

(* build_subtype:
   [visited] traces traversed object and variant types
   [loops] is a mapping from variables to variables, to reproduce
     positive loops in a class type
   [posi] true if the current variance is positive
   [level] number of expansions/enlargement allowed on this branch *)

let warn = ref false  (* whether double coercion might do better *)
let pred_expand n = if n mod 2 = 0 && n > 0 then pred n else n
let pred_enlarge n = if n mod 2 = 1 then pred n else n

type change = Unchanged | Equiv | Changed
let collect l = List.fold_left (fun c1 (_, c2) -> max c1 c2) Unchanged l

let rec filter_visited = function
    [] -> []
  | {desc=Tobject _|Tvariant _} :: _ as l -> l
  | _ :: l -> filter_visited l

let memq_warn t visited =
  if List.memq t visited then (warn := true; true) else false

let rec lid_of_path ?(hash="") = function
    Path.Pident id ->
      Longident.Lident (hash ^ Ident.name id)
  | Path.Pdot (p1, s, _) ->
      Longident.Ldot (lid_of_path p1, hash ^ s)
  | Path.Papply (p1, p2) ->
      Longident.Lapply (lid_of_path ~hash p1, lid_of_path p2)

let find_cltype_for_path env p =
  let cl_path = Env.lookup_type (lid_of_path ~hash:"#" p) env in
  let cl_abbr = Env.find_type cl_path env in

  match cl_abbr.type_manifest with
    Some ty ->
      begin match (repr ty).desc with
        Tobject(_,{contents=Some(p',_)}) when Path.same p p' -> cl_abbr, ty
      | _ -> raise Not_found
      end
  | None -> assert false

let has_constr_row' env t =
  has_constr_row (expand_abbrev env t)

let rec build_subtype env visited loops posi level t =
  let t = repr t in
  match t.desc with
    Tvar _ ->
      if posi then
        try
          let t' = List.assq t loops in
          warn := true;
          (t', Equiv)
        with Not_found ->
          (t, Unchanged)
      else
        (t, Unchanged)
  | Tarrow(l, t1, t2, _) ->
      if memq_warn t visited then (t, Unchanged) else
      let visited = t :: visited in
      let (t1', c1) = build_subtype env visited loops (not posi) level t1 in
      let (t2', c2) = build_subtype env visited loops posi level t2 in
      let c = max c1 c2 in
      if c > Unchanged then (newty (Tarrow(l, t1', t2', Cok)), c)
      else (t, Unchanged)
  | Ttuple tlist ->
      if memq_warn t visited then (t, Unchanged) else
      let visited = t :: visited in
      let tlist' =
        List.map (build_subtype env visited loops posi level) tlist
      in
      let c = collect tlist' in
      if c > Unchanged then (newty (Ttuple (List.map fst tlist')), c)
      else (t, Unchanged)
  | Tconstr(p, tl, abbrev)
    when level > 0 && generic_abbrev env p && safe_abbrev env t
    && not (has_constr_row' env t) ->
      let t' = repr (expand_abbrev env t) in
      let level' = pred_expand level in
      begin try match t'.desc with
        Tobject _ when posi && not (opened_object t') ->
          let cl_abbr, body = find_cltype_for_path env p in
          let ty =
            subst env !current_level Public abbrev None
              cl_abbr.type_params tl body in
          let ty = repr ty in
          let ty1, tl1 =
            match ty.desc with
              Tobject(ty1,{contents=Some(p',tl1)}) when Path.same p p' ->
                ty1, tl1
            | _ -> raise Not_found
          in
          (* Fix PR#4505: do not set ty to Tvar when it appears in tl1,
             as this occurrence might break the occur check.
             XXX not clear whether this correct anyway... *)
          if List.exists (deep_occur ty) tl1 then raise Not_found;
          ty.desc <- Tvar None;
          let t'' = newvar () in
          let loops = (ty, t'') :: loops in
          (* May discard [visited] as level is going down *)
          let (ty1', c) =
            build_subtype env [t'] loops posi (pred_enlarge level') ty1 in
          assert (is_Tvar t'');
          let nm =
            if c > Equiv || deep_occur ty ty1' then None else Some(p,tl1) in
          t''.desc <- Tobject (ty1', ref nm);
          (try unify_var env ty t with Unify _ -> assert false);
          (t'', Changed)
      | _ -> raise Not_found
      with Not_found ->
        let (t'',c) = build_subtype env visited loops posi level' t' in
        if c > Unchanged then (t'',c)
        else (t, Unchanged)
      end
  | Tconstr(p, tl, _abbrev) ->
      (* Must check recursion on constructors, since we do not always
         expand them *)
      if memq_warn t visited then (t, Unchanged) else
      let visited = t :: visited in
      begin try
        let decl = Env.find_type p env in
        if level = 0 && generic_abbrev env p && safe_abbrev env t
        && not (has_constr_row' env t)
        then warn := true;
        let tl' =
          List.map2
            (fun v t ->
              let (co,cn) = Variance.get_upper v in
              if cn then
                if co then (t, Unchanged)
                else build_subtype env visited loops (not posi) level t
              else
                if co then build_subtype env visited loops posi level t
                else (newvar(), Changed))
            decl.type_variance tl
        in
        let c = collect tl' in
        if c > Unchanged then (newconstr p (List.map fst tl'), c)
        else (t, Unchanged)
      with Not_found ->
        (t, Unchanged)
      end
  | Tvariant row ->
      let row = row_repr row in
      if memq_warn t visited || not (static_row row) then (t, Unchanged) else
      let level' = pred_enlarge level in
      let visited =
        t :: if level' < level then [] else filter_visited visited in
      let fields = filter_row_fields false row.row_fields in
      let fields =
        List.map
          (fun (l,f as orig) -> match row_field_repr f with
            Rpresent None ->
              if posi then
                (l, Reither(true, [], false, ref None)), Unchanged
              else
                orig, Unchanged
          | Rpresent(Some t) ->
              let (t', c) = build_subtype env visited loops posi level' t in
              let f =
                if posi && level > 0
                then Reither(false, [t'], false, ref None)
                else Rpresent(Some t')
              in (l, f), c
          | _ -> assert false)
          fields
      in
      let c = collect fields in
      let row =
        { row_fields = List.map fst fields; row_more = newvar();
          row_bound = (); row_closed = posi; row_fixed = false;
          row_name = if c > Unchanged then None else row.row_name }
      in
      (newty (Tvariant row), Changed)
  | Tobject (t1, _) ->
      if memq_warn t visited || opened_object t1 then (t, Unchanged) else
      let level' = pred_enlarge level in
      let visited =
        t :: if level' < level then [] else filter_visited visited in
      let (t1', c) = build_subtype env visited loops posi level' t1 in
      if c > Unchanged then (newty (Tobject (t1', ref None)), c)
      else (t, Unchanged)
  | Tfield(s, _, t1, t2) (* Always present *) ->
      let (t1', c1) = build_subtype env visited loops posi level t1 in
      let (t2', c2) = build_subtype env visited loops posi level t2 in
      let c = max c1 c2 in
      if c > Unchanged then (newty (Tfield(s, Fpresent, t1', t2')), c)
      else (t, Unchanged)
  | Tnil ->
      if posi then
        let v = newvar () in
        (v, Changed)
      else begin
        warn := true;
        (t, Unchanged)
      end
  | Tsubst _ | Tlink _ ->
      assert false
  | Tpoly(t1, tl) ->
      let (t1', c) = build_subtype env visited loops posi level t1 in
      if c > Unchanged then (newty (Tpoly(t1', tl)), c)
      else (t, Unchanged)
  | Tunivar _ | Tpackage _ ->
      (t, Unchanged)

let enlarge_type env ty =
  warn := false;
  (* [level = 4] allows 2 expansions involving objects/variants *)
  let (ty', _) = build_subtype env [] [] true 4 ty in
  (ty', !warn)

(**** Check whether a type is a subtype of another type. ****)

(*
    During the traversal, a trace of visited types is maintained. It
    is printed in case of error.
    Constraints (pairs of types that must be equals) are accumulated
    rather than being enforced straight. Indeed, the result would
    otherwise depend on the order in which these constraints are
    enforced.
    A function enforcing these constraints is returned. That way, type
    variables can be bound to their actual values before this function
    is called (see Typecore).
    Only well-defined abbreviations are expanded (hence the tests
    [generic_abbrev ...]).
*)

let subtypes = TypePairs.create 17

let subtype_error env trace =
  raise (Subtype (expand_trace env (List.rev trace), []))

let rec subtype_rec env trace t1 t2 cstrs =
  let t1 = repr t1 in
  let t2 = repr t2 in
  if t1 == t2 then cstrs else

  begin try
    TypePairs.find subtypes (t1, t2);
    cstrs
  with Not_found ->
    TypePairs.add subtypes (t1, t2) ();
    match (t1.desc, t2.desc) with
      (Tvar _, _) | (_, Tvar _) ->
        (trace, t1, t2, !univar_pairs)::cstrs
    | (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) when l1 = l2
      || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
        let cstrs = subtype_rec env ((t2, t1)::trace) t2 t1 cstrs in
        subtype_rec env ((u1, u2)::trace) u1 u2 cstrs
    | (Ttuple tl1, Ttuple tl2) ->
        subtype_list env trace tl1 tl2 cstrs
    | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 p2 ->
        cstrs
    | (Tconstr(p1, _tl1, _abbrev1), _)
      when generic_abbrev env p1 && safe_abbrev env t1 ->
        subtype_rec env trace (expand_abbrev env t1) t2 cstrs
    | (_, Tconstr(p2, _tl2, _abbrev2))
      when generic_abbrev env p2 && safe_abbrev env t2 ->
        subtype_rec env trace t1 (expand_abbrev env t2) cstrs
    | (Tconstr(p1, tl1, _), Tconstr(p2, tl2, _)) when Path.same p1 p2 ->
        begin try
          let decl = Env.find_type p1 env in
          List.fold_left2
            (fun cstrs v (t1, t2) ->
              let (co, cn) = Variance.get_upper v in
              if co then
                if cn then
                  (trace, newty2 t1.level (Ttuple[t1]),
                   newty2 t2.level (Ttuple[t2]), !univar_pairs) :: cstrs
                else subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
              else
                if cn then subtype_rec env ((t2, t1)::trace) t2 t1 cstrs
                else cstrs)
            cstrs decl.type_variance (List.combine tl1 tl2)
        with Not_found ->
          (trace, t1, t2, !univar_pairs)::cstrs
        end
    | (Tconstr(p1, _, _), _) when generic_private_abbrev env p1 ->
        subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs
(*  | (_, Tconstr(p2, _, _)) when generic_private_abbrev false env p2 ->
        subtype_rec env trace t1 (expand_abbrev_opt env t2) cstrs *)
    | (Tobject (f1, _), Tobject (f2, _))
      when is_Tvar (object_row f1) && is_Tvar (object_row f2) ->
        (* Same row variable implies same object. *)
        (trace, t1, t2, !univar_pairs)::cstrs
    | (Tobject (f1, _), Tobject (f2, _)) ->
        subtype_fields env trace f1 f2 cstrs
    | (Tvariant row1, Tvariant row2) ->
        begin try
          subtype_row env trace row1 row2 cstrs
        with Exit ->
          (trace, t1, t2, !univar_pairs)::cstrs
        end
    | (Tpoly (u1, []), Tpoly (u2, [])) ->
        subtype_rec env trace u1 u2 cstrs
    | (Tpoly (u1, tl1), Tpoly (u2, [])) ->
        let _, u1' = instance_poly false tl1 u1 in
        subtype_rec env trace u1' u2 cstrs
    | (Tpoly (u1, tl1), Tpoly (u2,tl2)) ->
        begin try
          enter_poly env univar_pairs u1 tl1 u2 tl2
            (fun t1 t2 -> subtype_rec env trace t1 t2 cstrs)
        with Unify _ ->
          (trace, t1, t2, !univar_pairs)::cstrs
        end
    | (Tpackage (p1, nl1, tl1), Tpackage (p2, nl2, tl2)) ->
        begin try
          let ntl1 = complete_type_list env nl2 t1.level (Mty_ident p1) nl1 tl1
          and ntl2 = complete_type_list env nl1 t2.level (Mty_ident p2) nl2 tl2
              ~allow_absent:true in
          let cstrs' =
            List.map
              (fun (n2,t2) -> (trace, List.assoc n2 ntl1, t2, !univar_pairs))
              ntl2
          in
          if eq_package_path env p1 p2 then cstrs' @ cstrs
          else begin
            (* need to check module subtyping *)
            let snap = Btype.snapshot () in
            try
              List.iter (fun (_, t1, t2, _) -> unify env t1 t2) cstrs';
              if !package_subtype env p1 nl1 tl1 p2 nl2 tl2
              then (Btype.backtrack snap; cstrs' @ cstrs)
              else raise (Unify [])
            with Unify _ ->
              Btype.backtrack snap; raise Not_found
          end
        with Not_found ->
          (trace, t1, t2, !univar_pairs)::cstrs
        end
    | (_, _) ->
        (trace, t1, t2, !univar_pairs)::cstrs
  end

and subtype_list env trace tl1 tl2 cstrs =
  if List.length tl1 <> List.length tl2 then
    subtype_error env trace;
  List.fold_left2
    (fun cstrs t1 t2 -> subtype_rec env ((t1, t2)::trace) t1 t2 cstrs)
    cstrs tl1 tl2

and subtype_fields env trace ty1 ty2 cstrs =
  (* Assume that either rest1 or rest2 is not Tvar *)
  let (fields1, rest1) = flatten_fields ty1 in
  let (fields2, rest2) = flatten_fields ty2 in
  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
  let cstrs =
    if rest2.desc = Tnil then cstrs else
    if miss1 = [] then
      subtype_rec env ((rest1, rest2)::trace) rest1 rest2 cstrs
    else
      (trace, build_fields (repr ty1).level miss1 rest1, rest2,
       !univar_pairs) :: cstrs
  in
  let cstrs =
    if miss2 = [] then cstrs else
    (trace, rest1, build_fields (repr ty2).level miss2 (newvar ()),
     !univar_pairs) :: cstrs
  in
  List.fold_left
    (fun cstrs (_, _k1, t1, _k2, t2) ->
      (* These fields are always present *)
      subtype_rec env ((t1, t2)::trace) t1 t2 cstrs)
    cstrs pairs

and subtype_row env trace row1 row2 cstrs =
  let row1 = row_repr row1 and row2 = row_repr row2 in
  let r1, r2, pairs =
    merge_row_fields row1.row_fields row2.row_fields in
  let more1 = repr row1.row_more
  and more2 = repr row2.row_more in
  match more1.desc, more2.desc with
    Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 ->
      subtype_rec env ((more1,more2)::trace) more1 more2 cstrs
  | (Tvar _|Tconstr _|Tnil), (Tvar _|Tconstr _|Tnil)
    when row1.row_closed && r1 = [] ->
      List.fold_left
        (fun cstrs (_,f1,f2) ->
          match row_field_repr f1, row_field_repr f2 with
            (Rpresent None|Reither(true,_,_,_)), Rpresent None ->
              cstrs
          | Rpresent(Some t1), Rpresent(Some t2) ->
              subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
          | Reither(false, t1::_, _, _), Rpresent(Some t2) ->
              subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
          | Rabsent, _ -> cstrs
          | _ -> raise Exit)
        cstrs pairs
  | Tunivar _, Tunivar _
    when row1.row_closed = row2.row_closed && r1 = [] && r2 = [] ->
      let cstrs =
        subtype_rec env ((more1,more2)::trace) more1 more2 cstrs in
      List.fold_left
        (fun cstrs (_,f1,f2) ->
          match row_field_repr f1, row_field_repr f2 with
            Rpresent None, Rpresent None
          | Reither(true,[],_,_), Reither(true,[],_,_)
          | Rabsent, Rabsent ->
              cstrs
          | Rpresent(Some t1), Rpresent(Some t2)
          | Reither(false,[t1],_,_), Reither(false,[t2],_,_) ->
              subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
          | _ -> raise Exit)
        cstrs pairs
  | _ ->
      raise Exit

let subtype env ty1 ty2 =
  TypePairs.clear subtypes;
  univar_pairs := [];
  (* Build constraint set. *)
  let cstrs = subtype_rec env [(ty1, ty2)] ty1 ty2 [] in
  TypePairs.clear subtypes;
  (* Enforce constraints. *)
  function () ->
    List.iter
      (function (trace0, t1, t2, pairs) ->
         try unify_pairs (ref env) t1 t2 pairs with Unify trace ->
           raise (Subtype (expand_trace env (List.rev trace0),
                           List.tl (List.tl trace))))
      (List.rev cstrs)

                              (*******************)
                              (*  Miscellaneous  *)
                              (*******************)

(* Utility for printing. The resulting type is not used in computation. *)
let rec unalias_object ty =
  let ty = repr ty in
  match ty.desc with
    Tfield (s, k, t1, t2) ->
      newty2 ty.level (Tfield (s, k, t1, unalias_object t2))
  | Tvar _ | Tnil ->
      newty2 ty.level ty.desc
  | Tunivar _ ->
      ty
  | Tconstr _ ->
      newvar2 ty.level
  | _ ->
      assert false

let unalias ty =
  let ty = repr ty in
  match ty.desc with
    Tvar _ | Tunivar _ ->
      ty
  | Tvariant row ->
      let row = row_repr row in
      let more = row.row_more in
      newty2 ty.level
        (Tvariant {row with row_more = newty2 more.level more.desc})
  | Tobject (ty, nm) ->
      newty2 ty.level (Tobject (unalias_object ty, nm))
  | _ ->
      newty2 ty.level ty.desc

(* Return the arity (as for curried functions) of the given type. *)
let rec arity ty =
  match (repr ty).desc with
    Tarrow(_, _t1, t2, _) -> 1 + arity t2
  | _ -> 0

(* Check whether an abbreviation expands to itself. *)
let cyclic_abbrev env id ty =
  let rec check_cycle seen ty =
    let ty = repr ty in
    match ty.desc with
      Tconstr (p, _tl, _abbrev) ->
        p = Path.Pident id || List.memq ty seen ||
        begin try
          check_cycle (ty :: seen) (expand_abbrev_opt env ty)
        with
          Cannot_expand -> false
        | Unify _ -> true
        end
    | _ ->
        false
  in check_cycle [] ty

(* Check for non-generalizable type variables *)
exception Non_closed0
let visited = ref TypeSet.empty

let rec closed_schema_rec env ty =
  let ty = repr ty in
  if TypeSet.mem ty !visited then () else begin
    visited := TypeSet.add ty !visited;
    match ty.desc with
      Tvar _ when ty.level <> generic_level ->
        raise Non_closed0
    | Tconstr _ ->
        let old = !visited in
        begin try iter_type_expr (closed_schema_rec env) ty
        with Non_closed0 -> try
          visited := old;
          closed_schema_rec env (try_expand_head try_expand_safe env ty)
        with Cannot_expand ->
          raise Non_closed0
        end
    | Tfield(_, kind, t1, t2) ->
        if field_kind_repr kind = Fpresent then
          closed_schema_rec env t1;
        closed_schema_rec env t2
    | Tvariant row ->
        let row = row_repr row in
        iter_row (closed_schema_rec env) row;
        if not (static_row row) then closed_schema_rec env row.row_more
    | _ ->
        iter_type_expr (closed_schema_rec env) ty
  end

(* Return whether all variables of type [ty] are generic. *)
let closed_schema env ty =
  visited := TypeSet.empty;
  try
    closed_schema_rec env ty;
    visited := TypeSet.empty;
    true
  with Non_closed0 ->
    visited := TypeSet.empty;
    false

(* Normalize a type before printing, saving... *)
(* Cannot use mark_type because deep_occur uses it too *)
let rec normalize_type_rec env visited ty =
  let ty = repr ty in
  if not (TypeSet.mem ty !visited) then begin
    visited := TypeSet.add ty !visited;
    let tm = row_of_type ty in
    begin if not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm then
      match tm.desc with (* PR#7348 *)
        Tconstr (Path.Pdot(m,i,pos), tl, _abbrev) ->
          let i' = String.sub i 0 (String.length i - 4) in
          log_type ty;
          ty.desc <- Tconstr(Path.Pdot(m,i',pos), tl, ref Mnil)
      | _ -> assert false
    else match ty.desc with
    | Tvariant row ->
      let row = row_repr row in
      let fields = List.map
          (fun (l,f0) ->
            let f = row_field_repr f0 in l,
            match f with Reither(b, ty::(_::_ as tyl), m, e) ->
              let tyl' =
                List.fold_left
                  (fun tyl ty ->
                    if List.exists (fun ty' -> equal env false [ty] [ty']) tyl
                    then tyl else ty::tyl)
                  [ty] tyl
              in
              if f != f0 || List.length tyl' < List.length tyl then
                Reither(b, List.rev tyl', m, e)
              else f
            | _ -> f)
          row.row_fields in
      let fields =
        List.sort (fun (p,_) (q,_) -> compare p q)
          (List.filter (fun (_,fi) -> fi <> Rabsent) fields) in
      log_type ty;
      ty.desc <- Tvariant {row with row_fields = fields}
    | Tobject (fi, nm) ->
        begin match !nm with
        | None -> ()
        | Some (n, v :: l) ->
            if deep_occur ty (newgenty (Ttuple l)) then
              (* The abbreviation may be hiding something, so remove it *)
              set_name nm None
            else let v' = repr v in
            begin match v'.desc with
            | Tvar _ | Tunivar _ ->
                if v' != v then set_name nm (Some (n, v' :: l))
            | Tnil ->
                log_type ty; ty.desc <- Tconstr (n, l, ref Mnil)
            | _ -> set_name nm None
            end
        | _ ->
            fatal_error "Ctype.normalize_type_rec"
        end;
        let fi = repr fi in
        if fi.level < lowest_level then () else
        let fields, row = flatten_fields fi in
        let fi' = build_fields fi.level fields row in
        log_type ty; fi.desc <- fi'.desc
    | _ -> ()
    end;
    iter_type_expr (normalize_type_rec env visited) ty
  end

let normalize_type env ty =
  normalize_type_rec env (ref TypeSet.empty) ty


                              (*************************)
                              (*  Remove dependencies  *)
                              (*************************)


(*
   Variables are left unchanged. Other type nodes are duplicated, with
   levels set to generic level.
   We cannot use Tsubst here, because unification may be called by
   expand_abbrev.
*)

let nondep_hash     = TypeHash.create 47
let nondep_variants = TypeHash.create 17
let clear_hash ()   =
  TypeHash.clear nondep_hash; TypeHash.clear nondep_variants

let rec nondep_type_rec env id ty =
  match ty.desc with
    Tvar _ | Tunivar _ -> ty
  | Tlink ty -> nondep_type_rec env id ty
  | _ -> try TypeHash.find nondep_hash ty
  with Not_found ->
    let ty' = newgenvar () in        (* Stub *)
    TypeHash.add nondep_hash ty ty';
    ty'.desc <-
      begin match ty.desc with
      | Tconstr(p, tl, _abbrev) ->
          if Path.isfree id p then
            begin try
              Tlink (nondep_type_rec env id
                       (expand_abbrev env (newty2 ty.level ty.desc)))
              (*
                 The [Tlink] is important. The expanded type may be a
                 variable, or may not be completely copied yet
                 (recursive type), so one cannot just take its
                 description.
               *)
            with Cannot_expand | Unify _ ->
              raise Not_found
            end
          else
            Tconstr(p, List.map (nondep_type_rec env id) tl, ref Mnil)
      | Tpackage(p, nl, tl) when Path.isfree id p ->
          let p' = normalize_package_path env p in
          if Path.isfree id p' then raise Not_found;
          Tpackage (p', nl, List.map (nondep_type_rec env id) tl)
      | Tobject (t1, name) ->
          Tobject (nondep_type_rec env id t1,
                 ref (match !name with
                        None -> None
                      | Some (p, tl) ->
                          if Path.isfree id p then None
                          else Some (p, List.map (nondep_type_rec env id) tl)))
      | Tvariant row ->
          let row = row_repr row in
          let more = repr row.row_more in
          (* We must keep sharing according to the row variable *)
          begin try
            let ty2 = TypeHash.find nondep_variants more in
            (* This variant type has been already copied *)
            TypeHash.add nondep_hash ty ty2;
            Tlink ty2
          with Not_found ->
            (* Register new type first for recursion *)
            TypeHash.add nondep_variants more ty';
            let static = static_row row in
            let more' = if static then newgenty Tnil else more in
            (* Return a new copy *)
            let row =
              copy_row (nondep_type_rec env id) true row true more' in
            match row.row_name with
              Some (p, _tl) when Path.isfree id p ->
                Tvariant {row with row_name = None}
            | _ -> Tvariant row
          end
      | _ -> copy_type_desc (nondep_type_rec env id) ty.desc
      end;
    ty'

let nondep_type env id ty =
  try
    let ty' = nondep_type_rec env id ty in
    clear_hash ();
    ty'
  with Not_found ->
    clear_hash ();
    raise Not_found

let () = nondep_type' := nondep_type

let unroll_abbrev id tl ty =
  let ty = repr ty and path = Path.Pident id in
  if is_Tvar ty || (List.exists (deep_occur ty) tl)
  || is_object_type path then
    ty
  else
    let ty' = newty2 ty.level ty.desc in
    link_type ty (newty2 ty.level (Tconstr (path, tl, ref Mnil)));
    ty'

(* Preserve sharing inside type declarations. *)
let nondep_type_decl env mid id is_covariant decl =
  try
    let params = List.map (nondep_type_rec env mid) decl.type_params in
    let tk =
      try map_kind (nondep_type_rec env mid) decl.type_kind
      with Not_found when is_covariant -> Type_abstract
    and tm =
      try match decl.type_manifest with
        None -> None
      | Some ty ->
          Some (unroll_abbrev id params (nondep_type_rec env mid ty))
      with Not_found when is_covariant ->
        None
    in
    clear_hash ();
    let priv =
      match tm with
      | Some ty when Btype.has_constr_row ty -> Private
      | _ -> decl.type_private
    in
    { type_params = params;
      type_arity = decl.type_arity;
      type_kind = tk;
      type_manifest = tm;
      type_private = priv;
      type_variance = decl.type_variance;
      type_newtype_level = None;
      type_loc = decl.type_loc;
      type_attributes = decl.type_attributes;
      type_immediate = decl.type_immediate;
      type_unboxed = decl.type_unboxed;
    }
  with Not_found ->
    clear_hash ();
    raise Not_found

(* Preserve sharing inside extension constructors. *)
let nondep_extension_constructor env mid ext =
  try
    let type_path, type_params =
      if Path.isfree mid ext.ext_type_path then
        begin
          let ty =
            newgenty (Tconstr(ext.ext_type_path, ext.ext_type_params, ref Mnil))
          in
          let ty' = nondep_type_rec env mid ty in
            match (repr ty').desc with
                Tconstr(p, tl, _) -> p, tl
              | _ -> raise Not_found
        end
      else
        let type_params =
          List.map (nondep_type_rec env mid) ext.ext_type_params
        in
          ext.ext_type_path, type_params
    in
    let args = map_type_expr_cstr_args (nondep_type_rec env mid) ext.ext_args in
    let ret_type = may_map (nondep_type_rec env mid) ext.ext_ret_type in
      clear_hash ();
      { ext_type_path = type_path;
        ext_type_params = type_params;
        ext_args = args;
        ext_ret_type = ret_type;
        ext_private = ext.ext_private;
        ext_attributes = ext.ext_attributes;
        ext_loc = ext.ext_loc;
      }
  with Not_found ->
    clear_hash ();
    raise Not_found


(* Preserve sharing inside class types. *)
let nondep_class_signature env id sign =
  { csig_self = nondep_type_rec env id sign.csig_self;
    csig_vars =
      Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t))
        sign.csig_vars;
    csig_concr = sign.csig_concr;
    csig_inher =
      List.map (fun (p,tl) -> (p, List.map (nondep_type_rec env id) tl))
        sign.csig_inher }

let rec nondep_class_type env id =
  function
    Cty_constr (p, _, cty) when Path.isfree id p ->
      nondep_class_type env id cty
  | Cty_constr (p, tyl, cty) ->
      Cty_constr (p, List.map (nondep_type_rec env id) tyl,
                   nondep_class_type env id cty)
  | Cty_signature sign ->
      Cty_signature (nondep_class_signature env id sign)
  | Cty_arrow (l, ty, cty) ->
      Cty_arrow (l, nondep_type_rec env id ty, nondep_class_type env id cty)

let nondep_class_declaration env id decl =
  assert (not (Path.isfree id decl.cty_path));
  let decl =
    { cty_params = List.map (nondep_type_rec env id) decl.cty_params;
      cty_variance = decl.cty_variance;
      cty_type = nondep_class_type env id decl.cty_type;
      cty_path = decl.cty_path;
      cty_new =
        begin match decl.cty_new with
          None    -> None
        | Some ty -> Some (nondep_type_rec env id ty)
        end;
      cty_loc = decl.cty_loc;
      cty_attributes = decl.cty_attributes;
    }
  in
  clear_hash ();
  decl

let nondep_cltype_declaration env id decl =
  assert (not (Path.isfree id decl.clty_path));
  let decl =
    { clty_params = List.map (nondep_type_rec env id) decl.clty_params;
      clty_variance = decl.clty_variance;
      clty_type = nondep_class_type env id decl.clty_type;
      clty_path = decl.clty_path;
      clty_loc = decl.clty_loc;
      clty_attributes = decl.clty_attributes;
    }
  in
  clear_hash ();
  decl

(* collapse conjunctive types in class parameters *)
let rec collapse_conj env visited ty =
  let ty = repr ty in
  if List.memq ty visited then () else
  let visited = ty :: visited in
  match ty.desc with
    Tvariant row ->
      let row = row_repr row in
      List.iter
        (fun (_l,fi) ->
          match row_field_repr fi with
            Reither (c, t1::(_::_ as tl), m, e) ->
              List.iter (unify env t1) tl;
              set_row_field e (Reither (c, [t1], m, ref None))
          | _ ->
              ())
        row.row_fields;
      iter_row (collapse_conj env visited) row
  | _ ->
      iter_type_expr (collapse_conj env visited) ty

let collapse_conj_params env params =
  List.iter (collapse_conj env []) params

let same_constr env t1 t2 =
  let t1 = expand_head env t1 in
  let t2 = expand_head env t2 in
  match t1.desc, t2.desc with
  | Tconstr (p1, _, _), Tconstr (p2, _, _) -> Path.same p1 p2
  | _ -> false

let () =
  Env.same_constr := same_constr

let maybe_pointer_type env typ =
   match (repr typ).desc with
  | Tconstr(p, _args, _abbrev) ->
    begin try
      let type_decl = Env.find_type p env in
      not type_decl.type_immediate
    with Not_found -> true
    (* This can happen due to e.g. missing -I options,
       causing some .cmi files to be unavailable.
       Maybe we should emit a warning. *)
    end
  | Tvariant row ->
      let row = Btype.row_repr row in
      (* if all labels are devoid of arguments, not a pointer *)
      not row.row_closed
      || List.exists
          (function
            | _, (Rpresent (Some _) | Reither (false, _, _, _)) -> true
            | _ -> false)
          row.row_fields
  | _ -> true

end
module Printtyp : sig 
#1 "printtyp.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Printing functions *)

open Format
open Types
open Outcometree

val longident: formatter -> Longident.t -> unit
val ident: formatter -> Ident.t -> unit
val tree_of_path: Path.t -> out_ident
val path: formatter -> Path.t -> unit
val string_of_path: Path.t -> string
val raw_type_expr: formatter -> type_expr -> unit
val string_of_label: Asttypes.arg_label -> string

val wrap_printing_env: Env.t -> (unit -> 'a) -> 'a
    (* Call the function using the environment for type path shortening *)
    (* This affects all the printing functions below *)

val reset: unit -> unit
val mark_loops: type_expr -> unit
val reset_and_mark_loops: type_expr -> unit
val reset_and_mark_loops_list: type_expr list -> unit
val type_expr: formatter -> type_expr -> unit
val constructor_arguments: formatter -> constructor_arguments -> unit
val tree_of_type_scheme: type_expr -> out_type
val type_sch : formatter -> type_expr -> unit
val type_scheme: formatter -> type_expr -> unit
(* Maxence *)
val reset_names: unit -> unit
val type_scheme_max: ?b_reset_names: bool ->
        formatter -> type_expr -> unit
(* End Maxence *)
val tree_of_value_description: Ident.t -> value_description -> out_sig_item
val value_description: Ident.t -> formatter -> value_description -> unit
val tree_of_type_declaration:
    Ident.t -> type_declaration -> rec_status -> out_sig_item
val type_declaration: Ident.t -> formatter -> type_declaration -> unit
val tree_of_extension_constructor:
    Ident.t -> extension_constructor -> ext_status -> out_sig_item
val extension_constructor:
    Ident.t -> formatter -> extension_constructor -> unit
val tree_of_module:
    Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item
val modtype: formatter -> module_type -> unit
val signature: formatter -> signature -> unit
val tree_of_modtype_declaration:
    Ident.t -> modtype_declaration -> out_sig_item
val tree_of_signature: Types.signature -> out_sig_item list
val tree_of_typexp: bool -> type_expr -> out_type
val modtype_declaration: Ident.t -> formatter -> modtype_declaration -> unit
val class_type: formatter -> class_type -> unit
val tree_of_class_declaration:
    Ident.t -> class_declaration -> rec_status -> out_sig_item
val class_declaration: Ident.t -> formatter -> class_declaration -> unit
val tree_of_cltype_declaration:
    Ident.t -> class_type_declaration -> rec_status -> out_sig_item
val cltype_declaration: Ident.t -> formatter -> class_type_declaration -> unit
val type_expansion: type_expr -> Format.formatter -> type_expr -> unit
val prepare_expansion: type_expr * type_expr -> type_expr * type_expr
val trace:
    bool -> bool-> string -> formatter -> (type_expr * type_expr) list -> unit
val report_unification_error:
    formatter -> Env.t -> ?unif:bool -> (type_expr * type_expr) list ->
    (formatter -> unit) -> (formatter -> unit) ->
    unit


val super_report_unification_error:
    formatter -> Env.t -> ?unif:bool -> (type_expr * type_expr) list ->
    (formatter -> unit) -> (formatter -> unit) ->
    unit


val report_subtyping_error:
    formatter -> Env.t -> (type_expr * type_expr) list ->
    string -> (type_expr * type_expr) list -> unit
val report_ambiguous_type_error:
    formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list ->
    (formatter -> unit) -> (formatter -> unit) -> (formatter -> unit) -> unit

(* for toploop *)
val print_items: (Env.t -> signature_item -> 'a option) ->
  Env.t -> signature_item list -> (out_sig_item * 'a option) list

end = struct
#1 "printtyp.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Printing functions *)

open Misc
open Ctype
open Format
open Longident
open Path
open Asttypes
open Types
open Btype
open Outcometree

(* Print a long identifier *)

let rec longident ppf = function
  | Lident s -> pp_print_string ppf s
  | Ldot(p, s) -> fprintf ppf "%a.%s" longident p s
  | Lapply(p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2

(* Print an identifier *)

let unique_names = ref Ident.empty

let ident_name id =
  try Ident.find_same id !unique_names with Not_found -> Ident.name id

let add_unique id =
  try ignore (Ident.find_same id !unique_names)
  with Not_found ->
    unique_names := Ident.add id (Ident.unique_toplevel_name id) !unique_names

let ident ppf id = pp_print_string ppf (ident_name id)

(* Print a path *)

let ident_pervasives = Ident.create_persistent "Pervasives"
let printing_env = ref Env.empty
let non_shadowed_pervasive = function
  | Pdot(Pident id, s, _pos) as path ->
      Ident.same id ident_pervasives &&
      (try Path.same path (Env.lookup_type (Lident s) !printing_env)
       with Not_found -> true)
  | _ -> false

let rec tree_of_path = function
  | Pident id ->
      Oide_ident (ident_name id)
  | Pdot(_, s, _pos) as path when non_shadowed_pervasive path ->
      Oide_ident s
  | Pdot(p, s, _pos) ->
      Oide_dot (tree_of_path p, s)
  | Papply(p1, p2) ->
      Oide_apply (tree_of_path p1, tree_of_path p2)

let rec path ppf = function
  | Pident id ->
      ident ppf id
  | Pdot(_, s, _pos) as path when non_shadowed_pervasive path ->
      pp_print_string ppf s
  | Pdot(p, s, _pos) ->
      path ppf p;
      pp_print_char ppf '.';
      pp_print_string ppf s
  | Papply(p1, p2) ->
      fprintf ppf "%a(%a)" path p1 path p2

let rec string_of_out_ident = function
  | Oide_ident s -> s
  | Oide_dot (id, s) -> String.concat "." [string_of_out_ident id; s]
  | Oide_apply (id1, id2) ->
      String.concat ""
        [string_of_out_ident id1; "("; string_of_out_ident id2; ")"]

let string_of_path p = string_of_out_ident (tree_of_path p)

(* Print a recursive annotation *)

let tree_of_rec = function
  | Trec_not -> Orec_not
  | Trec_first -> Orec_first
  | Trec_next -> Orec_next

(* Print a raw type expression, with sharing *)

let raw_list pr ppf = function
    [] -> fprintf ppf "[]"
  | a :: l ->
      fprintf ppf "@[<1>[%a%t]@]" pr a
        (fun ppf -> List.iter (fun x -> fprintf ppf ";@,%a" pr x) l)

let kind_vars = ref []
let kind_count = ref 0

let rec safe_kind_repr v = function
    Fvar {contents=Some k}  ->
      if List.memq k v then "Fvar loop" else
      safe_kind_repr (k::v) k
  | Fvar r ->
      let vid =
        try List.assq r !kind_vars
        with Not_found ->
          let c = incr kind_count; !kind_count in
          kind_vars := (r,c) :: !kind_vars;
          c
      in
      Printf.sprintf "Fvar {None}@%d" vid
  | Fpresent -> "Fpresent"
  | Fabsent -> "Fabsent"

let rec safe_commu_repr v = function
    Cok -> "Cok"
  | Cunknown -> "Cunknown"
  | Clink r ->
      if List.memq r v then "Clink loop" else
      safe_commu_repr (r::v) !r

let rec safe_repr v = function
    {desc = Tlink t} when not (List.memq t v) ->
      safe_repr (t::v) t
  | t -> t

let rec list_of_memo = function
    Mnil -> []
  | Mcons (_priv, p, _t1, _t2, rem) -> p :: list_of_memo rem
  | Mlink rem -> list_of_memo !rem

let print_name ppf = function
    None -> fprintf ppf "None"
  | Some name -> fprintf ppf "\"%s\"" name

let string_of_label = function
    Nolabel -> ""
  | Labelled s -> s
  | Optional s -> "?"^s

let visited = ref []
let rec raw_type ppf ty =
  let ty = safe_repr [] ty in
  if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id else begin
    visited := ty :: !visited;
    fprintf ppf "@[<1>{id=%d;level=%d;desc=@,%a}@]" ty.id ty.level
      raw_type_desc ty.desc
  end
and raw_type_list tl = raw_list raw_type tl
and raw_type_desc ppf = function
    Tvar name -> fprintf ppf "Tvar %a" print_name name
  | Tarrow(l,t1,t2,c) ->
      fprintf ppf "@[<hov1>Tarrow(\"%s\",@,%a,@,%a,@,%s)@]"
        (string_of_label l) raw_type t1 raw_type t2
        (safe_commu_repr [] c)
  | Ttuple tl ->
      fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl
  | Tconstr (p, tl, abbrev) ->
      fprintf ppf "@[<hov1>Tconstr(@,%a,@,%a,@,%a)@]" path p
        raw_type_list tl
        (raw_list path) (list_of_memo !abbrev)
  | Tobject (t, nm) ->
      fprintf ppf "@[<hov1>Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t
        (fun ppf ->
          match !nm with None -> fprintf ppf " None"
          | Some(p,tl) ->
              fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl)
  | Tfield (f, k, t1, t2) ->
      fprintf ppf "@[<hov1>Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f
        (safe_kind_repr [] k)
        raw_type t1 raw_type t2
  | Tnil -> fprintf ppf "Tnil"
  | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t
  | Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t
  | Tunivar name -> fprintf ppf "Tunivar %a" print_name name
  | Tpoly (t, tl) ->
      fprintf ppf "@[<hov1>Tpoly(@,%a,@,%a)@]"
        raw_type t
        raw_type_list tl
  | Tvariant row ->
      fprintf ppf
        "@[<hov1>{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%B;@ %s%B;@ @[<1>%s%t@]}@]"
        "row_fields="
        (raw_list (fun ppf (l, f) ->
          fprintf ppf "@[%s,@ %a@]" l raw_field f))
        row.row_fields
        "row_more=" raw_type row.row_more
        "row_closed=" row.row_closed
        "row_fixed=" row.row_fixed
        "row_name="
        (fun ppf ->
          match row.row_name with None -> fprintf ppf "None"
          | Some(p,tl) ->
              fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl)
  | Tpackage (p, _, tl) ->
      fprintf ppf "@[<hov1>Tpackage(@,%a@,%a)@]" path p
        raw_type_list tl

and raw_field ppf = function
    Rpresent None -> fprintf ppf "Rpresent None"
  | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t
  | Reither (c,tl,m,e) ->
      fprintf ppf "@[<hov1>Reither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c
        raw_type_list tl m
        (fun ppf ->
          match !e with None -> fprintf ppf " None"
          | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)
  | Rabsent -> fprintf ppf "Rabsent"

let raw_type_expr ppf t =
  visited := []; kind_vars := []; kind_count := 0;
  raw_type ppf t;
  visited := []; kind_vars := []

let () = Btype.print_raw := raw_type_expr

(* Normalize paths *)

type param_subst = Id | Nth of int | Map of int list

let is_nth = function
    Nth _ -> true
  | _ -> false

let compose l1 = function
  | Id -> Map l1
  | Map l2 -> Map (List.map (List.nth l1) l2)
  | Nth n  -> Nth (List.nth l1 n)

let apply_subst s1 tyl =
  if tyl = [] then []
  (* cf. PR#7543: Typemod.type_package doesn't respect type constructor arity *)
  else
    match s1 with
      Nth n1 -> [List.nth tyl n1]
    | Map l1 -> List.map (List.nth tyl) l1
    | Id -> tyl

type best_path = Paths of Path.t list | Best of Path.t

let printing_depth = ref 0
let printing_cont = ref ([] : Env.iter_cont list)
let printing_old = ref Env.empty
let printing_pers = ref Concr.empty
module PathMap = Map.Make(Path)
let printing_map = ref PathMap.empty

let same_type t t' = repr t == repr t'

let rec index l x =
  match l with
    [] -> raise Not_found
  | a :: l -> if x == a then 0 else 1 + index l x

let rec uniq = function
    [] -> true
  | a :: l -> not (List.memq a l) && uniq l

let rec normalize_type_path ?(cache=false) env p =
  try
    let (params, ty, _) = Env.find_type_expansion p env in
    let params = List.map repr params in
    match repr ty with
      {desc = Tconstr (p1, tyl, _)} ->
        let tyl = List.map repr tyl in
        if List.length params = List.length tyl
        && List.for_all2 (==) params tyl
        then normalize_type_path ~cache env p1
        else if cache || List.length params <= List.length tyl
             || not (uniq tyl) then (p, Id)
        else
          let l1 = List.map (index params) tyl in
          let (p2, s2) = normalize_type_path ~cache env p1 in
          (p2, compose l1 s2)
    | ty ->
        (p, Nth (index params ty))
  with
    Not_found ->
      (Env.normalize_path None env p, Id)

let penalty s =
  if s <> "" && s.[0] = '_' then
    10
  else
    try
      for i = 0 to String.length s - 2 do
        if s.[i] = '_' && s.[i + 1] = '_' then
          raise Exit
      done;
      1
    with Exit -> 10

let rec path_size = function
    Pident id ->
      penalty (Ident.name id), -Ident.binding_time id
  | Pdot (p, _, _) ->
      let (l, b) = path_size p in (1+l, b)
  | Papply (p1, p2) ->
      let (l, b) = path_size p1 in
      (l + fst (path_size p2), b)

let same_printing_env env =
  let used_pers = Env.used_persistent () in
  Env.same_types !printing_old env && Concr.equal !printing_pers used_pers

let set_printing_env env =
  printing_env := env;
  if !Clflags.real_paths
  || !printing_env == Env.empty || same_printing_env env then () else
  begin
    (* printf "Reset printing_map@."; *)
    printing_old := env;
    printing_pers := Env.used_persistent ();
    printing_map := PathMap.empty;
    printing_depth := 0;
    (* printf "Recompute printing_map.@."; *)
    let cont =
      Env.iter_types
        (fun p (p', _decl) ->
          let (p1, s1) = normalize_type_path env p' ~cache:true in
          (* Format.eprintf "%a -> %a = %a@." path p path p' path p1 *)
          if s1 = Id then
          try
            let r = PathMap.find p1 !printing_map in
            match !r with
              Paths l -> r := Paths (p :: l)
            | Best p' -> r := Paths [p; p'] (* assert false *)
          with Not_found ->
            printing_map := PathMap.add p1 (ref (Paths [p])) !printing_map)
        env in
    printing_cont := [cont];
  end

let wrap_printing_env env f =
  set_printing_env env;
  try_finally f (fun () -> set_printing_env Env.empty)

let wrap_printing_env env f =
  Env.without_cmis (wrap_printing_env env) f

let is_unambiguous path env =
  let l = Env.find_shadowed_types path env in
  List.exists (Path.same path) l || (* concrete paths are ok *)
  match l with
    [] -> true
  | p :: rem ->
      (* allow also coherent paths:  *)
      let normalize p = fst (normalize_type_path ~cache:true env p) in
      let p' = normalize p in
      List.for_all (fun p -> Path.same (normalize p) p') rem ||
      (* also allow repeatedly defining and opening (for toplevel) *)
      let id = lid_of_path p in
      List.for_all (fun p -> lid_of_path p = id) rem &&
      Path.same p (Env.lookup_type id env)

let rec get_best_path r =
  match !r with
    Best p' -> p'
  | Paths [] -> raise Not_found
  | Paths l ->
      r := Paths [];
      List.iter
        (fun p ->
          (* Format.eprintf "evaluating %a@." path p; *)
          match !r with
            Best p' when path_size p >= path_size p' -> ()
          | _ -> if is_unambiguous p !printing_env then r := Best p)
              (* else Format.eprintf "%a ignored as ambiguous@." path p *)
        l;
      get_best_path r

let best_type_path p =
  if !Clflags.real_paths || !printing_env == Env.empty
  then (p, Id)
  else
    let (p', s) = normalize_type_path !printing_env p in
    let get_path () = get_best_path (PathMap.find  p' !printing_map) in
    while !printing_cont <> [] &&
      try fst (path_size (get_path ())) > !printing_depth with Not_found -> true
    do
      printing_cont := List.map snd (Env.run_iter_cont !printing_cont);
      incr printing_depth;
    done;
    let p'' = try get_path () with Not_found -> p' in
    (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *)
    (p'', s)

(* Print a type expression *)

let names = ref ([] : (type_expr * string) list)
let name_counter = ref 0
let named_vars = ref ([] : string list)

let weak_counter = ref 1
let weak_var_map = ref TypeMap.empty
let named_weak_vars = ref StringSet.empty

let reset_names () = names := []; name_counter := 0; named_vars := []
let add_named_var ty =
  match ty.desc with
    Tvar (Some name) | Tunivar (Some name) ->
      if List.mem name !named_vars then () else
      named_vars := name :: !named_vars
  | _ -> ()

let name_is_already_used name =
  List.mem name !named_vars
  || List.exists (fun (_, name') -> name = name') !names
  || StringSet.mem name !named_weak_vars

let rec new_name () =
  let name =
    if !name_counter < 26
    then String.make 1 (Char.chr(97 + !name_counter))
    else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^
           string_of_int(!name_counter / 26) in
  incr name_counter;
  if name_is_already_used name then new_name () else name

let rec new_weak_name ty () =
  let name = "weak" ^ string_of_int !weak_counter in
  incr weak_counter;
  if name_is_already_used name then new_weak_name ty ()
  else begin
      named_weak_vars := StringSet.add name !named_weak_vars;
      weak_var_map := TypeMap.add ty name !weak_var_map;
      name
    end

let name_of_type name_generator t =
  (* We've already been through repr at this stage, so t is our representative
     of the union-find class. *)
  try List.assq t !names with Not_found ->
    try TypeMap.find t !weak_var_map with Not_found ->
    let name =
      match t.desc with
        Tvar (Some name) | Tunivar (Some name) ->
          (* Some part of the type we've already printed has assigned another
           * unification variable to that name. We want to keep the name, so try
           * adding a number until we find a name that's not taken. *)
          let current_name = ref name in
          let i = ref 0 in
          while List.exists (fun (_, name') -> !current_name = name') !names do
            current_name := name ^ (string_of_int !i);
            i := !i + 1;
          done;
          !current_name
      | _ ->
          (* No name available, create a new one *)
          name_generator ()
    in
    (* Exception for type declarations *)
    if name <> "_" then names := (t, name) :: !names;
    name

let check_name_of_type t = ignore(name_of_type new_name t)

let remove_names tyl =
  let tyl = List.map repr tyl in
  names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names

let visited_objects = ref ([] : type_expr list)
let aliased = ref ([] : type_expr list)
let delayed = ref ([] : type_expr list)

let add_delayed t =
  if not (List.memq t !delayed) then delayed := t :: !delayed

let is_aliased ty = List.memq (proxy ty) !aliased
let add_alias ty =
  let px = proxy ty in
  if not (is_aliased px) then begin
    aliased := px :: !aliased;
    add_named_var px
  end

let aliasable ty =
  match ty.desc with
    Tvar _ | Tunivar _ | Tpoly _ -> false
  | Tconstr (p, _, _) ->
      not (is_nth (snd (best_type_path p)))
  | _ -> true

let namable_row row =
  row.row_name <> None &&
  List.for_all
    (fun (_, f) ->
       match row_field_repr f with
       | Reither(c, l, _, _) ->
           row.row_closed && if c then l = [] else List.length l = 1
       | _ -> true)
    row.row_fields

let rec mark_loops_rec visited ty =
  let ty = repr ty in
  let px = proxy ty in
  if List.memq px visited && aliasable ty then add_alias px else
    let visited = px :: visited in
    match ty.desc with
    | Tvar _ -> add_named_var ty
    | Tarrow(_, ty1, ty2, _) ->
        mark_loops_rec visited ty1; mark_loops_rec visited ty2
    | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl
    | Tconstr(p, tyl, _) ->
        let (_p', s) = best_type_path p in
        List.iter (mark_loops_rec visited) (apply_subst s tyl)
    | Tpackage (_, _, tyl) ->
        List.iter (mark_loops_rec visited) tyl
    | Tvariant row ->
        if List.memq px !visited_objects then add_alias px else
         begin
          let row = row_repr row in
          if not (static_row row) then
            visited_objects := px :: !visited_objects;
          match row.row_name with
          | Some(_p, tyl) when namable_row row ->
              List.iter (mark_loops_rec visited) tyl
          | _ ->
              iter_row (mark_loops_rec visited) row
         end
    | Tobject (fi, nm) ->
        if List.memq px !visited_objects then add_alias px else
         begin
          if opened_object ty then
            visited_objects := px :: !visited_objects;
          begin match !nm with
          | None ->
              let fields, _ = flatten_fields fi in
              List.iter
                (fun (_, kind, ty) ->
                  if field_kind_repr kind = Fpresent then
                    mark_loops_rec visited ty)
                fields
          | Some (_, l) ->
              List.iter (mark_loops_rec visited) (List.tl l)
          end
        end
    | Tfield(_, kind, ty1, ty2) when field_kind_repr kind = Fpresent ->
        mark_loops_rec visited ty1; mark_loops_rec visited ty2
    | Tfield(_, _, _, ty2) ->
        mark_loops_rec visited ty2
    | Tnil -> ()
    | Tsubst ty -> mark_loops_rec visited ty
    | Tlink _ -> fatal_error "Printtyp.mark_loops_rec (2)"
    | Tpoly (ty, tyl) ->
        List.iter (fun t -> add_alias t) tyl;
        mark_loops_rec visited ty
    | Tunivar _ -> add_named_var ty

let mark_loops ty =
  normalize_type Env.empty ty;
  mark_loops_rec [] ty;;

let reset_loop_marks () =
  visited_objects := []; aliased := []; delayed := []

let reset () =
  unique_names := Ident.empty; reset_names (); reset_loop_marks ()

let reset_and_mark_loops ty =
  reset (); mark_loops ty

let reset_and_mark_loops_list tyl =
  reset (); List.iter mark_loops tyl

(* Disabled in classic mode when printing an unification error *)
let print_labels = ref true

let rec tree_of_typexp sch ty =
  let ty = repr ty in
  let px = proxy ty in
  if List.mem_assq px !names && not (List.memq px !delayed) then
   let mark = is_non_gen sch ty in
   let name = name_of_type (if mark then new_weak_name ty else new_name) px in
   Otyp_var (mark, name) else

  let pr_typ () =
    match ty.desc with
    | Tvar _ ->
        (*let lev =
          if is_non_gen sch ty then "/" ^ string_of_int ty.level else "" in*)
        let non_gen = is_non_gen sch ty in
        let name_gen = if non_gen then new_weak_name ty else new_name in
        Otyp_var (non_gen, name_of_type name_gen ty)
    | Tarrow(l, ty1, ty2, _) ->
        let pr_arrow l ty1 ty2 =
          let lab =
            if !print_labels || is_optional l then string_of_label l else ""
          in
          let t1 =
            if is_optional l then
              match (repr ty1).desc with
              | Tconstr(path, [ty], _)
                when Path.same path Predef.path_option ->
                  tree_of_typexp sch ty
              | _ -> Otyp_stuff "<hidden>"
            else tree_of_typexp sch ty1 in
          Otyp_arrow (lab, t1, tree_of_typexp sch ty2) in
        pr_arrow l ty1 ty2
    | Ttuple tyl ->
        Otyp_tuple (tree_of_typlist sch tyl)
    | Tconstr(p, tyl, _abbrev) ->
        let p', s = best_type_path p in
        let tyl' = apply_subst s tyl in
        if is_nth s && not (tyl'=[]) then tree_of_typexp sch (List.hd tyl') else
        Otyp_constr (tree_of_path p', tree_of_typlist sch tyl')
    | Tvariant row ->
        let row = row_repr row in
        let fields =
          if row.row_closed then
            List.filter (fun (_, f) -> row_field_repr f <> Rabsent)
              row.row_fields
          else row.row_fields in
        let present =
          List.filter
            (fun (_, f) ->
               match row_field_repr f with
               | Rpresent _ -> true
               | _ -> false)
            fields in
        let all_present = List.length present = List.length fields in
        begin match row.row_name with
        | Some(p, tyl) when namable_row row ->
            let (p', s) = best_type_path p in
            let id = tree_of_path p' in
            let args = tree_of_typlist sch (apply_subst s tyl) in
            let out_variant =
              if is_nth s then List.hd args else Otyp_constr (id, args) in
            if row.row_closed && all_present then
              out_variant
            else
              let non_gen = is_non_gen sch px in
              let tags =
                if all_present then None else Some (List.map fst present) in
              Otyp_variant (non_gen, Ovar_typ out_variant, row.row_closed, tags)
        | _ ->
            let non_gen =
              not (row.row_closed && all_present) && is_non_gen sch px in
            let fields = List.map (tree_of_row_field sch) fields in
            let tags =
              if all_present then None else Some (List.map fst present) in
            Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags)
        end
    | Tobject (fi, nm) ->
        tree_of_typobject sch fi !nm
    | Tnil | Tfield _ ->
        tree_of_typobject sch ty None
    | Tsubst ty ->
        tree_of_typexp sch ty
    | Tlink _ ->
        fatal_error "Printtyp.tree_of_typexp"
    | Tpoly (ty, []) ->
        tree_of_typexp sch ty
    | Tpoly (ty, tyl) ->
        (*let print_names () =
          List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names;
          prerr_string "; " in *)
        let tyl = List.map repr tyl in
        if tyl = [] then tree_of_typexp sch ty else begin
          let old_delayed = !delayed in
          (* Make the names delayed, so that the real type is
             printed once when used as proxy *)
          List.iter add_delayed tyl;
          let tl = List.map (name_of_type new_name) tyl in
          let tr = Otyp_poly (tl, tree_of_typexp sch ty) in
          (* Forget names when we leave scope *)
          remove_names tyl;
          delayed := old_delayed; tr
        end
    | Tunivar _ ->
        Otyp_var (false, name_of_type new_name ty)
    | Tpackage (p, n, tyl) ->
        let n =
          List.map (fun li -> String.concat "." (Longident.flatten li)) n in
        Otyp_module (Path.name p, n, tree_of_typlist sch tyl)
  in
  if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed;
  if is_aliased px && aliasable ty then begin
    check_name_of_type px;
    Otyp_alias (pr_typ (), name_of_type new_name px) end
  else pr_typ ()

and tree_of_row_field sch (l, f) =
  match row_field_repr f with
  | Rpresent None | Reither(true, [], _, _) -> (l, false, [])
  | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty])
  | Reither(c, tyl, _, _) ->
      if c (* contradiction: constant constructor with an argument *)
      then (l, true, tree_of_typlist sch tyl)
      else (l, false, tree_of_typlist sch tyl)
  | Rabsent -> (l, false, [] (* actually, an error *))

and tree_of_typlist sch tyl =
  List.map (tree_of_typexp sch) tyl

and tree_of_typobject sch fi nm =
  begin match nm with
  | None ->
      let pr_fields fi =
        let (fields, rest) = flatten_fields fi in
        let present_fields =
          List.fold_right
            (fun (n, k, t) l ->
               match field_kind_repr k with
               | Fpresent -> (n, t) :: l
               | _ -> l)
            fields [] in
        let sorted_fields =
          List.sort
            (fun (n, _) (n', _) -> String.compare n n') present_fields in
        tree_of_typfields sch rest sorted_fields in
      let (fields, rest) = pr_fields fi in
      Otyp_object (fields, rest)
  | Some (p, ty :: tyl) ->
      let non_gen = is_non_gen sch (repr ty) in
      let args = tree_of_typlist sch tyl in
      let (p', s) = best_type_path p in
      assert (s = Id);
      Otyp_class (non_gen, tree_of_path p', args)
  | _ ->
      fatal_error "Printtyp.tree_of_typobject"
  end

and is_non_gen sch ty =
    sch && is_Tvar ty && ty.level <> generic_level

and tree_of_typfields sch rest = function
  | [] ->
      let rest =
        match rest.desc with
        | Tvar _ | Tunivar _ -> Some (is_non_gen sch rest)
        | Tconstr _ -> Some false
        | Tnil -> None
        | _ -> fatal_error "typfields (1)"
      in
      ([], rest)
  | (s, t) :: l ->
      let field = (s, tree_of_typexp sch t) in
      let (fields, rest) = tree_of_typfields sch rest l in
      (field :: fields, rest)

let typexp sch ppf ty =
  !Oprint.out_type ppf (tree_of_typexp sch ty)

let type_expr ppf ty = typexp false ppf ty

and type_sch ppf ty = typexp true ppf ty

and type_scheme ppf ty = reset_and_mark_loops ty; typexp true ppf ty

(* Maxence *)
let type_scheme_max ?(b_reset_names=true) ppf ty =
  if b_reset_names then reset_names () ;
  typexp true ppf ty
(* End Maxence *)

let tree_of_type_scheme ty = reset_and_mark_loops ty; tree_of_typexp true ty

(* Print one type declaration *)

let tree_of_constraints params =
  List.fold_right
    (fun ty list ->
       let ty' = unalias ty in
       if proxy ty != proxy ty' then
         let tr = tree_of_typexp true ty in
         (tr, tree_of_typexp true ty') :: list
       else list)
    params []

let filter_params tyl =
  let params =
    List.fold_left
      (fun tyl ty ->
        let ty = repr ty in
        if List.memq ty tyl then Btype.newgenty (Tsubst ty) :: tyl
        else ty :: tyl)
      [] tyl
  in List.rev params

let mark_loops_constructor_arguments = function
  | Cstr_tuple l -> List.iter mark_loops l
  | Cstr_record l -> List.iter (fun l -> mark_loops l.ld_type) l

let rec tree_of_type_decl id decl =

  reset();

  let params = filter_params decl.type_params in

  begin match decl.type_manifest with
  | Some ty ->
      let vars = free_variables ty in
      List.iter
        (function {desc = Tvar (Some "_")} as ty ->
            if List.memq ty vars then ty.desc <- Tvar None
          | _ -> ())
        params
  | None -> ()
  end;

  List.iter add_alias params;
  List.iter mark_loops params;
  List.iter check_name_of_type (List.map proxy params);
  let ty_manifest =
    match decl.type_manifest with
    | None -> None
    | Some ty ->
        let ty =
          (* Special hack to hide variant name *)
          match repr ty with {desc=Tvariant row} ->
            let row = row_repr row in
            begin match row.row_name with
              Some (Pident id', _) when Ident.same id id' ->
                newgenty (Tvariant {row with row_name = None})
            | _ -> ty
            end
          | _ -> ty
        in
        mark_loops ty;
        Some ty
  in
  begin match decl.type_kind with
  | Type_abstract -> ()
  | Type_variant cstrs ->
      List.iter
        (fun c ->
           mark_loops_constructor_arguments c.cd_args;
           may mark_loops c.cd_res)
        cstrs
  | Type_record(l, _rep) ->
      List.iter (fun l -> mark_loops l.ld_type) l
  | Type_open -> ()
  end;

  let type_param =
    function
    | Otyp_var (_, id) -> id
    | _ -> "?"
  in
  let type_defined decl =
    let abstr =
      match decl.type_kind with
        Type_abstract ->
          decl.type_manifest = None || decl.type_private = Private
      | Type_record _ ->
          decl.type_private = Private
      | Type_variant tll ->
          decl.type_private = Private ||
          List.exists (fun cd -> cd.cd_res <> None) tll
      | Type_open ->
          decl.type_manifest = None
    in
    let vari =
      List.map2
        (fun ty v ->
          if abstr || not (is_Tvar (repr ty)) then Variance.get_upper v
          else (true,true))
        decl.type_params decl.type_variance
    in
    (Ident.name id,
     List.map2 (fun ty cocn -> type_param (tree_of_typexp false ty), cocn)
       params vari)
  in
  let tree_of_manifest ty1 =
    match ty_manifest with
    | None -> ty1
    | Some ty -> Otyp_manifest (tree_of_typexp false ty, ty1)
  in
  let (name, args) = type_defined decl in
  let constraints = tree_of_constraints params in
  let ty, priv =
    match decl.type_kind with
    | Type_abstract ->
        begin match ty_manifest with
        | None -> (Otyp_abstract, Public)
        | Some ty ->
            tree_of_typexp false ty, decl.type_private
        end
    | Type_variant cstrs ->
        tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)),
        decl.type_private
    | Type_record(lbls, _rep) ->
        tree_of_manifest (Otyp_record (List.map tree_of_label lbls)),
        decl.type_private
    | Type_open ->
        tree_of_manifest Otyp_open,
        decl.type_private
  in
  let immediate =
    Builtin_attributes.immediate decl.type_attributes
  in
    { otype_name = name;
      otype_params = args;
      otype_type = ty;
      otype_private = priv;
      otype_immediate = immediate;
      otype_unboxed = decl.type_unboxed.unboxed;
      otype_cstrs = constraints }

and tree_of_constructor_arguments = function
  | Cstr_tuple l -> tree_of_typlist false l
  | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ]

and tree_of_constructor cd =
  let name = Ident.name cd.cd_id in
  let arg () = tree_of_constructor_arguments cd.cd_args in
  match cd.cd_res with
  | None -> (name, arg (), None)
  | Some res ->
      let nm = !names in
      names := [];
      let ret = tree_of_typexp false res in
      let args = arg () in
      names := nm;
      (name, args, Some ret)

and tree_of_label l =
  (Ident.name l.ld_id, l.ld_mutable = Mutable, tree_of_typexp false l.ld_type)

let tree_of_type_declaration id decl rs =
  Osig_type (tree_of_type_decl id decl, tree_of_rec rs)

let type_declaration id ppf decl =
  !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_first)

let constructor_arguments ppf a =
  let tys = tree_of_constructor_arguments a in
  !Oprint.out_type ppf (Otyp_tuple tys)

(* Print an extension declaration *)

let tree_of_extension_constructor id ext es =
  reset ();
  let ty_name = Path.name ext.ext_type_path in
  let ty_params = filter_params ext.ext_type_params in
  List.iter add_alias ty_params;
  List.iter mark_loops ty_params;
  List.iter check_name_of_type (List.map proxy ty_params);
  mark_loops_constructor_arguments ext.ext_args;
  may mark_loops ext.ext_ret_type;
  let type_param =
    function
    | Otyp_var (_, id) -> id
    | _ -> "?"
  in
  let ty_params =
    List.map (fun ty -> type_param (tree_of_typexp false ty)) ty_params
  in
  let name = Ident.name id in
  let args, ret =
    match ext.ext_ret_type with
    | None -> (tree_of_constructor_arguments ext.ext_args, None)
    | Some res ->
        let nm = !names in
        names := [];
        let ret = tree_of_typexp false res in
        let args = tree_of_constructor_arguments ext.ext_args in
        names := nm;
        (args, Some ret)
  in
  let ext =
    { oext_name = name;
      oext_type_name = ty_name;
      oext_type_params = ty_params;
      oext_args = args;
      oext_ret_type = ret;
      oext_private = ext.ext_private }
  in
  let es =
    match es with
        Text_first -> Oext_first
      | Text_next -> Oext_next
      | Text_exception -> Oext_exception
  in
    Osig_typext (ext, es)

let extension_constructor id ppf ext =
  !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first)

(* Print a value declaration *)

let tree_of_value_description id decl =
  (* Format.eprintf "@[%a@]@." raw_type_expr decl.val_type; *)
  let id = Ident.name id in
  let ty = tree_of_type_scheme decl.val_type in
  let vd =
    { oval_name = id;
      oval_type = ty;
      oval_prims = [];
      oval_attributes = [] }
  in
  let vd =
    match decl.val_kind with
    | Val_prim p -> Primitive.print p vd
    | _ -> vd
  in
  Osig_value vd

let value_description id ppf decl =
  !Oprint.out_sig_item ppf (tree_of_value_description id decl)

(* Print a class type *)

let method_type (_, kind, ty) =
  match field_kind_repr kind, repr ty with
    Fpresent, {desc=Tpoly(ty, tyl)} -> (ty, tyl)
  | _       , ty                    -> (ty, [])

let tree_of_metho sch concrete csil (lab, kind, ty) =
  if lab <> dummy_method then begin
    let kind = field_kind_repr kind in
    let priv = kind <> Fpresent in
    let virt = not (Concr.mem lab concrete) in
    let (ty, tyl) = method_type (lab, kind, ty) in
    let tty = tree_of_typexp sch ty in
    remove_names tyl;
    Ocsg_method (lab, priv, virt, tty) :: csil
  end
  else csil

let rec prepare_class_type params = function
  | Cty_constr (_p, tyl, cty) ->
      let sty = Ctype.self_type cty in
      if List.memq (proxy sty) !visited_objects
      || not (List.for_all is_Tvar params)
      || List.exists (deep_occur sty) tyl
      then prepare_class_type params cty
      else List.iter mark_loops tyl
  | Cty_signature sign ->
      let sty = repr sign.csig_self in
      (* Self may have a name *)
      let px = proxy sty in
      if List.memq px !visited_objects then add_alias sty
      else visited_objects := px :: !visited_objects;
      let (fields, _) =
        Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
      in
      List.iter (fun met -> mark_loops (fst (method_type met))) fields;
      Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.csig_vars
  | Cty_arrow (_, ty, cty) ->
      mark_loops ty;
      prepare_class_type params cty

let rec tree_of_class_type sch params =
  function
  | Cty_constr (p', tyl, cty) ->
      let sty = Ctype.self_type cty in
      if List.memq (proxy sty) !visited_objects
      || not (List.for_all is_Tvar params)
      then
        tree_of_class_type sch params cty
      else
        Octy_constr (tree_of_path p', tree_of_typlist true tyl)
  | Cty_signature sign ->
      let sty = repr sign.csig_self in
      let self_ty =
        if is_aliased sty then
          Some (Otyp_var (false, name_of_type new_name (proxy sty)))
        else None
      in
      let (fields, _) =
        Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
      in
      let csil = [] in
      let csil =
        List.fold_left
          (fun csil (ty1, ty2) -> Ocsg_constraint (ty1, ty2) :: csil)
          csil (tree_of_constraints params)
      in
      let all_vars =
        Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.csig_vars []
      in
      (* Consequence of PR#3607: order of Map.fold has changed! *)
      let all_vars = List.rev all_vars in
      let csil =
        List.fold_left
          (fun csil (l, m, v, t) ->
            Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp sch t)
            :: csil)
          csil all_vars
      in
      let csil =
        List.fold_left (tree_of_metho sch sign.csig_concr) csil fields
      in
      Octy_signature (self_ty, List.rev csil)
  | Cty_arrow (l, ty, cty) ->
      let lab =
        if !print_labels || is_optional l then string_of_label l else ""
      in
      let ty =
       if is_optional l then
         match (repr ty).desc with
         | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty
         | _ -> newconstr (Path.Pident(Ident.create "<hidden>")) []
       else ty in
      let tr = tree_of_typexp sch ty in
      Octy_arrow (lab, tr, tree_of_class_type sch params cty)

let class_type ppf cty =
  reset ();
  prepare_class_type [] cty;
  !Oprint.out_class_type ppf (tree_of_class_type false [] cty)

let tree_of_class_param param variance =
  (match tree_of_typexp true param with
    Otyp_var (_, s) -> s
  | _ -> "?"),
  if is_Tvar (repr param) then (true, true) else variance

let class_variance =
  List.map Variance.(fun v -> mem May_pos v, mem May_neg v)

let tree_of_class_declaration id cl rs =
  let params = filter_params cl.cty_params in

  reset ();
  List.iter add_alias params;
  prepare_class_type params cl.cty_type;
  let sty = Ctype.self_type cl.cty_type in
  List.iter mark_loops params;

  List.iter check_name_of_type (List.map proxy params);
  if is_aliased sty then check_name_of_type (proxy sty);

  let vir_flag = cl.cty_new = None in
  Osig_class
    (vir_flag, Ident.name id,
     List.map2 tree_of_class_param params (class_variance cl.cty_variance),
     tree_of_class_type true params cl.cty_type,
     tree_of_rec rs)

let class_declaration id ppf cl =
  !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first)

let tree_of_cltype_declaration id cl rs =
  let params = List.map repr cl.clty_params in

  reset ();
  List.iter add_alias params;
  prepare_class_type params cl.clty_type;
  let sty = Ctype.self_type cl.clty_type in
  List.iter mark_loops params;

  List.iter check_name_of_type (List.map proxy params);
  if is_aliased sty then check_name_of_type (proxy sty);

  let sign = Ctype.signature_of_class_type cl.clty_type in

  let virt =
    let (fields, _) =
      Ctype.flatten_fields (Ctype.object_fields sign.csig_self) in
    List.exists
      (fun (lab, _, _) ->
         not (lab = dummy_method || Concr.mem lab sign.csig_concr))
      fields
    || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.csig_vars false
  in

  Osig_class_type
    (virt, Ident.name id,
     List.map2 tree_of_class_param params (class_variance cl.clty_variance),
     tree_of_class_type true params cl.clty_type,
     tree_of_rec rs)

let cltype_declaration id ppf cl =
  !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl Trec_first)

(* Print a module type *)

let wrap_env fenv ftree arg =
  let env = !printing_env in
  set_printing_env (fenv env);
  let tree = ftree arg in
  set_printing_env env;
  tree

let filter_rem_sig item rem =
  match item, rem with
  | Sig_class _, ctydecl :: tydecl1 :: tydecl2 :: rem ->
      ([ctydecl; tydecl1; tydecl2], rem)
  | Sig_class_type _, tydecl1 :: tydecl2 :: rem ->
      ([tydecl1; tydecl2], rem)
  | _ ->
      ([], rem)

let dummy =
  { type_params = []; type_arity = 0; type_kind = Type_abstract;
    type_private = Public; type_manifest = None; type_variance = [];
    type_newtype_level = None; type_loc = Location.none;
    type_attributes = [];
    type_immediate = false;
    type_unboxed = unboxed_false_default_false;
  }

let hide_rec_items = function
  | Sig_type(id, _decl, rs) ::rem
    when rs = Trec_first && not !Clflags.real_paths ->
      let rec get_ids = function
          Sig_type (id, _, Trec_next) :: rem ->
            id :: get_ids rem
        | _ -> []
      in
      let ids = id :: get_ids rem in
      set_printing_env
        (List.fold_right
           (fun id -> Env.add_type ~check:false (Ident.rename id) dummy)
           ids !printing_env)
  | _ -> ()

let rec tree_of_modtype ?(ellipsis=false) = function
  | Mty_ident p ->
      Omty_ident (tree_of_path p)
  | Mty_signature sg ->
      Omty_signature (if ellipsis then [Osig_ellipsis]
                      else tree_of_signature sg)
  | Mty_functor(param, ty_arg, ty_res) ->
      let res =
        match ty_arg with None -> tree_of_modtype ~ellipsis ty_res
        | Some mty ->
            wrap_env (Env.add_module ~arg:true param mty)
                     (tree_of_modtype ~ellipsis) ty_res
      in
      Omty_functor (Ident.name param,
                    may_map (tree_of_modtype ~ellipsis:false) ty_arg, res)
  | Mty_alias(_, p) ->
      Omty_alias (tree_of_path p)

and tree_of_signature sg =
  wrap_env (fun env -> env) (tree_of_signature_rec !printing_env false) sg

and tree_of_signature_rec env' in_type_group = function
    [] -> []
  | item :: rem as items ->
      let in_type_group =
        match in_type_group, item with
          true, Sig_type (_, _, Trec_next) -> true
        | _, Sig_type (_, _, (Trec_not | Trec_first)) ->
            set_printing_env env'; true
        | _ -> set_printing_env env'; false
      in
      let (sg, rem) = filter_rem_sig item rem in
      hide_rec_items items;
      let trees = trees_of_sigitem item in
      let env' = Env.add_signature (item :: sg) env' in
      trees @ tree_of_signature_rec env' in_type_group rem

and trees_of_sigitem = function
  | Sig_value(id, decl) ->
      [tree_of_value_description id decl]
  | Sig_type(id, _, _) when is_row_name (Ident.name id) ->
      []
  | Sig_type(id, decl, rs) ->
      [tree_of_type_declaration id decl rs]
  | Sig_typext(id, ext, es) ->
      [tree_of_extension_constructor id ext es]
  | Sig_module(id, md, rs) ->
      let ellipsis =
        List.exists (function ({txt="..."}, Parsetree.PStr []) -> true
                            | _ -> false)
          md.md_attributes in
      [tree_of_module id md.md_type rs ~ellipsis]
  | Sig_modtype(id, decl) ->
      [tree_of_modtype_declaration id decl]
  | Sig_class(id, decl, rs) ->
      [tree_of_class_declaration id decl rs]
  | Sig_class_type(id, decl, rs) ->
      [tree_of_cltype_declaration id decl rs]

and tree_of_modtype_declaration id decl =
  let mty =
    match decl.mtd_type with
    | None -> Omty_abstract
    | Some mty -> tree_of_modtype mty
  in
  Osig_modtype (Ident.name id, mty)

and tree_of_module id ?ellipsis mty rs =
  Osig_module (Ident.name id, tree_of_modtype ?ellipsis mty, tree_of_rec rs)

let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty)
let modtype_declaration id ppf decl =
  !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl)

(* For the toplevel: merge with tree_of_signature? *)

(* Refresh weak variable map in the toplevel *)
let refresh_weak () =
  let refresh t name (m,s) =
    if is_non_gen true (repr t) then
      begin
        TypeMap.add t name m,
        StringSet.add name s
      end
    else m, s in
  let m, s =
    TypeMap.fold refresh !weak_var_map (TypeMap.empty ,StringSet.empty)  in
  named_weak_vars := s;
  weak_var_map := m

let print_items showval env x =
  refresh_weak();
  let rec print showval env = function
  | [] -> []
  | item :: rem as items ->
      let (_sg, rem) = filter_rem_sig item rem in
      hide_rec_items items;
      let trees = trees_of_sigitem item in
      List.map (fun d -> (d, showval env item)) trees @
      print showval env rem in
  print showval env x

(* Print a signature body (used by -i when compiling a .ml) *)

let print_signature ppf tree =
  fprintf ppf "@[<v>%a@]" !Oprint.out_signature tree

let signature ppf sg =
  fprintf ppf "%a" print_signature (tree_of_signature sg)

(* Print an unification error *)

let same_path t t' =
  let t = repr t and t' = repr t' in
  t == t' ||
  match t.desc, t'.desc with
    Tconstr(p,tl,_), Tconstr(p',tl',_) ->
      let (p1, s1) = best_type_path p and (p2, s2)  = best_type_path p' in
      begin match s1, s2 with
        Nth n1, Nth n2 when n1 = n2 -> true
      | (Id | Map _), (Id | Map _) when Path.same p1 p2 ->
          let tl = apply_subst s1 tl and tl' = apply_subst s2 tl' in
          List.length tl = List.length tl' &&
          List.for_all2 same_type tl tl'
      | _ -> false
      end
  | _ ->
      false

let type_expansion t ppf t' =
  if same_path t t'
  then begin add_delayed (proxy t); type_expr ppf t end
  else
  let t' = if proxy t == proxy t' then unalias t' else t' in
  fprintf ppf "@[<2>%a@ =@ %a@]" type_expr t type_expr t'

let type_path_expansion tp ppf tp' =
  if Path.same tp tp' then path ppf tp else
  fprintf ppf "@[<2>%a@ =@ %a@]" path tp path tp'

let rec trace fst txt ppf = function
  | (t1, t1') :: (t2, t2') :: rem ->
      if not fst then fprintf ppf "@,";
      fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@] %a"
       (type_expansion t1) t1' txt (type_expansion t2) t2'
       (trace false txt) rem
  | _ -> ()

let rec filter_trace keep_last = function
  | (_, t1') :: (_, t2') :: [] when is_Tvar t1' || is_Tvar t2' ->
      []
  | (t1, t1') :: (t2, t2') :: rem ->
      let rem' = filter_trace keep_last rem in
      if is_constr_row ~allow_ident:true t1'
      || is_constr_row ~allow_ident:true t2'
      || same_path t1 t1' && same_path t2 t2' && not (keep_last && rem' = [])
      then rem'
      else (t1, t1') :: (t2, t2') :: rem'
  | _ -> []

let rec type_path_list ppf = function
  | [tp, tp'] -> type_path_expansion tp ppf tp'
  | (tp, tp') :: rem ->
      fprintf ppf "%a@;<2 0>%a"
        (type_path_expansion tp) tp'
        type_path_list rem
  | [] -> ()

(* Hide variant name and var, to force printing the expanded type *)
let hide_variant_name t =
  match repr t with
  | {desc = Tvariant row} as t when (row_repr row).row_name <> None ->
      newty2 t.level
        (Tvariant {(row_repr row) with row_name = None;
                   row_more = newvar2 (row_more row).level})
  | _ -> t

let prepare_expansion (t, t') =
  let t' = hide_variant_name t' in
  mark_loops t;
  if not (same_path t t') then mark_loops t';
  (t, t')

let may_prepare_expansion compact (t, t') =
  match (repr t').desc with
    Tvariant _ | Tobject _ when compact ->
      mark_loops t; (t, t)
  | _ -> prepare_expansion (t, t')

let print_tags ppf fields =
  match fields with [] -> ()
  | (t, _) :: fields ->
      fprintf ppf "`%s" t;
      List.iter (fun (t, _) -> fprintf ppf ",@ `%s" t) fields

let has_explanation t3 t4 =
  match t3.desc, t4.desc with
    Tfield _, (Tnil|Tconstr _) | (Tnil|Tconstr _), Tfield _
  | Tnil, Tconstr _ | Tconstr _, Tnil
  | _, Tvar _ | Tvar _, _
  | Tvariant _, Tvariant _ -> true
  | Tfield (l,_,_,{desc=Tnil}), Tfield (l',_,_,{desc=Tnil}) -> l = l'
  | _ -> false

let rec mismatch = function
    (_, t) :: (_, t') :: rem ->
      begin match mismatch rem with
        Some _ as m -> m
      | None ->
          if has_explanation t t' then Some(t,t') else None
      end
  | [] -> None
  | _ -> assert false

let explanation unif t3 t4 ppf =
  match t3.desc, t4.desc with
  | Ttuple [], Tvar _ | Tvar _, Ttuple [] ->
      fprintf ppf "@,Self type cannot escape its class"
  | Tconstr (p, _, _), Tvar _
    when unif && t4.level < Path.binding_time p ->
      fprintf ppf
        "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
        path p
  | Tvar _, Tconstr (p, _, _)
    when unif && t3.level < Path.binding_time p ->
      fprintf ppf
        "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
        path p
  | Tvar _, Tunivar _ | Tunivar _, Tvar _ ->
      fprintf ppf "@,The universal variable %a would escape its scope"
        type_expr (if is_Tunivar t3 then t3 else t4)
  | Tvar _, _ | _, Tvar _ ->
      let t, t' = if is_Tvar t3 then (t3, t4) else (t4, t3) in
      if occur_in Env.empty t t' then
        fprintf ppf "@,@[<hov>The type variable %a occurs inside@ %a@]"
          type_expr t type_expr t'
      else
        fprintf ppf "@,@[<hov>This instance of %a is ambiguous:@ %s@]"
          type_expr t'
          "it would escape the scope of its equation"
  | Tfield (lab, _, _, _), _ when lab = dummy_method ->
      fprintf ppf
        "@,Self type cannot be unified with a closed object type"
  | _, Tfield (lab, _, _, _) when lab = dummy_method ->
      fprintf ppf
        "@,Self type cannot be unified with a closed object type"
  | Tfield (l,_,_,{desc=Tnil}), Tfield (l',_,_,{desc=Tnil}) when l = l' ->
      fprintf ppf "@,Types for method %s are incompatible" l
  | (Tnil|Tconstr _), Tfield (l, _, _, _) ->
      fprintf ppf
        "@,@[The first object type has no method %s@]" l
  | Tfield (l, _, _, _), (Tnil|Tconstr _) ->
      fprintf ppf
        "@,@[The second object type has no method %s@]" l
  | Tnil, Tconstr _ | Tconstr _, Tnil ->
      fprintf ppf
        "@,@[The %s object type has an abstract row, it cannot be closed@]"
        (if t4.desc = Tnil then "first" else "second")
  | Tvariant row1, Tvariant row2 ->
      let row1 = row_repr row1 and row2 = row_repr row2 in
      begin match
        row1.row_fields, row1.row_closed, row2.row_fields, row2.row_closed with
      | [], true, [], true ->
          fprintf ppf "@,These two variant types have no intersection"
      | [], true, (_::_ as fields), _ ->
          fprintf ppf
            "@,@[The first variant type does not allow tag(s)@ @[<hov>%a@]@]"
            print_tags fields
      | (_::_ as fields), _, [], true ->
          fprintf ppf
            "@,@[The second variant type does not allow tag(s)@ @[<hov>%a@]@]"
            print_tags fields
      | [l1,_], true, [l2,_], true when l1 = l2 ->
          fprintf ppf "@,Types for tag `%s are incompatible" l1
      | _ -> ()
      end
  | _ -> ()


let warn_on_missing_def env ppf t =
  match t.desc with
  | Tconstr (p,_,_) ->
    begin
      try
        ignore(Env.find_type p env : Types.type_declaration)
      with Not_found ->
        fprintf ppf
          "@,@[%a is abstract because no corresponding cmi file was found \
           in path.@]" path p
    end
  | _ -> ()

let explanation unif mis ppf =
  match mis with
    None -> ()
  | Some (t3, t4) -> explanation unif t3 t4 ppf

let ident_same_name id1 id2 =
  if Ident.equal id1 id2 && not (Ident.same id1 id2) then begin
    add_unique id1; add_unique id2
  end

let rec path_same_name p1 p2 =
  match p1, p2 with
    Pident id1, Pident id2 -> ident_same_name id1 id2
  | Pdot (p1, s1, _), Pdot (p2, s2, _) when s1 = s2 -> path_same_name p1 p2
  | Papply (p1, p1'), Papply (p2, p2') ->
      path_same_name p1 p2; path_same_name p1' p2'
  | _ -> ()

let type_same_name t1 t2 =
  match (repr t1).desc, (repr t2).desc with
    Tconstr (p1, _, _), Tconstr (p2, _, _) ->
      path_same_name (fst (best_type_path p1)) (fst (best_type_path p2))
  | _ -> ()

let rec trace_same_names = function
    (t1, t1') :: (t2, t2') :: rem ->
      type_same_name t1 t2; type_same_name t1' t2'; trace_same_names rem
  | _ -> ()

let unification_error env unif tr txt1 ppf txt2 =
  reset ();
  trace_same_names tr;
  let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in
  let mis = mismatch tr in
  match tr with
  | [] | _ :: [] -> assert false
  | t1 :: t2 :: tr ->
    try
      let tr = filter_trace (mis = None) tr in
      let t1, t1' = may_prepare_expansion (tr = []) t1
      and t2, t2' = may_prepare_expansion (tr = []) t2 in
      print_labels := not !Clflags.classic;
      let tr = List.map prepare_expansion tr in
      fprintf ppf
        "@[<v>\
          @[%t@;<1 2>%a@ \
            %t@;<1 2>%a\
          @]%a%t\
         @]"
        txt1 (type_expansion t1) t1'
        txt2 (type_expansion t2) t2'
        (trace false "is not compatible with type") tr
        (explanation unif mis);
      if env <> Env.empty
      then begin
        warn_on_missing_def env ppf t1;
        warn_on_missing_def env ppf t2
      end;
      print_labels := true
    with exn ->
      print_labels := true;
      raise exn

let report_unification_error ppf env ?(unif=true)
    tr txt1 txt2 =
  wrap_printing_env env (fun () -> unification_error env unif tr txt1 ppf txt2)
;;


let super_type_expansion ~tag t ppf t' =
  if same_path t t' then begin
    Format.pp_open_tag ppf tag;
    type_expr ppf t;
    Format.pp_close_tag ppf ();
  end else begin
    let t' = if proxy t == proxy t' then unalias t' else t' in
    fprintf ppf "@[<2>";
    Format.pp_open_tag ppf tag;
    fprintf ppf "%a" type_expr t;
    Format.pp_close_tag ppf ();
    fprintf ppf "@ @{<dim>(defined as@}@ ";
    Format.pp_open_tag ppf tag;
    fprintf ppf "%a" type_expr t';
    Format.pp_close_tag ppf ();
    fprintf ppf "@{<dim>)@}";
    fprintf ppf "@]";
  end

let super_trace ppf =
  let rec super_trace first_report ppf = function
    | (t1, t1') :: (t2, t2') :: rem ->
      fprintf ppf
        "@,@,@[<v 2>";
      if first_report then
        fprintf ppf "The incompatible parts:@,"
      else begin
        fprintf ppf "Further expanded:@,"
      end;
      fprintf ppf
        "@[<v>\
          @[%a@]@,\
          vs@,\
          @[%a@]\
          %a\
        @]"
        (super_type_expansion ~tag:"error" t1) t1'
        (super_type_expansion ~tag:"info" t2) t2'
        (super_trace false) rem;
      fprintf ppf "@]"
    | _ -> ()
  in super_trace true ppf

let super_unification_error unif tr txt1 ppf txt2 = begin
  reset ();
  trace_same_names tr;
  let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in
  let mis = mismatch tr in
  match tr with
  | [] | _ :: [] -> assert false
  | t1 :: t2 :: tr ->
    try
      let tr = filter_trace (mis = None) tr in
      let t1, t1' = may_prepare_expansion (tr = []) t1
      and t2, t2' = may_prepare_expansion (tr = []) t2 in
      print_labels := not !Clflags.classic;
      let tr = List.map prepare_expansion tr in
      fprintf ppf
        "@[<v 0>\
          @[<v 2>\
            %t@,\
            @[<2>%a@]\
          @]@,\
          @[<v 2>\
            %t@,\
            @[<2>%a@]\
          @]\
          %a\
          %t\
        @]"
        txt1 (super_type_expansion ~tag:"error" t1) t1'
        txt2 (super_type_expansion ~tag:"info" t2) t2'
        super_trace tr
        (explanation unif mis);
      print_labels := true
    with exn ->
      print_labels := true;
      raise exn
end

let super_report_unification_error ppf env ?(unif=true)
    tr txt1 txt2 =
  wrap_printing_env env (fun () -> super_unification_error unif tr txt1 ppf txt2)
;;


let trace fst keep_last txt ppf tr =
  print_labels := not !Clflags.classic;
  trace_same_names tr;
  try match tr with
    t1 :: t2 :: tr' ->
      if fst then trace fst txt ppf (t1 :: t2 :: filter_trace keep_last tr')
      else trace fst txt ppf (filter_trace keep_last tr);
      print_labels := true
  | _ -> ()
  with exn ->
    print_labels := true;
    raise exn

let report_subtyping_error ppf env tr1 txt1 tr2 =
  wrap_printing_env env (fun () ->
    reset ();
    let tr1 = List.map prepare_expansion tr1
    and tr2 = List.map prepare_expansion tr2 in
    fprintf ppf "@[<v>%a" (trace true (tr2 = []) txt1) tr1;
    if tr2 = [] then fprintf ppf "@]" else
    let mis = mismatch tr2 in
    fprintf ppf "%a%t@]"
      (trace false (mis = None) "is not compatible with type") tr2
      (explanation true mis))

let report_ambiguous_type_error ppf env (tp0, tp0') tpl txt1 txt2 txt3 =
  wrap_printing_env env (fun () ->
    reset ();
    List.iter
      (fun (tp, tp') -> path_same_name tp0 tp; path_same_name tp0' tp')
      tpl;
    match tpl with
      [] -> assert false
    | [tp, tp'] ->
        fprintf ppf
          "@[%t@;<1 2>%a@ \
             %t@;<1 2>%a\
           @]"
          txt1 (type_path_expansion tp) tp'
          txt3 (type_path_expansion tp0) tp0'
    | _ ->
        fprintf ppf
          "@[%t@;<1 2>@[<hv>%a@]\
             @ %t@;<1 2>%a\
           @]"
          txt2 type_path_list tpl
          txt3 (type_path_expansion tp0) tp0')

end
module Includeclass : sig 
#1 "includeclass.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*           Jerome Vouillon, projet Cristal, INRIA Rocquencourt          *)
(*                                                                        *)
(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Inclusion checks for the class language *)

open Types
open Ctype
open Format

val class_types:
        Env.t -> class_type -> class_type -> class_match_failure list
val class_type_declarations:
  loc:Location.t ->
  Env.t -> class_type_declaration -> class_type_declaration ->
  class_match_failure list
val class_declarations:
  Env.t -> class_declaration -> class_declaration ->
  class_match_failure list

val report_error: formatter -> class_match_failure list -> unit

end = struct
#1 "includeclass.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*           Jerome Vouillon, projet Cristal, INRIA Rocquencourt          *)
(*                                                                        *)
(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Inclusion checks for the class language *)

open Types

let class_types env cty1 cty2 =
  Ctype.match_class_types env cty1 cty2

let class_type_declarations ~loc env cty1 cty2 =
  Builtin_attributes.check_deprecated_inclusion
    ~def:cty1.clty_loc
    ~use:cty2.clty_loc
    loc
    cty1.clty_attributes cty2.clty_attributes
    (Path.last cty1.clty_path);
  Ctype.match_class_declarations env
    cty1.clty_params cty1.clty_type
    cty2.clty_params cty2.clty_type

let class_declarations env cty1 cty2 =
  match cty1.cty_new, cty2.cty_new with
    None, Some _ ->
      [Ctype.CM_Virtual_class]
  | _ ->
      Ctype.match_class_declarations env
        cty1.cty_params cty1.cty_type
        cty2.cty_params cty2.cty_type

open Format
open Ctype

(*
let rec hide_params = function
    Tcty_arrow ("*", _, cty) -> hide_params cty
  | cty -> cty
*)

let include_err ppf =
  function
  | CM_Virtual_class ->
      fprintf ppf "A class cannot be changed from virtual to concrete"
  | CM_Parameter_arity_mismatch _ ->
      fprintf ppf
        "The classes do not have the same number of type parameters"
  | CM_Type_parameter_mismatch (env, trace) ->
      Printtyp.report_unification_error ppf env ~unif:false trace
        (function ppf ->
          fprintf ppf "A type parameter has type")
        (function ppf ->
          fprintf ppf "but is expected to have type")
  | CM_Class_type_mismatch (env, cty1, cty2) ->
      Printtyp.wrap_printing_env env (fun () ->
        fprintf ppf
          "@[The class type@;<1 2>%a@ %s@;<1 2>%a@]"
          Printtyp.class_type cty1
          "is not matched by the class type"
          Printtyp.class_type cty2)
  | CM_Parameter_mismatch (env, trace) ->
      Printtyp.report_unification_error ppf env ~unif:false trace
        (function ppf ->
          fprintf ppf "A parameter has type")
        (function ppf ->
          fprintf ppf "but is expected to have type")
  | CM_Val_type_mismatch (lab, env, trace) ->
      Printtyp.report_unification_error ppf env ~unif:false trace
        (function ppf ->
          fprintf ppf "The instance variable %s@ has type" lab)
        (function ppf ->
          fprintf ppf "but is expected to have type")
  | CM_Meth_type_mismatch (lab, env, trace) ->
      Printtyp.report_unification_error ppf env ~unif:false trace
        (function ppf ->
          fprintf ppf "The method %s@ has type" lab)
        (function ppf ->
          fprintf ppf "but is expected to have type")
  | CM_Non_mutable_value lab ->
      fprintf ppf
       "@[The non-mutable instance variable %s cannot become mutable@]" lab
  | CM_Non_concrete_value lab ->
      fprintf ppf
       "@[The virtual instance variable %s cannot become concrete@]" lab
  | CM_Missing_value lab ->
      fprintf ppf "@[The first class type has no instance variable %s@]" lab
  | CM_Missing_method lab ->
      fprintf ppf "@[The first class type has no method %s@]" lab
  | CM_Hide_public lab ->
     fprintf ppf "@[The public method %s cannot be hidden@]" lab
  | CM_Hide_virtual (k, lab) ->
      fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab
  | CM_Public_method lab ->
      fprintf ppf "@[The public method %s cannot become private" lab
  | CM_Virtual_method lab ->
      fprintf ppf "@[The virtual method %s cannot become concrete" lab
  | CM_Private_method lab ->
      fprintf ppf "The private method %s cannot become public" lab

let report_error ppf = function
  |  [] -> ()
  | err :: errs ->
      let print_errs ppf errs =
         List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in
      fprintf ppf "@[<v>%a%a@]" include_err err print_errs errs

end
module Includecore : sig 
#1 "includecore.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Inclusion checks for the core language *)

open Typedtree
open Types

exception Dont_match

type type_mismatch =
    Arity
  | Privacy
  | Kind
  | Constraint
  | Manifest
  | Variance
  | Field_type of Ident.t
  | Field_mutable of Ident.t
  | Field_arity of Ident.t
  | Field_names of int * Ident.t * Ident.t
  | Field_missing of bool * Ident.t
  | Record_representation of bool
  | Unboxed_representation of bool
  | Immediate

val value_descriptions:
  loc:Location.t -> Env.t -> Ident.t ->
  value_description -> value_description -> module_coercion    

val type_declarations:
  ?equality:bool ->
  loc:Location.t ->
  Env.t -> string ->
  type_declaration -> Ident.t -> type_declaration -> type_mismatch list

val extension_constructors:
  loc:Location.t ->
  Env.t -> Ident.t ->
  extension_constructor -> extension_constructor -> bool
(*
val class_types:
        Env.t -> class_type -> class_type -> bool
*)

val report_type_mismatch:
    string -> string -> string -> Format.formatter -> type_mismatch list -> unit

end = struct
#1 "includecore.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Inclusion checks for the core language *)

open Asttypes
open Path
open Types
open Typedtree

(* Inclusion between value descriptions *)

exception Dont_match

let value_descriptions ~loc env name
    (vd1 : Types.value_description)
    (vd2 : Types.value_description) =
  Builtin_attributes.check_deprecated_inclusion
    ~def:vd1.val_loc
    ~use:vd2.val_loc
    loc
    vd1.val_attributes vd2.val_attributes

    (Ident.name name);
  
  if Ctype.moregeneral env true vd1.val_type vd2.val_type then begin
    match (vd1.val_kind, vd2.val_kind) with
        (Val_prim p1, Val_prim p2) ->
          if p1 = p2 then Tcoerce_none else raise Dont_match
      | (Val_prim p, _) ->
          let pc = {pc_desc = p; pc_type = vd2.Types.val_type;
                  pc_env = env; pc_loc = vd1.Types.val_loc;

    pc_id = name;

                   } in
          Tcoerce_primitive pc
      | (_, Val_prim _) -> raise Dont_match
      | (_, _) -> Tcoerce_none
  end else
    raise Dont_match

(* Inclusion between "private" annotations *)

let private_flags decl1 decl2 =
  match decl1.type_private, decl2.type_private with
  | Private, Public ->
      decl2.type_kind = Type_abstract &&
      (decl2.type_manifest = None || decl1.type_kind <> Type_abstract)
  | _, _ -> true

(* Inclusion between manifest types (particularly for private row types) *)

let is_absrow env ty =
  match ty.desc with
    Tconstr(Pident _, _, _) ->
      begin match Ctype.expand_head env ty with
        {desc=Tobject _|Tvariant _} -> true
      | _ -> false
      end
  | _ -> false

let type_manifest env ty1 params1 ty2 params2 priv2 =
  let ty1' = Ctype.expand_head env ty1 and ty2' = Ctype.expand_head env ty2 in
  match ty1'.desc, ty2'.desc with
    Tvariant row1, Tvariant row2 when is_absrow env (Btype.row_more row2) ->
      let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in
      Ctype.equal env true (ty1::params1) (row2.row_more::params2) &&
      begin match row1.row_more with
        {desc=Tvar _|Tconstr _|Tnil} -> true
      | _ -> false
      end &&
      let r1, r2, pairs =
        Ctype.merge_row_fields row1.row_fields row2.row_fields in
      (not row2.row_closed ||
       row1.row_closed && Ctype.filter_row_fields false r1 = []) &&
      List.for_all
        (fun (_,f) -> match Btype.row_field_repr f with
          Rabsent | Reither _ -> true | Rpresent _ -> false)
        r2 &&
      let to_equal = ref (List.combine params1 params2) in
      List.for_all
        (fun (_, f1, f2) ->
          match Btype.row_field_repr f1, Btype.row_field_repr f2 with
            Rpresent(Some t1),
            (Rpresent(Some t2) | Reither(false, [t2], _, _)) ->
              to_equal := (t1,t2) :: !to_equal; true
          | Rpresent None, (Rpresent None | Reither(true, [], _, _)) -> true
          | Reither(c1,tl1,_,_), Reither(c2,tl2,_,_)
            when List.length tl1 = List.length tl2 && c1 = c2 ->
              to_equal := List.combine tl1 tl2 @ !to_equal; true
          | Rabsent, (Reither _ | Rabsent) -> true
          | _ -> false)
        pairs &&
      let tl1, tl2 = List.split !to_equal in
      Ctype.equal env true tl1 tl2
  | Tobject (fi1, _), Tobject (fi2, _)
    when is_absrow env (snd(Ctype.flatten_fields fi2)) ->
      let (fields2,rest2) = Ctype.flatten_fields fi2 in
      Ctype.equal env true (ty1::params1) (rest2::params2) &&
      let (fields1,rest1) = Ctype.flatten_fields fi1 in
      (match rest1 with {desc=Tnil|Tvar _|Tconstr _} -> true | _ -> false) &&
      let pairs, _miss1, miss2 = Ctype.associate_fields fields1 fields2 in
      miss2 = [] &&
      let tl1, tl2 =
        List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) in
      Ctype.equal env true (params1 @ tl1) (params2 @ tl2)
  | _ ->
      let rec check_super ty1 =
        Ctype.equal env true (ty1 :: params1) (ty2 :: params2) ||
        priv2 = Private &&
        try check_super
              (Ctype.try_expand_once_opt env (Ctype.expand_head env ty1))
        with Ctype.Cannot_expand -> false
      in check_super ty1

(* Inclusion between type declarations *)

type type_mismatch =
    Arity
  | Privacy
  | Kind
  | Constraint
  | Manifest
  | Variance
  | Field_type of Ident.t
  | Field_mutable of Ident.t
  | Field_arity of Ident.t
  | Field_names of int * Ident.t * Ident.t
  | Field_missing of bool * Ident.t
  | Record_representation of bool   (* true means second one is unboxed float *)
  | Unboxed_representation of bool  (* true means second one is unboxed *)
  | Immediate

let report_type_mismatch0 first second decl ppf err =
  let pr fmt = Format.fprintf ppf fmt in
  match err with
    Arity -> pr "They have different arities"
  | Privacy -> pr "A private type would be revealed"
  | Kind -> pr "Their kinds differ"
  | Constraint -> pr "Their constraints differ"
  | Manifest -> ()
  | Variance -> pr "Their variances do not agree"
  | Field_type s ->
      pr "The types for field %s are not equal" (Ident.name s)
  | Field_mutable s ->
      pr "The mutability of field %s is different" (Ident.name s)
  | Field_arity s ->
      pr "The arities for field %s differ" (Ident.name s)
  | Field_names (n, name1, name2) ->
      pr "Fields number %i have different names, %s and %s"
        n (Ident.name name1) (Ident.name name2)
  | Field_missing (b, s) ->
      pr "The field %s is only present in %s %s"
        (Ident.name s) (if b then second else first) decl
  | Record_representation b ->
      pr "Their internal representations differ:@ %s %s %s"
        (if b then second else first) decl
        "uses unboxed float representation"
  | Unboxed_representation b ->
      pr "Their internal representations differ:@ %s %s %s"
         (if b then second else first) decl
         "uses unboxed representation"
  | Immediate -> pr "%s is not an immediate type" first

let report_type_mismatch first second decl ppf =
  List.iter
    (fun err ->
      if err = Manifest then () else
      Format.fprintf ppf "@ %a." (report_type_mismatch0 first second decl) err)

let rec compare_constructor_arguments ~loc env cstr params1 params2 arg1 arg2 =
  match arg1, arg2 with
  | Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 ->
      if List.length arg1 <> List.length arg2 then [Field_arity cstr]
      else if
        (* Ctype.equal must be called on all arguments at once, cf. PR#7378 *)
        Ctype.equal env true (params1 @ arg1) (params2 @ arg2)
      then [] else [Field_type cstr]
  | Types.Cstr_record l1, Types.Cstr_record l2 ->
      compare_records env ~loc params1 params2 0 l1 l2
  | _ -> [Field_type cstr]

and compare_variants ~loc env params1 params2 n
    (cstrs1 : Types.constructor_declaration list)
    (cstrs2 : Types.constructor_declaration list) =
  match cstrs1, cstrs2 with
    [], []           -> []
  | [], c::_ -> [Field_missing (true, c.Types.cd_id)]
  | c::_, [] -> [Field_missing (false, c.Types.cd_id)]
  | cd1::rem1, cd2::rem2 ->
      if Ident.name cd1.cd_id <> Ident.name cd2.cd_id then
        [Field_names (n, cd1.cd_id, cd2.cd_id)]
      else begin
        Builtin_attributes.check_deprecated_inclusion
          ~def:cd1.cd_loc
          ~use:cd2.cd_loc
          loc
          cd1.cd_attributes cd2.cd_attributes
          (Ident.name cd1.cd_id);
        let r =
          match cd1.cd_res, cd2.cd_res with
          | Some r1, Some r2 ->
              if Ctype.equal env true [r1] [r2] then
                compare_constructor_arguments ~loc env cd1.cd_id [r1] [r2]
                  cd1.cd_args cd2.cd_args
              else [Field_type cd1.cd_id]
          | Some _, None | None, Some _ ->
              [Field_type cd1.cd_id]
          | _ ->
              compare_constructor_arguments ~loc env cd1.cd_id
                params1 params2 cd1.cd_args cd2.cd_args
        in
        if r <> [] then r
        else compare_variants ~loc env params1 params2 (n+1) rem1 rem2
      end


and compare_records ~loc env params1 params2 n
    (labels1 : Types.label_declaration list)
    (labels2 : Types.label_declaration list) =
  match labels1, labels2 with
    [], []           -> []
  | [], l::_ -> [Field_missing (true, l.Types.ld_id)]
  | l::_, [] -> [Field_missing (false, l.Types.ld_id)]
  | ld1::rem1, ld2::rem2 ->
      if Ident.name ld1.ld_id <> Ident.name ld2.ld_id
      then [Field_names (n, ld1.ld_id, ld2.ld_id)]
      else if ld1.ld_mutable <> ld2.ld_mutable then [Field_mutable ld1.ld_id] else begin
        Builtin_attributes.check_deprecated_mutable_inclusion
          ~def:ld1.ld_loc
          ~use:ld2.ld_loc
          loc
          ld1.ld_attributes ld2.ld_attributes
          (Ident.name ld1.ld_id);
        if Ctype.equal env true (ld1.ld_type::params1)(ld2.ld_type::params2)
        then (* add arguments to the parameters, cf. PR#7378 *)
          compare_records ~loc env
            (ld1.ld_type::params1) (ld2.ld_type::params2)
            (n+1)
            rem1 rem2
        else
          [Field_type ld1.ld_id]
      end

let type_declarations ?(equality = false) ~loc env name decl1 id decl2 =
  Builtin_attributes.check_deprecated_inclusion
    ~def:decl1.type_loc
    ~use:decl2.type_loc
    loc
    decl1.type_attributes decl2.type_attributes
    name;
  if decl1.type_arity <> decl2.type_arity then [Arity] else
  if not (private_flags decl1 decl2) then [Privacy] else
  let err = match (decl1.type_manifest, decl2.type_manifest) with
      (_, None) ->
        if Ctype.equal env true decl1.type_params decl2.type_params
        then [] else [Constraint]
    | (Some ty1, Some ty2) ->
        if type_manifest env ty1 decl1.type_params ty2 decl2.type_params
            decl2.type_private
        then [] else [Manifest]
    | (None, Some ty2) ->
        let ty1 =
          Btype.newgenty (Tconstr(Pident id, decl2.type_params, ref Mnil))
        in
        if Ctype.equal env true decl1.type_params decl2.type_params then
          if Ctype.equal env false [ty1] [ty2] then []
          else [Manifest]
        else [Constraint]
  in
  if err <> [] then err else
  let err =
    match (decl2.type_kind, decl1.type_unboxed.unboxed,
           decl2.type_unboxed.unboxed) with
    | Type_abstract, _, _ -> []
    | _, true, false -> [Unboxed_representation false]
    | _, false, true -> [Unboxed_representation true]
    | _ -> []
  in
  if err <> [] then err else
  let err = match (decl1.type_kind, decl2.type_kind) with
      (_, Type_abstract) -> []
    | (Type_variant cstrs1, Type_variant cstrs2) ->
        let mark cstrs usage name decl =
          List.iter
            (fun c ->
              Env.mark_constructor_used usage env name decl
                                        (Ident.name c.Types.cd_id))
            cstrs
        in
        let usage =
          if decl1.type_private = Private || decl2.type_private = Public
          then Env.Positive else Env.Privatize
        in
        mark cstrs1 usage name decl1;
        if equality then mark cstrs2 Env.Positive (Ident.name id) decl2;
        compare_variants ~loc env decl1.type_params decl2.type_params 1 cstrs1 cstrs2
    | (Type_record(labels1,rep1), Type_record(labels2,rep2)) ->
        let err = compare_records ~loc env decl1.type_params decl2.type_params
            1 labels1 labels2 in
        if err <> [] || rep1 = rep2 then err else
        [Record_representation (rep2 = Record_float)]
    | (Type_open, Type_open) -> []
    | (_, _) -> [Kind]
  in
  if err <> [] then err else
  let abstr = decl2.type_kind = Type_abstract && decl2.type_manifest = None in
  (* If attempt to assign a non-immediate type (e.g. string) to a type that
   * must be immediate, then we error *)
  let err =
    if abstr &&
       not decl1.type_immediate &&
       decl2.type_immediate then
      [Immediate]
    else []
  in
  if err <> [] then err else
  let need_variance =
    abstr || decl1.type_private = Private || decl1.type_kind = Type_open in
  if not need_variance then [] else
  let abstr = abstr || decl2.type_private = Private in
  let opn = decl2.type_kind = Type_open && decl2.type_manifest = None in
  let constrained ty = not (Btype.(is_Tvar (repr ty))) in
  if List.for_all2
      (fun ty (v1,v2) ->
        let open Variance in
        let imp a b = not a || b in
        let (co1,cn1) = get_upper v1 and (co2,cn2) = get_upper v2 in
        (if abstr then (imp co1 co2 && imp cn1 cn2)
         else if opn || constrained ty then (co1 = co2 && cn1 = cn2)
         else true) &&
        let (p1,n1,i1,j1) = get_lower v1 and (p2,n2,i2,j2) = get_lower v2 in
        imp abstr (imp p2 p1 && imp n2 n1 && imp i2 i1 && imp j2 j1))
      decl2.type_params (List.combine decl1.type_variance decl2.type_variance)
  then [] else [Variance]

(* Inclusion between extension constructors *)

let extension_constructors ~loc env id ext1 ext2 =
  let usage =
    if ext1.ext_private = Private || ext2.ext_private = Public
    then Env.Positive else Env.Privatize
  in
  Env.mark_extension_used usage env ext1 (Ident.name id);
  let ty1 =
    Btype.newgenty (Tconstr(ext1.ext_type_path, ext1.ext_type_params, ref Mnil))
  in
  let ty2 =
    Btype.newgenty (Tconstr(ext2.ext_type_path, ext2.ext_type_params, ref Mnil))
  in
  if Ctype.equal env true
       (ty1 :: ext1.ext_type_params)
       (ty2 :: ext2.ext_type_params)
  then
    if compare_constructor_arguments ~loc env (Ident.create "")
        ext1.ext_type_params ext2.ext_type_params
        ext1.ext_args ext2.ext_args = [] then
      if match ext1.ext_ret_type, ext2.ext_ret_type with
          Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) -> false
        | Some _, None | None, Some _ -> false
        | _ -> true
      then
        match ext1.ext_private, ext2.ext_private with
            Private, Public -> false
          | _, _ -> true
      else false
    else false
  else false

end
module Mtype : sig 
#1 "mtype.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Operations on module types *)

open Types

val scrape: Env.t -> module_type -> module_type
        (* Expand toplevel module type abbreviations
           till hitting a "hard" module type (signature, functor,
           or abstract module type ident. *)
val freshen: module_type -> module_type
        (* Return an alpha-equivalent copy of the given module type
           where bound identifiers are fresh. *)
val strengthen: aliasable:bool -> Env.t -> module_type -> Path.t -> module_type
        (* Strengthen abstract type components relative to the
           given path. *)
val strengthen_decl:
  aliasable:bool -> Env.t -> module_declaration -> Path.t -> module_declaration
val nondep_supertype: Env.t -> Ident.t -> module_type -> module_type
        (* Return the smallest supertype of the given type
           in which the given ident does not appear.
           Raise [Not_found] if no such type exists. *)
val no_code_needed: Env.t -> module_type -> bool
val no_code_needed_sig: Env.t -> signature -> bool
        (* Determine whether a module needs no implementation code,
           i.e. consists only of type definitions. *)
val enrich_modtype: Env.t -> Path.t -> module_type -> module_type
val enrich_typedecl: Env.t -> Path.t -> type_declaration -> type_declaration
val type_paths: Env.t -> Path.t -> module_type -> Path.t list
val contains_type: Env.t -> module_type -> bool
val remove_aliases: Env.t -> module_type -> module_type
val lower_nongen: int -> module_type -> unit

end = struct
#1 "mtype.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Operations on module types *)

open Asttypes
open Path
open Types


let rec scrape env mty =
  match mty with
    Mty_ident p ->
      begin try
        scrape env (Env.find_modtype_expansion p env)
      with Not_found ->
        mty
      end
  | _ -> mty

let freshen mty =
  Subst.modtype Subst.identity mty

let rec strengthen ~aliasable env mty p =
  match scrape env mty with
    Mty_signature sg ->
      Mty_signature(strengthen_sig ~aliasable env sg p 0)
  | Mty_functor(param, arg, res)
    when !Clflags.applicative_functors && Ident.name param <> "*" ->
      Mty_functor(param, arg,
        strengthen ~aliasable:false env res (Papply(p, Pident param)))
  | mty ->
      mty

and strengthen_sig ~aliasable env sg p pos =
  match sg with
    [] -> []
  | (Sig_value(_, desc) as sigelt) :: rem ->
      let nextpos =
        match desc.val_kind with
        | Val_prim _ -> pos
        | _ -> pos + 1
      in
      sigelt :: strengthen_sig ~aliasable env rem p nextpos
  | Sig_type(id, {type_kind=Type_abstract}, _) ::
    (Sig_type(id', {type_private=Private}, _) :: _ as rem)
    when Ident.name id = Ident.name id' ^ "#row" ->
      strengthen_sig ~aliasable env rem p pos
  | Sig_type(id, decl, rs) :: rem ->
      let newdecl =
        match decl.type_manifest, decl.type_private, decl.type_kind with
          Some _, Public, _ -> decl
        | Some _, Private, (Type_record _ | Type_variant _) -> decl
        | _ ->
            let manif =
              Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id, nopos),
                                          decl.type_params, ref Mnil))) in
            if decl.type_kind = Type_abstract then
              { decl with type_private = Public; type_manifest = manif }
            else
              { decl with type_manifest = manif }
      in
      Sig_type(id, newdecl, rs) :: strengthen_sig ~aliasable env rem p pos
  | (Sig_typext _ as sigelt) :: rem ->
      sigelt :: strengthen_sig ~aliasable env rem p (pos+1)
  | Sig_module(id, md, rs) :: rem ->
      let str =
        strengthen_decl ~aliasable env md (Pdot(p, Ident.name id, pos))
      in
      Sig_module(id, str, rs)
      :: strengthen_sig ~aliasable
        (Env.add_module_declaration ~check:false id md env) rem p (pos+1)
      (* Need to add the module in case it defines manifest module types *)
  | Sig_modtype(id, decl) :: rem ->
      let newdecl =
        match decl.mtd_type with
          None ->
            {decl with mtd_type = Some(Mty_ident(Pdot(p,Ident.name id,nopos)))}
        | Some _ ->
            decl
      in
      Sig_modtype(id, newdecl) ::
      strengthen_sig ~aliasable (Env.add_modtype id decl env) rem p pos
      (* Need to add the module type in case it is manifest *)
  | (Sig_class _ as sigelt) :: rem ->
      sigelt :: strengthen_sig ~aliasable env rem p (pos+1)
  | (Sig_class_type _ as sigelt) :: rem ->
      sigelt :: strengthen_sig ~aliasable env rem p pos

and strengthen_decl ~aliasable env md p =
  match md.md_type with
  | Mty_alias _ -> md
  | _ when aliasable -> {md with md_type = Mty_alias(Mta_present, p)}
  | mty -> {md with md_type = strengthen ~aliasable env mty p}

let () = Env.strengthen := strengthen

(* In nondep_supertype, env is only used for the type it assigns to id.
   Hence there is no need to keep env up-to-date by adding the bindings
   traversed. *)

type variance = Co | Contra | Strict

let nondep_supertype env mid mty =

  let rec nondep_mty env va mty =
    match mty with
      Mty_ident p ->
        if Path.isfree mid p then
          nondep_mty env va (Env.find_modtype_expansion p env)
        else mty
    | Mty_alias(_, p) ->
        if Path.isfree mid p then
          nondep_mty env va (Env.find_module p env).md_type
        else mty
    | Mty_signature sg ->
        Mty_signature(nondep_sig env va sg)
    | Mty_functor(param, arg, res) ->
        let var_inv =
          match va with Co -> Contra | Contra -> Co | Strict -> Strict in
        Mty_functor(param, Misc.may_map (nondep_mty env var_inv) arg,
                    nondep_mty
                      (Env.add_module ~arg:true param
                         (Btype.default_mty arg) env) va res)

  and nondep_sig env va = function
    [] -> []
  | item :: rem ->
      let rem' = nondep_sig env va rem in
      match item with
        Sig_value(id, d) ->
          Sig_value(id,
                    {d with val_type = Ctype.nondep_type env mid d.val_type})
          :: rem'
      | Sig_type(id, d, rs) ->
          Sig_type(id, Ctype.nondep_type_decl env mid id (va = Co) d, rs)
          :: rem'
      | Sig_typext(id, ext, es) ->
          Sig_typext(id, Ctype.nondep_extension_constructor env mid ext, es)
          :: rem'
      | Sig_module(id, md, rs) ->
          Sig_module(id, {md with md_type=nondep_mty env va md.md_type}, rs)
          :: rem'
      | Sig_modtype(id, d) ->
          begin try
            Sig_modtype(id, nondep_modtype_decl env d) :: rem'
          with Not_found ->
            match va with
              Co -> Sig_modtype(id, {mtd_type=None; mtd_loc=Location.none;
                                     mtd_attributes=[]}) :: rem'
            | _  -> raise Not_found
          end
      | Sig_class(id, d, rs) ->
          Sig_class(id, Ctype.nondep_class_declaration env mid d, rs)
          :: rem'
      | Sig_class_type(id, d, rs) ->
          Sig_class_type(id, Ctype.nondep_cltype_declaration env mid d, rs)
          :: rem'

  and nondep_modtype_decl env mtd =
    {mtd with mtd_type = Misc.may_map (nondep_mty env Strict) mtd.mtd_type}

  in
    nondep_mty env Co mty

let enrich_typedecl env p decl =
  match decl.type_manifest with
    Some _ -> decl
  | None ->
      try
        let orig_decl = Env.find_type p env in
        if orig_decl.type_arity <> decl.type_arity
        then decl
        else {decl with type_manifest =
                Some(Btype.newgenty(Tconstr(p, decl.type_params, ref Mnil)))}
      with Not_found ->
        decl

let rec enrich_modtype env p mty =
  match mty with
    Mty_signature sg ->
      Mty_signature(List.map (enrich_item env p) sg)
  | _ ->
      mty

and enrich_item env p = function
    Sig_type(id, decl, rs) ->
      Sig_type(id,
                enrich_typedecl env (Pdot(p, Ident.name id, nopos)) decl, rs)
  | Sig_module(id, md, rs) ->
      Sig_module(id,
                  {md with
                   md_type = enrich_modtype env
                       (Pdot(p, Ident.name id, nopos)) md.md_type},
                 rs)
  | item -> item

let rec type_paths env p mty =
  match scrape env mty with
    Mty_ident _ -> []
  | Mty_alias _ -> []
  | Mty_signature sg -> type_paths_sig env p 0 sg
  | Mty_functor _ -> []

and type_paths_sig env p pos sg =
  match sg with
    [] -> []
  | Sig_value(_id, decl) :: rem ->
      let pos' = match decl.val_kind with Val_prim _ -> pos | _ -> pos + 1 in
      type_paths_sig env p pos' rem
  | Sig_type(id, _decl, _) :: rem ->
      Pdot(p, Ident.name id, nopos) :: type_paths_sig env p pos rem
  | Sig_module(id, md, _) :: rem ->
      type_paths env (Pdot(p, Ident.name id, pos)) md.md_type @
      type_paths_sig (Env.add_module_declaration ~check:false id md env)
        p (pos+1) rem
  | Sig_modtype(id, decl) :: rem ->
      type_paths_sig (Env.add_modtype id decl env) p pos rem
  | (Sig_typext _ | Sig_class _) :: rem ->
      type_paths_sig env p (pos+1) rem
  | (Sig_class_type _) :: rem ->
      type_paths_sig env p pos rem

let rec no_code_needed env mty =
  match scrape env mty with
    Mty_ident _ -> false
  | Mty_signature sg -> no_code_needed_sig env sg
  | Mty_functor(_, _, _) -> false
  | Mty_alias(Mta_absent, _) -> true
  | Mty_alias(Mta_present, _) -> false

and no_code_needed_sig env sg =
  match sg with
    [] -> true
  | Sig_value(_id, decl) :: rem ->
      begin match decl.val_kind with
      | Val_prim _ -> no_code_needed_sig env rem
      | _ -> false
      end
  | Sig_module(id, md, _) :: rem ->
      no_code_needed env md.md_type &&
      no_code_needed_sig
        (Env.add_module_declaration ~check:false id md env) rem
  | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem ->
      no_code_needed_sig env rem
  | (Sig_typext _ | Sig_class _) :: _ ->
      false


(* Check whether a module type may return types *)

let rec contains_type env = function
    Mty_ident path ->
      begin try match (Env.find_modtype path env).mtd_type with
      | None -> raise Exit (* PR#6427 *)
      | Some mty -> contains_type env mty
      with Not_found -> raise Exit
      end
  | Mty_signature sg ->
      contains_type_sig env sg
  | Mty_functor (_, _, body) ->
      contains_type env body
  | Mty_alias _ ->
      ()

and contains_type_sig env = List.iter (contains_type_item env)

and contains_type_item env = function
    Sig_type (_,({type_manifest = None} |
                 {type_kind = Type_abstract; type_private = Private}),_)
  | Sig_modtype _
  | Sig_typext (_, {ext_args = Cstr_record _}, _) ->
      (* We consider that extension constructors with an inlined
         record create a type (the inlined record), even though
         it would be technically safe to ignore that considering
         the current constraints which guarantee that this type
         is kept local to expressions.  *)
      raise Exit
  | Sig_module (_, {md_type = mty}, _) ->
      contains_type env mty
  | Sig_value _
  | Sig_type _
  | Sig_typext _
  | Sig_class _
  | Sig_class_type _ ->
      ()

let contains_type env mty =
  try contains_type env mty; false with Exit -> true


(* Remove module aliases from a signature *)

module PathSet = Set.Make (Path)
module PathMap = Map.Make (Path)
module IdentSet = Set.Make (Ident)

let rec get_prefixes = function
    Pident _ -> PathSet.empty
  | Pdot (p, _, _)
  | Papply (p, _) -> PathSet.add p (get_prefixes p)

let rec get_arg_paths = function
    Pident _ -> PathSet.empty
  | Pdot (p, _, _) -> get_arg_paths p
  | Papply (p1, p2) ->
      PathSet.add p2
        (PathSet.union (get_prefixes p2)
           (PathSet.union (get_arg_paths p1) (get_arg_paths p2)))

let rec rollback_path subst p =
  try Pident (PathMap.find p subst)
  with Not_found ->
    match p with
      Pident _ | Papply _ -> p
    | Pdot (p1, s, n) ->
        let p1' = rollback_path subst p1 in
        if Path.same p1 p1' then p else rollback_path subst (Pdot (p1', s, n))

let rec collect_ids subst bindings p =
    begin match rollback_path subst p with
      Pident id ->
        let ids =
          try collect_ids subst bindings (Ident.find_same id bindings)
          with Not_found -> IdentSet.empty
        in
        IdentSet.add id ids
    | _ -> IdentSet.empty
    end

let collect_arg_paths mty =
  let open Btype in
  let paths = ref PathSet.empty
  and subst = ref PathMap.empty
  and bindings = ref Ident.empty in
  (* let rt = Ident.create "Root" in
     and prefix = ref (Path.Pident rt) in *)
  let it_path p = paths := PathSet.union (get_arg_paths p) !paths
  and it_signature_item it si =
    type_iterators.it_signature_item it si;
    match si with
      Sig_module (id, {md_type=Mty_alias(_, p)}, _) ->
        bindings := Ident.add id p !bindings
    | Sig_module (id, {md_type=Mty_signature sg}, _) ->
        List.iter
          (function Sig_module (id', _, _) ->
              subst :=
                PathMap.add (Pdot (Pident id, Ident.name id', -1)) id' !subst
            | _ -> ())
          sg
    | _ -> ()
  in
  let it = {type_iterators with it_path; it_signature_item} in
  it.it_module_type it mty;
  it.it_module_type unmark_iterators mty;
  PathSet.fold (fun p -> IdentSet.union (collect_ids !subst !bindings p))
    !paths IdentSet.empty

let rec remove_aliases env excl mty =
  match mty with
    Mty_signature sg ->
      Mty_signature (remove_aliases_sig env excl sg)
  | Mty_alias _ ->
      let mty' = Env.scrape_alias env mty in
      if mty' = mty then mty else
      remove_aliases env excl mty'
  | mty ->
      mty

and remove_aliases_sig env excl sg =
  match sg with
    [] -> []
  | Sig_module(id, md, rs) :: rem  ->
      let mty =
        match md.md_type with
          Mty_alias _ when IdentSet.mem id excl ->
            md.md_type
        | mty ->
            remove_aliases env excl mty
      in
      Sig_module(id, {md with md_type = mty} , rs) ::
      remove_aliases_sig (Env.add_module id mty env) excl rem
  | Sig_modtype(id, mtd) :: rem ->
      Sig_modtype(id, mtd) ::
      remove_aliases_sig (Env.add_modtype id mtd env) excl rem
  | it :: rem ->
      it :: remove_aliases_sig env excl rem

let remove_aliases env sg =
  let excl = collect_arg_paths sg in
  (* PathSet.iter (fun p -> Format.eprintf "%a@ " Printtyp.path p) excl;
  Format.eprintf "@."; *)
  remove_aliases env excl sg


(* Lower non-generalizable type variables *)

let lower_nongen nglev mty =
  let open Btype in
  let it_type_expr it ty =
    let ty = repr ty in
    match ty with
      {desc=Tvar _; level} ->
        if level < generic_level && level > nglev then set_level ty nglev
    | _ ->
        type_iterators.it_type_expr it ty
  in
  let it = {type_iterators with it_type_expr} in
  it.it_module_type it mty;
  it.it_module_type unmark_iterators mty

end
module Includemod : sig 
#1 "includemod.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Inclusion checks for the module language *)

open Typedtree
open Types
open Format

val modtypes:
  loc:Location.t -> Env.t ->
  module_type -> module_type -> module_coercion

val signatures: Env.t -> signature -> signature -> module_coercion

val compunit:
      Env.t -> string -> signature -> string -> signature -> module_coercion

val type_declarations:
  loc:Location.t -> Env.t ->
  Ident.t -> type_declaration -> type_declaration -> unit

val print_coercion: formatter -> module_coercion -> unit

type symptom =
    Missing_field of Ident.t * Location.t * string (* kind *)
  | Value_descriptions of Ident.t * value_description * value_description
  | Type_declarations of Ident.t * type_declaration
        * type_declaration * Includecore.type_mismatch list
  | Extension_constructors of
      Ident.t * extension_constructor * extension_constructor
  | Module_types of module_type * module_type
  | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration
  | Modtype_permutation
  | Interface_mismatch of string * string
  | Class_type_declarations of
      Ident.t * class_type_declaration * class_type_declaration *
      Ctype.class_match_failure list
  | Class_declarations of
      Ident.t * class_declaration * class_declaration *
      Ctype.class_match_failure list
  | Unbound_modtype_path of Path.t
  | Unbound_module_path of Path.t
  | Invalid_module_alias of Path.t

type pos =
    Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
type error = pos list * Env.t * symptom

exception Error of error list

val report_error: formatter -> error list -> unit
val expand_module_alias: Env.t -> pos list -> Path.t -> Types.module_type

end = struct
#1 "includemod.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Inclusion checks for the module language *)

open Misc
open Path
open Typedtree
open Types

type symptom =
    Missing_field of Ident.t * Location.t * string (* kind *)
  | Value_descriptions of Ident.t * value_description * value_description
  | Type_declarations of Ident.t * type_declaration
        * type_declaration * Includecore.type_mismatch list
  | Extension_constructors of
      Ident.t * extension_constructor * extension_constructor
  | Module_types of module_type * module_type
  | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration
  | Modtype_permutation
  | Interface_mismatch of string * string
  | Class_type_declarations of
      Ident.t * class_type_declaration * class_type_declaration *
      Ctype.class_match_failure list
  | Class_declarations of
      Ident.t * class_declaration * class_declaration *
      Ctype.class_match_failure list
  | Unbound_modtype_path of Path.t
  | Unbound_module_path of Path.t
  | Invalid_module_alias of Path.t

type pos =
    Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
type error = pos list * Env.t * symptom

exception Error of error list

(* All functions "blah env x1 x2" check that x1 is included in x2,
   i.e. that x1 is the type of an implementation that fulfills the
   specification x2. If not, Error is raised with a backtrace of the error. *)

(* Inclusion between value descriptions *)

let value_descriptions ~loc env cxt subst id vd1 vd2 =
  Cmt_format.record_value_dependency vd1 vd2;
  Env.mark_value_used env (Ident.name id) vd1;
  let vd2 = Subst.value_description subst vd2 in
  try

    Includecore.value_descriptions ~loc env id vd1 vd2
      
  with Includecore.Dont_match ->
    raise(Error[cxt, env, Value_descriptions(id, vd1, vd2)])

(* Inclusion between type declarations *)

let type_declarations ~loc env ?(old_env=env) cxt subst id decl1 decl2 =
  Env.mark_type_used env (Ident.name id) decl1;
  let decl2 = Subst.type_declaration subst decl2 in
  let err =
    Includecore.type_declarations ~loc env (Ident.name id) decl1 id decl2
  in
  if err <> [] then
    raise(Error[cxt, old_env, Type_declarations(id, decl1, decl2, err)])

(* Inclusion between extension constructors *)

let extension_constructors ~loc env cxt subst id ext1 ext2 =
  let ext2 = Subst.extension_constructor subst ext2 in
  if Includecore.extension_constructors ~loc env id ext1 ext2
  then ()
  else raise(Error[cxt, env, Extension_constructors(id, ext1, ext2)])

(* Inclusion between class declarations *)

let class_type_declarations ~loc ~old_env env cxt subst id decl1 decl2 =
  let decl2 = Subst.cltype_declaration subst decl2 in
  match Includeclass.class_type_declarations ~loc env decl1 decl2 with
    []     -> ()
  | reason ->
      raise(Error[cxt, old_env,
                  Class_type_declarations(id, decl1, decl2, reason)])

let class_declarations ~old_env env cxt subst id decl1 decl2 =
  let decl2 = Subst.class_declaration subst decl2 in
  match Includeclass.class_declarations env decl1 decl2 with
    []     -> ()
  | reason ->
      raise(Error[cxt, old_env, Class_declarations(id, decl1, decl2, reason)])

(* Expand a module type identifier when possible *)

exception Dont_match

let may_expand_module_path env path =
  try ignore (Env.find_modtype_expansion path env); true
  with Not_found -> false

let expand_module_path env cxt path =
  try
    Env.find_modtype_expansion path env
  with Not_found ->
    raise(Error[cxt, env, Unbound_modtype_path path])

let expand_module_alias env cxt path =
  try (Env.find_module path env).md_type
  with Not_found ->
    raise(Error[cxt, env, Unbound_module_path path])

(*
let rec normalize_module_path env cxt path =
  match expand_module_alias env cxt path with
    Mty_alias path' -> normalize_module_path env cxt path'
  | _ -> path
*)

(* Extract name, kind and ident from a signature item *)

type field_desc =
    Field_value of string
  | Field_type of string
  | Field_typext of string
  | Field_module of string
  | Field_modtype of string
  | Field_class of string
  | Field_classtype of string

let kind_of_field_desc = function
  | Field_value _ -> "value"
  | Field_type _ -> "type"
  | Field_typext _ -> "extension constructor"
  | Field_module _ -> "module"
  | Field_modtype _ -> "module type"
  | Field_class _ -> "class"
  | Field_classtype _ -> "class type"

let item_ident_name = function
    Sig_value(id, d) -> (id, d.val_loc, Field_value(Ident.name id))
  | Sig_type(id, d, _) -> (id, d.type_loc, Field_type(Ident.name id))
  | Sig_typext(id, d, _) -> (id, d.ext_loc, Field_typext(Ident.name id))
  | Sig_module(id, d, _) -> (id, d.md_loc, Field_module(Ident.name id))
  | Sig_modtype(id, d) -> (id, d.mtd_loc, Field_modtype(Ident.name id))
  | Sig_class(id, d, _) -> (id, d.cty_loc, Field_class(Ident.name id))
  | Sig_class_type(id, d, _) -> (id, d.clty_loc, Field_classtype(Ident.name id))

let is_runtime_component = function
  | Sig_value(_,{val_kind = Val_prim _})
  | Sig_type(_,_,_)
  | Sig_modtype(_,_)
  | Sig_class_type(_,_,_) -> false
  | Sig_value(_,_)
  | Sig_typext(_,_,_)
  | Sig_module(_,_,_)
  | Sig_class(_, _,_) -> true

(* Print a coercion *)

let rec print_list pr ppf = function
    [] -> ()
  | [a] -> pr ppf a
  | a :: l -> pr ppf a; Format.fprintf ppf ";@ "; print_list pr ppf l
let print_list pr ppf l =
  Format.fprintf ppf "[@[%a@]]" (print_list pr) l

let rec print_coercion ppf c =
  let pr fmt = Format.fprintf ppf fmt in
  match c with
    Tcoerce_none -> pr "id"
  | Tcoerce_structure (fl, nl) ->
      pr "@[<2>struct@ %a@ %a@]"
        (print_list print_coercion2) fl
        (print_list print_coercion3) nl
  | Tcoerce_functor (inp, out) ->
      pr "@[<2>functor@ (%a)@ (%a)@]"
        print_coercion inp
        print_coercion out
  | Tcoerce_primitive {pc_desc; pc_env = _; pc_type}  ->
      pr "prim %s@ (%a)" pc_desc.Primitive.prim_name
        Printtyp.raw_type_expr pc_type
  | Tcoerce_alias (p, c) ->
      pr "@[<2>alias %a@ (%a)@]"
        Printtyp.path p
        print_coercion c
and print_coercion2 ppf (n, c) =
  Format.fprintf ppf "@[%d,@ %a@]" n print_coercion c
and print_coercion3 ppf (i, n, c) =
  Format.fprintf ppf "@[%s, %d,@ %a@]"
    (Ident.unique_name i) n print_coercion c

(* Simplify a structure coercion *)

let simplify_structure_coercion cc id_pos_list =
  let rec is_identity_coercion pos = function
  | [] ->
      true
  | (n, c) :: rem ->
      n = pos && c = Tcoerce_none && is_identity_coercion (pos + 1) rem in
  if is_identity_coercion 0 cc
  then Tcoerce_none
  else Tcoerce_structure (cc, id_pos_list)

(* Inclusion between module types.
   Return the restriction that transforms a value of the smaller type
   into a value of the bigger type. *)

let rec modtypes ~loc env cxt subst mty1 mty2 =
  try
    try_modtypes ~loc env cxt subst mty1 mty2
  with
    Dont_match ->
      raise(Error[cxt, env, Module_types(mty1, Subst.modtype subst mty2)])
  | Error reasons as err ->
      match mty1, mty2 with
        Mty_alias _, _
      | _, Mty_alias _ -> raise err
      | _ ->
          raise(Error((cxt, env, Module_types(mty1, Subst.modtype subst mty2))
                      :: reasons))

and try_modtypes ~loc env cxt subst mty1 mty2 =
  match (mty1, mty2) with
  | (Mty_alias(pres1, p1), Mty_alias(pres2, p2)) -> begin
      if Env.is_functor_arg p2 env then
        raise (Error[cxt, env, Invalid_module_alias p2]);
      if not (Path.same p1 p2) then begin
        let p1 = Env.normalize_path None env p1
        and p2 = Env.normalize_path None env (Subst.module_path subst p2) in
        if not (Path.same p1 p2) then raise Dont_match
      end;
      match pres1, pres2 with
      | Mta_present, Mta_present -> Tcoerce_none
        (* Should really be Tcoerce_ignore if it existed *)
      | Mta_absent, Mta_absent -> Tcoerce_none
        (* Should really be Tcoerce_empty if it existed *)
      | Mta_present, Mta_absent -> Tcoerce_none
      | Mta_absent, Mta_present ->
        let p1 = try
            Env.normalize_path (Some Location.none) env p1
          with Env.Error (Env.Missing_module (_, _, path)) ->
            raise (Error[cxt, env, Unbound_module_path path])
        in
        Tcoerce_alias (p1, Tcoerce_none)
    end
  | (Mty_alias(pres1, p1), _) -> begin
      let p1 = try
        Env.normalize_path (Some Location.none) env p1
      with Env.Error (Env.Missing_module (_, _, path)) ->
        raise (Error[cxt, env, Unbound_module_path path])
      in
      let mty1 =
        Mtype.strengthen ~aliasable:true env
          (expand_module_alias env cxt p1) p1
      in
      let cc = modtypes ~loc env cxt subst mty1 mty2 in
      match pres1 with
      | Mta_present -> cc
      | Mta_absent -> Tcoerce_alias (p1, cc)
    end
  | (Mty_ident p1, _) when may_expand_module_path env p1 ->
      try_modtypes ~loc env cxt subst (expand_module_path env cxt p1) mty2
  | (_, Mty_ident _) ->
      try_modtypes2 ~loc env cxt mty1 (Subst.modtype subst mty2)
  | (Mty_signature sig1, Mty_signature sig2) ->
      signatures ~loc env cxt subst sig1 sig2
  | (Mty_functor(param1, None, res1), Mty_functor(_param2, None, res2)) ->
      begin match modtypes ~loc env (Body param1::cxt) subst res1 res2 with
        Tcoerce_none -> Tcoerce_none
      | cc -> Tcoerce_functor (Tcoerce_none, cc)
      end
  | (Mty_functor(param1, Some arg1, res1),
     Mty_functor(param2, Some arg2, res2)) ->
      let arg2' = Subst.modtype subst arg2 in
      let cc_arg = modtypes ~loc env (Arg param1::cxt) Subst.identity arg2' arg1 in
      let cc_res =
        modtypes ~loc (Env.add_module param1 arg2' env) (Body param1::cxt)
          (Subst.add_module param2 (Pident param1) subst) res1 res2 in
      begin match (cc_arg, cc_res) with
          (Tcoerce_none, Tcoerce_none) -> Tcoerce_none
        | _ -> Tcoerce_functor(cc_arg, cc_res)
      end
  | (_, _) ->
      raise Dont_match

and try_modtypes2 ~loc env cxt mty1 mty2 =
  (* mty2 is an identifier *)
  match (mty1, mty2) with
    (Mty_ident p1, Mty_ident p2)
    when Path.same (Env.normalize_path_prefix None env p1)
                   (Env.normalize_path_prefix None env p2) ->
      Tcoerce_none
  | (_, Mty_ident p2) when may_expand_module_path env p2 ->
      try_modtypes ~loc env cxt Subst.identity mty1 (expand_module_path env cxt p2)
  | (_, _) ->
      raise Dont_match

(* Inclusion between signatures *)

and signatures ~loc env cxt subst sig1 sig2 =
  (* Environment used to check inclusion of components *)
  let new_env =
    Env.add_signature sig1 (Env.in_signature true env) in
  (* Keep ids for module aliases *)
  let (id_pos_list,_) =
    List.fold_left
      (fun (l,pos) -> function
          Sig_module (id, _, _) ->
            ((id,pos,Tcoerce_none)::l , pos+1)
        | item -> (l, if is_runtime_component item then pos+1 else pos))
      ([], 0) sig1 in
  (* Build a table of the components of sig1, along with their positions.
     The table is indexed by kind and name of component *)
  let rec build_component_table pos tbl = function
      [] -> pos, tbl
    | item :: rem ->
        let (id, _loc, name) = item_ident_name item in
        let nextpos = if is_runtime_component item then pos + 1 else pos in
        build_component_table nextpos
                              (Tbl.add name (id, item, pos) tbl) rem in
  let len1, comps1 =
    build_component_table 0 Tbl.empty sig1 in
  let len2 =
    List.fold_left
      (fun n i -> if is_runtime_component i then n + 1 else n)
      0
      sig2
  in
  (* Pair each component of sig2 with a component of sig1,
     identifying the names along the way.
     Return a coercion list indicating, for all run-time components
     of sig2, the position of the matching run-time components of sig1
     and the coercion to be applied to it. *)
  let rec pair_components subst paired unpaired = function
      [] ->
        begin match unpaired with
            [] ->
              let cc =
                signature_components ~loc env new_env cxt subst
                  (List.rev paired)
              in
              if len1 = len2 then (* see PR#5098 *)
                simplify_structure_coercion cc id_pos_list
              else
                Tcoerce_structure (cc, id_pos_list)
          | _  -> raise(Error unpaired)
        end
    | item2 :: rem ->
        let (id2, loc, name2) = item_ident_name item2 in
        let name2, report =
          match item2, name2 with
            Sig_type (_, {type_manifest=None}, _), Field_type s
            when Btype.is_row_name s ->
              (* Do not report in case of failure,
                 as the main type will generate an error *)
              Field_type (String.sub s 0 (String.length s - 4)), false
          | _ -> name2, true
        in
        begin try
          let (id1, item1, pos1) = Tbl.find name2 comps1 in
          let new_subst =
            match item2 with
              Sig_type _ ->
                Subst.add_type id2 (Pident id1) subst
            | Sig_module _ ->
                Subst.add_module id2 (Pident id1) subst
            | Sig_modtype _ ->
                Subst.add_modtype id2 (Mty_ident (Pident id1)) subst
            | Sig_value _ | Sig_typext _
            | Sig_class _ | Sig_class_type _ ->
                subst
          in
          pair_components new_subst
            ((item1, item2, pos1) :: paired) unpaired rem
        with Not_found ->
          let unpaired =
            if report then
              (cxt, env, Missing_field (id2, loc, kind_of_field_desc name2)) ::
              unpaired
            else unpaired in
          pair_components subst paired unpaired rem
        end in
  (* Do the pairing and checking, and return the final coercion *)
  pair_components subst [] [] sig2

(* Inclusion between signature components *)

and signature_components ~loc old_env env cxt subst paired =
  let comps_rec rem = signature_components ~loc old_env env cxt subst rem in
  match paired with
    [] -> []
  | (Sig_value(id1, valdecl1), Sig_value(_id2, valdecl2), pos) :: rem ->
      let cc = value_descriptions ~loc env cxt subst id1 valdecl1 valdecl2 in
      begin match valdecl2.val_kind with
        Val_prim _ -> comps_rec rem
      | _ -> (pos, cc) :: comps_rec rem
      end
  | (Sig_type(id1, tydecl1, _), Sig_type(_id2, tydecl2, _), _pos) :: rem ->
      type_declarations ~loc ~old_env env cxt subst id1 tydecl1 tydecl2;
      comps_rec rem
  | (Sig_typext(id1, ext1, _), Sig_typext(_id2, ext2, _), pos)
    :: rem ->
      extension_constructors ~loc env cxt subst id1 ext1 ext2;
      (pos, Tcoerce_none) :: comps_rec rem
  | (Sig_module(id1, mty1, _), Sig_module(_id2, mty2, _), pos) :: rem ->
      let cc = module_declarations ~loc env cxt subst id1 mty1 mty2 in
      (pos, cc) :: comps_rec rem
  | (Sig_modtype(id1, info1), Sig_modtype(_id2, info2), _pos) :: rem ->
      modtype_infos ~loc env cxt subst id1 info1 info2;
      comps_rec rem
  | (Sig_class(id1, decl1, _), Sig_class(_id2, decl2, _), pos) :: rem ->
      class_declarations ~old_env env cxt subst id1 decl1 decl2;
      (pos, Tcoerce_none) :: comps_rec rem
  | (Sig_class_type(id1, info1, _),
     Sig_class_type(_id2, info2, _), _pos) :: rem ->
      class_type_declarations ~loc ~old_env env cxt subst id1 info1 info2;
      comps_rec rem
  | _ ->
      assert false

and module_declarations ~loc env cxt subst id1 md1 md2 =
  Builtin_attributes.check_deprecated_inclusion
    ~def:md1.md_loc
    ~use:md2.md_loc
    loc
    md1.md_attributes md2.md_attributes
    (Ident.name id1);
  let p1 = Pident id1 in
  Env.mark_module_used env (Ident.name id1) md1.md_loc;
  modtypes ~loc env (Module id1::cxt) subst
    (Mtype.strengthen ~aliasable:true env md1.md_type p1) md2.md_type

(* Inclusion between module type specifications *)

and modtype_infos ~loc env cxt subst id info1 info2 =
  Builtin_attributes.check_deprecated_inclusion
    ~def:info1.mtd_loc
    ~use:info2.mtd_loc
    loc
    info1.mtd_attributes info2.mtd_attributes
    (Ident.name id);
  let info2 = Subst.modtype_declaration subst info2 in
  let cxt' = Modtype id :: cxt in
  try
    match (info1.mtd_type, info2.mtd_type) with
      (None, None) -> ()
    | (Some _, None) -> ()
    | (Some mty1, Some mty2) ->
        check_modtype_equiv ~loc env cxt' mty1 mty2
    | (None, Some mty2) ->
        check_modtype_equiv ~loc env cxt' (Mty_ident(Pident id)) mty2
  with Error reasons ->
    raise(Error((cxt, env, Modtype_infos(id, info1, info2)) :: reasons))

and check_modtype_equiv ~loc env cxt mty1 mty2 =
  match
    (modtypes ~loc env cxt Subst.identity mty1 mty2,
     modtypes ~loc env cxt Subst.identity mty2 mty1)
  with
    (Tcoerce_none, Tcoerce_none) -> ()
  | (_c1, _c2) ->
      (* Format.eprintf "@[c1 = %a@ c2 = %a@]@."
        print_coercion _c1 print_coercion _c2; *)
      raise(Error [cxt, env, Modtype_permutation])

(* Simplified inclusion check between module types (for Env) *)

let can_alias env path =
  let rec no_apply = function
    | Pident _ -> true
    | Pdot(p, _, _) -> no_apply p
    | Papply _ -> false
  in
  no_apply path && not (Env.is_functor_arg path env)

let check_modtype_inclusion ~loc env mty1 path1 mty2 =
  try
    let aliasable = can_alias env path1 in
    ignore(modtypes ~loc env [] Subst.identity
                    (Mtype.strengthen ~aliasable env mty1 path1) mty2)
  with Error _ ->
    raise Not_found

let _ = Env.check_modtype_inclusion := check_modtype_inclusion

(* Check that an implementation of a compilation unit meets its
   interface. *)

let compunit env impl_name impl_sig intf_name intf_sig =
  try
    signatures ~loc:(Location.in_file impl_name) env [] Subst.identity
      impl_sig intf_sig
  with Error reasons ->
    raise(Error(([], Env.empty,Interface_mismatch(impl_name, intf_name))
                :: reasons))

(* Hide the context and substitution parameters to the outside world *)

let modtypes ~loc env mty1 mty2 = modtypes ~loc env [] Subst.identity mty1 mty2
let signatures env sig1 sig2 =
  signatures ~loc:Location.none env [] Subst.identity sig1 sig2
let type_declarations ~loc env id decl1 decl2 =
  type_declarations ~loc env [] Subst.identity id decl1 decl2

(*
let modtypes env m1 m2 =
  let c = modtypes env m1 m2 in
  Format.eprintf "@[<2>modtypes@ %a@ %a =@ %a@]@."
    Printtyp.modtype m1 Printtyp.modtype m2
    print_coercion c;
  c
*)

(* Error report *)

open Format
open Printtyp

let show_loc msg ppf loc =
  let pos = loc.Location.loc_start in
  if List.mem pos.Lexing.pos_fname [""; "_none_"; "//toplevel//"] then ()
  else fprintf ppf "@\n@[<2>%a:@ %s@]" Location.print_loc loc msg

let show_locs ppf (loc1, loc2) =
  show_loc "Expected declaration" ppf loc2;
  show_loc "Actual declaration" ppf loc1

let include_err ppf = function
  | Missing_field (id, loc, kind) ->
      fprintf ppf "The %s `%a' is required but not provided" kind ident id;
      show_loc "Expected declaration" ppf loc
  | Value_descriptions(id, d1, d2) ->
      fprintf ppf
        "@[<hv 2>Values do not match:@ %a@;<1 -2>is not included in@ %a@]"
        (value_description id) d1 (value_description id) d2;
      show_locs ppf (d1.val_loc, d2.val_loc);
  | Type_declarations(id, d1, d2, errs) ->
      fprintf ppf "@[<v>@[<hv>%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]"
        "Type declarations do not match"
        (type_declaration id) d1
        "is not included in"
        (type_declaration id) d2
        show_locs (d1.type_loc, d2.type_loc)
        (Includecore.report_type_mismatch
           "the first" "the second" "declaration") errs
  | Extension_constructors(id, x1, x2) ->
      fprintf ppf
       "@[<hv 2>Extension declarations do not match:@ \
        %a@;<1 -2>is not included in@ %a@]"
      (extension_constructor id) x1
      (extension_constructor id) x2;
      show_locs ppf (x1.ext_loc, x2.ext_loc)
  | Module_types(mty1, mty2)->
      fprintf ppf
       "@[<hv 2>Modules do not match:@ \
        %a@;<1 -2>is not included in@ %a@]"
      modtype mty1
      modtype mty2
  | Modtype_infos(id, d1, d2) ->
      fprintf ppf
       "@[<hv 2>Module type declarations do not match:@ \
        %a@;<1 -2>does not match@ %a@]"
      (modtype_declaration id) d1
      (modtype_declaration id) d2
  | Modtype_permutation ->
      fprintf ppf "Illegal permutation of structure fields"
  | Interface_mismatch(impl_name, intf_name) ->
      fprintf ppf "@[The implementation %s@ does not match the interface %s:"
       impl_name intf_name
  | Class_type_declarations(id, d1, d2, reason) ->
      fprintf ppf
       "@[<hv 2>Class type declarations do not match:@ \
        %a@;<1 -2>does not match@ %a@]@ %a"
      (Printtyp.cltype_declaration id) d1
      (Printtyp.cltype_declaration id) d2
      Includeclass.report_error reason
  | Class_declarations(id, d1, d2, reason) ->
      fprintf ppf
       "@[<hv 2>Class declarations do not match:@ \
        %a@;<1 -2>does not match@ %a@]@ %a"
      (Printtyp.class_declaration id) d1
      (Printtyp.class_declaration id) d2
      Includeclass.report_error reason
  | Unbound_modtype_path path ->
      fprintf ppf "Unbound module type %a" Printtyp.path path
  | Unbound_module_path path ->
      fprintf ppf "Unbound module %a" Printtyp.path path
  | Invalid_module_alias path ->
      fprintf ppf "Module %a cannot be aliased" Printtyp.path path

let rec context ppf = function
    Module id :: rem ->
      fprintf ppf "@[<2>module %a%a@]" ident id args rem
  | Modtype id :: rem ->
      fprintf ppf "@[<2>module type %a =@ %a@]" ident id context_mty rem
  | Body x :: rem ->
      fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem
  | Arg x :: rem ->
      fprintf ppf "functor (%a : %a) -> ..." ident x context_mty rem
  | [] ->
      fprintf ppf "<here>"
and context_mty ppf = function
    (Module _ | Modtype _) :: _ as rem ->
      fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem
  | cxt -> context ppf cxt
and args ppf = function
    Body x :: rem ->
      fprintf ppf "(%s)%a" (argname x) args rem
  | Arg x :: rem ->
      fprintf ppf "(%a :@ %a) : ..." ident x context_mty rem
  | cxt ->
      fprintf ppf " :@ %a" context_mty cxt
and argname x =
  let s = Ident.name x in
  if s = "*" then "" else s

let path_of_context = function
    Module id :: rem ->
      let rec subm path = function
          [] -> path
        | Module id :: rem -> subm (Pdot (path, Ident.name id, -1)) rem
        | _ -> assert false
      in subm (Pident id) rem
  | _ -> assert false

let context ppf cxt =
  if cxt = [] then () else
  if List.for_all (function Module _ -> true | _ -> false) cxt then
    fprintf ppf "In module %a:@ " path (path_of_context cxt)
  else
    fprintf ppf "@[<hv 2>At position@ %a@]@ " context cxt

let include_err ppf (cxt, env, err) =
  Printtyp.wrap_printing_env env (fun () ->
    fprintf ppf "@[<v>%a%a@]" context (List.rev cxt) include_err err)

let buffer = ref Bytes.empty
let is_big obj =
  let size = !Clflags.error_size in
  size > 0 &&
  begin
    if Bytes.length !buffer < size then buffer := Bytes.create size;
    try ignore (Marshal.to_buffer !buffer 0 size obj []); false
    with _ -> true
  end

let report_error ppf errs =
  if errs = [] then () else
  let (errs , err) = split_last errs in
  let pe = ref true in
  let include_err' ppf (_,_,obj as err) =
    if not (is_big obj) then fprintf ppf "%a@ " include_err err
    else if !pe then (fprintf ppf "...@ "; pe := false)
  in
  let print_errs ppf = List.iter (include_err' ppf) in
  fprintf ppf "@[<v>%a%a@]" print_errs errs include_err err


(* We could do a better job to split the individual error items
   as sub-messages of the main interface mismatch on the whole unit. *)
let () =
  Location.register_error_of_exn
    (function
      | Error err -> Some (Location.error_of_printer_file report_error err)
      | _ -> None
    )

end
module Stypes : sig 
#1 "stypes.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*           Damien Doligez, projet Moscova, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 2003 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Recording and dumping (partial) type information *)

(* Clflags.save_types must be true *)

open Typedtree;;

type annotation =
  | Ti_pat   of pattern
  | Ti_expr  of expression
  | Ti_class of class_expr
  | Ti_mod   of module_expr
  | An_call of Location.t * Annot.call
  | An_ident of Location.t * string * Annot.ident
;;

val record : annotation -> unit;;
val record_phrase : Location.t -> unit;;
val dump : string option -> unit;;

val get_location : annotation -> Location.t;;
val get_info : unit -> annotation list;;

end = struct
#1 "stypes.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*           Damien Doligez, projet Moscova, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 2003 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Recording and dumping (partial) type information *)

(*
  We record all types in a list as they are created.
  This means we can dump type information even if type inference fails,
  which is extremely important, since type information is most
  interesting in case of errors.
*)

open Annot;;
open Lexing;;
open Location;;
open Typedtree;;

let output_int oc i = output_string oc (string_of_int i)

type annotation =
  | Ti_pat   of pattern
  | Ti_expr  of expression
  | Ti_class of class_expr
  | Ti_mod   of module_expr
  | An_call of Location.t * Annot.call
  | An_ident of Location.t * string * Annot.ident
;;

let get_location ti =
  match ti with
    Ti_pat p   -> p.pat_loc
  | Ti_expr e  -> e.exp_loc
  | Ti_class c -> c.cl_loc
  | Ti_mod m   -> m.mod_loc
  | An_call (l, _k) -> l
  | An_ident (l, _s, _k) -> l
;;

let annotations = ref ([] : annotation list);;
let phrases = ref ([] : Location.t list);;

let record ti =
  if !Clflags.annotations && not (get_location ti).Location.loc_ghost then
    annotations := ti :: !annotations
;;

let record_phrase loc =
  if !Clflags.annotations then phrases := loc :: !phrases;
;;

(* comparison order:
   the intervals are sorted by order of increasing upper bound
   same upper bound -> sorted by decreasing lower bound
*)
let cmp_loc_inner_first loc1 loc2 =
  match compare loc1.loc_end.pos_cnum loc2.loc_end.pos_cnum with
  | 0 -> compare loc2.loc_start.pos_cnum loc1.loc_start.pos_cnum
  | x -> x
;;
let cmp_ti_inner_first ti1 ti2 =
  cmp_loc_inner_first (get_location ti1) (get_location ti2)
;;

let print_position pp pos =
  if pos = dummy_pos then
    output_string pp "--"
  else begin
    output_char pp '\"';
    output_string pp (String.escaped pos.pos_fname);
    output_string pp "\" ";
    output_int pp pos.pos_lnum;
    output_char pp ' ';
    output_int pp pos.pos_bol;
    output_char pp ' ';
    output_int pp pos.pos_cnum;
  end
;;

let print_location pp loc =
  print_position pp loc.loc_start;
  output_char pp ' ';
  print_position pp loc.loc_end;
;;

let sort_filter_phrases () =
  let ph = List.sort (fun x y -> cmp_loc_inner_first y x) !phrases in
  let rec loop accu cur l =
    match l with
    | [] -> accu
    | loc :: t ->
       if cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum
          && cur.loc_end.pos_cnum >= loc.loc_end.pos_cnum
       then loop accu cur t
       else loop (loc :: accu) loc t
  in
  phrases := loop [] Location.none ph;
;;

let rec printtyp_reset_maybe loc =
  match !phrases with
  | cur :: t when cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum ->
     Printtyp.reset ();
     phrases := t;
     printtyp_reset_maybe loc;
  | _ -> ()
;;

let call_kind_string k =
  match k with
  | Tail -> "tail"
  | Stack -> "stack"
  | Inline -> "inline"
;;

let print_ident_annot pp str k =
  match k with
  | Idef l ->
      output_string pp "def ";
      output_string pp str;
      output_char pp ' ';
      print_location pp l;
      output_char pp '\n'
  | Iref_internal l ->
      output_string pp "int_ref ";
      output_string pp str;
      output_char pp ' ';
      print_location pp l;
      output_char pp '\n'
  | Iref_external ->
      output_string pp "ext_ref ";
      output_string pp str;
      output_char pp '\n'
;;

(* The format of the annotation file is documented in emacs/caml-types.el. *)

let print_info pp prev_loc ti =
  match ti with
  | Ti_class _ | Ti_mod _ -> prev_loc
  | Ti_pat  {pat_loc = loc; pat_type = typ; pat_env = env}
  | Ti_expr {exp_loc = loc; exp_type = typ; exp_env = env} ->
      if loc <> prev_loc then begin
        print_location pp loc;
        output_char pp '\n'
      end;
      output_string pp "type(\n";
      printtyp_reset_maybe loc;
      Printtyp.mark_loops typ;
      Format.pp_print_string Format.str_formatter "  ";
      Printtyp.wrap_printing_env env
                       (fun () -> Printtyp.type_sch Format.str_formatter typ);
      Format.pp_print_newline Format.str_formatter ();
      let s = Format.flush_str_formatter () in
      output_string pp s;
      output_string pp ")\n";
      loc
  | An_call (loc, k) ->
      if loc <> prev_loc then begin
        print_location pp loc;
        output_char pp '\n'
      end;
      output_string pp "call(\n  ";
      output_string pp (call_kind_string k);
      output_string pp "\n)\n";
      loc
  | An_ident (loc, str, k) ->
      if loc <> prev_loc then begin
        print_location pp loc;
        output_char pp '\n'
      end;
      output_string pp "ident(\n  ";
      print_ident_annot pp str k;
      output_string pp ")\n";
      loc
;;

let get_info () =
  let info = List.fast_sort cmp_ti_inner_first !annotations in
  annotations := [];
  info
;;

let dump filename =
  if !Clflags.annotations then begin
    let do_dump _temp_filename pp =
      let info = get_info () in
      sort_filter_phrases ();
      ignore (List.fold_left (print_info pp) Location.none info) in
    begin match filename with
    | None -> do_dump "" stdout
    | Some filename ->
        Misc.output_to_file_via_temporary ~mode:[Open_text] filename do_dump
    end;
    phrases := [];
  end else begin
    annotations := [];
  end;
;;

end
module TypedtreeIter : sig 
#1 "typedtreeIter.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*    Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay)     *)
(*                                                                        *)
(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Asttypes
open Typedtree


module type IteratorArgument = sig
    val enter_structure : structure -> unit
    val enter_value_description : value_description -> unit
    val enter_type_extension : type_extension -> unit
    val enter_extension_constructor : extension_constructor -> unit
    val enter_pattern : pattern -> unit
    val enter_expression : expression -> unit
    val enter_package_type : package_type -> unit
    val enter_signature : signature -> unit
    val enter_signature_item : signature_item -> unit
    val enter_module_type_declaration : module_type_declaration -> unit
    val enter_module_type : module_type -> unit
    val enter_module_expr : module_expr -> unit
    val enter_with_constraint : with_constraint -> unit
    val enter_class_expr : class_expr -> unit
    val enter_class_signature : class_signature -> unit
    val enter_class_declaration : class_declaration -> unit
    val enter_class_description : class_description -> unit
    val enter_class_type_declaration : class_type_declaration -> unit
    val enter_class_type : class_type -> unit
    val enter_class_type_field : class_type_field -> unit
    val enter_core_type : core_type -> unit
    val enter_class_structure : class_structure -> unit
    val enter_class_field : class_field -> unit
    val enter_structure_item : structure_item -> unit


    val leave_structure : structure -> unit
    val leave_value_description : value_description -> unit
    val leave_type_extension : type_extension -> unit
    val leave_extension_constructor : extension_constructor -> unit
    val leave_pattern : pattern -> unit
    val leave_expression : expression -> unit
    val leave_package_type : package_type -> unit
    val leave_signature : signature -> unit
    val leave_signature_item : signature_item -> unit
    val leave_module_type_declaration : module_type_declaration -> unit
    val leave_module_type : module_type -> unit
    val leave_module_expr : module_expr -> unit
    val leave_with_constraint : with_constraint -> unit
    val leave_class_expr : class_expr -> unit
    val leave_class_signature : class_signature -> unit
    val leave_class_declaration : class_declaration -> unit
    val leave_class_description : class_description -> unit
    val leave_class_type_declaration : class_type_declaration -> unit
    val leave_class_type : class_type -> unit
    val leave_class_type_field : class_type_field -> unit
    val leave_core_type : core_type -> unit
    val leave_class_structure : class_structure -> unit
    val leave_class_field : class_field -> unit
    val leave_structure_item : structure_item -> unit

    val enter_bindings : rec_flag -> unit
    val enter_binding : value_binding -> unit
    val leave_binding : value_binding -> unit
    val leave_bindings : rec_flag -> unit

    val enter_type_declarations : rec_flag -> unit
    val enter_type_declaration : type_declaration -> unit
    val leave_type_declaration : type_declaration -> unit
    val leave_type_declarations : rec_flag -> unit

end

module MakeIterator :
  functor (Iter : IteratorArgument) ->
    sig
      val iter_structure : structure -> unit
      val iter_signature : signature -> unit
      val iter_structure_item : structure_item -> unit
      val iter_signature_item : signature_item -> unit
      val iter_expression : expression -> unit
      val iter_module_type : module_type -> unit
      val iter_pattern : pattern -> unit
      val iter_class_expr : class_expr -> unit
    end

module DefaultIteratorArgument : IteratorArgument

end = struct
#1 "typedtreeIter.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*    Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay)     *)
(*                                                                        *)
(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(*
TODO:
 - 2012/05/10: Follow camlp4 way of building map and iter using classes
     and inheritance ?
*)

open Asttypes
open Typedtree

module type IteratorArgument = sig

    val enter_structure : structure -> unit
    val enter_value_description : value_description -> unit
    val enter_type_extension : type_extension -> unit
    val enter_extension_constructor : extension_constructor -> unit
    val enter_pattern : pattern -> unit
    val enter_expression : expression -> unit
    val enter_package_type : package_type -> unit
    val enter_signature : signature -> unit
    val enter_signature_item : signature_item -> unit
    val enter_module_type_declaration : module_type_declaration -> unit
    val enter_module_type : module_type -> unit
    val enter_module_expr : module_expr -> unit
    val enter_with_constraint : with_constraint -> unit
    val enter_class_expr : class_expr -> unit
    val enter_class_signature : class_signature -> unit
    val enter_class_declaration : class_declaration -> unit
    val enter_class_description : class_description -> unit
    val enter_class_type_declaration : class_type_declaration -> unit
    val enter_class_type : class_type -> unit
    val enter_class_type_field : class_type_field -> unit
    val enter_core_type : core_type -> unit
    val enter_class_structure : class_structure -> unit
    val enter_class_field : class_field -> unit
    val enter_structure_item : structure_item -> unit


    val leave_structure : structure -> unit
    val leave_value_description : value_description -> unit
    val leave_type_extension : type_extension -> unit
    val leave_extension_constructor : extension_constructor -> unit
    val leave_pattern : pattern -> unit
    val leave_expression : expression -> unit
    val leave_package_type : package_type -> unit
    val leave_signature : signature -> unit
    val leave_signature_item : signature_item -> unit
    val leave_module_type_declaration : module_type_declaration -> unit
    val leave_module_type : module_type -> unit
    val leave_module_expr : module_expr -> unit
    val leave_with_constraint : with_constraint -> unit
    val leave_class_expr : class_expr -> unit
    val leave_class_signature : class_signature -> unit
    val leave_class_declaration : class_declaration -> unit
    val leave_class_description : class_description -> unit
    val leave_class_type_declaration : class_type_declaration -> unit
    val leave_class_type : class_type -> unit
    val leave_class_type_field : class_type_field -> unit
    val leave_core_type : core_type -> unit
    val leave_class_structure : class_structure -> unit
    val leave_class_field : class_field -> unit
    val leave_structure_item : structure_item -> unit

    val enter_bindings : rec_flag -> unit
    val enter_binding : value_binding -> unit
    val leave_binding : value_binding -> unit
    val leave_bindings : rec_flag -> unit

    val enter_type_declarations : rec_flag -> unit
    val enter_type_declaration : type_declaration -> unit
    val leave_type_declaration : type_declaration -> unit
    val leave_type_declarations : rec_flag -> unit

      end

module MakeIterator(Iter : IteratorArgument) : sig

    val iter_structure : structure -> unit
    val iter_signature : signature -> unit
    val iter_structure_item : structure_item -> unit
    val iter_signature_item : signature_item -> unit
    val iter_expression : expression -> unit
    val iter_module_type : module_type -> unit
    val iter_pattern : pattern -> unit
    val iter_class_expr : class_expr -> unit

  end = struct

    let may_iter f v =
      match v with
        None -> ()
      | Some x -> f x


    let rec iter_structure str =
      Iter.enter_structure str;
      List.iter iter_structure_item str.str_items;
      Iter.leave_structure str


    and iter_binding vb =
      Iter.enter_binding vb;
      iter_pattern vb.vb_pat;
      iter_expression vb.vb_expr;
      Iter.leave_binding vb

    and iter_bindings rec_flag list =
      Iter.enter_bindings rec_flag;
      List.iter iter_binding list;
      Iter.leave_bindings rec_flag

    and iter_case {c_lhs; c_guard; c_rhs} =
      iter_pattern c_lhs;
      may_iter iter_expression c_guard;
      iter_expression c_rhs

    and iter_cases cases =
      List.iter iter_case cases

    and iter_structure_item item =
      Iter.enter_structure_item item;
      begin
        match item.str_desc with
          Tstr_eval (exp, _attrs) -> iter_expression exp
        | Tstr_value (rec_flag, list) ->
            iter_bindings rec_flag list
        | Tstr_primitive vd -> iter_value_description vd
        | Tstr_type (rf, list) -> iter_type_declarations rf list
        | Tstr_typext tyext -> iter_type_extension tyext
        | Tstr_exception ext -> iter_extension_constructor ext
        | Tstr_module x -> iter_module_binding x
        | Tstr_recmodule list -> List.iter iter_module_binding list
        | Tstr_modtype mtd -> iter_module_type_declaration mtd
        | Tstr_open _ -> ()
        | Tstr_class list ->
            List.iter (fun (ci, _) -> iter_class_declaration ci) list
        | Tstr_class_type list ->
            List.iter
              (fun (_, _, ct) -> iter_class_type_declaration ct)
              list
        | Tstr_include incl -> iter_module_expr incl.incl_mod
        | Tstr_attribute _ ->
            ()
      end;
      Iter.leave_structure_item item

    and iter_module_binding x =
      iter_module_expr x.mb_expr

    and iter_value_description v =
      Iter.enter_value_description v;
      iter_core_type v.val_desc;
      Iter.leave_value_description v

    and iter_constructor_arguments = function
      | Cstr_tuple l -> List.iter iter_core_type l
      | Cstr_record l -> List.iter (fun ld -> iter_core_type ld.ld_type) l

    and iter_constructor_declaration cd =
      iter_constructor_arguments cd.cd_args;
      option iter_core_type cd.cd_res;

    and iter_type_parameter (ct, _v) =
      iter_core_type ct

    and iter_type_declaration decl =
      Iter.enter_type_declaration decl;
      List.iter iter_type_parameter decl.typ_params;
      List.iter (fun (ct1, ct2, _loc) ->
          iter_core_type ct1;
          iter_core_type ct2
      ) decl.typ_cstrs;
      begin match decl.typ_kind with
          Ttype_abstract -> ()
        | Ttype_variant list ->
            List.iter iter_constructor_declaration list
        | Ttype_record list ->
            List.iter
              (fun ld ->
                iter_core_type ld.ld_type
            ) list
        | Ttype_open -> ()
      end;
      option iter_core_type decl.typ_manifest;
      Iter.leave_type_declaration decl

    and iter_type_declarations rec_flag decls =
      Iter.enter_type_declarations rec_flag;
      List.iter iter_type_declaration decls;
      Iter.leave_type_declarations rec_flag

    and iter_extension_constructor ext =
      Iter.enter_extension_constructor ext;
      begin match ext.ext_kind with
          Text_decl(args, ret) ->
          iter_constructor_arguments args;
            option iter_core_type ret
        | Text_rebind _ -> ()
      end;
      Iter.leave_extension_constructor ext;

    and iter_type_extension tyext =
      Iter.enter_type_extension tyext;
      List.iter iter_type_parameter tyext.tyext_params;
      List.iter iter_extension_constructor tyext.tyext_constructors;
      Iter.leave_type_extension tyext

    and iter_pattern pat =
      Iter.enter_pattern pat;
      List.iter (fun (cstr, _, _attrs) -> match cstr with
              | Tpat_type _ -> ()
              | Tpat_unpack -> ()
              | Tpat_open _ -> ()
              | Tpat_constraint ct -> iter_core_type ct) pat.pat_extra;
      begin
        match pat.pat_desc with
          Tpat_any -> ()
        | Tpat_var _ -> ()
        | Tpat_alias (pat1, _, _) -> iter_pattern pat1
        | Tpat_constant _ -> ()
        | Tpat_tuple list ->
            List.iter iter_pattern list
        | Tpat_construct (_, _, args) ->
            List.iter iter_pattern args
        | Tpat_variant (_, pato, _) ->
            begin match pato with
                None -> ()
              | Some pat -> iter_pattern pat
            end
        | Tpat_record (list, _closed) ->
            List.iter (fun (_, _, pat) -> iter_pattern pat) list
        | Tpat_array list -> List.iter iter_pattern list
        | Tpat_or (p1, p2, _) -> iter_pattern p1; iter_pattern p2
        | Tpat_lazy p -> iter_pattern p
      end;
      Iter.leave_pattern pat

    and option f x = match x with None -> () | Some e -> f e

    and iter_expression exp =
      Iter.enter_expression exp;
      List.iter (function (cstr, _, _attrs) ->
        match cstr with
          Texp_constraint ct ->
            iter_core_type ct
        | Texp_coerce (cty1, cty2) ->
            option iter_core_type cty1; iter_core_type cty2
        | Texp_open _ -> ()
        | Texp_poly cto -> option iter_core_type cto
        | Texp_newtype _ -> ())
        exp.exp_extra;
      begin
        match exp.exp_desc with
          Texp_ident _ -> ()
        | Texp_constant _ -> ()
        | Texp_let (rec_flag, list, exp) ->
            iter_bindings rec_flag list;
            iter_expression exp
        | Texp_function { cases; _ } ->
            iter_cases cases
        | Texp_apply (exp, list) ->
            iter_expression exp;
            List.iter (fun (_label, expo) ->
                match expo with
                  None -> ()
                | Some exp -> iter_expression exp
            ) list
        | Texp_match (exp, list1, list2, _) ->
            iter_expression exp;
            iter_cases list1;
            iter_cases list2;
        | Texp_try (exp, list) ->
            iter_expression exp;
            iter_cases list
        | Texp_tuple list ->
            List.iter iter_expression list
        | Texp_construct (_, _, args) ->
            List.iter iter_expression args
        | Texp_variant (_label, expo) ->
            begin match expo with
                None -> ()
              | Some exp -> iter_expression exp
            end
        | Texp_record { fields; extended_expression; _ } ->
            Array.iter (function
                | _, Kept _ -> ()
                | _, Overridden (_, exp) -> iter_expression exp)
              fields;
            begin match extended_expression with
                None -> ()
              | Some exp -> iter_expression exp
            end
        | Texp_field (exp, _, _label) ->
            iter_expression exp
        | Texp_setfield (exp1, _, _label, exp2) ->
            iter_expression exp1;
            iter_expression exp2
        | Texp_array list ->
            List.iter iter_expression list
        | Texp_ifthenelse (exp1, exp2, expo) ->
            iter_expression exp1;
            iter_expression exp2;
            begin match expo with
                None -> ()
              | Some exp -> iter_expression exp
            end
        | Texp_sequence (exp1, exp2) ->
            iter_expression exp1;
            iter_expression exp2
        | Texp_while (exp1, exp2) ->
            iter_expression exp1;
            iter_expression exp2
        | Texp_for (_id, _, exp1, exp2, _dir, exp3) ->
            iter_expression exp1;
            iter_expression exp2;
            iter_expression exp3
        | Texp_send (exp, _meth, expo) ->
            iter_expression exp;
          begin
            match expo with
                None -> ()
              | Some exp -> iter_expression exp
          end
        | Texp_new _ -> ()
        | Texp_instvar _ -> ()
        | Texp_setinstvar (_, _, _, exp) ->
            iter_expression exp
        | Texp_override (_, list) ->
            List.iter (fun (_path, _, exp) ->
                iter_expression exp
            ) list
        | Texp_letmodule (_id, _, mexpr, exp) ->
            iter_module_expr mexpr;
            iter_expression exp
        | Texp_letexception (cd, exp) ->
            iter_extension_constructor cd;
            iter_expression exp
        | Texp_assert exp -> iter_expression exp
        | Texp_lazy exp -> iter_expression exp
        | Texp_object (cl, _) ->
            iter_class_structure cl
        | Texp_pack (mexpr) ->
            iter_module_expr mexpr
        | Texp_unreachable ->
            ()
        | Texp_extension_constructor _ ->
            ()
      end;
      Iter.leave_expression exp;

    and iter_package_type pack =
      Iter.enter_package_type pack;
      List.iter (fun (_s, ct) -> iter_core_type ct) pack.pack_fields;
      Iter.leave_package_type pack;

    and iter_signature sg =
      Iter.enter_signature sg;
      List.iter iter_signature_item sg.sig_items;
      Iter.leave_signature sg;

    and iter_signature_item item =
      Iter.enter_signature_item item;
      begin
        match item.sig_desc with
          Tsig_value vd ->
            iter_value_description vd
        | Tsig_type (rf, list) ->
            iter_type_declarations rf list
        | Tsig_exception ext ->
            iter_extension_constructor ext
        | Tsig_typext tyext ->
            iter_type_extension tyext
        | Tsig_module md ->
            iter_module_type md.md_type
        | Tsig_recmodule list ->
            List.iter (fun md -> iter_module_type md.md_type) list
        | Tsig_modtype mtd ->
            iter_module_type_declaration mtd
        | Tsig_open _ -> ()
        | Tsig_include incl -> iter_module_type incl.incl_mod
        | Tsig_class list ->
            List.iter iter_class_description list
        | Tsig_class_type list ->
            List.iter iter_class_type_declaration list
        | Tsig_attribute _ -> ()
      end;
      Iter.leave_signature_item item;

    and iter_module_type_declaration mtd =
      Iter.enter_module_type_declaration mtd;
      begin
        match mtd.mtd_type with
        | None -> ()
        | Some mtype -> iter_module_type mtype
      end;
      Iter.leave_module_type_declaration mtd

    and iter_class_declaration cd =
      Iter.enter_class_declaration cd;
      List.iter iter_type_parameter cd.ci_params;
      iter_class_expr cd.ci_expr;
      Iter.leave_class_declaration cd;

    and iter_class_description cd =
      Iter.enter_class_description cd;
      List.iter iter_type_parameter cd.ci_params;
      iter_class_type cd.ci_expr;
      Iter.leave_class_description cd;

    and iter_class_type_declaration cd =
      Iter.enter_class_type_declaration cd;
      List.iter iter_type_parameter cd.ci_params;
      iter_class_type cd.ci_expr;
      Iter.leave_class_type_declaration cd;

    and iter_module_type mty =
      Iter.enter_module_type mty;
      begin
        match mty.mty_desc with
          Tmty_ident _ -> ()
        | Tmty_alias _ -> ()
        | Tmty_signature sg -> iter_signature sg
        | Tmty_functor (_, _, mtype1, mtype2) ->
            Misc.may iter_module_type mtype1; iter_module_type mtype2
        | Tmty_with (mtype, list) ->
            iter_module_type mtype;
            List.iter (fun (_path, _, withc) ->
                iter_with_constraint withc
            ) list
        | Tmty_typeof mexpr ->
            iter_module_expr mexpr
      end;
      Iter.leave_module_type mty;

    and iter_with_constraint cstr =
      Iter.enter_with_constraint cstr;
      begin
        match cstr with
          Twith_type decl -> iter_type_declaration decl
        | Twith_module _ -> ()
        | Twith_typesubst decl -> iter_type_declaration decl
        | Twith_modsubst _ -> ()
      end;
      Iter.leave_with_constraint cstr;

    and iter_module_expr mexpr =
      Iter.enter_module_expr mexpr;
      begin
        match mexpr.mod_desc with
          Tmod_ident _ -> ()
        | Tmod_structure st -> iter_structure st
        | Tmod_functor (_, _, mtype, mexpr) ->
            Misc.may iter_module_type mtype;
            iter_module_expr mexpr
        | Tmod_apply (mexp1, mexp2, _) ->
            iter_module_expr mexp1;
            iter_module_expr mexp2
        | Tmod_constraint (mexpr, _, Tmodtype_implicit, _ ) ->
            iter_module_expr mexpr
        | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->
            iter_module_expr mexpr;
            iter_module_type mtype
        | Tmod_unpack (exp, _mty) ->
            iter_expression exp
(*          iter_module_type mty *)
      end;
      Iter.leave_module_expr mexpr;

    and iter_class_expr cexpr =
      Iter.enter_class_expr cexpr;
      begin
        match cexpr.cl_desc with
        | Tcl_constraint (cl, None, _, _, _ ) ->
            iter_class_expr cl;
        | Tcl_structure clstr -> iter_class_structure clstr
        | Tcl_fun (_label, pat, priv, cl, _partial) ->
          iter_pattern pat;
          List.iter (fun (_id, _, exp) -> iter_expression exp) priv;
          iter_class_expr cl

        | Tcl_apply (cl, args) ->
            iter_class_expr cl;
            List.iter (fun (_label, expo) ->
                match expo with
                  None -> ()
                | Some exp -> iter_expression exp
            ) args

        | Tcl_let (rec_flat, bindings, ivars, cl) ->
          iter_bindings rec_flat bindings;
          List.iter (fun (_id, _, exp) -> iter_expression exp) ivars;
            iter_class_expr cl

        | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) ->
            iter_class_expr cl;
            iter_class_type clty

        | Tcl_ident (_, _, tyl) ->
            List.iter iter_core_type tyl

        | Tcl_open (_, _, _, _, e) ->
            iter_class_expr e
      end;
      Iter.leave_class_expr cexpr;

    and iter_class_type ct =
      Iter.enter_class_type ct;
      begin
        match ct.cltyp_desc with
          Tcty_signature csg -> iter_class_signature csg
        | Tcty_constr (_path, _, list) ->
            List.iter iter_core_type list
        | Tcty_arrow (_label, ct, cl) ->
            iter_core_type ct;
            iter_class_type cl
        | Tcty_open (_, _, _, _, e) ->
            iter_class_type e
      end;
      Iter.leave_class_type ct;

    and iter_class_signature cs =
      Iter.enter_class_signature cs;
      iter_core_type cs.csig_self;
      List.iter iter_class_type_field cs.csig_fields;
      Iter.leave_class_signature cs


    and iter_class_type_field ctf =
      Iter.enter_class_type_field ctf;
      begin
        match ctf.ctf_desc with
          Tctf_inherit ct -> iter_class_type ct
        | Tctf_val (_s, _mut, _virt, ct) ->
            iter_core_type ct
        | Tctf_method (_s, _priv, _virt, ct) ->
            iter_core_type ct
        | Tctf_constraint  (ct1, ct2) ->
            iter_core_type ct1;
            iter_core_type ct2
        | Tctf_attribute _ -> ()
      end;
      Iter.leave_class_type_field ctf

    and iter_core_type ct =
      Iter.enter_core_type ct;
      begin
        match ct.ctyp_desc with
          Ttyp_any -> ()
        | Ttyp_var _ -> ()
        | Ttyp_arrow (_label, ct1, ct2) ->
            iter_core_type ct1;
            iter_core_type ct2
        | Ttyp_tuple list -> List.iter iter_core_type list
        | Ttyp_constr (_path, _, list) ->
            List.iter iter_core_type list
        | Ttyp_object (list, _o) ->
            List.iter iter_object_field list
        | Ttyp_class (_path, _, list) ->
            List.iter iter_core_type list
        | Ttyp_alias (ct, _s) ->
            iter_core_type ct
        | Ttyp_variant (list, _bool, _labels) ->
            List.iter iter_row_field list
        | Ttyp_poly (_list, ct) -> iter_core_type ct
        | Ttyp_package pack -> iter_package_type pack
      end;
      Iter.leave_core_type ct

    and iter_class_structure cs =
      Iter.enter_class_structure cs;
      iter_pattern cs.cstr_self;
      List.iter iter_class_field cs.cstr_fields;
      Iter.leave_class_structure cs;


    and iter_row_field rf =
      match rf with
        Ttag (_label, _attrs, _bool, list) ->
          List.iter iter_core_type list
      | Tinherit ct -> iter_core_type ct

    and iter_object_field ofield =
      match ofield with
        OTtag (_, _, ct) | OTinherit ct -> iter_core_type ct

    and iter_class_field cf =
      Iter.enter_class_field cf;
      begin
        match cf.cf_desc with
          Tcf_inherit (_ovf, cl, _super, _vals, _meths) ->
          iter_class_expr cl
      | Tcf_constraint (cty, cty') ->
          iter_core_type cty;
          iter_core_type cty'
      | Tcf_val (_lab, _, _, Tcfk_virtual cty, _) ->
          iter_core_type cty
      | Tcf_val (_lab, _, _, Tcfk_concrete (_, exp), _) ->
          iter_expression exp
      | Tcf_method (_lab, _, Tcfk_virtual cty) ->
          iter_core_type cty
      | Tcf_method (_lab, _, Tcfk_concrete (_, exp)) ->
          iter_expression exp
      | Tcf_initializer exp ->
          iter_expression exp
      | Tcf_attribute _ -> ()
      end;
      Iter.leave_class_field cf;
  end

module DefaultIteratorArgument = struct

      let enter_structure _ = ()
      let enter_value_description _ = ()
      let enter_type_extension _ = ()
      let enter_extension_constructor _ = ()
      let enter_pattern _ = ()
      let enter_expression _ = ()
      let enter_package_type _ = ()
      let enter_signature _ = ()
      let enter_signature_item _ = ()
      let enter_module_type_declaration _ = ()
      let enter_module_type _ = ()
      let enter_module_expr _ = ()
      let enter_with_constraint _ = ()
      let enter_class_expr _ = ()
      let enter_class_signature _ = ()
      let enter_class_declaration _ = ()
      let enter_class_description _ = ()
      let enter_class_type_declaration _ = ()
      let enter_class_type _ = ()
      let enter_class_type_field _ = ()
      let enter_core_type _ = ()
      let enter_class_structure _ = ()
    let enter_class_field _ = ()
    let enter_structure_item _ = ()


      let leave_structure _ = ()
      let leave_value_description _ = ()
      let leave_type_extension _ = ()
      let leave_extension_constructor _ = ()
      let leave_pattern _ = ()
      let leave_expression _ = ()
      let leave_package_type _ = ()
      let leave_signature _ = ()
      let leave_signature_item _ = ()
      let leave_module_type_declaration _ = ()
      let leave_module_type _ = ()
      let leave_module_expr _ = ()
      let leave_with_constraint _ = ()
      let leave_class_expr _ = ()
      let leave_class_signature _ = ()
      let leave_class_declaration _ = ()
      let leave_class_description _ = ()
      let leave_class_type_declaration _ = ()
      let leave_class_type _ = ()
      let leave_class_type_field _ = ()
      let leave_core_type _ = ()
      let leave_class_structure _ = ()
    let leave_class_field _ = ()
    let leave_structure_item _ = ()

    let enter_binding _ = ()
    let leave_binding _ = ()

    let enter_bindings _ = ()
    let leave_bindings _ = ()

    let enter_type_declaration _ = ()
    let leave_type_declaration _ = ()

    let enter_type_declarations _ = ()
    let leave_type_declarations _ = ()
end

end
module Untypeast : sig 
#1 "untypeast.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*      Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay)   *)
(*                                                                        *)
(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Parsetree

val lident_of_path : Path.t -> Longident.t

type mapper = {
  attribute: mapper -> Typedtree.attribute -> attribute;
  attributes: mapper -> Typedtree.attribute list -> attribute list;
  case: mapper -> Typedtree.case -> case;
  cases: mapper -> Typedtree.case list -> case list;
  class_declaration: mapper -> Typedtree.class_declaration -> class_declaration;
  class_description: mapper -> Typedtree.class_description -> class_description;
  class_expr: mapper -> Typedtree.class_expr -> class_expr;
  class_field: mapper -> Typedtree.class_field -> class_field;
  class_signature: mapper -> Typedtree.class_signature -> class_signature;
  class_structure: mapper -> Typedtree.class_structure -> class_structure;
  class_type: mapper -> Typedtree.class_type -> class_type;
  class_type_declaration: mapper -> Typedtree.class_type_declaration
                          -> class_type_declaration;
  class_type_field: mapper -> Typedtree.class_type_field -> class_type_field;
  constructor_declaration: mapper -> Typedtree.constructor_declaration
                           -> constructor_declaration;
  expr: mapper -> Typedtree.expression -> expression;
  extension_constructor: mapper -> Typedtree.extension_constructor
                         -> extension_constructor;
  include_declaration:
    mapper -> Typedtree.include_declaration -> include_declaration;
  include_description:
    mapper -> Typedtree.include_description -> include_description;
  label_declaration:
    mapper -> Typedtree.label_declaration -> label_declaration;
  location: mapper -> Location.t -> Location.t;
  module_binding: mapper -> Typedtree.module_binding -> module_binding;
  module_declaration:
    mapper -> Typedtree.module_declaration -> module_declaration;
  module_expr: mapper -> Typedtree.module_expr -> module_expr;
  module_type: mapper -> Typedtree.module_type -> module_type;
  module_type_declaration:
    mapper -> Typedtree.module_type_declaration -> module_type_declaration;
  package_type: mapper -> Typedtree.package_type -> package_type;
  open_description: mapper -> Typedtree.open_description -> open_description;
  pat: mapper -> Typedtree.pattern -> pattern;
  row_field: mapper -> Typedtree.row_field -> row_field;
  object_field: mapper -> Typedtree.object_field -> object_field;
  signature: mapper -> Typedtree.signature -> signature;
  signature_item: mapper -> Typedtree.signature_item -> signature_item;
  structure: mapper -> Typedtree.structure -> structure;
  structure_item: mapper -> Typedtree.structure_item -> structure_item;
  typ: mapper -> Typedtree.core_type -> core_type;
  type_declaration: mapper -> Typedtree.type_declaration -> type_declaration;
  type_extension: mapper -> Typedtree.type_extension -> type_extension;
  type_kind: mapper -> Typedtree.type_kind -> type_kind;
  value_binding: mapper -> Typedtree.value_binding -> value_binding;
  value_description: mapper -> Typedtree.value_description -> value_description;
  with_constraint:
    mapper -> (Path.t * Longident.t Location.loc * Typedtree.with_constraint)
    -> with_constraint;
}

val default_mapper : mapper

val untype_structure : ?mapper:mapper -> Typedtree.structure -> structure
val untype_signature : ?mapper:mapper -> Typedtree.signature -> signature

val constant : Asttypes.constant -> Parsetree.constant

end = struct
#1 "untypeast.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*    Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay)     *)
(*                                                                        *)
(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Longident
open Asttypes
open Parsetree
open Ast_helper

module T = Typedtree

type mapper = {
  attribute: mapper -> T.attribute -> attribute;
  attributes: mapper -> T.attribute list -> attribute list;
  case: mapper -> T.case -> case;
  cases: mapper -> T.case list -> case list;
  class_declaration: mapper -> T.class_declaration -> class_declaration;
  class_description: mapper -> T.class_description -> class_description;
  class_expr: mapper -> T.class_expr -> class_expr;
  class_field: mapper -> T.class_field -> class_field;
  class_signature: mapper -> T.class_signature -> class_signature;
  class_structure: mapper -> T.class_structure -> class_structure;
  class_type: mapper -> T.class_type -> class_type;
  class_type_declaration: mapper -> T.class_type_declaration
                          -> class_type_declaration;
  class_type_field: mapper -> T.class_type_field -> class_type_field;
  constructor_declaration: mapper -> T.constructor_declaration
                           -> constructor_declaration;
  expr: mapper -> T.expression -> expression;
  extension_constructor: mapper -> T.extension_constructor
                         -> extension_constructor;
  include_declaration: mapper -> T.include_declaration -> include_declaration;
  include_description: mapper -> T.include_description -> include_description;
  label_declaration: mapper -> T.label_declaration -> label_declaration;
  location: mapper -> Location.t -> Location.t;
  module_binding: mapper -> T.module_binding -> module_binding;
  module_declaration: mapper -> T.module_declaration -> module_declaration;
  module_expr: mapper -> T.module_expr -> module_expr;
  module_type: mapper -> T.module_type -> module_type;
  module_type_declaration:
    mapper -> T.module_type_declaration -> module_type_declaration;
  package_type: mapper -> T.package_type -> package_type;
  open_description: mapper -> T.open_description -> open_description;
  pat: mapper -> T.pattern -> pattern;
  row_field: mapper -> T.row_field -> row_field;
  object_field: mapper -> T.object_field -> object_field;
  signature: mapper -> T.signature -> signature;
  signature_item: mapper -> T.signature_item -> signature_item;
  structure: mapper -> T.structure -> structure;
  structure_item: mapper -> T.structure_item -> structure_item;
  typ: mapper -> T.core_type -> core_type;
  type_declaration: mapper -> T.type_declaration -> type_declaration;
  type_extension: mapper -> T.type_extension -> type_extension;
  type_kind: mapper -> T.type_kind -> type_kind;
  value_binding: mapper -> T.value_binding -> value_binding;
  value_description: mapper -> T.value_description -> value_description;
  with_constraint:
    mapper -> (Path.t * Longident.t Location.loc * T.with_constraint)
    -> with_constraint;
}

open T

(*
Some notes:

   * For Pexp_function, we cannot go back to the exact original version
   when there is a default argument, because the default argument is
   translated in the typer. The code, if printed, will not be parsable because
   new generated identifiers are not correct.

   * For Pexp_apply, it is unclear whether arguments are reordered, especially
    when there are optional arguments.

*)


(** Utility functions. *)

let string_is_prefix sub str =
  let sublen = String.length sub in
  String.length str >= sublen && String.sub str 0 sublen = sub

let map_opt f = function None -> None | Some e -> Some (f e)

let rec lident_of_path = function
  | Path.Pident id -> Longident.Lident (Ident.name id)
  | Path.Pdot (p, s, _) -> Longident.Ldot (lident_of_path p, s)
  | Path.Papply (p1, p2) ->
      Longident.Lapply (lident_of_path p1, lident_of_path p2)

let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}

(** Try a name [$name$0], check if it's free, if not, increment and repeat. *)
let fresh_name s env =
  let rec aux i =
    let name = s ^ string_of_int i in
    try
      let _ = Env.lookup_value (Lident name) env in
      name
    with
      | Not_found -> aux (i+1)
  in
  aux 0

(** Mapping functions. *)

let constant = function
  | Const_char c -> Pconst_char c
  | Const_string (s,d) -> Pconst_string (s,d)
  | Const_int i -> Pconst_integer (string_of_int i, None)
  | Const_int32 i -> Pconst_integer (Int32.to_string i, Some 'l')
  | Const_int64 i -> Pconst_integer (Int64.to_string i, Some 'L')
  | Const_nativeint i -> Pconst_integer (Nativeint.to_string i, Some 'n')
  | Const_float f -> Pconst_float (f,None)

let attribute sub (s, p) = (map_loc sub s, p)
let attributes sub l = List.map (sub.attribute sub) l

let structure sub str =
  List.map (sub.structure_item sub) str.str_items

let open_description sub od =
  let loc = sub.location sub od.open_loc in
  let attrs = sub.attributes sub od.open_attributes in
  Opn.mk ~loc ~attrs
    ~override:od.open_override
    (map_loc sub od.open_txt)

let structure_item sub item =
  let loc = sub.location sub item.str_loc in
  let desc =
    match item.str_desc with
      Tstr_eval (exp, attrs) -> Pstr_eval (sub.expr sub exp, attrs)
    | Tstr_value (rec_flag, list) ->
        Pstr_value (rec_flag, List.map (sub.value_binding sub) list)
    | Tstr_primitive vd ->
        Pstr_primitive (sub.value_description sub vd)
    | Tstr_type (rec_flag, list) ->
        Pstr_type (rec_flag, List.map (sub.type_declaration sub) list)
    | Tstr_typext tyext ->
        Pstr_typext (sub.type_extension sub tyext)
    | Tstr_exception ext ->
        Pstr_exception (sub.extension_constructor sub ext)
    | Tstr_module mb ->
        Pstr_module (sub.module_binding sub mb)
    | Tstr_recmodule list ->
        Pstr_recmodule (List.map (sub.module_binding sub) list)
    | Tstr_modtype mtd ->
        Pstr_modtype (sub.module_type_declaration sub mtd)
    | Tstr_open od ->
        Pstr_open (sub.open_description sub od)
    | Tstr_class list ->
        Pstr_class
          (List.map
             (fun (ci, _) -> sub.class_declaration sub ci)
             list)
    | Tstr_class_type list ->
        Pstr_class_type
          (List.map
             (fun (_id, _name, ct) -> sub.class_type_declaration sub ct)
             list)
    | Tstr_include incl ->
        Pstr_include (sub.include_declaration sub incl)
    | Tstr_attribute x ->
        Pstr_attribute x
  in
  Str.mk ~loc desc

let value_description sub v =
  let loc = sub.location sub v.val_loc in
  let attrs = sub.attributes sub v.val_attributes in
  Val.mk ~loc ~attrs
    ~prim:v.val_prim
    (map_loc sub v.val_name)
    (sub.typ sub v.val_desc)

let module_binding sub mb =
  let loc = sub.location sub mb.mb_loc in
  let attrs = sub.attributes sub mb.mb_attributes in
  Mb.mk ~loc ~attrs
    (map_loc sub mb.mb_name)
    (sub.module_expr sub mb.mb_expr)

let type_parameter sub (ct, v) = (sub.typ sub ct, v)

let type_declaration sub decl =
  let loc = sub.location sub decl.typ_loc in
  let attrs = sub.attributes sub decl.typ_attributes in
  Type.mk ~loc ~attrs
    ~params:(List.map (type_parameter sub) decl.typ_params)
    ~cstrs:(
      List.map
        (fun (ct1, ct2, loc) ->
           (sub.typ sub ct1, sub.typ sub ct2, sub.location sub loc))
        decl.typ_cstrs)
    ~kind:(sub.type_kind sub decl.typ_kind)
    ~priv:decl.typ_private
    ?manifest:(map_opt (sub.typ sub) decl.typ_manifest)
    (map_loc sub decl.typ_name)

let type_kind sub tk = match tk with
  | Ttype_abstract -> Ptype_abstract
  | Ttype_variant list ->
      Ptype_variant (List.map (sub.constructor_declaration sub) list)
  | Ttype_record list ->
      Ptype_record (List.map (sub.label_declaration sub) list)
  | Ttype_open -> Ptype_open

let constructor_arguments sub = function
   | Cstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l)
   | Cstr_record l -> Pcstr_record (List.map (sub.label_declaration sub) l)

let constructor_declaration sub cd =
  let loc = sub.location sub cd.cd_loc in
  let attrs = sub.attributes sub cd.cd_attributes in
  Type.constructor ~loc ~attrs
    ~args:(constructor_arguments sub cd.cd_args)
    ?res:(map_opt (sub.typ sub) cd.cd_res)
    (map_loc sub cd.cd_name)

let label_declaration sub ld =
  let loc = sub.location sub ld.ld_loc in
  let attrs = sub.attributes sub ld.ld_attributes in
  Type.field ~loc ~attrs
    ~mut:ld.ld_mutable
    (map_loc sub ld.ld_name)
    (sub.typ sub ld.ld_type)

let type_extension sub tyext =
  let attrs = sub.attributes sub tyext.tyext_attributes in
  Te.mk ~attrs
    ~params:(List.map (type_parameter sub) tyext.tyext_params)
    ~priv:tyext.tyext_private
    (map_loc sub tyext.tyext_txt)
    (List.map (sub.extension_constructor sub) tyext.tyext_constructors)

let extension_constructor sub ext =
  let loc = sub.location sub ext.ext_loc in
  let attrs = sub.attributes sub ext.ext_attributes in
  Te.constructor ~loc ~attrs
    (map_loc sub ext.ext_name)
    (match ext.ext_kind with
      | Text_decl (args, ret) ->
          Pext_decl (constructor_arguments sub args,
                     map_opt (sub.typ sub) ret)
      | Text_rebind (_p, lid) -> Pext_rebind (map_loc sub lid)
    )

let pattern sub pat =
  let loc = sub.location sub pat.pat_loc in
  (* todo: fix attributes on extras *)
  let attrs = sub.attributes sub pat.pat_attributes in
  let desc =
  match pat with
      { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } ->
        Ppat_unpack name
    | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } ->
        Ppat_type (map_loc sub lid)
    | { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } ->
        Ppat_constraint (sub.pat sub { pat with pat_extra=rem },
                         sub.typ sub ct)
    | _ ->
    match pat.pat_desc with
      Tpat_any -> Ppat_any
    | Tpat_var (id, name) ->
        begin
          match (Ident.name id).[0] with
            'A'..'Z' ->
              Ppat_unpack name
          | _ ->
              Ppat_var name
        end

    (* We transform (_ as x) in x if _ and x have the same location.
       The compiler transforms (x:t) into (_ as x : t).
       This avoids transforming a warning 27 into a 26.
     *)
    | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name)
         when pat_loc = pat.pat_loc ->
       Ppat_var name

    | Tpat_alias (pat, _id, name) ->
        Ppat_alias (sub.pat sub pat, name)
    | Tpat_constant cst -> Ppat_constant (constant cst)
    | Tpat_tuple list ->
        Ppat_tuple (List.map (sub.pat sub) list)
    | Tpat_construct (lid, _, args) ->
        Ppat_construct (map_loc sub lid,
          (match args with
              [] -> None
            | [arg] -> Some (sub.pat sub arg)
            | args ->
                Some
                  (Pat.tuple ~loc
                     (List.map (sub.pat sub) args)
                  )
          ))
    | Tpat_variant (label, pato, _) ->
        Ppat_variant (label, map_opt (sub.pat sub) pato)
    | Tpat_record (list, closed) ->
        Ppat_record (List.map (fun (lid, _, pat) ->
            map_loc sub lid, sub.pat sub pat) list, closed)
    | Tpat_array list -> Ppat_array (List.map (sub.pat sub) list)
    | Tpat_or (p1, p2, _) -> Ppat_or (sub.pat sub p1, sub.pat sub p2)
    | Tpat_lazy p -> Ppat_lazy (sub.pat sub p)
  in
  Pat.mk ~loc ~attrs desc

let exp_extra sub (extra, loc, attrs) sexp =
  let loc = sub.location sub loc in
  let attrs = sub.attributes sub attrs in
  let desc =
    match extra with
      Texp_coerce (cty1, cty2) ->
        Pexp_coerce (sexp,
                     map_opt (sub.typ sub) cty1,
                     sub.typ sub cty2)
    | Texp_constraint cty ->
        Pexp_constraint (sexp, sub.typ sub cty)
    | Texp_open (ovf, _path, lid, _) ->
        Pexp_open (ovf, map_loc sub lid, sexp)
    | Texp_poly cto -> Pexp_poly (sexp, map_opt (sub.typ sub) cto)
    | Texp_newtype s -> Pexp_newtype (mkloc s loc, sexp)
  in
  Exp.mk ~loc ~attrs desc

let cases sub l = List.map (sub.case sub) l

let case sub {c_lhs; c_guard; c_rhs} =
  {
   pc_lhs = sub.pat sub c_lhs;
   pc_guard = map_opt (sub.expr sub) c_guard;
   pc_rhs = sub.expr sub c_rhs;
  }

let value_binding sub vb =
  let loc = sub.location sub vb.vb_loc in
  let attrs = sub.attributes sub vb.vb_attributes in
  Vb.mk ~loc ~attrs
    (sub.pat sub vb.vb_pat)
    (sub.expr sub vb.vb_expr)

let expression sub exp =
  let loc = sub.location sub exp.exp_loc in
  let attrs = sub.attributes sub exp.exp_attributes in
  let desc =
    match exp.exp_desc with
      Texp_ident (_path, lid, _) -> Pexp_ident (map_loc sub lid)
    | Texp_constant cst -> Pexp_constant (constant cst)
    | Texp_let (rec_flag, list, exp) ->
        Pexp_let (rec_flag,
          List.map (sub.value_binding sub) list,
          sub.expr sub exp)

    (* Pexp_function can't have a label, so we split in 3 cases. *)
    (* One case, no guard: It's a fun. *)
    | Texp_function { arg_label; cases = [{c_lhs=p; c_guard=None; c_rhs=e}];
          _ } ->
        Pexp_fun (arg_label, None, sub.pat sub p, sub.expr sub e)
    (* No label: it's a function. *)
    | Texp_function { arg_label = Nolabel; cases; _; } ->
        Pexp_function (sub.cases sub cases)
    (* Mix of both, we generate `fun ~label:$name$ -> match $name$ with ...` *)
    | Texp_function { arg_label = Labelled s | Optional s as label; cases;
          _ } ->
        let name = fresh_name s exp.exp_env in
        Pexp_fun (label, None, Pat.var ~loc {loc;txt = name },
          Exp.match_ ~loc (Exp.ident ~loc {loc;txt= Lident name})
                          (sub.cases sub cases))
    | Texp_apply (exp, list) ->
        Pexp_apply (sub.expr sub exp,
          List.fold_right (fun (label, expo) list ->
              match expo with
                None -> list
              | Some exp -> (label, sub.expr sub exp) :: list
          ) list [])
    | Texp_match (exp, cases, exn_cases, _) ->
      let merged_cases = sub.cases sub cases
        @ List.map
          (fun c ->
            let uc = sub.case sub c in
            let pat = { uc.pc_lhs
                        with ppat_desc = Ppat_exception uc.pc_lhs }
            in
            { uc with pc_lhs = pat })
          exn_cases
      in
      Pexp_match (sub.expr sub exp, merged_cases)
    | Texp_try (exp, cases) ->
        Pexp_try (sub.expr sub exp, sub.cases sub cases)
    | Texp_tuple list ->
        Pexp_tuple (List.map (sub.expr sub) list)
    | Texp_construct (lid, _, args) ->
        Pexp_construct (map_loc sub lid,
          (match args with
              [] -> None
          | [ arg ] -> Some (sub.expr sub arg)
          | args ->
              Some
                (Exp.tuple ~loc (List.map (sub.expr sub) args))
          ))
    | Texp_variant (label, expo) ->
        Pexp_variant (label, map_opt (sub.expr sub) expo)
    | Texp_record { fields; extended_expression; _ } ->
        let list = Array.fold_left (fun l -> function
            | _, Kept _ -> l
            | _, Overridden (lid, exp) -> (lid, sub.expr sub exp) :: l)
            [] fields
        in
        Pexp_record (list, map_opt (sub.expr sub) extended_expression)
    | Texp_field (exp, lid, _label) ->
        Pexp_field (sub.expr sub exp, map_loc sub lid)
    | Texp_setfield (exp1, lid, _label, exp2) ->
        Pexp_setfield (sub.expr sub exp1, map_loc sub lid,
          sub.expr sub exp2)
    | Texp_array list ->
        Pexp_array (List.map (sub.expr sub) list)
    | Texp_ifthenelse (exp1, exp2, expo) ->
        Pexp_ifthenelse (sub.expr sub exp1,
          sub.expr sub exp2,
          map_opt (sub.expr sub) expo)
    | Texp_sequence (exp1, exp2) ->
        Pexp_sequence (sub.expr sub exp1, sub.expr sub exp2)
    | Texp_while (exp1, exp2) ->
        Pexp_while (sub.expr sub exp1, sub.expr sub exp2)
    | Texp_for (_id, name, exp1, exp2, dir, exp3) ->
        Pexp_for (name,
          sub.expr sub exp1, sub.expr sub exp2,
          dir, sub.expr sub exp3)
    | Texp_send (exp, meth, _) ->
        Pexp_send (sub.expr sub exp, match meth with
            Tmeth_name name -> mkloc name loc
          | Tmeth_val id -> mkloc (Ident.name id) loc)
    | Texp_new (_path, lid, _) -> Pexp_new (map_loc sub lid)
    | Texp_instvar (_, path, name) ->
      Pexp_ident ({loc = sub.location sub name.loc ; txt = lident_of_path path})
    | Texp_setinstvar (_, _path, lid, exp) ->
        Pexp_setinstvar (map_loc sub lid, sub.expr sub exp)
    | Texp_override (_, list) ->
        Pexp_override (List.map (fun (_path, lid, exp) ->
              (map_loc sub lid, sub.expr sub exp)
          ) list)
    | Texp_letmodule (_id, name, mexpr, exp) ->
        Pexp_letmodule (name, sub.module_expr sub mexpr,
          sub.expr sub exp)
    | Texp_letexception (ext, exp) ->
        Pexp_letexception (sub.extension_constructor sub ext,
                           sub.expr sub exp)
    | Texp_assert exp -> Pexp_assert (sub.expr sub exp)
    | Texp_lazy exp -> Pexp_lazy (sub.expr sub exp)
    | Texp_object (cl, _) ->
        Pexp_object (sub.class_structure sub cl)
    | Texp_pack (mexpr) ->
        Pexp_pack (sub.module_expr sub mexpr)
    | Texp_unreachable ->
        Pexp_unreachable
    | Texp_extension_constructor (lid, _) ->
        Pexp_extension ({ txt = "ocaml.extension_constructor"; loc },
                        PStr [ Str.eval ~loc
                                 (Exp.construct ~loc (map_loc sub lid) None)
                             ])
  in
  List.fold_right (exp_extra sub) exp.exp_extra
    (Exp.mk ~loc ~attrs desc)

let package_type sub pack =
  (map_loc sub pack.pack_txt,
    List.map (fun (s, ct) ->
        (s, sub.typ sub ct)) pack.pack_fields)

let module_type_declaration sub mtd =
  let loc = sub.location sub mtd.mtd_loc in
  let attrs = sub.attributes sub mtd.mtd_attributes in
  Mtd.mk ~loc ~attrs
    ?typ:(map_opt (sub.module_type sub) mtd.mtd_type)
    (map_loc sub mtd.mtd_name)

let signature sub sg =
  List.map (sub.signature_item sub) sg.sig_items

let signature_item sub item =
  let loc = sub.location sub item.sig_loc in
  let desc =
    match item.sig_desc with
      Tsig_value v ->
        Psig_value (sub.value_description sub v)
    | Tsig_type (rec_flag, list) ->
        Psig_type (rec_flag, List.map (sub.type_declaration sub) list)
    | Tsig_typext tyext ->
        Psig_typext (sub.type_extension sub tyext)
    | Tsig_exception ext ->
        Psig_exception (sub.extension_constructor sub ext)
    | Tsig_module md ->
        Psig_module (sub.module_declaration sub md)
    | Tsig_recmodule list ->
        Psig_recmodule (List.map (sub.module_declaration sub) list)
    | Tsig_modtype mtd ->
        Psig_modtype (sub.module_type_declaration sub mtd)
    | Tsig_open od ->
        Psig_open (sub.open_description sub od)
    | Tsig_include incl ->
        Psig_include (sub.include_description sub incl)
    | Tsig_class list ->
        Psig_class (List.map (sub.class_description sub) list)
    | Tsig_class_type list ->
        Psig_class_type (List.map (sub.class_type_declaration sub) list)
    | Tsig_attribute x ->
        Psig_attribute x
  in
  Sig.mk ~loc desc

let module_declaration sub md =
  let loc = sub.location sub md.md_loc in
  let attrs = sub.attributes sub md.md_attributes in
  Md.mk ~loc ~attrs
    (map_loc sub md.md_name)
    (sub.module_type sub md.md_type)

let include_infos f sub incl =
  let loc = sub.location sub incl.incl_loc in
  let attrs = sub.attributes sub incl.incl_attributes in
  Incl.mk ~loc ~attrs
    (f sub incl.incl_mod)

let include_declaration sub = include_infos sub.module_expr sub
let include_description sub = include_infos sub.module_type sub

let class_infos f sub ci =
  let loc = sub.location sub ci.ci_loc in
  let attrs = sub.attributes sub ci.ci_attributes in
  Ci.mk ~loc ~attrs
    ~virt:ci.ci_virt
    ~params:(List.map (type_parameter sub) ci.ci_params)
    (map_loc sub ci.ci_id_name)
    (f sub ci.ci_expr)

let class_declaration sub = class_infos sub.class_expr sub
let class_description sub = class_infos sub.class_type sub
let class_type_declaration sub = class_infos sub.class_type sub

let module_type sub mty =
  let loc = sub.location sub mty.mty_loc in
  let attrs = sub.attributes sub mty.mty_attributes in
  let desc = match mty.mty_desc with
      Tmty_ident (_path, lid) -> Pmty_ident (map_loc sub lid)
    | Tmty_alias (_path, lid) -> Pmty_alias (map_loc sub lid)
    | Tmty_signature sg -> Pmty_signature (sub.signature sub sg)
    | Tmty_functor (_id, name, mtype1, mtype2) ->
        Pmty_functor (name, map_opt (sub.module_type sub) mtype1,
          sub.module_type sub mtype2)
    | Tmty_with (mtype, list) ->
        Pmty_with (sub.module_type sub mtype,
          List.map (sub.with_constraint sub) list)
    | Tmty_typeof mexpr ->
        Pmty_typeof (sub.module_expr sub mexpr)
  in
  Mty.mk ~loc ~attrs desc

let with_constraint sub (_path, lid, cstr) =
  match cstr with
  | Twith_type decl ->
      Pwith_type (map_loc sub lid, sub.type_declaration sub decl)
  | Twith_module (_path, lid2) ->
      Pwith_module (map_loc sub lid, map_loc sub lid2)
  | Twith_typesubst decl ->
     Pwith_typesubst (map_loc sub lid, sub.type_declaration sub decl)
  | Twith_modsubst (_path, lid2) ->
      Pwith_modsubst (map_loc sub lid, map_loc sub lid2)

let module_expr sub mexpr =
  let loc = sub.location sub mexpr.mod_loc in
  let attrs = sub.attributes sub mexpr.mod_attributes in
  match mexpr.mod_desc with
      Tmod_constraint (m, _, Tmodtype_implicit, _ ) ->
        sub.module_expr sub m
    | _ ->
        let desc = match mexpr.mod_desc with
            Tmod_ident (_p, lid) -> Pmod_ident (map_loc sub lid)
          | Tmod_structure st -> Pmod_structure (sub.structure sub st)
          | Tmod_functor (_id, name, mtype, mexpr) ->
              Pmod_functor (name, Misc.may_map (sub.module_type sub) mtype,
                sub.module_expr sub mexpr)
          | Tmod_apply (mexp1, mexp2, _) ->
              Pmod_apply (sub.module_expr sub mexp1, sub.module_expr sub mexp2)
          | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->
              Pmod_constraint (sub.module_expr sub mexpr,
                sub.module_type sub mtype)
          | Tmod_constraint (_mexpr, _, Tmodtype_implicit, _) ->
              assert false
          | Tmod_unpack (exp, _pack) ->
              Pmod_unpack (sub.expr sub exp)
              (* TODO , sub.package_type sub pack) *)
        in
        Mod.mk ~loc ~attrs desc

let class_expr sub cexpr =
  let loc = sub.location sub cexpr.cl_loc in
  let attrs = sub.attributes sub cexpr.cl_attributes in
  let desc = match cexpr.cl_desc with
    | Tcl_constraint ( { cl_desc = Tcl_ident (_path, lid, tyl); _ },
                       None, _, _, _ ) ->
        Pcl_constr (map_loc sub lid,
          List.map (sub.typ sub) tyl)
    | Tcl_structure clstr -> Pcl_structure (sub.class_structure sub clstr)

    | Tcl_fun (label, pat, _pv, cl, _partial) ->
        Pcl_fun (label, None, sub.pat sub pat, sub.class_expr sub cl)

    | Tcl_apply (cl, args) ->
        Pcl_apply (sub.class_expr sub cl,
          List.fold_right (fun (label, expo) list ->
              match expo with
                None -> list
              | Some exp -> (label, sub.expr sub exp) :: list
          ) args [])

    | Tcl_let (rec_flat, bindings, _ivars, cl) ->
        Pcl_let (rec_flat,
          List.map (sub.value_binding sub) bindings,
          sub.class_expr sub cl)

    | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) ->
        Pcl_constraint (sub.class_expr sub cl,  sub.class_type sub clty)

    | Tcl_open (ovf, _p, lid, _env, e) ->
        Pcl_open (ovf, lid, sub.class_expr sub e)

    | Tcl_ident _ -> assert false
    | Tcl_constraint (_, None, _, _, _) -> assert false
  in
  Cl.mk ~loc ~attrs desc

let class_type sub ct =
  let loc = sub.location sub ct.cltyp_loc in
  let attrs = sub.attributes sub ct.cltyp_attributes in
  let desc = match ct.cltyp_desc with
      Tcty_signature csg -> Pcty_signature (sub.class_signature sub csg)
    | Tcty_constr (_path, lid, list) ->
        Pcty_constr (map_loc sub lid, List.map (sub.typ sub) list)
    | Tcty_arrow (label, ct, cl) ->
        Pcty_arrow (label, sub.typ sub ct, sub.class_type sub cl)
    | Tcty_open (ovf, _p, lid, _env, e) ->
        Pcty_open (ovf, lid, sub.class_type sub e)
  in
  Cty.mk ~loc ~attrs desc

let class_signature sub cs =
  {
    pcsig_self = sub.typ sub cs.csig_self;
    pcsig_fields = List.map (sub.class_type_field sub) cs.csig_fields;
  }

let class_type_field sub ctf =
  let loc = sub.location sub ctf.ctf_loc in
  let attrs = sub.attributes sub ctf.ctf_attributes in
  let desc = match ctf.ctf_desc with
      Tctf_inherit ct -> Pctf_inherit (sub.class_type sub ct)
    | Tctf_val (s, mut, virt, ct) ->
        Pctf_val (mkloc s loc, mut, virt, sub.typ sub ct)
    | Tctf_method  (s, priv, virt, ct) ->
        Pctf_method  (mkloc s loc, priv, virt, sub.typ sub ct)
    | Tctf_constraint  (ct1, ct2) ->
        Pctf_constraint (sub.typ sub ct1, sub.typ sub ct2)
    | Tctf_attribute x -> Pctf_attribute x
  in
  Ctf.mk ~loc ~attrs desc

let core_type sub ct =
  let loc = sub.location sub ct.ctyp_loc in
  let attrs = sub.attributes sub ct.ctyp_attributes in
  let desc = match ct.ctyp_desc with
      Ttyp_any -> Ptyp_any
    | Ttyp_var s -> Ptyp_var s
    | Ttyp_arrow (label, ct1, ct2) ->
        Ptyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2)
    | Ttyp_tuple list -> Ptyp_tuple (List.map (sub.typ sub) list)
    | Ttyp_constr (_path, lid, list) ->
        Ptyp_constr (map_loc sub lid,
          List.map (sub.typ sub) list)
    | Ttyp_object (list, o) ->
        Ptyp_object
          (List.map (sub.object_field sub) list, o)
    | Ttyp_class (_path, lid, list) ->
        Ptyp_class (map_loc sub lid, List.map (sub.typ sub) list)
    | Ttyp_alias (ct, s) ->
        Ptyp_alias (sub.typ sub ct, s)
    | Ttyp_variant (list, bool, labels) ->
        Ptyp_variant (List.map (sub.row_field sub) list, bool, labels)
    | Ttyp_poly (list, ct) ->
        let list = List.map (fun v -> mkloc v loc) list in
        Ptyp_poly (list, sub.typ sub ct)
    | Ttyp_package pack -> Ptyp_package (sub.package_type sub pack)
  in
  Typ.mk ~loc ~attrs desc

let class_structure sub cs =
  let rec remove_self = function
    | { pat_desc = Tpat_alias (p, id, _s) }
      when string_is_prefix "selfpat-" id.Ident.name ->
        remove_self p
    | p -> p
  in
  { pcstr_self = sub.pat sub (remove_self cs.cstr_self);
    pcstr_fields = List.map (sub.class_field sub) cs.cstr_fields;
  }

let row_field sub rf =
  match rf with
    Ttag (label, attrs, bool, list) ->
      Rtag (label, sub.attributes sub attrs, bool, List.map (sub.typ sub) list)
  | Tinherit ct -> Rinherit (sub.typ sub ct)

let object_field sub ofield =
  match ofield with
    OTtag (label, attrs, ct) ->
      Otag (label, sub.attributes sub attrs, sub.typ sub ct)
  | OTinherit ct -> Oinherit (sub.typ sub ct)

and is_self_pat = function
  | { pat_desc = Tpat_alias(_pat, id, _) } ->
      string_is_prefix "self-" (Ident.name id)
  | _ -> false

let class_field sub cf =
  let loc = sub.location sub cf.cf_loc in
  let attrs = sub.attributes sub cf.cf_attributes in
  let desc = match cf.cf_desc with
      Tcf_inherit (ovf, cl, super, _vals, _meths) ->
        Pcf_inherit (ovf, sub.class_expr sub cl,
                     map_opt (fun v -> mkloc v loc) super)
    | Tcf_constraint (cty, cty') ->
        Pcf_constraint (sub.typ sub cty, sub.typ sub cty')
    | Tcf_val (lab, mut, _, Tcfk_virtual cty, _) ->
        Pcf_val (lab, mut, Cfk_virtual (sub.typ sub cty))
    | Tcf_val (lab, mut, _, Tcfk_concrete (o, exp), _) ->
        Pcf_val (lab, mut, Cfk_concrete (o, sub.expr sub exp))
    | Tcf_method (lab, priv, Tcfk_virtual cty) ->
        Pcf_method (lab, priv, Cfk_virtual (sub.typ sub cty))
    | Tcf_method (lab, priv, Tcfk_concrete (o, exp)) ->
        let remove_fun_self = function
          | { exp_desc =
              Texp_function { arg_label = Nolabel; cases = [case]; _ } }
            when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs
          | e -> e
        in
        let exp = remove_fun_self exp in
        Pcf_method (lab, priv, Cfk_concrete (o, sub.expr sub exp))
    | Tcf_initializer exp ->
        let remove_fun_self = function
          | { exp_desc =
              Texp_function { arg_label = Nolabel; cases = [case]; _ } }
            when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs
          | e -> e
        in
        let exp = remove_fun_self exp in
        Pcf_initializer (sub.expr sub exp)
    | Tcf_attribute x -> Pcf_attribute x
  in
  Cf.mk ~loc ~attrs desc

let location _sub l = l

let default_mapper =
  {
    attribute = attribute ;
    attributes = attributes ;
    structure = structure;
    structure_item = structure_item;
    module_expr = module_expr;
    signature = signature;
    signature_item = signature_item;
    module_type = module_type;
    with_constraint = with_constraint;
    class_declaration = class_declaration;
    class_expr = class_expr;
    class_field = class_field;
    class_structure = class_structure;
    class_type = class_type;
    class_type_field = class_type_field;
    class_signature = class_signature;
    class_type_declaration = class_type_declaration;
    class_description = class_description;
    type_declaration = type_declaration;
    type_kind = type_kind;
    typ = core_type;
    type_extension = type_extension;
    extension_constructor = extension_constructor;
    value_description = value_description;
    pat = pattern;
    expr = expression;
    module_declaration = module_declaration;
    module_type_declaration = module_type_declaration;
    module_binding = module_binding;
    package_type = package_type ;
    open_description = open_description;
    include_description = include_description;
    include_declaration = include_declaration;
    value_binding = value_binding;
    constructor_declaration = constructor_declaration;
    label_declaration = label_declaration;
    cases = cases;
    case = case;
    location = location;
    row_field = row_field ;
    object_field = object_field ;
  }

let untype_structure ?(mapper=default_mapper) structure =
  mapper.structure mapper structure

let untype_signature ?(mapper=default_mapper) signature =
  mapper.signature mapper signature

end
module Parmatch : sig 
#1 "parmatch.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Detection of partial matches and unused match cases. *)
open Asttypes
open Typedtree
open Types

val pretty_const : constant -> string
val top_pretty : Format.formatter -> pattern -> unit
val pretty_pat : pattern -> unit
val pretty_line : pattern list -> unit
val pretty_matrix : pattern list list -> unit

val omega : pattern
val omegas : int -> pattern list
val omega_list : 'a list -> pattern list
val normalize_pat : pattern -> pattern
val all_record_args :
    (Longident.t loc * label_description * pattern) list ->
    (Longident.t loc * label_description * pattern) list
val const_compare : constant -> constant -> int

val le_pat : pattern -> pattern -> bool
val le_pats : pattern list -> pattern list -> bool

(* Exported compatibility functor, abstracted over constructor equality *)
module Compat :
  functor
    (Constr: sig
      val equal :
          Types.constructor_description ->
            Types.constructor_description ->
              bool
     end) -> sig
       val compat : pattern -> pattern -> bool
       val compats : pattern list -> pattern list -> bool
     end

exception Empty
val lub : pattern -> pattern -> pattern
val lubs : pattern list -> pattern list -> pattern list

val get_mins : ('a -> 'a -> bool) -> 'a list -> 'a list

(* Those two functions recombine one pattern and its arguments:
   For instance:
     (_,_)::p1::p2::rem -> (p1, p2)::rem
   The second one will replace mutable arguments by '_'
*)
val set_args : pattern -> pattern list -> pattern list
val set_args_erase_mutable : pattern -> pattern list -> pattern list

val pat_of_constr : pattern -> constructor_description -> pattern
val complete_constrs :
    pattern -> constructor_tag list -> constructor_description  list
val ppat_of_type :
    Env.t -> type_expr ->
    Parsetree.pattern *
    (string, constructor_description) Hashtbl.t *
    (string, label_description) Hashtbl.t

val pressure_variants: Env.t -> pattern list -> unit
val check_partial_gadt:
    ((string, constructor_description) Hashtbl.t ->
     (string, label_description) Hashtbl.t ->
     Parsetree.pattern -> pattern option) ->
    Location.t -> case list -> partial
val check_unused:
    (bool ->
     (string, constructor_description) Hashtbl.t ->
     (string, label_description) Hashtbl.t ->
     Parsetree.pattern -> pattern option) ->
    case list -> unit

(* Irrefutability tests *)
val irrefutable : pattern -> bool

(** An inactive pattern is a pattern, matching against which can be duplicated, erased or
    delayed without change in observable behavior of the program.  Patterns containing
    (lazy _) subpatterns or reads of mutable fields are active. *)
val inactive : partial:partial -> pattern -> bool

(* Ambiguous bindings *)
val check_ambiguous_bindings : case list -> unit

(* The tag used for open polymorphic variant types *)
val some_other_tag : label

end = struct
#1 "parmatch.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Detection of partial matches and unused match cases. *)

open Misc
open Asttypes
open Types
open Typedtree

(*************************************)
(* Utilities for building patterns   *)
(*************************************)

let make_pat desc ty tenv =
  {pat_desc = desc; pat_loc = Location.none; pat_extra = [];
   pat_type = ty ; pat_env = tenv;
   pat_attributes = [];
  }

let omega = make_pat Tpat_any Ctype.none Env.empty

let extra_pat =
  make_pat
    (Tpat_var (Ident.create "+", mknoloc "+"))
    Ctype.none Env.empty

let rec omegas i =
  if i <= 0 then [] else omega :: omegas (i-1)

let omega_list l = List.map (fun _ -> omega) l

let zero = make_pat (Tpat_constant (Const_int 0)) Ctype.none Env.empty

(*******************)
(* Coherence check *)
(*******************)

(* For some of the operations we do in this module, we would like (because it
   simplifies matters) to assume that patterns appearing on a given column in a
   pattern matrix are /coherent/ (think "of the same type").
   Unfortunately that is not always true.

   Consider the following (well-typed) example:
   {[
     type _ t = S : string t | U : unit t

     let f (type a) (t1 : a t) (t2 : a t) (a : a) =
       match t1, t2, a with
       | U, _, () -> ()
       | _, S, "" -> ()
   ]}

   Clearly the 3rd column contains incoherent patterns.

   On the example above, most of the algorithms will explore the pattern matrix
   as illustrated by the following tree:

   {v
                                                   S
                                                -------> | "" |
                             U     | S, "" | __/         | () |
                         --------> | _, () |   \  ¬ S
        | U, _, () | __/                        -------> | () |
        | _, S, "" |   \
                        ---------> | S, "" | ----------> | "" |
                           ¬ U                    S
   v}

   where following an edge labelled by a pattern P means "assuming the value I
   am matching on is filtered by [P] on the column I am currently looking at,
   then the following submatrix is still reachable".

   Notice that at any point of that tree, if the first column of a matrix is
   incoherent, then the branch leading to it can only be taken if the scrutinee
   is ill-typed.
   In the example above the only case where we have a matrix with an incoherent
   first column is when we consider [t1, t2, a] to be [U, S, ...]. However such
   a value would be ill-typed, so we can never actually get there.

   Checking the first column at each step of the recursion and making the
   concious decision of "aborting" the algorithm whenever the first column
   becomes incoherent, allows us to retain the initial assumption in later
   stages of the algorithms.

   ---

   N.B. two patterns can be considered coherent even though they might not be of
   the same type.

   That's in part because we only care about the "head" of patterns and leave
   checking coherence of subpatterns for the next steps of the algorithm:
   ('a', 'b') and (1, ()) will be deemed coherent because they are both a tuples
   of arity 2 (we'll notice at a later stage the incoherence of 'a' and 1).

   But also because it can be hard/costly to determine exactly whether two
   patterns are of the same type or not (eg. in the example above with _ and S,
   but see also the module [Coherence_illustration] in
   testsuite/tests/basic-more/robustmatch.ml).

   For the moment our weak, loosely-syntactic, coherence check seems to be
   enough and we leave it to each user to consider (and document!) what happens
   when an "incoherence" is not detected by this check.
*)


let simplify_head_pat p k =
  let rec simplify_head_pat p k =
    match p.pat_desc with
    | Tpat_alias (p,_,_) -> simplify_head_pat p k
    | Tpat_var (_,_) -> omega :: k
    | Tpat_or (p1,p2,_) -> simplify_head_pat p1 (simplify_head_pat p2 k)
    | _ -> p :: k
  in simplify_head_pat p k

let rec simplified_first_col = function
  | [] -> []
  | [] :: _ -> assert false (* the rows are non-empty! *)
  | (p::_) :: rows ->
      simplify_head_pat p (simplified_first_col rows)

(* Given the simplified first column of a matrix, this function first looks for
   a "discriminating" pattern on that column (i.e. a non-omega one) and then
   check that every other head pattern in the column is coherent with that one.
*)
let all_coherent column =
  let coherent_heads hp1 hp2 =
    match hp1.pat_desc, hp2.pat_desc with
    | (Tpat_var _ | Tpat_alias _ | Tpat_or _), _
    | _, (Tpat_var _ | Tpat_alias _ | Tpat_or _) ->
      assert false
    | Tpat_construct (_, c, _), Tpat_construct (_, c', _) ->
      c.cstr_consts = c'.cstr_consts
      && c.cstr_nonconsts = c'.cstr_nonconsts
    | Tpat_constant c1, Tpat_constant c2 -> begin
        match c1, c2 with
        | Const_char _, Const_char _
        | Const_int _, Const_int _
        | Const_int32 _, Const_int32 _
        | Const_int64 _, Const_int64 _
        | Const_nativeint _, Const_nativeint _
        | Const_float _, Const_float _
        | Const_string _, Const_string _ -> true
        | ( Const_char _
          | Const_int _
          | Const_int32 _
          | Const_int64 _
          | Const_nativeint _
          | Const_float _
          | Const_string _), _ -> false
      end
    | Tpat_tuple l1, Tpat_tuple l2 -> List.length l1 = List.length l2
    | Tpat_record ((_, lbl1, _) :: _, _), Tpat_record ((_, lbl2, _) :: _, _) ->
      Array.length lbl1.lbl_all = Array.length lbl2.lbl_all
    | Tpat_any, _
    | _, Tpat_any
    | Tpat_record ([], _), Tpat_record (_, _)
    | Tpat_record (_, _), Tpat_record ([], _)
    | Tpat_variant _, Tpat_variant _
    | Tpat_array _, Tpat_array _
    | Tpat_lazy _, Tpat_lazy _ -> true
    | _, _ -> false
  in
  match
    List.find (fun head_pat ->
      match head_pat.pat_desc with
      | Tpat_var _ | Tpat_alias _ | Tpat_or _ -> assert false
      | Tpat_any -> false
      | _ -> true
    ) column
  with
  | exception Not_found ->
    (* only omegas on the column: the column is coherent. *)
    true
  | discr_pat ->
    List.for_all (coherent_heads discr_pat) column

let first_column simplified_matrix =
  List.map fst simplified_matrix

(***********************)
(* Compatibility check *)
(***********************)

(* Patterns p and q compatible means:
   there exists value V that matches both, However....

  The case of extension types is dubious, as constructor rebind permits
  that different constructors are the same (and are thus compatible).

  Compilation must take this into account, consider:

  type t = ..
  type t += A|B
  type t += C=A

  let f x y = match x,y with
  | true,A  -> '1'
  | _,C     -> '2'
  | false,A -> '3'
  | _,_     -> '_'

  As C is bound to A the value of f false A is '2' (and not '3' as it would
  be in the absence of rebinding).

  Not considering rebinding, patterns "false,A" and "_,C" are incompatible
  and the compiler can swap the second and third clause, resulting in the
  (more efficiently compiled) matching

  match x,y with
  | true,A  -> '1'
  | false,A -> '3'
  | _,C     -> '2'
  | _,_     -> '_'

  This is not correct: when C is bound to A, "f false A" returns '2' (not '3')


  However, diagnostics do not take constructor rebinding into account.
  Notice, that due to module abstraction constructor rebinding is hidden.

  module X : sig type t = .. type t += A|B end = struct
    type t = ..
    type t += A
    type t += B=A
  end

  open X

  let f x = match x with
  | A -> '1'
  | B -> '2'
  | _ -> '_'

  The second clause above will NOT (and cannot) be flagged as useless.

  Finally, there are two compatibility fonction
   compat p q      ---> 'syntactic compatibility, used for diagnostics.
   may_compat p q --->   a safe approximation of possible compat,
                         for compilation

*)


let is_absent tag row = Btype.row_field tag !row = Rabsent

let is_absent_pat p = match p.pat_desc with
| Tpat_variant (tag, _, row) -> is_absent tag row
| _ -> false

let const_compare x y =
  match x,y with
  | Const_float f1, Const_float f2 ->
      Pervasives.compare (float_of_string f1) (float_of_string f2)
  | Const_string (s1, _), Const_string (s2, _) ->
      String.compare s1 s2
  | _, _ -> Pervasives.compare x y

let records_args l1 l2 =
  (* Invariant: fields are already sorted by Typecore.type_label_a_list *)
  let rec combine r1 r2 l1 l2 = match l1,l2 with
  | [],[] -> List.rev r1, List.rev r2
  | [],(_,_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2
  | (_,_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 []
  | (_,lbl1,p1)::rem1, ( _,lbl2,p2)::rem2 ->
      if lbl1.lbl_pos < lbl2.lbl_pos then
        combine (p1::r1) (omega::r2) rem1 l2
      else if lbl1.lbl_pos > lbl2.lbl_pos then
        combine (omega::r1) (p2::r2) l1 rem2
      else (* same label on both sides *)
        combine (p1::r1) (p2::r2) rem1 rem2 in
  combine [] [] l1 l2



module Compat
    (Constr:sig
      val equal :
          Types.constructor_description ->
            Types.constructor_description ->
              bool
    end) = struct

  let rec compat p q = match p.pat_desc,q.pat_desc with
(* Variables match any value *)
  | ((Tpat_any|Tpat_var _),_)
  | (_,(Tpat_any|Tpat_var _)) -> true
(* Structural induction *)
  | Tpat_alias (p,_,_),_      -> compat p q
  | _,Tpat_alias (q,_,_)      -> compat p q
  | Tpat_or (p1,p2,_),_ ->
      (compat p1 q || compat p2 q)
  | _,Tpat_or (q1,q2,_) ->
      (compat p q1 || compat p q2)
(* Constructors, with special case for extension *)
  | Tpat_construct (_, c1,ps1), Tpat_construct (_, c2,ps2) ->
      Constr.equal c1 c2 && compats ps1 ps2
(* More standard stuff *)
  | Tpat_variant(l1,op1, _), Tpat_variant(l2,op2,_) ->
      l1=l2 && ocompat op1 op2
  | Tpat_constant c1, Tpat_constant c2 ->
      const_compare c1 c2 = 0
  | Tpat_tuple ps, Tpat_tuple qs -> compats ps qs
  | Tpat_lazy p, Tpat_lazy q -> compat p q
  | Tpat_record (l1,_),Tpat_record (l2,_) ->
      let ps,qs = records_args l1 l2 in
      compats ps qs
  | Tpat_array ps, Tpat_array qs ->
      List.length ps = List.length qs &&
      compats ps qs
  | _,_  -> false

  and ocompat op oq = match op,oq with
  | None,None -> true
  | Some p,Some q -> compat p q
  | (None,Some _)|(Some _,None) -> false

  and compats ps qs = match ps,qs with
  | [], [] -> true
  | p::ps, q::qs -> compat p q && compats ps qs
  | _,_    -> false

end

module SyntacticCompat =
  Compat
    (struct
      let equal c1 c2 =  Types.equal_tag c1.cstr_tag c2.cstr_tag
    end)

let compat =  SyntacticCompat.compat
and compats = SyntacticCompat.compats

(* Due to (potential) rebinding, two extension constructors
   of the same arity type may equal *)

exception Empty (* Empty pattern *)

(****************************************)
(* Utilities for retrieving type paths  *)
(****************************************)

(* May need a clean copy, cf. PR#4745 *)
let clean_copy ty =
  if ty.level = Btype.generic_level then ty
  else Subst.type_expr Subst.identity ty

let get_type_path ty tenv =
  let ty = Ctype.repr (Ctype.expand_head tenv (clean_copy ty)) in
  match ty.desc with
  | Tconstr (path,_,_) -> path
  | _ -> fatal_error "Parmatch.get_type_path"

(*************************************)
(* Values as patterns pretty printer *)
(*************************************)

open Format
;;

let is_cons = function
| {cstr_name = "::"} -> true
| _ -> false

let pretty_const c = match c with
| Const_int i -> Printf.sprintf "%d" i
| Const_char c -> Printf.sprintf "%C" c
| Const_string (s, _) -> Printf.sprintf "%S" s
| Const_float f -> Printf.sprintf "%s" f
| Const_int32 i -> Printf.sprintf "%ldl" i
| Const_int64 i -> Printf.sprintf "%LdL" i
| Const_nativeint i -> Printf.sprintf "%ndn" i

let rec pretty_val ppf v =
  match v.pat_extra with
      (cstr, _loc, _attrs) :: rem ->
        begin match cstr with
          | Tpat_unpack ->
            fprintf ppf "@[(module %a)@]" pretty_val { v with pat_extra = rem }
          | Tpat_constraint _ ->
            fprintf ppf "@[(%a : _)@]" pretty_val { v with pat_extra = rem }
          | Tpat_type _ ->
            fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem }
          | Tpat_open _ ->
              fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem }
        end
    | [] ->
  match v.pat_desc with
  | Tpat_any -> fprintf ppf "_"
  | Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x)
  | Tpat_constant c -> fprintf ppf "%s" (pretty_const c)
  | Tpat_tuple vs ->
      fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
  | Tpat_construct (_, cstr, []) ->
      fprintf ppf "%s" cstr.cstr_name
  | Tpat_construct (_, cstr, [w]) ->
      fprintf ppf "@[<2>%s@ %a@]" cstr.cstr_name pretty_arg w
  | Tpat_construct (_, cstr, vs) ->
      let name = cstr.cstr_name in
      begin match (name, vs) with
        ("::", [v1;v2]) ->
          fprintf ppf "@[%a::@,%a@]" pretty_car v1 pretty_cdr v2
      |  _ ->
          fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs
      end
  | Tpat_variant (l, None, _) ->
      fprintf ppf "`%s" l
  | Tpat_variant (l, Some w, _) ->
      fprintf ppf "@[<2>`%s@ %a@]" l pretty_arg w
  | Tpat_record (lvs,_) ->
      let filtered_lvs = List.filter
          (function
            | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
            | _ -> true) lvs in
      begin match filtered_lvs with
      | [] -> fprintf ppf "_"
      | (_, lbl, _) :: q ->
          let elision_mark ppf =
            (* we assume that there is no label repetitions here *)
             if Array.length lbl.lbl_all > 1 + List.length q then
               fprintf ppf ";@ _@ "
             else () in
          fprintf ppf "@[{%a%t}@]"
            pretty_lvals filtered_lvs elision_mark
      end
  | Tpat_array vs ->
      fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
  | Tpat_lazy v ->
      fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v
  | Tpat_alias (v, x,_) ->
      fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x
  | Tpat_or (v,w,_)    ->
      fprintf ppf "@[(%a|@,%a)@]" pretty_or v pretty_or w

and pretty_car ppf v = match v.pat_desc with
| Tpat_construct (_,cstr, [_ ; _])
    when is_cons cstr ->
      fprintf ppf "(%a)" pretty_val v
| _ -> pretty_val ppf v

and pretty_cdr ppf v = match v.pat_desc with
| Tpat_construct (_,cstr, [v1 ; v2])
    when is_cons cstr ->
      fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2
| _ -> pretty_val ppf v

and pretty_arg ppf v = match v.pat_desc with
| Tpat_construct (_,_,_::_)
| Tpat_variant (_, Some _, _) -> fprintf ppf "(%a)" pretty_val v
|  _ -> pretty_val ppf v

and pretty_or ppf v = match v.pat_desc with
| Tpat_or (v,w,_) ->
    fprintf ppf "%a|@,%a" pretty_or v pretty_or w
| _ -> pretty_val ppf v

and pretty_vals sep ppf = function
  | [] -> ()
  | [v] -> pretty_val ppf v
  | v::vs ->
      fprintf ppf "%a%s@ %a" pretty_val v sep (pretty_vals sep) vs

and pretty_lvals ppf = function
  | [] -> ()
  | [_,lbl,v] ->
      fprintf ppf "%s=%a" lbl.lbl_name pretty_val v
  | (_, lbl,v)::rest ->
      fprintf ppf "%s=%a;@ %a"
        lbl.lbl_name pretty_val v pretty_lvals rest

let top_pretty ppf v =
  fprintf ppf "@[%a@]@?" pretty_val v


let pretty_pat p =
  top_pretty Format.str_formatter p ;
  prerr_string (Format.flush_str_formatter ())

type matrix = pattern list list

let pretty_line ps =
  List.iter
    (fun p ->
      top_pretty Format.str_formatter p ;
      prerr_string " <" ;
      prerr_string (Format.flush_str_formatter ()) ;
      prerr_string ">")
    ps

let pretty_matrix (pss : matrix) =
  prerr_endline "begin matrix" ;
  List.iter
    (fun ps ->
      pretty_line ps ;
      prerr_endline "")
    pss ;
  prerr_endline "end matrix"


(****************************)
(* Utilities for matching   *)
(****************************)

(* Check top matching *)
let simple_match p1 p2 =
  match p1.pat_desc, p2.pat_desc with
  | Tpat_construct(_, c1, _), Tpat_construct(_, c2, _) ->
      Types.equal_tag c1.cstr_tag c2.cstr_tag
  | Tpat_variant(l1, _, _), Tpat_variant(l2, _, _) ->
      l1 = l2
  | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0
  | Tpat_lazy _, Tpat_lazy _ -> true
  | Tpat_record _ , Tpat_record _ -> true
  | Tpat_tuple p1s, Tpat_tuple p2s
  | Tpat_array p1s, Tpat_array p2s -> List.length p1s = List.length p2s
  | _, (Tpat_any | Tpat_var(_)) -> true
  | _, _ -> false




(* extract record fields as a whole *)
let record_arg p = match p.pat_desc with
| Tpat_any -> []
| Tpat_record (args,_) -> args
| _ -> fatal_error "Parmatch.as_record"


(* Raise Not_found when pos is not present in arg *)
let get_field pos arg =
  let _,_, p = List.find (fun (_,lbl,_) -> pos = lbl.lbl_pos) arg in
  p

let extract_fields omegas arg =
  List.map
    (fun (_,lbl,_) ->
      try
        get_field lbl.lbl_pos arg
      with Not_found -> omega)
    omegas

let all_record_args lbls = match lbls with
| (_,{lbl_all=lbl_all},_)::_ ->
    let t =
      Array.map
        (fun lbl -> mknoloc (Longident.Lident "?temp?"), lbl,omega)
        lbl_all in
    List.iter
      (fun ((_, lbl,_) as x) ->  t.(lbl.lbl_pos) <- x)
      lbls ;
    Array.to_list t
|  _ -> fatal_error "Parmatch.all_record_args"


(* Build argument list when p2 >= p1, where p1 is a simple pattern *)
let rec simple_match_args p1 p2 = match p2.pat_desc with
| Tpat_alias (p2,_,_) -> simple_match_args p1 p2
| Tpat_construct(_, _, args) -> args
| Tpat_variant(_, Some arg, _) -> [arg]
| Tpat_tuple(args)  -> args
| Tpat_record(args,_) ->  extract_fields (record_arg p1) args
| Tpat_array(args) -> args
| Tpat_lazy arg -> [arg]
| (Tpat_any | Tpat_var(_)) ->
    begin match p1.pat_desc with
      Tpat_construct(_, _,args) -> omega_list args
    | Tpat_variant(_, Some _, _) -> [omega]
    | Tpat_tuple(args) -> omega_list args
    | Tpat_record(args,_) ->  omega_list args
    | Tpat_array(args) ->  omega_list args
    | Tpat_lazy _ -> [omega]
    | _ -> []
    end
| _ -> []

(*
  Normalize a pattern ->
   all arguments are omega (simple pattern) and no more variables
*)

let rec normalize_pat q = match q.pat_desc with
  | Tpat_any | Tpat_constant _ -> q
  | Tpat_var _ -> make_pat Tpat_any q.pat_type q.pat_env
  | Tpat_alias (p,_,_) -> normalize_pat p
  | Tpat_tuple (args) ->
      make_pat (Tpat_tuple (omega_list args)) q.pat_type q.pat_env
  | Tpat_construct  (lid, c,args) ->
      make_pat
        (Tpat_construct (lid, c,omega_list args))
        q.pat_type q.pat_env
  | Tpat_variant (l, arg, row) ->
      make_pat (Tpat_variant (l, may_map (fun _ -> omega) arg, row))
        q.pat_type q.pat_env
  | Tpat_array (args) ->
      make_pat (Tpat_array (omega_list args))  q.pat_type q.pat_env
  | Tpat_record (largs, closed) ->
      make_pat
        (Tpat_record (List.map (fun (lid,lbl,_) ->
                                 lid, lbl,omega) largs, closed))
        q.pat_type q.pat_env
  | Tpat_lazy _ ->
      make_pat (Tpat_lazy omega) q.pat_type q.pat_env
  | Tpat_or _ -> fatal_error "Parmatch.normalize_pat"

(*
  Build normalized (cf. supra) discriminating pattern,
  in the non-data type case
*)

let discr_pat q pss =

  let rec acc_pat acc pss = match pss with
    ({pat_desc = Tpat_alias (p,_,_)}::ps)::pss ->
        acc_pat acc ((p::ps)::pss)
  | ({pat_desc = Tpat_or (p1,p2,_)}::ps)::pss ->
        acc_pat acc ((p1::ps)::(p2::ps)::pss)
  | ({pat_desc = (Tpat_any | Tpat_var _)}::_)::pss ->
        acc_pat acc pss
  | (({pat_desc = Tpat_tuple _} as p)::_)::_ -> normalize_pat p
  | (({pat_desc = Tpat_lazy _} as p)::_)::_ -> normalize_pat p
  | (({pat_desc = Tpat_record (largs,closed)} as p)::_)::pss ->
      let new_omegas =
        List.fold_right
          (fun (lid, lbl,_) r ->
            try
              let _ = get_field lbl.lbl_pos r in
              r
            with Not_found ->
              (lid, lbl,omega)::r)
          largs (record_arg acc)
      in
      acc_pat
        (make_pat (Tpat_record (new_omegas, closed)) p.pat_type p.pat_env)
        pss
  | _ -> acc in

  match normalize_pat q with
  | {pat_desc= (Tpat_any | Tpat_record _)} as q -> acc_pat q pss
  | q -> q

(*
   In case a matching value is found, set actual arguments
   of the matching pattern.
*)

let rec read_args xs r = match xs,r with
| [],_ -> [],r
| _::xs, arg::rest ->
   let args,rest = read_args xs rest in
   arg::args,rest
| _,_ ->
    fatal_error "Parmatch.read_args"

let do_set_args erase_mutable q r = match q with
| {pat_desc = Tpat_tuple omegas} ->
    let args,rest = read_args omegas r in
    make_pat (Tpat_tuple args) q.pat_type q.pat_env::rest
| {pat_desc = Tpat_record (omegas,closed)} ->
    let args,rest = read_args omegas r in
    make_pat
      (Tpat_record
         (List.map2 (fun (lid, lbl,_) arg ->
           if
             erase_mutable &&
             (match lbl.lbl_mut with
             | Mutable -> true | Immutable -> false)
           then
             lid, lbl, omega
           else
             lid, lbl, arg)
            omegas args, closed))
      q.pat_type q.pat_env::
    rest
| {pat_desc = Tpat_construct (lid, c,omegas)} ->
    let args,rest = read_args omegas r in
    make_pat
      (Tpat_construct (lid, c,args))
      q.pat_type q.pat_env::
    rest
| {pat_desc = Tpat_variant (l, omega, row)} ->
    let arg, rest =
      match omega, r with
        Some _, a::r -> Some a, r
      | None, r -> None, r
      | _ -> assert false
    in
    make_pat
      (Tpat_variant (l, arg, row)) q.pat_type q.pat_env::
    rest
| {pat_desc = Tpat_lazy _omega} ->
    begin match r with
      arg::rest ->
        make_pat (Tpat_lazy arg) q.pat_type q.pat_env::rest
    | _ -> fatal_error "Parmatch.do_set_args (lazy)"
    end
| {pat_desc = Tpat_array omegas} ->
    let args,rest = read_args omegas r in
    make_pat
      (Tpat_array args) q.pat_type q.pat_env::
    rest
| {pat_desc=Tpat_constant _|Tpat_any} ->
    q::r (* case any is used in matching.ml *)
| _ -> fatal_error "Parmatch.set_args"

let set_args q r = do_set_args false q r
and set_args_erase_mutable q r = do_set_args true q r

(* filter pss according to pattern q *)
let filter_one q pss =
  let rec filter_rec = function
      ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss ->
        filter_rec ((p::ps)::pss)
    | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss ->
        filter_rec ((p1::ps)::(p2::ps)::pss)
    | (p::ps)::pss ->
        if simple_match q p
        then (simple_match_args q p @ ps) :: filter_rec pss
        else filter_rec pss
    | _ -> [] in
  filter_rec pss

(*
  Filter pss in the ``extra case''. This applies :
  - According to an extra constructor (datatype case, non-complete signature).
  - According to anything (all-variables case).
*)
let filter_extra pss =
  let rec filter_rec = function
      ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss ->
        filter_rec ((p::ps)::pss)
    | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss ->
        filter_rec ((p1::ps)::(p2::ps)::pss)
    | ({pat_desc = (Tpat_any | Tpat_var(_))} :: qs) :: pss ->
        qs :: filter_rec pss
    | _::pss  -> filter_rec pss
    | [] -> [] in
  filter_rec pss

(*
  Pattern p0 is the discriminating pattern,
  returns [(q0,pss0) ; ... ; (qn,pssn)]
  where the qi's are simple patterns and the pssi's are
  matched matrices.

  NOTES
   * (qi,[]) is impossible.
   * In the case when matching is useless (all-variable case),
     returns []
*)

let filter_all pat0 pss =

  let rec insert q qs env =
    match env with
      [] ->
        let q0 = normalize_pat q in
        [q0, [simple_match_args q0 q @ qs]]
    | ((q0,pss) as c)::env ->
        if simple_match q0 q
        then (q0, ((simple_match_args q0 q @ qs) :: pss)) :: env
        else c :: insert q qs env in

  let rec filter_rec env = function
    ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss ->
      filter_rec env ((p::ps)::pss)
  | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss ->
      filter_rec env ((p1::ps)::(p2::ps)::pss)
  | ({pat_desc = (Tpat_any | Tpat_var(_))}::_)::pss ->
      filter_rec env pss
  | (p::ps)::pss ->
      filter_rec (insert p ps env) pss
  | _ -> env

  and filter_omega env = function
    ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss ->
      filter_omega env ((p::ps)::pss)
  | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss ->
      filter_omega env ((p1::ps)::(p2::ps)::pss)
  | ({pat_desc = (Tpat_any | Tpat_var(_))}::ps)::pss ->
      filter_omega
        (List.map (fun (q,qss) -> (q,(simple_match_args q omega @ ps) :: qss))
           env)
        pss
  | _::pss -> filter_omega env pss
  | [] -> env in

  filter_omega
    (filter_rec
      (match pat0.pat_desc with
        (Tpat_record(_) | Tpat_tuple(_) | Tpat_lazy(_)) -> [pat0,[]]
      | _ -> [])
      pss)
    pss

(* Variant related functions *)

let rec set_last a = function
    [] -> []
  | [_] -> [a]
  | x::l -> x :: set_last a l

(* mark constructor lines for failure when they are incomplete *)
let rec mark_partial = function
    ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss ->
      mark_partial ((p::ps)::pss)
  | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss ->
      mark_partial ((p1::ps)::(p2::ps)::pss)
  | ({pat_desc = (Tpat_any | Tpat_var(_))} :: _ as ps) :: pss ->
      ps :: mark_partial pss
  | ps::pss  ->
      (set_last zero ps) :: mark_partial pss
  | [] -> []

let close_variant env row =
  let row = Btype.row_repr row in
  let nm =
    List.fold_left
      (fun nm (_tag,f) ->
        match Btype.row_field_repr f with
        | Reither(_, _, false, e) ->
            (* m=false means that this tag is not explicitly matched *)
            Btype.set_row_field e Rabsent;
            None
        | Rabsent | Reither (_, _, true, _) | Rpresent _ -> nm)
      row.row_name row.row_fields in
  if not row.row_closed || nm != row.row_name then begin
    (* this unification cannot fail *)
    Ctype.unify env row.row_more
      (Btype.newgenty
         (Tvariant {row with row_fields = []; row_more = Btype.newgenvar();
                    row_closed = true; row_name = nm}))
  end

let row_of_pat pat =
  match Ctype.expand_head pat.pat_env pat.pat_type with
    {desc = Tvariant row} -> Btype.row_repr row
  | _ -> assert false

(*
  Check whether the first column of env makes up a complete signature or
  not.
*)

let full_match closing env =  match env with
| ({pat_desc = Tpat_construct(_,c,_)},_) :: _ ->
    if c.cstr_consts < 0 then false (* extensions *)
    else List.length env = c.cstr_consts + c.cstr_nonconsts
| ({pat_desc = Tpat_variant _} as p,_) :: _ ->
    let fields =
      List.map
        (function ({pat_desc = Tpat_variant (tag, _, _)}, _) -> tag
          | _ -> assert false)
        env
    in
    let row = row_of_pat p in
    if closing && not (Btype.row_fixed row) then
      (* closing=true, we are considering the variant as closed *)
      List.for_all
        (fun (tag,f) ->
          match Btype.row_field_repr f with
            Rabsent | Reither(_, _, false, _) -> true
          | Reither (_, _, true, _)
              (* m=true, do not discard matched tags, rather warn *)
          | Rpresent _ -> List.mem tag fields)
        row.row_fields
    else
      row.row_closed &&
      List.for_all
        (fun (tag,f) ->
          Btype.row_field_repr f = Rabsent || List.mem tag fields)
        row.row_fields
| ({pat_desc = Tpat_constant(Const_char _)},_) :: _ ->
    List.length env = 256
| ({pat_desc = Tpat_constant(_)},_) :: _ -> false
| ({pat_desc = Tpat_tuple(_)},_) :: _ -> true
| ({pat_desc = Tpat_record(_)},_) :: _ -> true
| ({pat_desc = Tpat_array(_)},_) :: _ -> false
| ({pat_desc = Tpat_lazy(_)},_) :: _ -> true
| ({pat_desc = (Tpat_any|Tpat_var _|Tpat_alias _|Tpat_or _)},_) :: _
| []
  ->
    assert false

(* Written as a non-fragile matching, PR#7451 originated from a fragile matching below. *)
let should_extend ext env = match ext with
| None -> false
| Some ext -> begin match env with
  | [] -> assert false
  | (p,_)::_ ->
      begin match p.pat_desc with
      | Tpat_construct
          (_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)},_) ->
            let path = get_type_path p.pat_type p.pat_env in
            Path.same path ext
      | Tpat_construct
          (_, {cstr_tag=(Cstr_extension _)},_) -> false
      | Tpat_constant _|Tpat_tuple _|Tpat_variant _
      | Tpat_record  _|Tpat_array _ | Tpat_lazy _
        -> false
      | Tpat_any|Tpat_var _|Tpat_alias _|Tpat_or _
        -> assert false
      end
end

module ConstructorTagHashtbl = Hashtbl.Make(
  struct
    type t = Types.constructor_tag
    let hash = Hashtbl.hash
    let equal = Types.equal_tag
  end
)

(* complement constructor tags *)
let complete_tags nconsts nconstrs tags =
  let seen_const = Array.make nconsts false
  and seen_constr = Array.make nconstrs false in
  List.iter
    (function
      | Cstr_constant i -> seen_const.(i) <- true
      | Cstr_block i -> seen_constr.(i) <- true
      | _  -> assert false)
    tags ;
  let r = ConstructorTagHashtbl.create (nconsts+nconstrs) in
  for i = 0 to nconsts-1 do
    if not seen_const.(i) then
      ConstructorTagHashtbl.add r (Cstr_constant i) ()
  done ;
  for i = 0 to nconstrs-1 do
    if not seen_constr.(i) then
      ConstructorTagHashtbl.add r (Cstr_block i) ()
  done ;
  r

(* build a pattern from a constructor list *)
let pat_of_constr ex_pat cstr =
  {ex_pat with pat_desc =
   Tpat_construct (mknoloc (Longident.Lident "?pat_of_constr?"),
                   cstr, omegas cstr.cstr_arity)}

let orify x y = make_pat (Tpat_or (x, y, None)) x.pat_type x.pat_env

let rec orify_many = function
| [] -> assert false
| [x] -> x
| x :: xs -> orify x (orify_many xs)

let pat_of_constrs ex_pat cstrs =
  if cstrs = [] then raise Empty else
  orify_many (List.map (pat_of_constr ex_pat) cstrs)

let pats_of_type ?(always=false) env ty =
  let ty' = Ctype.expand_head env ty in
  match ty'.desc with
  | Tconstr (path, _, _) ->
      begin try match (Env.find_type path env).type_kind with
      | Type_variant cl when always || List.length cl = 1 ||
        List.for_all (fun cd -> cd.Types.cd_res <> None) cl ->
          let cstrs = fst (Env.find_type_descrs path env) in
          List.map (pat_of_constr (make_pat Tpat_any ty env)) cstrs
      | Type_record _ ->
          let labels = snd (Env.find_type_descrs path env) in
          let fields =
            List.map (fun ld ->
              mknoloc (Longident.Lident "?pat_of_label?"), ld, omega)
              labels
          in
          [make_pat (Tpat_record (fields, Closed)) ty env]
      | _ -> [omega]
      with Not_found -> [omega]
      end
  | Ttuple tl ->
      [make_pat (Tpat_tuple (omegas (List.length tl))) ty env]
  | _ -> [omega]

let rec get_variant_constructors env ty =
  match (Ctype.repr ty).desc with
  | Tconstr (path,_,_) -> begin
      try match Env.find_type path env with
      | {type_kind=Type_variant _} ->
          fst (Env.find_type_descrs path env)
      | {type_manifest = Some _} ->
          get_variant_constructors env
            (Ctype.expand_head_once env (clean_copy ty))
      | _ -> fatal_error "Parmatch.get_variant_constructors"
      with Not_found ->
        fatal_error "Parmatch.get_variant_constructors"
    end
  | _ -> fatal_error "Parmatch.get_variant_constructors"

(* Sends back a pattern that complements constructor tags all_tag *)
let complete_constrs p all_tags =
  let c =
    match p.pat_desc with Tpat_construct (_, c, _) -> c | _ -> assert false in
  let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
  let constrs = get_variant_constructors p.pat_env c.cstr_res in
  let others =
    List.filter
      (fun cnstr -> ConstructorTagHashtbl.mem not_tags cnstr.cstr_tag)
      constrs in
  let const, nonconst =
    List.partition (fun cnstr -> cnstr.cstr_arity = 0) others in
  const @ nonconst

let build_other_constrs env p =
  match p.pat_desc with
    Tpat_construct (_, {cstr_tag=Cstr_constant _|Cstr_block _}, _) ->
      let get_tag = function
        | {pat_desc = Tpat_construct (_,c,_)} -> c.cstr_tag
        | _ -> fatal_error "Parmatch.get_tag" in
      let all_tags =  List.map (fun (p,_) -> get_tag p) env in
      pat_of_constrs p (complete_constrs p all_tags)
  | _ -> extra_pat

(* Auxiliary for build_other *)

let build_other_constant proj make first next p env =
  let all = List.map (fun (p, _) -> proj p.pat_desc) env in
  let rec try_const i =
    if List.mem i all
    then try_const (next i)
    else make_pat (make i) p.pat_type p.pat_env
  in try_const first

(*
  Builds a pattern that is incompatible with all patterns in
  in the first column of env
*)

let some_other_tag = "<some other tag>"

let build_other ext env = match env with
| ({pat_desc = Tpat_construct (lid, {cstr_tag=Cstr_extension _},_)},_) :: _ ->
        (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *)
        make_pat (Tpat_var (Ident.create "*extension*",
                            {lid with txt="*extension*"})) Ctype.none Env.empty
| ({pat_desc = Tpat_construct _} as p,_) :: _ ->
    begin match ext with
    | Some ext when Path.same ext (get_type_path p.pat_type p.pat_env) ->
        extra_pat
    | _ ->
        build_other_constrs env p
    end
| ({pat_desc = Tpat_variant (_,_,r)} as p,_) :: _ ->
    let tags =
      List.map
        (function ({pat_desc = Tpat_variant (tag, _, _)}, _) -> tag
                | _ -> assert false)
        env
    in
    let row = row_of_pat p in
    let make_other_pat tag const =
      let arg = if const then None else Some omega in
      make_pat (Tpat_variant(tag, arg, r)) p.pat_type p.pat_env in
    begin match
      List.fold_left
        (fun others (tag,f) ->
          if List.mem tag tags then others else
          match Btype.row_field_repr f with
            Rabsent (* | Reither _ *) -> others
          (* This one is called after erasing pattern info *)
          | Reither (c, _, _, _) -> make_other_pat tag c :: others
          | Rpresent arg -> make_other_pat tag (arg = None) :: others)
        [] row.row_fields
    with
      [] ->
        make_other_pat some_other_tag true
    | pat::other_pats ->
        List.fold_left
          (fun p_res pat ->
            make_pat (Tpat_or (pat, p_res, None)) p.pat_type p.pat_env)
          pat other_pats
    end
| ({pat_desc = Tpat_constant(Const_char _)} as p,_) :: _ ->
    let all_chars =
      List.map
        (fun (p,_) -> match p.pat_desc with
        | Tpat_constant (Const_char c) -> c
        | _ -> assert false)
        env in

    let rec find_other i imax =
      if i > imax then raise Not_found
      else
        let ci = Char.chr i in
        if List.mem ci all_chars then
          find_other (i+1) imax
        else
          make_pat (Tpat_constant (Const_char ci)) p.pat_type p.pat_env in
    let rec try_chars = function
      | [] -> omega
      | (c1,c2) :: rest ->
          try
            find_other (Char.code c1) (Char.code c2)
          with
          | Not_found -> try_chars rest in

    try_chars
      [ 'a', 'z' ; 'A', 'Z' ; '0', '9' ;
        ' ', '~' ; Char.chr 0 , Char.chr 255]

| ({pat_desc=(Tpat_constant (Const_int _))} as p,_) :: _ ->
    build_other_constant
      (function Tpat_constant(Const_int i) -> i | _ -> assert false)
      (function i -> Tpat_constant(Const_int i))
      0 succ p env
| ({pat_desc=(Tpat_constant (Const_int32 _))} as p,_) :: _ ->
    build_other_constant
      (function Tpat_constant(Const_int32 i) -> i | _ -> assert false)
      (function i -> Tpat_constant(Const_int32 i))
      0l Int32.succ p env
| ({pat_desc=(Tpat_constant (Const_int64 _))} as p,_) :: _ ->
    build_other_constant
      (function Tpat_constant(Const_int64 i) -> i | _ -> assert false)
      (function i -> Tpat_constant(Const_int64 i))
      0L Int64.succ p env
| ({pat_desc=(Tpat_constant (Const_nativeint _))} as p,_) :: _ ->
    build_other_constant
      (function Tpat_constant(Const_nativeint i) -> i | _ -> assert false)
      (function i -> Tpat_constant(Const_nativeint i))
      0n Nativeint.succ p env
| ({pat_desc=(Tpat_constant (Const_string _))} as p,_) :: _ ->
    build_other_constant
      (function Tpat_constant(Const_string (s, _)) -> String.length s
              | _ -> assert false)
      (function i -> Tpat_constant(Const_string(String.make i '*', None)))
      0 succ p env
| ({pat_desc=(Tpat_constant (Const_float _))} as p,_) :: _ ->
    build_other_constant
      (function Tpat_constant(Const_float f) -> float_of_string f
              | _ -> assert false)
      (function f -> Tpat_constant(Const_float (string_of_float f)))
      0.0 (fun f -> f +. 1.0) p env

| ({pat_desc = Tpat_array _} as p,_)::_ ->
    let all_lengths =
      List.map
        (fun (p,_) -> match p.pat_desc with
        | Tpat_array args -> List.length args
        | _ -> assert false)
        env in
    let rec try_arrays l =
      if List.mem l all_lengths then try_arrays (l+1)
      else
        make_pat
          (Tpat_array (omegas l))
          p.pat_type p.pat_env in
    try_arrays 0
| [] -> omega
| _ -> omega

(*
  Core function :
  Is the last row of pattern matrix pss + qs satisfiable ?
  That is :
    Does there exists at least one value vector, es such that :
     1- for all ps in pss ps # es (ps and es are not compatible)
     2- qs <= es                  (es matches qs)
*)

let rec has_instance p = match p.pat_desc with
  | Tpat_variant (l,_,r) when is_absent l r -> false
  | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true
  | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) -> has_instance p
  | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2
  | Tpat_construct (_,_,ps) | Tpat_tuple ps | Tpat_array ps ->
      has_instances ps
  | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps)
  | Tpat_lazy p
    -> has_instance p


and has_instances = function
  | [] -> true
  | q::rem -> has_instance q && has_instances rem

(*
   In two places in the following function, we check the coherence of the first
   column of (pss + qs).
   If it is incoherent, then we exit early saying that (pss + qs) is not
   satisfiable (which is equivalent to saying "oh, we shouldn't have considered
   that branch, no good result came come from here").

   But what happens if we have a coherent but ill-typed column?
   - we might end up returning [false], which is equivalent to noticing the
   incompatibility: clearly this is fine.
   - if we end up returning [true] then we're saying that [qs] is useful while
   it is not. This is sad but not the end of the world, we're just allowing dead
   code to survive.
*)
let rec satisfiable pss qs = match pss with
| [] -> has_instances qs
| _  ->
    match qs with
    | [] -> false
    | {pat_desc = Tpat_or(q1,q2,_)}::qs ->
        satisfiable pss (q1::qs) || satisfiable pss (q2::qs)
    | {pat_desc = Tpat_alias(q,_,_)}::qs ->
          satisfiable pss (q::qs)
    | {pat_desc = (Tpat_any | Tpat_var(_))}::qs ->
        if not (all_coherent (simplified_first_col pss)) then
          false
        else begin
          let q0 = discr_pat omega pss in
          match filter_all q0 pss with
            (* first column of pss is made of variables only *)
          | [] -> satisfiable (filter_extra pss) qs
          | constrs  ->
              if full_match false constrs then
                List.exists
                  (fun (p,pss) ->
                    not (is_absent_pat p) &&
                    satisfiable pss (simple_match_args p omega @ qs))
                  constrs
              else
                satisfiable (filter_extra pss) qs
        end
    | {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> false
    | q::qs ->
        if not (all_coherent (q :: simplified_first_col pss)) then
          false
        else begin
          let q0 = discr_pat q pss in
          satisfiable (filter_one q0 pss) (simple_match_args q0 q @ qs)
        end

(* Also return the remaining cases, to enable GADT handling

   For considerations regarding the coherence check, see the comment on
   [satisfiable] above.  *)
let rec satisfiables pss qs = match pss with
| [] -> if has_instances qs then [qs] else []
| _  ->
    match qs with
    | [] -> []
    | {pat_desc = Tpat_or(q1,q2,_)}::qs ->
        satisfiables pss (q1::qs) @ satisfiables pss (q2::qs)
    | {pat_desc = Tpat_alias(q,_,_)}::qs ->
        satisfiables pss (q::qs)
    | {pat_desc = (Tpat_any | Tpat_var(_))}::qs ->
        if not (all_coherent (simplified_first_col pss)) then
          []
        else begin
          let q0 = discr_pat omega pss in
          let wild p =
            List.map (fun qs -> p::qs) (satisfiables (filter_extra pss) qs) in
          match filter_all q0 pss with
            (* first column of pss is made of variables only *)
          | [] ->
              wild omega
          | (p,_)::_ as constrs  ->
              let for_constrs () =
                List.flatten (
                List.map
                  (fun (p,pss) ->
                    if is_absent_pat p then [] else
                    List.map (set_args p)
                      (satisfiables pss (simple_match_args p omega @ qs)))
                  constrs )
              in
              if full_match false constrs then for_constrs () else
              match p.pat_desc with
                Tpat_construct _ ->
                  (* activate this code for checking non-gadt constructors *)
                  wild (build_other_constrs constrs p) @ for_constrs ()
              | _ ->
                  wild omega
        end
    | {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> []
    | q::qs ->
        if not (all_coherent (q :: simplified_first_col pss)) then
          []
        else begin
          let q0 = discr_pat q pss in
          List.map (set_args q0)
            (satisfiables (filter_one q0 pss) (simple_match_args q0 q @ qs))
        end

(*
  Now another satisfiable function that additionally
  supplies an example of a matching value.

  This function should be called for exhaustiveness check only.
*)

type 'a result =
  | Rnone           (* No matching value *)
  | Rsome of 'a     (* This matching value *)

(*
let rec try_many  f = function
  | [] -> Rnone
  | (p,pss)::rest ->
      match f (p,pss) with
      | Rnone -> try_many  f rest
      | r -> r
*)

let rappend r1 r2 =
  match r1, r2 with
  | Rnone, _ -> r2
  | _, Rnone -> r1
  | Rsome l1, Rsome l2 -> Rsome (l1 @ l2)

let rec try_many_gadt  f = function
  | [] -> Rnone
  | (p,pss)::rest ->
      rappend (f (p, pss)) (try_many_gadt f rest)

(*
let rec exhaust ext pss n = match pss with
| []    ->  Rsome (omegas n)
| []::_ ->  Rnone
| pss   ->
    let q0 = discr_pat omega pss in
    begin match filter_all q0 pss with
          (* first column of pss is made of variables only *)
    | [] ->
        begin match exhaust ext (filter_extra pss) (n-1) with
        | Rsome r -> Rsome (q0::r)
        | r -> r
      end
    | constrs ->
        let try_non_omega (p,pss) =
          if is_absent_pat p then
            Rnone
          else
            match
              exhaust
                ext pss (List.length (simple_match_args p omega) + n - 1)
            with
            | Rsome r -> Rsome (set_args p r)
            | r       -> r in
        if
          full_match true false constrs && not (should_extend ext constrs)
        then
          try_many try_non_omega constrs
        else
          (*
             D = filter_extra pss is the default matrix
             as it is included in pss, one can avoid
             recursive calls on specialized matrices,
             Essentially :
             * D exhaustive => pss exhaustive
             * D non-exhaustive => we have a non-filtered value
          *)
          let r =  exhaust ext (filter_extra pss) (n-1) in
          match r with
          | Rnone -> Rnone
          | Rsome r ->
              try
                Rsome (build_other ext constrs::r)
              with
      (* cannot occur, since constructors don't make a full signature *)
              | Empty -> fatal_error "Parmatch.exhaust"
    end

let combinations f lst lst' =
  let rec iter2 x =
    function
        [] -> []
      | y :: ys ->
          f x y :: iter2 x ys
  in
  let rec iter =
    function
        [] -> []
      | x :: xs -> iter2 x lst' @ iter xs
  in
  iter lst
*)
(*
let print_pat pat =
  let rec string_of_pat pat =
    match pat.pat_desc with
        Tpat_var _ -> "v"
      | Tpat_any -> "_"
      | Tpat_alias (p, x) -> Printf.sprintf "(%s) as ?"  (string_of_pat p)
      | Tpat_constant n -> "0"
      | Tpat_construct (_, lid, _) ->
        Printf.sprintf "%s" (String.concat "." (Longident.flatten lid.txt))
      | Tpat_lazy p ->
        Printf.sprintf "(lazy %s)" (string_of_pat p)
      | Tpat_or (p1,p2,_) ->
        Printf.sprintf "(%s | %s)" (string_of_pat p1) (string_of_pat p2)
      | Tpat_tuple list ->
        Printf.sprintf "(%s)" (String.concat "," (List.map string_of_pat list))
      | Tpat_variant (_, _, _) -> "variant"
      | Tpat_record (_, _) -> "record"
      | Tpat_array _ -> "array"
  in
  Printf.fprintf stderr "PAT[%s]\n%!" (string_of_pat pat)
*)

(* strictly more powerful than exhaust; however, exhaust
   was kept for backwards compatibility *)
let rec exhaust_gadt (ext:Path.t option) pss n = match pss with
| []    ->  Rsome [omegas n]
| []::_ ->  Rnone
| pss   ->
    if not (all_coherent (simplified_first_col pss)) then
      (* We're considering an ill-typed branch, we won't actually be able to
         produce a well typed value taking that branch. *)
      Rnone
    else begin
      (* Assuming the first column is ill-typed but considered coherent, we
         might end up producing an ill-typed witness of non-exhaustivity
         corresponding to the current branch.

         If [exhaust] has been called by [do_check_partial], then the witnesses
         produced get typechecked and the ill-typed ones are discarded.

         If [exhaust] has been called by [do_check_fragile], then it is possible
         we might fail to warn the user that the matching is fragile. See for
         example testsuite/tests/warnings/w04_failure.ml. *)
      let q0 = discr_pat omega pss in
      match filter_all q0 pss with
            (* first column of pss is made of variables only *)
      | [] ->
          begin match exhaust_gadt ext (filter_extra pss) (n-1) with
          | Rsome r -> Rsome (List.map (fun row -> q0::row) r)
          | r -> r
        end
      | constrs ->
          let try_non_omega (p,pss) =
            if is_absent_pat p then
              Rnone
            else
              match
                exhaust_gadt
                  ext pss (List.length (simple_match_args p omega) + n - 1)
              with
              | Rsome r -> Rsome (List.map (fun row ->  (set_args p row)) r)
              | r       -> r in
          let before = try_many_gadt try_non_omega constrs in
          if
            full_match false constrs && not (should_extend ext constrs)
          then
            before
          else
            (*
              D = filter_extra pss is the default matrix
              as it is included in pss, one can avoid
              recursive calls on specialized matrices,
              Essentially :
            * D exhaustive => pss exhaustive
            * D non-exhaustive => we have a non-filtered value
            *)
            let r =  exhaust_gadt ext (filter_extra pss) (n-1) in
            match r with
            | Rnone -> before
            | Rsome r ->
                try
                  let p = build_other ext constrs in
                  let dug = List.map (fun tail -> p :: tail) r in
                  match before with
                  | Rnone -> Rsome dug
                  | Rsome x -> Rsome (x @ dug)
                with
        (* cannot occur, since constructors don't make a full signature *)
                | Empty -> fatal_error "Parmatch.exhaust"
    end

let exhaust_gadt ext pss n =
  let ret = exhaust_gadt ext pss n in
  match ret with
    Rnone -> Rnone
  | Rsome lst ->
      (* The following line is needed to compile stdlib/printf.ml *)
      if lst = [] then Rsome (omegas n) else
      let singletons =
        List.map
          (function
              [x] -> x
            | _ -> assert false)
          lst
      in
      Rsome [orify_many singletons]

(*
   Another exhaustiveness check, enforcing variant typing.
   Note that it does not check exact exhaustiveness, but whether a
   matching could be made exhaustive by closing all variant types.
   When this is true of all other columns, the current column is left
   open (even if it means that the whole matching is not exhaustive as
   a result).
   When this is false for the matrix minus the current column, and the
   current column is composed of variant tags, we close the variant
   (even if it doesn't help in making the matching exhaustive).
*)

let rec pressure_variants tdefs = function
  | []    -> false
  | []::_ -> true
  | pss   ->
      if not (all_coherent (simplified_first_col pss)) then
        true
      else begin
        let q0 = discr_pat omega pss in
        match filter_all q0 pss with
          [] -> pressure_variants tdefs (filter_extra pss)
        | constrs ->
            let rec try_non_omega = function
                (_p,pss) :: rem ->
                  let ok = pressure_variants tdefs pss in
                  try_non_omega rem && ok
              | [] -> true
            in
            if full_match (tdefs=None) constrs then
              try_non_omega constrs
            else if tdefs = None then
              pressure_variants None (filter_extra pss)
            else
              let full = full_match true constrs in
              let ok =
                if full then try_non_omega constrs
                else try_non_omega (filter_all q0 (mark_partial pss))
              in
              begin match constrs, tdefs with
                ({pat_desc=Tpat_variant _} as p,_):: _, Some env ->
                  let row = row_of_pat p in
                  if Btype.row_fixed row
                  || pressure_variants None (filter_extra pss) then ()
                  else close_variant env row
              | _ -> ()
              end;
              ok
      end


(* Yet another satisfiable function *)

(*
   This time every_satisfiable pss qs checks the
   utility of every expansion of qs.
   Expansion means expansion of or-patterns inside qs
*)

type answer =
  | Used                                (* Useful pattern *)
  | Unused                              (* Useless pattern *)
  | Upartial of Typedtree.pattern list  (* Mixed, with list of useless ones *)



(* this row type enable column processing inside the matrix
    - left  ->  elements not to be processed,
    - right ->  elements to be processed
*)
type 'a row = {no_ors : 'a list ; ors : 'a list ; active : 'a list}


(*
let pretty_row {ors=ors ; no_ors=no_ors; active=active} =
  pretty_line ors ; prerr_string " *" ;
  pretty_line no_ors ; prerr_string " *" ;
  pretty_line active

let pretty_rows rs =
  prerr_endline "begin matrix" ;
  List.iter
    (fun r ->
      pretty_row r ;
      prerr_endline "")
    rs ;
  prerr_endline "end matrix"
*)

(* Initial build *)
let make_row ps = {ors=[] ; no_ors=[]; active=ps}

let make_rows pss = List.map make_row pss


(* Useful to detect and expand  or pats inside as pats *)
let rec unalias p = match p.pat_desc with
| Tpat_alias (p,_,_) -> unalias p
| _ -> p


let is_var p = match (unalias p).pat_desc with
| Tpat_any|Tpat_var _ -> true
| _                   -> false

let is_var_column rs =
  List.for_all
    (fun r -> match r.active with
    | p::_ -> is_var p
    | []   -> assert false)
    rs

(* Standard or-args for left-to-right matching *)
let rec or_args p = match p.pat_desc with
| Tpat_or (p1,p2,_) -> p1,p2
| Tpat_alias (p,_,_)  -> or_args p
| _                 -> assert false

(* Just remove current column *)
let remove r = match r.active with
| _::rem -> {r with active=rem}
| []     -> assert false

let remove_column rs = List.map remove rs

(* Current column has been processed *)
let push_no_or r = match r.active with
| p::rem -> { r with no_ors = p::r.no_ors ; active=rem}
| [] -> assert false

let push_or r = match r.active with
| p::rem -> { r with ors = p::r.ors ; active=rem}
| [] -> assert false

let push_or_column rs = List.map push_or rs
and push_no_or_column rs = List.map push_no_or rs

(* Those are adaptations of the previous homonymous functions that
   work on the current column, instead of the first column
*)

let discr_pat q rs =
  discr_pat q (List.map (fun r -> r.active) rs)

let filter_one q rs =
  let rec filter_rec rs = match rs with
  | [] -> []
  | r::rem ->
      match r.active with
      | [] -> assert false
      | {pat_desc = Tpat_alias(p,_,_)}::ps ->
          filter_rec ({r with active = p::ps}::rem)
      | {pat_desc = Tpat_or(p1,p2,_)}::ps ->
          filter_rec
            ({r with active = p1::ps}::
             {r with active = p2::ps}::
             rem)
      | p::ps ->
          if simple_match q p then
            {r with active=simple_match_args q p @ ps} :: filter_rec rem
          else
            filter_rec rem in
  filter_rec rs


(* Back to normal matrices *)
let make_vector r = List.rev r.no_ors

let make_matrix rs = List.map make_vector rs


(* Standard union on answers *)
let union_res r1 r2 = match r1, r2 with
| (Unused,_)
| (_, Unused) -> Unused
| Used,_    -> r2
| _, Used   -> r1
| Upartial u1, Upartial u2 -> Upartial (u1@u2)

(* propose or pats for expansion *)
let extract_elements qs =
  let rec do_rec seen = function
    | [] -> []
    | q::rem ->
        {no_ors= List.rev_append seen rem @ qs.no_ors ;
        ors=[] ;
        active = [q]}::
        do_rec (q::seen) rem in
  do_rec [] qs.ors

(* idem for matrices *)
let transpose rs = match rs with
| [] -> assert false
| r::rem ->
    let i = List.map (fun x -> [x]) r in
    List.fold_left
      (List.map2 (fun r x -> x::r))
      i rem

let extract_columns pss qs = match pss with
| [] -> List.map (fun _ -> []) qs.ors
| _  ->
  let rows = List.map extract_elements pss in
  transpose rows

(* Core function
   The idea is to first look for or patterns (recursive case), then
   check or-patterns argument usefulness (terminal case)
*)
let rec simplified_first_usefulness_col = function
  | [] -> []
  | row :: rows ->
    match row.active with
    | [] -> assert false (* the rows are non-empty! *)
    | p :: _ -> simplify_head_pat p (simplified_first_usefulness_col rows)

let rec every_satisfiables pss qs = match qs.active with
| []     ->
    (* qs is now partitionned,  check usefulness *)
    begin match qs.ors with
    | [] -> (* no or-patterns *)
        if satisfiable (make_matrix pss) (make_vector qs) then
          Used
        else
          Unused
    | _  -> (* n or-patterns -> 2n expansions *)
        List.fold_right2
          (fun pss qs r -> match r with
          | Unused -> Unused
          | _ ->
              match qs.active with
              | [q] ->
                  let q1,q2 = or_args q in
                  let r_loc = every_both pss qs q1 q2 in
                  union_res r r_loc
              | _   -> assert false)
          (extract_columns pss qs) (extract_elements qs)
          Used
    end
| q::rem ->
    let uq = unalias q in
    begin match uq.pat_desc with
    | Tpat_any | Tpat_var _ ->
        if is_var_column pss then
(* forget about ``all-variable''  columns now *)
          every_satisfiables (remove_column pss) (remove qs)
        else
(* otherwise this is direct food for satisfiable *)
          every_satisfiables (push_no_or_column pss) (push_no_or qs)
    | Tpat_or (q1,q2,_) ->
        if
          q1.pat_loc.Location.loc_ghost &&
          q2.pat_loc.Location.loc_ghost
        then
(* syntactically generated or-pats should not be expanded *)
          every_satisfiables (push_no_or_column pss) (push_no_or qs)
        else
(* this is a real or-pattern *)
          every_satisfiables (push_or_column pss) (push_or qs)
    | Tpat_variant (l,_,r) when is_absent l r -> (* Ah Jacques... *)
        Unused
    | _ ->
(* standard case, filter matrix *)
	(* The handling of incoherent matrices is kept in line with
           [satisfiable] *)
        if not (all_coherent (uq :: simplified_first_usefulness_col pss)) then
          Unused
        else begin
          let q0 = discr_pat q pss in
          every_satisfiables
            (filter_one q0 pss)
            {qs with active=simple_match_args q0 q @ rem}
        end
    end

(*
  This function ``every_both'' performs the usefulness check
  of or-pat q1|q2.
  The trick is to call every_satisfied twice with
  current active columns restricted to q1 and q2,
  That way,
  - others orpats in qs.ors will not get expanded.
  - all matching work performed on qs.no_ors is not performed again.
  *)
and every_both pss qs q1 q2 =
  let qs1 = {qs with active=[q1]}
  and qs2 =  {qs with active=[q2]} in
  let r1 = every_satisfiables pss qs1
  and r2 =  every_satisfiables (if compat q1 q2 then qs1::pss else pss) qs2 in
  match r1 with
  | Unused ->
      begin match r2 with
      | Unused -> Unused
      | Used   -> Upartial [q1]
      | Upartial u2 -> Upartial (q1::u2)
      end
  | Used ->
      begin match r2 with
      | Unused -> Upartial [q2]
      | _      -> r2
      end
  | Upartial u1 ->
      begin match r2 with
      | Unused -> Upartial (u1@[q2])
      | Used   -> r1
      | Upartial u2 -> Upartial (u1 @ u2)
      end




(* le_pat p q  means, forall V,  V matches q implies V matches p *)
let rec le_pat p q =
  match (p.pat_desc, q.pat_desc) with
  | (Tpat_var _|Tpat_any),_ -> true
  | Tpat_alias(p,_,_), _ -> le_pat p q
  | _, Tpat_alias(q,_,_) -> le_pat p q
  | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0
  | Tpat_construct(_,c1,ps), Tpat_construct(_,c2,qs) ->
      Types.equal_tag c1.cstr_tag c2.cstr_tag && le_pats ps qs
  | Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) ->
      (l1 = l2 && le_pat p1 p2)
  | Tpat_variant(l1,None,_r1), Tpat_variant(l2,None,_) ->
      l1 = l2
  | Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false
  | Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs
  | Tpat_lazy p, Tpat_lazy q -> le_pat p q
  | Tpat_record (l1,_), Tpat_record (l2,_) ->
      let ps,qs = records_args l1 l2 in
      le_pats ps qs
  | Tpat_array(ps), Tpat_array(qs) ->
      List.length ps = List.length qs && le_pats ps qs
(* In all other cases, enumeration is performed *)
  | _,_  -> not (satisfiable [[p]] [q])

and le_pats ps qs =
  match ps,qs with
    p::ps, q::qs -> le_pat p q && le_pats ps qs
  | _, _         -> true

let get_mins le ps =
  let rec select_rec r = function
      [] -> r
    | p::ps ->
        if List.exists (fun p0 -> le p0 p) ps
        then select_rec r ps
        else select_rec (p::r) ps in
  select_rec [] (select_rec [] ps)

(*
  lub p q is a pattern that matches all values matched by p and q
  may raise Empty, when p and q are not compatible
*)

let rec lub p q = match p.pat_desc,q.pat_desc with
| Tpat_alias (p,_,_),_      -> lub p q
| _,Tpat_alias (q,_,_)      -> lub p q
| (Tpat_any|Tpat_var _),_ -> q
| _,(Tpat_any|Tpat_var _) -> p
| Tpat_or (p1,p2,_),_     -> orlub p1 p2 q
| _,Tpat_or (q1,q2,_)     -> orlub q1 q2 p (* Thanks god, lub is commutative *)
| Tpat_constant c1, Tpat_constant c2 when const_compare c1 c2 = 0 -> p
| Tpat_tuple ps, Tpat_tuple qs ->
    let rs = lubs ps qs in
    make_pat (Tpat_tuple rs) p.pat_type p.pat_env
| Tpat_lazy p, Tpat_lazy q ->
    let r = lub p q in
    make_pat (Tpat_lazy r) p.pat_type p.pat_env
| Tpat_construct (lid, c1,ps1), Tpat_construct (_,c2,ps2)
      when  Types.equal_tag c1.cstr_tag c2.cstr_tag  ->
        let rs = lubs ps1 ps2 in
        make_pat (Tpat_construct (lid, c1,rs))
          p.pat_type p.pat_env
| Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_)
          when  l1=l2 ->
            let r=lub p1 p2 in
            make_pat (Tpat_variant (l1,Some r,row)) p.pat_type p.pat_env
| Tpat_variant (l1,None,_row), Tpat_variant(l2,None,_)
              when l1 = l2 -> p
| Tpat_record (l1,closed),Tpat_record (l2,_) ->
    let rs = record_lubs l1 l2 in
    make_pat (Tpat_record (rs, closed)) p.pat_type p.pat_env
| Tpat_array ps, Tpat_array qs
      when List.length ps = List.length qs ->
        let rs = lubs ps qs in
        make_pat (Tpat_array rs) p.pat_type p.pat_env
| _,_  ->
    raise Empty

and orlub p1 p2 q =
  try
    let r1 = lub p1 q in
    try
      {q with pat_desc=(Tpat_or (r1,lub p2 q,None))}
  with
  | Empty -> r1
with
| Empty -> lub p2 q

and record_lubs l1 l2 =
  let rec lub_rec l1 l2 = match l1,l2 with
  | [],_ -> l2
  | _,[] -> l1
  | (lid1, lbl1,p1)::rem1, (lid2, lbl2,p2)::rem2 ->
      if lbl1.lbl_pos < lbl2.lbl_pos then
        (lid1, lbl1,p1)::lub_rec rem1 l2
      else if lbl2.lbl_pos < lbl1.lbl_pos  then
        (lid2, lbl2,p2)::lub_rec l1 rem2
      else
        (lid1, lbl1,lub p1 p2)::lub_rec rem1 rem2 in
  lub_rec l1 l2

and lubs ps qs = match ps,qs with
| p::ps, q::qs -> lub p q :: lubs ps qs
| _,_ -> []


(******************************)
(* Exported variant closing   *)
(******************************)

(* Apply pressure to variants *)

let pressure_variants tdefs patl =
  let pss = List.map (fun p -> [p;omega]) patl in
  ignore (pressure_variants (Some tdefs) pss)

(*****************************)
(* Utilities for diagnostics *)
(*****************************)

(*
  Build up a working pattern matrix by forgetting
  about guarded patterns
*)

let rec initial_matrix = function
    [] -> []
  | {c_guard=Some _} :: rem -> initial_matrix rem
  | {c_guard=None; c_lhs=p} :: rem -> [p] :: initial_matrix rem

(******************************************)
(* Look for a row that matches some value *)
(******************************************)

(*
  Useful for seeing if the example of
  non-matched value can indeed be matched
  (by a guarded clause)
*)



exception NoGuard

let rec initial_all no_guard = function
  | [] ->
      if no_guard then
        raise NoGuard
      else
        []
  | {c_lhs=pat; c_guard; _} :: rem ->
      ([pat], pat.pat_loc) :: initial_all (no_guard && c_guard = None) rem


let rec do_filter_var = function
  | (_::ps,loc)::rem -> (ps,loc)::do_filter_var rem
  | _ -> []

let do_filter_one q pss =
  let rec filter_rec = function
    | ({pat_desc = Tpat_alias(p,_,_)}::ps,loc)::pss ->
        filter_rec ((p::ps,loc)::pss)
    | ({pat_desc = Tpat_or(p1,p2,_)}::ps,loc)::pss ->
        filter_rec ((p1::ps,loc)::(p2::ps,loc)::pss)
    | (p::ps,loc)::pss ->
        if simple_match q p
        then (simple_match_args q p @ ps, loc) :: filter_rec pss
        else filter_rec pss
    | _ -> [] in
  filter_rec pss

let rec do_match pss qs = match qs with
| [] ->
    begin match pss  with
    | ([],loc)::_ -> Some loc
    | _ -> None
    end
| q::qs -> match q with
  | {pat_desc = Tpat_or (q1,q2,_)} ->
      begin match do_match pss (q1::qs) with
      | None -> do_match pss (q2::qs)
      | r -> r
      end
  | {pat_desc = Tpat_any} ->
      do_match (do_filter_var pss) qs
  | _ ->
      let q0 = normalize_pat q in
      (* [pss] will (or won't) match [q0 :: qs] regardless of the coherence of
	 its first column. *)
      do_match (do_filter_one q0 pss) (simple_match_args q0 q @ qs)


let check_partial_all v casel =
  try
    let pss = initial_all true casel in
    do_match pss [v]
  with
  | NoGuard -> None

(************************)
(* Exhaustiveness check *)
(************************)

(* conversion from Typedtree.pattern to Parsetree.pattern list *)
module Conv = struct
  open Parsetree
  let mkpat desc = Ast_helper.Pat.mk desc

  let name_counter = ref 0
  let fresh name =
    let current = !name_counter in
    name_counter := !name_counter + 1;
    "#$" ^ name ^ string_of_int current

  let conv typed =
    let constrs = Hashtbl.create 7 in
    let labels = Hashtbl.create 7 in
    let rec loop pat =
      match pat.pat_desc with
        Tpat_or (pa,pb,_) ->
          mkpat (Ppat_or (loop pa, loop pb))
      | Tpat_var (_, ({txt="*extension*"} as nm)) -> (* PR#7330 *)
          mkpat (Ppat_var nm)
      | Tpat_any
      | Tpat_var _ ->
          mkpat Ppat_any
      | Tpat_constant c ->
          mkpat (Ppat_constant (Untypeast.constant c))
      | Tpat_alias (p,_,_) -> loop p
      | Tpat_tuple lst ->
          mkpat (Ppat_tuple (List.map loop lst))
      | Tpat_construct (cstr_lid, cstr, lst) ->
          let id = fresh cstr.cstr_name in
          let lid = { cstr_lid with txt = Longident.Lident id } in
          Hashtbl.add constrs id cstr;
          let arg =
            match List.map loop lst with
            | []  -> None
            | [p] -> Some p
            | lst -> Some (mkpat (Ppat_tuple lst))
          in
          mkpat (Ppat_construct(lid, arg))
      | Tpat_variant(label,p_opt,_row_desc) ->
          let arg = Misc.may_map loop p_opt in
          mkpat (Ppat_variant(label, arg))
      | Tpat_record (subpatterns, _closed_flag) ->
          let fields =
            List.map
              (fun (_, lbl, p) ->
                let id = fresh lbl.lbl_name in
                Hashtbl.add labels id lbl;
                (mknoloc (Longident.Lident id), loop p))
              subpatterns
          in
          mkpat (Ppat_record (fields, Open))
      | Tpat_array lst ->
          mkpat (Ppat_array (List.map loop lst))
      | Tpat_lazy p ->
          mkpat (Ppat_lazy (loop p))
    in
    let ps = loop typed in
    (ps, constrs, labels)
end


(* Whether the counter-example contains an extension pattern *)
let contains_extension pat =
  let r = ref false in
  let rec loop = function
      {pat_desc=Tpat_var (_, {txt="*extension*"})} ->
        r := true
    | p -> Typedtree.iter_pattern_desc loop p.pat_desc
  in loop pat; !r

(* Build an untyped or-pattern from its expected type *)
let ppat_of_type env ty =
  match pats_of_type env ty with
    [{pat_desc = Tpat_any}] ->
      (Conv.mkpat Parsetree.Ppat_any, Hashtbl.create 0, Hashtbl.create 0)
  | pats ->
      Conv.conv (orify_many pats)

let do_check_partial ?pred exhaust loc casel pss = match pss with
| [] ->
        (*
          This can occur
          - For empty matches generated by ocamlp4 (no warning)
          - when all patterns have guards (then, casel <> [])
          (specific warning)
          Then match MUST be considered non-exhaustive,
          otherwise compilation of PM is broken.
          *)
    begin match casel with
    | [] -> ()
    | _  ->
      if Warnings.is_active Warnings.All_clauses_guarded then
        Location.prerr_warning loc Warnings.All_clauses_guarded
    end ;
    Partial
| ps::_  ->
    begin match exhaust None pss (List.length ps) with
    | Rnone -> Total
    | Rsome [u] ->
        let v =
          match pred with
          | Some pred ->
              let (pattern,constrs,labels) = Conv.conv u in
              let u' = pred constrs labels pattern in
              (* pretty_pat u;
              begin match u' with
                None -> prerr_endline ": impossible"
              | Some _ -> prerr_endline ": possible"
              end; *)
              u'
          | None -> Some u
        in
        begin match v with
          None -> Total
        | Some v ->
            if Warnings.is_active (Warnings.Partial_match "") then begin
              let errmsg =
                try
                  let buf = Buffer.create 16 in
                  let fmt = formatter_of_buffer buf in
                  top_pretty fmt v;
                  begin match check_partial_all v casel with
                  | None -> ()
                  | Some _ ->
                      (* This is 'Some loc', where loc is the location of
                         a possibly matching clause.
                         Forget about loc, because printing two locations
                         is a pain in the top-level *)
                      Buffer.add_string buf
                        "\n(However, some guarded clause may match this value.)"
                  end;
                  if contains_extension v then
                    Buffer.add_string buf
                      "\nMatching over values of extensible variant types \
                         (the *extension* above)\n\
                      must include a wild card pattern in order to be exhaustive."
                  ;
                  Buffer.contents buf
                with _ ->
                  ""
              in
                Location.prerr_warning loc (Warnings.Partial_match errmsg)
            end;
            Partial
        end
    | _ ->
        fatal_error "Parmatch.check_partial"
    end

(*
let do_check_partial_normal loc casel pss =
  do_check_partial exhaust loc casel pss
 *)

let do_check_partial_gadt pred loc casel pss =
  do_check_partial ~pred exhaust_gadt loc casel pss



(*****************)
(* Fragile check *)
(*****************)

(* Collect all data types in a pattern *)

let rec add_path path = function
  | [] -> [path]
  | x::rem as paths ->
      if Path.same path x then paths
      else x::add_path path rem

let extendable_path path =
  not
    (Path.same path Predef.path_bool ||
    Path.same path Predef.path_list ||
    Path.same path Predef.path_unit ||
    Path.same path Predef.path_option)

let rec collect_paths_from_pat r p = match p.pat_desc with
| Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)},ps)
  ->
    let path =  get_type_path p.pat_type p.pat_env in
    List.fold_left
      collect_paths_from_pat
      (if extendable_path path then add_path path r else r)
      ps
| Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r
| Tpat_tuple ps | Tpat_array ps
| Tpat_construct (_, {cstr_tag=Cstr_extension _}, ps)->
    List.fold_left collect_paths_from_pat r ps
| Tpat_record (lps,_) ->
    List.fold_left
      (fun r (_, _, p) -> collect_paths_from_pat r p)
      r lps
| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_) -> collect_paths_from_pat r p
| Tpat_or (p1,p2,_) ->
    collect_paths_from_pat (collect_paths_from_pat r p1) p2
| Tpat_lazy p
    ->
    collect_paths_from_pat r p


(*
  Actual fragile check
   1. Collect data types in the patterns of the match.
   2. One exhaustivity check per datatype, considering that
      the type is extended.
*)

let do_check_fragile_param exhaust loc casel pss =
  let exts =
    List.fold_left
      (fun r c -> collect_paths_from_pat r c.c_lhs)
      [] casel in
  match exts with
  | [] -> ()
  | _ -> match pss with
    | [] -> ()
    | ps::_ ->
        List.iter
          (fun ext ->
            match exhaust (Some ext) pss (List.length ps) with
            | Rnone ->
                Location.prerr_warning
                  loc
                  (Warnings.Fragile_match (Path.name ext))
            | Rsome _ -> ())
          exts

(*let do_check_fragile_normal = do_check_fragile_param exhaust*)
let do_check_fragile_gadt = do_check_fragile_param exhaust_gadt

(********************************)
(* Exported unused clause check *)
(********************************)

let check_unused pred casel =
  if Warnings.is_active Warnings.Unused_match
  || List.exists (fun c -> c.c_rhs.exp_desc = Texp_unreachable) casel then
    let rec do_rec pref = function
      | [] -> ()
      | {c_lhs=q; c_guard; c_rhs} :: rem ->
          let qs = [q] in
            begin try
              let pss =
                  get_mins le_pats (List.filter (compats qs) pref) in
              (* First look for redundant or partially redundant patterns *)
              let r = every_satisfiables (make_rows pss) (make_row qs) in
              let refute = (c_rhs.exp_desc = Texp_unreachable) in
              (* Do not warn for unused [pat -> .] *)
              if r = Unused && refute then () else
              let r =
                (* Do not refine if there are no other lines *)
                let skip =
                  r = Unused || (not refute && pref = []) ||
                  not(refute || Warnings.is_active Warnings.Unreachable_case) in
                if skip then r else
                (* Then look for empty patterns *)
                let sfs = satisfiables pss qs in
                if sfs = [] then Unused else
                let sfs =
                  List.map (function [u] -> u | _ -> assert false) sfs in
                let u = orify_many sfs in
                (*Format.eprintf "%a@." pretty_val u;*)
                let (pattern,constrs,labels) = Conv.conv u in
                let pattern = {pattern with Parsetree.ppat_loc = q.pat_loc} in
                match pred refute constrs labels pattern with
                  None when not refute ->
                    Location.prerr_warning q.pat_loc Warnings.Unreachable_case;
                    Used
                | _ -> r
              in
              match r with
              | Unused ->
                  Location.prerr_warning
                    q.pat_loc Warnings.Unused_match
              | Upartial ps ->
                  List.iter
                    (fun p ->
                      Location.prerr_warning
                        p.pat_loc Warnings.Unused_pat)
                    ps
              | Used -> ()
            with Empty | Not_found | NoGuard -> assert false
            end ;

          if c_guard <> None then
            do_rec pref rem
          else
            do_rec ([q]::pref) rem in

    do_rec [] casel

(*********************************)
(* Exported irrefutability tests *)
(*********************************)

let irrefutable pat = le_pat pat omega

let inactive ~partial pat =
  match partial with
  | Partial -> false
  | Total -> begin
      let rec loop pat =
        match pat.pat_desc with
        | Tpat_lazy _ | Tpat_array _ ->
          false
        | Tpat_any | Tpat_var _ | Tpat_variant (_, None, _) ->
            true
        | Tpat_constant c -> begin
            match c with
            | Const_string _ -> Config.safe_string
            | Const_int _ | Const_char _ | Const_float _
            | Const_int32 _ | Const_int64 _ | Const_nativeint _ -> true
          end
        | Tpat_tuple ps | Tpat_construct (_, _, ps) ->
            List.for_all (fun p -> loop p) ps
        | Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) ->
            loop p
        | Tpat_record (ldps,_) ->
            List.for_all
              (fun (_, lbl, p) -> lbl.lbl_mut = Immutable && loop p)
              ldps
        | Tpat_or (p,q,_) ->
            loop p && loop q
      in
      loop pat
  end







(*********************************)
(* Exported exhaustiveness check *)
(*********************************)

(*
   Fragile check is performed when required and
   on exhaustive matches only.
*)

let check_partial_param do_check_partial do_check_fragile loc casel =
    let pss = initial_matrix casel in
    let pss = get_mins le_pats pss in
    let total = do_check_partial loc casel pss in
    if
      total = Total && Warnings.is_active (Warnings.Fragile_match "")
    then begin
      do_check_fragile loc casel pss
    end ;
    total

(*let check_partial =
    check_partial_param
      do_check_partial_normal
      do_check_fragile_normal*)

let check_partial_gadt pred loc casel =
  check_partial_param (do_check_partial_gadt pred)
    do_check_fragile_gadt loc casel


(*************************************)
(* Ambiguous variable in or-patterns *)
(*************************************)

(* Specification: ambiguous variables in or-patterns.

   The semantics of or-patterns in OCaml is specified with
   a left-to-right bias: a value [v] matches the pattern [p | q] if it
   matches [p] or [q], but if it matches both, the environment
   captured by the match is the environment captured by [p], never the
   one captured by [q].

   While this property is generally well-understood, one specific case
   where users expect a different semantics is when a pattern is
   followed by a when-guard: [| p when g -> e]. Consider for example:

     | ((Const x, _) | (_, Const x)) when is_neutral x -> branch

   The semantics is clear: match the scrutinee against the pattern, if
   it matches, test the guard, and if the guard passes, take the
   branch.

   However, consider the input [(Const a, Const b)], where [a] fails
   the test [is_neutral f], while [b] passes the test [is_neutral
   b]. With the left-to-right semantics, the clause above is *not*
   taken by its input: matching [(Const a, Const b)] against the
   or-pattern succeeds in the left branch, it returns the environment
   [x -> a], and then the guard [is_neutral a] is tested and fails,
   the branch is not taken. Most users, however, intuitively expect
   that any pair that has one side passing the test will take the
   branch. They assume it is equivalent to the following:

     | (Const x, _) when is_neutral x -> branch
     | (_, Const x) when is_neutral x -> branch

   while it is not.

   The code below is dedicated to finding these confusing cases: the
   cases where a guard uses "ambiguous" variables, that are bound to
   different parts of the scrutinees by different sides of
   a or-pattern. In other words, it finds the cases where the
   specified left-to-right semantics is not equivalent to
   a non-deterministic semantics (any branch can be taken) relatively
   to a specific guard.
*)

module IdSet = Set.Make(Ident)

let pattern_vars p = IdSet.of_list (Typedtree.pat_bound_idents p)

(* Row for ambiguous variable search,
   unseen is the traditional pattern row,
   seen   is a list of position bindings *)

type amb_row = { unseen : pattern list ; seen : IdSet.t list; }


(* Push binding variables now *)

let rec do_push r p ps seen k = match p.pat_desc with
| Tpat_alias (p,x,_) -> do_push (IdSet.add x r) p ps seen k
| Tpat_var (x,_) ->
    (omega,{ unseen = ps; seen=IdSet.add x r::seen; })::k
| Tpat_or (p1,p2,_) ->
    do_push r p1 ps seen (do_push r p2 ps seen k)
| _ ->
    (p,{ unseen = ps; seen = r::seen; })::k

let rec push_vars = function
  | [] -> []
  | { unseen = [] }::_ -> assert false
  | { unseen = p::ps; seen; }::rem ->
      do_push IdSet.empty p ps seen (push_vars rem)

let collect_stable = function
  | [] -> assert false
  | { seen=xss; _}::rem ->
      let rec c_rec xss = function
        | [] -> xss
        | {seen=yss; _}::rem ->
            let xss = List.map2 IdSet.inter xss yss in
            c_rec xss rem in
      let inters = c_rec xss rem in
      List.fold_left IdSet.union IdSet.empty inters


(*********************************************)
(* Filtering utilities for our specific rows *)
(*********************************************)

(* Take a pattern matrix as a list (rows) of lists (columns) of patterns
     | p1, p2, .., pn
     | q1, q2, .., qn
     | r1, r2, .., rn
     | ...

   We split this matrix into a list of sub-matrices, one for each head
   constructor appearing in the leftmost column. For each row whose
   left column starts with a head constructor, remove this head
   column, prepend one column for each argument of the constructor,
   and add the resulting row in the sub-matrix corresponding to this
   head constructor.

   Rows whose left column is omega (the Any pattern _) may match any
   head constructor, so they are added to all groups.

   The list of sub-matrices is represented as a list of pair
     (head constructor, submatrix)
*)

let filter_all =
  (* the head constructor (as a pattern with omega arguments) of
     a pattern *)
  let discr_head pat =
    match pat.pat_desc with
    | Tpat_record (lbls, closed) ->
        (* a partial record pattern { f1 = p1; f2 = p2; _ }
           needs to be expanded, otherwise matching against this head
           would drop the pattern arguments for non-mentioned fields *)
        let lbls = all_record_args lbls in
        normalize_pat { pat with pat_desc = Tpat_record (lbls, closed) }
    | _ -> normalize_pat pat
  in

  (* insert a row of head [p] and rest [r] into the right group *)
  let rec insert p r env = match env with
  | [] ->
      (* if no group matched this row, it has a head constructor that
         was never seen before; add a new sub-matrix for this head *)
      let p0 = discr_head p in
      [p0,[{ r with unseen = simple_match_args p0 p @ r.unseen }]]
  | (q0,rs) as bd::env ->
      if simple_match q0 p then begin
        let r = { r with unseen = simple_match_args q0 p@r.unseen; } in
        (q0,r::rs)::env
      end
      else bd::insert p r env in

  (* insert a row of head omega into all groups *)
  let insert_omega r env =
    List.map
      (fun (q0,rs) ->
         let r =
           { r with unseen = simple_match_args q0 omega @ r.unseen; } in
         (q0,r::rs))
      env
  in

  let rec filter_rec env = function
    | [] -> env
    | ({pat_desc=(Tpat_var _|Tpat_alias _|Tpat_or _)},_)::_ -> assert false
    | ({pat_desc=Tpat_any}, _)::rs -> filter_rec env rs
    | (p,r)::rs -> filter_rec (insert p r env) rs in

  let rec filter_omega env = function
    | [] -> env
    | ({pat_desc=(Tpat_var _|Tpat_alias _|Tpat_or _)},_)::_ -> assert false
    | ({pat_desc=Tpat_any},r)::rs -> filter_omega (insert_omega r env) rs
    | _::rs -> filter_omega env rs in

  fun rs ->
    (* first insert the rows with head constructors,
       to get the definitive list of groups *)
    let env = filter_rec [] rs in
    (* then add the omega rows to all groups *)
    filter_omega env rs

(* Compute stable bindings *)

let rec do_stable rs = match rs with
| [] -> assert false (* No empty matrix *)
| { unseen=[]; _ }::_ ->
    collect_stable rs
| _ ->
    let rs = push_vars rs in
    if not (all_coherent (first_column rs)) then begin
      (* If the first column is incoherent, then all the variables of this
         matrix are stable. *)
      List.fold_left (fun acc (_, { seen; _ }) ->
        List.fold_left IdSet.union acc seen
      ) IdSet.empty rs
    end else begin
      (* If the column is ill-typed but deemed coherent, we might spuriously
         warn about some variables being unstable.
         As sad as that might be, the warning can be silenced by splitting the
         or-pattern...  *)
      match filter_all rs with
      | [] ->
          do_stable (List.map snd rs)
      | (_,rs)::env ->
          List.fold_left
            (fun xs (_,rs) -> IdSet.inter xs (do_stable rs))
            (do_stable rs) env
    end

let stable p = do_stable [{unseen=[p]; seen=[];}]


(* All identifier paths that appear in an expression that occurs
   as a clause right hand side or guard.

  The function is rather complex due to the compilation of
  unpack patterns by introducing code in rhs expressions
  and **guards**.

  For pattern (module M:S)  -> e the code is
  let module M_mod = unpack M .. in e

  Hence M is "free" in e iff M_mod is free in e.

  Not doing so will yield excessive  warning in
  (module (M:S) } ...) when true -> ....
  as M is always present in
  let module M_mod = unpack M .. in true
*)

let all_rhs_idents exp =
  let ids = ref IdSet.empty in
  let module Iterator = TypedtreeIter.MakeIterator(struct
    include TypedtreeIter.DefaultIteratorArgument
    let enter_expression exp = match exp.exp_desc with
      | Texp_ident (path, _lid, _descr) ->
          List.iter
            (fun id -> ids := IdSet.add id !ids)
            (Path.heads path)
      | _ -> ()

(* Very hackish, detect unpack pattern  compilation
   and perform "indirect check for them" *)
    let is_unpack exp =
      List.exists
        (fun (attr, _) -> attr.txt = "#modulepat") exp.exp_attributes

    let leave_expression exp =
      if is_unpack exp then begin match exp.exp_desc with
      | Texp_letmodule
          (id_mod,_,
           {mod_desc=
            Tmod_unpack ({exp_desc=Texp_ident (Path.Pident id_exp,_,_)},_)},
           _) ->
             assert (IdSet.mem id_exp !ids) ;
             if not (IdSet.mem id_mod !ids) then begin
               ids := IdSet.remove id_exp !ids
             end
      | _ -> assert false
      end
  end) in
  Iterator.iter_expression exp;
  !ids

let check_ambiguous_bindings =
  let open Warnings in
  let warn0 = Ambiguous_pattern [] in
  fun cases ->
    if is_active warn0 then
      List.iter
        (fun case -> match case with
        | { c_guard=None ; _} -> ()
        | { c_lhs=p; c_guard=Some g; _} ->
            let all =
              IdSet.inter (pattern_vars p) (all_rhs_idents g) in
            if not (IdSet.is_empty all) then begin
              let st = stable p in
              let ambiguous = IdSet.diff all st in
              if not (IdSet.is_empty  ambiguous) then begin
                let pps = IdSet.elements ambiguous |> List.map Ident.name in
                let warn = Ambiguous_pattern pps in
                Location.prerr_warning p.pat_loc warn
              end
            end)
        cases

end
module Ast_iterator : sig 
#1 "ast_iterator.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                      Nicolas Ojeda Bar, LexiFi                         *)
(*                                                                        *)
(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** {!iterator} allows to implement AST inspection using open recursion.  A
    typical mapper would be based on {!default_iterator}, a trivial iterator,
    and will fall back on it for handling the syntax it does not modify. *)

open Parsetree

(** {1 A generic Parsetree iterator} *)

type iterator = {
  attribute: iterator -> attribute -> unit;
  attributes: iterator -> attribute list -> unit;
  case: iterator -> case -> unit;
  cases: iterator -> case list -> unit;
  class_declaration: iterator -> class_declaration -> unit;
  class_description: iterator -> class_description -> unit;
  class_expr: iterator -> class_expr -> unit;
  class_field: iterator -> class_field -> unit;
  class_signature: iterator -> class_signature -> unit;
  class_structure: iterator -> class_structure -> unit;
  class_type: iterator -> class_type -> unit;
  class_type_declaration: iterator -> class_type_declaration -> unit;
  class_type_field: iterator -> class_type_field -> unit;
  constructor_declaration: iterator -> constructor_declaration -> unit;
  expr: iterator -> expression -> unit;
  extension: iterator -> extension -> unit;
  extension_constructor: iterator -> extension_constructor -> unit;
  include_declaration: iterator -> include_declaration -> unit;
  include_description: iterator -> include_description -> unit;
  label_declaration: iterator -> label_declaration -> unit;
  location: iterator -> Location.t -> unit;
  module_binding: iterator -> module_binding -> unit;
  module_declaration: iterator -> module_declaration -> unit;
  module_expr: iterator -> module_expr -> unit;
  module_type: iterator -> module_type -> unit;
  module_type_declaration: iterator -> module_type_declaration -> unit;
  open_description: iterator -> open_description -> unit;
  pat: iterator -> pattern -> unit;
  payload: iterator -> payload -> unit;
  signature: iterator -> signature -> unit;
  signature_item: iterator -> signature_item -> unit;
  structure: iterator -> structure -> unit;
  structure_item: iterator -> structure_item -> unit;
  typ: iterator -> core_type -> unit;
  type_declaration: iterator -> type_declaration -> unit;
  type_extension: iterator -> type_extension -> unit;
  type_kind: iterator -> type_kind -> unit;
  value_binding: iterator -> value_binding -> unit;
  value_description: iterator -> value_description -> unit;
  with_constraint: iterator -> with_constraint -> unit;
}
(** A [iterator] record implements one "method" per syntactic category,
    using an open recursion style: each method takes as its first
    argument the iterator to be applied to children in the syntax
    tree. *)

val default_iterator: iterator
(** A default iterator, which implements a "do not do anything" mapping. *)

end = struct
#1 "ast_iterator.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                      Nicolas Ojeda Bar, LexiFi                         *)
(*                                                                        *)
(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* A generic Parsetree mapping class *)

(*
[@@@ocaml.warning "+9"]
  (* Ensure that record patterns don't miss any field. *)
*)


open Parsetree
open Location

type iterator = {
  attribute: iterator -> attribute -> unit;
  attributes: iterator -> attribute list -> unit;
  case: iterator -> case -> unit;
  cases: iterator -> case list -> unit;
  class_declaration: iterator -> class_declaration -> unit;
  class_description: iterator -> class_description -> unit;
  class_expr: iterator -> class_expr -> unit;
  class_field: iterator -> class_field -> unit;
  class_signature: iterator -> class_signature -> unit;
  class_structure: iterator -> class_structure -> unit;
  class_type: iterator -> class_type -> unit;
  class_type_declaration: iterator -> class_type_declaration -> unit;
  class_type_field: iterator -> class_type_field -> unit;
  constructor_declaration: iterator -> constructor_declaration -> unit;
  expr: iterator -> expression -> unit;
  extension: iterator -> extension -> unit;
  extension_constructor: iterator -> extension_constructor -> unit;
  include_declaration: iterator -> include_declaration -> unit;
  include_description: iterator -> include_description -> unit;
  label_declaration: iterator -> label_declaration -> unit;
  location: iterator -> Location.t -> unit;
  module_binding: iterator -> module_binding -> unit;
  module_declaration: iterator -> module_declaration -> unit;
  module_expr: iterator -> module_expr -> unit;
  module_type: iterator -> module_type -> unit;
  module_type_declaration: iterator -> module_type_declaration -> unit;
  open_description: iterator -> open_description -> unit;
  pat: iterator -> pattern -> unit;
  payload: iterator -> payload -> unit;
  signature: iterator -> signature -> unit;
  signature_item: iterator -> signature_item -> unit;
  structure: iterator -> structure -> unit;
  structure_item: iterator -> structure_item -> unit;
  typ: iterator -> core_type -> unit;
  type_declaration: iterator -> type_declaration -> unit;
  type_extension: iterator -> type_extension -> unit;
  type_kind: iterator -> type_kind -> unit;
  value_binding: iterator -> value_binding -> unit;
  value_description: iterator -> value_description -> unit;
  with_constraint: iterator -> with_constraint -> unit;
}
(** A [iterator] record implements one "method" per syntactic category,
    using an open recursion style: each method takes as its first
    argument the iterator to be applied to children in the syntax
    tree. *)

let iter_fst f (x, _) = f x
let iter_snd f (_, y) = f y
let iter_tuple f1 f2 (x, y) = f1 x; f2 y
let iter_tuple3 f1 f2 f3 (x, y, z) = f1 x; f2 y; f3 z
let iter_opt f = function None -> () | Some x -> f x

let iter_loc sub {loc; txt = _} = sub.location sub loc

module T = struct
  (* Type expressions for the core language *)

  let row_field sub = function
    | Rtag (_, attrs, _, tl) ->
        sub.attributes sub attrs; List.iter (sub.typ sub) tl
    | Rinherit t -> sub.typ sub t

  let object_field sub = function
    | Otag (_, attrs, t) ->
        sub.attributes sub attrs; sub.typ sub t
    | Oinherit t -> sub.typ sub t

  let iter sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
    sub.location sub loc;
    sub.attributes sub attrs;
    match desc with
    | Ptyp_any
    | Ptyp_var _ -> ()
    | Ptyp_arrow (_lab, t1, t2) ->
        sub.typ sub t1; sub.typ sub t2
    | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl
    | Ptyp_constr (lid, tl) ->
        iter_loc sub lid; List.iter (sub.typ sub) tl
    | Ptyp_object (ol, _o) ->
        List.iter (object_field sub) ol
    | Ptyp_class (lid, tl) ->
        iter_loc sub lid; List.iter (sub.typ sub) tl
    | Ptyp_alias (t, _) -> sub.typ sub t
    | Ptyp_variant (rl, _b, _ll) ->
        List.iter (row_field sub) rl
    | Ptyp_poly (_, t) -> sub.typ sub t
    | Ptyp_package (lid, l) ->
        iter_loc sub lid;
        List.iter (iter_tuple (iter_loc sub) (sub.typ sub)) l
    | Ptyp_extension x -> sub.extension sub x

  let iter_type_declaration sub
      {ptype_name; ptype_params; ptype_cstrs;
       ptype_kind;
       ptype_private = _;
       ptype_manifest;
       ptype_attributes;
       ptype_loc} =
    iter_loc sub ptype_name;
    List.iter (iter_fst (sub.typ sub)) ptype_params;
    List.iter
      (iter_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub))
      ptype_cstrs;
    sub.type_kind sub ptype_kind;
    iter_opt (sub.typ sub) ptype_manifest;
    sub.location sub ptype_loc;
    sub.attributes sub ptype_attributes

  let iter_type_kind sub = function
    | Ptype_abstract -> ()
    | Ptype_variant l ->
        List.iter (sub.constructor_declaration sub) l
    | Ptype_record l -> List.iter (sub.label_declaration sub) l
    | Ptype_open -> ()

  let iter_constructor_arguments sub = function
    | Pcstr_tuple l -> List.iter (sub.typ sub) l
    | Pcstr_record l ->
        List.iter (sub.label_declaration sub) l

  let iter_type_extension sub
      {ptyext_path; ptyext_params;
       ptyext_constructors;
       ptyext_private = _;
       ptyext_attributes} =
    iter_loc sub ptyext_path;
    List.iter (sub.extension_constructor sub) ptyext_constructors;
    List.iter (iter_fst (sub.typ sub)) ptyext_params;
    sub.attributes sub ptyext_attributes

  let iter_extension_constructor_kind sub = function
      Pext_decl(ctl, cto) ->
        iter_constructor_arguments sub ctl; iter_opt (sub.typ sub) cto
    | Pext_rebind li ->
        iter_loc sub li

  let iter_extension_constructor sub
      {pext_name;
       pext_kind;
       pext_loc;
       pext_attributes} =
    iter_loc sub pext_name;
    iter_extension_constructor_kind sub pext_kind;
    sub.location sub pext_loc;
    sub.attributes sub pext_attributes

end

module CT = struct
  (* Type expressions for the class language *)

  let iter sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} =
    sub.location sub loc;
    sub.attributes sub attrs;
    match desc with
    | Pcty_constr (lid, tys) ->
        iter_loc sub lid; List.iter (sub.typ sub) tys
    | Pcty_signature x -> sub.class_signature sub x
    | Pcty_arrow (_lab, t, ct) ->
        sub.typ sub t; sub.class_type sub ct
    | Pcty_extension x -> sub.extension sub x
    | Pcty_open (_ovf, lid, e) ->
        iter_loc sub lid; sub.class_type sub e

  let iter_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
    =
    sub.location sub loc;
    sub.attributes sub attrs;
    match desc with
    | Pctf_inherit ct -> sub.class_type sub ct
    | Pctf_val (_s, _m, _v, t) -> sub.typ sub t
    | Pctf_method (_s, _p, _v, t) -> sub.typ sub t
    | Pctf_constraint (t1, t2) ->
        sub.typ sub t1; sub.typ sub t2
    | Pctf_attribute x -> sub.attribute sub x
    | Pctf_extension x -> sub.extension sub x

  let iter_signature sub {pcsig_self; pcsig_fields} =
    sub.typ sub pcsig_self;
    List.iter (sub.class_type_field sub) pcsig_fields
end

module MT = struct
  (* Type expressions for the module language *)

  let iter sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} =
    sub.location sub loc;
    sub.attributes sub attrs;
    match desc with
    | Pmty_ident s -> iter_loc sub s
    | Pmty_alias s -> iter_loc sub s
    | Pmty_signature sg -> sub.signature sub sg
    | Pmty_functor (s, mt1, mt2) ->
        iter_loc sub s;
        iter_opt (sub.module_type sub) mt1;
        sub.module_type sub mt2
    | Pmty_with (mt, l) ->
        sub.module_type sub mt;
        List.iter (sub.with_constraint sub) l
    | Pmty_typeof me -> sub.module_expr sub me
    | Pmty_extension x -> sub.extension sub x

  let iter_with_constraint sub = function
    | Pwith_type (lid, d) ->
        iter_loc sub lid; sub.type_declaration sub d
    | Pwith_module (lid, lid2) ->
        iter_loc sub lid; iter_loc sub lid2
    | Pwith_typesubst (lid, d) ->
        iter_loc sub lid; sub.type_declaration sub d
    | Pwith_modsubst (s, lid) ->
        iter_loc sub s; iter_loc sub lid

  let iter_signature_item sub {psig_desc = desc; psig_loc = loc} =
    sub.location sub loc;
    match desc with
    | Psig_value vd -> sub.value_description sub vd
    | Psig_type (_rf, l) -> List.iter (sub.type_declaration sub) l
    | Psig_typext te -> sub.type_extension sub te
    | Psig_exception ed -> sub.extension_constructor sub ed
    | Psig_module x -> sub.module_declaration sub x
    | Psig_recmodule l ->
        List.iter (sub.module_declaration sub) l
    | Psig_modtype x -> sub.module_type_declaration sub x
    | Psig_open x -> sub.open_description sub x
    | Psig_include x -> sub.include_description sub x
    | Psig_class l -> List.iter (sub.class_description sub) l
    | Psig_class_type l ->
        List.iter (sub.class_type_declaration sub) l
    | Psig_extension (x, attrs) ->
        sub.extension sub x; sub.attributes sub attrs
    | Psig_attribute x -> sub.attribute sub x
end


module M = struct
  (* Value expressions for the module language *)

  let iter sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
    sub.location sub loc;
    sub.attributes sub attrs;
    match desc with
    | Pmod_ident x -> iter_loc sub x
    | Pmod_structure str -> sub.structure sub str
    | Pmod_functor (arg, arg_ty, body) ->
        iter_loc sub arg;
        iter_opt (sub.module_type sub) arg_ty;
        sub.module_expr sub body
    | Pmod_apply (m1, m2) ->
        sub.module_expr sub m1; sub.module_expr sub m2
    | Pmod_constraint (m, mty) ->
        sub.module_expr sub m; sub.module_type sub mty
    | Pmod_unpack e -> sub.expr sub e
    | Pmod_extension x -> sub.extension sub x

  let iter_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
    sub.location sub loc;
    match desc with
    | Pstr_eval (x, attrs) ->
        sub.expr sub x; sub.attributes sub attrs
    | Pstr_value (_r, vbs) -> List.iter (sub.value_binding sub) vbs
    | Pstr_primitive vd -> sub.value_description sub vd
    | Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l
    | Pstr_typext te -> sub.type_extension sub te
    | Pstr_exception ed -> sub.extension_constructor sub ed
    | Pstr_module x -> sub.module_binding sub x
    | Pstr_recmodule l -> List.iter (sub.module_binding sub) l
    | Pstr_modtype x -> sub.module_type_declaration sub x
    | Pstr_open x -> sub.open_description sub x
    | Pstr_class l -> List.iter (sub.class_declaration sub) l
    | Pstr_class_type l ->
        List.iter (sub.class_type_declaration sub) l
    | Pstr_include x -> sub.include_declaration sub x
    | Pstr_extension (x, attrs) ->
        sub.extension sub x; sub.attributes sub attrs
    | Pstr_attribute x -> sub.attribute sub x
end

module E = struct
  (* Value expressions for the core language *)

  let iter sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
    sub.location sub loc;
    sub.attributes sub attrs;
    match desc with
    | Pexp_ident x -> iter_loc sub x
    | Pexp_constant _ -> ()
    | Pexp_let (_r, vbs, e) ->
        List.iter (sub.value_binding sub) vbs;
        sub.expr sub e
    | Pexp_fun (_lab, def, p, e) ->
        iter_opt (sub.expr sub) def;
        sub.pat sub p;
        sub.expr sub e
    | Pexp_function pel -> sub.cases sub pel
    | Pexp_apply (e, l) ->
        sub.expr sub e; List.iter (iter_snd (sub.expr sub)) l
    | Pexp_match (e, pel) ->
        sub.expr sub e; sub.cases sub pel
    | Pexp_try (e, pel) -> sub.expr sub e; sub.cases sub pel
    | Pexp_tuple el -> List.iter (sub.expr sub) el
    | Pexp_construct (lid, arg) ->
        iter_loc sub lid; iter_opt (sub.expr sub) arg
    | Pexp_variant (_lab, eo) ->
        iter_opt (sub.expr sub) eo
    | Pexp_record (l, eo) ->
        List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) l;
        iter_opt (sub.expr sub) eo
    | Pexp_field (e, lid) ->
        sub.expr sub e; iter_loc sub lid
    | Pexp_setfield (e1, lid, e2) ->
        sub.expr sub e1; iter_loc sub lid;
        sub.expr sub e2
    | Pexp_array el -> List.iter (sub.expr sub) el
    | Pexp_ifthenelse (e1, e2, e3) ->
        sub.expr sub e1; sub.expr sub e2;
        iter_opt (sub.expr sub) e3
    | Pexp_sequence (e1, e2) ->
        sub.expr sub e1; sub.expr sub e2
    | Pexp_while (e1, e2) ->
        sub.expr sub e1; sub.expr sub e2
    | Pexp_for (p, e1, e2, _d, e3) ->
        sub.pat sub p; sub.expr sub e1; sub.expr sub e2;
        sub.expr sub e3
    | Pexp_coerce (e, t1, t2) ->
        sub.expr sub e; iter_opt (sub.typ sub) t1;
        sub.typ sub t2
    | Pexp_constraint (e, t) ->
        sub.expr sub e; sub.typ sub t
    | Pexp_send (e, _s) -> sub.expr sub e
    | Pexp_new lid -> iter_loc sub lid
    | Pexp_setinstvar (s, e) ->
        iter_loc sub s; sub.expr sub e
    | Pexp_override sel ->
        List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) sel
    | Pexp_letmodule (s, me, e) ->
        iter_loc sub s; sub.module_expr sub me;
        sub.expr sub e
    | Pexp_letexception (cd, e) ->
        sub.extension_constructor sub cd;
        sub.expr sub e
    | Pexp_assert e -> sub.expr sub e
    | Pexp_lazy e -> sub.expr sub e
    | Pexp_poly (e, t) ->
        sub.expr sub e; iter_opt (sub.typ sub) t
    | Pexp_object cls -> sub.class_structure sub cls
    | Pexp_newtype (_s, e) -> sub.expr sub e
    | Pexp_pack me -> sub.module_expr sub me
    | Pexp_open (_ovf, lid, e) ->
        iter_loc sub lid; sub.expr sub e
    | Pexp_extension x -> sub.extension sub x
    | Pexp_unreachable -> ()
end

module P = struct
  (* Patterns *)

  let iter sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} =
    sub.location sub loc;
    sub.attributes sub attrs;
    match desc with
    | Ppat_any -> ()
    | Ppat_var s -> iter_loc sub s
    | Ppat_alias (p, s) -> sub.pat sub p; iter_loc sub s
    | Ppat_constant _ -> ()
    | Ppat_interval _ -> ()
    | Ppat_tuple pl -> List.iter (sub.pat sub) pl
    | Ppat_construct (l, p) ->
        iter_loc sub l; iter_opt (sub.pat sub) p
    | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p
    | Ppat_record (lpl, _cf) ->
        List.iter (iter_tuple (iter_loc sub) (sub.pat sub)) lpl
    | Ppat_array pl -> List.iter (sub.pat sub) pl
    | Ppat_or (p1, p2) -> sub.pat sub p1; sub.pat sub p2
    | Ppat_constraint (p, t) ->
        sub.pat sub p; sub.typ sub t
    | Ppat_type s -> iter_loc sub s
    | Ppat_lazy p -> sub.pat sub p
    | Ppat_unpack s -> iter_loc sub s
    | Ppat_exception p -> sub.pat sub p
    | Ppat_extension x -> sub.extension sub x
    | Ppat_open (lid, p) ->
        iter_loc sub lid; sub.pat sub p

end

module CE = struct
  (* Value expressions for the class language *)

  let iter sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} =
    sub.location sub loc;
    sub.attributes sub attrs;
    match desc with
    | Pcl_constr (lid, tys) ->
        iter_loc sub lid; List.iter (sub.typ sub) tys
    | Pcl_structure s ->
        sub.class_structure sub s
    | Pcl_fun (_lab, e, p, ce) ->
        iter_opt (sub.expr sub) e;
        sub.pat sub p;
        sub.class_expr sub ce
    | Pcl_apply (ce, l) ->
        sub.class_expr sub ce;
        List.iter (iter_snd (sub.expr sub)) l
    | Pcl_let (_r, vbs, ce) ->
        List.iter (sub.value_binding sub) vbs;
        sub.class_expr sub ce
    | Pcl_constraint (ce, ct) ->
        sub.class_expr sub ce; sub.class_type sub ct
    | Pcl_extension x -> sub.extension sub x
    | Pcl_open (_ovf, lid, e) ->
        iter_loc sub lid; sub.class_expr sub e

  let iter_kind sub = function
    | Cfk_concrete (_o, e) -> sub.expr sub e
    | Cfk_virtual t -> sub.typ sub t

  let iter_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
    sub.location sub loc;
    sub.attributes sub attrs;
    match desc with
    | Pcf_inherit (_o, ce, _s) -> sub.class_expr sub ce
    | Pcf_val (s, _m, k) -> iter_loc sub s; iter_kind sub k
    | Pcf_method (s, _p, k) ->
        iter_loc sub s; iter_kind sub k
    | Pcf_constraint (t1, t2) ->
        sub.typ sub t1; sub.typ sub t2
    | Pcf_initializer e -> sub.expr sub e
    | Pcf_attribute x -> sub.attribute sub x
    | Pcf_extension x -> sub.extension sub x

  let iter_structure sub {pcstr_self; pcstr_fields} =
    sub.pat sub pcstr_self;
    List.iter (sub.class_field sub) pcstr_fields

  let class_infos sub f {pci_virt = _; pci_params = pl; pci_name; pci_expr;
                         pci_loc; pci_attributes} =
    List.iter (iter_fst (sub.typ sub)) pl;
    iter_loc sub pci_name;
    f pci_expr;
    sub.location sub pci_loc;
    sub.attributes sub pci_attributes
end

(* Now, a generic AST mapper, to be extended to cover all kinds and
   cases of the OCaml grammar.  The default behavior of the mapper is
   the identity. *)

let default_iterator =
  {
    structure = (fun this l -> List.iter (this.structure_item this) l);
    structure_item = M.iter_structure_item;
    module_expr = M.iter;
    signature = (fun this l -> List.iter (this.signature_item this) l);
    signature_item = MT.iter_signature_item;
    module_type = MT.iter;
    with_constraint = MT.iter_with_constraint;
    class_declaration =
      (fun this -> CE.class_infos this (this.class_expr this));
    class_expr = CE.iter;
    class_field = CE.iter_field;
    class_structure = CE.iter_structure;
    class_type = CT.iter;
    class_type_field = CT.iter_field;
    class_signature = CT.iter_signature;
    class_type_declaration =
      (fun this -> CE.class_infos this (this.class_type this));
    class_description =
      (fun this -> CE.class_infos this (this.class_type this));
    type_declaration = T.iter_type_declaration;
    type_kind = T.iter_type_kind;
    typ = T.iter;
    type_extension = T.iter_type_extension;
    extension_constructor = T.iter_extension_constructor;
    value_description =
      (fun this {pval_name; pval_type; pval_prim = _; pval_loc;
                 pval_attributes} ->
        iter_loc this pval_name;
        this.typ this pval_type;
        this.attributes this pval_attributes;
        this.location this pval_loc
      );

    pat = P.iter;
    expr = E.iter;

    module_declaration =
      (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} ->
         iter_loc this pmd_name;
         this.module_type this pmd_type;
         this.attributes this pmd_attributes;
         this.location this pmd_loc
      );

    module_type_declaration =
      (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} ->
         iter_loc this pmtd_name;
         iter_opt (this.module_type this) pmtd_type;
         this.attributes this pmtd_attributes;
         this.location this pmtd_loc
      );

    module_binding =
      (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} ->
         iter_loc this pmb_name; this.module_expr this pmb_expr;
         this.attributes this pmb_attributes;
         this.location this pmb_loc
      );


    open_description =
      (fun this {popen_lid; popen_override = _; popen_attributes; popen_loc} ->
         iter_loc this popen_lid;
         this.location this popen_loc;
         this.attributes this popen_attributes
      );


    include_description =
      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
         this.module_type this pincl_mod;
         this.location this pincl_loc;
         this.attributes this pincl_attributes
      );

    include_declaration =
      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
         this.module_expr this pincl_mod;
         this.location this pincl_loc;
         this.attributes this pincl_attributes
      );


    value_binding =
      (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} ->
         this.pat this pvb_pat;
         this.expr this pvb_expr;
         this.location this pvb_loc;
         this.attributes this pvb_attributes
      );


    constructor_declaration =
      (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} ->
         iter_loc this pcd_name;
         T.iter_constructor_arguments this pcd_args;
         iter_opt (this.typ this) pcd_res;
         this.location this pcd_loc;
         this.attributes this pcd_attributes
      );

    label_declaration =
      (fun this {pld_name; pld_type; pld_loc; pld_mutable = _; pld_attributes}->
         iter_loc this pld_name;
         this.typ this pld_type;
         this.location this pld_loc;
         this.attributes this pld_attributes
      );

    cases = (fun this l -> List.iter (this.case this) l);
    case =
      (fun this {pc_lhs; pc_guard; pc_rhs} ->
         this.pat this pc_lhs;
         iter_opt (this.expr this) pc_guard;
         this.expr this pc_rhs
      );

    location = (fun _this _l -> ());

    extension = (fun this (s, e) -> iter_loc this s; this.payload this e);
    attribute = (fun this (s, e) -> iter_loc this s; this.payload this e);
    attributes = (fun this l -> List.iter (this.attribute this) l);
    payload =
      (fun this -> function
         | PStr x -> this.structure this x
         | PSig x -> this.signature this x
         | PTyp x -> this.typ this x
         | PPat (x, g) -> this.pat this x; iter_opt (this.expr this) g
      );
  }

end
module Typetexp : sig 
#1 "typetexp.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Typechecking of type expressions for the core language *)

open Types

val transl_simple_type:
        Env.t -> bool -> Parsetree.core_type -> Typedtree.core_type
val transl_simple_type_univars:
        Env.t -> Parsetree.core_type -> Typedtree.core_type
val transl_simple_type_delayed:
        Env.t -> Parsetree.core_type -> Typedtree.core_type * (unit -> unit)
        (* Translate a type, but leave type variables unbound. Returns
           the type and a function that binds the type variable. *)
val transl_type_scheme:
        Env.t -> Parsetree.core_type -> Typedtree.core_type
val reset_type_variables: unit -> unit
val type_variable: Location.t -> string -> type_expr
val transl_type_param:
  Env.t -> Parsetree.core_type -> Typedtree.core_type

type variable_context
val narrow: unit -> variable_context
val widen: variable_context -> unit

exception Already_bound

type error =
    Unbound_type_variable of string
  | Unbound_type_constructor of Longident.t
  | Unbound_type_constructor_2 of Path.t
  | Type_arity_mismatch of Longident.t * int * int
  | Bound_type_variable of string
  | Recursive_type
  | Unbound_row_variable of Longident.t
  | Type_mismatch of (type_expr * type_expr) list
  | Alias_type_mismatch of (type_expr * type_expr) list
  | Present_has_conjunction of string
  | Present_has_no_type of string
  | Constructor_mismatch of type_expr * type_expr
  | Not_a_variant of type_expr
  | Variant_tags of string * string
  | Invalid_variable_name of string
  | Cannot_quantify of string * type_expr
  | Multiple_constraints_on_type of Longident.t
  | Method_mismatch of string * type_expr * type_expr
  | Unbound_value of Longident.t
  | Unbound_constructor of Longident.t
  | Unbound_label of Longident.t
  | Unbound_module of Longident.t
  | Unbound_class of Longident.t
  | Unbound_modtype of Longident.t
  | Unbound_cltype of Longident.t
  | Ill_typed_functor_application of Longident.t
  | Illegal_reference_to_recursive_module
  | Access_functor_as_structure of Longident.t
  | Apply_structure_as_functor of Longident.t
  | Cannot_scrape_alias of Longident.t * Path.t
  | Opened_object of Path.t option
  | Not_an_object of type_expr

exception Error of Location.t * Env.t * error

val report_error: Env.t -> Format.formatter -> error -> unit

(* Support for first-class modules. *)
val transl_modtype_longident:  (* from Typemod *)
    (Location.t -> Env.t -> Longident.t -> Path.t) ref
val transl_modtype: (* from Typemod *)
    (Env.t -> Parsetree.module_type -> Typedtree.module_type) ref
val create_package_mty:
    Location.t -> Env.t -> Parsetree.package_type ->
    (Longident.t Asttypes.loc * Parsetree.core_type) list *
      Parsetree.module_type

val find_type:
    Env.t -> Location.t -> Longident.t -> Path.t * type_declaration
val find_constructor:
    Env.t -> Location.t -> Longident.t -> constructor_description
val find_all_constructors:
    Env.t -> Location.t -> Longident.t ->
    (constructor_description * (unit -> unit)) list
val find_label:
    Env.t -> Location.t -> Longident.t -> label_description
val find_all_labels:
    Env.t -> Location.t -> Longident.t ->
    (label_description * (unit -> unit)) list
val find_value:
    Env.t -> Location.t -> Longident.t -> Path.t * value_description
val find_class:
    Env.t -> Location.t -> Longident.t -> Path.t * class_declaration
val find_module:
    Env.t -> Location.t -> Longident.t -> Path.t * module_declaration
val lookup_module:
    ?load:bool -> Env.t -> Location.t -> Longident.t -> Path.t
val find_modtype:
    Env.t -> Location.t -> Longident.t -> Path.t * modtype_declaration
val find_class_type:
    Env.t -> Location.t -> Longident.t -> Path.t * class_type_declaration

val unbound_constructor_error: Env.t -> Longident.t Location.loc -> 'a
val unbound_label_error: Env.t -> Longident.t Location.loc -> 'a


val spellcheck: 
  Format.formatter ->
  (('a -> 'a list -> 'a list) ->
   Longident.t option -> 'b -> 'c list -> string list) ->
  'b -> Longident.t -> unit

end = struct
#1 "typetexp.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* typetexp.ml,v 1.34.4.9 2002/01/07 08:39:16 garrigue Exp *)

(* Typechecking of type expressions for the core language *)

open Asttypes
open Misc
open Parsetree
open Typedtree
open Types
open Ctype

exception Already_bound

type error =
    Unbound_type_variable of string
  | Unbound_type_constructor of Longident.t
  | Unbound_type_constructor_2 of Path.t
  | Type_arity_mismatch of Longident.t * int * int
  | Bound_type_variable of string
  | Recursive_type
  | Unbound_row_variable of Longident.t
  | Type_mismatch of (type_expr * type_expr) list
  | Alias_type_mismatch of (type_expr * type_expr) list
  | Present_has_conjunction of string
  | Present_has_no_type of string
  | Constructor_mismatch of type_expr * type_expr
  | Not_a_variant of type_expr
  | Variant_tags of string * string
  | Invalid_variable_name of string
  | Cannot_quantify of string * type_expr
  | Multiple_constraints_on_type of Longident.t
  | Method_mismatch of string * type_expr * type_expr
  | Unbound_value of Longident.t
  | Unbound_constructor of Longident.t
  | Unbound_label of Longident.t
  | Unbound_module of Longident.t
  | Unbound_class of Longident.t
  | Unbound_modtype of Longident.t
  | Unbound_cltype of Longident.t
  | Ill_typed_functor_application of Longident.t
  | Illegal_reference_to_recursive_module
  | Access_functor_as_structure of Longident.t
  | Apply_structure_as_functor of Longident.t
  | Cannot_scrape_alias of Longident.t * Path.t
  | Opened_object of Path.t option
  | Not_an_object of type_expr

exception Error of Location.t * Env.t * error
exception Error_forward of Location.error


type variable_context = int * (string, type_expr) Tbl.t

(* Local definitions *)

let instance_list = Ctype.instance_list Env.empty

(* Narrowing unbound identifier errors. *)

let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a =
  fun env loc lid make_error ->
  let check_module mlid =
    try ignore (Env.lookup_module ~load:true mlid env) with
    | Not_found ->
        narrow_unbound_lid_error env loc mlid (fun lid -> Unbound_module lid)
    | Env.Recmodule ->
        raise (Error (loc, env, Illegal_reference_to_recursive_module))
  in
  begin match lid with
  | Longident.Lident _ -> ()
  | Longident.Ldot (mlid, _) ->
      check_module mlid;
      let md = Env.find_module (Env.lookup_module ~load:true mlid env) env in
      begin match Env.scrape_alias env md.md_type with
      | Mty_functor _ ->
          raise (Error (loc, env, Access_functor_as_structure mlid))
      | Mty_alias(_, p) ->
          raise (Error (loc, env, Cannot_scrape_alias(mlid, p)))
      | _ -> ()
      end
  | Longident.Lapply (flid, mlid) ->
      check_module flid;
      let fmd = Env.find_module (Env.lookup_module ~load:true flid env) env in
      begin match Env.scrape_alias env fmd.md_type with
      | Mty_signature _ ->
          raise (Error (loc, env, Apply_structure_as_functor flid))
      | Mty_alias(_, p) ->
          raise (Error (loc, env, Cannot_scrape_alias(flid, p)))
      | _ -> ()
      end;
      check_module mlid;
      let mmd = Env.find_module (Env.lookup_module ~load:true mlid env) env in
      begin match Env.scrape_alias env mmd.md_type with
      | Mty_alias(_, p) ->
          raise (Error (loc, env, Cannot_scrape_alias(mlid, p)))
      | _ ->
          raise (Error (loc, env, Ill_typed_functor_application lid))
      end
  end;
  raise (Error (loc, env, make_error lid))

let find_component (lookup : ?loc:_ -> _) make_error env loc lid =
  try
    match lid with
    | Longident.Ldot (Longident.Lident "*predef*", s) ->
        lookup ~loc (Longident.Lident s) Env.initial_safe_string
    | _ ->
        lookup ~loc lid env
  with Not_found ->
    narrow_unbound_lid_error env loc lid make_error
  | Env.Recmodule ->
    raise (Error (loc, env, Illegal_reference_to_recursive_module))

let find_type env loc lid =
  let path =
    find_component Env.lookup_type (fun lid -> Unbound_type_constructor lid)
      env loc lid
  in
  let decl = Env.find_type path env in
  Builtin_attributes.check_deprecated loc decl.type_attributes (Path.name path);
  (path, decl)

let find_constructor =
  find_component Env.lookup_constructor (fun lid -> Unbound_constructor lid)
let find_all_constructors =
  find_component Env.lookup_all_constructors
    (fun lid -> Unbound_constructor lid)
let find_label =
  find_component Env.lookup_label (fun lid -> Unbound_label lid)
let find_all_labels =
  find_component Env.lookup_all_labels (fun lid -> Unbound_label lid)

let find_class env loc lid =
  let (path, decl) as r =
    find_component Env.lookup_class (fun lid -> Unbound_class lid) env loc lid
  in
  Builtin_attributes.check_deprecated loc decl.cty_attributes (Path.name path);
  r

let find_value env loc lid =
  Env.check_value_name (Longident.last lid) loc;
  let (path, decl) as r =
    find_component Env.lookup_value (fun lid -> Unbound_value lid) env loc lid
  in
  Builtin_attributes.check_deprecated loc decl.val_attributes (Path.name path);
  r

let lookup_module ?(load=false) env loc lid =
  find_component (fun ?loc lid env -> (Env.lookup_module ~load ?loc lid env))
    (fun lid -> Unbound_module lid) env loc lid

let find_module env loc lid =
  let path = lookup_module ~load:true env loc lid in
  let decl = Env.find_module path env in
  (* No need to check for deprecated here, this is done in Env. *)
  (path, decl)

let find_modtype env loc lid =
  let (path, decl) as r =
    find_component Env.lookup_modtype (fun lid -> Unbound_modtype lid)
      env loc lid
  in
  Builtin_attributes.check_deprecated loc decl.mtd_attributes (Path.name path);
  r

let find_class_type env loc lid =
  let (path, decl) as r =
    find_component Env.lookup_cltype (fun lid -> Unbound_cltype lid)
      env loc lid
  in
  Builtin_attributes.check_deprecated loc decl.clty_attributes (Path.name path);
  r

let unbound_constructor_error env lid =
  narrow_unbound_lid_error env lid.loc lid.txt
    (fun lid -> Unbound_constructor lid)

let unbound_label_error env lid =
  narrow_unbound_lid_error env lid.loc lid.txt
    (fun lid -> Unbound_label lid)

(* Support for first-class modules. *)

let transl_modtype_longident = ref (fun _ -> assert false)
let transl_modtype = ref (fun _ -> assert false)

let create_package_mty fake loc env (p, l) =
  let l =
    List.sort
      (fun (s1, _t1) (s2, _t2) ->
         if s1.txt = s2.txt then
           raise (Error (loc, env, Multiple_constraints_on_type s1.txt));
         compare s1.txt s2.txt)
      l
  in
  l,
  List.fold_left
    (fun mty (s, t) ->
      let d = {ptype_name = mkloc (Longident.last s.txt) s.loc;
               ptype_params = [];
               ptype_cstrs = [];
               ptype_kind = Ptype_abstract;
               ptype_private = Asttypes.Public;
               ptype_manifest = if fake then None else Some t;
               ptype_attributes = [];
               ptype_loc = loc} in
      Ast_helper.Mty.mk ~loc
        (Pmty_with (mty, [ Pwith_type ({ txt = s.txt; loc }, d) ]))
    )
    (Ast_helper.Mty.mk ~loc (Pmty_ident p))
    l

(* Translation of type expressions *)

let type_variables = ref (Tbl.empty : (string, type_expr) Tbl.t)
let univars        = ref ([] : (string * type_expr) list)
let pre_univars    = ref ([] : type_expr list)
let used_variables = ref (Tbl.empty : (string, type_expr * Location.t) Tbl.t)

let reset_type_variables () =
  reset_global_level ();
  Ctype.reset_reified_var_counter ();
  type_variables := Tbl.empty

let narrow () =
  (increase_global_level (), !type_variables)

let widen (gl, tv) =
  restore_global_level gl;
  type_variables := tv

let strict_ident c = (c = '_' || c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z')

let validate_name = function
    None -> None
  | Some name as s ->
      if name <> "" && strict_ident name.[0] then s else None

let new_global_var ?name () =
  new_global_var ?name:(validate_name name) ()
let newvar ?name () =
  newvar ?name:(validate_name name) ()

let type_variable loc name =
  try
    Tbl.find name !type_variables
  with Not_found ->
    raise(Error(loc, Env.empty, Unbound_type_variable ("'" ^ name)))

let transl_type_param env styp =
  let loc = styp.ptyp_loc in
  match styp.ptyp_desc with
    Ptyp_any ->
      let ty = new_global_var ~name:"_" () in
        { ctyp_desc = Ttyp_any; ctyp_type = ty; ctyp_env = env;
          ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; }
  | Ptyp_var name ->
      let ty =
        try
          if name <> "" && name.[0] = '_' then
            raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name)));
          ignore (Tbl.find name !type_variables);
          raise Already_bound
        with Not_found ->
          let v = new_global_var ~name () in
            type_variables := Tbl.add name v !type_variables;
            v
      in
        { ctyp_desc = Ttyp_var name; ctyp_type = ty; ctyp_env = env;
          ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; }
  | _ -> assert false

let transl_type_param env styp =
  (* Currently useless, since type parameters cannot hold attributes
     (but this could easily be lifted in the future). *)
  Builtin_attributes.warning_scope styp.ptyp_attributes
    (fun () -> transl_type_param env styp)


let new_pre_univar ?name () =
  let v = newvar ?name () in pre_univars := v :: !pre_univars; v

let rec swap_list = function
    x :: y :: l -> y :: x :: swap_list l
  | l -> l

type policy = Fixed | Extensible | Univars

let rec transl_type env policy styp =
  Builtin_attributes.warning_scope styp.ptyp_attributes
    (fun () -> transl_type_aux env policy styp)

and transl_type_aux env policy styp =
  let loc = styp.ptyp_loc in
  let ctyp ctyp_desc ctyp_type =
    { ctyp_desc; ctyp_type; ctyp_env = env;
      ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes }
  in
  match styp.ptyp_desc with
    Ptyp_any ->
      let ty =
        if policy = Univars then new_pre_univar () else
          if policy = Fixed then
            raise (Error (styp.ptyp_loc, env, Unbound_type_variable "_"))
          else newvar ()
      in
      ctyp Ttyp_any ty
  | Ptyp_var name ->
    let ty =
      if name <> "" && name.[0] = '_' then
        raise (Error (styp.ptyp_loc, env, Invalid_variable_name ("'" ^ name)));
      begin try
        instance env (List.assoc name !univars)
      with Not_found -> try
        instance env (fst(Tbl.find name !used_variables))
      with Not_found ->
        let v =
          if policy = Univars then new_pre_univar ~name () else newvar ~name ()
        in
        used_variables := Tbl.add name (v, styp.ptyp_loc) !used_variables;
        v
      end
    in
    ctyp (Ttyp_var name) ty
  | Ptyp_arrow(l, st1, st2) ->
    let cty1 = transl_type env policy st1 in
    let cty2 = transl_type env policy st2 in
    let ty1 = cty1.ctyp_type in
    let ty1 =
      if Btype.is_optional l
      then newty (Tconstr(Predef.path_option,[ty1], ref Mnil))
      else ty1 in
    let ty = newty (Tarrow(l, ty1, cty2.ctyp_type, Cok)) in
    ctyp (Ttyp_arrow (l, cty1, cty2)) ty
  | Ptyp_tuple stl ->
    assert (List.length stl >= 2);
    let ctys = List.map (transl_type env policy) stl in
    let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in
    ctyp (Ttyp_tuple ctys) ty
  | Ptyp_constr(lid, stl) ->
      let (path, decl) = find_type env lid.loc lid.txt in
      let stl =
        match stl with
        | [ {ptyp_desc=Ptyp_any} as t ] when decl.type_arity > 1 ->
            List.map (fun _ -> t) decl.type_params
        | _ -> stl
      in
      if List.length stl <> decl.type_arity then
        raise(Error(styp.ptyp_loc, env,
                    Type_arity_mismatch(lid.txt, decl.type_arity,
                                        List.length stl)));
      let args = List.map (transl_type env policy) stl in
      let params = instance_list decl.type_params in
      let unify_param =
        match decl.type_manifest with
          None -> unify_var
        | Some ty ->
            if (repr ty).level = Btype.generic_level then unify_var else unify
      in
      List.iter2
        (fun (sty, cty) ty' ->
           try unify_param env ty' cty.ctyp_type with Unify trace ->
             raise (Error(sty.ptyp_loc, env, Type_mismatch (swap_list trace))))
        (List.combine stl args) params;
      let constr =
        newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args) in
      begin try
        Ctype.enforce_constraints env constr
      with Unify trace ->
        raise (Error(styp.ptyp_loc, env, Type_mismatch trace))
      end;
      ctyp (Ttyp_constr (path, lid, args)) constr
  | Ptyp_object (fields, o) ->
      let ty, fields = transl_fields env policy o fields in
      ctyp (Ttyp_object (fields, o)) (newobj ty)
  | Ptyp_class(lid, stl) ->
      let (path, decl, _is_variant) =
        try
          let path = Env.lookup_type lid.txt env in
          let decl = Env.find_type path env in
          let rec check decl =
            match decl.type_manifest with
              None -> raise Not_found
            | Some ty ->
                match (repr ty).desc with
                  Tvariant row when Btype.static_row row -> ()
                | Tconstr (path, _, _) ->
                    check (Env.find_type path env)
                | _ -> raise Not_found
          in check decl;
          Location.deprecated styp.ptyp_loc
            "old syntax for polymorphic variant type";
          (path, decl,true)
        with Not_found -> try
          let lid2 =
            match lid.txt with
              Longident.Lident s     -> Longident.Lident ("#" ^ s)
            | Longident.Ldot(r, s)   -> Longident.Ldot (r, "#" ^ s)
            | Longident.Lapply(_, _) -> fatal_error "Typetexp.transl_type"
          in
          let path = Env.lookup_type lid2 env in
          let decl = Env.find_type path env in
          (path, decl, false)
        with Not_found ->
          ignore (find_class env lid.loc lid.txt); assert false
      in
      if List.length stl <> decl.type_arity then
        raise(Error(styp.ptyp_loc, env,
                    Type_arity_mismatch(lid.txt, decl.type_arity,
                                        List.length stl)));
      let args = List.map (transl_type env policy) stl in
      let params = instance_list decl.type_params in
      List.iter2
        (fun (sty, cty) ty' ->
           try unify_var env ty' cty.ctyp_type with Unify trace ->
             raise (Error(sty.ptyp_loc, env, Type_mismatch (swap_list trace))))
        (List.combine stl args) params;
        let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in
      let ty =
        try Ctype.expand_head env (newconstr path ty_args)
        with Unify trace ->
          raise (Error(styp.ptyp_loc, env, Type_mismatch trace))
      in
      let ty = match ty.desc with
        Tvariant row ->
          let row = Btype.row_repr row in
          let fields =
            List.map
              (fun (l,f) -> l,
                match Btype.row_field_repr f with
                | Rpresent (Some ty) ->
                    Reither(false, [ty], false, ref None)
                | Rpresent None ->
                    Reither (true, [], false, ref None)
                | _ -> f)
              row.row_fields
          in
          let row = { row_closed = true; row_fields = fields;
                      row_bound = (); row_name = Some (path, ty_args);
                      row_fixed = false; row_more = newvar () } in
          let static = Btype.static_row row in
          let row =
            if static then { row with row_more = newty Tnil }
            else if policy <> Univars then row
            else { row with row_more = new_pre_univar () }
          in
          newty (Tvariant row)
      | Tobject (fi, _) ->
          let _, tv = flatten_fields fi in
          if policy = Univars then pre_univars := tv :: !pre_univars;
          ty
      | _ ->
          assert false
      in
      ctyp (Ttyp_class (path, lid, args)) ty
  | Ptyp_alias(st, alias) ->
      let cty =
        try
          let t =
            try List.assoc alias !univars
            with Not_found ->
              instance env (fst(Tbl.find alias !used_variables))
          in
          let ty = transl_type env policy st in
          begin try unify_var env t ty.ctyp_type with Unify trace ->
            let trace = swap_list trace in
            raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace))
          end;
          ty
        with Not_found ->
          if !Clflags.principal then begin_def ();
          let t = newvar () in
          used_variables := Tbl.add alias (t, styp.ptyp_loc) !used_variables;
          let ty = transl_type env policy st in
          begin try unify_var env t ty.ctyp_type with Unify trace ->
            let trace = swap_list trace in
            raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace))
          end;
          if !Clflags.principal then begin
            end_def ();
            generalize_structure t;
          end;
          let t = instance env t in
          let px = Btype.proxy t in
          begin match px.desc with
          | Tvar None -> Btype.log_type px; px.desc <- Tvar (Some alias)
          | Tunivar None -> Btype.log_type px; px.desc <- Tunivar (Some alias)
          | _ -> ()
          end;
          { ty with ctyp_type = t }
      in
      ctyp (Ttyp_alias (cty, alias)) cty.ctyp_type
  | Ptyp_variant(fields, closed, present) ->
      let name = ref None in
      let mkfield l f =
        newty (Tvariant {row_fields=[l,f]; row_more=newvar();
                         row_bound=(); row_closed=true;
                         row_fixed=false; row_name=None}) in
      let hfields = Hashtbl.create 17 in
      let add_typed_field loc l f =
        let h = Btype.hash_variant l in
        try
          let (l',f') = Hashtbl.find hfields h in
          (* Check for tag conflicts *)
          if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l')));
          let ty = mkfield l f and ty' = mkfield l f' in
          if equal env false [ty] [ty'] then () else
          try unify env ty ty'
          with Unify _trace ->
            raise(Error(loc, env, Constructor_mismatch (ty,ty')))
        with Not_found ->
          Hashtbl.add hfields h (l,f)
      in
      let add_field = function
          Rtag (l, attrs, c, stl) ->
            name := None;
            let tl =
              Builtin_attributes.warning_scope attrs
                (fun () -> List.map (transl_type env policy) stl)
            in
            let f = match present with
              Some present when not (List.mem l.txt present) ->
                let ty_tl = List.map (fun cty -> cty.ctyp_type) tl in
                Reither(c, ty_tl, false, ref None)
            | _ ->
                if List.length stl > 1 || c && stl <> [] then
                  raise(Error(styp.ptyp_loc, env,
                              Present_has_conjunction l.txt));
                match tl with [] -> Rpresent None
                | st :: _ ->
                      Rpresent (Some st.ctyp_type)
            in
            add_typed_field styp.ptyp_loc l.txt f;
              Ttag (l,attrs,c,tl)
        | Rinherit sty ->
            let cty = transl_type env policy sty in
            let ty = cty.ctyp_type in
            let nm =
              match repr cty.ctyp_type with
                {desc=Tconstr(p, tl, _)} -> Some(p, tl)
              | _                        -> None
            in
            begin try
              (* Set name if there are no fields yet *)
              Hashtbl.iter (fun _ _ -> raise Exit) hfields;
              name := nm
            with Exit ->
              (* Unset it otherwise *)
              name := None
            end;
            let fl = match expand_head env cty.ctyp_type, nm with
              {desc=Tvariant row}, _ when Btype.static_row row ->
                let row = Btype.row_repr row in
                row.row_fields
            | {desc=Tvar _}, Some(p, _) ->
                raise(Error(sty.ptyp_loc, env, Unbound_type_constructor_2 p))
            | _ ->
                raise(Error(sty.ptyp_loc, env, Not_a_variant ty))
            in
            List.iter
              (fun (l, f) ->
                let f = match present with
                  Some present when not (List.mem l present) ->
                    begin match f with
                      Rpresent(Some ty) ->
                        Reither(false, [ty], false, ref None)
                    | Rpresent None ->
                        Reither(true, [], false, ref None)
                    | _ ->
                        assert false
                    end
                | _ -> f
                in
                add_typed_field sty.ptyp_loc l f)
              fl;
              Tinherit cty
      in
      let tfields = List.map add_field fields in
      let fields = Hashtbl.fold (fun _ p l -> p :: l) hfields [] in
      begin match present with None -> ()
      | Some present ->
          List.iter
            (fun l -> if not (List.mem_assoc l fields) then
              raise(Error(styp.ptyp_loc, env, Present_has_no_type l)))
            present
      end;
      let row =
        { row_fields = List.rev fields; row_more = newvar ();
          row_bound = (); row_closed = (closed = Closed);
          row_fixed = false; row_name = !name } in
      let static = Btype.static_row row in
      let row =
        if static then { row with row_more = newty Tnil }
        else if policy <> Univars then row
        else { row with row_more = new_pre_univar () }
      in
      let ty = newty (Tvariant row) in
      ctyp (Ttyp_variant (tfields, closed, present)) ty
  | Ptyp_poly(vars, st) ->
      let vars = List.map (fun v -> v.txt) vars in
      begin_def();
      let new_univars = List.map (fun name -> name, newvar ~name ()) vars in
      let old_univars = !univars in
      univars := new_univars @ !univars;
      let cty = transl_type env policy st in
      let ty = cty.ctyp_type in
      univars := old_univars;
      end_def();
      generalize ty;
      let ty_list =
        List.fold_left
          (fun tyl (name, ty1) ->
            let v = Btype.proxy ty1 in
            if deep_occur v ty then begin
              match v.desc with
                Tvar name when v.level = Btype.generic_level ->
                  v.desc <- Tunivar name;
                  v :: tyl
              | _ ->
                raise (Error (styp.ptyp_loc, env, Cannot_quantify (name, v)))
            end else tyl)
          [] new_univars
      in
      let ty' = Btype.newgenty (Tpoly(ty, List.rev ty_list)) in
      unify_var env (newvar()) ty';
      ctyp (Ttyp_poly (vars, cty)) ty'
  | Ptyp_package (p, l) ->
      let l, mty = create_package_mty true styp.ptyp_loc env (p, l) in
      let z = narrow () in
      let mty = !transl_modtype env mty in
      widen z;
      let ptys = List.map (fun (s, pty) ->
                             s, transl_type env policy pty
                          ) l in
      let path = !transl_modtype_longident styp.ptyp_loc env p.txt in
      let ty = newty (Tpackage (path,
                       List.map (fun (s, _pty) -> s.txt) l,
                       List.map (fun (_,cty) -> cty.ctyp_type) ptys))
      in
      ctyp (Ttyp_package {
            pack_path = path;
            pack_type = mty.mty_type;
            pack_fields = ptys;
            pack_txt = p;
           }) ty
  | Ptyp_extension ext ->
      raise (Error_forward (Builtin_attributes.error_of_extension ext))

and transl_poly_type env policy t =
  transl_type env policy (Ast_helper.Typ.force_poly t)

and transl_fields env policy o fields =
  let hfields = Hashtbl.create 17 in
  let add_typed_field loc l ty =
    try
      let ty' = Hashtbl.find hfields l in
      if equal env false [ty] [ty'] then () else
        try unify env ty ty'
        with Unify _trace ->
          raise(Error(loc, env, Method_mismatch (l, ty, ty')))
    with Not_found ->
      Hashtbl.add hfields l ty in
  let add_field = function
    | Otag (s, a, ty1) -> begin
        let ty1 =
          Builtin_attributes.warning_scope a
            (fun () -> transl_poly_type env policy ty1)
        in
        let field = OTtag (s, a, ty1) in
        add_typed_field ty1.ctyp_loc s.txt ty1.ctyp_type;
        field
      end
    | Oinherit sty -> begin
        let cty = transl_type env policy sty in
        let nm =
          match repr cty.ctyp_type with
            {desc=Tconstr(p, _, _)} -> Some p
          | _                        -> None in
        let t = expand_head env cty.ctyp_type in
        match t, nm with
          {desc=Tobject ({desc=(Tfield _ | Tnil) as tf}, _)}, _ -> begin
            if opened_object t then
              raise (Error (sty.ptyp_loc, env, Opened_object nm));
            let rec iter_add = function
              | Tfield (s, _k, ty1, ty2) -> begin
                  add_typed_field sty.ptyp_loc s ty1;
                  iter_add ty2.desc
                end
              | Tnil -> ()
              | _ -> assert false in
            iter_add tf;
            OTinherit cty
            end
        | {desc=Tvar _}, Some p ->
            raise (Error (sty.ptyp_loc, env, Unbound_type_constructor_2 p))
        | _ -> raise (Error (sty.ptyp_loc, env, Not_an_object t))
      end in
  let object_fields = List.map add_field fields in
  let fields = Hashtbl.fold (fun s ty l -> (s, ty) :: l) hfields [] in
  let ty_init =
     match o, policy with
     | Closed, _ -> newty Tnil
     | Open, Univars -> new_pre_univar ()
     | Open, _ -> newvar () in
  let ty = List.fold_left (fun ty (s, ty') ->
      newty (Tfield (s, Fpresent, ty', ty))) ty_init fields in
  ty, object_fields


(* Make the rows "fixed" in this type, to make universal check easier *)
let rec make_fixed_univars ty =
  let ty = repr ty in
  if ty.level >= Btype.lowest_level then begin
    Btype.mark_type_node ty;
    match ty.desc with
    | Tvariant row ->
        let row = Btype.row_repr row in
        if Btype.is_Tunivar (Btype.row_more row) then
          ty.desc <- Tvariant
              {row with row_fixed=true;
               row_fields = List.map
                 (fun (s,f as p) -> match Btype.row_field_repr f with
                   Reither (c, tl, _m, r) -> s, Reither (c, tl, true, r)
                 | _ -> p)
                 row.row_fields};
        Btype.iter_row make_fixed_univars row
    | _ ->
        Btype.iter_type_expr make_fixed_univars ty
  end

let make_fixed_univars ty =
  make_fixed_univars ty;
  Btype.unmark_type ty

let create_package_mty = create_package_mty false

let globalize_used_variables env fixed =
  let r = ref [] in
  Tbl.iter
    (fun name (ty, loc) ->
      let v = new_global_var () in
      let snap = Btype.snapshot () in
      if try unify env v ty; true with _ -> Btype.backtrack snap; false
      then try
        r := (loc, v,  Tbl.find name !type_variables) :: !r
      with Not_found ->
        if fixed && Btype.is_Tvar (repr ty) then
          raise(Error(loc, env, Unbound_type_variable ("'"^name)));
        let v2 = new_global_var () in
        r := (loc, v, v2) :: !r;
        type_variables := Tbl.add name v2 !type_variables)
    !used_variables;
  used_variables := Tbl.empty;
  fun () ->
    List.iter
      (function (loc, t1, t2) ->
        try unify env t1 t2 with Unify trace ->
          raise (Error(loc, env, Type_mismatch trace)))
      !r

let transl_simple_type env fixed styp =
  univars := []; used_variables := Tbl.empty;
  let typ = transl_type env (if fixed then Fixed else Extensible) styp in
  globalize_used_variables env fixed ();
  make_fixed_univars typ.ctyp_type;
  typ

let transl_simple_type_univars env styp =
  univars := []; used_variables := Tbl.empty; pre_univars := [];
  begin_def ();
  let typ = transl_type env Univars styp in
  (* Only keep already global variables in used_variables *)
  let new_variables = !used_variables in
  used_variables := Tbl.empty;
  Tbl.iter
    (fun name p ->
      if Tbl.mem name !type_variables then
        used_variables := Tbl.add name p !used_variables)
    new_variables;
  globalize_used_variables env false ();
  end_def ();
  generalize typ.ctyp_type;
  let univs =
    List.fold_left
      (fun acc v ->
        let v = repr v in
        match v.desc with
          Tvar name when v.level = Btype.generic_level ->
            v.desc <- Tunivar name; v :: acc
        | _ -> acc)
      [] !pre_univars
  in
  make_fixed_univars typ.ctyp_type;
    { typ with ctyp_type =
        instance env (Btype.newgenty (Tpoly (typ.ctyp_type, univs))) }

let transl_simple_type_delayed env styp =
  univars := []; used_variables := Tbl.empty;
  let typ = transl_type env Extensible styp in
  make_fixed_univars typ.ctyp_type;
  (typ, globalize_used_variables env false)

let transl_type_scheme env styp =
  reset_type_variables();
  begin_def();
  let typ = transl_simple_type env false styp in
  end_def();
  generalize typ.ctyp_type;
  typ


(* Error report *)

open Format
open Printtyp

let spellcheck ppf fold env lid =
  let choices ~path name =
    let env = fold (fun x xs -> x::xs) path env [] in
    Misc.spellcheck env name in
  match lid with
    | Longident.Lapply _ -> ()
    | Longident.Lident s ->
       Misc.did_you_mean ppf (fun () -> choices ~path:None s)
    | Longident.Ldot (r, s) ->
       Misc.did_you_mean ppf (fun () -> choices ~path:(Some r) s)

let fold_descr fold get_name f = fold (fun descr acc -> f (get_name descr) acc)
let fold_simple fold4 f = fold4 (fun name _path _descr acc -> f name acc)

let fold_values = fold_simple Env.fold_values
let fold_types = fold_simple Env.fold_types
let fold_modules = fold_simple Env.fold_modules
let fold_constructors = fold_descr Env.fold_constructors (fun d -> d.cstr_name)
let fold_labels = fold_descr Env.fold_labels (fun d -> d.lbl_name)
let fold_classs = fold_simple Env.fold_classs
let fold_modtypes = fold_simple Env.fold_modtypes
let fold_cltypes = fold_simple Env.fold_cltypes

let report_error env ppf = function
  | Unbound_type_variable name ->
     (* we don't use "spellcheck" here: the function that raises this
        error seems not to be called anywhere, so it's unclear how it
        should be handled *)
    fprintf ppf "Unbound type parameter %s@." name
  | Unbound_type_constructor lid ->
    fprintf ppf "Unbound type constructor %a" longident lid;
    spellcheck ppf fold_types env lid;
  | Unbound_type_constructor_2 p ->
    fprintf ppf "The type constructor@ %a@ is not yet completely defined"
      path p
  | Type_arity_mismatch(lid, expected, provided) ->
    fprintf ppf
      "@[The type constructor %a@ expects %i argument(s),@ \
        but is here applied to %i argument(s)@]"
      longident lid expected provided
  | Bound_type_variable name ->
    fprintf ppf "Already bound type parameter '%s" name
  | Recursive_type ->
    fprintf ppf "This type is recursive"
  | Unbound_row_variable lid ->
      (* we don't use "spellcheck" here: this error is not raised
         anywhere so it's unclear how it should be handled *)
      fprintf ppf "Unbound row variable in #%a" longident lid
  | Type_mismatch trace ->
      Printtyp.report_unification_error ppf Env.empty trace
        (function ppf ->
           fprintf ppf "This type")
        (function ppf ->
           fprintf ppf "should be an instance of type")
  | Alias_type_mismatch trace ->
      Printtyp.report_unification_error ppf Env.empty trace
        (function ppf ->
           fprintf ppf "This alias is bound to type")
        (function ppf ->
           fprintf ppf "but is used as an instance of type")
  | Present_has_conjunction l ->
      fprintf ppf "The present constructor %s has a conjunctive type" l
  | Present_has_no_type l ->
      fprintf ppf "The present constructor %s has no type" l
  | Constructor_mismatch (ty, ty') ->
      wrap_printing_env env (fun ()  ->
        Printtyp.reset_and_mark_loops_list [ty; ty'];
        fprintf ppf "@[<hov>%s %a@ %s@ %a@]"
          "This variant type contains a constructor"
          Printtyp.type_expr ty
          "which should be"
          Printtyp.type_expr ty')
  | Not_a_variant ty ->
      Printtyp.reset_and_mark_loops ty;
      fprintf ppf
        "@[The type %a@ does not expand to a polymorphic variant type@]"
        Printtyp.type_expr ty;
      begin match ty.desc with
        | Tvar (Some s) ->
           (* PR#7012: help the user that wrote 'Foo instead of `Foo *)
           Misc.did_you_mean ppf (fun () -> ["`" ^ s])
        | _ -> ()
      end
  | Variant_tags (lab1, lab2) ->
      fprintf ppf
        "@[Variant tags `%s@ and `%s have the same hash value.@ %s@]"
        lab1 lab2 "Change one of them."
  | Invalid_variable_name name ->
      fprintf ppf "The type variable name %s is not allowed in programs" name
  | Cannot_quantify (name, v) ->
      fprintf ppf
        "@[<hov>The universal type variable '%s cannot be generalized:@ %s.@]"
        name
        (if Btype.is_Tvar v then "it escapes its scope" else
         if Btype.is_Tunivar v then "it is already bound to another variable"
         else "it is not a variable")
  | Multiple_constraints_on_type s ->
      fprintf ppf "Multiple constraints for type %a" longident s
  | Method_mismatch (l, ty, ty') ->
      wrap_printing_env env (fun ()  ->
        Printtyp.reset_and_mark_loops_list [ty; ty'];
        fprintf ppf "@[<hov>Method '%s' has type %a,@ which should be %a@]"
          l Printtyp.type_expr ty Printtyp.type_expr ty')
  | Unbound_value lid ->
      fprintf ppf "Unbound value %a" longident lid;
      spellcheck ppf fold_values env lid;
  | Unbound_module lid ->
      fprintf ppf "Unbound module %a" longident lid;
      spellcheck ppf fold_modules env lid;
  | Unbound_constructor lid ->
      fprintf ppf "Unbound constructor %a" longident lid;
      spellcheck ppf fold_constructors env lid;
  | Unbound_label lid ->
      fprintf ppf "Unbound record field %a" longident lid;
      spellcheck ppf fold_labels env lid;
  | Unbound_class lid ->
      fprintf ppf "Unbound class %a" longident lid;
      spellcheck ppf fold_classs env lid;
  | Unbound_modtype lid ->
      fprintf ppf "Unbound module type %a" longident lid;
      spellcheck ppf fold_modtypes env lid;
  | Unbound_cltype lid ->
      fprintf ppf "Unbound class type %a" longident lid;
      spellcheck ppf fold_cltypes env lid;
  | Ill_typed_functor_application lid ->
      fprintf ppf "Ill-typed functor application %a" longident lid
  | Illegal_reference_to_recursive_module ->
      fprintf ppf "Illegal recursive module reference"
  | Access_functor_as_structure lid ->
      fprintf ppf "The module %a is a functor, not a structure" longident lid
  | Apply_structure_as_functor lid ->
      fprintf ppf "The module %a is a structure, not a functor" longident lid
  | Cannot_scrape_alias(lid, p) ->
      fprintf ppf
        "The module %a is an alias for module %a, which is missing"
        longident lid path p
  | Opened_object nm ->
      fprintf ppf
        "Illegal open object type%a"
        (fun ppf -> function
             Some p -> fprintf ppf "@ %a" path p
           | None -> fprintf ppf "") nm
  | Not_an_object ty ->
      Printtyp.reset_and_mark_loops ty;
      fprintf ppf "@[The type %a@ is not an object type@]"
        Printtyp.type_expr ty

let () =
  Location.register_error_of_exn
    (function
      | Error (loc, env, err) ->
        Some (Location.error_of_printer loc (report_error env) err)
      | Error_forward err ->
        Some err
      | _ ->
        None
    )

end
module Typedecl : sig 
#1 "typedecl.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Typing of type definitions and primitive definitions *)

open Types
open Format

val transl_type_decl:
    Env.t -> Asttypes.rec_flag -> Parsetree.type_declaration list ->
    Typedtree.type_declaration list * Env.t

val transl_exception:
    Env.t ->
    Parsetree.extension_constructor -> Typedtree.extension_constructor * Env.t

val transl_type_extension:
    bool -> Env.t -> Location.t -> Parsetree.type_extension ->
    Typedtree.type_extension * Env.t

val transl_value_decl:
    Env.t -> Location.t ->
    Parsetree.value_description -> Typedtree.value_description * Env.t

val transl_with_constraint:
    Env.t -> Ident.t -> Path.t option -> Types.type_declaration ->
    Parsetree.type_declaration -> Typedtree.type_declaration

val abstract_type_decl: int -> type_declaration
val approx_type_decl:
    Parsetree.type_declaration list ->
                                  (Ident.t * type_declaration) list
val check_recmod_typedecl:
    Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit
val check_coherence:
    Env.t -> Location.t -> Ident.t -> type_declaration -> unit

(* for fixed types *)
val is_fixed_type : Parsetree.type_declaration -> bool

(* for typeclass.ml *)
val compute_variance_decls:
    Env.t ->
    (Ident.t * Types.type_declaration * Types.type_declaration *
     Types.class_declaration * Types.class_type_declaration *
     'a Typedtree.class_infos) list ->
    (Types.type_declaration * Types.type_declaration *
     Types.class_declaration * Types.class_type_declaration) list

(* for typeopt.ml *)
val get_unboxed_type_representation: Env.t -> type_expr -> type_expr option


type native_repr_kind = Unboxed | Untagged

type error =
    Repeated_parameter
  | Duplicate_constructor of string
  | Too_many_constructors
  | Duplicate_label of string
  | Recursive_abbrev of string
  | Cycle_in_def of string * type_expr
  | Definition_mismatch of type_expr * Includecore.type_mismatch list
  | Constraint_failed of type_expr * type_expr
  | Inconsistent_constraint of Env.t * (type_expr * type_expr) list
  | Type_clash of Env.t * (type_expr * type_expr) list
  | Parameters_differ of Path.t * type_expr * type_expr
  | Null_arity_external
  | Missing_native_external
  | Unbound_type_var of type_expr * type_declaration
  | Cannot_extend_private_type of Path.t
  | Not_extensible_type of Path.t
  | Extension_mismatch of Path.t * Includecore.type_mismatch list
  | Rebind_wrong_type of Longident.t * Env.t * (type_expr * type_expr) list
  | Rebind_mismatch of Longident.t * Path.t * Path.t
  | Rebind_private of Longident.t
  | Bad_variance of int * (bool*bool*bool) * (bool*bool*bool)
  | Unavailable_type_constructor of Path.t
  | Bad_fixed_type of string
  | Unbound_type_var_ext of type_expr * extension_constructor
  | Varying_anonymous
  | Val_in_structure
  | Multiple_native_repr_attributes
  | Cannot_unbox_or_untag_type of native_repr_kind
  | Deep_unbox_or_untag_attribute of native_repr_kind
  | Bad_immediate_attribute
  | Bad_unboxed_attribute of string
  | Wrong_unboxed_type_float
  | Boxed_and_unboxed
  | Nonrec_gadt

exception Error of Location.t * error

val report_error: formatter -> error -> unit

end = struct
#1 "typedecl.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(**** Typing of type definitions ****)

open Misc
open Asttypes
open Parsetree
open Primitive
open Types
open Typetexp

type native_repr_kind = Unboxed | Untagged

type error =
    Repeated_parameter
  | Duplicate_constructor of string
  | Too_many_constructors
  | Duplicate_label of string
  | Recursive_abbrev of string
  | Cycle_in_def of string * type_expr
  | Definition_mismatch of type_expr * Includecore.type_mismatch list
  | Constraint_failed of type_expr * type_expr
  | Inconsistent_constraint of Env.t * (type_expr * type_expr) list
  | Type_clash of Env.t * (type_expr * type_expr) list
  | Parameters_differ of Path.t * type_expr * type_expr
  | Null_arity_external
  | Missing_native_external
  | Unbound_type_var of type_expr * type_declaration
  | Cannot_extend_private_type of Path.t
  | Not_extensible_type of Path.t
  | Extension_mismatch of Path.t * Includecore.type_mismatch list
  | Rebind_wrong_type of Longident.t * Env.t * (type_expr * type_expr) list
  | Rebind_mismatch of Longident.t * Path.t * Path.t
  | Rebind_private of Longident.t
  | Bad_variance of int * (bool * bool * bool) * (bool * bool * bool)
  | Unavailable_type_constructor of Path.t
  | Bad_fixed_type of string
  | Unbound_type_var_ext of type_expr * extension_constructor
  | Varying_anonymous
  | Val_in_structure
  | Multiple_native_repr_attributes
  | Cannot_unbox_or_untag_type of native_repr_kind
  | Deep_unbox_or_untag_attribute of native_repr_kind
  | Bad_immediate_attribute
  | Bad_unboxed_attribute of string
  | Wrong_unboxed_type_float
  | Boxed_and_unboxed
  | Nonrec_gadt

open Typedtree

exception Error of Location.t * error

(* Note: do not factor the branches in the following pattern-matching:
   the records must be constants for the compiler to do sharing on them.
*)
let get_unboxed_from_attributes sdecl =
   
  if !Clflags.bs_only then unboxed_false_default_false
  else

  let unboxed = Builtin_attributes.has_unboxed sdecl.ptype_attributes in
  let boxed = Builtin_attributes.has_boxed sdecl.ptype_attributes in
  match boxed, unboxed, !Clflags.unboxed_types with
  | true, true, _ -> raise (Error(sdecl.ptype_loc, Boxed_and_unboxed))
  | true, false, _ -> unboxed_false_default_false
  | false, true, _ -> unboxed_true_default_false
  | false, false, false -> unboxed_false_default_true
  | false, false, true -> unboxed_true_default_true

(* Enter all declared types in the environment as abstract types *)

let enter_type rec_flag env sdecl id =
  let needed =
    match rec_flag with
    | Asttypes.Nonrecursive ->
        begin match sdecl.ptype_kind with
        | Ptype_variant scds ->
            List.iter (fun cd ->
              if cd.pcd_res <> None then raise (Error(cd.pcd_loc, Nonrec_gadt)))
              scds
        | _ -> ()
        end;
        Btype.is_row_name (Ident.name id)
    | Asttypes.Recursive -> true
  in
  if not needed then env else
  let decl =
    { type_params =
        List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params;
      type_arity = List.length sdecl.ptype_params;
      type_kind = Type_abstract;
      type_private = sdecl.ptype_private;
      type_manifest =
        begin match sdecl.ptype_manifest with None -> None
        | Some _ -> Some(Ctype.newvar ()) end;
      type_variance = List.map (fun _ -> Variance.full) sdecl.ptype_params;
      type_newtype_level = None;
      type_loc = sdecl.ptype_loc;
      type_attributes = sdecl.ptype_attributes;
      type_immediate = false;
      type_unboxed = unboxed_false_default_false;
    }
  in
  Env.add_type ~check:true id decl env

let update_type temp_env env id loc =
  let path = Path.Pident id in
  let decl = Env.find_type path temp_env in
  match decl.type_manifest with None -> ()
  | Some ty ->
      let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in
      try Ctype.unify env (Ctype.newconstr path params) ty
      with Ctype.Unify trace ->
        raise (Error(loc, Type_clash (env, trace)))

(* We use the Ctype.expand_head_opt version of expand_head to get access
   to the manifest type of private abbreviations. *)
let rec get_unboxed_type_representation env ty fuel =
  if fuel < 0 then None else
  let ty = Ctype.repr (Ctype.expand_head_opt env ty) in
  match ty.desc with
  | Tconstr (p, args, _) ->
    begin match Env.find_type p env with
    | exception Not_found -> Some ty
    | {type_unboxed = {unboxed = false}} -> Some ty
    | {type_params; type_kind =
         Type_record ([{ld_type = ty2; _}], _)
       | Type_variant [{cd_args = Cstr_tuple [ty2]; _}]
       | Type_variant [{cd_args = Cstr_record [{ld_type = ty2; _}]; _}]}

         -> get_unboxed_type_representation env
             (Ctype.apply env type_params ty2 args) (fuel - 1)
    | {type_kind=Type_abstract} -> None
          (* This case can occur when checking a recursive unboxed type
             declaration. *)
    | _ -> assert false (* only the above can be unboxed *)
    end
  | _ -> Some ty

let get_unboxed_type_representation env ty =
  (* Do not give too much fuel: PR#7424 *)
  get_unboxed_type_representation env ty 100
;;

(* Determine if a type's values are represented by floats at run-time. *)
let is_float env ty =
  match get_unboxed_type_representation env ty with
    Some {desc = Tconstr(p, _, _); _} -> Path.same p Predef.path_float
  | _ -> false

(* Determine if a type definition defines a fixed type. (PW) *)
let is_fixed_type sd =
  let rec has_row_var sty =
    match sty.ptyp_desc with
      Ptyp_alias (sty, _) -> has_row_var sty
    | Ptyp_class _
    | Ptyp_object (_, Open)
    | Ptyp_variant (_, Open, _)
    | Ptyp_variant (_, Closed, Some _) -> true
    | _ -> false
  in
  match sd.ptype_manifest with
    None -> false
  | Some sty ->
      sd.ptype_kind = Ptype_abstract &&
      sd.ptype_private = Private &&
      has_row_var sty

(* Set the row variable in a fixed type *)
let set_fixed_row env loc p decl =
  let tm =
    match decl.type_manifest with
      None -> assert false
    | Some t -> Ctype.expand_head env t
  in
  let rv =
    match tm.desc with
      Tvariant row ->
        let row = Btype.row_repr row in
        tm.desc <- Tvariant {row with row_fixed = true};
        if Btype.static_row row then Btype.newgenty Tnil
        else row.row_more
    | Tobject (ty, _) ->
        snd (Ctype.flatten_fields ty)
    | _ ->
        raise (Error (loc, Bad_fixed_type "is not an object or variant"))
  in
  if not (Btype.is_Tvar rv) then
    raise (Error (loc, Bad_fixed_type "has no row variable"));
  rv.desc <- Tconstr (p, decl.type_params, ref Mnil)

(* Translate one type declaration *)

module StringSet =
  Set.Make(struct
    type t = string
    let compare (x:t) y = compare x y
  end)

let make_params env params =
  let make_param (sty, v) =
    try
      (transl_type_param env sty, v)
    with Already_bound ->
      raise(Error(sty.ptyp_loc, Repeated_parameter))
  in
    List.map make_param params

let transl_labels env closed lbls =
  assert (lbls <> []);
  let all_labels = ref StringSet.empty in
  List.iter
    (fun {pld_name = {txt=name; loc}} ->
       if StringSet.mem name !all_labels then
         raise(Error(loc, Duplicate_label name));
       all_labels := StringSet.add name !all_labels)
    lbls;
  let mk {pld_name=name;pld_mutable=mut;pld_type=arg;pld_loc=loc;
          pld_attributes=attrs} =
    Builtin_attributes.warning_scope attrs
      (fun () ->
         let arg = Ast_helper.Typ.force_poly arg in
         let cty = transl_simple_type env closed arg in
         {ld_id = Ident.create name.txt; ld_name = name; ld_mutable = mut;
          ld_type = cty; ld_loc = loc; ld_attributes = attrs}
      )
  in
  let lbls = List.map mk lbls in
  let lbls' =
    List.map
      (fun ld ->
         let ty = ld.ld_type.ctyp_type in
         let ty = match ty.desc with Tpoly(t,[]) -> t | _ -> ty in
         {Types.ld_id = ld.ld_id;
          ld_mutable = ld.ld_mutable;
          ld_type = ty;
          ld_loc = ld.ld_loc;
          ld_attributes = ld.ld_attributes
         }
      )
      lbls in
  lbls, lbls'

let transl_constructor_arguments env closed = function
  | Pcstr_tuple l ->
      let l = List.map (transl_simple_type env closed) l in
      Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l),
      Cstr_tuple l
  | Pcstr_record l ->
      let lbls, lbls' = transl_labels env closed l in
      Types.Cstr_record lbls',
      Cstr_record lbls

let make_constructor env type_path type_params sargs sret_type =
  match sret_type with
  | None ->
      let args, targs =
        transl_constructor_arguments env true sargs
      in
        targs, None, args, None, type_params
  | Some sret_type ->
      (* if it's a generalized constructor we must first narrow and
         then widen so as to not introduce any new constraints *)
      let z = narrow () in
      reset_type_variables ();
      let args, targs =
        transl_constructor_arguments env false sargs
      in
      let tret_type = transl_simple_type env false sret_type in
      let ret_type = tret_type.ctyp_type in
      let params =
        match (Ctype.repr ret_type).desc with
        | Tconstr (p', params, _) when Path.same type_path p' ->
            params
        | _ ->
            raise (Error (sret_type.ptyp_loc, Constraint_failed
                            (ret_type, Ctype.newconstr type_path type_params)))
      in
      widen z;
      targs, Some tret_type, args, Some ret_type, params

(* Check that the variable [id] is present in the [univ] list. *)
let check_type_var loc univ id =
  let f t = (Btype.repr t).id = id in
  if not (List.exists f univ) then raise (Error (loc, Wrong_unboxed_type_float))

(* Check that all the variables found in [ty] are in [univ].
   Because [ty] is the argument to an abstract type, the representation
   of that abstract type could be any subexpression of [ty], in particular
   any type variable present in [ty].
*)
let rec check_unboxed_abstract_arg loc univ ty =
  match ty.desc with
  | Tvar _ -> check_type_var loc univ ty.id
  | Tarrow (_, t1, t2, _)
  | Tfield (_, _, t1, t2) ->
    check_unboxed_abstract_arg loc univ t1;
    check_unboxed_abstract_arg loc univ t2
  | Ttuple args
  | Tconstr (_, args, _)
  | Tpackage (_, _, args) ->
    List.iter (check_unboxed_abstract_arg loc univ) args
  | Tobject (fields, r) ->
    check_unboxed_abstract_arg loc univ fields;
    begin match !r with
    | None -> ()
    | Some (_, args) -> List.iter (check_unboxed_abstract_arg loc univ) args
    end
  | Tnil
  | Tunivar _ -> ()
  | Tlink e -> check_unboxed_abstract_arg loc univ e
  | Tsubst _ -> assert false
  | Tvariant { row_fields; row_more; row_name } ->
    List.iter (check_unboxed_abstract_row_field loc univ) row_fields;
    check_unboxed_abstract_arg loc univ row_more;
    begin match row_name with
    | None -> ()
    | Some (_, args) -> List.iter (check_unboxed_abstract_arg loc univ) args
    end
  | Tpoly (t, _) -> check_unboxed_abstract_arg loc univ t

and check_unboxed_abstract_row_field loc univ (_, field) =
  match field with
  | Rpresent (Some ty) -> check_unboxed_abstract_arg loc univ ty
  | Reither (_, args, _, r) ->
    List.iter (check_unboxed_abstract_arg loc univ) args;
    begin match !r with
    | None -> ()
    | Some f -> check_unboxed_abstract_row_field loc univ ("", f)
    end
  | Rabsent
  | Rpresent None -> ()

(* Check that the argument to a GADT constructor is compatible with unboxing
   the type, given the universal parameters of the type. *)
let rec check_unboxed_gadt_arg loc univ env ty =
  match get_unboxed_type_representation env ty with
  | Some {desc = Tvar _; id} -> check_type_var loc univ id
  | Some {desc = Tarrow _ | Ttuple _ | Tpackage _ | Tobject _ | Tnil
                 | Tvariant _; _} ->
    ()
    (* A comment in [Translcore.transl_exp0] claims the above cannot be
       represented by floats. *)
  | Some {desc = Tconstr (p, args, _); _} ->
    let tydecl = Env.find_type p env in
    assert (not tydecl.type_unboxed.unboxed);
    if tydecl.type_kind = Type_abstract then
      List.iter (check_unboxed_abstract_arg loc univ) args
  | Some {desc = Tfield _ | Tlink _ | Tsubst _; _} -> assert false
  | Some {desc = Tunivar _; _} -> ()
  | Some {desc = Tpoly (t2, _); _} -> check_unboxed_gadt_arg loc univ env t2
  | None -> ()
      (* This case is tricky: the argument is another (or the same) type
         in the same recursive definition. In this case we don't have to
         check because we will also check that other type for correctness. *)

let transl_declaration env sdecl id =
  (* Bind type parameters *)
  reset_type_variables();
  Ctype.begin_def ();
  let tparams = make_params env sdecl.ptype_params in
  let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in
  let cstrs = List.map
    (fun (sty, sty', loc) ->
      transl_simple_type env false sty,
      transl_simple_type env false sty', loc)
    sdecl.ptype_cstrs
  in
  let raw_status = get_unboxed_from_attributes sdecl in
  if raw_status.unboxed && not raw_status.default then begin
    match sdecl.ptype_kind with
    | Ptype_abstract ->
        raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
                      "it is abstract"))
    | Ptype_variant [{pcd_args = Pcstr_tuple []; _}] ->
      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
                    "its constructor has no argument"))
    | Ptype_variant [{pcd_args = Pcstr_tuple [_]; _}] -> ()
    | Ptype_variant [{pcd_args = Pcstr_tuple _; _}] ->
      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
                    "its constructor has more than one argument"))
    | Ptype_variant [{pcd_args = Pcstr_record
                        [{pld_mutable=Immutable; _}]; _}] -> ()
    | Ptype_variant [{pcd_args = Pcstr_record [{pld_mutable=Mutable; _}]; _}] ->
      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute "it is mutable"))
    | Ptype_variant [{pcd_args = Pcstr_record _; _}] ->
      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
                    "its constructor has more than one argument"))
    | Ptype_variant _ ->
      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
                    "it has more than one constructor"))
    | Ptype_record [{pld_mutable=Immutable; _}] -> ()
    | Ptype_record [{pld_mutable=Mutable; _}] ->
      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
                    "it is mutable"))
    | Ptype_record _ ->
      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
                    "it has more than one field"))
    | Ptype_open ->
      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
                    "extensible variant types cannot be unboxed"))
  end;
  let unboxed_status =
    match sdecl.ptype_kind with
    | Ptype_variant [{pcd_args = Pcstr_tuple [_]; _}]
      | Ptype_variant [{pcd_args = Pcstr_record
                          [{pld_mutable = Immutable; _}]; _}]
      | Ptype_record [{pld_mutable = Immutable; _}] ->
    raw_status
    | _ -> (* The type is not unboxable, mark it as boxed *)
      unboxed_false_default_false
  in
  let unbox = unboxed_status.unboxed in
  let (tkind, kind) =
    match sdecl.ptype_kind with
      | Ptype_abstract -> Ttype_abstract, Type_abstract
      | Ptype_variant scstrs ->
        assert (scstrs <> []);
        if List.exists (fun cstr -> cstr.pcd_res <> None) scstrs then begin
          match cstrs with
            [] -> ()
          | (_,_,loc)::_ ->
              Location.prerr_warning loc Warnings.Constraint_on_gadt
        end;
        let all_constrs = ref StringSet.empty in
        List.iter
          (fun {pcd_name = {txt = name}} ->
            if StringSet.mem name !all_constrs then
              raise(Error(sdecl.ptype_loc, Duplicate_constructor name));
            all_constrs := StringSet.add name !all_constrs)
          scstrs;
        if List.length
            (List.filter (fun cd -> cd.pcd_args <> Pcstr_tuple []) scstrs)
           > (Config.max_tag + 1) then
          raise(Error(sdecl.ptype_loc, Too_many_constructors));
        let make_cstr scstr =
          let name = Ident.create scstr.pcd_name.txt in
          let targs, tret_type, args, ret_type, cstr_params =
            make_constructor env (Path.Pident id) params
                             scstr.pcd_args scstr.pcd_res
          in
          if Config.flat_float_array && unbox then begin
            (* Cannot unbox a type when the argument can be both float and
               non-float because it interferes with the dynamic float array
               optimization. This can only happen when the type is a GADT
               and the argument is an existential type variable or an
               unboxed (or abstract) type constructor applied to some
               existential type variable. Of course we also have to rule
               out any abstract type constructor applied to anything that
               might be an existential type variable.
               There is a difficulty with existential variables created
               out of thin air (rather than bound by the declaration).
               See PR#7511 and GPR#1133 for details. *)
            match Datarepr.constructor_existentials args ret_type with
            | _, [] -> ()
            | [argty], _ex ->
                check_unboxed_gadt_arg sdecl.ptype_loc cstr_params env argty
            | _ -> assert false
          end;
          let tcstr =
            { cd_id = name;
              cd_name = scstr.pcd_name;
              cd_args = targs;
              cd_res = tret_type;
              cd_loc = scstr.pcd_loc;
              cd_attributes = scstr.pcd_attributes }
          in
          let cstr =
            { Types.cd_id = name;
              cd_args = args;
              cd_res = ret_type;
              cd_loc = scstr.pcd_loc;
              cd_attributes = scstr.pcd_attributes }
          in
            tcstr, cstr
        in
        let make_cstr scstr =
          Builtin_attributes.warning_scope scstr.pcd_attributes
            (fun () -> make_cstr scstr)
        in
        let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in
          Ttype_variant tcstrs, Type_variant cstrs
      | Ptype_record lbls ->
          let lbls, lbls' = transl_labels env true lbls in
          let rep =
            if unbox then Record_unboxed false
            else if List.for_all (fun l -> is_float env l.Types.ld_type) lbls'
            then Record_float
            else Record_regular
          in
          Ttype_record lbls, Type_record(lbls', rep)
      | Ptype_open -> Ttype_open, Type_open
      in
    let (tman, man) = match sdecl.ptype_manifest with
        None -> None, None
      | Some sty ->
        let no_row = not (is_fixed_type sdecl) in
        let cty = transl_simple_type env no_row sty in
        Some cty, Some cty.ctyp_type
    in
    let decl =
      { type_params = params;
        type_arity = List.length params;
        type_kind = kind;
        type_private = sdecl.ptype_private;
        type_manifest = man;
        type_variance = List.map (fun _ -> Variance.full) params;
        type_newtype_level = None;
        type_loc = sdecl.ptype_loc;
        type_attributes = sdecl.ptype_attributes;
        type_immediate = false;
        type_unboxed = unboxed_status;
      } in

  (* Check constraints *)
    List.iter
      (fun (cty, cty', loc) ->
        let ty = cty.ctyp_type in
        let ty' = cty'.ctyp_type in
        try Ctype.unify env ty ty' with Ctype.Unify tr ->
          raise(Error(loc, Inconsistent_constraint (env, tr))))
      cstrs;
    Ctype.end_def ();
  (* Add abstract row *)
    if is_fixed_type sdecl then begin
      let p =
        try Env.lookup_type (Longident.Lident(Ident.name id ^ "#row")) env
        with Not_found -> assert false in
      set_fixed_row env sdecl.ptype_loc p decl
    end;
  (* Check for cyclic abbreviations *)
    begin match decl.type_manifest with None -> ()
      | Some ty ->
        if Ctype.cyclic_abbrev env id ty then
          raise(Error(sdecl.ptype_loc, Recursive_abbrev sdecl.ptype_name.txt));
    end;
    {
      typ_id = id;
      typ_name = sdecl.ptype_name;
      typ_params = tparams;
      typ_type = decl;
      typ_cstrs = cstrs;
      typ_loc = sdecl.ptype_loc;
      typ_manifest = tman;
      typ_kind = tkind;
      typ_private = sdecl.ptype_private;
      typ_attributes = sdecl.ptype_attributes;
    }

(* Generalize a type declaration *)

let generalize_decl decl =
  List.iter Ctype.generalize decl.type_params;
  Btype.iter_type_expr_kind Ctype.generalize decl.type_kind;
  begin match decl.type_manifest with
  | None    -> ()
  | Some ty -> Ctype.generalize ty
  end

(* Check that all constraints are enforced *)

module TypeSet = Btype.TypeSet
module TypeMap = Btype.TypeMap

let rec check_constraints_rec env loc visited ty =
  let ty = Ctype.repr ty in
  if TypeSet.mem ty !visited then () else begin
  visited := TypeSet.add ty !visited;
  match ty.desc with
  | Tconstr (path, args, _) ->
      let args' = List.map (fun _ -> Ctype.newvar ()) args in
      let ty' = Ctype.newconstr path args' in
      begin try Ctype.enforce_constraints env ty'
      with Ctype.Unify _ -> assert false
      | Not_found -> raise (Error(loc, Unavailable_type_constructor path))
      end;
      if not (Ctype.matches env ty ty') then
        raise (Error(loc, Constraint_failed (ty, ty')));
      List.iter (check_constraints_rec env loc visited) args
  | Tpoly (ty, tl) ->
      let _, ty = Ctype.instance_poly false tl ty in
      check_constraints_rec env loc visited ty
  | _ ->
      Btype.iter_type_expr (check_constraints_rec env loc visited) ty
  end

module SMap = Map.Make(String)

let check_constraints_labels env visited l pl =
  let rec get_loc name = function
      [] -> assert false
    | pld :: tl ->
        if name = pld.pld_name.txt then pld.pld_type.ptyp_loc
        else get_loc name tl
  in
  List.iter
    (fun {Types.ld_id=name; ld_type=ty} ->
       check_constraints_rec env (get_loc (Ident.name name) pl) visited ty)
    l

let check_constraints env sdecl (_, decl) =
  let visited = ref TypeSet.empty in
  begin match decl.type_kind with
  | Type_abstract -> ()
  | Type_variant l ->
      let find_pl = function
          Ptype_variant pl -> pl
        | Ptype_record _ | Ptype_abstract | Ptype_open -> assert false
      in
      let pl = find_pl sdecl.ptype_kind in
      let pl_index =
        let foldf acc x =
          SMap.add x.pcd_name.txt x acc
        in
        List.fold_left foldf SMap.empty pl
      in
      List.iter
        (fun {Types.cd_id=name; cd_args; cd_res} ->
          let {pcd_args; pcd_res; _} =
            try SMap.find (Ident.name name) pl_index
            with Not_found -> assert false in
          begin match cd_args, pcd_args with
          | Cstr_tuple tyl, Pcstr_tuple styl ->
              List.iter2
                (fun sty ty ->
                   check_constraints_rec env sty.ptyp_loc visited ty)
                styl tyl
          | Cstr_record tyl, Pcstr_record styl ->
              check_constraints_labels env visited tyl styl
          | _ -> assert false
          end;
          match pcd_res, cd_res with
          | Some sr, Some r ->
              check_constraints_rec env sr.ptyp_loc visited r
          | _ ->
              () )
        l
  | Type_record (l, _) ->
      let find_pl = function
          Ptype_record pl -> pl
        | Ptype_variant _ | Ptype_abstract | Ptype_open -> assert false
      in
      let pl = find_pl sdecl.ptype_kind in
      check_constraints_labels env visited l pl
  | Type_open -> ()
  end;
  begin match decl.type_manifest with
  | None -> ()
  | Some ty ->
      let sty =
        match sdecl.ptype_manifest with Some sty -> sty | _ -> assert false
      in
      check_constraints_rec env sty.ptyp_loc visited ty
  end

(*
   If both a variant/record definition and a type equation are given,
   need to check that the equation refers to a type of the same kind
   with the same constructors and labels.
*)
let check_coherence env loc id decl =
  match decl with
    { type_kind = (Type_variant _ | Type_record _| Type_open);
      type_manifest = Some ty } ->
      begin match (Ctype.repr ty).desc with
        Tconstr(path, args, _) ->
          begin try
            let decl' = Env.find_type path env in
            let err =
              if List.length args <> List.length decl.type_params
              then [Includecore.Arity]
              else if not (Ctype.equal env false args decl.type_params)
              then [Includecore.Constraint]
              else
                Includecore.type_declarations ~loc ~equality:true env
                  (Path.last path)
                  decl'
                  id
                  (Subst.type_declaration
                     (Subst.add_type id path Subst.identity) decl)
            in
            if err <> [] then
              raise(Error(loc, Definition_mismatch (ty, err)))
          with Not_found ->
            raise(Error(loc, Unavailable_type_constructor path))
          end
      | _ -> raise(Error(loc, Definition_mismatch (ty, [])))
      end
  | _ -> ()

let check_abbrev env sdecl (id, decl) =
  check_coherence env sdecl.ptype_loc id decl

(* Check that recursion is well-founded *)

let check_well_founded env loc path to_check ty =
  let visited = ref TypeMap.empty in
  let rec check ty0 parents ty =
    let ty = Btype.repr ty in
    if TypeSet.mem ty parents then begin
      (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*)
      if match ty0.desc with
      | Tconstr (p, _, _) -> Path.same p path
      | _ -> false
      then raise (Error (loc, Recursive_abbrev (Path.name path)))
      else raise (Error (loc, Cycle_in_def (Path.name path, ty0)))
    end;
    let (fini, parents) =
      try
        let prev = TypeMap.find ty !visited in
        if TypeSet.subset parents prev then (true, parents) else
        (false, TypeSet.union parents prev)
      with Not_found ->
        (false, parents)
    in
    if fini then () else
    let rec_ok =
      match ty.desc with
        Tconstr(p,_,_) ->
          !Clflags.recursive_types && Ctype.is_contractive env p
      | Tobject _ | Tvariant _ -> true
      | _ -> !Clflags.recursive_types
    in
    let visited' = TypeMap.add ty parents !visited in
    let arg_exn =
      try
        visited := visited';
        let parents =
          if rec_ok then TypeSet.empty else TypeSet.add ty parents in
        Btype.iter_type_expr (check ty0 parents) ty;
        None
      with e ->
        visited := visited'; Some e
    in
    match ty.desc with
    | Tconstr(p, _, _) when arg_exn <> None || to_check p ->
        if to_check p then may raise arg_exn
        else Btype.iter_type_expr (check ty0 TypeSet.empty) ty;
        begin try
          let ty' = Ctype.try_expand_once_opt env ty in
          let ty0 = if TypeSet.is_empty parents then ty else ty0 in
          check ty0 (TypeSet.add ty parents) ty'
        with
          Ctype.Cannot_expand -> may raise arg_exn
        end
    | _ -> may raise arg_exn
  in
  let snap = Btype.snapshot () in
  try Ctype.wrap_trace_gadt_instances env (check ty TypeSet.empty) ty
  with Ctype.Unify _ ->
    (* Will be detected by check_recursion *)
    Btype.backtrack snap

let check_well_founded_manifest env loc path decl =
  if decl.type_manifest = None then () else
  let args = List.map (fun _ -> Ctype.newvar()) decl.type_params in
  check_well_founded env loc path (Path.same path) (Ctype.newconstr path args)

let check_well_founded_decl env loc path decl to_check =
  let open Btype in
  let it =
    {type_iterators with
     it_type_expr = (fun _ -> check_well_founded env loc path to_check)} in
  it.it_type_declaration it (Ctype.instance_declaration decl)

(* Check for ill-defined abbrevs *)

let check_recursion env loc path decl to_check =
  (* to_check is true for potentially mutually recursive paths.
     (path, decl) is the type declaration to be checked. *)

  if decl.type_params = [] then () else

  let visited = ref [] in

  let rec check_regular cpath args prev_exp ty =
    let ty = Ctype.repr ty in
    if not (List.memq ty !visited) then begin
      visited := ty :: !visited;
      match ty.desc with
      | Tconstr(path', args', _) ->
          if Path.same path path' then begin
            if not (Ctype.equal env false args args') then
              raise (Error(loc,
                     Parameters_differ(cpath, ty, Ctype.newconstr path args)))
          end
          (* Attempt to expand a type abbreviation if:
              1- [to_check path'] holds
                 (otherwise the expansion cannot involve [path]);
              2- we haven't expanded this type constructor before
                 (otherwise we could loop if [path'] is itself
                 a non-regular abbreviation). *)
          else if to_check path' && not (List.mem path' prev_exp) then begin
            try
              (* Attempt expansion *)
              let (params0, body0, _) = Env.find_type_expansion path' env in
              let (params, body) =
                Ctype.instance_parameterized_type params0 body0 in
              begin
                try List.iter2 (Ctype.unify env) params args'
                with Ctype.Unify _ ->
                  raise (Error(loc, Constraint_failed
                                 (ty, Ctype.newconstr path' params0)));
              end;
              check_regular path' args (path' :: prev_exp) body
            with Not_found -> ()
          end;
          List.iter (check_regular cpath args prev_exp) args'
      | Tpoly (ty, tl) ->
          let (_, ty) = Ctype.instance_poly ~keep_names:true false tl ty in
          check_regular cpath args prev_exp ty
      | _ ->
          Btype.iter_type_expr (check_regular cpath args prev_exp) ty
    end in

  Misc.may
    (fun body ->
      let (args, body) =
        Ctype.instance_parameterized_type
          ~keep_names:true decl.type_params body in
      check_regular path args [] body)
    decl.type_manifest

let check_abbrev_recursion env id_loc_list to_check tdecl =
  let decl = tdecl.typ_type in
  let id = tdecl.typ_id in
  check_recursion env (List.assoc id id_loc_list) (Path.Pident id) decl to_check

(* Compute variance *)

let get_variance ty visited =
  try TypeMap.find ty !visited with Not_found -> Variance.null

let compute_variance env visited vari ty =
  let rec compute_variance_rec vari ty =
    (* Format.eprintf "%a: %x@." Printtyp.type_expr ty (Obj.magic vari); *)
    let ty = Ctype.repr ty in
    let vari' = get_variance ty visited in
    if Variance.subset vari vari' then () else
    let vari = Variance.union vari vari' in
    visited := TypeMap.add ty vari !visited;
    let compute_same = compute_variance_rec vari in
    match ty.desc with
      Tarrow (_, ty1, ty2, _) ->
        let open Variance in
        let v = conjugate vari in
        let v1 =
          if mem May_pos v || mem May_neg v
          then set May_weak true v else v
        in
        compute_variance_rec v1 ty1;
        compute_same ty2
    | Ttuple tl ->
        List.iter compute_same tl
    | Tconstr (path, tl, _) ->
        let open Variance in
        if tl = [] then () else begin
          try
            let decl = Env.find_type path env in
            let cvari f = mem f vari in
            List.iter2
              (fun ty v ->
                let cv f = mem f v in
                let strict =
                  cvari Inv && cv Inj || (cvari Pos || cvari Neg) && cv Inv
                in
                if strict then compute_variance_rec full ty else
                let p1 = inter v vari
                and n1 = inter v (conjugate vari) in
                let v1 =
                  union (inter covariant (union p1 (conjugate p1)))
                    (inter (conjugate covariant) (union n1 (conjugate n1)))
                and weak =
                  cvari May_weak && (cv May_pos || cv May_neg) ||
                  (cvari May_pos || cvari May_neg) && cv May_weak
                in
                let v2 = set May_weak weak v1 in
                compute_variance_rec v2 ty)
              tl decl.type_variance
          with Not_found ->
            List.iter (compute_variance_rec may_inv) tl
        end
    | Tobject (ty, _) ->
        compute_same ty
    | Tfield (_, _, ty1, ty2) ->
        compute_same ty1;
        compute_same ty2
    | Tsubst ty ->
        compute_same ty
    | Tvariant row ->
        let row = Btype.row_repr row in
        List.iter
          (fun (_,f) ->
            match Btype.row_field_repr f with
              Rpresent (Some ty) ->
                compute_same ty
            | Reither (_, tyl, _, _) ->
                let open Variance in
                let upper =
                  List.fold_left (fun s f -> set f true s)
                    null [May_pos; May_neg; May_weak]
                in
                let v = inter vari upper in
                (* cf PR#7269:
                   if List.length tyl > 1 then upper else inter vari upper *)
                List.iter (compute_variance_rec v) tyl
            | _ -> ())
          row.row_fields;
        compute_same row.row_more
    | Tpoly (ty, _) ->
        compute_same ty
    | Tvar _ | Tnil | Tlink _ | Tunivar _ -> ()
    | Tpackage (_, _, tyl) ->
        let v =
          Variance.(if mem Pos vari || mem Neg vari then full else may_inv)
        in
        List.iter (compute_variance_rec v) tyl
  in
  compute_variance_rec vari ty

let make p n i =
  let open Variance in
  set May_pos p (set May_neg n (set May_weak n (set Inj i null)))

let compute_variance_type env check (required, loc) decl tyl =
  (* Requirements *)
  let required =
    List.map (fun (c,n,i) -> if c || n then (c,n,i) else (true,true,i))
      required
  in
  (* Prepare *)
  let params = List.map Btype.repr decl.type_params in
  let tvl = ref TypeMap.empty in
  (* Compute occurrences in the body *)
  let open Variance in
  List.iter
    (fun (cn,ty) ->
      compute_variance env tvl (if cn then full else covariant) ty)
    tyl;
  if check then begin
    (* Check variance of parameters *)
    let pos = ref 0 in
    List.iter2
      (fun ty (c, n, i) ->
        incr pos;
        let var = get_variance ty tvl in
        let (co,cn) = get_upper var and ij = mem Inj var in
        if Btype.is_Tvar ty && (co && not c || cn && not n || not ij && i)
        then raise (Error(loc, Bad_variance (!pos, (co,cn,ij), (c,n,i)))))
      params required;
    (* Check propagation from constrained parameters *)
    let args = Btype.newgenty (Ttuple params) in
    let fvl = Ctype.free_variables args in
    let fvl = List.filter (fun v -> not (List.memq v params)) fvl in
    (* If there are no extra variables there is nothing to do *)
    if fvl = [] then () else
    let tvl2 = ref TypeMap.empty in
    List.iter2
      (fun ty (p,n,_) ->
        if Btype.is_Tvar ty then () else
        let v =
          if p then if n then full else covariant else conjugate covariant in
        compute_variance env tvl2 v ty)
      params required;
    let visited = ref TypeSet.empty in
    let rec check ty =
      let ty = Ctype.repr ty in
      if TypeSet.mem ty !visited then () else
      let visited' = TypeSet.add ty !visited in
      visited := visited';
      let v1 = get_variance ty tvl in
      let snap = Btype.snapshot () in
      let v2 =
        TypeMap.fold
          (fun t vt v ->
            if Ctype.equal env false [ty] [t] then union vt v else v)
          !tvl2 null in
      Btype.backtrack snap;
      let (c1,n1) = get_upper v1 and (c2,n2,_,i2) = get_lower v2 in
      if c1 && not c2 || n1 && not n2 then
        if List.memq ty fvl then
          let code = if not i2 then -2 else if c2 || n2 then -1 else -3 in
          raise (Error (loc, Bad_variance (code, (c1,n1,false), (c2,n2,false))))
        else
          Btype.iter_type_expr check ty
    in
    List.iter (fun (_,ty) -> check ty) tyl;
  end;
  List.map2
    (fun ty (p, n, i) ->
      let v = get_variance ty tvl in
      let tr = decl.type_private in
      (* Use required variance where relevant *)
      let concr = decl.type_kind <> Type_abstract (*|| tr = Type_new*) in
      let (p, n) =
        if tr = Private || not (Btype.is_Tvar ty) then (p, n) (* set *)
        else (false, false) (* only check *)
      and i = concr  || i && tr = Private in
      let v = union v (make p n i) in
      let v =
        if not concr then v else
        if mem Pos v && mem Neg v then full else
        if Btype.is_Tvar ty then v else
        union v
          (if p then if n then full else covariant else conjugate covariant)
      in
      if decl.type_kind = Type_abstract && tr = Public then v else
      set May_weak (mem May_neg v) v)
    params required

let add_false = List.map (fun ty -> false, ty)

(* A parameter is constrained if it is either instantiated,
   or it is a variable appearing in another parameter *)
let constrained vars ty =
  match ty.desc with
  | Tvar _ -> List.exists (fun tl -> List.memq ty tl) vars
  | _ -> true

let for_constr = function
  | Types.Cstr_tuple l -> add_false l
  | Types.Cstr_record l ->
      List.map
        (fun {Types.ld_mutable; ld_type} -> (ld_mutable = Mutable, ld_type))
        l

let compute_variance_gadt env check (required, loc as rloc) decl
    (tl, ret_type_opt) =
  match ret_type_opt with
  | None ->
      compute_variance_type env check rloc {decl with type_private = Private}
        (for_constr tl)
  | Some ret_type ->
      match Ctype.repr ret_type with
      | {desc=Tconstr (_, tyl, _)} ->
          (* let tyl = List.map (Ctype.expand_head env) tyl in *)
          let tyl = List.map Ctype.repr tyl in
          let fvl = List.map (Ctype.free_variables ?env:None) tyl in
          let _ =
            List.fold_left2
              (fun (fv1,fv2) ty (c,n,_) ->
                match fv2 with [] -> assert false
                | fv :: fv2 ->
                    (* fv1 @ fv2 = free_variables of other parameters *)
                    if (c||n) && constrained (fv1 @ fv2) ty then
                      raise (Error(loc, Varying_anonymous));
                    (fv :: fv1, fv2))
              ([], fvl) tyl required
          in
          compute_variance_type env check rloc
            {decl with type_params = tyl; type_private = Private}
            (for_constr tl)
      | _ -> assert false

let compute_variance_extension env check decl ext rloc =
  compute_variance_gadt env check rloc
    {decl with type_params = ext.ext_type_params}
    (ext.ext_args, ext.ext_ret_type)

let compute_variance_decl env check decl (required, _ as rloc) =
  if (decl.type_kind = Type_abstract || decl.type_kind = Type_open)
       && decl.type_manifest = None then
    List.map
      (fun (c, n, i) ->
        make (not n) (not c) (decl.type_kind <> Type_abstract || i))
      required
  else
  let mn =
    match decl.type_manifest with
      None -> []
    | Some ty -> [false, ty]
  in
  match decl.type_kind with
    Type_abstract | Type_open ->
      compute_variance_type env check rloc decl mn
  | Type_variant tll ->
      if List.for_all (fun c -> c.Types.cd_res = None) tll then
        compute_variance_type env check rloc decl
          (mn @ List.flatten (List.map (fun c -> for_constr c.Types.cd_args)
                                tll))
      else begin
        let mn =
          List.map (fun (_,ty) -> (Types.Cstr_tuple [ty],None)) mn in
        let tll =
          mn @ List.map (fun c -> c.Types.cd_args, c.Types.cd_res) tll in
        match List.map (compute_variance_gadt env check rloc decl) tll with
        | vari :: rem ->
            let varl = List.fold_left (List.map2 Variance.union) vari rem in
            List.map
              Variance.(fun v -> if mem Pos v && mem Neg v then full else v)
              varl
        | _ -> assert false
      end
  | Type_record (ftl, _) ->
      compute_variance_type env check rloc decl
        (mn @ List.map (fun {Types.ld_mutable; ld_type} ->
             (ld_mutable = Mutable, ld_type)) ftl)

let is_hash id =
  let s = Ident.name id in
  String.length s > 0 && s.[0] = '#'

let marked_as_immediate decl =
  Builtin_attributes.immediate decl.type_attributes

let compute_immediacy env tdecl =
  match (tdecl.type_kind, tdecl.type_manifest) with
  | (Type_variant [{cd_args = Cstr_tuple [arg]; _}], _)
    | (Type_variant [{cd_args = Cstr_record [{ld_type = arg; _}]; _}], _)
    | (Type_record ([{ld_type = arg; _}], _), _)
  when tdecl.type_unboxed.unboxed ->
    begin match get_unboxed_type_representation env arg with
    | Some argrepr -> not (Ctype.maybe_pointer_type env argrepr)
    | None -> false
    end
  | (Type_variant (_ :: _ as cstrs), _) ->
    not (List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs)
  | (Type_abstract, Some(typ)) ->
    not (Ctype.maybe_pointer_type env typ)
  | (Type_abstract, None) -> marked_as_immediate tdecl
  | _ -> false

(* Computes the fixpoint for the variance and immediacy of type declarations *)

let rec compute_properties_fixpoint env decls required variances immediacies =
  let new_decls =
    List.map2
      (fun (id, decl) (variance, immediacy) ->
         id, {decl with type_variance = variance; type_immediate = immediacy})
      decls (List.combine variances immediacies)
  in
  let new_env =
    List.fold_right
      (fun (id, decl) env -> Env.add_type ~check:true id decl env)
      new_decls env
  in
  let new_variances =
    List.map2
      (fun (_id, decl) -> compute_variance_decl new_env false decl)
      new_decls required
  in
  let new_variances =
    List.map2 (List.map2 Variance.union) new_variances variances in
  let new_immediacies =
    List.map
      (fun (_id, decl) -> compute_immediacy new_env decl)
      new_decls
  in
  if new_variances <> variances || new_immediacies <> immediacies then
    compute_properties_fixpoint env decls required new_variances new_immediacies
  else begin
    (* List.iter (fun (id, decl) ->
      Printf.eprintf "%s:" (Ident.name id);
      List.iter (fun (v : Variance.t) ->
        Printf.eprintf " %x" (Obj.magic v : int))
        decl.type_variance;
      prerr_endline "")
      new_decls; *)
    List.iter (fun (_, decl) ->
      if (marked_as_immediate decl) && (not decl.type_immediate) then
        raise (Error (decl.type_loc, Bad_immediate_attribute))
      else ())
      new_decls;
    List.iter2
      (fun (id, decl) req -> if not (is_hash id) then
        ignore (compute_variance_decl new_env true decl req))
      new_decls required;
    new_decls, new_env
  end

let init_variance (_id, decl) =
  List.map (fun _ -> Variance.null) decl.type_params

let add_injectivity =
  List.map
    (function
      | Covariant -> (true, false, false)
      | Contravariant -> (false, true, false)
      | Invariant -> (false, false, false)
    )

(* for typeclass.ml *)
let compute_variance_decls env cldecls =
  let decls, required =
    List.fold_right
      (fun (obj_id, obj_abbr, _cl_abbr, _clty, _cltydef, ci) (decls, req) ->
        let variance = List.map snd ci.ci_params in
        (obj_id, obj_abbr) :: decls,
        (add_injectivity variance, ci.ci_loc) :: req)
      cldecls ([],[])
  in
  let (decls, _) =
    compute_properties_fixpoint env decls required
      (List.map init_variance decls)
      (List.map (fun _ -> false) decls)
  in
  List.map2
    (fun (_,decl) (_, _, cl_abbr, clty, cltydef, _) ->
      let variance = decl.type_variance in
      (decl, {cl_abbr with type_variance = variance},
       {clty with cty_variance = variance},
       {cltydef with clty_variance = variance}))
    decls cldecls

(* Check multiple declarations of labels/constructors *)

let check_duplicates sdecl_list =
  let labels = Hashtbl.create 7 and constrs = Hashtbl.create 7 in
  List.iter
    (fun sdecl -> match sdecl.ptype_kind with
      Ptype_variant cl ->
        List.iter
          (fun pcd ->
            try
              let name' = Hashtbl.find constrs pcd.pcd_name.txt in
              Location.prerr_warning pcd.pcd_loc
                (Warnings.Duplicate_definitions
                   ("constructor", pcd.pcd_name.txt, name',
                    sdecl.ptype_name.txt))
            with Not_found ->
              Hashtbl.add constrs pcd.pcd_name.txt sdecl.ptype_name.txt)
          cl
    | Ptype_record fl ->
        List.iter
          (fun {pld_name=cname;pld_loc=loc} ->
            try
              let name' = Hashtbl.find labels cname.txt in
              Location.prerr_warning loc
                (Warnings.Duplicate_definitions
                   ("label", cname.txt, name', sdecl.ptype_name.txt))
            with Not_found -> Hashtbl.add labels cname.txt sdecl.ptype_name.txt)
          fl
    | Ptype_abstract -> ()
    | Ptype_open -> ())
    sdecl_list

(* Force recursion to go through id for private types*)
let name_recursion sdecl id decl =
  match decl with
  | { type_kind = Type_abstract;
      type_manifest = Some ty;
      type_private = Private; } when is_fixed_type sdecl ->
    let ty = Ctype.repr ty in
    let ty' = Btype.newty2 ty.level ty.desc in
    if Ctype.deep_occur ty ty' then
      let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in
      Btype.link_type ty (Btype.newty2 ty.level td);
      {decl with type_manifest = Some ty'}
    else decl
  | _ -> decl

(* Translate a set of type declarations, mutually recursive or not *)
let transl_type_decl env rec_flag sdecl_list =
  (* Add dummy types for fixed rows *)
  let fixed_types = List.filter is_fixed_type sdecl_list in
  let sdecl_list =
    List.map
      (fun sdecl ->
        let ptype_name =
          mkloc (sdecl.ptype_name.txt ^"#row") sdecl.ptype_name.loc in
        {sdecl with
         ptype_name; ptype_kind = Ptype_abstract; ptype_manifest = None})
      fixed_types
    @ sdecl_list
  in

  (* Create identifiers. *)
  let id_list =
    List.map (fun sdecl -> Ident.create sdecl.ptype_name.txt) sdecl_list
  in
  (*
     Since we've introduced fresh idents, make sure the definition
     level is at least the binding time of these events. Otherwise,
     passing one of the recursively-defined type constrs as argument
     to an abbreviation may fail.
  *)
  Ctype.init_def(Ident.current_time());
  Ctype.begin_def();
  (* Enter types. *)
  let temp_env =
    List.fold_left2 (enter_type rec_flag) env sdecl_list id_list in
  (* Translate each declaration. *)
  let current_slot = ref None in
  let warn_unused = Warnings.is_active (Warnings.Unused_type_declaration "") in
  let id_slots id =
    match rec_flag with
    | Asttypes.Recursive when warn_unused ->
        (* See typecore.ml for a description of the algorithm used
             to detect unused declarations in a set of recursive definitions. *)
        let slot = ref [] in
        let td = Env.find_type (Path.Pident id) temp_env in
        let name = Ident.name id in
        Env.set_type_used_callback
          name td
          (fun old_callback ->
             match !current_slot with
             | Some slot -> slot := (name, td) :: !slot
             | None ->
                 List.iter (fun (name, d) -> Env.mark_type_used env name d)
                   (get_ref slot);
                 old_callback ()
          );
        id, Some slot
    | Asttypes.Recursive | Asttypes.Nonrecursive ->
        id, None
  in
  let transl_declaration name_sdecl (id, slot) =
    current_slot := slot;
    Builtin_attributes.warning_scope
      name_sdecl.ptype_attributes
      (fun () -> transl_declaration temp_env name_sdecl id)
  in
  let tdecls =
    List.map2 transl_declaration sdecl_list (List.map id_slots id_list) in
  let decls =
    List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in
  current_slot := None;
  (* Check for duplicates *)
  check_duplicates sdecl_list;
  (* Build the final env. *)
  let newenv =
    List.fold_right
      (fun (id, decl) env -> Env.add_type ~check:true id decl env)
      decls env
  in
  (* Update stubs *)
  begin match rec_flag with
    | Asttypes.Nonrecursive -> ()
    | Asttypes.Recursive ->
      List.iter2
        (fun id sdecl -> update_type temp_env newenv id sdecl.ptype_loc)
        id_list sdecl_list
  end;
  (* Generalize type declarations. *)
  Ctype.end_def();
  List.iter (fun (_, decl) -> generalize_decl decl) decls;
  (* Check for ill-formed abbrevs *)
  let id_loc_list =
    List.map2 (fun id sdecl -> (id, sdecl.ptype_loc))
      id_list sdecl_list
  in
  List.iter (fun (id, decl) ->
    check_well_founded_manifest newenv (List.assoc id id_loc_list)
      (Path.Pident id) decl)
    decls;
  let to_check =
    function Path.Pident id -> List.mem_assoc id id_loc_list | _ -> false in
  List.iter (fun (id, decl) ->
    check_well_founded_decl newenv (List.assoc id id_loc_list) (Path.Pident id)
      decl to_check)
    decls;
  List.iter (check_abbrev_recursion newenv id_loc_list to_check) tdecls;
  (* Check that all type variables are closed *)
  List.iter2
    (fun sdecl tdecl ->
      let decl = tdecl.typ_type in
       match Ctype.closed_type_decl decl with
         Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
       | None   -> ())
    sdecl_list tdecls;
  (* Check that constraints are enforced *)
  List.iter2 (check_constraints newenv) sdecl_list decls;
  (* Name recursion *)
  let decls =
    List.map2 (fun sdecl (id, decl) -> id, name_recursion sdecl id decl)
      sdecl_list decls
  in
  (* Add variances to the environment *)
  let required =
    List.map
      (fun sdecl ->
         add_injectivity (List.map snd sdecl.ptype_params),
         sdecl.ptype_loc
      )
      sdecl_list
  in
  let final_decls, final_env =
    compute_properties_fixpoint env decls required
      (List.map init_variance decls)
      (List.map (fun _ -> false) decls)
  in
  (* Check re-exportation *)
  List.iter2 (check_abbrev final_env) sdecl_list final_decls;
  (* Keep original declaration *)
  let final_decls =
    List.map2
      (fun tdecl (_id2, decl) ->
        { tdecl with typ_type = decl }
      ) tdecls final_decls
  in
  (* Done *)
  (final_decls, final_env)

(* Translating type extensions *)

let transl_extension_constructor env type_path type_params
                                 typext_params priv sext =
  let id = Ident.create sext.pext_name.txt in
  let args, ret_type, kind =
    match sext.pext_kind with
      Pext_decl(sargs, sret_type) ->
        let targs, tret_type, args, ret_type, _ =
          make_constructor env type_path typext_params
            sargs sret_type
        in
          args, ret_type, Text_decl(targs, tret_type)
    | Pext_rebind lid ->
        let cdescr = Typetexp.find_constructor env lid.loc lid.txt in
        let usage =
          if cdescr.cstr_private = Private || priv = Public
          then Env.Positive else Env.Privatize
        in
        Env.mark_constructor usage env (Longident.last lid.txt) cdescr;
        let (args, cstr_res) = Ctype.instance_constructor cdescr in
        let res, ret_type =
          if cdescr.cstr_generalized then
            let params = Ctype.instance_list env type_params in
            let res = Ctype.newconstr type_path params in
            let ret_type = Some (Ctype.newconstr type_path params) in
              res, ret_type
          else (Ctype.newconstr type_path typext_params), None
        in
        begin
          try
            Ctype.unify env cstr_res res
          with Ctype.Unify trace ->
            raise (Error(lid.loc,
                     Rebind_wrong_type(lid.txt, env, trace)))
        end;
        (* Remove "_" names from parameters used in the constructor *)
        if not cdescr.cstr_generalized then begin
          let vars =
            Ctype.free_variables (Btype.newgenty (Ttuple args))
          in
            List.iter
              (function {desc = Tvar (Some "_")} as ty ->
                          if List.memq ty vars then ty.desc <- Tvar None
                        | _ -> ())
              typext_params
        end;
        (* Ensure that constructor's type matches the type being extended *)
        let cstr_type_path, cstr_type_params =
          match cdescr.cstr_res.desc with
            Tconstr (p, _, _) ->
              let decl = Env.find_type p env in
                p, decl.type_params
          | _ -> assert false
        in
        let cstr_types =
          (Btype.newgenty
             (Tconstr(cstr_type_path, cstr_type_params, ref Mnil)))
          :: cstr_type_params
        in
        let ext_types =
          (Btype.newgenty
             (Tconstr(type_path, type_params, ref Mnil)))
          :: type_params
        in
        if not (Ctype.equal env true cstr_types ext_types) then
          raise (Error(lid.loc,
                       Rebind_mismatch(lid.txt, cstr_type_path, type_path)));
        (* Disallow rebinding private constructors to non-private *)
        begin
          match cdescr.cstr_private, priv with
            Private, Public ->
              raise (Error(lid.loc, Rebind_private lid.txt))
          | _ -> ()
        end;
        let path =
          match cdescr.cstr_tag with
            Cstr_extension(path, _) -> path
          | _ -> assert false
        in
        let args =
          match cdescr.cstr_inlined with
          | None ->
              Types.Cstr_tuple args
          | Some decl ->
              let tl =
                match args with
                | [ {desc=Tconstr(_, tl, _)} ] -> tl
                | _ -> assert false
              in
              let decl = Ctype.instance_declaration decl in
              assert (List.length decl.type_params = List.length tl);
              List.iter2 (Ctype.unify env) decl.type_params tl;
              let lbls =
                match decl.type_kind with
                | Type_record (lbls, Record_extension) -> lbls
                | _ -> assert false
              in
              Types.Cstr_record lbls
        in
        args, ret_type, Text_rebind(path, lid)
  in
  let ext =
    { ext_type_path = type_path;
      ext_type_params = typext_params;
      ext_args = args;
      ext_ret_type = ret_type;
      ext_private = priv;
      Types.ext_loc = sext.pext_loc;
      Types.ext_attributes = sext.pext_attributes; }
  in
    { ext_id = id;
      ext_name = sext.pext_name;
      ext_type = ext;
      ext_kind = kind;
      Typedtree.ext_loc = sext.pext_loc;
      Typedtree.ext_attributes = sext.pext_attributes; }

let transl_extension_constructor env type_path type_params
    typext_params priv sext =
  Builtin_attributes.warning_scope sext.pext_attributes
    (fun () -> transl_extension_constructor env type_path type_params
        typext_params priv sext)

let transl_type_extension extend env loc styext =
  reset_type_variables();
  Ctype.begin_def();
  let (type_path, type_decl) =
    let lid = styext.ptyext_path in
    Typetexp.find_type env lid.loc lid.txt
  in
  begin
    match type_decl.type_kind with
    | Type_open -> begin
        match type_decl.type_private with
        | Private when extend -> begin
            match
              List.find
                (function {pext_kind = Pext_decl _} -> true
                        | {pext_kind = Pext_rebind _} -> false)
                styext.ptyext_constructors
            with
            | {pext_loc} ->
                raise (Error(pext_loc, Cannot_extend_private_type type_path))
            | exception Not_found -> ()
          end
        | _ -> ()
      end
    | _ ->
        raise (Error(loc, Not_extensible_type type_path))
  end;
  let type_variance =
    List.map (fun v ->
                let (co, cn) = Variance.get_upper v in
                  (not cn, not co, false))
             type_decl.type_variance
  in
  let err =
    if type_decl.type_arity <> List.length styext.ptyext_params then
      [Includecore.Arity]
    else
      if List.for_all2
           (fun (c1, n1, _) (c2, n2, _) -> (not c2 || c1) && (not n2 || n1))
           type_variance
           (add_injectivity (List.map snd styext.ptyext_params))
      then [] else [Includecore.Variance]
  in
  if err <> [] then
    raise (Error(loc, Extension_mismatch (type_path, err)));
  let ttype_params = make_params env styext.ptyext_params in
  let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in
  List.iter2 (Ctype.unify_var env)
    (Ctype.instance_list env type_decl.type_params)
    type_params;
  let constructors =
    List.map (transl_extension_constructor env type_path
               type_decl.type_params type_params styext.ptyext_private)
      styext.ptyext_constructors
  in
  Ctype.end_def();
  (* Generalize types *)
  List.iter Ctype.generalize type_params;
  List.iter
    (fun ext ->
       Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args;
       may Ctype.generalize ext.ext_type.ext_ret_type)
    constructors;
  (* Check that all type variables are closed *)
  List.iter
    (fun ext ->
       match Ctype.closed_extension_constructor ext.ext_type with
         Some ty ->
           raise(Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type)))
       | None -> ())
    constructors;
  (* Check variances are correct *)
  List.iter
    (fun ext->
      ignore (compute_variance_extension env true type_decl
                ext.ext_type (type_variance, loc)))
    constructors;
  (* Add extension constructors to the environment *)
  let newenv =
    List.fold_left
      (fun env ext ->
         Env.add_extension ~check:true ext.ext_id ext.ext_type env)
      env constructors
  in
  let tyext =
    { tyext_path = type_path;
      tyext_txt = styext.ptyext_path;
      tyext_params = ttype_params;
      tyext_constructors = constructors;
      tyext_private = styext.ptyext_private;
      tyext_attributes = styext.ptyext_attributes; }
  in
    (tyext, newenv)

let transl_type_extension extend env loc styext =
  Builtin_attributes.warning_scope styext.ptyext_attributes
    (fun () -> transl_type_extension extend env loc styext)

let transl_exception env sext =
  reset_type_variables();
  Ctype.begin_def();
  let ext =
    transl_extension_constructor env
      Predef.path_exn [] [] Asttypes.Public sext
  in
  Ctype.end_def();
  (* Generalize types *)
  Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args;
  may Ctype.generalize ext.ext_type.ext_ret_type;
  (* Check that all type variables are closed *)
  begin match Ctype.closed_extension_constructor ext.ext_type with
    Some ty ->
      raise (Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type)))
  | None -> ()
  end;
  let newenv = Env.add_extension ~check:true ext.ext_id ext.ext_type env in
    ext, newenv

type native_repr_attribute =
  | Native_repr_attr_absent
  | Native_repr_attr_present of native_repr_kind

let get_native_repr_attribute attrs ~global_repr =
  match
    Attr_helper.get_no_payload_attribute ["unboxed"; "ocaml.unboxed"]  attrs,
    Attr_helper.get_no_payload_attribute ["untagged"; "ocaml.untagged"] attrs,
    global_repr
  with
  | None, None, None -> Native_repr_attr_absent
  | None, None, Some repr -> Native_repr_attr_present repr
  | Some _, None, None -> Native_repr_attr_present Unboxed
  | None, Some _, None -> Native_repr_attr_present Untagged
  | Some { Location.loc }, _, _
  | _, Some { Location.loc }, _ ->
    raise (Error (loc, Multiple_native_repr_attributes))

let native_repr_of_type env kind ty =
  match kind, (Ctype.expand_head_opt env ty).desc with
  | Untagged, Tconstr (path, _, _) when Path.same path Predef.path_int ->
    Some Untagged_int
  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_float ->
    Some Unboxed_float
  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int32 ->
    Some (Unboxed_integer Pint32)
  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int64 ->
    Some (Unboxed_integer Pint64)
  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_nativeint ->
    Some (Unboxed_integer Pnativeint)
  | _ ->
    None

(* Raises an error when [core_type] contains an [@unboxed] or [@untagged]
   attribute in a strict sub-term. *)
let error_if_has_deep_native_repr_attributes core_type =
  let open Ast_iterator in
  let this_iterator =
    { default_iterator with typ = fun iterator core_type ->
      begin
        match
          get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None
        with
        | Native_repr_attr_present kind ->
           raise (Error (core_type.ptyp_loc,
                         Deep_unbox_or_untag_attribute kind))
        | Native_repr_attr_absent -> ()
      end;
      default_iterator.typ iterator core_type }
  in
  default_iterator.typ this_iterator core_type

let make_native_repr env core_type ty ~global_repr =
  error_if_has_deep_native_repr_attributes core_type;
  match get_native_repr_attribute core_type.ptyp_attributes ~global_repr with
  | Native_repr_attr_absent ->
    Same_as_ocaml_repr
  | Native_repr_attr_present kind ->
    begin match native_repr_of_type env kind ty with
    | None ->
      raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind))
    | Some repr -> repr
    end

let rec parse_native_repr_attributes env core_type ty ~global_repr =
  match core_type.ptyp_desc, (Ctype.repr ty).desc,
    get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None
  with
  | Ptyp_arrow _, Tarrow _, Native_repr_attr_present kind  ->
    raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind))
  | Ptyp_arrow (_, ct1, ct2), Tarrow (_, t1, t2, _), _ ->
    let repr_arg = make_native_repr env ct1 t1 ~global_repr in
    let repr_args, repr_res =
      parse_native_repr_attributes env ct2 t2 ~global_repr
    in
    (repr_arg :: repr_args, repr_res)
  | Ptyp_arrow _, _, _ | _, Tarrow _, _ -> assert false
  | _ -> ([], make_native_repr env core_type ty ~global_repr)


let check_unboxable env loc ty =
  let ty = Ctype.repr (Ctype.expand_head_opt env ty) in
  try match ty.desc with
  | Tconstr (p, _, _) ->
    let tydecl = Env.find_type p env in
    if tydecl.type_unboxed.unboxed then
      Location.prerr_warning loc
        (Warnings.Unboxable_type_in_prim_decl (Path.name p))
  | _ -> ()
  with Not_found -> ()

(* Translate a value declaration *)
let transl_value_decl env loc valdecl =
  let cty = Typetexp.transl_type_scheme env valdecl.pval_type in
  let ty = cty.ctyp_type in
  let v =
  match valdecl.pval_prim with
    [] when Env.is_in_signature env ->
      { val_type = ty; val_kind = Val_reg; Types.val_loc = loc;
        val_attributes = valdecl.pval_attributes }
  | [] ->
      raise (Error(valdecl.pval_loc, Val_in_structure))
  | _ ->
      let global_repr =
        match
          get_native_repr_attribute valdecl.pval_attributes ~global_repr:None
        with
        | Native_repr_attr_present repr -> Some repr
        | Native_repr_attr_absent -> None
      in
      let native_repr_args, native_repr_res =
        if !Clflags.bs_only then          
          let rec scann (attrs : Parsetree.attributes)  = 
            match attrs with 
            | ({txt = "internal.arity";_}, 
              PStr [ {pstr_desc = Pstr_eval
                        (
                          ({pexp_desc = Pexp_constant (Pconst_integer (i,_))} :
                             Parsetree.expression) ,_)}]) :: _ -> 
               Some (int_of_string i)              
            | _ :: rest  -> scann rest 
            | [] -> None 
          and make n = 
            if n = 0 then []
            else Primitive.Same_as_ocaml_repr :: make (n - 1)
          in 
            match scann valdecl.pval_attributes with 
            | None ->  parse_native_repr_attributes env valdecl.pval_type ty ~global_repr
            | Some x -> make x , Primitive.Same_as_ocaml_repr
        else
        parse_native_repr_attributes env valdecl.pval_type ty ~global_repr
      in
      let prim =
        Primitive.parse_declaration valdecl
          ~native_repr_args
          ~native_repr_res
      in
      let prim_native_name = prim.prim_native_name in 
      if prim.prim_arity = 0 &&
         not ( String.length prim_native_name > 3 &&
               String.unsafe_get prim_native_name 0 = 'B' &&
               String.unsafe_get prim_native_name 1 = 'S' &&
               String.unsafe_get prim_native_name 2 = ':'
             ) && 
         (prim.prim_name = "" || (prim.prim_name.[0] <> '%' && prim.prim_name.[0] <> '#')) then
        raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external));
      if !Clflags.native_code
      && prim.prim_arity > 5
      && prim_native_name = ""
      then raise(Error(valdecl.pval_type.ptyp_loc, Missing_native_external));
      Btype.iter_type_expr (check_unboxable env loc) ty;
      { val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc;
        val_attributes = valdecl.pval_attributes }
  in
  let (id, newenv) =
    Env.enter_value valdecl.pval_name.txt v env
      ~check:(fun s -> Warnings.Unused_value_declaration s)
  in
  let desc =
    {
     val_id = id;
     val_name = valdecl.pval_name;
     val_desc = cty; val_val = v;
     val_prim = valdecl.pval_prim;
     val_loc = valdecl.pval_loc;
     val_attributes = valdecl.pval_attributes;
    }
  in
  desc, newenv

let transl_value_decl env loc valdecl =
  Builtin_attributes.warning_scope valdecl.pval_attributes
    (fun () -> transl_value_decl env loc valdecl)

(* Translate a "with" constraint -- much simplified version of
    transl_type_decl. *)
let transl_with_constraint env id row_path orig_decl sdecl =
  Env.mark_type_used env (Ident.name id) orig_decl;
  reset_type_variables();
  Ctype.begin_def();
  let tparams = make_params env sdecl.ptype_params in
  let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in
  let orig_decl = Ctype.instance_declaration orig_decl in
  let arity_ok = List.length params = orig_decl.type_arity in
  if arity_ok then
    List.iter2 (Ctype.unify_var env) params orig_decl.type_params;
  let constraints = List.map
    (function (ty, ty', loc) ->
       try
         let cty = transl_simple_type env false ty in
         let cty' = transl_simple_type env false ty' in
         let ty = cty.ctyp_type in
         let ty' = cty'.ctyp_type in
         Ctype.unify env ty ty';
         (cty, cty', loc)
       with Ctype.Unify tr ->
         raise(Error(loc, Inconsistent_constraint (env, tr))))
    sdecl.ptype_cstrs
  in
  let no_row = not (is_fixed_type sdecl) in
  let (tman, man) =  match sdecl.ptype_manifest with
      None -> None, None
    | Some sty ->
        let cty = transl_simple_type env no_row sty in
        Some cty, Some cty.ctyp_type
  in
  let priv =
    if sdecl.ptype_private = Private then Private else
    if arity_ok && orig_decl.type_kind <> Type_abstract
    then orig_decl.type_private else sdecl.ptype_private
  in
  if arity_ok && orig_decl.type_kind <> Type_abstract
  && sdecl.ptype_private = Private then
    Location.deprecated sdecl.ptype_loc "spurious use of private";
  let type_kind, type_unboxed =
    if arity_ok && man <> None then
      orig_decl.type_kind, orig_decl.type_unboxed
    else
      Type_abstract, unboxed_false_default_false
  in
  let decl =
    { type_params = params;
      type_arity = List.length params;
      type_kind;
      type_private = priv;
      type_manifest = man;
      type_variance = [];
      type_newtype_level = None;
      type_loc = sdecl.ptype_loc;
      type_attributes = sdecl.ptype_attributes;
      type_immediate = false;
      type_unboxed;
    }
  in
  begin match row_path with None -> ()
  | Some p -> set_fixed_row env sdecl.ptype_loc p decl
  end;
  begin match Ctype.closed_type_decl decl with None -> ()
  | Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
  end;
  let decl = name_recursion sdecl id decl in
  let type_variance =
    compute_variance_decl env true decl
      (add_injectivity (List.map snd sdecl.ptype_params), sdecl.ptype_loc)
  in
  let type_immediate = compute_immediacy env decl in
  let decl = {decl with type_variance; type_immediate} in
  Ctype.end_def();
  generalize_decl decl;
  {
    typ_id = id;
    typ_name = sdecl.ptype_name;
    typ_params = tparams;
    typ_type = decl;
    typ_cstrs = constraints;
    typ_loc = sdecl.ptype_loc;
    typ_manifest = tman;
    typ_kind = Ttype_abstract;
    typ_private = sdecl.ptype_private;
    typ_attributes = sdecl.ptype_attributes;
  }

(* Approximate a type declaration: just make all types abstract *)

let abstract_type_decl arity =
  let rec make_params n =
    if n <= 0 then [] else Ctype.newvar() :: make_params (n-1) in
  Ctype.begin_def();
  let decl =
    { type_params = make_params arity;
      type_arity = arity;
      type_kind = Type_abstract;
      type_private = Public;
      type_manifest = None;
      type_variance = replicate_list Variance.full arity;
      type_newtype_level = None;
      type_loc = Location.none;
      type_attributes = [];
      type_immediate = false;
      type_unboxed = unboxed_false_default_false;
     } in
  Ctype.end_def();
  generalize_decl decl;
  decl

let approx_type_decl sdecl_list =
  List.map
    (fun sdecl ->
      (Ident.create sdecl.ptype_name.txt,
       abstract_type_decl (List.length sdecl.ptype_params)))
    sdecl_list

(* Variant of check_abbrev_recursion to check the well-formedness
   conditions on type abbreviations defined within recursive modules. *)

let check_recmod_typedecl env loc recmod_ids path decl =
  (* recmod_ids is the list of recursively-defined module idents.
     (path, decl) is the type declaration to be checked. *)
  let to_check path =
    List.exists (fun id -> Path.isfree id path) recmod_ids in
  check_well_founded_decl env loc path decl to_check;
  check_recursion env loc path decl to_check


(**** Error report ****)

open Format

let explain_unbound_gen ppf tv tl typ kwd pr =
  try
    let ti = List.find (fun ti -> Ctype.deep_occur tv (typ ti)) tl in
    let ty0 = (* Hack to force aliasing when needed *)
      Btype.newgenty (Tobject(tv, ref None)) in
    Printtyp.reset_and_mark_loops_list [typ ti; ty0];
    fprintf ppf
      ".@.@[<hov2>In %s@ %a@;<1 -2>the variable %a is unbound@]"
      kwd pr ti Printtyp.type_expr tv
  with Not_found -> ()

let explain_unbound ppf tv tl typ kwd lab =
  explain_unbound_gen ppf tv tl typ kwd
    (fun ppf ti -> fprintf ppf "%s%a" (lab ti) Printtyp.type_expr (typ ti))

let explain_unbound_single ppf tv ty =
  let trivial ty =
    explain_unbound ppf tv [ty] (fun t -> t) "type" (fun _ -> "") in
  match (Ctype.repr ty).desc with
    Tobject(fi,_) ->
      let (tl, rv) = Ctype.flatten_fields fi in
      if rv == tv then trivial ty else
      explain_unbound ppf tv tl (fun (_,_,t) -> t)
        "method" (fun (lab,_,_) -> lab ^ ": ")
  | Tvariant row ->
      let row = Btype.row_repr row in
      if row.row_more == tv then trivial ty else
      explain_unbound ppf tv row.row_fields
        (fun (_l,f) -> match Btype.row_field_repr f with
          Rpresent (Some t) -> t
        | Reither (_,[t],_,_) -> t
        | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl)
        | _ -> Btype.newgenty (Ttuple[]))
        "case" (fun (lab,_) -> "`" ^ lab ^ " of ")
  | _ -> trivial ty


let tys_of_constr_args = function
  | Types.Cstr_tuple tl -> tl
  | Types.Cstr_record lbls -> List.map (fun l -> l.Types.ld_type) lbls

let report_error ppf = function
  | Repeated_parameter ->
      fprintf ppf "A type parameter occurs several times"
  | Duplicate_constructor s ->
      fprintf ppf "Two constructors are named %s" s
  | Too_many_constructors ->
      fprintf ppf
        "@[Too many non-constant constructors@ -- maximum is %i %s@]"
        (Config.max_tag + 1) "non-constant constructors"
  | Duplicate_label s ->
      fprintf ppf "Two labels are named %s" s
  | Recursive_abbrev s ->
      fprintf ppf "The type abbreviation %s is cyclic" s
  | Cycle_in_def (s, ty) ->
      Printtyp.reset_and_mark_loops ty;
      fprintf ppf "@[<v>The definition of %s contains a cycle:@ %a@]"
        s Printtyp.type_expr ty
  | Definition_mismatch (ty, errs) ->
      Printtyp.reset_and_mark_loops ty;
      fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%a@]%a@]"
        "This variant or record definition" "does not match that of type"
        Printtyp.type_expr ty
        (Includecore.report_type_mismatch "the original" "this" "definition")
        errs
  | Constraint_failed (ty, ty') ->
      Printtyp.reset_and_mark_loops ty;
      Printtyp.mark_loops ty';
      fprintf ppf "@[%s@ @[<hv>Type@ %a@ should be an instance of@ %a@]@]"
        "Constraints are not satisfied in this type."
        Printtyp.type_expr ty Printtyp.type_expr ty'
  | Parameters_differ (path, ty, ty') ->
      Printtyp.reset_and_mark_loops ty;
      Printtyp.mark_loops ty';
      fprintf ppf
        "@[<hv>In the definition of %s, type@ %a@ should be@ %a@]"
        (Path.name path) Printtyp.type_expr ty Printtyp.type_expr ty'
  | Inconsistent_constraint (env, trace) ->
      fprintf ppf "The type constraints are not consistent.@.";
      Printtyp.report_unification_error ppf env trace
        (fun ppf -> fprintf ppf "Type")
        (fun ppf -> fprintf ppf "is not compatible with type")
  | Type_clash (env, trace) ->
      Printtyp.report_unification_error ppf env trace
        (function ppf ->
           fprintf ppf "This type constructor expands to type")
        (function ppf ->
           fprintf ppf "but is used here with type")
  | Null_arity_external ->
      fprintf ppf "External identifiers must be functions"
  | Missing_native_external ->
      fprintf ppf "@[<hv>An external function with more than 5 arguments \
                   requires a second stub function@ \
                   for native-code compilation@]"
  | Unbound_type_var (ty, decl) ->
      fprintf ppf "A type variable is unbound in this type declaration";
      let ty = Ctype.repr ty in
      begin match decl.type_kind, decl.type_manifest with
      | Type_variant tl, _ ->
          explain_unbound_gen ppf ty tl (fun c ->
              let tl = tys_of_constr_args c.Types.cd_args in
              Btype.newgenty (Ttuple tl)
            )
            "case" (fun ppf c ->
                fprintf ppf
                  "%s of %a" (Ident.name c.Types.cd_id)
                  Printtyp.constructor_arguments c.Types.cd_args)
      | Type_record (tl, _), _ ->
          explain_unbound ppf ty tl (fun l -> l.Types.ld_type)
            "field" (fun l -> Ident.name l.Types.ld_id ^ ": ")
      | Type_abstract, Some ty' ->
          explain_unbound_single ppf ty ty'
      | _ -> ()
      end
  | Unbound_type_var_ext (ty, ext) ->
      fprintf ppf "A type variable is unbound in this extension constructor";
      let args = tys_of_constr_args ext.ext_args in
      explain_unbound ppf ty args (fun c -> c) "type" (fun _ -> "")
  | Cannot_extend_private_type path ->
      fprintf ppf "@[%s@ %a@]"
        "Cannot extend private type definition"
        Printtyp.path path
  | Not_extensible_type path ->
      fprintf ppf "@[%s@ %a@ %s@]"
        "Type definition"
        Printtyp.path path
        "is not extensible"
  | Extension_mismatch (path, errs) ->
      fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%s@]%a@]"
        "This extension" "does not match the definition of type"
        (Path.name path)
        (Includecore.report_type_mismatch
           "the type" "this extension" "definition")
        errs
  | Rebind_wrong_type (lid, env, trace) ->
      Printtyp.report_unification_error ppf env trace
        (function ppf ->
          fprintf ppf "The constructor %a@ has type"
            Printtyp.longident lid)
        (function ppf ->
           fprintf ppf "but was expected to be of type")
  | Rebind_mismatch (lid, p, p') ->
      fprintf ppf
        "@[%s@ %a@ %s@ %s@ %s@ %s@ %s@]"
        "The constructor" Printtyp.longident lid
        "extends type" (Path.name p)
        "whose declaration does not match"
        "the declaration of type" (Path.name p')
  | Rebind_private lid ->
      fprintf ppf "@[%s@ %a@ %s@]"
        "The constructor"
        Printtyp.longident lid
        "is private"
  | Bad_variance (n, v1, v2) ->
      let variance (p,n,i) =
        let inj = if i then "injective " else "" in
        match p, n with
          true,  true  -> inj ^ "invariant"
        | true,  false -> inj ^ "covariant"
        | false, true  -> inj ^ "contravariant"
        | false, false -> if inj = "" then "unrestricted" else inj
      in
      let suffix n =
        let teen = (n mod 100)/10 = 1 in
        match n mod 10 with
        | 1 when not teen -> "st"
        | 2 when not teen -> "nd"
        | 3 when not teen -> "rd"
        | _ -> "th"
      in
      if n = -1 then
        fprintf ppf "@[%s@ %s@ It"
          "In this definition, a type variable has a variance that"
          "is not reflected by its occurrence in type parameters."
      else if n = -2 then
        fprintf ppf "@[%s@ %s@]"
          "In this definition, a type variable cannot be deduced"
          "from the type parameters."
      else if n = -3 then
        fprintf ppf "@[%s@ %s@ It"
          "In this definition, a type variable has a variance that"
          "cannot be deduced from the type parameters."
      else
        fprintf ppf "@[%s@ %s@ The %d%s type parameter"
          "In this definition, expected parameter"
          "variances are not satisfied."
          n (suffix n);
      if n <> -2 then
        fprintf ppf " was expected to be %s,@ but it is %s.@]"
          (variance v2) (variance v1)
  | Unavailable_type_constructor p ->
      fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p
  | Bad_fixed_type r ->
      fprintf ppf "This fixed type %s" r
  | Varying_anonymous ->
      fprintf ppf "@[%s@ %s@ %s@]"
        "In this GADT definition," "the variance of some parameter"
        "cannot be checked"
  | Val_in_structure ->
      fprintf ppf "Value declarations are only allowed in signatures"
  | Multiple_native_repr_attributes ->
      fprintf ppf "Too many [@@unboxed]/[@@untagged] attributes"
  | Cannot_unbox_or_untag_type Unboxed ->
      fprintf ppf "Don't know how to unbox this type. Only float, int32, \
                   int64 and nativeint can be unboxed"
  | Cannot_unbox_or_untag_type Untagged ->
      fprintf ppf "Don't know how to untag this type. Only int \
                   can be untagged"
  | Deep_unbox_or_untag_attribute kind ->
      fprintf ppf
        "The attribute '%s' should be attached to a direct argument or \
         result of the primitive, it should not occur deeply into its type"
        (match kind with Unboxed -> "@unboxed" | Untagged -> "@untagged")
  | Bad_immediate_attribute ->
      fprintf ppf "@[%s@ %s@]"
        "Types marked with the immediate attribute must be"
        "non-pointer types like int or bool"
  | Bad_unboxed_attribute msg ->
      fprintf ppf "@[This type cannot be unboxed because@ %s.@]" msg
  | Wrong_unboxed_type_float ->
      fprintf ppf "@[This type cannot be unboxed because@ \
                   it might contain both float and non-float values.@ \
                   You should annotate it with [%@%@ocaml.boxed].@]"
  | Boxed_and_unboxed ->
      fprintf ppf "@[A type cannot be boxed and unboxed at the same time.@]"
  | Nonrec_gadt ->
      fprintf ppf
        "@[GADT case syntax cannot be used in a 'nonrec' block.@]"

let () =
  Location.register_error_of_exn
    (function
      | Error (loc, err) ->
        Some (Location.error_of_printer loc report_error err)
      | _ ->
        None
    )

end
module Lambda : sig 
#1 "lambda.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* The "lambda" intermediate code *)

open Asttypes

type compile_time_constant =
  | Big_endian
  | Word_size
  | Int_size
  | Max_wosize
  | Ostype_unix
  | Ostype_win32
  | Ostype_cygwin
  | Backend_type

type loc_kind =
  | Loc_FILE
  | Loc_LINE
  | Loc_MODULE
  | Loc_LOC
  | Loc_POS

type tag_info = 
  | Blk_constructor of string * int (* Number of non-const constructors*)
  | Blk_tuple
  | Blk_array
  | Blk_variant of string 
  | Blk_record of string array
  | Blk_module of string list option
  | Blk_extension_slot
  | Blk_na
  | Blk_some
  | Blk_some_not_nested (* ['a option] where ['a] can not inhabit a non-like value *)
  | Blk_record_inlined of string array * string  * int   
  | Blk_record_ext of string array

val default_tag_info : tag_info

val ref_tag_info : tag_info

type field_dbg_info = 
  | Fld_na
  | Fld_record of string
  | Fld_module of string     
  | Fld_record_inline of string 
  | Fld_record_extension of string 
  
type set_field_dbg_info = 
  | Fld_set_na
  | Fld_record_set of string 
  | Fld_record_inline_set of string  
  | Fld_record_extension_set of string

type immediate_or_pointer =
  | Immediate
  | Pointer

type initialization_or_assignment =
  | Assignment
  (* Initialization of in heap values, like [caml_initialize] C primitive.  The
     field should not have been read before and initialization should happen
     only once. *)
  | Heap_initialization
  (* Initialization of roots only. Compiles to a simple store.
     No checks are done to preserve GC invariants.  *)
  | Root_initialization

type is_safe =
  | Safe
  | Unsafe

type pointer_info = 
  | Pt_constructor of string 
  | Pt_variant of string
  | Pt_module_alias 
  | Pt_builtin_boolean
  | Pt_shape_none   
  | Pt_na  

val default_pointer_info : pointer_info  

type primitive =
  | Pidentity
  | Pbytes_to_string
  | Pbytes_of_string
  | Pignore
  | Prevapply
  | Pdirapply
  | Ploc of loc_kind
    (* Globals *)
  | Pgetglobal of Ident.t
  | Psetglobal of Ident.t
  (* Operations on heap blocks *)
  | Pmakeblock of int * tag_info * mutable_flag * block_shape
  | Pfield of int * field_dbg_info
  | Pfield_computed
  | Psetfield of int * immediate_or_pointer * initialization_or_assignment * set_field_dbg_info
  | Psetfield_computed of immediate_or_pointer * initialization_or_assignment
  | Pfloatfield of int * field_dbg_info
  | Psetfloatfield of int * initialization_or_assignment * set_field_dbg_info
  | Pduprecord of Types.record_representation * int
  (* Force lazy values *)
  | Plazyforce
  (* External call *)
  | Pccall of Primitive.description
  (* Exceptions *)
  | Praise of raise_kind
  (* Boolean operations *)
  | Psequand | Psequor | Pnot
  (* Integer operations *)
  | Pnegint | Paddint | Psubint | Pmulint
  | Pdivint of is_safe | Pmodint of is_safe
  | Pandint | Porint | Pxorint
  | Plslint | Plsrint | Pasrint
  | Pintcomp of comparison
  | Poffsetint of int
  | Poffsetref of int
  (* Float operations *)
  | Pintoffloat | Pfloatofint
  | Pnegfloat | Pabsfloat
  | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
  | Pfloatcomp of comparison
  (* String operations *)
  | Pstringlength | Pstringrefu  | Pstringrefs
  | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
  (* Array operations *)
  | Pmakearray of array_kind * mutable_flag
  | Pduparray of array_kind * mutable_flag
  (** For [Pduparray], the argument must be an immutable array.
      The arguments of [Pduparray] give the kind and mutability of the
      array being *produced* by the duplication. *)
  | Parraylength of array_kind
  | Parrayrefu of array_kind
  | Parraysetu of array_kind
  | Parrayrefs of array_kind
  | Parraysets of array_kind
  (* Test if the argument is a block or an immediate integer *)
  | Pisint
  (* Test if the (integer) argument is outside an interval *)
  | Pisout
  (* Bitvect operations *)
  | Pbittest
  (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *)
  | Pbintofint of boxed_integer
  | Pintofbint of boxed_integer
  | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*)
  | Pnegbint of boxed_integer
  | Paddbint of boxed_integer
  | Psubbint of boxed_integer
  | Pmulbint of boxed_integer
  | Pdivbint of { size : boxed_integer; is_safe : is_safe }
  | Pmodbint of { size : boxed_integer; is_safe : is_safe }
  | Pandbint of boxed_integer
  | Porbint of boxed_integer
  | Pxorbint of boxed_integer
  | Plslbint of boxed_integer
  | Plsrbint of boxed_integer
  | Pasrbint of boxed_integer
  | Pbintcomp of boxed_integer * comparison
  (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *)
  | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout
  | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout
  (* size of the nth dimension of a big array *)
  | Pbigarraydim of int
  (* load/set 16,32,64 bits from a string: (unsafe)*)
  | Pstring_load_16 of bool
  | Pstring_load_32 of bool
  | Pstring_load_64 of bool
  | Pstring_set_16 of bool
  | Pstring_set_32 of bool
  | Pstring_set_64 of bool
  (* load/set 16,32,64 bits from a
     (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *)
  | Pbigstring_load_16 of bool
  | Pbigstring_load_32 of bool
  | Pbigstring_load_64 of bool
  | Pbigstring_set_16 of bool
  | Pbigstring_set_32 of bool
  | Pbigstring_set_64 of bool
  (* Compile time constants *)
  | Pctconst of compile_time_constant
  (* byte swap *)
  | Pbswap16
  | Pbbswap of boxed_integer
  (* Integer to external pointer *)
  | Pint_as_pointer
  (* Inhibition of optimisation *)
  | Popaque

and comparison =
    Ceq | Cneq | Clt | Cgt | Cle | Cge

and array_kind =
    Pgenarray | Paddrarray | Pintarray | Pfloatarray

and value_kind =
    Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval

and block_shape =
  value_kind list option

and boxed_integer = Primitive.boxed_integer =
    Pnativeint | Pint32 | Pint64

and bigarray_kind =
    Pbigarray_unknown
  | Pbigarray_float32 | Pbigarray_float64
  | Pbigarray_sint8 | Pbigarray_uint8
  | Pbigarray_sint16 | Pbigarray_uint16
  | Pbigarray_int32 | Pbigarray_int64
  | Pbigarray_caml_int | Pbigarray_native_int
  | Pbigarray_complex32 | Pbigarray_complex64

and bigarray_layout =
    Pbigarray_unknown_layout
  | Pbigarray_c_layout
  | Pbigarray_fortran_layout

and raise_kind =
  | Raise_regular
  | Raise_reraise
  | Raise_notrace

type structured_constant =
    Const_base of constant
  | Const_pointer of int * pointer_info
  | Const_block of int * tag_info * structured_constant list
  | Const_float_array of string list
  | Const_immstring of string

type inline_attribute =
  | Always_inline (* [@inline] or [@inline always] *)
  | Never_inline (* [@inline never] *)
  | Unroll of int (* [@unroll x] *)
  | Default_inline (* no [@inline] attribute *)

type specialise_attribute =
  | Always_specialise (* [@specialise] or [@specialise always] *)
  | Never_specialise (* [@specialise never] *)
  | Default_specialise (* no [@specialise] attribute *)

type function_kind = Curried | Tupled

type let_kind = Strict | Alias | StrictOpt | Variable
(* Meaning of kinds for let x = e in e':
    Strict: e may have side-effects; always evaluate e first
      (If e is a simple expression, e.g. a variable or constant,
       we may still substitute e'[x/e].)
    Alias: e is pure, we can substitute e'[x/e] if x has 0 or 1 occurrences
      in e'
    StrictOpt: e does not have side-effects, but depend on the store;
      we can discard e if x does not appear in e'
    Variable: the variable x is assigned later in e'
 *)

type public_info = string option (* label name *)

type meth_kind = Self | Public of public_info | Cached

type shared_code = (int * int) list     (* stack size -> code label *)

type function_attribute = {
  inline : inline_attribute;
  specialise : specialise_attribute;
  is_a_functor: bool;
  stub: bool;
}

type lambda =
    Lvar of Ident.t
  | Lconst of structured_constant
  | Lapply of lambda_apply
  | Lfunction of lfunction
  | Llet of let_kind * value_kind * Ident.t * lambda * lambda
  | Lletrec of (Ident.t * lambda) list * lambda
  | Lprim of primitive * lambda list * Location.t
  | Lswitch of lambda * lambda_switch * Location.t
(* switch on strings, clauses are sorted by string order,
   strings are pairwise distinct *)
  | Lstringswitch of
      lambda * (string * lambda) list * lambda option * Location.t
  | Lstaticraise of int * lambda list
  | Lstaticcatch of lambda * (int * Ident.t list) * lambda
  | Ltrywith of lambda * Ident.t * lambda
  | Lifthenelse of lambda * lambda * lambda
  | Lsequence of lambda * lambda
  | Lwhile of lambda * lambda
  | Lfor of Ident.t * lambda * lambda * direction_flag * lambda
  | Lassign of Ident.t * lambda
  | Lsend of meth_kind * lambda * lambda * lambda list * Location.t
  | Levent of lambda * lambda_event
  | Lifused of Ident.t * lambda

and lfunction =
  { kind: function_kind;
    params: Ident.t list;
    body: lambda;
    attr: function_attribute; (* specified with [@inline] attribute *)
    loc : Location.t; }

and lambda_apply =
  { ap_func : lambda;
    ap_args : lambda list;
    ap_loc : Location.t;
    ap_should_be_tailcall : bool;       (* true if [@tailcall] was specified *)
    ap_inlined : inline_attribute; (* specified with the [@inlined] attribute *)
    ap_specialised : specialise_attribute; }

and lambda_switch =
  { sw_numconsts: int;                  (* Number of integer cases *)
    sw_consts: (int * lambda) list;     (* Integer cases *)
    sw_numblocks: int;                  (* Number of tag block cases *)
    sw_blocks: (int * lambda) list;     (* Tag block cases *)
    sw_failaction : lambda option}      (* Action to take if failure *)
and lambda_event =
  { lev_loc: Location.t;
    lev_kind: lambda_event_kind;
    lev_repr: int ref option;
    lev_env: Env.summary }

and lambda_event_kind =
    Lev_before
  | Lev_after of Types.type_expr
  | Lev_function
  | Lev_pseudo
  | Lev_module_definition of Ident.t

type program =
  { module_ident : Ident.t;
    main_module_block_size : int;
    required_globals : Ident.Set.t;    (* Modules whose initializer side effects
                                          must occur before [code]. *)
    code : lambda }
(* Lambda code for the middle-end.
   * In the closure case the code is a sequence of assignments to a
     preallocated block of size [main_module_block_size] using
     (Setfield(Getglobal(module_ident))). The size is used to preallocate
     the block.
   * In the flambda case the code is an expression returning a block
     value of size [main_module_block_size]. The size is used to build
     the module root as an initialize_symbol
     Initialize_symbol(module_name, 0,
       [getfield 0; ...; getfield (main_module_block_size - 1)])
*)

(* Sharing key *)
val make_key: lambda -> lambda option

val const_unit: structured_constant
val lambda_assert_false: lambda
val lambda_unit: lambda
val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda
val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda

val iter: (lambda -> unit) -> lambda -> unit
module IdentSet: Set.S with type elt = Ident.t
val free_variables: lambda -> IdentSet.t
val free_methods: lambda -> IdentSet.t

val transl_normal_path: Path.t -> lambda   (* Path.t is already normal *)
val transl_path: ?loc:Location.t -> Env.t -> Path.t -> lambda
[@@ocaml.deprecated "use transl_{module,value,extension,class}_path instead"]

val transl_module_path: ?loc:Location.t -> Env.t -> Path.t -> lambda
val transl_value_path: ?loc:Location.t -> Env.t -> Path.t -> lambda
val transl_extension_path: ?loc:Location.t -> Env.t -> Path.t -> lambda
val transl_class_path: ?loc:Location.t -> Env.t -> Path.t -> lambda

val make_sequence: ('a -> lambda) -> 'a list -> lambda

val subst_lambda: lambda Ident.tbl -> lambda -> lambda
val map : (lambda -> lambda) -> lambda -> lambda
val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda

val commute_comparison : comparison -> comparison
val negate_comparison : comparison -> comparison

val default_function_attribute : function_attribute
val default_stub_attribute : function_attribute

(***********************)
(* For static failures *)
(***********************)

(* Get a new static failure ident *)
val next_raise_count : unit -> int
val next_negative_raise_count : unit -> int
  (* Negative raise counts are used to compile 'match ... with
     exception x -> ...'.  This disabled some simplifications
     performed by the Simplif module that assume that static raises
     are in tail position in their handler. *)

val staticfail : lambda (* Anticipated static failure *)

(* Check anticipated failure, substitute its final value *)
val is_guarded: lambda -> bool
val patch_guarded : lambda -> lambda -> lambda

val raise_kind: raise_kind -> string
val lam_of_loc : loc_kind -> Location.t -> lambda

val merge_inline_attributes
   : inline_attribute
  -> inline_attribute
  -> inline_attribute option

val reset: unit -> unit

end = struct
#1 "lambda.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Misc
open Path
open Asttypes

type compile_time_constant =
  | Big_endian
  | Word_size
  | Int_size
  | Max_wosize
  | Ostype_unix
  | Ostype_win32
  | Ostype_cygwin
  | Backend_type

type loc_kind =
  | Loc_FILE
  | Loc_LINE
  | Loc_MODULE
  | Loc_LOC
  | Loc_POS

type tag_info = 
  | Blk_constructor of string * int (* Number of non-const constructors*)
  | Blk_tuple
  | Blk_array
  | Blk_variant of string 
  | Blk_record of string array
  | Blk_module of string list option
  | Blk_extension_slot
  | Blk_na
  | Blk_some
  | Blk_some_not_nested (* ['a option] where ['a] can not inhabit a non-like value *)
  | Blk_record_inlined of string array * string * int 
  | Blk_record_ext of string array

let default_tag_info : tag_info = Blk_na

let ref_tag_info : tag_info = Blk_record [| "contents" |]
  
type field_dbg_info = 
  | Fld_na
  | Fld_record of string
  | Fld_module of string     
  | Fld_record_inline of string   
  | Fld_record_extension of string 
  
type set_field_dbg_info = 
    | Fld_set_na
    | Fld_record_set of string 
    | Fld_record_inline_set of string
    | Fld_record_extension_set of string

type immediate_or_pointer =
  | Immediate
  | Pointer

type initialization_or_assignment =
  | Assignment
  | Heap_initialization
  | Root_initialization

type is_safe =
  | Safe
  | Unsafe

type primitive =
  | Pidentity
  | Pbytes_to_string
  | Pbytes_of_string
  | Pignore
  | Prevapply
  | Pdirapply
  | Ploc of loc_kind
    (* Globals *)
  | Pgetglobal of Ident.t
  | Psetglobal of Ident.t
  (* Operations on heap blocks *)
  | Pmakeblock of int * tag_info * mutable_flag * block_shape
  | Pfield of int * field_dbg_info
  | Pfield_computed
  | Psetfield of int * immediate_or_pointer * initialization_or_assignment * set_field_dbg_info
  | Psetfield_computed of immediate_or_pointer * initialization_or_assignment
  | Pfloatfield of int * field_dbg_info
  | Psetfloatfield of int * initialization_or_assignment * set_field_dbg_info
  | Pduprecord of Types.record_representation * int
  (* Force lazy values *)
  | Plazyforce
  (* External call *)
  | Pccall of Primitive.description
  (* Exceptions *)
  | Praise of raise_kind
  (* Boolean operations *)
  | Psequand | Psequor | Pnot
  (* Integer operations *)
  | Pnegint | Paddint | Psubint | Pmulint
  | Pdivint of is_safe | Pmodint of is_safe
  | Pandint | Porint | Pxorint
  | Plslint | Plsrint | Pasrint
  | Pintcomp of comparison
  | Poffsetint of int
  | Poffsetref of int
  (* Float operations *)
  | Pintoffloat | Pfloatofint
  | Pnegfloat | Pabsfloat
  | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
  | Pfloatcomp of comparison
  (* String operations *)
  | Pstringlength | Pstringrefu  | Pstringrefs
  | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
  (* Array operations *)
  | Pmakearray of array_kind * mutable_flag
  | Pduparray of array_kind * mutable_flag
  | Parraylength of array_kind
  | Parrayrefu of array_kind
  | Parraysetu of array_kind
  | Parrayrefs of array_kind
  | Parraysets of array_kind
  (* Test if the argument is a block or an immediate integer *)
  | Pisint
  (* Test if the (integer) argument is outside an interval *)
  | Pisout
  (* Bitvect operations *)
  | Pbittest
  (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *)
  | Pbintofint of boxed_integer
  | Pintofbint of boxed_integer
  | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*)
  | Pnegbint of boxed_integer
  | Paddbint of boxed_integer
  | Psubbint of boxed_integer
  | Pmulbint of boxed_integer
  | Pdivbint of { size : boxed_integer; is_safe : is_safe }
  | Pmodbint of { size : boxed_integer; is_safe : is_safe }
  | Pandbint of boxed_integer
  | Porbint of boxed_integer
  | Pxorbint of boxed_integer
  | Plslbint of boxed_integer
  | Plsrbint of boxed_integer
  | Pasrbint of boxed_integer
  | Pbintcomp of boxed_integer * comparison
  (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *)
  | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout
  | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout
  (* size of the nth dimension of a big array *)
  | Pbigarraydim of int
  (* load/set 16,32,64 bits from a string: (unsafe)*)
  | Pstring_load_16 of bool
  | Pstring_load_32 of bool
  | Pstring_load_64 of bool
  | Pstring_set_16 of bool
  | Pstring_set_32 of bool
  | Pstring_set_64 of bool
  (* load/set 16,32,64 bits from a
     (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *)
  | Pbigstring_load_16 of bool
  | Pbigstring_load_32 of bool
  | Pbigstring_load_64 of bool
  | Pbigstring_set_16 of bool
  | Pbigstring_set_32 of bool
  | Pbigstring_set_64 of bool
  (* Compile time constants *)
  | Pctconst of compile_time_constant
  (* byte swap *)
  | Pbswap16
  | Pbbswap of boxed_integer
  (* Integer to external pointer *)
  | Pint_as_pointer
  (* Inhibition of optimisation *)
  | Popaque

and comparison =
    Ceq | Cneq | Clt | Cgt | Cle | Cge

and value_kind =
    Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval

and block_shape =
  value_kind list option

and array_kind =
    Pgenarray | Paddrarray | Pintarray | Pfloatarray

and boxed_integer = Primitive.boxed_integer =
    Pnativeint | Pint32 | Pint64

and bigarray_kind =
    Pbigarray_unknown
  | Pbigarray_float32 | Pbigarray_float64
  | Pbigarray_sint8 | Pbigarray_uint8
  | Pbigarray_sint16 | Pbigarray_uint16
  | Pbigarray_int32 | Pbigarray_int64
  | Pbigarray_caml_int | Pbigarray_native_int
  | Pbigarray_complex32 | Pbigarray_complex64

and bigarray_layout =
    Pbigarray_unknown_layout
  | Pbigarray_c_layout
  | Pbigarray_fortran_layout

and raise_kind =
  | Raise_regular
  | Raise_reraise
  | Raise_notrace

type pointer_info = 
  | Pt_constructor of string 
  | Pt_variant of string
  | Pt_module_alias 
  | Pt_builtin_boolean  
  | Pt_shape_none   
  | Pt_na 

let default_pointer_info = Pt_na
  
type structured_constant =
    Const_base of constant
  | Const_pointer of int * pointer_info
  | Const_block of int * tag_info * structured_constant list
  | Const_float_array of string list
  | Const_immstring of string


type inline_attribute =
  | Always_inline (* [@inline] or [@inline always] *)
  | Never_inline (* [@inline never] *)
  | Unroll of int (* [@unroll x] *)
  | Default_inline (* no [@inline] attribute *)

type specialise_attribute =
  | Always_specialise (* [@specialise] or [@specialise always] *)
  | Never_specialise (* [@specialise never] *)
  | Default_specialise (* no [@specialise] attribute *)

type function_kind = Curried | Tupled

type let_kind = Strict | Alias | StrictOpt | Variable

type public_info = string option (* label name *)

type meth_kind = Self | Public of public_info | Cached

type shared_code = (int * int) list

type function_attribute = {
  inline : inline_attribute;
  specialise : specialise_attribute;
  is_a_functor: bool;
  stub: bool;
}

type lambda =
    Lvar of Ident.t
  | Lconst of structured_constant
  | Lapply of lambda_apply
  | Lfunction of lfunction
  | Llet of let_kind * value_kind * Ident.t * lambda * lambda
  | Lletrec of (Ident.t * lambda) list * lambda
  | Lprim of primitive * lambda list * Location.t
  | Lswitch of lambda * lambda_switch * Location.t
  | Lstringswitch of
      lambda * (string * lambda) list * lambda option * Location.t
  | Lstaticraise of int * lambda list
  | Lstaticcatch of lambda * (int * Ident.t list) * lambda
  | Ltrywith of lambda * Ident.t * lambda
  | Lifthenelse of lambda * lambda * lambda
  | Lsequence of lambda * lambda
  | Lwhile of lambda * lambda
  | Lfor of Ident.t * lambda * lambda * direction_flag * lambda
  | Lassign of Ident.t * lambda
  | Lsend of meth_kind * lambda * lambda * lambda list * Location.t
  | Levent of lambda * lambda_event
  | Lifused of Ident.t * lambda

and lfunction =
  { kind: function_kind;
    params: Ident.t list;
    body: lambda;
    attr: function_attribute; (* specified with [@inline] attribute *)
    loc: Location.t; }

and lambda_apply =
  { ap_func : lambda;
    ap_args : lambda list;
    ap_loc : Location.t;
    ap_should_be_tailcall : bool;
    ap_inlined : inline_attribute;
    ap_specialised : specialise_attribute; }

and lambda_switch =
  { sw_numconsts: int;
    sw_consts: (int * lambda) list;
    sw_numblocks: int;
    sw_blocks: (int * lambda) list;
    sw_failaction : lambda option}

and lambda_event =
  { lev_loc: Location.t;
    lev_kind: lambda_event_kind;
    lev_repr: int ref option;
    lev_env: Env.summary }

and lambda_event_kind =
    Lev_before
  | Lev_after of Types.type_expr
  | Lev_function
  | Lev_pseudo
  | Lev_module_definition of Ident.t

type program =
  { module_ident : Ident.t;
    main_module_block_size : int;
    required_globals : Ident.Set.t;
    code : lambda }

let const_unit = Const_pointer(0, default_pointer_info)

let lambda_assert_false = Lconst (Const_pointer(0, Pt_constructor "assert false"))  


let lambda_unit = Lconst const_unit

let default_function_attribute = {
  inline = Default_inline;
  specialise = Default_specialise;
  is_a_functor = false;
  stub = false;
}

let default_stub_attribute =
  { default_function_attribute with stub = true }

(* Build sharing keys *)
(*
   Those keys are later compared with Pervasives.compare.
   For that reason, they should not include cycles.
*)

exception Not_simple

let max_raw = 32

let make_key e =
  let count = ref 0   (* Used for controling size *)
  and make_key = Ident.make_key_generator () in
  (* make_key is used for normalizing let-bound variables *)
  let rec tr_rec env e =
    incr count ;
    if !count > max_raw then raise Not_simple ; (* Too big ! *)
    match e with
    | Lvar id ->
      begin
        try Ident.find_same id env
        with Not_found -> e
      end
    | Lconst  (Const_base (Const_string _)) ->
        (* Mutable constants are not shared *)
        raise Not_simple
    | Lconst _ -> e
    | Lapply ap ->
        Lapply {ap with ap_func = tr_rec env ap.ap_func;
                        ap_args = tr_recs env ap.ap_args;
                        ap_loc = Location.none}
    | Llet (Alias,_k,x,ex,e) -> (* Ignore aliases -> substitute *)
        let ex = tr_rec env ex in
        tr_rec (Ident.add x ex env) e
    | Llet ((Strict | StrictOpt),_k,x,ex,Lvar v) when Ident.same v x ->
        tr_rec env ex
    | Llet (str,k,x,ex,e) ->
     (* Because of side effects, keep other lets with normalized names *)
        let ex = tr_rec env ex in
        let y = make_key x in
        Llet (str,k,y,ex,tr_rec (Ident.add x (Lvar y) env) e)
    | Lprim (p,es,_) ->
        Lprim (p,tr_recs env es, Location.none)
    | Lswitch (e,sw,loc) ->
        Lswitch (tr_rec env e,tr_sw env sw,loc)
    | Lstringswitch (e,sw,d,_) ->
        Lstringswitch
          (tr_rec env e,
           List.map (fun (s,e) -> s,tr_rec env e) sw,
           tr_opt env d,
          Location.none)
    | Lstaticraise (i,es) ->
        Lstaticraise (i,tr_recs env es)
    | Lstaticcatch (e1,xs,e2) ->
        Lstaticcatch (tr_rec env e1,xs,tr_rec env e2)
    | Ltrywith (e1,x,e2) ->
        Ltrywith (tr_rec env e1,x,tr_rec env e2)
    | Lifthenelse (cond,ifso,ifnot) ->
        Lifthenelse (tr_rec env cond,tr_rec env ifso,tr_rec env ifnot)
    | Lsequence (e1,e2) ->
        Lsequence (tr_rec env e1,tr_rec env e2)
    | Lassign (x,e) ->
        Lassign (x,tr_rec env e)
    | Lsend (m,e1,e2,es,_loc) ->
        Lsend (m,tr_rec env e1,tr_rec env e2,tr_recs env es,Location.none)
    | Lifused (id,e) -> Lifused (id,tr_rec env e)
    | Lletrec _|Lfunction _
    | Lfor _ | Lwhile _
(* Beware: (PR#6412) the event argument to Levent
   may include cyclic structure of type Type.typexpr *)
    | Levent _  ->
        raise Not_simple

  and tr_recs env es = List.map (tr_rec env) es

  and tr_sw env sw =
    { sw with
      sw_consts = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_consts ;
      sw_blocks = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_blocks ;
      sw_failaction = tr_opt env sw.sw_failaction ; }

  and tr_opt env = function
    | None -> None
    | Some e -> Some (tr_rec env e) in

  try
    Some (tr_rec Ident.empty e)
  with Not_simple -> None

(***************)

let name_lambda strict arg fn =
  match arg with
    Lvar id -> fn id
  | _ -> let id = Ident.create "let" in Llet(strict, Pgenval, id, arg, fn id)

let name_lambda_list args fn =
  let rec name_list names = function
    [] -> fn (List.rev names)
  | (Lvar _ as arg) :: rem ->
      name_list (arg :: names) rem
  | arg :: rem ->
      let id = Ident.create "let" in
      Llet(Strict, Pgenval, id, arg, name_list (Lvar id :: names) rem) in
  name_list [] args


let iter_opt f = function
  | None -> ()
  | Some e -> f e

let iter f = function
    Lvar _
  | Lconst _ -> ()
  | Lapply{ap_func = fn; ap_args = args} ->
      f fn; List.iter f args
  | Lfunction{body} ->
      f body
  | Llet(_str, _k, _id, arg, body) ->
      f arg; f body
  | Lletrec(decl, body) ->
      f body;
      List.iter (fun (_id, exp) -> f exp) decl
  | Lprim(_p, args, _loc) ->
      List.iter f args
  | Lswitch(arg, sw,_) ->
      f arg;
      List.iter (fun (_key, case) -> f case) sw.sw_consts;
      List.iter (fun (_key, case) -> f case) sw.sw_blocks;
      iter_opt f sw.sw_failaction
  | Lstringswitch (arg,cases,default,_) ->
      f arg ;
      List.iter (fun (_,act) -> f act) cases ;
      iter_opt f default
  | Lstaticraise (_,args) ->
      List.iter f args
  | Lstaticcatch(e1, _, e2) ->
      f e1; f e2
  | Ltrywith(e1, _, e2) ->
      f e1; f e2
  | Lifthenelse(e1, e2, e3) ->
      f e1; f e2; f e3
  | Lsequence(e1, e2) ->
      f e1; f e2
  | Lwhile(e1, e2) ->
      f e1; f e2
  | Lfor(_v, e1, e2, _dir, e3) ->
      f e1; f e2; f e3
  | Lassign(_, e) ->
      f e
  | Lsend (_k, met, obj, args, _) ->
      List.iter f (met::obj::args)
  | Levent (lam, _evt) ->
      f lam
  | Lifused (_v, e) ->
      f e


module IdentSet = Set.Make(Ident)

let free_ids get l =
  let fv = ref IdentSet.empty in
  let rec free l =
    iter free l;
    fv := List.fold_right IdentSet.add (get l) !fv;
    match l with
      Lfunction{params} ->
        List.iter (fun param -> fv := IdentSet.remove param !fv) params
    | Llet(_str, _k, id, _arg, _body) ->
        fv := IdentSet.remove id !fv
    | Lletrec(decl, _body) ->
        List.iter (fun (id, _exp) -> fv := IdentSet.remove id !fv) decl
    | Lstaticcatch(_e1, (_,vars), _e2) ->
        List.iter (fun id -> fv := IdentSet.remove id !fv) vars
    | Ltrywith(_e1, exn, _e2) ->
        fv := IdentSet.remove exn !fv
    | Lfor(v, _e1, _e2, _dir, _e3) ->
        fv := IdentSet.remove v !fv
    | Lassign(id, _e) ->
        fv := IdentSet.add id !fv
    | Lvar _ | Lconst _ | Lapply _
    | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _
    | Lifthenelse _ | Lsequence _ | Lwhile _
    | Lsend _ | Levent _ | Lifused _ -> ()
  in free l; !fv

let free_variables l =
  free_ids (function Lvar id -> [id] | _ -> []) l

let free_methods l =
  free_ids (function Lsend(Self, Lvar meth, _, _, _) -> [meth] | _ -> []) l

(* Check if an action has a "when" guard *)
let raise_count = ref 0

let next_raise_count () =
  incr raise_count ;
  !raise_count

let negative_raise_count = ref 0

let next_negative_raise_count () =
  decr negative_raise_count ;
  !negative_raise_count

(* Anticipated staticraise, for guards *)
let staticfail = Lstaticraise (0,[])

let rec is_guarded = function
  | Lifthenelse(_cond, _body, Lstaticraise (0,[])) -> true
  | Llet(_str, _k, _id, _lam, body) -> is_guarded body
  | Levent(lam, _ev) -> is_guarded lam
  | _ -> false

let rec patch_guarded patch = function
  | Lifthenelse (cond, body, Lstaticraise (0,[])) ->
      Lifthenelse (cond, body, patch)
  | Llet(str, k, id, lam, body) ->
      Llet (str, k, id, lam, patch_guarded patch body)
  | Levent(lam, ev) ->
      Levent (patch_guarded patch lam, ev)
  | _ -> fatal_error "Lambda.patch_guarded"

(* Translate an access path *)

let rec transl_normal_path = function
    Pident id ->
      if Ident.global id
      then Lprim(Pgetglobal id, [], Location.none)
      else Lvar id
  | Pdot(p, s, pos) ->
      Lprim(Pfield (pos, Fld_module s), [transl_normal_path p], Location.none)
  | Papply _ ->
      fatal_error "Lambda.transl_path"

(* Translation of identifiers *)

let transl_module_path ?(loc=Location.none) env path =
  transl_normal_path (Env.normalize_path (Some loc) env path)

let transl_value_path ?(loc=Location.none) env path =
  transl_normal_path (Env.normalize_path_prefix (Some loc) env path)

let transl_class_path = transl_value_path
let transl_extension_path = transl_value_path

(* compatibility alias, deprecated in the .mli *)
let transl_path = transl_value_path

(* Compile a sequence of expressions *)

let rec make_sequence fn = function
    [] -> lambda_unit
  | [x] -> fn x
  | x::rem ->
      let lam = fn x in Lsequence(lam, make_sequence fn rem)

(* Apply a substitution to a lambda-term.
   Assumes that the bound variables of the lambda-term do not
   belong to the domain of the substitution.
   Assumes that the image of the substitution is out of reach
   of the bound variables of the lambda-term (no capture). *)

let subst_lambda s lam =
  let rec subst = function
    Lvar id as l ->
      begin try Ident.find_same id s with Not_found -> l end
  | Lconst _ as l -> l
  | Lapply ap ->
      Lapply{ap with ap_func = subst ap.ap_func;
                     ap_args = List.map subst ap.ap_args}
  | Lfunction{kind; params; body; attr; loc} ->
      Lfunction{kind; params; body = subst body; attr; loc}
  | Llet(str, k, id, arg, body) -> Llet(str, k, id, subst arg, subst body)
  | Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body)
  | Lprim(p, args, loc) -> Lprim(p, List.map subst args, loc)
  | Lswitch(arg, sw, loc) ->
      Lswitch(subst arg,
              {sw with sw_consts = List.map subst_case sw.sw_consts;
                       sw_blocks = List.map subst_case sw.sw_blocks;
                       sw_failaction = subst_opt  sw.sw_failaction; },
              loc)
  | Lstringswitch (arg,cases,default,loc) ->
      Lstringswitch
        (subst arg,List.map subst_strcase cases,subst_opt default,loc)
  | Lstaticraise (i,args) ->  Lstaticraise (i, List.map subst args)
  | Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2)
  | Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2)
  | Lifthenelse(e1, e2, e3) -> Lifthenelse(subst e1, subst e2, subst e3)
  | Lsequence(e1, e2) -> Lsequence(subst e1, subst e2)
  | Lwhile(e1, e2) -> Lwhile(subst e1, subst e2)
  | Lfor(v, e1, e2, dir, e3) -> Lfor(v, subst e1, subst e2, dir, subst e3)
  | Lassign(id, e) -> Lassign(id, subst e)
  | Lsend (k, met, obj, args, loc) ->
      Lsend (k, subst met, subst obj, List.map subst args, loc)
  | Levent (lam, evt) -> Levent (subst lam, evt)
  | Lifused (v, e) -> Lifused (v, subst e)
  and subst_decl (id, exp) = (id, subst exp)
  and subst_case (key, case) = (key, subst case)
  and subst_strcase (key, case) = (key, subst case)
  and subst_opt = function
    | None -> None
    | Some e -> Some (subst e)
  in subst lam

let rec map f lam =
  let lam =
    match lam with
    | Lvar _ -> lam
    | Lconst _ -> lam
    | Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall;
          ap_inlined; ap_specialised } ->
        Lapply {
          ap_func = map f ap_func;
          ap_args = List.map (map f) ap_args;
          ap_loc;
          ap_should_be_tailcall;
          ap_inlined;
          ap_specialised;
        }
    | Lfunction { kind; params; body; attr; loc; } ->
        Lfunction { kind; params; body = map f body; attr; loc; }
    | Llet (str, k, v, e1, e2) ->
        Llet (str, k, v, map f e1, map f e2)
    | Lletrec (idel, e2) ->
        Lletrec (List.map (fun (v, e) -> (v, map f e)) idel, map f e2)
    | Lprim (p, el, loc) ->
        Lprim (p, List.map (map f) el, loc)
    | Lswitch (e, sw, loc) ->
        Lswitch (map f e,
          { sw_numconsts = sw.sw_numconsts;
            sw_consts = List.map (fun (n, e) -> (n, map f e)) sw.sw_consts;
            sw_numblocks = sw.sw_numblocks;
            sw_blocks = List.map (fun (n, e) -> (n, map f e)) sw.sw_blocks;
            sw_failaction = Misc.may_map (map f) sw.sw_failaction;
          },
          loc)
    | Lstringswitch (e, sw, default, loc) ->
        Lstringswitch (
          map f e,
          List.map (fun (s, e) -> (s, map f e)) sw,
          Misc.may_map (map f) default,
          loc)
    | Lstaticraise (i, args) ->
        Lstaticraise (i, List.map (map f) args)
    | Lstaticcatch (body, id, handler) ->
        Lstaticcatch (map f body, id, map f handler)
    | Ltrywith (e1, v, e2) ->
        Ltrywith (map f e1, v, map f e2)
    | Lifthenelse (e1, e2, e3) ->
        Lifthenelse (map f e1, map f e2, map f e3)
    | Lsequence (e1, e2) ->
        Lsequence (map f e1, map f e2)
    | Lwhile (e1, e2) ->
        Lwhile (map f e1, map f e2)
    | Lfor (v, e1, e2, dir, e3) ->
        Lfor (v, map f e1, map f e2, dir, map f e3)
    | Lassign (v, e) ->
        Lassign (v, map f e)
    | Lsend (k, m, o, el, loc) ->
        Lsend (k, map f m, map f o, List.map (map f) el, loc)
    | Levent (l, ev) ->
        Levent (map f l, ev)
    | Lifused (v, e) ->
        Lifused (v, map f e)
  in
  f lam

(* To let-bind expressions to variables *)

let bind str var exp body =
  match exp with
    Lvar var' when Ident.same var var' -> body
  | _ -> Llet(str, Pgenval, var, exp, body)

and commute_comparison = function
| Ceq -> Ceq| Cneq -> Cneq
| Clt -> Cgt | Cle -> Cge
| Cgt -> Clt | Cge -> Cle

and negate_comparison = function
| Ceq -> Cneq| Cneq -> Ceq
| Clt -> Cge | Cle -> Cgt
| Cgt -> Cle | Cge -> Clt

let raise_kind = function
  | Raise_regular -> "raise"
  | Raise_reraise -> "reraise"
  | Raise_notrace -> "raise_notrace"

let lam_of_loc kind loc =
  let loc_start = loc.Location.loc_start in
  let (file, lnum, cnum) = Location.get_pos_info loc_start in
  
  let file = Filename.basename file in  

  let enum = loc.Location.loc_end.Lexing.pos_cnum -
      loc_start.Lexing.pos_cnum + cnum in
  match kind with
  | Loc_POS ->
    Lconst (Const_block (0, Blk_tuple, [
          Const_immstring file;
          Const_base (Const_int lnum);
          Const_base (Const_int cnum);
          Const_base (Const_int enum);
        ]))
  | Loc_FILE -> Lconst (Const_immstring file)
  | Loc_MODULE ->
    let filename = Filename.basename file in
    let name = Env.get_unit_name () in
    let module_name = if name = "" then "//"^filename^"//" else name in
    Lconst (Const_immstring module_name)
  | Loc_LOC ->
    let loc = Printf.sprintf "File %S, line %d, characters %d-%d"
        file lnum cnum enum in
    Lconst (Const_immstring loc)
  | Loc_LINE -> Lconst (Const_base (Const_int lnum))

let merge_inline_attributes attr1 attr2 =
  match attr1, attr2 with
  | Default_inline, _ -> Some attr2
  | _, Default_inline -> Some attr1
  | _, _ ->
    if attr1 = attr2 then Some attr1
    else None

let reset () =
  raise_count := 0

end
module Typeopt : sig 
#1 "typeopt.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Auxiliaries for type-based optimizations, e.g. array kinds *)

val is_function_type :
      Env.t -> Types.type_expr -> (Types.type_expr * Types.type_expr) option
val is_base_type : Env.t -> Types.type_expr -> Path.t -> bool

val maybe_pointer_type : Env.t -> Types.type_expr
  -> Lambda.immediate_or_pointer
val maybe_pointer : Typedtree.expression -> Lambda.immediate_or_pointer

val array_type_kind : Env.t -> Types.type_expr -> Lambda.array_kind
val array_kind : Typedtree.expression -> Lambda.array_kind
val array_pattern_kind : Typedtree.pattern -> Lambda.array_kind
val bigarray_type_kind_and_layout :
      Env.t -> Types.type_expr -> Lambda.bigarray_kind * Lambda.bigarray_layout
val value_kind : Env.t -> Types.type_expr -> Lambda.value_kind

val classify_lazy_argument : Typedtree.expression ->
                             [ `Constant_or_function
                             | `Float
                             | `Identifier of [`Forward_value | `Other]
                             | `Other]

val cannot_inhabit_none_like_value:
  Types.type_expr ->
  Env.t -> 
  bool


end = struct
#1 "typeopt.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Auxiliaries for type-based optimizations, e.g. array kinds *)

open Path
open Types
open Asttypes
open Typedtree
open Lambda

let scrape_ty env ty =
  let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in
  match ty.desc with
  | Tconstr (p, _, _) ->
      begin match Env.find_type p env with
      | {type_unboxed = {unboxed = true; _}; _} ->
        begin match Typedecl.get_unboxed_type_representation env ty with
        | None -> ty
        | Some ty2 -> ty2
        end
      | _ -> ty
      | exception Not_found -> ty
      end
  | _ -> ty

let scrape env ty =
  (scrape_ty env ty).desc


(**  [Types.constructor_description]
     records the type at the definition type so for ['a option]
     it will always be [Tvar]
*)
let cannot_inhabit_none_like_value (typ : Types.type_expr) (env : Env.t) =
  match scrape env typ with
  |  Tconstr(p, _,_) ->
      (* all built in types could not inhabit none-like values:
         int, char, float, bool, unit, exn, array, list, nativeint,
         int32, int64, lazy_t, bytes
      *)
      if Predef.type_is_builtin_path_but_option p then true
      else
        begin match (Env.find_type p env).type_kind with
        | exception _ -> 
            false
        | Types.Type_abstract | Types.Type_open -> false
        | Types.Type_record _ -> true
        | Types.Type_variant
            ([{cd_id = {Ident.name="None"}; cd_args = Types.Cstr_tuple [] };
             {cd_id = {Ident.name = "Some"}; cd_args = Types.Cstr_tuple [_]}]
            |
             [{cd_id = {Ident.name="Some"}; cd_args = Types.Cstr_tuple [_] };
              {cd_id = {Ident.name = "None"}; cd_args = Types.Cstr_tuple []}]
            ) -> false (* conservative *)
        | Types.Type_variant _ -> true
        end
  | Ttuple _
  | Tvariant _
  | Tpackage _ 
  | Tarrow _ -> true
  | Tfield _ 
  | Tpoly _ 
  | Tunivar _ 
  | Tlink _ 
  | Tsubst _
  | Tnil 
  | Tvar _
  | Tobject _ 
    -> false

let is_function_type env ty =
  match scrape env ty with
  | Tarrow (_, lhs, rhs, _) -> Some (lhs, rhs)
  | _ -> None

let is_base_type env ty base_ty_path =
  match scrape env ty with
  | Tconstr(p, _, _) -> Path.same p base_ty_path
  | _ -> false

let maybe_pointer_type env ty =
  if Ctype.maybe_pointer_type env ty then
    Pointer
  else
    Immediate

let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type

type classification =
  | Int
  | Float
  | Lazy
  | Addr  (* anything except a float or a lazy *)
  | Any

let classify env ty =
  let ty = scrape_ty env ty in
  if maybe_pointer_type env ty = Immediate then Int
  else match ty.desc with
  | Tvar _ | Tunivar _ ->
      Any
  | Tconstr (p, _args, _abbrev) ->
      if Path.same p Predef.path_float then Float
      else if Path.same p Predef.path_lazy_t then Lazy
      else if Path.same p Predef.path_string
           || Path.same p Predef.path_bytes
           || Path.same p Predef.path_array
           || Path.same p Predef.path_nativeint
           || Path.same p Predef.path_int32
           || Path.same p Predef.path_int64 then Addr
      else begin
        try
          match (Env.find_type p env).type_kind with
          | Type_abstract ->
              Any
          | Type_record _ | Type_variant _ | Type_open ->
              Addr
        with Not_found ->
          (* This can happen due to e.g. missing -I options,
             causing some .cmi files to be unavailable.
             Maybe we should emit a warning. *)
          Any
      end
  | Tarrow _ | Ttuple _ | Tpackage _ | Tobject _ | Tnil | Tvariant _ ->
      Addr
  | Tlink _ | Tsubst _ | Tpoly _ | Tfield _ ->
      assert false

let array_type_kind env ty =
  match scrape env ty with
  | Tconstr(p, [elt_ty], _) | Tpoly({desc = Tconstr(p, [elt_ty], _)}, _)
    when Path.same p Predef.path_array ->
      begin match classify env elt_ty with
      | Any -> if Config.flat_float_array then Pgenarray else Paddrarray
      | Float -> if Config.flat_float_array then Pfloatarray else Paddrarray
      | Addr | Lazy -> Paddrarray
      | Int -> Pintarray
      end
  | Tconstr(p, [], _) | Tpoly({desc = Tconstr(p, [], _)}, _)
    when Path.same p Predef.path_floatarray ->
      Pfloatarray
  | _ ->
      (* This can happen with e.g. Obj.field *)
      Pgenarray

let array_kind exp = array_type_kind exp.exp_env exp.exp_type

let array_pattern_kind pat = array_type_kind pat.pat_env pat.pat_type

let bigarray_decode_type env ty tbl dfl =
  match scrape env ty with
  | Tconstr(Pdot(Pident mod_id, type_name, _), [], _)
    when Ident.name mod_id = "CamlinternalBigarray" ->
      begin try List.assoc type_name tbl with Not_found -> dfl end
  | _ ->
      dfl

let kind_table =
  ["float32_elt", Pbigarray_float32;
   "float64_elt", Pbigarray_float64;
   "int8_signed_elt", Pbigarray_sint8;
   "int8_unsigned_elt", Pbigarray_uint8;
   "int16_signed_elt", Pbigarray_sint16;
   "int16_unsigned_elt", Pbigarray_uint16;
   "int32_elt", Pbigarray_int32;
   "int64_elt", Pbigarray_int64;
   "int_elt", Pbigarray_caml_int;
   "nativeint_elt", Pbigarray_native_int;
   "complex32_elt", Pbigarray_complex32;
   "complex64_elt", Pbigarray_complex64]

let layout_table =
  ["c_layout", Pbigarray_c_layout;
   "fortran_layout", Pbigarray_fortran_layout]

let bigarray_type_kind_and_layout env typ =
  match scrape env typ with
  | Tconstr(_p, [_caml_type; elt_type; layout_type], _abbrev) ->
      (bigarray_decode_type env elt_type kind_table Pbigarray_unknown,
       bigarray_decode_type env layout_type layout_table
                            Pbigarray_unknown_layout)
  | _ ->
      (Pbigarray_unknown, Pbigarray_unknown_layout)

let value_kind env ty =
  match scrape env ty with
  | Tconstr(p, _, _) when Path.same p Predef.path_int ->
      Pintval
  | Tconstr(p, _, _) when Path.same p Predef.path_char ->
      Pintval
  | Tconstr(p, _, _) when Path.same p Predef.path_float ->
      Pfloatval
  | Tconstr(p, _, _) when Path.same p Predef.path_int32 ->
      Pboxedintval Pint32
  | Tconstr(p, _, _) when Path.same p Predef.path_int64 ->
      Pboxedintval Pint64
  | Tconstr(p, _, _) when Path.same p Predef.path_nativeint ->
      Pboxedintval Pnativeint
  | _ ->
      Pgenval


(** Whether a forward block is needed for a lazy thunk on a value, i.e.
    if the value can be represented as a float/forward/lazy *)
let lazy_val_requires_forward env ty =
  match classify env ty with
  | Any | Lazy -> true
  | Float -> Config.flat_float_array
  | Addr | Int -> false

(** The compilation of the expression [lazy e] depends on the form of e:
    constants, floats and identifiers are optimized.  The optimization must be
    taken into account when determining whether a recursive binding is safe. *)
let classify_lazy_argument : Typedtree.expression ->
                             [`Constant_or_function
                             |`Float
                             |`Identifier of [`Forward_value|`Other]
                             |`Other] =
  fun e -> match e.exp_desc with
    | Texp_constant
        ( Const_int _ | Const_char _ | Const_string _
        | Const_int32 _ | Const_int64 _ | Const_nativeint _ )
    | Texp_function _
    | Texp_construct (_, {cstr_arity = 0}, _) ->
       `Constant_or_function
    | Texp_constant(Const_float _) ->
       `Float
    | Texp_ident _ when lazy_val_requires_forward e.exp_env e.exp_type ->
       `Identifier `Forward_value
    | Texp_ident _ ->
       `Identifier `Other
    | _ ->
       `Other

end
module Typecore : sig 
#1 "typecore.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Type inference for the core language *)

open Asttypes
open Types
open Format

val is_nonexpansive: Typedtree.expression -> bool

val type_binding:
        Env.t -> rec_flag ->
          Parsetree.value_binding list ->
          Annot.ident option ->
          Typedtree.value_binding list * Env.t
val type_let:
        Env.t -> rec_flag ->
          Parsetree.value_binding list ->
          Annot.ident option ->
          Typedtree.value_binding list * Env.t
val type_expression:
        Env.t -> Parsetree.expression -> Typedtree.expression
val type_class_arg_pattern:
        string -> Env.t -> Env.t -> arg_label -> Parsetree.pattern ->
        Typedtree.pattern * (Ident.t * string loc * Ident.t * type_expr) list *
        Env.t * Env.t
val type_self_pattern:
        string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
        Typedtree.pattern *
        (Ident.t * type_expr) Meths.t ref *
        (Ident.t * Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr)
            Vars.t ref *
        Env.t * Env.t * Env.t
val check_partial:
        ?lev:int -> Env.t -> type_expr ->
        Location.t -> Typedtree.case list -> Typedtree.partial
val type_expect:
        ?in_function:(Location.t * type_expr) ->
        Env.t -> Parsetree.expression -> type_expr -> Typedtree.expression
val type_exp:
        Env.t -> Parsetree.expression -> Typedtree.expression
val type_approx:
        Env.t -> Parsetree.expression -> type_expr
val type_argument:
        Env.t -> Parsetree.expression ->
        type_expr -> type_expr -> Typedtree.expression

val option_some: Typedtree.expression -> Typedtree.expression
val option_none: type_expr -> Location.t -> Typedtree.expression
val extract_option_type: Env.t -> type_expr -> type_expr
val iter_pattern: (Typedtree.pattern -> unit) -> Typedtree.pattern -> unit
val generalizable: int -> type_expr -> bool
val reset_delayed_checks: unit -> unit
val force_delayed_checks: unit -> unit

val name_pattern : string -> Typedtree.case list -> Ident.t

val self_coercion : (Path.t * Location.t list ref) list ref

type error =
    Polymorphic_label of Longident.t
  | Constructor_arity_mismatch of Longident.t * int * int
  | Label_mismatch of Longident.t * (type_expr * type_expr) list
  | Pattern_type_clash of (type_expr * type_expr) list
  | Or_pattern_type_clash of Ident.t * (type_expr * type_expr) list
  | Multiply_bound_variable of string
  | Orpat_vars of Ident.t * Ident.t list
  | Expr_type_clash of (type_expr * type_expr) list
  | Apply_non_function of type_expr
  | Apply_wrong_label of arg_label * type_expr
  | Label_multiply_defined of string
  | Label_missing of Ident.t list
  | Label_not_mutable of Longident.t
  | Wrong_name of string * type_expr * string * Path.t * string * string list
  | Name_type_mismatch of
      string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
  | Invalid_format of string
  | Undefined_method of type_expr * string * string list option
  | Undefined_inherited_method of string * string list
  | Virtual_class of Longident.t
  | Private_type of type_expr
  | Private_label of Longident.t * type_expr
  | Unbound_instance_variable of string * string list
  | Instance_variable_not_mutable of bool * string
  | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list
  | Outside_class
  | Value_multiply_overridden of string
  | Coercion_failure of
      type_expr * type_expr * (type_expr * type_expr) list * bool
  | Too_many_arguments of bool * type_expr
  | Abstract_wrong_label of arg_label * type_expr
  | Scoping_let_module of string * type_expr
  | Masked_instance_variable of Longident.t
  | Not_a_variant_type of Longident.t
  | Incoherent_label_order
  | Less_general of string * (type_expr * type_expr) list
  | Modules_not_allowed
  | Cannot_infer_signature
  | Not_a_packed_module of type_expr
  | Recursive_local_constraint of (type_expr * type_expr) list
  | Unexpected_existential
  | Unqualified_gadt_pattern of Path.t * string
  | Invalid_interval
  | Invalid_for_loop_index
  | No_value_clauses
  | Exception_pattern_below_toplevel
  | Inlined_record_escape
  | Inlined_record_expected
  | Unrefuted_pattern of Typedtree.pattern
  | Invalid_extension_constructor_payload
  | Not_an_extension_constructor
  | Literal_overflow of string
  | Unknown_literal of string * char
  | Illegal_letrec_pat
  | Illegal_letrec_expr
  | Illegal_class_expr

exception Error of Location.t * Env.t * error
exception Error_forward of Location.error


val super_report_error_no_wrap_printing_env: Env.t -> formatter -> error -> unit


val report_error: Env.t -> formatter -> error -> unit
 (* Deprecated.  Use Location.{error_of_exn, report_error}. *)

(* Forward declaration, to be filled in by Typemod.type_module *)
val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref
(* Forward declaration, to be filled in by Typemod.type_open *)
val type_open:
  (?used_slot:bool ref -> override_flag -> Env.t -> Location.t ->
   Longident.t loc -> Path.t * Env.t)
    ref
(* Forward declaration, to be filled in by Typeclass.class_structure *)
val type_object:
  (Env.t -> Location.t -> Parsetree.class_structure ->
   Typedtree.class_structure * Types.class_signature * string list) ref
val type_package:
  (Env.t -> Parsetree.module_expr -> Path.t -> Longident.t list ->
  Typedtree.module_expr * type_expr list) ref

val create_package_type : Location.t -> Env.t ->
  Longident.t * (Longident.t * Parsetree.core_type) list ->
  Path.t * (Longident.t * Typedtree.core_type) list * Types.type_expr

val constant: Parsetree.constant -> (Asttypes.constant, error) result

val check_recursive_bindings : Env.t -> Typedtree.value_binding list -> unit
val check_recursive_class_bindings :
  Env.t -> Ident.t list -> Typedtree.class_expr list -> unit

end = struct
#1 "typecore.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Typechecking for the core language *)

open Misc
open Asttypes
open Parsetree
open Types
open Typedtree
open Btype
open Ctype

type error =
    Polymorphic_label of Longident.t
  | Constructor_arity_mismatch of Longident.t * int * int
  | Label_mismatch of Longident.t * (type_expr * type_expr) list
  | Pattern_type_clash of (type_expr * type_expr) list
  | Or_pattern_type_clash of Ident.t * (type_expr * type_expr) list
  | Multiply_bound_variable of string
  | Orpat_vars of Ident.t * Ident.t list
  | Expr_type_clash of (type_expr * type_expr) list
  | Apply_non_function of type_expr
  | Apply_wrong_label of arg_label * type_expr
  | Label_multiply_defined of string
  | Label_missing of Ident.t list
  | Label_not_mutable of Longident.t
  | Wrong_name of string * type_expr * string * Path.t * string * string list
  | Name_type_mismatch of
      string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
  | Invalid_format of string
  | Undefined_method of type_expr * string * string list option
  | Undefined_inherited_method of string * string list
  | Virtual_class of Longident.t
  | Private_type of type_expr
  | Private_label of Longident.t * type_expr
  | Unbound_instance_variable of string * string list
  | Instance_variable_not_mutable of bool * string
  | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list
  | Outside_class
  | Value_multiply_overridden of string
  | Coercion_failure of
      type_expr * type_expr * (type_expr * type_expr) list * bool
  | Too_many_arguments of bool * type_expr
  | Abstract_wrong_label of arg_label * type_expr
  | Scoping_let_module of string * type_expr
  | Masked_instance_variable of Longident.t
  | Not_a_variant_type of Longident.t
  | Incoherent_label_order
  | Less_general of string * (type_expr * type_expr) list
  | Modules_not_allowed
  | Cannot_infer_signature
  | Not_a_packed_module of type_expr
  | Recursive_local_constraint of (type_expr * type_expr) list
  | Unexpected_existential
  | Unqualified_gadt_pattern of Path.t * string
  | Invalid_interval
  | Invalid_for_loop_index
  | No_value_clauses
  | Exception_pattern_below_toplevel
  | Inlined_record_escape
  | Inlined_record_expected
  | Unrefuted_pattern of pattern
  | Invalid_extension_constructor_payload
  | Not_an_extension_constructor
  | Literal_overflow of string
  | Unknown_literal of string * char
  | Illegal_letrec_pat
  | Illegal_letrec_expr
  | Illegal_class_expr

exception Error of Location.t * Env.t * error
exception Error_forward of Location.error

(* Forward declaration, to be filled in by Typemod.type_module *)

let type_module =
  ref ((fun _env _md -> assert false) :
       Env.t -> Parsetree.module_expr -> Typedtree.module_expr)

(* Forward declaration, to be filled in by Typemod.type_open *)

let type_open :
  (?used_slot:bool ref -> override_flag -> Env.t -> Location.t ->
   Longident.t loc -> Path.t * Env.t)
    ref =
  ref (fun ?used_slot:_ _ -> assert false)

(* Forward declaration, to be filled in by Typemod.type_package *)

let type_package =
  ref (fun _ -> assert false)

(* Forward declaration, to be filled in by Typeclass.class_structure *)
let type_object =
  ref (fun _env _s -> assert false :
       Env.t -> Location.t -> Parsetree.class_structure ->
         Typedtree.class_structure * Types.class_signature * string list)

(*
  Saving and outputting type information.
  We keep these function names short, because they have to be
  called each time we create a record of type [Typedtree.expression]
  or [Typedtree.pattern] that will end up in the typed AST.
*)
let re node =
  Cmt_format.add_saved_type (Cmt_format.Partial_expression node);
  Stypes.record (Stypes.Ti_expr node);
  node
;;
let rp node =
  Cmt_format.add_saved_type (Cmt_format.Partial_pattern node);
  Stypes.record (Stypes.Ti_pat node);
  node
;;


type recarg =
  | Allowed
  | Required
  | Rejected


let case lhs rhs =
  {c_lhs = lhs; c_guard = None; c_rhs = rhs}

(* Upper approximation of free identifiers on the parse tree *)

let iter_expression f e =

  let rec expr e =
    f e;
    match e.pexp_desc with
    | Pexp_extension _ (* we don't iterate under extension point *)
    | Pexp_ident _
    | Pexp_new _
    | Pexp_constant _ -> ()
    | Pexp_function pel -> List.iter case pel
    | Pexp_fun (_, eo, _, e) -> may expr eo; expr e
    | Pexp_apply (e, lel) -> expr e; List.iter (fun (_, e) -> expr e) lel
    | Pexp_let (_, pel, e) ->  expr e; List.iter binding pel
    | Pexp_match (e, pel)
    | Pexp_try (e, pel) -> expr e; List.iter case pel
    | Pexp_array el
    | Pexp_tuple el -> List.iter expr el
    | Pexp_construct (_, eo)
    | Pexp_variant (_, eo) -> may expr eo
    | Pexp_record (iel, eo) ->
        may expr eo; List.iter (fun (_, e) -> expr e) iel
    | Pexp_open (_, _, e)
    | Pexp_newtype (_, e)
    | Pexp_poly (e, _)
    | Pexp_lazy e
    | Pexp_assert e
    | Pexp_setinstvar (_, e)
    | Pexp_send (e, _)
    | Pexp_constraint (e, _)
    | Pexp_coerce (e, _, _)
    | Pexp_letexception (_, e)
    | Pexp_field (e, _) -> expr e
    | Pexp_while (e1, e2)
    | Pexp_sequence (e1, e2)
    | Pexp_setfield (e1, _, e2) -> expr e1; expr e2
    | Pexp_ifthenelse (e1, e2, eo) -> expr e1; expr e2; may expr eo
    | Pexp_for (_, e1, e2, _, e3) -> expr e1; expr e2; expr e3
    | Pexp_override sel -> List.iter (fun (_, e) -> expr e) sel
    | Pexp_letmodule (_, me, e) -> expr e; module_expr me
    | Pexp_object { pcstr_fields = fs } -> List.iter class_field fs
    | Pexp_pack me -> module_expr me
    | Pexp_unreachable -> ()

  and case {pc_lhs = _; pc_guard; pc_rhs} =
    may expr pc_guard;
    expr pc_rhs

  and binding x =
    expr x.pvb_expr

  and module_expr me =
    match me.pmod_desc with
    | Pmod_extension _
    | Pmod_ident _ -> ()
    | Pmod_structure str -> List.iter structure_item str
    | Pmod_constraint (me, _)
    | Pmod_functor (_, _, me) -> module_expr me
    | Pmod_apply (me1, me2) -> module_expr me1; module_expr me2
    | Pmod_unpack e -> expr e


  and structure_item str =
    match str.pstr_desc with
    | Pstr_eval (e, _) -> expr e
    | Pstr_value (_, pel) -> List.iter binding pel
    | Pstr_primitive _
    | Pstr_type _
    | Pstr_typext _
    | Pstr_exception _
    | Pstr_modtype _
    | Pstr_open _
    | Pstr_class_type _
    | Pstr_attribute _
    | Pstr_extension _ -> ()
    | Pstr_include {pincl_mod = me}
    | Pstr_module {pmb_expr = me} -> module_expr me
    | Pstr_recmodule l -> List.iter (fun x -> module_expr x.pmb_expr) l
    | Pstr_class cdl -> List.iter (fun c -> class_expr c.pci_expr) cdl

  and class_expr ce =
    match ce.pcl_desc with
    | Pcl_constr _ -> ()
    | Pcl_structure { pcstr_fields = fs } -> List.iter class_field fs
    | Pcl_fun (_, eo, _,  ce) -> may expr eo; class_expr ce
    | Pcl_apply (ce, lel) ->
        class_expr ce; List.iter (fun (_, e) -> expr e) lel
    | Pcl_let (_, pel, ce) ->
        List.iter binding pel; class_expr ce
    | Pcl_open (_, _, ce)
    | Pcl_constraint (ce, _) -> class_expr ce
    | Pcl_extension _ -> ()

  and class_field cf =
    match cf.pcf_desc with
    | Pcf_inherit (_, ce, _) -> class_expr ce
    | Pcf_val (_, _, Cfk_virtual _)
    | Pcf_method (_, _, Cfk_virtual _ ) | Pcf_constraint _ -> ()
    | Pcf_val (_, _, Cfk_concrete (_, e))
    | Pcf_method (_, _, Cfk_concrete (_, e)) -> expr e
    | Pcf_initializer e -> expr e
    | Pcf_attribute _ | Pcf_extension _ -> ()

  in
  expr e


let all_idents_cases el =
  let idents = Hashtbl.create 8 in
  let f = function
    | {pexp_desc=Pexp_ident { txt = Longident.Lident id; _ }; _} ->
        Hashtbl.replace idents id ()
    | _ -> ()
  in
  List.iter
    (fun cp ->
      may (iter_expression f) cp.pc_guard;
      iter_expression f cp.pc_rhs
    )
    el;
  Hashtbl.fold (fun x () rest -> x :: rest) idents []


(* Typing of constants *)

let type_constant = function
    Const_int _ -> instance_def Predef.type_int
  | Const_char _ -> instance_def Predef.type_char
  | Const_string _ -> instance_def Predef.type_string
  | Const_float _ -> instance_def Predef.type_float
  | Const_int32 _ -> instance_def Predef.type_int32
  | Const_int64 _ -> instance_def Predef.type_int64
  | Const_nativeint _ -> instance_def Predef.type_nativeint

let constant : Parsetree.constant -> (Asttypes.constant, error) result =
  function
  | Pconst_integer (i,None) ->
     begin
       try Ok (Const_int (Misc.Int_literal_converter.int i))
       with Failure _ -> Error (Literal_overflow "int")
     end
  | Pconst_integer (i,Some 'l') ->
     begin
       try Ok (Const_int32 (Misc.Int_literal_converter.int32 i))
       with Failure _ -> Error (Literal_overflow "int32")
     end
  | Pconst_integer (i,Some 'L') ->
     begin
       try Ok (Const_int64 (Misc.Int_literal_converter.int64 i))
       with Failure _ -> Error (Literal_overflow "int64")
     end
  | Pconst_integer (i,Some 'n') ->
     begin
       try Ok (Const_nativeint (Misc.Int_literal_converter.nativeint i))
       with Failure _ -> Error (Literal_overflow "nativeint")
     end
  | Pconst_integer (i,Some c) -> Error (Unknown_literal (i, c))
  | Pconst_char c -> Ok (Const_char c)
  | Pconst_string (s,d) -> Ok (Const_string (s,d))
  | Pconst_float (f,None)-> Ok (Const_float f)
  | Pconst_float (f,Some c) -> Error (Unknown_literal (f, c))

let constant_or_raise env loc cst =
  match constant cst with
  | Ok c -> c
  | Error err -> raise (Error (loc, env, err))

(* Specific version of type_option, using newty rather than newgenty *)

let type_option ty =
  newty (Tconstr(Predef.path_option,[ty], ref Mnil))

let mkexp exp_desc exp_type exp_loc exp_env =
  { exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = [] }

let option_none ty loc =
  let lid = Longident.Lident "None"
  and env = Env.initial_safe_string in
  let cnone = Env.lookup_constructor lid env in
  mkexp (Texp_construct(mknoloc lid, cnone, [])) ty loc env

let option_some texp =
  let lid = Longident.Lident "Some" in
  let csome = Env.lookup_constructor lid Env.initial_safe_string in
  mkexp ( Texp_construct(mknoloc lid , csome, [texp]) )
    (type_option texp.exp_type) texp.exp_loc texp.exp_env

let extract_option_type env ty =
  match expand_head env ty with {desc = Tconstr(path, [ty], _)}
    when Path.same path Predef.path_option -> ty
  | _ -> assert false

let extract_concrete_record env ty =
  match extract_concrete_typedecl env ty with
    (p0, p, {type_kind=Type_record (fields, _)}) -> (p0, p, fields)
  | _ -> raise Not_found

let extract_concrete_variant env ty =
  match extract_concrete_typedecl env ty with
    (p0, p, {type_kind=Type_variant cstrs}) -> (p0, p, cstrs)
  | (p0, p, {type_kind=Type_open}) -> (p0, p, [])
  | _ -> raise Not_found

let extract_label_names env ty =
  try
    let (_, _,fields) = extract_concrete_record env ty in
    List.map (fun l -> l.Types.ld_id) fields
  with Not_found ->
    assert false

(* Typing of patterns *)

(* unification inside type_pat*)
let unify_pat_types loc env ty ty' =
  try
    unify env ty ty'
  with
    Unify trace ->
      raise(Error(loc, env, Pattern_type_clash(trace)))
  | Tags(l1,l2) ->
      raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2)))

(* unification inside type_exp and type_expect *)
let unify_exp_types loc env ty expected_ty =
  (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type
    Printtyp.raw_type_expr expected_ty; *)
  try
    unify env ty expected_ty
  with
    Unify trace ->
      raise(Error(loc, env, Expr_type_clash(trace)))
  | Tags(l1,l2) ->
      raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2)))

(* level at which to create the local type declarations *)
let newtype_level = ref None
let get_newtype_level () =
  match !newtype_level with
    Some y -> y
  | None -> assert false

let unify_pat_types_gadt loc env ty ty' =
  let newtype_level =
    match !newtype_level with
    | None -> assert false
    | Some x -> x
  in
  try
    unify_gadt ~newtype_level env ty ty'
  with
    Unify trace ->
      raise(Error(loc, !env, Pattern_type_clash(trace)))
  | Tags(l1,l2) ->
      raise(Typetexp.Error(loc, !env, Typetexp.Variant_tags (l1, l2)))
  | Unification_recursive_abbrev trace ->
      raise(Error(loc, !env, Recursive_local_constraint trace))


(* Creating new conjunctive types is not allowed when typing patterns *)

let unify_pat env pat expected_ty =
  unify_pat_types pat.pat_loc env pat.pat_type expected_ty

(* make all Reither present in open variants *)
let finalize_variant pat =
  match pat.pat_desc with
    Tpat_variant(tag, opat, r) ->
      let row =
        match expand_head pat.pat_env pat.pat_type with
          {desc = Tvariant row} -> r := row; row_repr row
        | _ -> assert false
      in
      begin match row_field tag row with
      | Rabsent -> () (* assert false *)
      | Reither (true, [], _, e) when not row.row_closed ->
          set_row_field e (Rpresent None)
      | Reither (false, ty::tl, _, e) when not row.row_closed ->
          set_row_field e (Rpresent (Some ty));
          begin match opat with None -> assert false
          | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl)
          end
      | Reither (c, _l, true, e) when not (row_fixed row) ->
          set_row_field e (Reither (c, [], false, ref None))
      | _ -> ()
      end;
      (* Force check of well-formedness   WHY? *)
      (* unify_pat pat.pat_env pat
        (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false;
                        row_bound=(); row_fixed=false; row_name=None})); *)
  | _ -> ()

let rec iter_pattern f p =
  f p;
  iter_pattern_desc (iter_pattern f) p.pat_desc

let has_variants p =
  try
    iter_pattern (function {pat_desc=Tpat_variant _} -> raise Exit | _ -> ())
      p;
    false
  with Exit ->
    true


(* pattern environment *)
let pattern_variables = ref ([] :
 (Ident.t * type_expr * string loc * Location.t * bool (* as-variable *)) list)
let pattern_force = ref ([] : (unit -> unit) list)
let pattern_scope = ref (None : Annot.ident option);;
let allow_modules = ref false
let module_variables = ref ([] : (string loc * Location.t) list)
let reset_pattern scope allow =
  pattern_variables := [];
  pattern_force := [];
  pattern_scope := scope;
  allow_modules := allow;
  module_variables := [];
;;

let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty =
  if List.exists (fun (id, _, _, _, _) -> Ident.name id = name.txt)
      !pattern_variables
  then raise(Error(loc, Env.empty, Multiply_bound_variable name.txt));
  let id = Ident.create name.txt in
  pattern_variables :=
    (id, ty, name, loc, is_as_variable) :: !pattern_variables;
  if is_module then begin
    (* Note: unpack patterns enter a variable of the same name *)
    if not !allow_modules then
      raise (Error (loc, Env.empty, Modules_not_allowed));
    module_variables := (name, loc) :: !module_variables
  end else
    (* moved to genannot *)
    may (fun s -> Stypes.record (Stypes.An_ident (name.loc, name.txt, s)))
        !pattern_scope;
  id

let sort_pattern_variables vs =
  List.sort
    (fun (x,_,_,_,_) (y,_,_,_,_) ->
      Pervasives.compare (Ident.name x) (Ident.name y))
    vs

let enter_orpat_variables loc env  p1_vs p2_vs =
  (* unify_vars operate on sorted lists *)

  let p1_vs = sort_pattern_variables p1_vs
  and p2_vs = sort_pattern_variables p2_vs in

  let rec unify_vars p1_vs p2_vs =
    let vars vs = List.map (fun (x,_t,_,_l,_a) -> x) vs in
    match p1_vs, p2_vs with
      | (x1,t1,_,_l1,_a1)::rem1, (x2,t2,_,_l2,_a2)::rem2
        when Ident.equal x1 x2 ->
          if x1==x2 then
            unify_vars rem1 rem2
          else begin
            begin try
              unify env t1 t2
            with
            | Unify trace ->
                raise(Error(loc, env, Or_pattern_type_clash(x1, trace)))
            end;
          (x2,x1)::unify_vars rem1 rem2
          end
      | [],[] -> []
      | (x,_,_,_,_)::_, [] -> raise (Error (loc, env, Orpat_vars (x, [])))
      | [],(y,_,_,_,_)::_  -> raise (Error (loc, env, Orpat_vars (y, [])))
      | (x,_,_,_,_)::_, (y,_,_,_,_)::_ ->
          let err =
            if Ident.name x < Ident.name y
            then Orpat_vars (x, vars p2_vs)
            else Orpat_vars (y, vars p1_vs) in
          raise (Error (loc, env, err)) in
  unify_vars p1_vs p2_vs

let rec build_as_type env p =
  match p.pat_desc with
    Tpat_alias(p1,_, _) -> build_as_type env p1
  | Tpat_tuple pl ->
      let tyl = List.map (build_as_type env) pl in
      newty (Ttuple tyl)
  | Tpat_construct(_, cstr, pl) ->
      let keep = cstr.cstr_private = Private || cstr.cstr_existentials <> [] in
      if keep then p.pat_type else
      let tyl = List.map (build_as_type env) pl in
      let ty_args, ty_res = instance_constructor cstr in
      List.iter2 (fun (p,ty) -> unify_pat env {p with pat_type = ty})
        (List.combine pl tyl) ty_args;
      ty_res
  | Tpat_variant(l, p', _) ->
      let ty = may_map (build_as_type env) p' in
      newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar();
                      row_bound=(); row_name=None;
                      row_fixed=false; row_closed=false})
  | Tpat_record (lpl,_) ->
      let lbl = snd3 (List.hd lpl) in
      if lbl.lbl_private = Private then p.pat_type else
      let ty = newvar () in
      let ppl = List.map (fun (_, l, p) -> l.lbl_pos, p) lpl in
      let do_label lbl =
        let _, ty_arg, ty_res = instance_label false lbl in
        unify_pat env {p with pat_type = ty} ty_res;
        let refinable =
          lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl &&
          match (repr lbl.lbl_arg).desc with Tpoly _ -> false | _ -> true in
        if refinable then begin
          let arg = List.assoc lbl.lbl_pos ppl in
          unify_pat env {arg with pat_type = build_as_type env arg} ty_arg
        end else begin
          let _, ty_arg', ty_res' = instance_label false lbl in
          unify env ty_arg ty_arg';
          unify_pat env p ty_res'
        end in
      Array.iter do_label lbl.lbl_all;
      ty
  | Tpat_or(p1, p2, row) ->
      begin match row with
        None ->
          let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in
          unify_pat env {p2 with pat_type = ty2} ty1;
          ty1
      | Some row ->
          let row = row_repr row in
          newty (Tvariant{row with row_closed=false; row_more=newvar()})
      end
  | Tpat_any | Tpat_var _ | Tpat_constant _
  | Tpat_array _ | Tpat_lazy _ -> p.pat_type

let build_or_pat env loc lid =
  let path, decl = Typetexp.find_type env lid.loc lid.txt
  in
  let tyl = List.map (fun _ -> newvar()) decl.type_params in
  let row0 =
    let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in
    match ty.desc with
      Tvariant row when static_row row -> row
    | _ -> raise(Error(lid.loc, env, Not_a_variant_type lid.txt))
  in
  let pats, fields =
    List.fold_left
      (fun (pats,fields) (l,f) ->
        match row_field_repr f with
          Rpresent None ->
            (l,None) :: pats,
            (l, Reither(true,[], true, ref None)) :: fields
        | Rpresent (Some ty) ->
            (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env;
                      pat_type=ty; pat_extra=[]; pat_attributes=[]})
            :: pats,
            (l, Reither(false, [ty], true, ref None)) :: fields
        | _ -> pats, fields)
      ([],[]) (row_repr row0).row_fields in
  let row =
    { row_fields = List.rev fields; row_more = newvar(); row_bound = ();
      row_closed = false; row_fixed = false; row_name = Some (path, tyl) }
  in
  let ty = newty (Tvariant row) in
  let gloc = {loc with Location.loc_ghost=true} in
  let row' = ref {row with row_more=newvar()} in
  let pats =
    List.map
      (fun (l,p) ->
        {pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc;
         pat_env=env; pat_type=ty; pat_extra=[]; pat_attributes=[]})
      pats
  in
  match pats with
    [] -> raise(Error(lid.loc, env, Not_a_variant_type lid.txt))
  | pat :: pats ->
      let r =
        List.fold_left
          (fun pat pat0 ->
            {pat_desc=Tpat_or(pat0,pat,Some row0); pat_extra=[];
             pat_loc=gloc; pat_env=env; pat_type=ty; pat_attributes=[]})
          pat pats in
      (path, rp { r with pat_loc = loc },ty)

(* Type paths *)

let rec expand_path env p =
  let decl =
    try Some (Env.find_type p env) with Not_found -> None
  in
  match decl with
    Some {type_manifest = Some ty} ->
      begin match repr ty with
        {desc=Tconstr(p,_,_)} -> expand_path env p
      | _ -> p
         (* PR#6394: recursive module may introduce incoherent manifest *)
      end
  | _ ->
      let p' = Env.normalize_path None env p in
      if Path.same p p' then p else expand_path env p'

let compare_type_path env tpath1 tpath2 =
  Path.same (expand_path env tpath1) (expand_path env tpath2)

(* Records *)
let label_of_kind kind =
  if kind = "record" then "field" else "constructor"

module NameChoice(Name : sig
  type t
  val type_kind: string
  val get_name: t -> string
  val get_type: t -> type_expr
  val get_descrs: Env.type_descriptions -> t list
  val unbound_name_error: Env.t -> Longident.t loc -> 'a
  val in_env: t -> bool
end) = struct
  open Name

  let get_type_path d =
    match (repr (get_type d)).desc with
    | Tconstr(p, _, _) -> p
    | _ -> assert false

  let lookup_from_type env tpath lid =
    let descrs = get_descrs (Env.find_type_descrs tpath env) in
    Env.mark_type_used env (Path.last tpath) (Env.find_type tpath env);
    match lid.txt with
      Longident.Lident s -> begin
        try
          List.find (fun nd -> get_name nd = s) descrs
        with Not_found ->
          let names = List.map get_name descrs in
          raise (Error (lid.loc, env,
                        Wrong_name ("", newvar (), type_kind, tpath, s, names)))
      end
    | _ -> raise Not_found

  let rec unique eq acc = function
      [] -> List.rev acc
    | x :: rem ->
        if List.exists (eq x) acc then unique eq acc rem
        else unique eq (x :: acc) rem

  let ambiguous_types env lbl others =
    let tpath = get_type_path lbl in
    let others =
      List.map (fun (lbl, _) -> get_type_path lbl) others in
    let tpaths = unique (compare_type_path env) [tpath] others in
    match tpaths with
      [_] -> []
    | _ -> List.map Printtyp.string_of_path tpaths

  let disambiguate_by_type env tpath lbls =
    let check_type (lbl, _) =
      let lbl_tpath = get_type_path lbl in
      compare_type_path env tpath lbl_tpath
    in
    List.find check_type lbls

  let disambiguate ?(warn=Location.prerr_warning) ?(check_lk=fun _ _ -> ())
      ?scope lid env opath lbls =
    let scope = match scope with None -> lbls | Some l -> l in
    let lbl = match opath with
      None ->
        begin match lbls with
          [] -> unbound_name_error env lid
        | (lbl, use) :: rest ->
            use ();
            let paths = ambiguous_types env lbl rest in
            if paths <> [] then
              warn lid.loc
                (Warnings.Ambiguous_name ([Longident.last lid.txt],
                                          paths, false));
            lbl
        end
    | Some(tpath0, tpath, pr) ->
        let warn_pr () =
          let label = label_of_kind type_kind in
          warn lid.loc
            (Warnings.Not_principal
               ("this type-based " ^ label ^ " disambiguation"))
        in
        try
          let lbl, use = disambiguate_by_type env tpath scope in
          use ();
          if not pr then begin
            (* Check if non-principal type is affecting result *)
            match lbls with
              [] -> warn_pr ()
            | (lbl', _use') :: rest ->
                let lbl_tpath = get_type_path lbl' in
                if not (compare_type_path env tpath lbl_tpath) then warn_pr ()
                else
                  let paths = ambiguous_types env lbl rest in
                  if paths <> [] then
                    warn lid.loc
                      (Warnings.Ambiguous_name ([Longident.last lid.txt],
                                                paths, false))
          end;
          lbl
        with Not_found -> try
          let lbl = lookup_from_type env tpath lid in
          check_lk tpath lbl;
          if in_env lbl then
          begin
          let s = Printtyp.string_of_path tpath in
          warn lid.loc
            (Warnings.Name_out_of_scope (s, [Longident.last lid.txt], false));
          end;
          if not pr then warn_pr ();
          lbl
        with Not_found ->
          if lbls = [] then unbound_name_error env lid else
          let tp = (tpath0, expand_path env tpath) in
          let tpl =
            List.map
              (fun (lbl, _) ->
                let tp0 = get_type_path lbl in
                let tp = expand_path env tp0 in
                  (tp0, tp))
              lbls
          in
          raise (Error (lid.loc, env,
                        Name_type_mismatch (type_kind, lid.txt, tp, tpl)))
    in
    if in_env lbl then
    begin match scope with
      (lab1,_)::_ when lab1 == lbl -> ()
    | _ ->
        Location.prerr_warning lid.loc
          (Warnings.Disambiguated_name(get_name lbl))
    end;
    lbl
end

let wrap_disambiguate kind ty f x =
  try f x with Error (loc, env, Wrong_name ("",_,tk,tp,name,valid_names)) ->
    raise (Error (loc, env, Wrong_name (kind,ty,tk,tp,name,valid_names)))

module Label = NameChoice (struct
  type t = label_description
  let type_kind = "record"
  let get_name lbl = lbl.lbl_name
  let get_type lbl = lbl.lbl_res
  let get_descrs = snd
  let unbound_name_error = Typetexp.unbound_label_error
  let in_env lbl =
    match lbl.lbl_repres with
    | Record_regular | Record_float | Record_unboxed false -> true
    | Record_unboxed true | Record_inlined _ | Record_extension -> false
end)

let disambiguate_label_by_ids keep closed ids labels =
  let check_ids (lbl, _) =
    let lbls = Hashtbl.create 8 in
    Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all;
    List.for_all (Hashtbl.mem lbls) ids
  and check_closed (lbl, _) =
    (not closed || List.length ids = Array.length lbl.lbl_all)
  in
  let labels' = List.filter check_ids labels in
  if keep && labels' = [] then (false, labels) else
  let labels'' = List.filter check_closed labels' in
  if keep && labels'' = [] then (false, labels') else (true, labels'')

(* Only issue warnings once per record constructor/pattern *)
let disambiguate_lid_a_list loc closed env opath lid_a_list =
  let ids = List.map (fun (lid, _) -> Longident.last lid.txt) lid_a_list in
  let w_pr = ref false and w_amb = ref []
  and w_scope = ref [] and w_scope_ty = ref "" in
  let warn loc msg =
    let open Warnings in
    match msg with
    | Not_principal _ -> w_pr := true
    | Ambiguous_name([s], l, _) -> w_amb := (s, l) :: !w_amb
    | Name_out_of_scope(ty, [s], _) ->
        w_scope := s :: !w_scope; w_scope_ty := ty
    | _ -> Location.prerr_warning loc msg
  in
  let process_label lid =
    (* Strategy for each field:
       * collect all the labels in scope for that name
       * if the type is known and principal, just eventually warn
         if the real label was not in scope
       * fail if there is no known type and no label found
       * otherwise use other fields to reduce the list of candidates
       * if there is no known type reduce it incrementally, so that
         there is still at least one candidate (for error message)
       * if the reduced list is valid, call Label.disambiguate
     *)
    let scope = Typetexp.find_all_labels env lid.loc lid.txt in
    if opath = None && scope = [] then
      Typetexp.unbound_label_error env lid;
    let (ok, labels) =
      match opath with
        Some (_, _, true) -> (true, scope) (* disambiguate only checks scope *)
      | _  -> disambiguate_label_by_ids (opath=None) closed ids scope
    in
    if ok then Label.disambiguate lid env opath labels ~warn ~scope
          else fst (List.hd labels) (* will fail later *)
  in
  let lbl_a_list =
    List.map (fun (lid,a) -> lid, process_label lid, a) lid_a_list in
  if !w_pr then
    Location.prerr_warning loc
      (Warnings.Not_principal "this type-based record disambiguation")
  else begin
    match List.rev !w_amb with
      (_,types)::_ as amb ->
        let paths =
          List.map (fun (_,lbl,_) -> Label.get_type_path lbl) lbl_a_list in
        let path = List.hd paths in
        if List.for_all (compare_type_path env path) (List.tl paths) then
          Location.prerr_warning loc
            (Warnings.Ambiguous_name (List.map fst amb, types, true))
        else
          List.iter
            (fun (s,l) -> Location.prerr_warning loc
                (Warnings.Ambiguous_name ([s],l,false)))
            amb
    | _ -> ()
  end;
  if !w_scope <> [] then
    Location.prerr_warning loc
      (Warnings.Name_out_of_scope (!w_scope_ty, List.rev !w_scope, true));
  lbl_a_list

let rec find_record_qual = function
  | [] -> None
  | ({ txt = Longident.Ldot (modname, _) }, _) :: _ -> Some modname
  | _ :: rest -> find_record_qual rest

let map_fold_cont f xs k =
  List.fold_right (fun x k ys -> f x (fun y -> k (y :: ys)))
    xs (fun ys -> k (List.rev ys)) []

let type_label_a_list ?labels loc closed env type_lbl_a opath lid_a_list k =
  let lbl_a_list =
    match lid_a_list, labels with
      ({txt=Longident.Lident s}, _)::_, Some labels when Hashtbl.mem labels s ->
        (* Special case for rebuilt syntax trees *)
        List.map
          (function lid, a -> match lid.txt with
            Longident.Lident s -> lid, Hashtbl.find labels s, a
          | _ -> assert false)
          lid_a_list
    | _ ->
        let lid_a_list =
          match find_record_qual lid_a_list with
            None -> lid_a_list
          | Some modname ->
              List.map
                (fun (lid, a as lid_a) ->
                  match lid.txt with Longident.Lident s ->
                    {lid with txt=Longident.Ldot (modname, s)}, a
                  | _ -> lid_a)
                lid_a_list
        in
        disambiguate_lid_a_list loc closed env opath lid_a_list
  in
  (* Invariant: records are sorted in the typed tree *)
  let lbl_a_list =
    List.sort
      (fun (_,lbl1,_) (_,lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos)
      lbl_a_list
  in
  map_fold_cont type_lbl_a lbl_a_list k
;;

(* Checks over the labels mentioned in a record pattern:
   no duplicate definitions (error); properly closed (warning) *)

let check_recordpat_labels loc lbl_pat_list closed =
  match lbl_pat_list with
  | [] -> ()                            (* should not happen *)
  | (_, label1, _) :: _ ->
      let all = label1.lbl_all in
      let defined = Array.make (Array.length all) false in
      let check_defined (_, label, _) =
        if defined.(label.lbl_pos)
        then raise(Error(loc, Env.empty, Label_multiply_defined label.lbl_name))
        else defined.(label.lbl_pos) <- true in
      List.iter check_defined lbl_pat_list;
      if closed = Closed
      && Warnings.is_active (Warnings.Non_closed_record_pattern "")
      then begin
        let undefined = ref [] in
        for i = 0 to Array.length all - 1 do
          if not defined.(i) then undefined := all.(i).lbl_name :: !undefined
        done;
        if !undefined <> [] then begin
          let u = String.concat ", " (List.rev !undefined) in
          Location.prerr_warning loc (Warnings.Non_closed_record_pattern u)
        end
      end

(* Constructors *)

module Constructor = NameChoice (struct
  type t = constructor_description
  let type_kind = "variant"
  let get_name cstr = cstr.cstr_name
  let get_type cstr = cstr.cstr_res
  let get_descrs = fst
  let unbound_name_error = Typetexp.unbound_constructor_error
  let in_env _ = true
end)

(* unification of a type with a tconstr with
   freshly created arguments *)
let unify_head_only loc env ty constr =
  let (_, ty_res) = instance_constructor constr in
  match (repr ty_res).desc with
  | Tconstr(p,args,m) ->
      ty_res.desc <- Tconstr(p,List.map (fun _ -> newvar ()) args,m);
      enforce_constraints env ty_res;
      unify_pat_types loc env ty_res ty
  | _ -> assert false

(* Typing of patterns *)

(* Remember current state for backtracking.
   No variable information, as we only backtrack on
   patterns without variables (cf. assert statements). *)
type state =
 { snapshot: Btype.snapshot;
   levels: Ctype.levels;
   env: Env.t; }
let save_state env =
  { snapshot = Btype.snapshot ();
    levels = Ctype.save_levels ();
    env = !env; }
let set_state s env =
  Btype.backtrack s.snapshot;
  Ctype.set_levels s.levels;
  env := s.env

(* type_pat does not generate local constraints inside or patterns *)
type type_pat_mode =
  | Normal
  | Splitting_or   (* splitting an or-pattern *)
  | Inside_or      (* inside a non-split or-pattern *)
  | Split_or       (* always split or-patterns *)

exception Need_backtrack

(* type_pat propagates the expected type as well as maps for
   constructors and labels.
   Unification may update the typing environment. *)
(* constrs <> None => called from parmatch: backtrack on or-patterns
   explode > 0 => explode Ppat_any for gadts *)
let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
    sp expected_ty k =
  Builtin_attributes.warning_scope sp.ppat_attributes
    (fun () ->
       type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
         sp expected_ty k
    )

and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
    sp expected_ty k =
  let mode' = if mode = Splitting_or then Normal else mode in
  let type_pat ?(constrs=constrs) ?(labels=labels) ?(mode=mode')
      ?(explode=explode) ?(env=env) =
    type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env in
  let loc = sp.ppat_loc in
  let rp k x : pattern = if constrs = None then k (rp x) else k x in
  match sp.ppat_desc with
    Ppat_any ->
      let k' d = rp k {
        pat_desc = d;
        pat_loc = loc; pat_extra=[];
        pat_type = expected_ty;
        pat_attributes = sp.ppat_attributes;
        pat_env = !env }
      in
      if explode > 0 then
        let (sp, constrs, labels) = Parmatch.ppat_of_type !env expected_ty in
        if sp.ppat_desc = Parsetree.Ppat_any then k' Tpat_any else
        if mode = Inside_or then raise Need_backtrack else
        let explode =
          match sp.ppat_desc with
            Parsetree.Ppat_or _ -> explode - 5
          | _ -> explode - 1
        in
        type_pat ~constrs:(Some constrs) ~labels:(Some labels)
          ~explode sp expected_ty k
      else k' Tpat_any
  | Ppat_var name ->
      let id = (* PR#7330 *)
        if name.txt = "*extension*" then Ident.create name.txt else
        enter_variable loc name expected_ty
      in
      rp k {
        pat_desc = Tpat_var (id, name);
        pat_loc = loc; pat_extra=[];
        pat_type = expected_ty;
        pat_attributes = sp.ppat_attributes;
        pat_env = !env }
  | Ppat_unpack name ->
      assert (constrs = None);
      let id = enter_variable loc name expected_ty ~is_module:true in
      rp k {
        pat_desc = Tpat_var (id, name);
        pat_loc = sp.ppat_loc;
        pat_extra=[Tpat_unpack, loc, sp.ppat_attributes];
        pat_type = expected_ty;
        pat_attributes = [];
        pat_env = !env }
  | Ppat_constraint({ppat_desc=Ppat_var name; ppat_loc=lloc},
                    ({ptyp_desc=Ptyp_poly _} as sty)) ->
      (* explicitly polymorphic type *)
      assert (constrs = None);
      let cty, force = Typetexp.transl_simple_type_delayed !env sty in
      let ty = cty.ctyp_type in
      unify_pat_types lloc !env ty expected_ty;
      pattern_force := force :: !pattern_force;
      begin match ty.desc with
      | Tpoly (body, tyl) ->
          begin_def ();
          let _, ty' = instance_poly ~keep_names:true false tyl body in
          end_def ();
          generalize ty';
          let id = enter_variable lloc name ty' in
          rp k {
            pat_desc = Tpat_var (id, name);
            pat_loc = lloc;
            pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes];
            pat_type = ty;
            pat_attributes = [];
            pat_env = !env
          }
      | _ -> assert false
      end
  | Ppat_alias(sq, name) ->
      assert (constrs = None);
      type_pat sq expected_ty (fun q ->
        begin_def ();
        let ty_var = build_as_type !env q in
        end_def ();
        generalize ty_var;
        let id = enter_variable ~is_as_variable:true loc name ty_var in
        rp k {
          pat_desc = Tpat_alias(q, id, name);
          pat_loc = loc; pat_extra=[];
          pat_type = q.pat_type;
          pat_attributes = sp.ppat_attributes;
          pat_env = !env })
  | Ppat_constant cst ->
      let cst = constant_or_raise !env loc cst in
      unify_pat_types loc !env (type_constant cst) expected_ty;
      rp k {
        pat_desc = Tpat_constant cst;
        pat_loc = loc; pat_extra=[];
        pat_type = expected_ty;
        pat_attributes = sp.ppat_attributes;
        pat_env = !env }
  | Ppat_interval (Pconst_char c1, Pconst_char c2) ->
      let open Ast_helper.Pat in
      let gloc = {loc with Location.loc_ghost=true} in
      let rec loop c1 c2 =
        if c1 = c2 then constant ~loc:gloc (Pconst_char c1)
        else
          or_ ~loc:gloc
            (constant ~loc:gloc (Pconst_char c1))
            (loop (Char.chr(Char.code c1 + 1)) c2)
      in
      let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in
      let p = {p with ppat_loc=loc} in
      type_pat ~explode:0 p expected_ty k
        (* TODO: record 'extra' to remember about interval *)
  | Ppat_interval _ ->
      raise (Error (loc, !env, Invalid_interval))
  | Ppat_tuple spl ->
      assert (List.length spl >= 2);
      let spl_ann = List.map (fun p -> (p,newvar ())) spl in
      let ty = newty (Ttuple(List.map snd spl_ann)) in
      unify_pat_types loc !env ty expected_ty;
      map_fold_cont (fun (p,t) -> type_pat p t) spl_ann (fun pl ->
        rp k {
        pat_desc = Tpat_tuple pl;
        pat_loc = loc; pat_extra=[];
        pat_type = expected_ty;
        pat_attributes = sp.ppat_attributes;
        pat_env = !env })
  | Ppat_construct(lid, sarg) ->
      let opath =
        try
          let (p0, p, _) = extract_concrete_variant !env expected_ty in
            Some (p0, p, true)
        with Not_found -> None
      in
      let candidates =
        match lid.txt, constrs with
          Longident.Lident s, Some constrs when Hashtbl.mem constrs s ->
            [Hashtbl.find constrs s, (fun () -> ())]
        | _ ->  Typetexp.find_all_constructors !env lid.loc lid.txt
      in
      let check_lk tpath constr =
        if constr.cstr_generalized then
          raise (Error (lid.loc, !env,
                        Unqualified_gadt_pattern (tpath, constr.cstr_name)))
      in
      let constr =
        wrap_disambiguate "This variant pattern is expected to have" expected_ty
          (Constructor.disambiguate lid !env opath ~check_lk) candidates
      in
      if constr.cstr_generalized && constrs <> None && mode = Inside_or
      then raise Need_backtrack;
      Env.mark_constructor Env.Pattern !env (Longident.last lid.txt) constr;
      Builtin_attributes.check_deprecated loc constr.cstr_attributes
        constr.cstr_name;
      if no_existentials && constr.cstr_existentials <> [] then
        raise (Error (loc, !env, Unexpected_existential));
      (* if constructor is gadt, we must verify that the expected type has the
         correct head *)
      if constr.cstr_generalized then
        unify_head_only loc !env expected_ty constr;
      let sargs =
        match sarg with
          None -> []
        | Some {ppat_desc = Ppat_tuple spl} when
            constr.cstr_arity > 1 ||
            Builtin_attributes.explicit_arity sp.ppat_attributes
          -> spl
        | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity <> 1 ->
            if constr.cstr_arity = 0 then
              Location.prerr_warning sp.ppat_loc
                                     Warnings.Wildcard_arg_to_constant_constr;
            replicate_list sp constr.cstr_arity
        | Some sp -> [sp] in
      begin match sargs with
      | [{ppat_desc = Ppat_constant _} as sp]
        when Builtin_attributes.warn_on_literal_pattern
            constr.cstr_attributes ->
          Location.prerr_warning sp.ppat_loc
            Warnings.Fragile_literal_pattern
      | _ -> ()
      end;
      if List.length sargs <> constr.cstr_arity then
        raise(Error(loc, !env, Constructor_arity_mismatch(lid.txt,
                                     constr.cstr_arity, List.length sargs)));
      let (ty_args, ty_res) =
        instance_constructor ~in_pattern:(env, get_newtype_level ()) constr
      in
      (* PR#7214: do not use gadt unification for toplevel lets *)
      if not constr.cstr_generalized || mode = Inside_or || no_existentials
      then unify_pat_types loc !env ty_res expected_ty
      else unify_pat_types_gadt loc env ty_res expected_ty;

      let rec check_non_escaping p =
        match p.ppat_desc with
        | Ppat_or (p1, p2) ->
            check_non_escaping p1;
            check_non_escaping p2
        | Ppat_alias (p, _) ->
            check_non_escaping p
        | Ppat_constraint _ ->
            raise (Error (p.ppat_loc, !env, Inlined_record_escape))
        | _ ->
            ()
      in
      if constr.cstr_inlined <> None then List.iter check_non_escaping sargs;

      map_fold_cont (fun (p,t) -> type_pat p t) (List.combine sargs ty_args)
      (fun args ->
        rp k {
          pat_desc=Tpat_construct(lid, constr, args);
          pat_loc = loc; pat_extra=[];
          pat_type = expected_ty;
          pat_attributes = sp.ppat_attributes;
          pat_env = !env })
  | Ppat_variant(l, sarg) ->
      let arg_type = match sarg with None -> [] | Some _ -> [newvar()] in
      let row = { row_fields =
                    [l, Reither(sarg = None, arg_type, true, ref None)];
                  row_bound = ();
                  row_closed = false;
                  row_more = newvar ();
                  row_fixed = false;
                  row_name = None } in
      (* PR#7404: allow some_other_tag blindly, as it would not unify with
         the abstract row variable *)
      if l = Parmatch.some_other_tag then assert (constrs <> None)
      else unify_pat_types loc !env (newty (Tvariant row)) expected_ty;
      let k arg =
        rp k {
        pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()});
        pat_loc = loc; pat_extra=[];
        pat_type =  expected_ty;
        pat_attributes = sp.ppat_attributes;
        pat_env = !env }
      in begin
        (* PR#6235: propagate type information *)
        match sarg, arg_type with
          Some p, [ty] -> type_pat p ty (fun p -> k (Some p))
        | _            -> k None
      end
  | Ppat_record(lid_sp_list, closed) ->
      assert (lid_sp_list <> []);
      let opath, record_ty =
        try
          let (p0, p,_) = extract_concrete_record !env expected_ty in
          Some (p0, p, true), expected_ty
        with Not_found -> None, newvar ()
      in
      let type_label_pat (label_lid, label, sarg) k =
        begin_def ();
        let (vars, ty_arg, ty_res) = instance_label false label in
        if vars = [] then end_def ();
        begin try
          unify_pat_types loc !env ty_res record_ty
        with Unify trace ->
          raise(Error(label_lid.loc, !env,
                      Label_mismatch(label_lid.txt, trace)))
        end;
        type_pat sarg ty_arg (fun arg ->
          if vars <> [] then begin
            end_def ();
            generalize ty_arg;
            List.iter generalize vars;
            let instantiated tv =
              let tv = expand_head !env tv in
              not (is_Tvar tv) || tv.level <> generic_level in
            if List.exists instantiated vars then
              raise
                (Error(label_lid.loc, !env, Polymorphic_label label_lid.txt))
          end;
          k (label_lid, label, arg))
      in
      let k' k lbl_pat_list =
        check_recordpat_labels loc lbl_pat_list closed;
        unify_pat_types loc !env record_ty expected_ty;
        rp k {
        pat_desc = Tpat_record (lbl_pat_list, closed);
        pat_loc = loc; pat_extra=[];
        pat_type = expected_ty;
        pat_attributes = sp.ppat_attributes;
        pat_env = !env }
      in
      if constrs = None then
        k (wrap_disambiguate "This record pattern is expected to have"
             expected_ty
             (type_label_a_list ?labels loc false !env type_label_pat opath
                lid_sp_list)
             (k' (fun x -> x)))
      else
        type_label_a_list ?labels loc false !env type_label_pat opath
          lid_sp_list (k' k)
  | Ppat_array spl ->
      let ty_elt = newvar() in
      unify_pat_types
        loc !env (instance_def (Predef.type_array ty_elt)) expected_ty;
      let spl_ann = List.map (fun p -> (p,newvar())) spl in
      map_fold_cont (fun (p,_) -> type_pat p ty_elt) spl_ann (fun pl ->
        rp k {
        pat_desc = Tpat_array pl;
        pat_loc = loc; pat_extra=[];
        pat_type = expected_ty;
        pat_attributes = sp.ppat_attributes;
        pat_env = !env })
  | Ppat_or(sp1, sp2) ->
      let state = save_state env in
      begin match
        if mode = Split_or || mode = Splitting_or then raise Need_backtrack;
        let initial_pattern_variables = !pattern_variables in
        let initial_module_variables = !module_variables in
        let p1 =
          try Some (type_pat ~mode:Inside_or sp1 expected_ty (fun x -> x))
          with Need_backtrack -> None in
        let p1_variables = !pattern_variables in
        let p1_module_variables = !module_variables in
        pattern_variables := initial_pattern_variables;
        module_variables := initial_module_variables;
        let p2 =
          try Some (type_pat ~mode:Inside_or sp2 expected_ty (fun x -> x))
          with Need_backtrack -> None in
        let p2_variables = !pattern_variables in
        match p1, p2 with
          None, None -> raise Need_backtrack
        | Some p, None | None, Some p -> p (* no variables in this case *)
        | Some p1, Some p2 ->
        let alpha_env =
          enter_orpat_variables loc !env p1_variables p2_variables in
        pattern_variables := p1_variables;
        module_variables := p1_module_variables;
        { pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None);
          pat_loc = loc; pat_extra=[];
          pat_type = expected_ty;
          pat_attributes = sp.ppat_attributes;
          pat_env = !env }
      with
        p -> rp k p
      | exception Need_backtrack when mode <> Inside_or ->
          assert (constrs <> None);
          set_state state env;
          let mode =
            if mode = Split_or then mode else Splitting_or in
          try type_pat ~mode sp1 expected_ty k with Error _ ->
            set_state state env;
            type_pat ~mode sp2 expected_ty k
      end
  | Ppat_lazy sp1 ->
      let nv = newvar () in
      unify_pat_types loc !env (instance_def (Predef.type_lazy_t nv))
        expected_ty;
      (* do not explode under lazy: PR#7421 *)
      type_pat ~explode:0 sp1 nv (fun p1 ->
        rp k {
        pat_desc = Tpat_lazy p1;
        pat_loc = loc; pat_extra=[];
        pat_type = expected_ty;
        pat_attributes = sp.ppat_attributes;
        pat_env = !env })
  | Ppat_constraint(sp, sty) ->
      (* Separate when not already separated by !principal *)
      let separate = true in
      if separate then begin_def();
      let cty, force = Typetexp.transl_simple_type_delayed !env sty in
      let ty = cty.ctyp_type in
      let ty, expected_ty' =
        if separate then begin
          end_def();
          generalize_structure ty;
          instance !env ty, instance !env ty
        end else ty, ty
      in
      unify_pat_types loc !env ty expected_ty;
      type_pat sp expected_ty' (fun p ->
        (*Format.printf "%a@.%a@."
          Printtyp.raw_type_expr ty
          Printtyp.raw_type_expr p.pat_type;*)
        pattern_force := force :: !pattern_force;
        let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in
        let p =
          if not separate then p else
          match p.pat_desc with
            Tpat_var (id,s) ->
              {p with pat_type = ty;
               pat_desc = Tpat_alias
                 ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s);
               pat_extra = [extra];
             }
          | _ -> {p with pat_type = ty;
                  pat_extra = extra :: p.pat_extra}
        in k p)
  | Ppat_type lid ->
      let (path, p,ty) = build_or_pat !env loc lid in
      unify_pat_types loc !env ty expected_ty;
      k { p with pat_extra =
        (Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra }
  | Ppat_open (lid,p) ->
      let path, new_env =
        !type_open Asttypes.Fresh !env sp.ppat_loc lid in
      let new_env = ref new_env in
      type_pat ~env:new_env p expected_ty ( fun p ->
        env := Env.copy_local !env ~from:!new_env;
        k { p with pat_extra =( Tpat_open (path,lid,!new_env),
                            loc, sp.ppat_attributes) :: p.pat_extra }
      )
  | Ppat_exception _ ->
      raise (Error (loc, !env, Exception_pattern_below_toplevel))
  | Ppat_extension ext ->
      raise (Error_forward (Builtin_attributes.error_of_extension ext))

let type_pat ?(allow_existentials=false) ?constrs ?labels ?(mode=Normal)
    ?(explode=0) ?(lev=get_current_level()) env sp expected_ty =
  newtype_level := Some lev;
  try
    let r =
      type_pat ~no_existentials:(not allow_existentials) ~constrs ~labels
        ~mode ~explode ~env sp expected_ty (fun x -> x) in
    iter_pattern (fun p -> p.pat_env <- !env) r;
    newtype_level := None;
    r
  with e ->
    newtype_level := None;
    raise e


(* this function is passed to Partial.parmatch
   to type check gadt nonexhaustiveness *)
let partial_pred ~lev ?mode ?explode env expected_ty constrs labels p =
  let env = ref env in
  let state = save_state env in
  try
    reset_pattern None true;
    let typed_p =
      Ctype.with_passive_variants
        (type_pat ~allow_existentials:true ~lev
           ~constrs ~labels ?mode ?explode env p)
        expected_ty
    in
    set_state state env;
    (* types are invalidated but we don't need them here *)
    Some typed_p
  with Error _ ->
    set_state state env;
    None

let check_partial ?(lev=get_current_level ()) env expected_ty loc cases =
  let explode = match cases with [_] -> 5 | _ -> 0 in
  Parmatch.check_partial_gadt
    (partial_pred ~lev ~explode env expected_ty) loc cases

let check_unused ?(lev=get_current_level ()) env expected_ty cases =
  Parmatch.check_unused
    (fun refute constrs labels spat ->
      match
        partial_pred ~lev ~mode:Split_or ~explode:5
          env expected_ty constrs labels spat
      with
        Some pat when refute ->
          raise (Error (spat.ppat_loc, env, Unrefuted_pattern pat))
      | r -> r)
    cases

let add_pattern_variables ?check ?check_as env =
  let pv = get_ref pattern_variables in
  (List.fold_right
     (fun (id, ty, _name, loc, as_var) env ->
       let check = if as_var then check_as else check in
       Env.add_value ?check id
         {val_type = ty; val_kind = Val_reg; Types.val_loc = loc;
          val_attributes = [];
         } env
     )
     pv env,
   get_ref module_variables)

let type_pattern ~lev env spat scope expected_ty =
  reset_pattern scope true;
  let new_env = ref env in
  let pat = type_pat ~allow_existentials:true ~lev new_env spat expected_ty in
  let new_env, unpacks =
    add_pattern_variables !new_env
      ~check:(fun s -> Warnings.Unused_var_strict s)
      ~check_as:(fun s -> Warnings.Unused_var s) in
  (pat, new_env, get_ref pattern_force, unpacks)

let type_pattern_list env spatl scope expected_tys allow =
  reset_pattern scope allow;
  let new_env = ref env in
  let type_pat (attrs, pat) ty =
    Builtin_attributes.warning_scope ~ppwarning:false attrs
      (fun () ->
         type_pat new_env pat ty
      )
  in
  let patl = List.map2 type_pat spatl expected_tys in
  let new_env, unpacks = add_pattern_variables !new_env in
  (patl, new_env, get_ref pattern_force, unpacks)

let type_class_arg_pattern cl_num val_env met_env l spat =
  reset_pattern None false;
  let nv = newvar () in
  let pat = type_pat (ref val_env) spat nv in
  if has_variants pat then begin
    Parmatch.pressure_variants val_env [pat];
    iter_pattern finalize_variant pat
  end;
  List.iter (fun f -> f()) (get_ref pattern_force);
  if is_optional l then unify_pat val_env pat (type_option (newvar ()));
  let (pv, met_env) =
    List.fold_right
      (fun (id, ty, name, loc, as_var) (pv, env) ->
         let check s =
           if as_var then Warnings.Unused_var s
           else Warnings.Unused_var_strict s in
         let id' = Ident.create (Ident.name id) in
         ((id', name, id, ty)::pv,
          Env.add_value id' {val_type = ty;
                             val_kind = Val_ivar (Immutable, cl_num);
                             val_attributes = [];
                             Types.val_loc = loc;
                            } ~check
            env))
      !pattern_variables ([], met_env)
  in
  let val_env, _ = add_pattern_variables val_env in
  (pat, pv, val_env, met_env)

let type_self_pattern cl_num privty val_env met_env par_env spat =
  let open Ast_helper in
  let spat =
    Pat.mk (Ppat_alias (Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")),
                        mknoloc ("selfpat-" ^ cl_num)))
  in
  reset_pattern None false;
  let nv = newvar() in
  let pat = type_pat (ref val_env) spat nv in
  List.iter (fun f -> f()) (get_ref pattern_force);
  let meths = ref Meths.empty in
  let vars = ref Vars.empty in
  let pv = !pattern_variables in
  pattern_variables := [];
  let (val_env, met_env, par_env) =
    List.fold_right
      (fun (id, ty, _name, loc, as_var) (val_env, met_env, par_env) ->
         (Env.add_value id {val_type = ty;
                            val_kind = Val_unbound;
                            val_attributes = [];
                            Types.val_loc = loc;
                           } val_env,
          Env.add_value id {val_type = ty;
                            val_kind = Val_self (meths, vars, cl_num, privty);
                            val_attributes = [];
                            Types.val_loc = loc;
                           }
            ~check:(fun s -> if as_var then Warnings.Unused_var s
                             else Warnings.Unused_var_strict s)
            met_env,
          Env.add_value id {val_type = ty; val_kind = Val_unbound;
                            val_attributes = [];
                            Types.val_loc = loc;
                           } par_env))
      pv (val_env, met_env, par_env)
  in
  (pat, meths, vars, val_env, met_env, par_env)

let delayed_checks = ref []
let reset_delayed_checks () = delayed_checks := []
let add_delayed_check f =
  delayed_checks := (f, Warnings.backup ()) :: !delayed_checks

let force_delayed_checks () =
  (* checks may change type levels *)
  let snap = Btype.snapshot () in
  let w_old = Warnings.backup () in
  List.iter
    (fun (f, w) -> Warnings.restore w; f ())
    (List.rev !delayed_checks);
  Warnings.restore w_old;
  reset_delayed_checks ();
  Btype.backtrack snap

let rec final_subexpression sexp =
  match sexp.pexp_desc with
    Pexp_let (_, _, e)
  | Pexp_sequence (_, e)
  | Pexp_try (e, _)
  | Pexp_ifthenelse (_, e, _)
  | Pexp_match (_, {pc_rhs=e} :: _)
    -> final_subexpression e
  | _ -> sexp

(* Generalization criterion for expressions *)

let rec is_nonexpansive exp =
  match exp.exp_desc with
    Texp_ident(_,_,_) -> true
  | Texp_constant _ -> true
  | Texp_let(_rec_flag, pat_exp_list, body) ->
      List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list &&
      is_nonexpansive body
  | Texp_function _ -> true
  | Texp_apply(e, (_,None)::el) ->
      is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd el)
  | Texp_match(e, cases, [], _) ->
      is_nonexpansive e &&
      List.for_all
        (fun {c_lhs = _; c_guard; c_rhs} ->
           is_nonexpansive_opt c_guard && is_nonexpansive c_rhs
        ) cases
  | Texp_tuple el ->
      List.for_all is_nonexpansive el
  | Texp_construct( _, _, el) ->
      List.for_all is_nonexpansive el
  | Texp_variant(_, arg) -> is_nonexpansive_opt arg
  | Texp_record { fields; extended_expression } ->
      Array.for_all
        (fun (lbl, definition) ->
           match definition with
           | Overridden (_, exp) ->
               lbl.lbl_mut = Immutable && is_nonexpansive exp
           | Kept _ -> true)
        fields
      && is_nonexpansive_opt extended_expression
  | Texp_field(exp, _, _) -> is_nonexpansive exp
  | Texp_array [] -> true
  | Texp_ifthenelse(_cond, ifso, ifnot) ->
      is_nonexpansive ifso && is_nonexpansive_opt ifnot
  | Texp_sequence (_e1, e2) -> is_nonexpansive e2  (* PR#4354 *)
  | Texp_new (_, _, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 ->
      true
  (* Note: nonexpansive only means no _observable_ side effects *)
  | Texp_lazy e -> is_nonexpansive e
  | Texp_object ({cstr_fields=fields; cstr_type = { csig_vars=vars}}, _) ->
      let count = ref 0 in
      List.for_all
        (fun field -> match field.cf_desc with
            Tcf_method _ -> true
          | Tcf_val (_, _, _, Tcfk_concrete (_, e), _) ->
              incr count; is_nonexpansive e
          | Tcf_val (_, _, _, Tcfk_virtual _, _) ->
              incr count; true
          | Tcf_initializer e -> is_nonexpansive e
          | Tcf_constraint _ -> true
          | Tcf_inherit _ -> false
          | Tcf_attribute _ -> true)
        fields &&
      Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)
        vars true &&
      !count = 0
  | Texp_letmodule (_, _, mexp, e) ->
      is_nonexpansive_mod mexp && is_nonexpansive e
  | Texp_pack mexp ->
      is_nonexpansive_mod mexp
  (* Computations which raise exceptions are nonexpansive, since (raise e) is equivalent
     to (raise e; diverge), and a nonexpansive "diverge" can be produced using lazy values
     or the relaxed value restriction. See GPR#1142 *)
  | Texp_assert exp ->
      is_nonexpansive exp
  | Texp_apply (
      { exp_desc = Texp_ident (_, _, {val_kind =
             Val_prim {Primitive.prim_name = "%raise"}}) },
      [Nolabel, Some e]) ->
     is_nonexpansive e
  | _ -> false

and is_nonexpansive_mod mexp =
  match mexp.mod_desc with
  | Tmod_ident _ -> true
  | Tmod_functor _ -> true
  | Tmod_unpack (e, _) -> is_nonexpansive e
  | Tmod_constraint (m, _, _, _) -> is_nonexpansive_mod m
  | Tmod_structure str ->
      List.for_all
        (fun item -> match item.str_desc with
          | Tstr_eval _ | Tstr_primitive _ | Tstr_type _
          | Tstr_modtype _ | Tstr_open _ | Tstr_class_type _  -> true
          | Tstr_value (_, pat_exp_list) ->
              List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list
          | Tstr_module {mb_expr=m;_}
          | Tstr_include {incl_mod=m;_} -> is_nonexpansive_mod m
          | Tstr_recmodule id_mod_list ->
              List.for_all (fun {mb_expr=m;_} -> is_nonexpansive_mod m)
                id_mod_list
          | Tstr_exception {ext_kind = Text_decl _} ->
              false (* true would be unsound *)
          | Tstr_exception {ext_kind = Text_rebind _} -> true
          | Tstr_typext te ->
              List.for_all
                (function {ext_kind = Text_decl _} -> false
                        | {ext_kind = Text_rebind _} -> true)
                te.tyext_constructors
          | Tstr_class _ -> false (* could be more precise *)
          | Tstr_attribute _ -> true
        )
        str.str_items
  | Tmod_apply _ -> false

and is_nonexpansive_opt = function
    None -> true
  | Some e -> is_nonexpansive e

module Env' = Env
module Rec_context =
struct
  type access =
      Dereferenced
    (** [Dereferenced] indicates that the value (not just the address) of a
        variable is accessed *)

    | Guarded
    (** [Guarded] indicates that the address of a variable is used in a
        guarded context, i.e. under a constructor.  A variable that is
        dereferenced within a function body or lazy context is also considered
        guarded. *)

    | Unguarded
    (** [Unguarded] indicates that the address of a variable is used in an
        unguarded context, i.e. not under a constructor. *)

  (** [guard] represents guarded contexts such as [C -] and [{l = -}] *)
  let guard : access -> access = function
    | Dereferenced -> Dereferenced
    | Guarded -> Guarded
    | Unguarded -> Guarded

  (** [inspect] represents elimination contexts such as [match - with cases],
      [e -] and [- e] *)
  let inspect : access -> access = function
    | Dereferenced -> Dereferenced
    | Guarded -> Dereferenced
    | Unguarded -> Dereferenced

  (** [delay] represents contexts that delay evaluation such as [fun p -> -]
      or [lazy -] *)
  let delay : access -> access = function
    | Dereferenced -> Guarded
    | Guarded -> Guarded
    | Unguarded -> Guarded

  module Use :
  sig
    type t
    val guard : t -> t
    (** An expression appears in a guarded context *)

    val discard : t -> t
    (** The address of a subexpression is not used, but may be bound *)

    val inspect : t -> t
    (** The value of a subexpression is inspected with match, application, etc. *)

    val delay : t -> t
    (** An expression appears under 'fun p ->' or 'lazy' *)

    val join : t -> t -> t
    (** Combine the access information of two expressions *)

    val single : Ident.t -> access -> t
    (** Combine the access information of two expressions *)

    val empty : t
    (** No variables are accessed in an expression; it might be a
        constant or a global identifier *)
      
    val unguarded : t -> Ident.t list
    (** The list of identifiers that are used in an unguarded context *)

    val dependent : t -> Ident.t list
    (** The list of all used identifiers *)
  end =
  struct
    module M = Map.Make(Ident)

    (** A "t" maps each rec-bound variable to an access status *)
    type t = access M.t

    let map f tbl = M.map f tbl
    let guard t = map guard t
    let inspect t = map inspect t
    let delay t = map delay t
    let discard = guard

    let prec x y =
      match x, y with
      | Dereferenced, _
      | _, Dereferenced -> Dereferenced
      | Unguarded, _
      | _, Unguarded -> Unguarded
      | _ -> Guarded

    let join x y =
      M.fold
        (fun id v tbl ->
           let v' = try M.find id tbl with Not_found -> Guarded in
           M.add id (prec v v') tbl)
        x y

    let single id access = M.add id access M.empty
  
    let empty = M.empty

    let list_matching p t =
      let r = ref [] in
      M.iter (fun id v -> if p v then r := id :: !r) t;
      !r
    
    let unguarded =
      list_matching (function Unguarded | Dereferenced -> true | _ -> false)

    let dependent =
      list_matching (function _ -> true)
  end

  module Env =
  struct
    (* A typing environment maps identifiers to types *)
    type env = Use.t Ident.tbl

    let empty = Ident.empty

    let join x y =
      let r = 
      Ident.fold_all
        (fun id v tbl ->
           let v' = try Ident.find_same id tbl with Not_found -> Use.empty in
           Ident.add id (Use.join v v') tbl)
        x
        y
      in
      r
  end
end

let rec pattern_variables : Typedtree.pattern -> Ident.t list =
  fun pat -> match pat.pat_desc with
    | Tpat_any -> []
    | Tpat_var (id, _) -> [id]
    | Tpat_alias (pat, id, _) -> id :: pattern_variables pat
    | Tpat_constant _ -> []
    | Tpat_tuple pats -> List.concat (List.map pattern_variables pats)
    | Tpat_construct (_, _, pats) ->
        List.concat (List.map pattern_variables pats)
    | Tpat_variant (_, Some pat, _) -> pattern_variables pat
    | Tpat_variant (_, None, _) -> []
    | Tpat_record (fields, _) ->
        List.concat (List.map (fun (_,_,p) -> pattern_variables p) fields)
    | Tpat_array pats ->
        List.concat (List.map pattern_variables pats)
    | Tpat_or (l,r,_) ->
        pattern_variables l @ pattern_variables r
    | Tpat_lazy p ->
        pattern_variables p

module Rec_check =
struct
  open Rec_context

  let build_unguarded_env : Ident.t list -> Env.env = fun idlist ->
    List.fold_left
      (fun env id -> Ident.add id (Use.single id Unguarded) env)
      Env.empty
      idlist

  let is_ref : Types.value_description -> bool = function
    | { Types.val_kind =
          Types.Val_prim { Primitive.prim_name = "%makemutable";
                           prim_arity = 1 } } ->
          true
    | _ -> false

  let scrape env ty =
    (Ctype.repr (Ctype.expand_head_opt env (Ctype.correct_levels ty))).desc

  let array_element_kind env ty =
    match scrape env ty with
    | Tvar _ | Tunivar _ ->
        `Pgenarray
    | Tconstr(p, _, _) ->
        if Path.same p Predef.path_int || Path.same p Predef.path_char then
          `Pintarray
        else if Path.same p Predef.path_float then
          `Pfloatarray
        else if Path.same p Predef.path_string
             || Path.same p Predef.path_array
             || Path.same p Predef.path_nativeint
             || Path.same p Predef.path_int32
             || Path.same p Predef.path_int64 then
          `Paddrarray
        else begin
          try
            match Env'.find_type p env with
              {type_kind = Type_abstract} ->
                `Pgenarray
            | {type_kind = Type_variant cstrs}
              when List.for_all (fun c -> c.Types.cd_args = Types.Cstr_tuple [])
                  cstrs ->
                `Pintarray
            | {type_kind = _} ->
                `Paddrarray
          with Not_found ->
            (* This can happen due to e.g. missing -I options,
               causing some .cmi files to be unavailable.
               Maybe we should emit a warning. *)
            `Pgenarray
        end
    | _ ->
        `Paddrarray

  let array_type_kind env ty =
    match scrape env ty with
    | Tconstr(p, [elt_ty], _) | Tpoly({desc = Tconstr(p, [elt_ty], _)}, _)
      when Path.same p Predef.path_array ->
        array_element_kind env elt_ty
    | _ ->
        (* This can happen with e.g. Obj.field *)
        `Pgenarray

  let array_kind exp = array_type_kind exp.exp_env exp.exp_type

  let has_concrete_element_type : Typedtree.expression -> bool =
    fun e -> array_kind e <> `Pgenarray

  type sd = Static | Dynamic

  let rec classify_expression : Typedtree.expression -> sd =
    fun exp -> match exp.exp_desc with 
      | Texp_let (_, _, e)
      | Texp_letmodule (_, _, _, e)
      | Texp_sequence (_, e)
      | Texp_letexception (_, e) -> classify_expression e
      | Texp_ident _
      | Texp_for _
      | Texp_constant _
      | Texp_new _
      | Texp_instvar _
      | Texp_tuple _
      | Texp_array _
      | Texp_construct _
      | Texp_variant _
      | Texp_record _
      | Texp_setfield _
      | Texp_while _
      | Texp_setinstvar _
      | Texp_pack _
      | Texp_object _
      | Texp_function _
      | Texp_lazy _
      | Texp_unreachable
      | Texp_extension_constructor _ -> Static
      | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, _)
        when is_ref vd -> Static
      | Texp_apply _
      | Texp_match _
      | Texp_ifthenelse _
      | Texp_send _
      | Texp_field _
      | Texp_assert _
      | Texp_try _
      | Texp_override _ -> Dynamic

  let rec expression : Env.env -> Typedtree.expression -> Use.t =
    fun env exp -> match exp.exp_desc with
      | Texp_ident (pth, _, _) ->
          (path env pth)
      | Texp_let (rec_flag, bindings, body) ->
        let env', ty = value_bindings rec_flag env bindings in
        (* Here and in other binding constructs 'discard' is used in a
           similar way to the way it's used in sequence: uses are
           propagated, but unguarded access are not. *)
        Use.join (Use.discard ty) (expression (Env.join env env') body)
      | Texp_letmodule (x, _, m, e) ->
        let ty = modexp env m in
        Use.join (Use.discard ty) (expression (Ident.add x ty env) e)
      | Texp_match (e, val_cases, exn_cases, _) ->
        let t = expression env e in
        let exn_case env {Typedtree.c_rhs} = expression env c_rhs in
        let cs = list (case ~scrutinee:t) env val_cases
        and es = list exn_case env exn_cases in
        Use.(join cs es)
      | Texp_for (_, _, e1, e2, _, e3) ->
        Use.(join
                (join
                   (inspect (expression env e1))
                   (inspect (expression env e2)))
                (* The body is evaluated, but not used, and not available 
                   for inclusion in another value *)
                (discard (expression env e3)))

      | Texp_constant _ ->
        Use.empty
      | Texp_new (pth, _, _) ->
          Use.inspect (path env pth)
      | Texp_instvar _ ->
        Use.empty
      | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, [_, Some arg])
        when is_ref vd ->
          Use.guard (expression env arg)
      | Texp_apply (e, args) ->
        let arg env (_, eo) = option expression env eo in
        Use.(join
                (inspect (expression env e))
                (inspect (list arg env args)))
      | Texp_tuple exprs ->
        Use.guard (list expression env exprs)
      | Texp_array exprs when array_kind exp = `Pfloatarray ->
        Use.inspect (list expression env exprs)
      | Texp_array exprs when has_concrete_element_type exp ->
        Use.guard (list expression env exprs)
      | Texp_array exprs ->
        (* This is counted as a use, because constructing a generic array
           involves inspecting the elements (PR#6939). *)
        Use.inspect (list expression env exprs)
      | Texp_construct (_, desc, exprs) ->
        let access_constructor =
          match desc.cstr_tag with
          | Cstr_extension (pth, _) -> Use.inspect (path env pth)
          | _ -> Use.empty
        in
        let use = match desc.cstr_tag with
          | Cstr_unboxed -> (fun x -> x)
          | Cstr_constant _ | Cstr_block _ | Cstr_extension _ -> Use.guard
        in
        Use.join access_constructor (use (list expression env exprs))
      | Texp_variant (_, eo) ->
        Use.guard (option expression env eo)
      | Texp_record { fields = es; extended_expression = eo;
                      representation = rep } ->
          let use = match rep with
            | Record_float -> Use.inspect
            | Record_unboxed _ -> (fun x -> x)
            | Record_regular | Record_inlined _
            | Record_extension -> Use.guard
          in
          let field env = function
              _, Kept _ -> Use.empty
            | _, Overridden (_, e) -> expression env e
          in
          Use.join
            (use (array field env es))
            (option expression env eo)
      | Texp_ifthenelse (cond, ifso, ifnot) ->
          Use.(join (inspect (expression env cond))
                  (join
                     (expression env ifso)
                     (option expression env ifnot)))
      | Texp_setfield (e1, _, _, e2) ->
          Use.(join (inspect (expression env e1))
                (inspect (expression env e2)))
      | Texp_sequence (e1, e2) ->
        Use.(join (discard (expression env e1))
                (expression env e2))
      | Texp_while (e1, e2) ->
        Use.(join (inspect (expression env e1))
                (discard (expression env e2)))
      | Texp_send (e1, _, eo) ->
        Use.(join (inspect (expression env e1))
                (inspect (option expression env eo)))
      | Texp_field (e, _, _) ->
        Use.(inspect (expression env e))
      | Texp_setinstvar (_,_,_,e) ->
          Use.(inspect (expression env e))
      | Texp_letexception (_, e) ->
          expression env e
      | Texp_assert e ->
          Use.inspect (expression env e)
      | Texp_pack m ->
          modexp env m
      | Texp_object (clsstrct, _) ->
          class_structure env clsstrct
      | Texp_try (e, cases) ->
        (* This is more permissive than the old check. *)
        let case env {Typedtree.c_rhs} = expression env c_rhs in
        Use.join (expression env e)
          (list case env cases)
      | Texp_override (_, fields) ->
        let field env (_, _, e) = expression env e in
        Use.inspect (list field env fields)
      | Texp_function { cases } ->
        Use.delay (list (case ~scrutinee:Use.empty) env cases)
      | Texp_lazy e ->
         begin match Typeopt.classify_lazy_argument e with
         | `Constant_or_function
         | `Identifier _
         | `Float ->
            expression env e
         | `Other ->
            Use.delay (expression env e)
         end
      | Texp_unreachable ->
        Use.empty
      | Texp_extension_constructor _ ->
        Use.empty
  and option : 'a. (Env.env -> 'a -> Use.t) -> Env.env -> 'a option -> Use.t =
    fun f env -> Misc.Stdlib.Option.value_default (f env) ~default:Use.empty
  and list : 'a. (Env.env -> 'a -> Use.t) -> Env.env -> 'a list -> Use.t =
    fun f env ->
      List.fold_left (fun typ item -> Use.join (f env item) typ) Use.empty
  and array : 'a. (Env.env -> 'a -> Use.t) -> Env.env -> 'a array -> Use.t =
    fun f env ->
      Array.fold_left (fun typ item -> Use.join (f env item) typ) Use.empty
  and class_structure : Env.env -> Typedtree.class_structure -> Use.t =
    fun env cs -> Use.(inspect (list class_field env cs.cstr_fields))
  and class_field : Env.env -> Typedtree.class_field -> Use.t =
    fun env cf -> match cf.cf_desc with
      | Tcf_inherit (_, ce, _super, _inh_vars, _inh_meths) ->
          Use.inspect (class_expr env ce)
      | Tcf_val (_lab, _mut, _, cfk, _) ->
          class_field_kind env cfk
      | Tcf_method (_, _, cfk) ->
          class_field_kind env cfk
      | Tcf_constraint _ ->
          Use.empty
      | Tcf_initializer e ->
          Use.inspect (expression env e)
      | Tcf_attribute _ ->
          Use.empty
  and class_field_kind : Env.env -> Typedtree.class_field_kind -> Use.t =
    fun env cfk -> match cfk with
      | Tcfk_virtual _ ->
          Use.empty
      | Tcfk_concrete (_, e) ->
          Use.inspect (expression env e)
  and modexp : Env.env -> Typedtree.module_expr -> Use.t =
    fun env m -> match m.mod_desc with
      | Tmod_ident (pth, _) ->
          (path env pth)
      | Tmod_structure s ->
          structure env s
      | Tmod_functor (_, _, _, e) ->
        Use.delay (modexp env e)
      | Tmod_apply (f, p, _) ->
        Use.(join
                (inspect (modexp env f))
                (inspect (modexp env p)))
      | Tmod_constraint (m, _, _, Tcoerce_none) ->
        modexp env m
      | Tmod_constraint (m, _, _, _) ->
        Use.inspect (modexp env m)
      | Tmod_unpack (e, _) ->
          expression env e
  and path : Env.env -> Path.t -> Use.t =
    fun env pth -> match pth with
      | Path.Pident x ->
          (try Ident.find_same x env with Not_found -> Use.empty)
      | Path.Pdot (t, _, _) ->
          Use.inspect (path env t)
      | Path.Papply (f, p) ->
          Use.(inspect (join (path env f) (path env p)))
  and structure : Env.env -> Typedtree.structure -> Use.t =
    fun env s ->
      let _, ty =
        List.fold_left
          (fun (env, ty) item ->
             let env', ty' = structure_item env item in
             Env.join env env', Use.join ty ty')
          (env, Use.empty)
          s.str_items
      in
      Use.guard ty
  and structure_item : Env.env -> Typedtree.structure_item -> Env.env * Use.t =
    fun env s -> match s.str_desc with
      | Tstr_eval (e, _) ->
          Env.empty, expression env e
      | Tstr_value (rec_flag, valbinds) ->
          value_bindings rec_flag env valbinds
      | Tstr_module {mb_id; mb_expr} ->
          let ty = modexp env mb_expr in
          Ident.add mb_id ty Env.empty, ty
      | Tstr_recmodule mbs ->
          let modbind env {mb_expr} = modexp env mb_expr in
          (* Over-approximate: treat any access as a use *)
          Env.empty, Use.inspect (list modbind env mbs)
      | Tstr_primitive _ ->
          Env.empty, Use.empty
      | Tstr_type _ ->
          Env.empty, Use.empty
      | Tstr_typext _ ->
          Env.empty, Use.empty
      | Tstr_exception _ ->
          Env.empty, Use.empty
      | Tstr_modtype _ ->
          Env.empty, Use.empty
      | Tstr_open _ ->
          Env.empty, Use.empty
      | Tstr_class classes ->
          (* Any occurrence in a class definition is counted as a use,
             so there's no need to add anything to the environment. *)
          let cls env ({ci_expr=ce}, _) = class_expr env ce in
          Env.empty, Use.inspect (list cls env classes)
      | Tstr_class_type _ ->
          Env.empty, Use.empty
      | Tstr_include inc ->
          (* This is a kind of projection.  There's no need to add
             anything to the environment because everything is used in
             the type component already *)
          Env.empty, Use.inspect (modexp env inc.incl_mod)
      | Tstr_attribute _ ->
          Env.empty, Use.empty
  and class_expr : Env.env -> Typedtree.class_expr -> Use.t =
    fun env ce -> match ce.cl_desc with
      | Tcl_ident (pth, _, _) ->
          Use.inspect (path env pth)
      | Tcl_structure cs ->
          class_structure env cs
      | Tcl_fun (_, _, args, ce, _) ->
          let arg env (_, _, e) = expression env e in
          Use.inspect (Use.join (list arg env args)
                          (class_expr env ce))
      | Tcl_apply (ce, args) ->
          let arg env (_, eo) = option expression env eo in
          Use.inspect (Use.join (class_expr env ce)
                          (list arg env args))
      | Tcl_let (rec_flag, valbinds, _, ce) ->
          let _, ty = value_bindings rec_flag env valbinds in
          Use.(inspect (join ty (class_expr env ce)))
      | Tcl_constraint (ce, _, _, _, _) ->
          class_expr env ce
      | Tcl_open (_, _, _, _, ce) ->
          class_expr env ce
  and case : Env.env -> Typedtree.case -> scrutinee:Use.t -> Use.t =
    fun env { Typedtree.c_lhs; c_guard; c_rhs } ~scrutinee:ty ->
      let ty =
        if is_destructuring_pattern c_lhs then Use.inspect ty
        else Use.discard ty (* as in 'let' *)
      in
      let vars = pattern_variables c_lhs in
      let env = 
        List.fold_left
          (fun env id -> Ident.add id ty env)
          env
          vars
      in
      Use.(join ty
              (join (expression env c_rhs)
                 (inspect (option expression env c_guard))))
  and value_bindings : rec_flag -> Env.env -> Typedtree.value_binding list -> Env.env * Use.t =
    fun rec_flag env bindings ->
      match rec_flag with
      | Recursive ->
          (* Approximation: 
                let rec y =
                  let rec x1 = e1
                      and x2 = e2
                    in e
             treated as
                let rec y =
                   let rec x = (e1, e2)[x1:=fst x, x2:=snd x] in
                      e[x1:=fst x, x2:=snd x]
             Further, use the fact that x1,x2 cannot occur unguarded in e1, e2
             to avoid recursive trickiness.
          *)
          let ids, ty =
            List.fold_left
              (fun (pats, tys) {vb_pat=p; vb_expr=e} ->
                 (pattern_variables p @ pats,
                  Use.join (expression env e) tys))
              ([], Use.empty)
              bindings
          in
          (List.fold_left (fun  (env : Env.env) (id : Ident.t) ->
               Ident.add id ty env) Env.empty ids,
           ty)
      | Nonrecursive ->
          List.fold_left
            (fun (env2, ty) binding ->
               let env', ty' = value_binding env binding in
               (Env.join env2 env', Use.join ty ty'))
            (Env.empty, Use.empty)
            bindings
  and value_binding : Env.env -> Typedtree.value_binding -> Env.env * Use.t =
    (* NB: returns new environment only *)
    fun env { vb_pat; vb_expr } ->
      let vars = pattern_variables vb_pat in
      let ty = expression env vb_expr in
      let ty = if is_destructuring_pattern vb_pat then Use.inspect ty else ty in
      (List.fold_left
        (fun env id -> Ident.add id ty env)
        Env.empty
        vars,
       ty)
  and is_destructuring_pattern : Typedtree.pattern -> bool =
    fun pat -> match pat.pat_desc with
      | Tpat_any -> false
      | Tpat_var (_, _) -> false
      | Tpat_alias (pat, _, _) -> is_destructuring_pattern pat
      | Tpat_constant _ -> true
      | Tpat_tuple _ -> true
      | Tpat_construct (_, _, _) -> true
      | Tpat_variant _ -> true
      | Tpat_record (_, _) -> true
      | Tpat_array _ -> true
      | Tpat_or (l,r,_) -> is_destructuring_pattern l || is_destructuring_pattern r
      | Tpat_lazy _ -> true

  let check_recursive_expression env idlist expr =
    let ty = expression (build_unguarded_env idlist) expr in
    match Use.unguarded ty, Use.dependent ty, classify_expression expr with
    | _ :: _, _, _ (* The expression inspects rec-bound variables *)
    | _, _ :: _, Dynamic -> (* The expression depends on rec-bound variables 
                               and its size is unknown *)
        raise(Error(expr.exp_loc, env, Illegal_letrec_expr))
    | [], _, Static (* The expression has known size *)
    | [], [], Dynamic -> (* The expression has unknown size,
                            but does not depend on rec-bound variables *)
        ()
  let check_class_expr env idlist ce =
    let rec class_expr : Env.env -> Typedtree.class_expr -> Use.t =
      fun env ce -> match ce.cl_desc with
        | Tcl_ident (_, _, _) -> Use.empty
        | Tcl_structure _ -> Use.empty
        | Tcl_fun (_, _, _, _, _) -> Use.empty
        | Tcl_apply (_, _) -> Use.empty
        | Tcl_let (rec_flag, valbinds, _, ce) ->
            let _, ty = value_bindings rec_flag env valbinds in
            Use.join ty (class_expr env ce)
        | Tcl_constraint (ce, _, _, _, _) ->
            class_expr env ce
        | Tcl_open (_, _, _, _, ce) ->
            class_expr env ce
    in
    match Use.unguarded (class_expr (build_unguarded_env idlist) ce) with
    | [] -> ()
    | _ :: _ -> raise(Error(ce.cl_loc, env, Illegal_class_expr))
end

let check_recursive_bindings env valbinds =
  let ids = List.concat
      (List.map (fun b -> pattern_variables b.vb_pat) valbinds) in
  List.iter
    (fun {vb_expr} ->
       Rec_check.check_recursive_expression env ids vb_expr)
    valbinds

let check_recursive_class_bindings env ids exprs =
  List.iter
    (fun expr ->
       Rec_check.check_class_expr env ids expr)
    exprs

(* Approximate the type of an expression, for better recursion *)

let rec approx_type env sty =
  match sty.ptyp_desc with
    Ptyp_arrow (p, _, sty) ->
      let ty1 = if is_optional p then type_option (newvar ()) else newvar () in
      newty (Tarrow (p, ty1, approx_type env sty, Cok))
  | Ptyp_tuple args ->
      newty (Ttuple (List.map (approx_type env) args))
  | Ptyp_constr (lid, ctl) ->
      begin try
        let path = Env.lookup_type lid.txt env in
        let decl = Env.find_type path env in
        if List.length ctl <> decl.type_arity then raise Not_found;
        let tyl = List.map (approx_type env) ctl in
        newconstr path tyl
      with Not_found -> newvar ()
      end
  | Ptyp_poly (_, sty) ->
      approx_type env sty
  | _ -> newvar ()

let rec type_approx env sexp =
  match sexp.pexp_desc with
    Pexp_let (_, _, e) -> type_approx env e
  | Pexp_fun (p, _, _, e) ->
      let ty = if is_optional p then type_option (newvar ()) else newvar () in
      newty (Tarrow(p, ty, type_approx env e, Cok))
  | Pexp_function ({pc_rhs=e}::_) ->
      newty (Tarrow(Nolabel, newvar (), type_approx env e, Cok))
  | Pexp_match (_, {pc_rhs=e}::_) -> type_approx env e
  | Pexp_try (e, _) -> type_approx env e
  | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l))
  | Pexp_ifthenelse (_,e,_) -> type_approx env e
  | Pexp_sequence (_,e) -> type_approx env e
  | Pexp_constraint (e, sty) ->
      let ty = type_approx env e in
      let ty1 = approx_type env sty in
      begin try unify env ty ty1 with Unify trace ->
        raise(Error(sexp.pexp_loc, env, Expr_type_clash trace))
      end;
      ty1
  | Pexp_coerce (e, sty1, sty2) ->
      let approx_ty_opt = function
        | None -> newvar ()
        | Some sty -> approx_type env sty
      in
      let ty = type_approx env e
      and ty1 = approx_ty_opt sty1
      and ty2 = approx_type env sty2 in
      begin try unify env ty ty1 with Unify trace ->
        raise(Error(sexp.pexp_loc, env, Expr_type_clash trace))
      end;
      ty2
  | _ -> newvar ()

(* List labels in a function type, and whether return type is a variable *)
let rec list_labels_aux env visited ls ty_fun =
  let ty = expand_head env ty_fun in
  if List.memq ty visited then
    List.rev ls, false
  else match ty.desc with
    Tarrow (l, _, ty_res, _) ->
      list_labels_aux env (ty::visited) (l::ls) ty_res
  | _ ->
      List.rev ls, is_Tvar ty

let list_labels env ty =
  wrap_trace_gadt_instances env (list_labels_aux env [] []) ty

(* Check that all univars are safe in a type *)
let check_univars env expans kind exp ty_expected vars =
  if expans && not (is_nonexpansive exp) then
    generalize_expansive env exp.exp_type;
  (* need to expand twice? cf. Ctype.unify2 *)
  let vars = List.map (expand_head env) vars in
  let vars = List.map (expand_head env) vars in
  let vars' =
    List.filter
      (fun t ->
        let t = repr t in
        generalize t;
        match t.desc with
          Tvar name when t.level = generic_level ->
            log_type t; t.desc <- Tunivar name; true
        | _ -> false)
      vars in
  if List.length vars = List.length vars' then () else
  let ty = newgenty (Tpoly(repr exp.exp_type, vars'))
  and ty_expected = repr ty_expected in
  raise (Error (exp.exp_loc, env,
                Less_general(kind, [ty, ty; ty_expected, ty_expected])))

(* Check that a type is not a function *)
let check_application_result env statement exp =
  let loc = exp.exp_loc in
  match (expand_head env exp.exp_type).desc with
  | Tarrow _ ->
      Location.prerr_warning exp.exp_loc Warnings.Partial_application
  | Tvar _ -> ()
  | Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
  | _ ->
      if statement then
        Location.prerr_warning loc Warnings.Statement_type

(* Check that a type is generalizable at some level *)
let generalizable level ty =
  let rec check ty =
    let ty = repr ty in
    if ty.level < lowest_level then () else
    if ty.level <= level then raise Exit else
    (mark_type_node ty; iter_type_expr check ty)
  in
  try check ty; unmark_type ty; true
  with Exit -> unmark_type ty; false

(* Hack to allow coercion of self. Will clean-up later. *)
let self_coercion = ref ([] : (Path.t * Location.t list ref) list)

(* Helpers for packaged modules. *)
let create_package_type loc env (p, l) =
  let s = !Typetexp.transl_modtype_longident loc env p in
  let fields = List.map (fun (name, ct) ->
                           name, Typetexp.transl_simple_type env false ct) l in
  let ty = newty (Tpackage (s,
                    List.map fst l,
                   List.map (fun (_, cty) -> cty.ctyp_type) fields))
  in
   (s, fields, ty)

 let wrap_unpacks sexp unpacks =
   let open Ast_helper in
   List.fold_left
     (fun sexp (name, loc) ->
       Exp.letmodule ~loc:sexp.pexp_loc ~attrs:[mknoloc "#modulepat",PStr []]
         name
         (Mod.unpack ~loc
            (Exp.ident ~loc:name.loc (mkloc (Longident.Lident name.txt)
                                            name.loc)))
         sexp
     )
    sexp unpacks

(* Helpers for type_cases *)

let contains_variant_either ty =
  let rec loop ty =
    let ty = repr ty in
    if ty.level >= lowest_level then begin
      mark_type_node ty;
      match ty.desc with
        Tvariant row ->
          let row = row_repr row in
          if not row.row_fixed then
            List.iter
              (fun (_,f) ->
                match row_field_repr f with Reither _ -> raise Exit | _ -> ())
              row.row_fields;
          iter_row loop row
      | _ ->
          iter_type_expr loop ty
    end
  in
  try loop ty; unmark_type ty; false
  with Exit -> unmark_type ty; true

let iter_ppat f p =
  match p.ppat_desc with
  | Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_interval _
  | Ppat_extension _
  | Ppat_type _ | Ppat_unpack _ -> ()
  | Ppat_array pats -> List.iter f pats
  | Ppat_or (p1,p2) -> f p1; f p2
  | Ppat_variant (_, arg) | Ppat_construct (_, arg) -> may f arg
  | Ppat_tuple lst ->  List.iter f lst
  | Ppat_exception p | Ppat_alias (p,_)
  | Ppat_open (_,p)
  | Ppat_constraint (p,_) | Ppat_lazy p -> f p
  | Ppat_record (args, _flag) -> List.iter (fun (_,p) -> f p) args

let contains_polymorphic_variant p =
  let rec loop p =
    match p.ppat_desc with
      Ppat_variant _ | Ppat_type _ -> raise Exit
    | _ -> iter_ppat loop p
  in
  try loop p; false with Exit -> true

let contains_gadt env p =
  let rec loop env p =
    match p.ppat_desc with
      | Ppat_construct (lid, _) ->
        begin try
          let cstrs = Env.lookup_all_constructors lid.txt env in
          List.iter (fun (cstr,_) -> if cstr.cstr_generalized then raise Exit)
            cstrs
        with Not_found -> ()
        end; iter_ppat (loop env) p
      | Ppat_open (lid,sub_p) ->
        let _, new_env = !type_open Asttypes.Override env p.ppat_loc lid in
        loop new_env sub_p
    | _ -> iter_ppat (loop env) p
  in
  try loop env p; false with Exit -> true

let check_absent_variant env =
  iter_pattern
    (function {pat_desc = Tpat_variant (s, arg, row)} as pat ->
      let row = row_repr !row in
      if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent)
          row.row_fields
      || not row.row_fixed && not (static_row row)  (* same as Ctype.poly *)
      then () else
      let ty_arg =
        match arg with None -> [] | Some p -> [correct_levels p.pat_type] in
      let row' = {row_fields = [s, Reither(arg=None,ty_arg,true,ref None)];
                  row_more = newvar (); row_bound = ();
                  row_closed = false; row_fixed = false; row_name = None} in
      (* Should fail *)
      unify_pat env {pat with pat_type = newty (Tvariant row')}
                    (correct_levels pat.pat_type)
      | _ -> ())

(* Duplicate types of values in the environment *)
(* XXX Should we do something about global type variables too? *)

let duplicate_ident_types caselist env =
  let caselist =
    List.filter (fun {pc_lhs} -> contains_gadt env pc_lhs) caselist in
  Env.copy_types (all_idents_cases caselist) env

(* Getting proper location of already typed expressions.

   Used to avoid confusing locations on type error messages in presence of
   type constraints.
   For example:

       (* Before patch *)
       # let x : string = (5 : int);;
                           ^
       (* After patch *)
       # let x : string = (5 : int);;
                          ^^^^^^^^^
*)
let proper_exp_loc exp =
  let rec aux = function
    | [] -> exp.exp_loc
    | ((Texp_constraint _ | Texp_coerce _), loc, _) :: _ -> loc
    | _ :: rest -> aux rest
  in
  aux exp.exp_extra

(* To find reasonable names for let-bound and lambda-bound idents *)

let rec name_pattern default = function
    [] -> Ident.create default
  | {c_lhs=p; _} :: rem ->
      match p.pat_desc with
        Tpat_var (id, _) -> id
      | Tpat_alias(_, id, _) -> id
      | _ -> name_pattern default rem

(* Typing of expressions *)

let unify_exp env exp expected_ty =
  let loc = proper_exp_loc exp in
  unify_exp_types loc env exp.exp_type expected_ty

let rec type_exp ?recarg env sexp =
  (* We now delegate everything to type_expect *)
  type_expect ?recarg env sexp (newvar ())

(* Typing of an expression with an expected type.
   This provide better error messages, and allows controlled
   propagation of return type information.
   In the principal case, [type_expected'] may be at generic_level.
 *)

and type_expect ?in_function ?recarg env sexp ty_expected =
  let previous_saved_types = Cmt_format.get_saved_types () in
  let exp =
    Builtin_attributes.warning_scope sexp.pexp_attributes
      (fun () ->
         type_expect_ ?in_function ?recarg env sexp ty_expected
      )
  in
  Cmt_format.set_saved_types
    (Cmt_format.Partial_expression exp :: previous_saved_types);
  exp

and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
  let loc = sexp.pexp_loc in
  (* Record the expression type before unifying it with the expected type *)
  let rue exp =
    unify_exp env (re exp) (instance env ty_expected);
    exp
  in
  match sexp.pexp_desc with
  | Pexp_ident lid ->
      begin
        let (path, desc) = Typetexp.find_value env lid.loc lid.txt in
        if !Clflags.annotations then begin
          let dloc = desc.Types.val_loc in
          let annot =
            if dloc.Location.loc_ghost then Annot.Iref_external
            else Annot.Iref_internal dloc
          in
          let name = Path.name ~paren:Oprint.parenthesized_ident path in
          Stypes.record (Stypes.An_ident (loc, name, annot))
        end;
        let is_recarg =
          match (repr desc.val_type).desc with
          | Tconstr(p, _, _) -> Path.is_constructor_typath p
          | _ -> false
        in

        begin match is_recarg, recarg, (repr desc.val_type).desc with
        | _, Allowed, _
        | true, Required, _
        | false, Rejected, _
          -> ()
        | true, Rejected, _
        | false, Required, (Tvar _ | Tconstr _) ->
            raise (Error (loc, env, Inlined_record_escape))
        | false, Required, _  ->
            () (* will fail later *)
        end;
        rue {
          exp_desc =
            begin match desc.val_kind with
              Val_ivar (_, cl_num) ->
                let (self_path, _) =
                  Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
                in
                Texp_instvar(self_path, path,
                             match lid.txt with
                                 Longident.Lident txt -> { txt; loc = lid.loc }
                               | _ -> assert false)
            | Val_self (_, _, cl_num, _) ->
                let (path, _) =
                  Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
                in
                Texp_ident(path, lid, desc)
            | Val_unbound ->
                raise(Error(loc, env, Masked_instance_variable lid.txt))
            (*| Val_prim _ ->
                let p = Env.normalize_path (Some loc) env path in
                Env.add_required_global (Path.head p);
                Texp_ident(path, lid, desc)*)
            | _ ->
                Texp_ident(path, lid, desc)
          end;
          exp_loc = loc; exp_extra = [];
          exp_type = instance env desc.val_type;
          exp_attributes = sexp.pexp_attributes;
          exp_env = env }
      end
  | Pexp_constant(Pconst_string (str, _) as cst) -> (
    let cst = constant_or_raise env loc cst in
    (* Terrible hack for format strings *)
    let ty_exp = expand_head env ty_expected in
    let fmt6_path =
      Path.(Pdot (Pident (Ident.create_persistent "CamlinternalFormatBasics"),
                  "format6", 0)) in
    let is_format = match ty_exp.desc with
      | Tconstr(path, _, _) when Path.same path fmt6_path ->
        if !Clflags.principal && ty_exp.level <> generic_level then
          Location.prerr_warning loc
            (Warnings.Not_principal "this coercion to format6");
        true
      | _ -> false
    in
    if is_format then
      let format_parsetree =
        { (type_format loc str env) with pexp_loc = sexp.pexp_loc }  in
      type_expect ?in_function env format_parsetree ty_expected
    else
      rue {
        exp_desc = Texp_constant cst;
        exp_loc = loc; exp_extra = [];
        exp_type = instance_def Predef.type_string;
        exp_attributes = sexp.pexp_attributes;
        exp_env = env }
  )
  | Pexp_constant cst ->
      let cst = constant_or_raise env loc cst in
      rue {
        exp_desc = Texp_constant cst;
        exp_loc = loc; exp_extra = [];
        exp_type = type_constant cst;
        exp_attributes = sexp.pexp_attributes;
        exp_env = env }
  | Pexp_let(Nonrecursive,
             [{pvb_pat=spat; pvb_expr=sval; pvb_attributes=[]}], sbody)
    when contains_gadt env spat ->
    (* TODO: allow non-empty attributes? *)
      type_expect ?in_function env
        {sexp with
         pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])}
        ty_expected
  | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
      let scp =
        match sexp.pexp_attributes, rec_flag with
        | [{txt="#default"},_], _ -> None
        | _, Recursive -> Some (Annot.Idef loc)
        | _, Nonrecursive -> Some (Annot.Idef sbody.pexp_loc)
      in
      let (pat_exp_list, new_env, unpacks) =
        type_let env rec_flag spat_sexp_list scp true in
      let body =
        type_expect new_env (wrap_unpacks sbody unpacks) ty_expected in
      let () =
        if rec_flag = Recursive then
          check_recursive_bindings env pat_exp_list
      in
      re {
        exp_desc = Texp_let(rec_flag, pat_exp_list, body);
        exp_loc = loc; exp_extra = [];
        exp_type = body.exp_type;
        exp_attributes = sexp.pexp_attributes;
        exp_env = env }
  | Pexp_fun (l, Some default, spat, sbody) ->
      assert(is_optional l); (* default allowed only with optional argument *)
      let open Ast_helper in
      let default_loc = default.pexp_loc in
      let scases = [
        Exp.case
          (Pat.construct ~loc:default_loc
             (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
             (Some (Pat.var ~loc:default_loc (mknoloc "*sth*"))))
          (Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*")));

        Exp.case
          (Pat.construct ~loc:default_loc
             (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
             None)
          default;
       ]
      in
      let sloc =
        { Location.loc_start = spat.ppat_loc.Location.loc_start;
          loc_end = default_loc.Location.loc_end;
          loc_ghost = true }
      in
      let smatch =
        Exp.match_ ~loc:sloc
          (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
          scases
      in
      let pat = Pat.var ~loc:sloc (mknoloc "*opt*") in
      let body =
        Exp.let_ ~loc Nonrecursive ~attrs:[mknoloc "#default",PStr []]
          [Vb.mk spat smatch] sbody
      in
      type_function ?in_function loc sexp.pexp_attributes env ty_expected
        l [Exp.case pat body]
  | Pexp_fun (l, None, spat, sbody) ->
      type_function ?in_function loc sexp.pexp_attributes env ty_expected
        l [Ast_helper.Exp.case spat sbody]
  | Pexp_function caselist ->
      type_function ?in_function
        loc sexp.pexp_attributes env ty_expected Nolabel caselist
  | Pexp_apply(sfunct, sargs) ->
      assert (sargs <> []);
      begin_def (); (* one more level for non-returning functions *)
      if !Clflags.principal then begin_def ();
      let funct = type_exp env sfunct in
      if !Clflags.principal then begin
          end_def ();
          generalize_structure funct.exp_type
        end;
      let rec lower_args seen ty_fun =
        let ty = expand_head env ty_fun in
        if List.memq ty seen then () else
        match ty.desc with
          Tarrow (_l, ty_arg, ty_fun, _com) ->
            (try unify_var env (newvar()) ty_arg with Unify _ -> assert false);
            lower_args (ty::seen) ty_fun
        | _ -> ()
      in
      let ty = instance env funct.exp_type in
      end_def ();
      wrap_trace_gadt_instances env (lower_args []) ty;
      begin_def ();
      let (args, ty_res) = type_application env funct sargs in
      end_def ();
      unify_var env (newvar()) funct.exp_type;
      rue {
        exp_desc = Texp_apply(funct, args);
        exp_loc = loc; exp_extra = [];
        exp_type = ty_res;
        exp_attributes = sexp.pexp_attributes;
        exp_env = env }
  | Pexp_match(sarg, caselist) ->
      begin_def ();
      let arg = type_exp env sarg in
      end_def ();
      if not (is_nonexpansive arg) then generalize_expansive env arg.exp_type;
      generalize arg.exp_type;
      let rec split_cases vc ec = function
        | [] -> List.rev vc, List.rev ec
        | {pc_lhs = {ppat_desc=Ppat_exception p}} as c :: rest ->
            split_cases vc ({c with pc_lhs = p} :: ec) rest
        | c :: rest ->
            split_cases (c :: vc) ec rest
      in
      let val_caselist, exn_caselist = split_cases [] [] caselist in
      if val_caselist = [] && exn_caselist <> [] then
        raise (Error (loc, env, No_value_clauses));
      (* Note: val_caselist = [] and exn_caselist = [], i.e. a fully
         empty pattern matching can be generated by Camlp4 with its
         revised syntax.  Let's accept it for backward compatibility. *)
      let val_cases, partial =
        type_cases env arg.exp_type ty_expected true loc val_caselist in
      let exn_cases, _ =
        type_cases env Predef.type_exn ty_expected false loc exn_caselist in
      re {
        exp_desc = Texp_match(arg, val_cases, exn_cases, partial);
        exp_loc = loc; exp_extra = [];
        exp_type = instance env ty_expected;
        exp_attributes = sexp.pexp_attributes;
        exp_env = env }
  | Pexp_try(sbody, caselist) ->
      let body = type_expect env sbody ty_expected in
      let cases, _ =
        type_cases env Predef.type_exn ty_expected false loc caselist in
      re {
        exp_desc = Texp_try(body, cases);
        exp_loc = loc; exp_extra = [];
        exp_type = body.exp_type;
        exp_attributes = sexp.pexp_attributes;
        exp_env = env }
  | Pexp_tuple sexpl ->
      assert (List.length sexpl >= 2);
      let subtypes = List.map (fun _ -> newgenvar ()) sexpl in
      let to_unify = newgenty (Ttuple subtypes) in
      unify_exp_types loc env to_unify ty_expected;
      let expl =
        List.map2 (fun body ty -> type_expect env body ty) sexpl subtypes
      in
      re {
        exp_desc = Texp_tuple expl;
        exp_loc = loc; exp_extra = [];
        (* Keep sharing *)
        exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl));
        exp_attributes = sexp.pexp_attributes;
        exp_env = env }
  | Pexp_construct(lid, sarg) ->
      type_construct env loc lid sarg ty_expected sexp.pexp_attributes
  | Pexp_variant(l, sarg) ->
      (* Keep sharing *)
      let ty_expected0 = instance env ty_expected in
      begin try match
        sarg, expand_head env ty_expected, expand_head env ty_expected0 with
      | Some sarg, {desc = Tvariant row}, {desc = Tvariant row0} ->
          let row = row_repr row in
          begin match row_field_repr (List.assoc l row.row_fields),
          row_field_repr (List.assoc l row0.row_fields) with
            Rpresent (Some ty), Rpresent (Some ty0) ->
              let arg = type_argument env sarg ty ty0 in
              re { exp_desc = Texp_variant(l, Some arg);
                   exp_loc = loc; exp_extra = [];
                   exp_type = ty_expected0;
                   exp_attributes = sexp.pexp_attributes;
                   exp_env = env }
          | _ -> raise Not_found
          end
      | _ -> raise Not_found
      with Not_found ->
        let arg = may_map (type_exp env) sarg in
        let arg_type = may_map (fun arg -> arg.exp_type) arg in
        rue {
          exp_desc = Texp_variant(l, arg);
          exp_loc = loc; exp_extra = [];
          exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type];
                                    row_more = newvar ();
                                    row_bound = ();
                                    row_closed = false;
                                    row_fixed = false;
                                    row_name = None});
          exp_attributes = sexp.pexp_attributes;
          exp_env = env }
      end
  | Pexp_record(lid_sexp_list, opt_sexp) ->
      assert (lid_sexp_list <> []);
      let opt_exp =
        match opt_sexp with
          None -> None
        | Some sexp ->
            if !Clflags.principal then begin_def ();
            let exp = type_exp ~recarg env sexp in
            if !Clflags.principal then begin
              end_def ();
              generalize_structure exp.exp_type
            end;
            Some exp
      in
      let ty_record, opath =
        let get_path ty =
          try
            let (p0, p,_) = extract_concrete_record env ty in
            (* XXX level may be wrong *)
            Some (p0, p, ty.level = generic_level || not !Clflags.principal)
          with Not_found -> None
        in
        match get_path ty_expected with
          None ->
            begin match opt_exp with
              None -> newvar (), None
            | Some exp ->
                match get_path exp.exp_type with
                  None -> newvar (), None
                | Some (_, p', _) as op ->
                    let decl = Env.find_type p' env in
                    begin_def ();
                    let ty =
                      newconstr p' (instance_list env decl.type_params) in
                    end_def ();
                    generalize_structure ty;
                    ty, op
            end
        | op -> ty_expected, op
      in
      let closed = (opt_sexp = None) in
      let lbl_exp_list =
        wrap_disambiguate "This record expression is expected to have" ty_record
          (type_label_a_list loc closed env
             (fun e k -> k (type_label_exp true env loc ty_record e))
             opath lid_sexp_list)
          (fun x -> x)
      in
      unify_exp_types loc env ty_record (instance env ty_expected);

      (* type_label_a_list returns a list of labels sorted by lbl_pos *)
      (* note: check_duplicates would better be implemented in
         type_label_a_list directly *)
      let rec check_duplicates = function
        | (_, lbl1, _) :: (_, lbl2, _) :: _ when lbl1.lbl_pos = lbl2.lbl_pos ->
          raise(Error(loc, env, Label_multiply_defined lbl1.lbl_name))
        | _ :: rem ->
            check_duplicates rem
        | [] -> ()
      in
      check_duplicates lbl_exp_list;
      let opt_exp, label_definitions =
        let (_lid, lbl, _lbl_exp) = List.hd lbl_exp_list in
        let matching_label lbl =
          List.find
            (fun (_, lbl',_) -> lbl'.lbl_pos = lbl.lbl_pos)
            lbl_exp_list
        in
        match opt_exp with
          None ->
            let label_definitions =
              Array.map (fun lbl ->
                  match matching_label lbl with
                  | (lid, _lbl, lbl_exp) ->
                      Overridden (lid, lbl_exp)
                  | exception Not_found ->
                      let present_indices =
                        List.map (fun (_, lbl, _) -> lbl.lbl_pos) lbl_exp_list
                      in
                      let label_names = extract_label_names env ty_expected in
                      let rec missing_labels n = function
                          [] -> []
                        | lbl :: rem ->
                            if List.mem n present_indices
                            then missing_labels (n + 1) rem
                            else lbl :: missing_labels (n + 1) rem
                      in
                      let missing = missing_labels 0 label_names in
                      raise(Error(loc, env, Label_missing missing)))
                lbl.lbl_all
            in
            None, label_definitions
        | Some exp ->
            let ty_exp = instance env exp.exp_type in
            let unify_kept lbl =
              let _, ty_arg1, ty_res1 = instance_label false lbl in
              unify_exp_types exp.exp_loc env ty_exp ty_res1;
              match matching_label lbl with
              | lid, _lbl, lbl_exp ->
                  (* do not connect result types for overridden labels *)
                  Overridden (lid, lbl_exp)
              | exception Not_found -> begin
                  let _, ty_arg2, ty_res2 = instance_label false lbl in
                  unify env ty_arg1 ty_arg2;
                  unify env (instance env ty_expected) ty_res2;
                  Kept ty_arg1
                end
            in
            let label_definitions = Array.map unify_kept lbl.lbl_all in
            Some {exp with exp_type = ty_exp}, label_definitions
      in
      let num_fields =
        match lbl_exp_list with [] -> assert false
        | (_, lbl,_)::_ -> Array.length lbl.lbl_all in
      let opt_exp =
        if opt_sexp <> None && List.length lid_sexp_list = num_fields then
          (Location.prerr_warning loc Warnings.Useless_record_with; None)
        else opt_exp
      in
      let label_descriptions, representation =
        let (_, { lbl_all; lbl_repres }, _) = List.hd lbl_exp_list in
        lbl_all, lbl_repres
      in
      let fields =
        Array.map2 (fun descr def -> descr, def)
          label_descriptions label_definitions
      in
      re {
        exp_desc = Texp_record {
            fields; representation;
            extended_expression = opt_exp
          };
        exp_loc = loc; exp_extra = [];
        exp_type = instance env ty_expected;
        exp_attributes = sexp.pexp_attributes;
        exp_env = env }
  | Pexp_field(srecord, lid) ->
      let (record, label, _) = type_label_access env srecord lid in
      let (_, ty_arg, ty_res) = instance_label false label in
      unify_exp env record ty_res;
      rue {
        exp_desc = Texp_field(record, lid, label);
        exp_loc = loc; exp_extra = [];
        exp_type = ty_arg;
        exp_attributes = sexp.pexp_attributes;
        exp_env = env }
  | Pexp_setfield(srecord, lid, snewval) ->
      let (record, label, opath) = type_label_access env srecord lid in
      let ty_record = if opath = None then newvar () else record.exp_type in
      let (label_loc, label, newval) =
        type_label_exp false env loc ty_record (lid, label, snewval) in
      unify_exp env record ty_record;
      if label.lbl_mut = Immutable then
        raise(Error(loc, env, Label_not_mutable lid.txt));
      Builtin_attributes.check_deprecated_mutable lid.loc label.lbl_attributes
        (Longident.last lid.txt);
      rue {
        exp_desc = Texp_setfield(record, label_loc, label, newval);
        exp_loc = loc; exp_extra = [];
        exp_type = instance_def Predef.type_unit;
        exp_attributes = sexp.pexp_attributes;
        exp_env = env }
  | Pexp_array(sargl) ->
      let ty = newgenvar() in
      let to_unify = Predef.type_array ty in
      unify_exp_types loc env to_unify ty_expected;
      let argl = List.map (fun sarg -> type_expect env sarg ty) sargl in
      re {
        exp_desc = Texp_array argl;
        exp_loc = loc; exp_extra = [];
        exp_type = instance env ty_expected;
        exp_attributes = sexp.pexp_attributes;
        exp_env = env }
  | Pexp_ifthenelse(scond, sifso, sifnot) ->
      let cond = type_expect env scond Predef.type_bool in
      begin match sifnot with
        None ->
          let ifso = type_expect env sifso Predef.type_unit in
          rue {
            exp_desc = Texp_ifthenelse(cond, ifso, None);
            exp_loc = loc; exp_extra = [];
            exp_type = ifso.exp_type;
            exp_attributes = sexp.pexp_attributes;
            exp_env = env }
      | Some sifnot ->
          let ifso = type_expect env sifso ty_expected in
          let ifnot = type_expect env sifnot ty_expected in
          (* Keep sharing *)
          unify_exp env ifnot ifso.exp_type;
          re {
            exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot);
            exp_loc = loc; exp_extra = [];
            exp_type = ifso.exp_type;
            exp_attributes = sexp.pexp_attributes;
            exp_env = env }
      end
  | Pexp_sequence(sexp1, sexp2) ->
      let exp1 = type_statement env sexp1 in
      let exp2 = type_expect env sexp2 ty_expected in
      re {
        exp_desc = Texp_sequence(exp1, exp2);
        exp_loc = loc; exp_extra = [];
        exp_type = exp2.exp_type;
        exp_attributes = sexp.pexp_attributes;
        exp_env = env }
  | Pexp_while(scond, sbody) ->
      let cond = type_expect env scond Predef.type_bool in
      let body = type_statement env sbody in
      rue {
        exp_desc = Texp_while(cond, body);
        exp_loc = loc; exp_extra = [];
        exp_type = instance_def Predef.type_unit;
        exp_attributes = sexp.pexp_attributes;
        exp_env = env }
  | Pexp_for(param, slow, shigh, dir, sbody) ->
      let low = type_expect env slow Predef.type_int in
      let high = type_expect env shigh Predef.type_int in
      let id, new_env =
        match param.ppat_desc with
        | Ppat_any -> Ident.create "_for", env
        | Ppat_var {txt} ->
            Env.enter_value txt {val_type = instance_def Predef.type_int;
                                 val_attributes = [];
                                 val_kind = Val_reg; Types.val_loc = loc; } env
              ~check:(fun s -> Warnings.Unused_for_index s)
        | _ ->
            raise (Error (param.ppat_loc, env, Invalid_for_loop_index))
      in
      let body = type_statement new_env sbody in
      rue {
        exp_desc = Texp_for(id, param, low, high, dir, body);
        exp_loc = loc; exp_extra = [];
        exp_type = instance_def Predef.type_unit;
        exp_attributes = sexp.pexp_attributes;
        exp_env = env }
  | Pexp_constraint (sarg, sty) ->
      let separate = true in (* always separate, 1% slowdown for lablgtk *)
      if separate then begin_def ();
      let cty = Typetexp.transl_simple_type env false sty in
      let ty = cty.ctyp_type in
      let (arg, ty') =
        if separate then begin
          end_def ();
          generalize_structure ty;
          (type_argument env sarg ty (instance env ty), instance env ty)
        end else
          (type_argument env sarg ty ty, ty)
      in
      rue {
        exp_desc = arg.exp_desc;
        exp_loc = arg.exp_loc;
        exp_type = ty';
        exp_attributes = arg.exp_attributes;
        exp_env = env;
        exp_extra =
          (Texp_constraint cty, loc, sexp.pexp_attributes) :: arg.exp_extra;
      }
  | Pexp_coerce(sarg, sty, sty') ->
      let separate = true in (* always separate, 1% slowdown for lablgtk *)
      (* Also see PR#7199 for a problem with the following:
         let separate = !Clflags.principal || Env.has_local_constraints env in*)
      let (arg, ty',cty,cty') =
        match sty with
        | None ->
            let (cty', force) =
              Typetexp.transl_simple_type_delayed env sty'
            in
            let ty' = cty'.ctyp_type in
            if separate then begin_def ();
            let arg = type_exp env sarg in
            let gen =
              if separate then begin
                end_def ();
                let tv = newvar () in
                let gen = generalizable tv.level arg.exp_type in
                (try unify_var env tv arg.exp_type with Unify trace ->
                  raise(Error(arg.exp_loc, env, Expr_type_clash trace)));
                gen
              end else true
            in
            begin match arg.exp_desc, !self_coercion, (repr ty').desc with
              Texp_ident(_, _, {val_kind=Val_self _}), (path,r) :: _,
              Tconstr(path',_,_) when Path.same path path' ->
                (* prerr_endline "self coercion"; *)
                r := loc :: !r;
                force ()
            | _ when free_variables ~env arg.exp_type = []
                  && free_variables ~env ty' = [] ->
                if not gen && (* first try a single coercion *)
                  let snap = snapshot () in
                  let ty, _b = enlarge_type env ty' in
                  try
                    force (); Ctype.unify env arg.exp_type ty; true
                  with Unify _ ->
                    backtrack snap; false
                then ()
                else begin try
                  let force' = subtype env arg.exp_type ty' in
                  force (); force' ();
                  if not gen && !Clflags.principal then
                    Location.prerr_warning loc
                      (Warnings.Not_principal "this ground coercion");
                with Subtype (tr1, tr2) ->
                  (* prerr_endline "coercion failed"; *)
                  raise(Error(loc, env, Not_subtype(tr1, tr2)))
                end;
            | _ ->
                let ty, b = enlarge_type env ty' in
                force ();
                begin try Ctype.unify env arg.exp_type ty with Unify trace ->
                  raise(Error(sarg.pexp_loc, env,
                        Coercion_failure(ty', full_expand env ty', trace, b)))
                end
            end;
            (arg, ty', None, cty')
        | Some sty ->
            if separate then begin_def ();
            let (cty, force) =
              Typetexp.transl_simple_type_delayed env sty
            and (cty', force') =
              Typetexp.transl_simple_type_delayed env sty'
            in
            let ty = cty.ctyp_type in
            let ty' = cty'.ctyp_type in
            begin try
              let force'' = subtype env ty ty' in
              force (); force' (); force'' ()
            with Subtype (tr1, tr2) ->
              raise(Error(loc, env, Not_subtype(tr1, tr2)))
            end;
            if separate then begin
              end_def ();
              generalize_structure ty;
              generalize_structure ty';
              (type_argument env sarg ty (instance env ty),
               instance env ty', Some cty, cty')
            end else
              (type_argument env sarg ty ty, ty', Some cty, cty')
      in
      rue {
        exp_desc = arg.exp_desc;
        exp_loc = arg.exp_loc;
        exp_type = ty';
        exp_attributes = arg.exp_attributes;
        exp_env = env;
        exp_extra = (Texp_coerce (cty, cty'), loc, sexp.pexp_attributes) ::
                       arg.exp_extra;
      }
  | Pexp_send (e, {txt=met}) ->
      if !Clflags.principal then begin_def ();
      let obj = type_exp env e in
      let obj_meths = ref None in
      begin try
        let (meth, exp, typ) =
          match obj.exp_desc with
            Texp_ident(_path, _, {val_kind = Val_self (meths, _, _, privty)}) ->
              obj_meths := Some meths;
              let (id, typ) =
                filter_self_method env met Private meths privty
              in
              if is_Tvar (repr typ) then
                Location.prerr_warning loc
                  (Warnings.Undeclared_virtual_method met);
              (Tmeth_val id, None, typ)
          | Texp_ident(_path, lid, {val_kind = Val_anc (methods, cl_num)}) ->
              let method_id =
                begin try List.assoc met methods with Not_found ->
                  let valid_methods = List.map fst methods in
                  raise(Error(e.pexp_loc, env,
                              Undefined_inherited_method (met, valid_methods)))
                end
              in
              begin match
                Env.lookup_value (Longident.Lident ("selfpat-" ^ cl_num)) env,
                Env.lookup_value (Longident.Lident ("self-" ^cl_num)) env
              with
                (_, ({val_kind = Val_self (meths, _, _, privty)} as desc)),
                (path, _) ->
                  obj_meths := Some meths;
                  let (_, typ) =
                    filter_self_method env met Private meths privty
                  in
                  let method_type = newvar () in
                  let (obj_ty, res_ty) = filter_arrow env method_type Nolabel in
                  unify env obj_ty desc.val_type;
                  unify env res_ty (instance env typ);
                  let exp =
                    Texp_apply({exp_desc =
                                Texp_ident(Path.Pident method_id, lid,
                                           {val_type = method_type;
                                            val_kind = Val_reg;
                                            val_attributes = [];
                                            Types.val_loc = Location.none});
                                exp_loc = loc; exp_extra = [];
                                exp_type = method_type;
                                exp_attributes = []; (* check *)
                                exp_env = env},
                          [ Nolabel,
                            Some {exp_desc = Texp_ident(path, lid, desc);
                                  exp_loc = obj.exp_loc; exp_extra = [];
                                  exp_type = desc.val_type;
                                  exp_attributes = []; (* check *)
                                  exp_env = env}
                          ])
                  in
                  (Tmeth_name met, Some (re {exp_desc = exp;
                                             exp_loc = loc; exp_extra = [];
                                             exp_type = typ;
                                             exp_attributes = []; (* check *)
                                             exp_env = env}), typ)
              |  _ ->
                  assert false
              end
          | _ ->
              (Tmeth_name met, None,
               filter_method env met Public obj.exp_type)
        in
        if !Clflags.principal then begin
          end_def ();
          generalize_structure typ;
        end;
        let typ =
          match repr typ with
            {desc = Tpoly (ty, [])} ->
              instance env ty
          | {desc = Tpoly (ty, tl); level = l} ->
              if !Clflags.principal && l <> generic_level then
                Location.prerr_warning loc
                  (Warnings.Not_principal "this use of a polymorphic method");
              snd (instance_poly false tl ty)
          | {desc = Tvar _} as ty ->
              let ty' = newvar () in
              unify env (instance_def ty) (newty(Tpoly(ty',[])));
              (* if not !Clflags.nolabels then
                 Location.prerr_warning loc (Warnings.Unknown_method met); *)
              ty'
          | _ ->
              assert false
        in
        rue {
          exp_desc = Texp_send(obj, meth, exp);
          exp_loc = loc; exp_extra = [];
          exp_type = typ;
          exp_attributes = sexp.pexp_attributes;
          exp_env = env }
      with Unify _ ->
        let valid_methods =
          match !obj_meths with
          | Some meths ->
             Some (Meths.fold (fun meth _meth_ty li -> meth::li) !meths [])
          | None ->
             match (expand_head env obj.exp_type).desc with
             | Tobject (fields, _) ->
                let (fields, _) = Ctype.flatten_fields fields in
                let collect_fields li (meth, meth_kind, _meth_ty) =
                  if meth_kind = Fpresent then meth::li else li in
                Some (List.fold_left collect_fields [] fields)
             | _ -> None
        in
        raise(Error(e.pexp_loc, env,
                    Undefined_method (obj.exp_type, met, valid_methods)))
      end
  | Pexp_new cl ->
      let (cl_path, cl_decl) = Typetexp.find_class env cl.loc cl.txt in
      begin match cl_decl.cty_new with
          None ->
            raise(Error(loc, env, Virtual_class cl.txt))
        | Some ty ->
            rue {
              exp_desc = Texp_new (cl_path, cl, cl_decl);
              exp_loc = loc; exp_extra = [];
              exp_type = instance_def ty;
              exp_attributes = sexp.pexp_attributes;
              exp_env = env }
        end
  | Pexp_setinstvar (lab, snewval) ->
      begin try
        let (path, desc) = Env.lookup_value (Longident.Lident lab.txt) env in
        match desc.val_kind with
          Val_ivar (Mutable, cl_num) ->
            let newval =
              type_expect env snewval (instance env desc.val_type) in
            let (path_self, _) =
              Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
            in
            rue {
              exp_desc = Texp_setinstvar(path_self, path, lab, newval);
              exp_loc = loc; exp_extra = [];
              exp_type = instance_def Predef.type_unit;
              exp_attributes = sexp.pexp_attributes;
              exp_env = env }
        | Val_ivar _ ->
            raise(Error(loc, env, Instance_variable_not_mutable(true,lab.txt)))
        | _ ->
            raise(Error(loc, env, Instance_variable_not_mutable(false,lab.txt)))
      with
        Not_found ->
          let collect_vars name _path val_desc li =
            match val_desc.val_kind with
            | Val_ivar (Mutable, _) -> name::li
            | _ -> li in
          let valid_vars = Env.fold_values collect_vars None env [] in
          raise(Error(loc, env,
                      Unbound_instance_variable (lab.txt, valid_vars)))
      end
  | Pexp_override lst ->
      let _ =
       List.fold_right
        (fun (lab, _) l ->
           if List.exists (fun l -> l.txt = lab.txt) l then
             raise(Error(loc, env,
                         Value_multiply_overridden lab.txt));
           lab::l)
        lst
        [] in
      begin match
        try
          Env.lookup_value (Longident.Lident "selfpat-*") env,
          Env.lookup_value (Longident.Lident "self-*") env
        with Not_found ->
          raise(Error(loc, env, Outside_class))
      with
        (_, {val_type = self_ty; val_kind = Val_self (_, vars, _, _)}),
        (path_self, _) ->
          let type_override (lab, snewval) =
            begin try
              let (id, _, _, ty) = Vars.find lab.txt !vars in
              (Path.Pident id, lab, type_expect env snewval (instance env ty))
            with
              Not_found ->
                let vars = Vars.fold (fun var _ li -> var::li) !vars [] in
                raise(Error(loc, env,
                            Unbound_instance_variable (lab.txt, vars)))
            end
          in
          let modifs = List.map type_override lst in
          rue {
            exp_desc = Texp_override(path_self, modifs);
            exp_loc = loc; exp_extra = [];
            exp_type = self_ty;
            exp_attributes = sexp.pexp_attributes;
            exp_env = env }
      | _ ->
          assert false
      end
  | Pexp_letmodule(name, smodl, sbody) ->
      let ty = newvar() in
      (* remember original level *)
      begin_def ();
      Ident.set_current_time ty.level;
      let context = Typetexp.narrow () in
      let modl = !type_module env smodl in
      let (id, new_env) = Env.enter_module name.txt modl.mod_type env in
      Ctype.init_def(Ident.current_time());
      Typetexp.widen context;
      let body = type_expect new_env sbody ty_expected in
      (* go back to original level *)
      end_def ();
      (* Unification of body.exp_type with the fresh variable ty
         fails if and only if the prefix condition is violated,
         i.e. if generative types rooted at id show up in the
         type body.exp_type.  Thus, this unification enforces the
         scoping condition on "let module". *)
      (* Note that this code will only be reached if ty_expected
         is a generic type variable, otherwise the error will occur
         above in type_expect *)
      begin try
        Ctype.unify_var new_env ty body.exp_type
      with Unify _ ->
        raise(Error(loc, env, Scoping_let_module(name.txt, body.exp_type)))
      end;
      re {
        exp_desc = Texp_letmodule(id, name, modl, body);
        exp_loc = loc; exp_extra = [];
        exp_type = ty;
        exp_attributes = sexp.pexp_attributes;
        exp_env = env }
  | Pexp_letexception(cd, sbody) ->
      let (cd, newenv) = Typedecl.transl_exception env cd in
      let body = type_expect newenv sbody ty_expected in
      re {
        exp_desc = Texp_letexception(cd, body);
        exp_loc = loc; exp_extra = [];
        exp_type = body.exp_type;
        exp_attributes = sexp.pexp_attributes;
        exp_env = env }

  | Pexp_assert (e) ->
      let cond = type_expect env e Predef.type_bool in
      let exp_type =
        match cond.exp_desc with
        | Texp_construct(_, {cstr_name="false"}, _) ->
            instance env ty_expected
        | _ ->
            instance_def Predef.type_unit
      in
      rue {
        exp_desc = Texp_assert cond;
        exp_loc = loc; exp_extra = [];
        exp_type;
        exp_attributes = sexp.pexp_attributes;
        exp_env = env;
      }
  | Pexp_lazy e ->
      let ty = newgenvar () in
      let to_unify = Predef.type_lazy_t ty in
      unify_exp_types loc env to_unify ty_expected;
      let arg = type_expect env e ty in
      re {
        exp_desc = Texp_lazy arg;
        exp_loc = loc; exp_extra = [];
        exp_type = instance env ty_expected;
        exp_attributes = sexp.pexp_attributes;
        exp_env = env;
      }
  | Pexp_object s ->
      let desc, sign, meths = !type_object env loc s in
      rue {
        exp_desc = Texp_object (desc, (*sign,*) meths);
        exp_loc = loc; exp_extra = [];
        exp_type = sign.csig_self;
        exp_attributes = sexp.pexp_attributes;
        exp_env = env;
      }
  | Pexp_poly(sbody, sty) ->
      if !Clflags.principal then begin_def ();
      let ty, cty =
        match sty with None -> repr ty_expected, None
        | Some sty ->
            let sty = Ast_helper.Typ.force_poly sty in
            let cty = Typetexp.transl_simple_type env false sty in
            repr cty.ctyp_type, Some cty
      in
      if !Clflags.principal then begin
        end_def ();
        generalize_structure ty
      end;
      if sty <> None then
        unify_exp_types loc env (instance env ty) (instance env ty_expected);
      let exp =
        match (expand_head env ty).desc with
          Tpoly (ty', []) ->
            let exp = type_expect env sbody ty' in
            { exp with exp_type = instance env ty }
        | Tpoly (ty', tl) ->
            (* One more level to generalize locally *)
            begin_def ();
            if !Clflags.principal then begin_def ();
            let vars, ty'' = instance_poly true tl ty' in
            if !Clflags.principal then begin
              end_def ();
              generalize_structure ty''
            end;
            let exp = type_expect env sbody ty'' in
            end_def ();
            check_univars env false "method" exp ty_expected vars;
            { exp with exp_type = instance env ty }
        | Tvar _ ->
            let exp = type_exp env sbody in
            let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in
            unify_exp env exp ty;
            exp
        | _ -> assert false
      in
      re { exp with exp_extra =
             (Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra }
  | Pexp_newtype({txt=name}, sbody) ->
      let ty = newvar () in
      (* remember original level *)
      begin_def ();
      (* Create a fake abstract type declaration for name. *)
      let level = get_current_level () in
      let decl = {
        type_params = [];
        type_arity = 0;
        type_kind = Type_abstract;
        type_private = Public;
        type_manifest = None;
        type_variance = [];
        type_newtype_level = Some (level, level);
        type_loc = loc;
        type_attributes = [];
        type_immediate = false;
        type_unboxed = unboxed_false_default_false;
      }
      in
      Ident.set_current_time ty.level;
      let (id, new_env) = Env.enter_type name decl env in
      Ctype.init_def(Ident.current_time());

      let body = type_exp new_env sbody in
      (* Replace every instance of this type constructor in the resulting
         type. *)
      let seen = Hashtbl.create 8 in
      let rec replace t =
        if Hashtbl.mem seen t.id then ()
        else begin
          Hashtbl.add seen t.id ();
          match t.desc with
          | Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty
          | _ -> Btype.iter_type_expr replace t
        end
      in
      let ety = Subst.type_expr Subst.identity body.exp_type in
      replace ety;
      (* back to original level *)
      end_def ();
      (* lower the levels of the result type *)
      (* unify_var env ty ety; *)

      (* non-expansive if the body is non-expansive, so we don't introduce
         any new extra node in the typed AST. *)
      rue { body with exp_loc = loc; exp_type = ety;
            exp_extra =
            (Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra }
  | Pexp_pack m ->
      let (p, nl) =
        match Ctype.expand_head env (instance env ty_expected) with
          {desc = Tpackage (p, nl, _tl)} ->
            if !Clflags.principal &&
              (Ctype.expand_head env ty_expected).level < Btype.generic_level
            then
              Location.prerr_warning loc
                (Warnings.Not_principal "this module packing");
            (p, nl)
        | {desc = Tvar _} ->
            raise (Error (loc, env, Cannot_infer_signature))
        | _ ->
            raise (Error (loc, env, Not_a_packed_module ty_expected))
      in
      let (modl, tl') = !type_package env m p nl in
      rue {
        exp_desc = Texp_pack modl;
        exp_loc = loc; exp_extra = [];
        exp_type = newty (Tpackage (p, nl, tl'));
        exp_attributes = sexp.pexp_attributes;
        exp_env = env }
  | Pexp_open (ovf, lid, e) ->
      let (path, newenv) = !type_open ovf env sexp.pexp_loc lid in
      let exp = type_expect newenv e ty_expected in
      { exp with
        exp_extra = (Texp_open (ovf, path, lid, newenv), loc,
                     sexp.pexp_attributes) ::
                      exp.exp_extra;
      }

  | Pexp_extension ({ txt = ("ocaml.extension_constructor"
                             |"extension_constructor"); _ },
                    payload) ->
      begin match payload with
      | PStr [ { pstr_desc =
                   Pstr_eval ({ pexp_desc = Pexp_construct (lid, None); _ }, _)
               } ] ->
          let path =
            match (Typetexp.find_constructor env lid.loc lid.txt).cstr_tag with
            | Cstr_extension (path, _) -> path
            | _ -> raise (Error (lid.loc, env, Not_an_extension_constructor))
          in
          rue {
            exp_desc = Texp_extension_constructor (lid, path);
            exp_loc = loc; exp_extra = [];
            exp_type = instance_def Predef.type_extension_constructor;
            exp_attributes = sexp.pexp_attributes;
            exp_env = env }
      | _ ->
          raise (Error (loc, env, Invalid_extension_constructor_payload))
      end
  | Pexp_extension ext ->
      raise (Error_forward (Builtin_attributes.error_of_extension ext))

  | Pexp_unreachable ->
      re { exp_desc = Texp_unreachable;
           exp_loc = loc; exp_extra = [];
           exp_type = instance env ty_expected;
           exp_attributes = sexp.pexp_attributes;
           exp_env = env }

and type_function ?in_function loc attrs env ty_expected l caselist =
  let (loc_fun, ty_fun) =
    match in_function with Some p -> p
    | None -> (loc, instance env ty_expected)
  in
  let separate = !Clflags.principal || Env.has_local_constraints env in
  if separate then begin_def ();
  let (ty_arg, ty_res) =
    try filter_arrow env (instance env ty_expected) l
    with Unify _ ->
      match expand_head env ty_expected with
        {desc = Tarrow _} as ty ->
          raise(Error(loc, env, Abstract_wrong_label(l, ty)))
      | _ ->
          raise(Error(loc_fun, env,
                      Too_many_arguments (in_function <> None, ty_fun)))
  in
  let ty_arg =
    if is_optional l then
      let tv = newvar() in
      begin
        try unify env ty_arg (type_option tv)
        with Unify _ -> assert false
      end;
      type_option tv
    else ty_arg
  in
  if separate then begin
    end_def ();
    generalize_structure ty_arg;
    generalize_structure ty_res
  end;
  let cases, partial =
    type_cases ~in_function:(loc_fun,ty_fun) env ty_arg ty_res
      true loc caselist in
  let not_function ty =
    let ls, tvar = list_labels env ty in
    ls = [] && not tvar
  in
  if is_optional l && not_function ty_res then
    Location.prerr_warning (List.hd cases).c_lhs.pat_loc
      Warnings.Unerasable_optional_argument;
  let param = name_pattern "param" cases in
  re {
    exp_desc = Texp_function { arg_label = l; param; cases; partial; };
    exp_loc = loc; exp_extra = [];
    exp_type = instance env (newgenty (Tarrow(l, ty_arg, ty_res, Cok)));
    exp_attributes = attrs;
    exp_env = env }


and type_label_access env srecord lid =
  if !Clflags.principal then begin_def ();
  let record = type_exp ~recarg:Allowed env srecord in
  if !Clflags.principal then begin
    end_def ();
    generalize_structure record.exp_type
  end;
  let ty_exp = record.exp_type in
  let opath =
    try
      let (p0, p,_) = extract_concrete_record env ty_exp in
      Some(p0, p, ty_exp.level = generic_level || not !Clflags.principal)
    with Not_found -> None
  in
  let labels = Typetexp.find_all_labels env lid.loc lid.txt in
  let label =
    wrap_disambiguate "This expression has" ty_exp
      (Label.disambiguate lid env opath) labels in
  (record, label, opath)

(* Typing format strings for printing or reading.
   These formats are used by functions in modules Printf, Format, and Scanf.
   (Handling of * modifiers contributed by Thorsten Ohl.) *)

and type_format loc str env =
  let loc = {loc with Location.loc_ghost = true} in
  try
    CamlinternalFormatBasics.(CamlinternalFormat.(
      let mk_exp_loc pexp_desc = {
        pexp_desc = pexp_desc;
        pexp_loc = loc;
        pexp_attributes = [];
      } and mk_lid_loc lid = {
        txt = lid;
        loc = loc;
      } in
      let mk_constr name args =
        let lid = Longident.(Ldot(Lident "CamlinternalFormatBasics", name)) in
        let arg = match args with
          | []          -> None
          | [ e ]       -> Some e
          | _ :: _ :: _ -> Some (mk_exp_loc (Pexp_tuple args)) in
        mk_exp_loc (Pexp_construct (mk_lid_loc lid, arg)) in
      let mk_cst cst = mk_exp_loc (Pexp_constant cst) in
      let mk_int n = mk_cst (Pconst_integer (string_of_int n, None))
      and mk_string str = mk_cst (Pconst_string (str, None))
      and mk_char chr = mk_cst (Pconst_char chr) in
      let rec mk_formatting_lit fmting = match fmting with
        | Close_box ->
          mk_constr "Close_box" []
        | Close_tag ->
          mk_constr "Close_tag" []
        | Break (org, ns, ni) ->
          mk_constr "Break" [ mk_string org; mk_int ns; mk_int ni ]
        | FFlush ->
          mk_constr "FFlush" []
        | Force_newline ->
          mk_constr "Force_newline" []
        | Flush_newline ->
          mk_constr "Flush_newline" []
        | Magic_size (org, sz) ->
          mk_constr "Magic_size" [ mk_string org; mk_int sz ]
        | Escaped_at ->
          mk_constr "Escaped_at" []
        | Escaped_percent ->
          mk_constr "Escaped_percent" []
        | Scan_indic c ->
          mk_constr "Scan_indic" [ mk_char c ]
      and mk_formatting_gen : type a b c d e f .
          (a, b, c, d, e, f) formatting_gen -> Parsetree.expression =
        fun fmting -> match fmting with
        | Open_tag (Format (fmt', str')) ->
          mk_constr "Open_tag" [ mk_format fmt' str' ]
        | Open_box (Format (fmt', str')) ->
          mk_constr "Open_box" [ mk_format fmt' str' ]
      and mk_format : type a b c d e f .
          (a, b, c, d, e, f) CamlinternalFormatBasics.fmt -> string ->
          Parsetree.expression = fun fmt str ->
        mk_constr "Format" [ mk_fmt fmt; mk_string str ]
      and mk_side side = match side with
        | Left  -> mk_constr "Left"  []
        | Right -> mk_constr "Right" []
        | Zeros -> mk_constr "Zeros" []
      and mk_iconv iconv = match iconv with
        | Int_d  -> mk_constr "Int_d"  [] | Int_pd -> mk_constr "Int_pd" []
        | Int_sd -> mk_constr "Int_sd" [] | Int_i  -> mk_constr "Int_i"  []
        | Int_pi -> mk_constr "Int_pi" [] | Int_si -> mk_constr "Int_si" []
        | Int_x  -> mk_constr "Int_x"  [] | Int_Cx -> mk_constr "Int_Cx" []
        | Int_X  -> mk_constr "Int_X"  [] | Int_CX -> mk_constr "Int_CX" []
        | Int_o  -> mk_constr "Int_o"  [] | Int_Co -> mk_constr "Int_Co" []
        | Int_u  -> mk_constr "Int_u"  []
      and mk_fconv fconv = match fconv with
        | Float_f  -> mk_constr "Float_f"  []
        | Float_pf -> mk_constr "Float_pf" []
        | Float_sf -> mk_constr "Float_sf" []
        | Float_e  -> mk_constr "Float_e"  []
        | Float_pe -> mk_constr "Float_pe" []
        | Float_se -> mk_constr "Float_se" []
        | Float_E  -> mk_constr "Float_E"  []
        | Float_pE -> mk_constr "Float_pE" []
        | Float_sE -> mk_constr "Float_sE" []
        | Float_g  -> mk_constr "Float_g"  []
        | Float_pg -> mk_constr "Float_pg" []
        | Float_sg -> mk_constr "Float_sg" []
        | Float_G  -> mk_constr "Float_G"  []
        | Float_pG -> mk_constr "Float_pG" []
        | Float_sG -> mk_constr "Float_sG" []
        | Float_h  -> mk_constr "Float_h"  []
        | Float_ph -> mk_constr "Float_ph" []
        | Float_sh -> mk_constr "Float_sh" []
        | Float_H  -> mk_constr "Float_H"  []
        | Float_pH -> mk_constr "Float_pH" []
        | Float_sH -> mk_constr "Float_sH" []
        | Float_F  -> mk_constr "Float_F"  []
      and mk_counter cnt = match cnt with
        | Line_counter  -> mk_constr "Line_counter"  []
        | Char_counter  -> mk_constr "Char_counter"  []
        | Token_counter -> mk_constr "Token_counter" []
      and mk_int_opt n_opt = match n_opt with
        | None ->
          let lid_loc = mk_lid_loc (Longident.Lident "None") in
          mk_exp_loc (Pexp_construct (lid_loc, None))
        | Some n ->
          let lid_loc = mk_lid_loc (Longident.Lident "Some") in
          mk_exp_loc (Pexp_construct (lid_loc, Some (mk_int n)))
      and mk_fmtty : type a b c d e f g h i j k l .
          (a, b, c, d, e, f, g, h, i, j, k, l) fmtty_rel -> Parsetree.expression
          =
      fun fmtty -> match fmtty with
        | Char_ty rest      -> mk_constr "Char_ty"      [ mk_fmtty rest ]
        | String_ty rest    -> mk_constr "String_ty"    [ mk_fmtty rest ]
        | Int_ty rest       -> mk_constr "Int_ty"       [ mk_fmtty rest ]
        | Int32_ty rest     -> mk_constr "Int32_ty"     [ mk_fmtty rest ]
        | Nativeint_ty rest -> mk_constr "Nativeint_ty" [ mk_fmtty rest ]
        | Int64_ty rest     -> mk_constr "Int64_ty"     [ mk_fmtty rest ]
        | Float_ty rest     -> mk_constr "Float_ty"     [ mk_fmtty rest ]
        | Bool_ty rest      -> mk_constr "Bool_ty"      [ mk_fmtty rest ]
        | Alpha_ty rest     -> mk_constr "Alpha_ty"     [ mk_fmtty rest ]
        | Theta_ty rest     -> mk_constr "Theta_ty"     [ mk_fmtty rest ]
        | Any_ty rest       -> mk_constr "Any_ty"       [ mk_fmtty rest ]
        | Reader_ty rest    -> mk_constr "Reader_ty"    [ mk_fmtty rest ]
        | Ignored_reader_ty rest ->
          mk_constr "Ignored_reader_ty" [ mk_fmtty rest ]
        | Format_arg_ty (sub_fmtty, rest) ->
          mk_constr "Format_arg_ty" [ mk_fmtty sub_fmtty; mk_fmtty rest ]
        | Format_subst_ty (sub_fmtty1, sub_fmtty2, rest) ->
          mk_constr "Format_subst_ty"
            [ mk_fmtty sub_fmtty1; mk_fmtty sub_fmtty2; mk_fmtty rest ]
        | End_of_fmtty -> mk_constr "End_of_fmtty" []
      and mk_ignored : type a b c d e f .
          (a, b, c, d, e, f) ignored -> Parsetree.expression =
      fun ign -> match ign with
        | Ignored_char ->
          mk_constr "Ignored_char" []
        | Ignored_caml_char ->
          mk_constr "Ignored_caml_char" []
        | Ignored_string pad_opt ->
          mk_constr "Ignored_string" [ mk_int_opt pad_opt ]
        | Ignored_caml_string pad_opt ->
          mk_constr "Ignored_caml_string" [ mk_int_opt pad_opt ]
        | Ignored_int (iconv, pad_opt) ->
          mk_constr "Ignored_int" [ mk_iconv iconv; mk_int_opt pad_opt ]
        | Ignored_int32 (iconv, pad_opt) ->
          mk_constr "Ignored_int32" [ mk_iconv iconv; mk_int_opt pad_opt ]
        | Ignored_nativeint (iconv, pad_opt) ->
          mk_constr "Ignored_nativeint" [ mk_iconv iconv; mk_int_opt pad_opt ]
        | Ignored_int64 (iconv, pad_opt) ->
          mk_constr "Ignored_int64" [ mk_iconv iconv; mk_int_opt pad_opt ]
        | Ignored_float (pad_opt, prec_opt) ->
          mk_constr "Ignored_float" [ mk_int_opt pad_opt; mk_int_opt prec_opt ]
        | Ignored_bool pad_opt ->
          mk_constr "Ignored_bool" [ mk_int_opt pad_opt ]
        | Ignored_format_arg (pad_opt, fmtty) ->
          mk_constr "Ignored_format_arg" [ mk_int_opt pad_opt; mk_fmtty fmtty ]
        | Ignored_format_subst (pad_opt, fmtty) ->
          mk_constr "Ignored_format_subst" [
            mk_int_opt pad_opt; mk_fmtty fmtty ]
        | Ignored_reader ->
          mk_constr "Ignored_reader" []
        | Ignored_scan_char_set (width_opt, char_set) ->
          mk_constr "Ignored_scan_char_set" [
            mk_int_opt width_opt; mk_string char_set ]
        | Ignored_scan_get_counter counter ->
          mk_constr "Ignored_scan_get_counter" [
            mk_counter counter
          ]
        | Ignored_scan_next_char ->
          mk_constr "Ignored_scan_next_char" []
      and mk_padding : type x y . (x, y) padding -> Parsetree.expression =
      fun pad -> match pad with
        | No_padding         -> mk_constr "No_padding" []
        | Lit_padding (s, w) -> mk_constr "Lit_padding" [ mk_side s; mk_int w ]
        | Arg_padding s      -> mk_constr "Arg_padding" [ mk_side s ]
      and mk_precision : type x y . (x, y) precision -> Parsetree.expression =
      fun prec -> match prec with
        | No_precision    -> mk_constr "No_precision" []
        | Lit_precision w -> mk_constr "Lit_precision" [ mk_int w ]
        | Arg_precision   -> mk_constr "Arg_precision" []
      and mk_fmt : type a b c d e f .
          (a, b, c, d, e, f) fmt -> Parsetree.expression =
      fun fmt -> match fmt with
        | Char rest ->
          mk_constr "Char" [ mk_fmt rest ]
        | Caml_char rest ->
          mk_constr "Caml_char" [ mk_fmt rest ]
        | String (pad, rest) ->
          mk_constr "String" [ mk_padding pad; mk_fmt rest ]
        | Caml_string (pad, rest) ->
          mk_constr "Caml_string" [ mk_padding pad; mk_fmt rest ]
        | Int (iconv, pad, prec, rest) ->
          mk_constr "Int" [
            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
        | Int32 (iconv, pad, prec, rest) ->
          mk_constr "Int32" [
            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
        | Nativeint (iconv, pad, prec, rest) ->
          mk_constr "Nativeint" [
            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
        | Int64 (iconv, pad, prec, rest) ->
          mk_constr "Int64" [
            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
        | Float (fconv, pad, prec, rest) ->
          mk_constr "Float" [
            mk_fconv fconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
        | Bool (pad, rest) ->
          mk_constr "Bool" [ mk_padding pad; mk_fmt rest ]
        | Flush rest ->
          mk_constr "Flush" [ mk_fmt rest ]
        | String_literal (s, rest) ->
          mk_constr "String_literal" [ mk_string s; mk_fmt rest ]
        | Char_literal (c, rest) ->
          mk_constr "Char_literal" [ mk_char c; mk_fmt rest ]
        | Format_arg (pad_opt, fmtty, rest) ->
          mk_constr "Format_arg" [
            mk_int_opt pad_opt; mk_fmtty fmtty; mk_fmt rest ]
        | Format_subst (pad_opt, fmtty, rest) ->
          mk_constr "Format_subst" [
            mk_int_opt pad_opt; mk_fmtty fmtty; mk_fmt rest ]
        | Alpha rest ->
          mk_constr "Alpha" [ mk_fmt rest ]
        | Theta rest ->
          mk_constr "Theta" [ mk_fmt rest ]
        | Formatting_lit (fmting, rest) ->
          mk_constr "Formatting_lit" [ mk_formatting_lit fmting; mk_fmt rest ]
        | Formatting_gen (fmting, rest) ->
          mk_constr "Formatting_gen" [ mk_formatting_gen fmting; mk_fmt rest ]
        | Reader rest ->
          mk_constr "Reader" [ mk_fmt rest ]
        | Scan_char_set (width_opt, char_set, rest) ->
          mk_constr "Scan_char_set" [
            mk_int_opt width_opt; mk_string char_set; mk_fmt rest ]
        | Scan_get_counter (cnt, rest) ->
          mk_constr "Scan_get_counter" [ mk_counter cnt; mk_fmt rest ]
        | Scan_next_char rest ->
          mk_constr "Scan_next_char" [ mk_fmt rest ]
        | Ignored_param (ign, rest) ->
          mk_constr "Ignored_param" [ mk_ignored ign; mk_fmt rest ]
        | End_of_format ->
          mk_constr "End_of_format" []
        | Custom _ ->
          (* Custom formatters have no syntax so they will never appear
             in formats parsed from strings. *)
          assert false
      in
      let legacy_behavior = not !Clflags.strict_formats in
      let Fmt_EBB fmt = fmt_ebb_of_string ~legacy_behavior str in
      mk_constr "Format" [ mk_fmt fmt; mk_string str ]
    ))
  with Failure msg ->
    raise (Error (loc, env, Invalid_format msg))

and type_label_exp create env loc ty_expected
          (lid, label, sarg) =
  (* Here also ty_expected may be at generic_level *)
  begin_def ();
  let separate = !Clflags.principal || Env.has_local_constraints env in
  if separate then (begin_def (); begin_def ());
  let (vars, ty_arg, ty_res) = instance_label true label in
  if separate then begin
    end_def ();
    (* Generalize label information *)
    generalize_structure ty_arg;
    generalize_structure ty_res
  end;
  begin try
    unify env (instance_def ty_res) (instance env ty_expected)
  with Unify trace ->
    raise (Error(lid.loc, env, Label_mismatch(lid.txt, trace)))
  end;
  (* Instantiate so that we can generalize internal nodes *)
  let ty_arg = instance_def ty_arg in
  if separate then begin
    end_def ();
    (* Generalize information merged from ty_expected *)
    generalize_structure ty_arg
  end;
  if label.lbl_private = Private then
    if create then
      raise (Error(loc, env, Private_type ty_expected))
    else
      raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected)));
  let arg =
    let snap = if vars = [] then None else Some (Btype.snapshot ()) in
    let arg = type_argument env sarg ty_arg (instance env ty_arg) in
    end_def ();
    try
      check_univars env (vars <> []) "field value" arg label.lbl_arg vars;
      arg
    with exn when not (is_nonexpansive arg) -> try
      (* Try to retype without propagating ty_arg, cf PR#4862 *)
      may Btype.backtrack snap;
      begin_def ();
      let arg = type_exp env sarg in
      end_def ();
      generalize_expansive env arg.exp_type;
      unify_exp env arg ty_arg;
      check_univars env false "field value" arg label.lbl_arg vars;
      arg
    with Error (_, _, Less_general _) as e -> raise e
    | _ -> raise exn    (* In case of failure return the first error *)
  in
  (lid, label, {arg with exp_type = instance env arg.exp_type})

and type_argument ?recarg env sarg ty_expected' ty_expected =
  (* ty_expected' may be generic *)
  let no_labels ty =
    let ls, tvar = list_labels env ty in
    not tvar && List.for_all ((=) Nolabel) ls
  in
  let rec is_inferred sexp =
    match sexp.pexp_desc with
      Pexp_ident _ | Pexp_apply _ | Pexp_field _ | Pexp_constraint _
    | Pexp_coerce _ | Pexp_send _ | Pexp_new _ -> true
    | Pexp_sequence (_, e) | Pexp_open (_, _, e) -> is_inferred e
    | Pexp_ifthenelse (_, e1, Some e2) -> is_inferred e1 && is_inferred e2
    | _ -> false
  in
  match expand_head env ty_expected' with
    {desc = Tarrow(Nolabel,ty_arg,ty_res,_); level = lv}
    when is_inferred sarg ->
      (* apply optional arguments when expected type is "" *)
      (* we must be very careful about not breaking the semantics *)
      if !Clflags.principal then begin_def ();
      let texp = type_exp env sarg in
      if !Clflags.principal then begin
        end_def ();
        generalize_structure texp.exp_type
      end;
      let rec make_args args ty_fun =
        match (expand_head env ty_fun).desc with
        | Tarrow (l,ty_arg,ty_fun,_) when is_optional l ->
            let ty = option_none (instance env ty_arg) sarg.pexp_loc in
            make_args ((l, Some ty) :: args) ty_fun
        | Tarrow (l,_,ty_res',_) when l = Nolabel || !Clflags.classic ->
            List.rev args, ty_fun, no_labels ty_res'
        | Tvar _ ->  List.rev args, ty_fun, false
        |  _ -> [], texp.exp_type, false
      in
      let args, ty_fun', simple_res = make_args [] texp.exp_type in
      let warn = !Clflags.principal &&
        (lv <> generic_level || (repr ty_fun').level <> generic_level)
      and texp = {texp with exp_type = instance env texp.exp_type}
      and ty_fun = instance env ty_fun' in
      if not (simple_res || no_labels ty_res) then begin
        unify_exp env texp ty_expected;
        texp
      end else begin
      unify_exp env {texp with exp_type = ty_fun} ty_expected;
      if args = [] then texp else
      (* eta-expand to avoid side effects *)
      let var_pair name ty =
        let id = Ident.create name in
        {pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[];
         pat_attributes = [];
         pat_loc = Location.none; pat_env = env},
        {exp_type = ty; exp_loc = Location.none; exp_env = env;
         exp_extra = []; exp_attributes = [];
         exp_desc =
         Texp_ident(Path.Pident id, mknoloc (Longident.Lident name),
                    {val_type = ty; val_kind = Val_reg;
                     val_attributes = [];
                     Types.val_loc = Location.none})}
      in
      let eta_pat, eta_var = var_pair "eta" ty_arg in
      let func texp =
        let e =
          {texp with exp_type = ty_res; exp_desc =
           Texp_apply
             (texp,
              args @ [Nolabel, Some eta_var])}
        in
        let cases = [case eta_pat e] in
        let param = name_pattern "param" cases in
        { texp with exp_type = ty_fun; exp_desc =
          Texp_function { arg_label = Nolabel; param; cases;
            partial = Total; } }
      in
      Location.prerr_warning texp.exp_loc
        (Warnings.Eliminated_optional_arguments
           (List.map (fun (l, _) -> Printtyp.string_of_label l) args));
      if warn then Location.prerr_warning texp.exp_loc
          (Warnings.Without_principality "eliminated optional argument");
      (* let-expand to have side effects *)
      let let_pat, let_var = var_pair "arg" texp.exp_type in
      re { texp with exp_type = ty_fun; exp_desc =
           Texp_let (Nonrecursive,
                     [{vb_pat=let_pat; vb_expr=texp; vb_attributes=[];
                       vb_loc=Location.none;
                      }],
                     func let_var) }
      end
  | _ ->
      let texp = type_expect ?recarg env sarg ty_expected' in
      unify_exp env texp ty_expected;
      texp

and type_application env funct sargs =
  (* funct.exp_type may be generic *)
  let result_type omitted ty_fun =
    List.fold_left
      (fun ty_fun (l,ty,lv) -> newty2 lv (Tarrow(l,ty,ty_fun,Cok)))
      ty_fun omitted
  in
  let has_label l ty_fun =
    let ls, tvar = list_labels env ty_fun in
    tvar || List.mem l ls
  in
  let ignored = ref [] in
  let rec type_unknown_args
      (args :
      (Asttypes.arg_label * (unit -> Typedtree.expression) option) list)
    omitted ty_fun = function
      [] ->
        (List.map
            (function l, None -> l, None
                | l, Some f -> l, Some (f ()))
           (List.rev args),
         instance env (result_type omitted ty_fun))
    | (l1, sarg1) :: sargl ->
        let (ty1, ty2) =
          let ty_fun = expand_head env ty_fun in
          match ty_fun.desc with
            Tvar _ ->
              let t1 = newvar () and t2 = newvar () in
              let not_identity = function
                  Texp_ident(_,_,{val_kind=Val_prim
                                  {Primitive.prim_name="%identity"}}) ->
                    false
                | _ -> true
              in
              if ty_fun.level >= t1.level && not_identity funct.exp_desc then
                Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument;
              unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown))));
              (t1, t2)
          | Tarrow (l,t1,t2,_) when l = l1
            || !Clflags.classic && l1 = Nolabel && not (is_optional l) ->
              (t1, t2)
          | td ->
              let ty_fun =
                match td with Tarrow _ -> newty td | _ -> ty_fun in
              let ty_res = result_type (omitted @ !ignored) ty_fun in
              match ty_res.desc with
                Tarrow _ ->
                  if (!Clflags.classic || not (has_label l1 ty_fun)) then
                    raise (Error(sarg1.pexp_loc, env,
                                 Apply_wrong_label(l1, ty_res)))
                  else
                    raise (Error(funct.exp_loc, env, Incoherent_label_order))
              | _ ->
                  raise(Error(funct.exp_loc, env, Apply_non_function
                                (expand_head env funct.exp_type)))
        in
        let optional = is_optional l1 in
        let arg1 () =
          let arg1 = type_expect env sarg1 ty1 in
          if optional then
            unify_exp env arg1 (type_option(newvar()));
          arg1
        in
        type_unknown_args ((l1, Some arg1) :: args) omitted ty2 sargl
  in
  let ignore_labels =
    !Clflags.classic ||
    begin
      let ls, tvar = list_labels env funct.exp_type in
      not tvar &&
      let labels = List.filter (fun l -> not (is_optional l)) ls in
      List.length labels = List.length sargs &&
      List.for_all (fun (l,_) -> l = Nolabel) sargs &&
      List.exists (fun l -> l <> Nolabel) labels &&
      (Location.prerr_warning
         funct.exp_loc
         (Warnings.Labels_omitted
            (List.map Printtyp.string_of_label
                      (List.filter ((<>) Nolabel) labels)));
       true)
    end
  in
  let warned = ref false in
  let rec type_args args omitted ty_fun ty_fun0 ty_old sargs more_sargs =
    match expand_head env ty_fun, expand_head env ty_fun0 with
      {desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun',
      {desc=Tarrow (_, ty0, ty_fun0, _)}
      when (sargs <> [] || more_sargs <> []) && commu_repr com = Cok ->
        let may_warn loc w =
          if not !warned && !Clflags.principal && lv <> generic_level
          then begin
            warned := true;
            Location.prerr_warning loc w
          end
        in
        let name = label_name l
        and optional = is_optional l in
        let sargs, more_sargs, arg =
          if ignore_labels && not (is_optional l) then begin
            (* In classic mode, omitted = [] *)
            match sargs, more_sargs with
              (l', sarg0) :: _, _ ->
                raise(Error(sarg0.pexp_loc, env,
                            Apply_wrong_label(l', ty_old)))
            | _, (l', sarg0) :: more_sargs ->
                if l <> l' && l' <> Nolabel then
                  raise(Error(sarg0.pexp_loc, env,
                              Apply_wrong_label(l', ty_fun')))
                else
                  ([], more_sargs,
                   Some (fun () -> type_argument env sarg0 ty ty0))
            | _ ->
                assert false
          end else try
            let (l', sarg0, sargs, more_sargs) =
              try
                let (l', sarg0, sargs1, sargs2) = extract_label name sargs in
                if sargs1 <> [] then
                  may_warn sarg0.pexp_loc
                    (Warnings.Not_principal "commuting this argument");
                (l', sarg0, sargs1 @ sargs2, more_sargs)
              with Not_found ->
                let (l', sarg0, sargs1, sargs2) =
                  extract_label name more_sargs in
                if sargs1 <> [] || sargs <> [] then
                  may_warn sarg0.pexp_loc
                    (Warnings.Not_principal "commuting this argument");
                (l', sarg0, sargs @ sargs1, sargs2)
            in
            if not optional && is_optional l' then
              Location.prerr_warning sarg0.pexp_loc
                (Warnings.Nonoptional_label (Printtyp.string_of_label l));
            sargs, more_sargs,
            if not optional || is_optional l' then
              Some (fun () -> type_argument env sarg0 ty ty0)
            else begin
              may_warn sarg0.pexp_loc
                (Warnings.Not_principal "using an optional argument here");
              Some (fun () -> option_some (type_argument env sarg0
                                             (extract_option_type env ty)
                                             (extract_option_type env ty0)))
            end
          with Not_found ->
            sargs, more_sargs,
            if optional &&
              (List.mem_assoc Nolabel sargs
               || List.mem_assoc Nolabel more_sargs)
            then begin
              may_warn funct.exp_loc
                (Warnings.Without_principality "eliminated optional argument");
              ignored := (l,ty,lv) :: !ignored;
              Some (fun () -> option_none (instance env ty) Location.none)
            end else begin
              may_warn funct.exp_loc
                (Warnings.Without_principality "commuted an argument");
              None
            end
        in
        let omitted =
          if arg = None then (l,ty,lv) :: omitted else omitted in
        let ty_old = if sargs = [] then ty_fun else ty_old in
        type_args ((l,arg)::args) omitted ty_fun ty_fun0
          ty_old sargs more_sargs
    | _ ->
        match sargs with
          (l, sarg0) :: _ when ignore_labels ->
            raise(Error(sarg0.pexp_loc, env,
                        Apply_wrong_label(l, ty_old)))
        | _ ->
            type_unknown_args args omitted ty_fun0
              (sargs @ more_sargs)
  in
  let is_ignore funct =
    match funct.exp_desc with
      Texp_ident (_, _, {val_kind=Val_prim{Primitive.prim_name="%ignore"}}) ->
        (try ignore (filter_arrow env (instance env funct.exp_type) Nolabel);
             true
        with Unify _ -> false)
    | _ -> false
  in
  match sargs with
    (* Special case for ignore: avoid discarding warning *)
    [Nolabel, sarg] when is_ignore funct ->
      let ty_arg, ty_res =
        filter_arrow env (instance env funct.exp_type) Nolabel
      in
      let exp = type_expect env sarg ty_arg in
      begin match (expand_head env exp.exp_type).desc with
      | Tarrow _ ->
          Location.prerr_warning exp.exp_loc Warnings.Partial_application
      | Tvar _ ->
          add_delayed_check (fun () -> check_application_result env false exp)
      | _ -> ()
      end;
      ([Nolabel, Some exp], ty_res)
  | _ ->
      let ty = funct.exp_type in
      if ignore_labels then
        type_args [] [] ty (instance env ty) ty [] sargs
      else
        type_args [] [] ty (instance env ty) ty sargs []

and type_construct env loc lid sarg ty_expected attrs =
  let opath =
    try
      let (p0, p,_) = extract_concrete_variant env ty_expected in
      Some(p0, p, ty_expected.level = generic_level || not !Clflags.principal)
    with Not_found -> None
  in
  let constrs = Typetexp.find_all_constructors env lid.loc lid.txt in
  let constr =
    wrap_disambiguate "This variant expression is expected to have" ty_expected
      (Constructor.disambiguate lid env opath) constrs in
  Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr;
  Builtin_attributes.check_deprecated loc constr.cstr_attributes
    constr.cstr_name;
  let sargs =
    match sarg with
      None -> []
    | Some {pexp_desc = Pexp_tuple sel} when
        constr.cstr_arity > 1 || Builtin_attributes.explicit_arity attrs
      -> sel
    | Some se -> [se] in
  if List.length sargs <> constr.cstr_arity then
    raise(Error(loc, env, Constructor_arity_mismatch
                  (lid.txt, constr.cstr_arity, List.length sargs)));
  let separate = !Clflags.principal || Env.has_local_constraints env in
  if separate then (begin_def (); begin_def ());
  let (ty_args, ty_res) = instance_constructor constr in
  let texp =
    re {
      exp_desc = Texp_construct(lid, constr, []);
      exp_loc = loc; exp_extra = [];
      exp_type = ty_res;
      exp_attributes = attrs;
      exp_env = env } in
  if separate then begin
    end_def ();
    generalize_structure ty_res;
    unify_exp env {texp with exp_type = instance_def ty_res}
                  (instance env ty_expected);
    end_def ();
    List.iter generalize_structure ty_args;
    generalize_structure ty_res;
  end;
  let ty_args0, ty_res =
    match instance_list env (ty_res :: ty_args) with
      t :: tl -> tl, t
    | _ -> assert false
  in
  let texp = {texp with exp_type = ty_res} in
  if not separate then unify_exp env texp (instance env ty_expected);
  let recarg =
    match constr.cstr_inlined with
    | None -> Rejected
    | Some _ ->
        begin match sargs with
        | [{pexp_desc =
              Pexp_ident _ |
              Pexp_record (_, (Some {pexp_desc = Pexp_ident _}| None))}] ->
            Required
        | _ ->
            raise (Error(loc, env, Inlined_record_expected))
        end
  in
  let args =
    List.map2 (fun e (t,t0) -> type_argument ~recarg env e t t0) sargs
      (List.combine ty_args ty_args0) in
  if constr.cstr_private = Private then
    raise(Error(loc, env, Private_type ty_res));
  (* NOTE: shouldn't we call "re" on this final expression? -- AF *)
  { texp with
    exp_desc = Texp_construct(lid, constr, args) }

(* Typing of statements (expressions whose values are discarded) *)

and type_statement env sexp =
  let loc = (final_subexpression sexp).pexp_loc in
  begin_def();
  let exp = type_exp env sexp in
  end_def();
  let ty = expand_head env exp.exp_type and tv = newvar() in
  if is_Tvar ty && ty.level > tv.level then
      Location.prerr_warning loc Warnings.Nonreturning_statement;
  if !Clflags.strict_sequence then
    let expected_ty = instance_def Predef.type_unit in
    unify_exp env exp expected_ty;
    exp
  else begin
    begin match ty.desc with
    | Tarrow _ ->
        Location.prerr_warning loc Warnings.Partial_application
    | Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
    | Tvar _ ->
        add_delayed_check (fun () -> check_application_result env true exp)
    | _ ->
        Location.prerr_warning loc Warnings.Statement_type
    end;
    unify_var env tv ty;
    exp
  end

(* Typing of match cases *)

and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
  (* ty_arg is _fully_ generalized *)
  let patterns = List.map (fun {pc_lhs=p} -> p) caselist in
  let contains_polyvars = List.exists contains_polymorphic_variant patterns in
  let erase_either = contains_polyvars && contains_variant_either ty_arg
  and has_gadts = List.exists (contains_gadt env) patterns in
(*  prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *)
  let ty_arg =
    if (has_gadts || erase_either) && not !Clflags.principal
    then correct_levels ty_arg else ty_arg
  and ty_res, env =
    if has_gadts && not !Clflags.principal then
      correct_levels ty_res, duplicate_ident_types caselist env
    else ty_res, env
  in
  let rec is_var spat =
    match spat.ppat_desc with
      Ppat_any | Ppat_var _ -> true
    | Ppat_alias (spat, _) -> is_var spat
    | _ -> false in
  let needs_exhaust_check =
    match caselist with
      [{pc_rhs = {pexp_desc = Pexp_unreachable}}] -> true
    | [{pc_lhs}] when is_var pc_lhs -> false
    | _ -> true
  in
  let init_env () =
    (* raise level for existentials *)
    begin_def ();
    Ident.set_current_time (get_current_level ());
    let lev = Ident.current_time () in
    Ctype.init_def (lev+1000);                 (* up to 1000 existentials *)
    (lev, Env.add_gadt_instance_level lev env)
  in
  let lev, env =
    if has_gadts then init_env () else (get_current_level (), env)
  in
(*  if has_gadts then
    Format.printf "lev = %d@.%a@." lev Printtyp.raw_type_expr ty_res; *)
  (* Do we need to propagate polymorphism *)
  let propagate =
    !Clflags.principal || has_gadts || (repr ty_arg).level = generic_level ||
    match caselist with
      [{pc_lhs}] when is_var pc_lhs -> false
    | _ -> true in
  if propagate then begin_def (); (* propagation of the argument *)
  let pattern_force = ref [] in
(*  Format.printf "@[%i %i@ %a@]@." lev (get_current_level())
    Printtyp.raw_type_expr ty_arg; *)
  let pat_env_list =
    List.map
      (fun {pc_lhs; pc_guard; pc_rhs} ->
        let loc =
          let open Location in
          match pc_guard with
          | None -> pc_rhs.pexp_loc
          | Some g -> {pc_rhs.pexp_loc with loc_start=g.pexp_loc.loc_start}
        in
        if !Clflags.principal then begin_def (); (* propagation of pattern *)
        let scope = Some (Annot.Idef loc) in
        let (pat, ext_env, force, unpacks) =
          let partial =
            if !Clflags.principal || erase_either
            then Some false else None in
          let ty_arg = instance ?partial env ty_arg in
          type_pattern ~lev env pc_lhs scope ty_arg
        in
        pattern_force := force @ !pattern_force;
        let pat =
          if !Clflags.principal then begin
            end_def ();
            iter_pattern (fun {pat_type=t} -> generalize_structure t) pat;
            { pat with pat_type = instance ext_env pat.pat_type }
          end else pat
        in
        (pat, (ext_env, unpacks)))
      caselist in
  (* Unify all cases (delayed to keep it order-free) *)
  let ty_arg' = newvar () in
  let unify_pats ty =
    List.iter (fun (pat, (ext_env, _)) -> unify_pat ext_env pat ty)
      pat_env_list in
  unify_pats ty_arg';
  (* Check for polymorphic variants to close *)
  let patl = List.map fst pat_env_list in
  if List.exists has_variants patl then begin
    Parmatch.pressure_variants env patl;
    List.iter (iter_pattern finalize_variant) patl
  end;
  (* `Contaminating' unifications start here *)
  List.iter (fun f -> f()) !pattern_force;
  (* Post-processing and generalization *)
  if propagate || erase_either then unify_pats (instance env ty_arg);
  if propagate then begin
    List.iter
      (iter_pattern (fun {pat_type=t} -> unify_var env t (newvar()))) patl;
    end_def ();
    List.iter (iter_pattern (fun {pat_type=t} -> generalize t)) patl;
  end;
  (* type bodies *)
  let in_function = if List.length caselist = 1 then in_function else None in
  let cases =
    List.map2
      (fun (pat, (ext_env, unpacks)) {pc_lhs; pc_guard; pc_rhs} ->
        let sexp = wrap_unpacks pc_rhs unpacks in
        let ty_res' =
          if !Clflags.principal then begin
            begin_def ();
            let ty = instance ~partial:true env ty_res in
            end_def ();
            generalize_structure ty; ty
          end
          else if contains_gadt env pc_lhs then correct_levels ty_res
          else ty_res in
(*        Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level())
          Printtyp.raw_type_expr ty_res'; *)
        let guard =
          match pc_guard with
          | None -> None
          | Some scond ->
              Some
                (type_expect ext_env (wrap_unpacks scond unpacks)
                   Predef.type_bool)
        in
        let exp = type_expect ?in_function ext_env sexp ty_res' in
        {
         c_lhs = pat;
         c_guard = guard;
         c_rhs = {exp with exp_type = instance env ty_res'}
        }
      )
      pat_env_list caselist
  in
  if !Clflags.principal || has_gadts then begin
    let ty_res' = instance env ty_res in
    List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases
  end;
  let do_init = has_gadts || needs_exhaust_check in
  let lev, env =
    if do_init && not has_gadts then init_env () else lev, env in
  let ty_arg_check =
    if do_init then
      (* Hack: use for_saving to copy variables too *)
      Subst.type_expr (Subst.for_saving Subst.identity) ty_arg
    else ty_arg
  in
  let partial =
    if partial_flag then
      check_partial ~lev env ty_arg_check loc cases
    else
      Partial
  in
  let unused_check () =
    List.iter (fun (pat, (env, _)) -> check_absent_variant env pat)
      pat_env_list;
    check_unused ~lev env (instance env ty_arg_check) cases ;
    Parmatch.check_ambiguous_bindings cases
  in
  if contains_polyvars || do_init then
    add_delayed_check unused_check
  else
    unused_check ();
  (* Check for unused cases, do not delay because of gadts *)
  if do_init then begin
    end_def ();
    (* Ensure that existential types do not escape *)
    unify_exp_types loc env (instance env ty_res) (newvar ()) ;
  end;
  cases, partial

(* Typing of let bindings *)

and type_let ?(check = fun s -> Warnings.Unused_var s)
             ?(check_strict = fun s -> Warnings.Unused_var_strict s)
    env rec_flag spat_sexp_list scope allow =
  let open Ast_helper in
  begin_def();
  if !Clflags.principal then begin_def ();

  let is_fake_let =
    match spat_sexp_list with
    | [{pvb_expr={pexp_desc=Pexp_match(
           {pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}}] ->
        true (* the fake let-declaration introduced by fun ?(x = e) -> ... *)
    | _ ->
        false
  in
  let check = if is_fake_let then check_strict else check in

  let spatl =
    List.map
      (fun {pvb_pat=spat; pvb_expr=sexp; pvb_attributes=attrs} ->
        attrs,
        match spat.ppat_desc, sexp.pexp_desc with
          (Ppat_any | Ppat_constraint _), _ -> spat
        | _, Pexp_coerce (_, _, sty)
        | _, Pexp_constraint (_, sty) when !Clflags.principal ->
            (* propagate type annotation to pattern,
               to allow it to be generalized in -principal mode *)
            Pat.constraint_
              ~loc:{spat.ppat_loc with Location.loc_ghost=true}
              spat
              sty
        | _ -> spat)
      spat_sexp_list in
  let nvs = List.map (fun _ -> newvar ()) spatl in
  let (pat_list, new_env, force, unpacks) =
    type_pattern_list env spatl scope nvs allow in
  let attrs_list = List.map fst spatl in
  let is_recursive = (rec_flag = Recursive) in
  (* If recursive, first unify with an approximation of the expression *)
  if is_recursive then
    List.iter2
      (fun pat binding ->
        let pat =
          match pat.pat_type.desc with
          | Tpoly (ty, tl) ->
              {pat with pat_type =
               snd (instance_poly ~keep_names:true false tl ty)}
          | _ -> pat
        in unify_pat env pat (type_approx env binding.pvb_expr))
      pat_list spat_sexp_list;
  (* Polymorphic variant processing *)
  List.iter
    (fun pat ->
      if has_variants pat then begin
        Parmatch.pressure_variants env [pat];
        iter_pattern finalize_variant pat
      end)
    pat_list;
  (* Generalize the structure *)
  let pat_list =
    if !Clflags.principal then begin
      end_def ();
      List.map
        (fun pat ->
          iter_pattern (fun pat -> generalize_structure pat.pat_type) pat;
          {pat with pat_type = instance env pat.pat_type})
        pat_list
    end else pat_list in
  (* Only bind pattern variables after generalizing *)
  List.iter (fun f -> f()) force;
  let exp_env =
    if is_recursive then new_env else env in

  let current_slot = ref None in
  let rec_needed = ref false in
  let warn_about_unused_bindings =
    List.exists
      (fun attrs ->
         Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () ->
           Warnings.is_active (check "") || Warnings.is_active (check_strict "") ||
           (is_recursive && (Warnings.is_active Warnings.Unused_rec_flag))))
      attrs_list
  in
  let pat_slot_list =
    (* Algorithm to detect unused declarations in recursive bindings:
       - During type checking of the definitions, we capture the 'value_used'
         events on the bound identifiers and record them in a slot corresponding
         to the current definition (!current_slot).
         In effect, this creates a dependency graph between definitions.

       - After type checking the definition (!current_slot = None),
         when one of the bound identifier is effectively used, we trigger
         again all the events recorded in the corresponding slot.
         The effect is to traverse the transitive closure of the graph created
         in the first step.

       We also keep track of whether *all* variables in a given pattern
       are unused. If this is the case, for local declarations, the issued
       warning is 26, not 27.
     *)
    List.map2
      (fun attrs pat ->
         Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () ->
           if not warn_about_unused_bindings then pat, None
           else
             let some_used = ref false in
             (* has one of the identifier of this pattern been used? *)
             let slot = ref [] in
             List.iter
               (fun id ->
                  let vd = Env.find_value (Path.Pident id) new_env in
                  (* note: Env.find_value does not trigger the value_used event *)
                  let name = Ident.name id in
                  let used = ref false in
                  if not (name = "" || name.[0] = '_' || name.[0] = '#') then
                    add_delayed_check
                      (fun () ->
                         if not !used then
                           Location.prerr_warning vd.Types.val_loc
                             ((if !some_used then check_strict else check) name)
                      );
                  Env.set_value_used_callback
                    name vd
                    (fun () ->
                       match !current_slot with
                       | Some slot ->
                         slot := (name, vd) :: !slot; rec_needed := true
                       | None ->
                         List.iter
                           (fun (name, vd) -> Env.mark_value_used env name vd)
                           (get_ref slot);
                         used := true;
                         some_used := true
                    )
               )
               (Typedtree.pat_bound_idents pat);
             pat, Some slot
         ))
      attrs_list
      pat_list
  in
  let exp_list =
    List.map2
      (fun {pvb_expr=sexp; pvb_attributes; _} (pat, slot) ->
        let sexp =
          if rec_flag = Recursive then wrap_unpacks sexp unpacks else sexp in
        if is_recursive then current_slot := slot;
        match pat.pat_type.desc with
        | Tpoly (ty, tl) ->
            begin_def ();
            if !Clflags.principal then begin_def ();
            let vars, ty' = instance_poly ~keep_names:true true tl ty in
            if !Clflags.principal then begin
              end_def ();
              generalize_structure ty'
            end;
            let exp =
              Builtin_attributes.warning_scope pvb_attributes
                  (fun () -> type_expect exp_env sexp ty')
            in
            end_def ();
            check_univars env true "definition" exp pat.pat_type vars;
            {exp with exp_type = instance env exp.exp_type}
        | _ ->
            Builtin_attributes.warning_scope pvb_attributes (fun () ->
              type_expect exp_env sexp pat.pat_type))
      spat_sexp_list pat_slot_list in
  current_slot := None;
  if is_recursive && not !rec_needed
  && Warnings.is_active Warnings.Unused_rec_flag then begin
    let {pvb_pat; pvb_attributes} = List.hd spat_sexp_list in
    (* See PR#6677 *)
    Builtin_attributes.warning_scope ~ppwarning:false pvb_attributes
      (fun () ->
         Location.prerr_warning pvb_pat.ppat_loc Warnings.Unused_rec_flag
      )
  end;
  List.iter2
    (fun pat (attrs, exp) ->
       Builtin_attributes.warning_scope ~ppwarning:false attrs
         (fun () ->
            ignore(check_partial env pat.pat_type pat.pat_loc
                     [case pat exp])
         )
    )
    pat_list
    (List.map2 (fun (attrs, _) e -> attrs, e) spatl exp_list);
  end_def();
  List.iter2
    (fun pat exp ->
       if not (is_nonexpansive exp) then
         iter_pattern (fun pat -> generalize_expansive env pat.pat_type) pat)
    pat_list exp_list;
  List.iter
    (fun pat -> iter_pattern (fun pat -> generalize pat.pat_type) pat)
    pat_list;
  let l = List.combine pat_list exp_list in
  let l =
    List.map2
      (fun (p, e) pvb ->
        {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes;
         vb_loc=pvb.pvb_loc;
        })
      l spat_sexp_list
  in
  if is_recursive then
    List.iter 
      (fun {vb_pat=pat} -> match pat.pat_desc with
           Tpat_var _ -> ()
         | Tpat_alias ({pat_desc=Tpat_any}, _, _) -> ()
         | _ -> raise(Error(pat.pat_loc, env, Illegal_letrec_pat)))
      l;
  (l, new_env, unpacks)

(* Typing of toplevel bindings *)

let type_binding env rec_flag spat_sexp_list scope =
  Typetexp.reset_type_variables();
  let (pat_exp_list, new_env, _unpacks) =
    type_let
      ~check:(fun s -> Warnings.Unused_value_declaration s)
      ~check_strict:(fun s -> Warnings.Unused_value_declaration s)
      env rec_flag spat_sexp_list scope false
  in
  (pat_exp_list, new_env)

let type_let env rec_flag spat_sexp_list scope =
  let (pat_exp_list, new_env, _unpacks) =
    type_let env rec_flag spat_sexp_list scope false in
  (pat_exp_list, new_env)

(* Typing of toplevel expressions *)

let type_expression env sexp =
  Typetexp.reset_type_variables();
  begin_def();
  let exp = type_exp env sexp in
  end_def();
  if not (is_nonexpansive exp) then generalize_expansive env exp.exp_type;
  generalize exp.exp_type;
  match sexp.pexp_desc with
    Pexp_ident lid ->
      (* Special case for keeping type variables when looking-up a variable *)
      let (_path, desc) = Env.lookup_value lid.txt env in
      {exp with exp_type = desc.val_type}
  | _ -> exp

(* Error report *)

let spellcheck ppf unbound_name valid_names =
  Misc.did_you_mean ppf (fun () ->
    Misc.spellcheck valid_names unbound_name
  )

let spellcheck_idents ppf unbound valid_idents =
  spellcheck ppf (Ident.name unbound) (List.map Ident.name valid_idents)

open Format
open Printtyp

let report_error env ppf = function
  | Polymorphic_label lid ->
      fprintf ppf "@[The record field %a is polymorphic.@ %s@]"
        longident lid "You cannot instantiate it in a pattern."
  | Constructor_arity_mismatch(lid, expected, provided) ->
      fprintf ppf
       "@[The constructor %a@ expects %i argument(s),@ \
        but is applied here to %i argument(s)@]"
       longident lid expected provided
  | Label_mismatch(lid, trace) ->
      report_unification_error ppf env trace
        (function ppf ->
           fprintf ppf "The record field %a@ belongs to the type"
                   longident lid)
        (function ppf ->
           fprintf ppf "but is mixed here with fields of type")
  | Pattern_type_clash trace ->
      report_unification_error ppf env trace
        (function ppf ->
          fprintf ppf "This pattern matches values of type")
        (function ppf ->
          fprintf ppf "but a pattern was expected which matches values of type")
  | Or_pattern_type_clash (id, trace) ->
      report_unification_error ppf env trace
        (function ppf ->
          fprintf ppf "The variable %s on the left-hand side of this \
                       or-pattern has type" (Ident.name id))
        (function ppf ->
          fprintf ppf "but on the right-hand side it has type")
  | Multiply_bound_variable name ->
      fprintf ppf "Variable %s is bound several times in this matching" name
  | Orpat_vars (id, valid_idents) ->
      fprintf ppf "Variable %s must occur on both sides of this | pattern"
        (Ident.name id);
      spellcheck_idents ppf id valid_idents
  | Expr_type_clash trace ->
      report_unification_error ppf env trace
        (function ppf ->
           fprintf ppf "This expression has type")
        (function ppf ->
           fprintf ppf "but an expression was expected of type")
  | Apply_non_function typ ->
      reset_and_mark_loops typ;
      begin match (repr typ).desc with
        Tarrow _ ->
          fprintf ppf "@[<v>@[<2>This function has type@ %a@]"
            type_expr typ;
          fprintf ppf "@ @[It is applied to too many arguments;@ %s@]@]"
                      "maybe you forgot a `;'."
      | _ ->
          fprintf ppf "@[<v>@[<2>This expression has type@ %a@]@ %s@]"
            type_expr typ
            "This is not a function; it cannot be applied."
      end
  | Apply_wrong_label (l, ty) ->
      let print_label ppf = function
        | Nolabel -> fprintf ppf "without label"
        | l ->
            fprintf ppf "with label %s" (prefixed_label_name l)
      in
      reset_and_mark_loops ty;
      fprintf ppf
        "@[<v>@[<2>The function applied to this argument has type@ %a@]@.\
          This argument cannot be applied %a@]"
        type_expr ty print_label l
  | Label_multiply_defined s ->
      fprintf ppf "The record field label %s is defined several times" s
  | Label_missing labels ->
      let print_labels ppf =
        List.iter (fun lbl -> fprintf ppf "@ %s" (Ident.name lbl)) in
      fprintf ppf "@[<hov>Some record fields are undefined:%a@]"
        print_labels labels
  | Label_not_mutable lid ->
      fprintf ppf "The record field %a is not mutable" longident lid
  | Wrong_name (eorp, ty, kind, p, name, valid_names) ->
      reset_and_mark_loops ty;
      if Path.is_constructor_typath p then begin
        fprintf ppf "@[The field %s is not part of the record \
                     argument for the %a constructor@]"
          name
          path p;
      end else begin
      fprintf ppf "@[@[<2>%s type@ %a@]@ "
        eorp type_expr ty;
      fprintf ppf "The %s %s does not belong to type %a@]"
        (label_of_kind kind)
        name (*kind*) path p;
       end;
      spellcheck ppf name valid_names;
  | Name_type_mismatch (kind, lid, tp, tpl) ->
      let name = label_of_kind kind in
      report_ambiguous_type_error ppf env tp tpl
        (function ppf ->
           fprintf ppf "The %s %a@ belongs to the %s type"
             name longident lid kind)
        (function ppf ->
           fprintf ppf "The %s %a@ belongs to one of the following %s types:"
             name longident lid kind)
        (function ppf ->
           fprintf ppf "but a %s was expected belonging to the %s type"
             name kind)
  | Invalid_format msg ->
      fprintf ppf "%s" msg
  | Undefined_method (ty, me, valid_methods) ->
      reset_and_mark_loops ty;
      fprintf ppf
        "@[<v>@[This expression has type@;<1 2>%a@]@,\
         It has no method %s@]" type_expr ty me;
      begin match valid_methods with
        | None -> ()
        | Some valid_methods -> spellcheck ppf me valid_methods
      end
  | Undefined_inherited_method (me, valid_methods) ->
      fprintf ppf "This expression has no method %s" me;
      spellcheck ppf me valid_methods;
  | Virtual_class cl ->
      fprintf ppf "Cannot instantiate the virtual class %a"
        longident cl
  | Unbound_instance_variable (var, valid_vars) ->
      fprintf ppf "Unbound instance variable %s" var;
      spellcheck ppf var valid_vars;
  | Instance_variable_not_mutable (b, v) ->
      if b then
        fprintf ppf "The instance variable %s is not mutable" v
      else
        fprintf ppf "The value %s is not an instance variable" v
  | Not_subtype(tr1, tr2) ->
      report_subtyping_error ppf env tr1 "is not a subtype of" tr2
  | Outside_class ->
      fprintf ppf "This object duplication occurs outside a method definition"
  | Value_multiply_overridden v ->
      fprintf ppf "The instance variable %s is overridden several times" v
  | Coercion_failure (ty, ty', trace, b) ->
      report_unification_error ppf env trace
        (function ppf ->
           let ty, ty' = prepare_expansion (ty, ty') in
           fprintf ppf
             "This expression cannot be coerced to type@;<1 2>%a;@ it has type"
           (type_expansion ty) ty')
        (function ppf ->
           fprintf ppf "but is here used with type");
      if b then
        fprintf ppf ".@.@[<hov>%s@ %s@]"
          "This simple coercion was not fully general."
          "Consider using a double coercion."
  | Too_many_arguments (in_function, ty) ->
      reset_and_mark_loops ty;
      if in_function then begin
        fprintf ppf "This function expects too many arguments,@ ";
        fprintf ppf "it should have type@ %a"
          type_expr ty
      end else begin
        fprintf ppf "This expression should not be a function,@ ";
        fprintf ppf "the expected type is@ %a"
          type_expr ty
      end
  | Abstract_wrong_label (l, ty) ->
      let label_mark = function
        | Nolabel -> "but its first argument is not labelled"
        | l -> sprintf "but its first argument is labelled %s"
                       (prefixed_label_name l) in
      reset_and_mark_loops ty;
      fprintf ppf "@[<v>@[<2>This function should have type@ %a@]@,%s@]"
      type_expr ty (label_mark l)
  | Scoping_let_module(id, ty) ->
      reset_and_mark_loops ty;
      fprintf ppf
       "This `let module' expression has type@ %a@ " type_expr ty;
      fprintf ppf
       "In this type, the locally bound module name %s escapes its scope" id
  | Masked_instance_variable lid ->
      fprintf ppf
        "The instance variable %a@ \
         cannot be accessed from the definition of another instance variable"
        longident lid
  | Private_type ty ->
      fprintf ppf "Cannot create values of the private type %a" type_expr ty
  | Private_label (lid, ty) ->
      fprintf ppf "Cannot assign field %a of the private type %a"
        longident lid type_expr ty
  | Not_a_variant_type lid ->
      fprintf ppf "The type %a@ is not a variant type" longident lid
  | Incoherent_label_order ->
      fprintf ppf "This function is applied to arguments@ ";
      fprintf ppf "in an order different from other calls.@ ";
      fprintf ppf "This is only allowed when the real type is known."
  | Less_general (kind, trace) ->
      report_unification_error ppf env trace
        (fun ppf -> fprintf ppf "This %s has type" kind)
        (fun ppf -> fprintf ppf "which is less general than")
  | Modules_not_allowed ->
      fprintf ppf "Modules are not allowed in this pattern."
  | Cannot_infer_signature ->
      fprintf ppf
        "The signature for this packaged module couldn't be inferred."
  | Not_a_packed_module ty ->
      fprintf ppf
        "This expression is packed module, but the expected type is@ %a"
        type_expr ty
  | Recursive_local_constraint trace ->
      report_unification_error ppf env trace
        (function ppf ->
           fprintf ppf "Recursive local constraint when unifying")
        (function ppf ->
           fprintf ppf "with")
  | Unexpected_existential ->
      fprintf ppf
        "Unexpected existential"
  | Unqualified_gadt_pattern (tpath, name) ->
      fprintf ppf "@[The GADT constructor %s of type %a@ %s.@]"
        name path tpath
        "must be qualified in this pattern"
  | Invalid_interval ->
      fprintf ppf "@[Only character intervals are supported in patterns.@]"
  | Invalid_for_loop_index ->
      fprintf ppf
        "@[Invalid for-loop index: only variables and _ are allowed.@]"
  | No_value_clauses ->
      fprintf ppf
        "None of the patterns in this 'match' expression match values."
  | Exception_pattern_below_toplevel ->
      fprintf ppf
        "@[Exception patterns must be at the top level of a match case.@]"
  | Inlined_record_escape ->
      fprintf ppf
        "@[This form is not allowed as the type of the inlined record could \
         escape.@]"
  | Inlined_record_expected ->
      fprintf ppf
        "@[This constructor expects an inlined record argument.@]"
  | Unrefuted_pattern pat ->
      fprintf ppf
        "@[%s@ %s@ %a@]"
        "This match case could not be refuted."
        "Here is an example of a value that would reach it:"
        Parmatch.top_pretty pat
  | Invalid_extension_constructor_payload ->
      fprintf ppf
        "Invalid [%%extension_constructor] payload, a constructor is expected."
  | Not_an_extension_constructor ->
      fprintf ppf
        "This constructor is not an extension constructor."
  | Literal_overflow ty ->
      fprintf ppf "Integer literal exceeds the range of representable \
                   integers of type %s" ty
  | Unknown_literal (n, m) ->
      fprintf ppf "Unknown modifier '%c' for literal %s%c" m n m
  | Illegal_letrec_pat ->
      fprintf ppf
        "Only variables are allowed as left-hand side of `let rec'"
  | Illegal_letrec_expr ->
      fprintf ppf
        "This kind of expression is not allowed as right-hand side of `let rec'"
  | Illegal_class_expr ->
      fprintf ppf "This kind of recursive class expression is not allowed"


let super_report_error_no_wrap_printing_env = report_error


let report_error env ppf err =
  wrap_printing_env env (fun () -> report_error env ppf err)

let () =
  Location.register_error_of_exn
    (function
      | Error (loc, env, err) ->
        Some (Location.error_of_printer loc (report_error env) err)
      | Error_forward err ->
        Some err
      | _ ->
        None
    )

let () =
  Env.add_delayed_check_forward := add_delayed_check

(* drop ?recarg argument from the external API *)
let type_expect ?in_function env e ty = type_expect ?in_function env e ty
let type_exp env e = type_exp env e
let type_argument env e t1 t2 = type_argument env e t1 t2

end
module Typeclass : sig 
#1 "typeclass.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Asttypes
open Types
open Format

type 'a class_info = {
  cls_id : Ident.t;
  cls_id_loc : string loc;
  cls_decl : class_declaration;
  cls_ty_id : Ident.t;
  cls_ty_decl : class_type_declaration;
  cls_obj_id : Ident.t;
  cls_obj_abbr : type_declaration;
  cls_typesharp_id : Ident.t;
  cls_abbr : type_declaration;
  cls_arity : int;
  cls_pub_methods : string list;
  cls_info : 'a;
}

type class_type_info = {
  clsty_ty_id : Ident.t;
  clsty_id_loc : string loc;
  clsty_ty_decl : class_type_declaration;
  clsty_obj_id : Ident.t;
  clsty_obj_abbr : type_declaration;
  clsty_typesharp_id : Ident.t;
  clsty_abbr : type_declaration;
  clsty_info : Typedtree.class_type_declaration;
}

val class_declarations:
  Env.t -> Parsetree.class_declaration list ->
  Typedtree.class_declaration class_info list * Env.t

(*
and class_declaration =
  (class_expr, Types.class_declaration) class_infos
*)

val class_descriptions:
  Env.t -> Parsetree.class_description list ->
  Typedtree.class_description class_info list * Env.t

(*
and class_description =
  (class_type, unit) class_infos
*)

val class_type_declarations:
  Env.t -> Parsetree.class_description list -> class_type_info list * Env.t

(*
and class_type_declaration =
  (class_type, Types.class_type_declaration) class_infos
*)

val approx_class_declarations:
  Env.t -> Parsetree.class_description list -> class_type_info list

val virtual_methods: Types.class_signature -> label list

(*
val type_classes :
           bool ->
           ('a -> Types.type_expr) ->
           (Env.t -> 'a -> 'b * Types.class_type) ->
           Env.t ->
           'a Parsetree.class_infos list ->
  (  Ident.t * Types.class_declaration *
     Ident.t * Types.class_type_declaration *
     Ident.t * Types.type_declaration *
     Ident.t * Types.type_declaration *
     int * string list * 'b * 'b Typedtree.class_infos)
           list * Env.t
*)

type error =
    Unconsistent_constraint of (type_expr * type_expr) list
  | Field_type_mismatch of string * string * (type_expr * type_expr) list
  | Structure_expected of class_type
  | Cannot_apply of class_type
  | Apply_wrong_label of arg_label
  | Pattern_type_clash of type_expr
  | Repeated_parameter
  | Unbound_class_2 of Longident.t
  | Unbound_class_type_2 of Longident.t
  | Abbrev_type_clash of type_expr * type_expr * type_expr
  | Constructor_type_mismatch of string * (type_expr * type_expr) list
  | Virtual_class of bool * bool * string list * string list
  | Parameter_arity_mismatch of Longident.t * int * int
  | Parameter_mismatch of (type_expr * type_expr) list
  | Bad_parameters of Ident.t * type_expr * type_expr
  | Class_match_failure of Ctype.class_match_failure list
  | Unbound_val of string
  | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
  | Make_nongen_seltype of type_expr
  | Non_generalizable_class of Ident.t * Types.class_declaration
  | Cannot_coerce_self of type_expr
  | Non_collapsable_conjunction of
      Ident.t * Types.class_declaration * (type_expr * type_expr) list
  | Final_self_clash of (type_expr * type_expr) list
  | Mutability_mismatch of string * mutable_flag
  | No_overriding of string * string
  | Duplicate of string * string

exception Error of Location.t * Env.t * error
exception Error_forward of Location.error

val report_error : Env.t -> formatter -> error -> unit

end = struct
#1 "typeclass.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Parsetree
open Asttypes
open Path
open Types
open Typecore
open Typetexp
open Format

type 'a class_info = {
  cls_id : Ident.t;
  cls_id_loc : string loc;
  cls_decl : class_declaration;
  cls_ty_id : Ident.t;
  cls_ty_decl : class_type_declaration;
  cls_obj_id : Ident.t;
  cls_obj_abbr : type_declaration;
  cls_typesharp_id : Ident.t;
  cls_abbr : type_declaration;
  cls_arity : int;
  cls_pub_methods : string list;
  cls_info : 'a;
}

type class_type_info = {
  clsty_ty_id : Ident.t;
  clsty_id_loc : string loc;
  clsty_ty_decl : class_type_declaration;
  clsty_obj_id : Ident.t;
  clsty_obj_abbr : type_declaration;
  clsty_typesharp_id : Ident.t;
  clsty_abbr : type_declaration;
  clsty_info : Typedtree.class_type_declaration;
}

type error =
    Unconsistent_constraint of (type_expr * type_expr) list
  | Field_type_mismatch of string * string * (type_expr * type_expr) list
  | Structure_expected of class_type
  | Cannot_apply of class_type
  | Apply_wrong_label of arg_label
  | Pattern_type_clash of type_expr
  | Repeated_parameter
  | Unbound_class_2 of Longident.t
  | Unbound_class_type_2 of Longident.t
  | Abbrev_type_clash of type_expr * type_expr * type_expr
  | Constructor_type_mismatch of string * (type_expr * type_expr) list
  | Virtual_class of bool * bool * string list * string list
  | Parameter_arity_mismatch of Longident.t * int * int
  | Parameter_mismatch of (type_expr * type_expr) list
  | Bad_parameters of Ident.t * type_expr * type_expr
  | Class_match_failure of Ctype.class_match_failure list
  | Unbound_val of string
  | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
  | Make_nongen_seltype of type_expr
  | Non_generalizable_class of Ident.t * Types.class_declaration
  | Cannot_coerce_self of type_expr
  | Non_collapsable_conjunction of
      Ident.t * Types.class_declaration * (type_expr * type_expr) list
  | Final_self_clash of (type_expr * type_expr) list
  | Mutability_mismatch of string * mutable_flag
  | No_overriding of string * string
  | Duplicate of string * string

exception Error of Location.t * Env.t * error
exception Error_forward of Location.error

open Typedtree

let ctyp desc typ env loc =
  { ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env;
    ctyp_attributes = [] }

                       (**********************)
                       (*  Useful constants  *)
                       (**********************)


(*
   Self type have a dummy private method, thus preventing it to become
   closed.
*)
let dummy_method = Btype.dummy_method

(*
   Path associated to the temporary class type of a class being typed
   (its constructor is not available).
*)
let unbound_class = Path.Pident (Ident.create "*undef*")


                (************************************)
                (*  Some operations on class types  *)
                (************************************)


(* Fully expand the head of a class type *)
let rec scrape_class_type =
  function
    Cty_constr (_, _, cty) -> scrape_class_type cty
  | cty                     -> cty

(* Generalize a class type *)
let rec generalize_class_type gen =
  function
    Cty_constr (_, params, cty) ->
      List.iter gen params;
      generalize_class_type gen cty
  | Cty_signature {csig_self = sty; csig_vars = vars; csig_inher = inher} ->
      gen sty;
      Vars.iter (fun _ (_, _, ty) -> gen ty) vars;
      List.iter (fun (_,tl) -> List.iter gen tl) inher
  | Cty_arrow (_, ty, cty) ->
      gen ty;
      generalize_class_type gen cty

let generalize_class_type vars =
  let gen = if vars then Ctype.generalize else Ctype.generalize_structure in
  generalize_class_type gen

(* Return the virtual methods of a class type *)
let virtual_methods sign =
  let (fields, _) =
    Ctype.flatten_fields (Ctype.object_fields sign.Types.csig_self)
  in
  List.fold_left
    (fun virt (lab, _, _) ->
       if lab = dummy_method then virt else
       if Concr.mem lab sign.csig_concr then virt else
       lab::virt)
    [] fields

(* Return the constructor type associated to a class type *)
let rec constructor_type constr cty =
  match cty with
    Cty_constr (_, _, cty) ->
      constructor_type constr cty
  | Cty_signature _ ->
      constr
  | Cty_arrow (l, ty, cty) ->
      Ctype.newty (Tarrow (l, ty, constructor_type constr cty, Cok))

let rec class_body cty =
  match cty with
    Cty_constr _ ->
      cty (* Only class bodies can be abbreviated *)
  | Cty_signature _ ->
      cty
  | Cty_arrow (_, _, cty) ->
      class_body cty

let extract_constraints cty =
  let sign = Ctype.signature_of_class_type cty in
  (Vars.fold (fun lab _ vars -> lab :: vars) sign.csig_vars [],
   begin let (fields, _) =
     Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
   in
   List.fold_left
     (fun meths (lab, _, _) ->
        if lab = dummy_method then meths else lab::meths)
     [] fields
   end,
   sign.csig_concr)

let rec abbreviate_class_type path params cty =
  match cty with
    Cty_constr (_, _, _) | Cty_signature _ ->
      Cty_constr (path, params, cty)
  | Cty_arrow (l, ty, cty) ->
      Cty_arrow (l, ty, abbreviate_class_type path params cty)

(* Check that all type variables are generalizable *)
(* Use Env.empty to prevent expansion of recursively defined object types;
   cf. typing-poly/poly.ml *)
let rec closed_class_type =
  function
    Cty_constr (_, params, _) ->
      List.for_all (Ctype.closed_schema Env.empty) params
  | Cty_signature sign ->
      Ctype.closed_schema Env.empty sign.csig_self
        &&
      Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema Env.empty ty && cc)
        sign.csig_vars
        true
  | Cty_arrow (_, ty, cty) ->
      Ctype.closed_schema Env.empty ty
        &&
      closed_class_type cty

let closed_class cty =
  List.for_all (Ctype.closed_schema Env.empty) cty.cty_params
    &&
  closed_class_type cty.cty_type

let rec limited_generalize rv =
  function
    Cty_constr (_path, params, cty) ->
      List.iter (Ctype.limited_generalize rv) params;
      limited_generalize rv cty
  | Cty_signature sign ->
      Ctype.limited_generalize rv sign.csig_self;
      Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty)
        sign.csig_vars;
      List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl)
        sign.csig_inher
  | Cty_arrow (_, ty, cty) ->
      Ctype.limited_generalize rv ty;
      limited_generalize rv cty

(* Record a class type *)
let rc node =
  Cmt_format.add_saved_type (Cmt_format.Partial_class_expr node);
  Stypes.record (Stypes.Ti_class node); (* moved to genannot *)
  node


                (***********************************)
                (*  Primitives for typing classes  *)
                (***********************************)


(* Enter a value in the method environment only *)
let enter_met_env ?check loc lab kind ty val_env met_env par_env =
  let (id, val_env) =
    Env.enter_value lab {val_type = ty; val_kind = Val_unbound;
                         val_attributes = [];
                         Types.val_loc = loc} val_env
  in
  (id, val_env,
   Env.add_value ?check id {val_type = ty; val_kind = kind;
                            val_attributes = [];
                            Types.val_loc = loc} met_env,
   Env.add_value id {val_type = ty; val_kind = Val_unbound;
                     val_attributes = [];
                     Types.val_loc = loc} par_env)

(* Enter an instance variable in the environment *)
let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc =
  let instance = Ctype.instance val_env in
  let (id, virt) =
    try
      let (id, mut', virt', ty') = Vars.find lab !vars in
      if mut' <> mut then
        raise (Error(loc, val_env, Mutability_mismatch(lab, mut)));
      Ctype.unify val_env (instance ty) (instance ty');
      (if not inh then Some id else None),
      (if virt' = Concrete then virt' else virt)
    with
      Ctype.Unify tr ->
        raise (Error(loc, val_env,
                     Field_type_mismatch("instance variable", lab, tr)))
    | Not_found -> None, virt
  in
  let (id, _, _, _) as result =
    match id with Some id -> (id, val_env, met_env, par_env)
    | None ->
        enter_met_env Location.none lab (Val_ivar (mut, cl_num))
          ty val_env met_env par_env
  in
  vars := Vars.add lab (id, mut, virt, ty) !vars;
  result

let concr_vals vars =
  Vars.fold
    (fun id (_, vf, _) s -> if vf = Virtual then s else Concr.add id s)
    vars Concr.empty

let inheritance self_type env ovf concr_meths warn_vals loc parent =
  match scrape_class_type parent with
    Cty_signature cl_sig ->

      (* Methods *)
      begin try
        Ctype.unify env self_type cl_sig.csig_self
      with Ctype.Unify trace ->
        match trace with
          _::_::_::({desc = Tfield(n, _, _, _)}, _)::rem ->
            raise(Error(loc, env, Field_type_mismatch ("method", n, rem)))
        | _ ->
            assert false
      end;

      (* Overriding *)
      let over_meths = Concr.inter cl_sig.csig_concr concr_meths in
      let concr_vals = concr_vals cl_sig.csig_vars in
      let over_vals = Concr.inter concr_vals warn_vals in
      begin match ovf with
        Some Fresh ->
          let cname =
            match parent with
              Cty_constr (p, _, _) -> Path.name p
            | _ -> "inherited"
          in
          if not (Concr.is_empty over_meths) then
            Location.prerr_warning loc
              (Warnings.Method_override (cname :: Concr.elements over_meths));
          if not (Concr.is_empty over_vals) then
            Location.prerr_warning loc
              (Warnings.Instance_variable_override
                 (cname :: Concr.elements over_vals));
      | Some Override
        when Concr.is_empty over_meths && Concr.is_empty over_vals ->
        raise (Error(loc, env, No_overriding ("","")))
      | _ -> ()
      end;

      let concr_meths = Concr.union cl_sig.csig_concr concr_meths
      and warn_vals = Concr.union concr_vals warn_vals in

      (cl_sig, concr_meths, warn_vals)

  | _ ->
      raise(Error(loc, env, Structure_expected parent))

let virtual_method val_env meths self_type lab priv sty loc =
  let (_, ty') =
     Ctype.filter_self_method val_env lab priv meths self_type
  in
  let sty = Ast_helper.Typ.force_poly sty in
  let cty = transl_simple_type val_env false sty in
  let ty = cty.ctyp_type in
  begin
    try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
        raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace)));
  end;
  cty

let delayed_meth_specs = ref []

let declare_method val_env meths self_type lab priv sty loc =
  let (_, ty') =
     Ctype.filter_self_method val_env lab priv meths self_type
  in
  let unif ty =
    try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
      raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace)))
  in
  let sty = Ast_helper.Typ.force_poly sty in
  match sty.ptyp_desc, priv with
    Ptyp_poly ([],sty'), Public ->
(* TODO: we moved the [transl_simple_type_univars] outside of the lazy,
so that we can get an immediate value. Is that correct ? Ask Jacques. *)
      let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) val_env loc in
      delayed_meth_specs :=
      Warnings.mk_lazy (fun () ->
            let cty = transl_simple_type_univars val_env sty' in
            let ty = cty.ctyp_type in
            unif ty;
            returned_cty.ctyp_desc <- Ttyp_poly ([], cty);
            returned_cty.ctyp_type <- ty;
          ) ::
      !delayed_meth_specs;
      returned_cty
  | _ ->
      let cty = transl_simple_type val_env false sty in
      let ty = cty.ctyp_type in
      unif ty;
      cty

let type_constraint val_env sty sty' loc =
  let cty  = transl_simple_type val_env false sty in
  let ty = cty.ctyp_type in
  let cty' = transl_simple_type val_env false sty' in
  let ty' = cty'.ctyp_type in
  begin
    try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
        raise(Error(loc, val_env, Unconsistent_constraint trace));
  end;
  (cty, cty')

let make_method loc cl_num expr =
  let open Ast_helper in
  let mkid s = mkloc s loc in
  Exp.fun_ ~loc:expr.pexp_loc Nolabel None
    (Pat.alias ~loc (Pat.var ~loc (mkid "self-*")) (mkid ("self-" ^ cl_num)))
    expr

(*******************************)

let add_val lab (mut, virt, ty) val_sig =
  let virt =
    try
      let (_mut', virt', _ty') = Vars.find lab val_sig in
      if virt' = Concrete then virt' else virt
    with Not_found -> virt
  in
  Vars.add lab (mut, virt, ty) val_sig

let rec class_type_field env self_type meths arg ctf =
  Builtin_attributes.warning_scope ctf.pctf_attributes
    (fun () -> class_type_field_aux env self_type meths arg ctf)

and class_type_field_aux env self_type meths
    (fields, val_sig, concr_meths, inher) ctf =

  let loc = ctf.pctf_loc in
  let mkctf desc =
    { ctf_desc = desc; ctf_loc = loc; ctf_attributes = ctf.pctf_attributes }
  in
  match ctf.pctf_desc with
    Pctf_inherit sparent ->
      let parent = class_type env sparent in
      let inher =
        match parent.cltyp_type with
          Cty_constr (p, tl, _) -> (p, tl) :: inher
        | _ -> inher
      in
      let (cl_sig, concr_meths, _) =
        inheritance self_type env None concr_meths Concr.empty sparent.pcty_loc
          parent.cltyp_type
      in
      let val_sig =
        Vars.fold add_val cl_sig.csig_vars val_sig in
      (mkctf (Tctf_inherit parent) :: fields,
       val_sig, concr_meths, inher)

  | Pctf_val ({txt=lab}, mut, virt, sty) ->
      let cty = transl_simple_type env false sty in
      let ty = cty.ctyp_type in
      (mkctf (Tctf_val (lab, mut, virt, cty)) :: fields,
      add_val lab (mut, virt, ty) val_sig, concr_meths, inher)

  | Pctf_method ({txt=lab}, priv, virt, sty)  ->
      let cty =
        declare_method env meths self_type lab priv sty  ctf.pctf_loc in
      let concr_meths =
        match virt with
        | Concrete -> Concr.add lab concr_meths
        | Virtual -> concr_meths
      in
      (mkctf (Tctf_method (lab, priv, virt, cty)) :: fields,
        val_sig, concr_meths, inher)

  | Pctf_constraint (sty, sty') ->
      let (cty, cty') = type_constraint env sty sty'  ctf.pctf_loc in
      (mkctf (Tctf_constraint (cty, cty')) :: fields,
        val_sig, concr_meths, inher)

  | Pctf_attribute x ->
      Builtin_attributes.warning_attribute x;
      (mkctf (Tctf_attribute x) :: fields,
        val_sig, concr_meths, inher)

  | Pctf_extension ext ->
      raise (Error_forward (Builtin_attributes.error_of_extension ext))

and class_signature env {pcsig_self=sty; pcsig_fields=sign} =
  let meths = ref Meths.empty in
  let self_cty = transl_simple_type env false sty in
  let self_cty = { self_cty with
    ctyp_type = Ctype.expand_head env self_cty.ctyp_type } in
  let self_type =  self_cty.ctyp_type in

  (* Check that the binder is a correct type, and introduce a dummy
     method preventing self type from being closed. *)
  let dummy_obj = Ctype.newvar () in
  Ctype.unify env (Ctype.filter_method env dummy_method Private dummy_obj)
    (Ctype.newty (Ttuple []));
  begin try
    Ctype.unify env self_type dummy_obj
  with Ctype.Unify _ ->
    raise(Error(sty.ptyp_loc, env, Pattern_type_clash self_type))
  end;

  (* Class type fields *)
  let (rev_fields, val_sig, concr_meths, inher) =
    Builtin_attributes.warning_scope []
      (fun () ->
         List.fold_left (class_type_field env self_type meths)
           ([], Vars.empty, Concr.empty, [])
           sign
      )
  in
  let cty =   {csig_self = self_type;
   csig_vars = val_sig;
   csig_concr = concr_meths;
   csig_inher = inher}
  in
  { csig_self = self_cty;
    csig_fields = List.rev rev_fields;
    csig_type = cty;
  }

and class_type env scty =
  Builtin_attributes.warning_scope scty.pcty_attributes
    (fun () -> class_type_aux env scty)

and class_type_aux env scty =
  let cltyp desc typ =
    {
     cltyp_desc = desc;
     cltyp_type = typ;
     cltyp_loc = scty.pcty_loc;
     cltyp_env = env;
     cltyp_attributes = scty.pcty_attributes;
    }
  in
  match scty.pcty_desc with
    Pcty_constr (lid, styl) ->
      let (path, decl) = Typetexp.find_class_type env scty.pcty_loc lid.txt in
      if Path.same decl.clty_path unbound_class then
        raise(Error(scty.pcty_loc, env, Unbound_class_type_2 lid.txt));
      let (params, clty) =
        Ctype.instance_class decl.clty_params decl.clty_type
      in
      if List.length params <> List.length styl then
        raise(Error(scty.pcty_loc, env,
                    Parameter_arity_mismatch (lid.txt, List.length params,
                                                   List.length styl)));
      let ctys = List.map2
        (fun sty ty ->
          let cty' = transl_simple_type env false sty in
          let ty' = cty'.ctyp_type in
          begin
           try Ctype.unify env ty' ty with Ctype.Unify trace ->
                  raise(Error(sty.ptyp_loc, env, Parameter_mismatch trace))
            end;
            cty'
        )       styl params
      in
      let typ = Cty_constr (path, params, clty) in
      cltyp (Tcty_constr ( path, lid , ctys)) typ

  | Pcty_signature pcsig ->
      let clsig = class_signature env pcsig in
      let typ = Cty_signature clsig.csig_type in
      cltyp (Tcty_signature clsig) typ

  | Pcty_arrow (l, sty, scty) ->
      let cty = transl_simple_type env false sty in
      let ty = cty.ctyp_type in
      let ty =
        if Btype.is_optional l
        then Ctype.newty (Tconstr(Predef.path_option,[ty], ref Mnil))
        else ty in
      let clty = class_type env scty in
      let typ = Cty_arrow (l, ty, clty.cltyp_type) in
      cltyp (Tcty_arrow (l, cty, clty)) typ

  | Pcty_open (ovf, lid, e) ->
      let (path, newenv) = !Typecore.type_open ovf env scty.pcty_loc lid in
      let clty = class_type newenv e in
      cltyp (Tcty_open (ovf, path, lid, newenv, clty)) clty.cltyp_type

  | Pcty_extension ext ->
      raise (Error_forward (Builtin_attributes.error_of_extension ext))

let class_type env scty =
  delayed_meth_specs := [];
  let cty = class_type env scty in
  List.iter Lazy.force (List.rev !delayed_meth_specs);
  delayed_meth_specs := [];
  cty

(*******************************)

let rec class_field self_loc cl_num self_type meths vars arg cf =
  Builtin_attributes.warning_scope cf.pcf_attributes
    (fun () -> class_field_aux self_loc cl_num self_type meths vars arg cf)

and class_field_aux self_loc cl_num self_type meths vars
    (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher,
     local_meths, local_vals) cf =
  let loc = cf.pcf_loc in
  let mkcf desc =
    { cf_desc = desc; cf_loc = loc; cf_attributes = cf.pcf_attributes }
  in
  match cf.pcf_desc with
    Pcf_inherit (ovf, sparent, super) ->
      let parent = class_expr cl_num val_env par_env sparent in
      let inher =
        match parent.cl_type with
          Cty_constr (p, tl, _) -> (p, tl) :: inher
        | _ -> inher
      in
      let (cl_sig, concr_meths, warn_vals) =
        inheritance self_type val_env (Some ovf) concr_meths warn_vals
          sparent.pcl_loc parent.cl_type
      in
      (* Variables *)
      let (val_env, met_env, par_env, inh_vars) =
        Vars.fold
          (fun lab info (val_env, met_env, par_env, inh_vars) ->
             let mut, vr, ty = info in
             let (id, val_env, met_env, par_env) =
               enter_val cl_num vars true lab mut vr ty val_env met_env par_env
                 sparent.pcl_loc
             in
             (val_env, met_env, par_env, (lab, id) :: inh_vars))
          cl_sig.csig_vars (val_env, met_env, par_env, [])
      in
      (* Inherited concrete methods *)
      let inh_meths =
        Concr.fold (fun lab rem -> (lab, Ident.create lab)::rem)
          cl_sig.csig_concr []
      in
      (* Super *)
      let (val_env, met_env, par_env,super) =
        match super with
          None ->
            (val_env, met_env, par_env,None)
        | Some {txt=name} ->
            let (_id, val_env, met_env, par_env) =
              enter_met_env ~check:(fun s -> Warnings.Unused_ancestor s)
                sparent.pcl_loc name (Val_anc (inh_meths, cl_num)) self_type
                val_env met_env par_env
            in
            (val_env, met_env, par_env,Some name)
      in
      (val_env, met_env, par_env,
       lazy (mkcf (Tcf_inherit (ovf, parent, super, inh_vars, inh_meths)))
       :: fields,
       concr_meths, warn_vals, inher, local_meths, local_vals)

  | Pcf_val (lab, mut, Cfk_virtual styp) ->
      if !Clflags.principal then Ctype.begin_def ();
      let cty = Typetexp.transl_simple_type val_env false styp in
      let ty = cty.ctyp_type in
      if !Clflags.principal then begin
        Ctype.end_def ();
        Ctype.generalize_structure ty
      end;
      let (id, val_env, met_env', par_env) =
        enter_val cl_num vars false lab.txt mut Virtual ty
          val_env met_env par_env loc
      in
      (val_env, met_env', par_env,
       lazy (mkcf (Tcf_val (lab, mut, id, Tcfk_virtual cty,
                            met_env == met_env')))
             :: fields,
             concr_meths, warn_vals, inher, local_meths, local_vals)

  | Pcf_val (lab, mut, Cfk_concrete (ovf, sexp)) ->
      if Concr.mem lab.txt local_vals then
        raise(Error(loc, val_env, Duplicate ("instance variable", lab.txt)));
      if Concr.mem lab.txt warn_vals then begin
        if ovf = Fresh then
          Location.prerr_warning lab.loc
            (Warnings.Instance_variable_override[lab.txt])
      end else begin
        if ovf = Override then
          raise(Error(loc, val_env,
                      No_overriding ("instance variable", lab.txt)))
      end;
      if !Clflags.principal then Ctype.begin_def ();
      let exp =
        try type_exp val_env sexp with Ctype.Unify [(ty, _)] ->
          raise(Error(loc, val_env, Make_nongen_seltype ty))
      in
      if !Clflags.principal then begin
        Ctype.end_def ();
        Ctype.generalize_structure exp.exp_type
       end;
      let (id, val_env, met_env', par_env) =
        enter_val cl_num vars false lab.txt mut Concrete exp.exp_type
          val_env met_env par_env loc
      in
      (val_env, met_env', par_env,
       lazy (mkcf (Tcf_val (lab, mut, id,
                            Tcfk_concrete (ovf, exp), met_env == met_env')))
       :: fields,
       concr_meths, Concr.add lab.txt warn_vals, inher, local_meths,
       Concr.add lab.txt local_vals)

  | Pcf_method (lab, priv, Cfk_virtual sty) ->
      let cty = virtual_method val_env meths self_type lab.txt priv sty loc in
      (val_env, met_env, par_env,
        lazy (mkcf(Tcf_method (lab, priv, Tcfk_virtual cty)))
       ::fields,
        concr_meths, warn_vals, inher, local_meths, local_vals)

  | Pcf_method (lab, priv, Cfk_concrete (ovf, expr))  ->
      let expr =
        match expr.pexp_desc with
        | Pexp_poly _ -> expr
        | _ -> Ast_helper.Exp.poly ~loc:expr.pexp_loc expr None
      in
      if Concr.mem lab.txt local_meths then
        raise(Error(loc, val_env, Duplicate ("method", lab.txt)));
      if Concr.mem lab.txt concr_meths then begin
        if ovf = Fresh then
          Location.prerr_warning loc (Warnings.Method_override [lab.txt])
      end else begin
        if ovf = Override then
          raise(Error(loc, val_env, No_overriding("method", lab.txt)))
      end;
      let (_, ty) =
        Ctype.filter_self_method val_env lab.txt priv meths self_type
      in
      begin try match expr.pexp_desc with
        Pexp_poly (sbody, sty) ->
          begin match sty with None -> ()
                | Some sty ->
                    let sty = Ast_helper.Typ.force_poly sty in
                    let cty' = Typetexp.transl_simple_type val_env false sty in
                    let ty' = cty'.ctyp_type in
              Ctype.unify val_env ty' ty
          end;
          begin match (Ctype.repr ty).desc with
            Tvar _ ->
              let ty' = Ctype.newvar () in
              Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty;
              Ctype.unify val_env (type_approx val_env sbody) ty'
          | Tpoly (ty1, tl) ->
              let _, ty1' = Ctype.instance_poly false tl ty1 in
              let ty2 = type_approx val_env sbody in
              Ctype.unify val_env ty2 ty1'
          | _ -> assert false
          end
      | _ -> assert false
      with Ctype.Unify trace ->
        raise(Error(loc, val_env,
                    Field_type_mismatch ("method", lab.txt, trace)))
      end;
      let meth_expr = make_method self_loc cl_num expr in
      (* backup variables for Pexp_override *)
      let vars_local = !vars in

      let field =
        Warnings.mk_lazy
          (fun () ->
             (* Read the generalized type *)
             let (_, ty) = Meths.find lab.txt !meths in
             let meth_type =
               Btype.newgenty (Tarrow(Nolabel, self_type, ty, Cok)) in
             Ctype.raise_nongen_level ();
             vars := vars_local;
             let texp = type_expect met_env meth_expr meth_type in
             Ctype.end_def ();
             mkcf (Tcf_method (lab, priv, Tcfk_concrete (ovf, texp)))
          )
      in
      (val_env, met_env, par_env, field::fields,
       Concr.add lab.txt concr_meths, warn_vals, inher,
       Concr.add lab.txt local_meths, local_vals)

  | Pcf_constraint (sty, sty') ->
      let (cty, cty') = type_constraint val_env sty sty' loc in
      (val_env, met_env, par_env,
        lazy (mkcf (Tcf_constraint (cty, cty'))) :: fields,
        concr_meths, warn_vals, inher, local_meths, local_vals)

  | Pcf_initializer expr ->
      let expr = make_method self_loc cl_num expr in
      let vars_local = !vars in
      let field =
        lazy begin
          Ctype.raise_nongen_level ();
          let meth_type =
            Ctype.newty
              (Tarrow (Nolabel, self_type,
                       Ctype.instance_def Predef.type_unit, Cok)) in
          vars := vars_local;
          let texp = type_expect met_env expr meth_type in
          Ctype.end_def ();
          mkcf (Tcf_initializer texp)
        end in
      (val_env, met_env, par_env, field::fields, concr_meths, warn_vals,
       inher, local_meths, local_vals)
  | Pcf_attribute x ->
      Builtin_attributes.warning_attribute x;
      (val_env, met_env, par_env,
        lazy (mkcf (Tcf_attribute x)) :: fields,
        concr_meths, warn_vals, inher, local_meths, local_vals)
  | Pcf_extension ext ->
      raise (Error_forward (Builtin_attributes.error_of_extension ext))

and class_structure cl_num final val_env met_env loc
  { pcstr_self = spat; pcstr_fields = str } =
  (* Environment for substructures *)
  let par_env = met_env in

  (* Location of self. Used for locations of self arguments *)
  let self_loc = {spat.ppat_loc with Location.loc_ghost = true} in

  (* Self type, with a dummy method preventing it from being closed/escaped. *)
  let self_type = Ctype.newvar () in
  Ctype.unify val_env
    (Ctype.filter_method val_env dummy_method Private self_type)
    (Ctype.newty (Ttuple []));

  (* Private self is used for private method calls *)
  let private_self = if final then Ctype.newvar () else self_type in

  (* Self binder *)
  let (pat, meths, vars, val_env, meth_env, par_env) =
    type_self_pattern cl_num private_self val_env met_env par_env spat
  in
  let public_self = pat.pat_type in

  (* Check that the binder has a correct type *)
  let ty =
    if final then Ctype.newty (Tobject (Ctype.newvar(), ref None))
    else self_type in
  begin try Ctype.unify val_env public_self ty with
    Ctype.Unify _ ->
      raise(Error(spat.ppat_loc, val_env, Pattern_type_clash public_self))
  end;
  let get_methods ty =
    (fst (Ctype.flatten_fields
            (Ctype.object_fields (Ctype.expand_head val_env ty)))) in
  if final then begin
    (* Copy known information to still empty self_type *)
    List.iter
      (fun (lab,kind,ty) ->
        let k =
          if Btype.field_kind_repr kind = Fpresent then Public else Private in
        try Ctype.unify val_env ty
            (Ctype.filter_method val_env lab k self_type)
        with _ -> assert false)
      (get_methods public_self)
  end;

  (* Typing of class fields *)
  let (_, _, _, fields, concr_meths, _, inher, _local_meths, _local_vals) =
    Builtin_attributes.warning_scope []
      (fun () ->
         List.fold_left (class_field self_loc cl_num self_type meths vars)
           (val_env, meth_env, par_env, [], Concr.empty, Concr.empty, [],
            Concr.empty, Concr.empty)
           str
      )
  in
  Ctype.unify val_env self_type (Ctype.newvar ());
  let sign =
    {csig_self = public_self;
     csig_vars = Vars.map (fun (_id, mut, vr, ty) -> (mut, vr, ty)) !vars;
     csig_concr = concr_meths;
      csig_inher = inher} in
  let methods = get_methods self_type in
  let priv_meths =
    List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind <> Fpresent)
      methods in
  if final then begin
    (* Unify private_self and a copy of self_type. self_type will not
       be modified after this point *)
    Ctype.close_object self_type;
    let mets = virtual_methods {sign with csig_self = self_type} in
    let vals =
      Vars.fold
        (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l)
        sign.csig_vars [] in
    if mets <> [] || vals <> [] then
      raise(Error(loc, val_env, Virtual_class(true, final, mets, vals)));
    let self_methods =
      List.fold_right
        (fun (lab,kind,ty) rem ->
          if lab = dummy_method then
            (* allow public self and private self to be unified *)
            match Btype.field_kind_repr kind with
              Fvar r -> Btype.set_kind r Fabsent; rem
            | _ -> rem
          else
            Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem)))
        methods (Ctype.newty Tnil) in
    begin try
      Ctype.unify val_env private_self
        (Ctype.newty (Tobject(self_methods, ref None)));
      Ctype.unify val_env public_self self_type
    with Ctype.Unify trace -> raise(Error(loc, val_env, Final_self_clash trace))
    end;
  end;

  (* Typing of method bodies *)
  (* if !Clflags.principal then *) begin
    let ms = !meths in
    (* Generalize the spine of methods accessed through self *)
    Meths.iter (fun _ (_,ty) -> Ctype.generalize_spine ty) ms;
    meths :=
      Meths.map (fun (id,ty) -> (id, Ctype.generic_instance val_env ty)) ms;
    (* But keep levels correct on the type of self *)
    Meths.iter (fun _ (_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) ms
  end;
  let fields = List.map Lazy.force (List.rev fields) in
  let meths = Meths.map (function (id, _ty) -> id) !meths in

  (* Check for private methods made public *)
  let pub_meths' =
    List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind = Fpresent)
      (get_methods public_self) in
  let names = List.map (fun (x,_,_) -> x) in
  let l1 = names priv_meths and l2 = names pub_meths' in
  let added = List.filter (fun x -> List.mem x l1) l2 in
  if added <> [] then
    Location.prerr_warning loc (Warnings.Implicit_public_methods added);
  let sign = if final then sign else
      {sign with Types.csig_self = Ctype.expand_head val_env public_self} in
  {
    cstr_self = pat;
    cstr_fields = fields;
    cstr_type = sign;
    cstr_meths = meths}, sign (* redondant, since already in cstr_type *)

and class_expr cl_num val_env met_env scl =
  Builtin_attributes.warning_scope scl.pcl_attributes
    (fun () -> class_expr_aux cl_num val_env met_env scl)

and class_expr_aux cl_num val_env met_env scl =
  match scl.pcl_desc with
    Pcl_constr (lid, styl) ->
      let (path, decl) = Typetexp.find_class val_env scl.pcl_loc lid.txt in
      if Path.same decl.cty_path unbound_class then
        raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt));
      let tyl = List.map
          (fun sty -> transl_simple_type val_env false sty)
          styl
      in
      let (params, clty) =
        Ctype.instance_class decl.cty_params decl.cty_type
      in
      let clty' = abbreviate_class_type path params clty in
      if List.length params <> List.length tyl then
        raise(Error(scl.pcl_loc, val_env,
                    Parameter_arity_mismatch (lid.txt, List.length params,
                                                   List.length tyl)));
      List.iter2
        (fun cty' ty ->
          let ty' = cty'.ctyp_type in
           try Ctype.unify val_env ty' ty with Ctype.Unify trace ->
             raise(Error(cty'.ctyp_loc, val_env, Parameter_mismatch trace)))
        tyl params;
      let cl =
        rc {cl_desc = Tcl_ident (path, lid, tyl);
            cl_loc = scl.pcl_loc;
            cl_type = clty';
            cl_env = val_env;
            cl_attributes = scl.pcl_attributes;
           }
      in
      let (vals, meths, concrs) = extract_constraints clty in
      rc {cl_desc = Tcl_constraint (cl, None, vals, meths, concrs);
          cl_loc = scl.pcl_loc;
          cl_type = clty';
          cl_env = val_env;
          cl_attributes = []; (* attributes are kept on the inner cl node *)
         }
  | Pcl_structure cl_str ->
      let (desc, ty) =
        class_structure cl_num false val_env met_env scl.pcl_loc cl_str in
      rc {cl_desc = Tcl_structure desc;
          cl_loc = scl.pcl_loc;
          cl_type = Cty_signature ty;
          cl_env = val_env;
          cl_attributes = scl.pcl_attributes;
         }
  | Pcl_fun (l, Some default, spat, sbody) ->
      let loc = default.pexp_loc in
      let open Ast_helper in
      let scases = [
        Exp.case
          (Pat.construct ~loc
             (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
             (Some (Pat.var ~loc (mknoloc "*sth*"))))
          (Exp.ident ~loc (mknoloc (Longident.Lident "*sth*")));

        Exp.case
          (Pat.construct ~loc
             (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
             None)
          default;
       ]
      in
      let smatch =
        Exp.match_ ~loc (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
          scases
      in
      let sfun =
        Cl.fun_ ~loc:scl.pcl_loc
          l None
          (Pat.var ~loc (mknoloc "*opt*"))
          (Cl.let_ ~loc:scl.pcl_loc Nonrecursive [Vb.mk spat smatch] sbody)
          (* Note: we don't put the '#default' attribute, as it
             is not detected for class-level let bindings.  See #5975.*)
      in
      class_expr cl_num val_env met_env sfun
  | Pcl_fun (l, None, spat, scl') ->
      if !Clflags.principal then Ctype.begin_def ();
      let (pat, pv, val_env', met_env) =
        Typecore.type_class_arg_pattern cl_num val_env met_env l spat
      in
      if !Clflags.principal then begin
        Ctype.end_def ();
        iter_pattern (fun {pat_type=ty} -> Ctype.generalize_structure ty) pat
      end;
      let pv =
        List.map
          begin fun (id, id_loc, id', _ty) ->
            let path = Pident id' in
            (* do not mark the value as being used *)
            let vd = Env.find_value path val_env' in
            (id, id_loc,
             {exp_desc =
              Texp_ident(path, mknoloc (Longident.Lident (Ident.name id)), vd);
              exp_loc = Location.none; exp_extra = [];
              exp_type = Ctype.instance val_env' vd.val_type;
              exp_attributes = []; (* check *)
              exp_env = val_env'})
          end
          pv
      in
      let not_function = function
          Cty_arrow _ -> false
        | _ -> true
      in
      let partial =
        let dummy = type_exp val_env (Ast_helper.Exp.unreachable ()) in
        Typecore.check_partial val_env pat.pat_type pat.pat_loc
          [{c_lhs = pat; c_guard = None; c_rhs = dummy}]
      in
      Ctype.raise_nongen_level ();
      let cl = class_expr cl_num val_env' met_env scl' in
      Ctype.end_def ();
      if Btype.is_optional l && not_function cl.cl_type then
        Location.prerr_warning pat.pat_loc
          Warnings.Unerasable_optional_argument;
      rc {cl_desc = Tcl_fun (l, pat, pv, cl, partial);
          cl_loc = scl.pcl_loc;
          cl_type = Cty_arrow
            (l, Ctype.instance_def pat.pat_type, cl.cl_type);
          cl_env = val_env;
          cl_attributes = scl.pcl_attributes;
         }
  | Pcl_apply (scl', sargs) ->
      assert (sargs <> []);
      if !Clflags.principal then Ctype.begin_def ();
      let cl = class_expr cl_num val_env met_env scl' in
      if !Clflags.principal then begin
        Ctype.end_def ();
        generalize_class_type false cl.cl_type;
      end;
      let rec nonopt_labels ls ty_fun =
        match ty_fun with
        | Cty_arrow (l, _, ty_res) ->
            if Btype.is_optional l then nonopt_labels ls ty_res
            else nonopt_labels (l::ls) ty_res
        | _    -> ls
      in
      let ignore_labels =
        !Clflags.classic ||
        let labels = nonopt_labels [] cl.cl_type in
        List.length labels = List.length sargs &&
        List.for_all (fun (l,_) -> l = Nolabel) sargs &&
        List.exists (fun l -> l <> Nolabel) labels &&
        begin
          Location.prerr_warning
            cl.cl_loc
            (Warnings.Labels_omitted
               (List.map Printtyp.string_of_label
                         (List.filter ((<>) Nolabel) labels)));
          true
        end
      in
      let rec type_args args omitted ty_fun ty_fun0 sargs more_sargs =
        match ty_fun, ty_fun0 with
        | Cty_arrow (l, ty, ty_fun), Cty_arrow (_, ty0, ty_fun0)
          when sargs <> [] || more_sargs <> [] ->
            let name = Btype.label_name l
            and optional = Btype.is_optional l in
            let sargs, more_sargs, arg =
              if ignore_labels && not (Btype.is_optional l) then begin
                match sargs, more_sargs with
                  (l', sarg0)::_, _ ->
                    raise(Error(sarg0.pexp_loc, val_env, Apply_wrong_label l'))
                | _, (l', sarg0)::more_sargs ->
                    if l <> l' && l' <> Nolabel then
                      raise(Error(sarg0.pexp_loc, val_env,
                                  Apply_wrong_label l'))
                    else ([], more_sargs,
                          Some (type_argument val_env sarg0 ty ty0))
                | _ ->
                    assert false
              end else try
                let (l', sarg0, sargs, more_sargs) =
                  try
                    let (l', sarg0, sargs1, sargs2) =
                      Btype.extract_label name sargs
                    in (l', sarg0, sargs1 @ sargs2, more_sargs)
                  with Not_found ->
                    let (l', sarg0, sargs1, sargs2) =
                      Btype.extract_label name more_sargs
                    in (l', sarg0, sargs @ sargs1, sargs2)
                in
                if not optional && Btype.is_optional l' then
                  Location.prerr_warning sarg0.pexp_loc
                    (Warnings.Nonoptional_label (Printtyp.string_of_label l));
                sargs, more_sargs,
                if not optional || Btype.is_optional l' then
                  Some (type_argument val_env sarg0 ty ty0)
                else
                  let ty' = extract_option_type val_env ty
                  and ty0' = extract_option_type val_env ty0 in
                  let arg = type_argument val_env sarg0 ty' ty0' in
                  Some (option_some arg)
              with Not_found ->
                sargs, more_sargs,
                if Btype.is_optional l
                   && (List.mem_assoc Nolabel sargs
                       || List.mem_assoc Nolabel more_sargs)
                then
                  Some (option_none ty0 Location.none)
                else None
            in
            let omitted = if arg = None then (l,ty0) :: omitted else omitted in
            type_args ((l,arg)::args) omitted ty_fun ty_fun0
              sargs more_sargs
        | _ ->
            match sargs @ more_sargs with
              (l, sarg0)::_ ->
                if omitted <> [] then
                  raise(Error(sarg0.pexp_loc, val_env, Apply_wrong_label l))
                else
                  raise(Error(cl.cl_loc, val_env, Cannot_apply cl.cl_type))
            | [] ->
                (List.rev args,
                 List.fold_left
                   (fun ty_fun (l,ty) -> Cty_arrow(l,ty,ty_fun))
                   ty_fun0 omitted)
      in
      let (args, cty) =
        let (_, ty_fun0) = Ctype.instance_class [] cl.cl_type in
        if ignore_labels then
          type_args [] [] cl.cl_type ty_fun0 [] sargs
        else
          type_args [] [] cl.cl_type ty_fun0 sargs []
      in
      rc {cl_desc = Tcl_apply (cl, args);
          cl_loc = scl.pcl_loc;
          cl_type = cty;
          cl_env = val_env;
          cl_attributes = scl.pcl_attributes;
         }
  | Pcl_let (rec_flag, sdefs, scl') ->
      let (defs, val_env) =
        try
          Typecore.type_let val_env rec_flag sdefs None
        with Ctype.Unify [(ty, _)] ->
          raise(Error(scl.pcl_loc, val_env, Make_nongen_seltype ty))
      in
      let (vals, met_env) =
        List.fold_right
          (fun (id, id_loc) (vals, met_env) ->
             let path = Pident id in
             (* do not mark the value as used *)
             let vd = Env.find_value path val_env in
             Ctype.begin_def ();
             let expr =
               {exp_desc =
                Texp_ident(path, mknoloc(Longident.Lident (Ident.name id)),vd);
                exp_loc = Location.none; exp_extra = [];
                exp_type = Ctype.instance val_env vd.val_type;
                exp_attributes = [];
                exp_env = val_env;
               }
             in
             Ctype.end_def ();
             Ctype.generalize expr.exp_type;
             let desc =
               {val_type = expr.exp_type; val_kind = Val_ivar (Immutable,
                                                               cl_num);
                val_attributes = [];
                Types.val_loc = vd.Types.val_loc;
               }
             in
             let id' = Ident.create (Ident.name id) in
             ((id', id_loc, expr)
              :: vals,
              Env.add_value id' desc met_env))
          (let_bound_idents_with_loc defs)
          ([], met_env)
      in
      let cl = class_expr cl_num val_env met_env scl' in
      let () = if rec_flag = Recursive then
        check_recursive_bindings val_env defs
      in
      rc {cl_desc = Tcl_let (rec_flag, defs, vals, cl);
          cl_loc = scl.pcl_loc;
          cl_type = cl.cl_type;
          cl_env = val_env;
          cl_attributes = scl.pcl_attributes;
         }
  | Pcl_constraint (scl', scty) ->
      Ctype.begin_class_def ();
      let context = Typetexp.narrow () in
      let cl = class_expr cl_num val_env met_env scl' in
      Typetexp.widen context;
      let context = Typetexp.narrow () in
      let clty = class_type val_env scty in
      Typetexp.widen context;
      Ctype.end_def ();

      limited_generalize (Ctype.row_variable (Ctype.self_type cl.cl_type))
          cl.cl_type;
      limited_generalize (Ctype.row_variable (Ctype.self_type clty.cltyp_type))
        clty.cltyp_type;

      begin match
        Includeclass.class_types val_env cl.cl_type clty.cltyp_type
      with
        []    -> ()
      | error -> raise(Error(cl.cl_loc, val_env, Class_match_failure error))
      end;
      let (vals, meths, concrs) = extract_constraints clty.cltyp_type in
      rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs);
          cl_loc = scl.pcl_loc;
          cl_type = snd (Ctype.instance_class [] clty.cltyp_type);
          cl_env = val_env;
          cl_attributes = scl.pcl_attributes;
         }
  | Pcl_open (ovf, lid, e) ->
      let used_slot = ref false in
      let (path, new_val_env) = !Typecore.type_open ~used_slot ovf val_env scl.pcl_loc lid in
      let (_path, new_met_env) = !Typecore.type_open ~used_slot ovf met_env scl.pcl_loc lid in
      let cl = class_expr cl_num new_val_env new_met_env e in
      rc {cl_desc = Tcl_open (ovf, path, lid, new_val_env, cl);
          cl_loc = scl.pcl_loc;
          cl_type = cl.cl_type;
          cl_env = val_env;
          cl_attributes = scl.pcl_attributes;
         }
  | Pcl_extension ext ->
      raise (Error_forward (Builtin_attributes.error_of_extension ext))

(*******************************)

(* Approximate the type of the constructor to allow recursive use *)
(* of optional parameters                                         *)

let var_option = Predef.type_option (Btype.newgenvar ())

let rec approx_declaration cl =
  match cl.pcl_desc with
    Pcl_fun (l, _, _, cl) ->
      let arg =
        if Btype.is_optional l then Ctype.instance_def var_option
        else Ctype.newvar () in
      Ctype.newty (Tarrow (l, arg, approx_declaration cl, Cok))
  | Pcl_let (_, _, cl) ->
      approx_declaration cl
  | Pcl_constraint (cl, _) ->
      approx_declaration cl
  | _ -> Ctype.newvar ()

let rec approx_description ct =
  match ct.pcty_desc with
    Pcty_arrow (l, _, ct) ->
      let arg =
        if Btype.is_optional l then Ctype.instance_def var_option
        else Ctype.newvar () in
      Ctype.newty (Tarrow (l, arg, approx_description ct, Cok))
  | _ -> Ctype.newvar ()

(*******************************)

let temp_abbrev loc env id arity =
  let params = ref [] in
  for _i = 1 to arity do
    params := Ctype.newvar () :: !params
  done;
  let ty = Ctype.newobj (Ctype.newvar ()) in
  let env =
    Env.add_type ~check:true id
      {type_params = !params;
       type_arity = arity;
       type_kind = Type_abstract;
       type_private = Public;
       type_manifest = Some ty;
       type_variance = Misc.replicate_list Variance.full arity;
       type_newtype_level = None;
       type_loc = loc;
       type_attributes = []; (* or keep attrs from the class decl? *)
       type_immediate = false;
       type_unboxed = unboxed_false_default_false;
      }
      env
  in
  (!params, ty, env)

let initial_env define_class approx
    (res, env) (cl, id, ty_id, obj_id, cl_id) =
  (* Temporary abbreviations *)
  let arity = List.length cl.pci_params in
  let (obj_params, obj_ty, env) = temp_abbrev cl.pci_loc env obj_id arity in
  let (cl_params, cl_ty, env) = temp_abbrev cl.pci_loc env cl_id arity in

  (* Temporary type for the class constructor *)
  let constr_type = approx cl.pci_expr in
  if !Clflags.principal then Ctype.generalize_spine constr_type;
  let dummy_cty =
    Cty_signature
      { csig_self = Ctype.newvar ();
        csig_vars = Vars.empty;
        csig_concr = Concr.empty;
        csig_inher = [] }
  in
  let dummy_class =
    {Types.cty_params = [];             (* Dummy value *)
     cty_variance = [];
     cty_type = dummy_cty;        (* Dummy value *)
     cty_path = unbound_class;
     cty_new =
       begin match cl.pci_virt with
       | Virtual  -> None
       | Concrete -> Some constr_type
       end;
     cty_loc = Location.none;
     cty_attributes = [];
    }
  in
  let env =
    Env.add_cltype ty_id
      {clty_params = [];            (* Dummy value *)
       clty_variance = [];
       clty_type = dummy_cty;       (* Dummy value *)
       clty_path = unbound_class;
       clty_loc = Location.none;
       clty_attributes = [];
      }
      (
        if define_class then
          Env.add_class id dummy_class env
        else
          env
      )
  in
  ((cl, id, ty_id,
    obj_id, obj_params, obj_ty,
    cl_id, cl_params, cl_ty,
    constr_type, dummy_class)::res,
   env)

let class_infos define_class kind
    (cl, id, ty_id,
     obj_id, obj_params, obj_ty,
     cl_id, cl_params, cl_ty,
     constr_type, dummy_class)
    (res, env) =

  reset_type_variables ();
  Ctype.begin_class_def ();

  (* Introduce class parameters *)
  let ci_params =
    let make_param (sty, v) =
      try
          (transl_type_param env sty, v)
      with Already_bound ->
        raise(Error(sty.ptyp_loc, env, Repeated_parameter))
    in
      List.map make_param cl.pci_params
  in
  let params = List.map (fun (cty, _) -> cty.ctyp_type) ci_params in

  (* Allow self coercions (only for class declarations) *)
  let coercion_locs = ref [] in

  (* Type the class expression *)
  let (expr, typ) =
    try
      Typecore.self_coercion :=
        (Path.Pident obj_id, coercion_locs) :: !Typecore.self_coercion;
      let res = kind env cl.pci_expr in
      Typecore.self_coercion := List.tl !Typecore.self_coercion;
      res
    with exn ->
      Typecore.self_coercion := []; raise exn
  in

  Ctype.end_def ();

  let sty = Ctype.self_type typ in

  (* First generalize the type of the dummy method (cf PR#6123) *)
  let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
  List.iter (fun (met, _, ty) -> if met = dummy_method then Ctype.generalize ty)
    fields;
  (* Generalize the row variable *)
  let rv = Ctype.row_variable sty in
  List.iter (Ctype.limited_generalize rv) params;
  limited_generalize rv typ;

  (* Check the abbreviation for the object type *)
  let (obj_params', obj_type) = Ctype.instance_class params typ in
  let constr = Ctype.newconstr (Path.Pident obj_id) obj_params in
  begin
    let ty = Ctype.self_type obj_type in
    Ctype.hide_private_methods ty;
    Ctype.close_object ty;
    begin try
      List.iter2 (Ctype.unify env) obj_params obj_params'
    with Ctype.Unify _ ->
      raise(Error(cl.pci_loc, env,
            Bad_parameters (obj_id, constr,
                            Ctype.newconstr (Path.Pident obj_id)
                                            obj_params')))
    end;
    begin try
      Ctype.unify env ty constr
    with Ctype.Unify _ ->
      raise(Error(cl.pci_loc, env,
        Abbrev_type_clash (constr, ty, Ctype.expand_head env constr)))
    end
  end;

  (* Check the other temporary abbreviation (#-type) *)
  begin
    let (cl_params', cl_type) = Ctype.instance_class params typ in
    let ty = Ctype.self_type cl_type in
    Ctype.hide_private_methods ty;
    Ctype.set_object_name obj_id (Ctype.row_variable ty) cl_params ty;
    begin try
      List.iter2 (Ctype.unify env) cl_params cl_params'
    with Ctype.Unify _ ->
      raise(Error(cl.pci_loc, env,
            Bad_parameters (cl_id,
                            Ctype.newconstr (Path.Pident cl_id)
                                            cl_params,
                            Ctype.newconstr (Path.Pident cl_id)
                                            cl_params')))
    end;
    begin try
      Ctype.unify env ty cl_ty
    with Ctype.Unify _ ->
      let constr = Ctype.newconstr (Path.Pident cl_id) params in
      raise(Error(cl.pci_loc, env, Abbrev_type_clash (constr, ty, cl_ty)))
    end
  end;

  (* Type of the class constructor *)
  begin try
    Ctype.unify env
      (constructor_type constr obj_type)
      (Ctype.instance env constr_type)
  with Ctype.Unify trace ->
    raise(Error(cl.pci_loc, env,
                Constructor_type_mismatch (cl.pci_name.txt, trace)))
  end;

  (* Class and class type temporary definitions *)
  let cty_variance = List.map (fun _ -> Variance.full) params in
  let cltydef =
    {clty_params = params; clty_type = class_body typ;
     clty_variance = cty_variance;
     clty_path = Path.Pident obj_id;
     clty_loc = cl.pci_loc;
     clty_attributes = cl.pci_attributes;
    }
  and clty =
    {cty_params = params; cty_type = typ;
     cty_variance = cty_variance;
     cty_path = Path.Pident obj_id;
     cty_new =
       begin match cl.pci_virt with
       | Virtual  -> None
       | Concrete -> Some constr_type
       end;
     cty_loc = cl.pci_loc;
     cty_attributes = cl.pci_attributes;
    }
  in
  dummy_class.cty_type <- typ;
  let env =
    Env.add_cltype ty_id cltydef (
    if define_class then Env.add_class id clty env else env)
  in

  if cl.pci_virt = Concrete then begin
    let sign = Ctype.signature_of_class_type typ in
    let mets = virtual_methods sign in
    let vals =
      Vars.fold
        (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l)
        sign.csig_vars [] in
    if mets <> []  || vals <> [] then
      raise(Error(cl.pci_loc, env, Virtual_class(define_class, false, mets,
                                                 vals)));
  end;

  (* Misc. *)
  let arity = Ctype.class_type_arity typ in
  let pub_meths =
    let (fields, _) =
      Ctype.flatten_fields (Ctype.object_fields (Ctype.expand_head env obj_ty))
    in
    List.map (function (lab, _, _) -> lab) fields
  in

  (* Final definitions *)
  let (params', typ') = Ctype.instance_class params typ in
  let cltydef =
    {clty_params = params'; clty_type = class_body typ';
     clty_variance = cty_variance;
     clty_path = Path.Pident obj_id;
     clty_loc = cl.pci_loc;
     clty_attributes = cl.pci_attributes;
    }
  and clty =
    {cty_params = params'; cty_type = typ';
     cty_variance = cty_variance;
     cty_path = Path.Pident obj_id;
     cty_new =
       begin match cl.pci_virt with
       | Virtual  -> None
       | Concrete -> Some (Ctype.instance env constr_type)
       end;
     cty_loc = cl.pci_loc;
     cty_attributes = cl.pci_attributes;
    }
  in
  let obj_abbr =
    {type_params = obj_params;
     type_arity = List.length obj_params;
     type_kind = Type_abstract;
     type_private = Public;
     type_manifest = Some obj_ty;
     type_variance = List.map (fun _ -> Variance.full) obj_params;
     type_newtype_level = None;
     type_loc = cl.pci_loc;
     type_attributes = []; (* or keep attrs from cl? *)
     type_immediate = false;
     type_unboxed = unboxed_false_default_false;
    }
  in
  let (cl_params, cl_ty) =
    Ctype.instance_parameterized_type params (Ctype.self_type typ)
  in
  Ctype.hide_private_methods cl_ty;
  Ctype.set_object_name obj_id (Ctype.row_variable cl_ty) cl_params cl_ty;
  let cl_abbr =
    {type_params = cl_params;
     type_arity = List.length cl_params;
     type_kind = Type_abstract;
     type_private = Public;
     type_manifest = Some cl_ty;
     type_variance = List.map (fun _ -> Variance.full) cl_params;
     type_newtype_level = None;
     type_loc = cl.pci_loc;
     type_attributes = []; (* or keep attrs from cl? *)
     type_immediate = false;
     type_unboxed = unboxed_false_default_false;
    }
  in
  ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params,
    arity, pub_meths, List.rev !coercion_locs, expr) :: res,
   env)

let final_decl env define_class
    (cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params,
     arity, pub_meths, coe, expr) =

  begin try Ctype.collapse_conj_params env clty.cty_params
  with Ctype.Unify trace ->
    raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, trace)))
  end;

  List.iter Ctype.generalize clty.cty_params;
  generalize_class_type true clty.cty_type;
  Misc.may  Ctype.generalize clty.cty_new;
  List.iter Ctype.generalize obj_abbr.type_params;
  Misc.may  Ctype.generalize obj_abbr.type_manifest;
  List.iter Ctype.generalize cl_abbr.type_params;
  Misc.may  Ctype.generalize cl_abbr.type_manifest;

  if not (closed_class clty) then
    raise(Error(cl.pci_loc, env, Non_generalizable_class (id, clty)));

  begin match
    Ctype.closed_class clty.cty_params
      (Ctype.signature_of_class_type clty.cty_type)
  with
    None        -> ()
  | Some reason ->
      let printer =
        if define_class
        then function ppf -> Printtyp.class_declaration id ppf clty
        else function ppf -> Printtyp.cltype_declaration id ppf cltydef
      in
      raise(Error(cl.pci_loc, env, Unbound_type_var(printer, reason)))
  end;

  (id, cl.pci_name, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
   arity, pub_meths, coe, expr,
   { ci_loc = cl.pci_loc;
     ci_virt = cl.pci_virt;
     ci_params = ci_params;
(* TODO : check that we have the correct use of identifiers *)
     ci_id_name = cl.pci_name;
     ci_id_class = id;
     ci_id_class_type = ty_id;
     ci_id_object = obj_id;
     ci_id_typehash = cl_id;
     ci_expr = expr;
     ci_decl = clty;
     ci_type_decl = cltydef;
     ci_attributes = cl.pci_attributes;
 })
(*   (cl.pci_variance, cl.pci_loc)) *)

let class_infos define_class kind
    (cl, id, ty_id,
     obj_id, obj_params, obj_ty,
     cl_id, cl_params, cl_ty,
     constr_type, dummy_class)
    (res, env) =
  Builtin_attributes.warning_scope cl.pci_attributes
    (fun () ->
       class_infos define_class kind
         (cl, id, ty_id,
          obj_id, obj_params, obj_ty,
          cl_id, cl_params, cl_ty,
          constr_type, dummy_class)
         (res, env)
    )

let extract_type_decls
    (_id, _id_loc, clty, _ty_id, cltydef, obj_id, obj_abbr, _cl_id, cl_abbr,
     _arity, _pub_meths, _coe, _expr, required) decls =
  (obj_id, obj_abbr, cl_abbr, clty, cltydef, required) :: decls

let merge_type_decls
    (id, id_loc, _clty, ty_id, _cltydef, obj_id, _obj_abbr, cl_id, _cl_abbr,
     arity, pub_meths, coe, expr, req) (obj_abbr, cl_abbr, clty, cltydef) =
  (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
   arity, pub_meths, coe, expr, req)

let final_env define_class env
    (id, _id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
     _arity, _pub_meths, _coe, _expr, _req) =
  (* Add definitions after cleaning them *)
  Env.add_type ~check:true obj_id
    (Subst.type_declaration Subst.identity obj_abbr) (
  Env.add_type ~check:true cl_id
    (Subst.type_declaration Subst.identity cl_abbr) (
  Env.add_cltype ty_id (Subst.cltype_declaration Subst.identity cltydef) (
  if define_class then
    Env.add_class id (Subst.class_declaration Subst.identity clty) env
  else env)))

(* Check that #c is coercible to c if there is a self-coercion *)
let check_coercions env
    (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
     arity, pub_meths, coercion_locs, _expr, req) =
  begin match coercion_locs with [] -> ()
  | loc :: _ ->
      let cl_ty, obj_ty =
        match cl_abbr.type_manifest, obj_abbr.type_manifest with
          Some cl_ab, Some obj_ab ->
            let cl_params, cl_ty =
              Ctype.instance_parameterized_type cl_abbr.type_params cl_ab
            and obj_params, obj_ty =
              Ctype.instance_parameterized_type obj_abbr.type_params obj_ab
            in
            List.iter2 (Ctype.unify env) cl_params obj_params;
            cl_ty, obj_ty
        | _ -> assert false
      in
      begin try Ctype.subtype env cl_ty obj_ty ()
      with Ctype.Subtype (tr1, tr2) ->
        raise(Typecore.Error(loc, env, Typecore.Not_subtype(tr1, tr2)))
      end;
      if not (Ctype.opened_object cl_ty) then
        raise(Error(loc, env, Cannot_coerce_self obj_ty))
  end;
  {cls_id = id;
   cls_id_loc = id_loc;
   cls_decl = clty;
   cls_ty_id = ty_id;
   cls_ty_decl = cltydef;
   cls_obj_id = obj_id;
   cls_obj_abbr = obj_abbr;
   cls_typesharp_id = cl_id;
   cls_abbr = cl_abbr;
   cls_arity = arity;
   cls_pub_methods = pub_meths;
   cls_info=req}

(*******************************)

let type_classes define_class approx kind env cls =
  let cls =
    List.map
      (function cl ->
         (cl,
          Ident.create cl.pci_name.txt, Ident.create cl.pci_name.txt,
          Ident.create cl.pci_name.txt, Ident.create ("#" ^ cl.pci_name.txt)))
      cls
  in
  Ctype.init_def (Ident.current_time ());
  Ctype.begin_class_def ();
  let (res, env) =
    List.fold_left (initial_env define_class approx) ([], env) cls
  in
  let (res, env) =
    List.fold_right (class_infos define_class kind) res ([], env)
  in
  Ctype.end_def ();
  let res = List.rev_map (final_decl env define_class) res in
  let decls = List.fold_right extract_type_decls res [] in
  let decls = Typedecl.compute_variance_decls env decls in
  let res = List.map2 merge_type_decls res decls in
  let env = List.fold_left (final_env define_class) env res in
  let res = List.map (check_coercions env) res in
  (res, env)

let class_num = ref 0
let class_declaration env sexpr =
  incr class_num;
  let expr = class_expr (string_of_int !class_num) env env sexpr in
  (expr, expr.cl_type)

let class_description env sexpr =
  let expr = class_type env sexpr in
  (expr, expr.cltyp_type)

let class_declarations env cls =
  let info, env =
    type_classes true approx_declaration class_declaration env cls
  in
  let ids, exprs =
    List.split
      (List.map
         (fun ci -> ci.cls_id, ci.cls_info.ci_expr)
         info)
  in
  check_recursive_class_bindings env ids exprs;
  info, env

let class_descriptions env cls =
  type_classes true approx_description class_description env cls

let class_type_declarations env cls =
  let (decls, env) =
    type_classes false approx_description class_description env cls
  in
  (List.map
     (fun decl ->
        {clsty_ty_id = decl.cls_ty_id;
         clsty_id_loc = decl.cls_id_loc;
         clsty_ty_decl = decl.cls_ty_decl;
         clsty_obj_id = decl.cls_obj_id;
         clsty_obj_abbr = decl.cls_obj_abbr;
         clsty_typesharp_id = decl.cls_typesharp_id;
         clsty_abbr = decl.cls_abbr;
         clsty_info = decl.cls_info})
     decls,
   env)

let rec unify_parents env ty cl =
  match cl.cl_desc with
    Tcl_ident (p, _, _) ->
      begin try
        let decl = Env.find_class p env in
        let _, body = Ctype.find_cltype_for_path env decl.cty_path in
        Ctype.unify env ty (Ctype.instance env body)
      with
        Not_found -> ()
      | _exn -> assert false
      end
  | Tcl_structure st -> unify_parents_struct env ty st
  | Tcl_open (_, _, _, _, cl)
  | Tcl_fun (_, _, _, cl, _)
  | Tcl_apply (cl, _)
  | Tcl_let (_, _, _, cl)
  | Tcl_constraint (cl, _, _, _, _) -> unify_parents env ty cl
and unify_parents_struct env ty st =
  List.iter
    (function
      | {cf_desc = Tcf_inherit (_, cl, _, _, _)} ->
          unify_parents env ty cl
      | _ -> ())
    st.cstr_fields

let type_object env loc s =
  incr class_num;
  let (desc, sign) =
    class_structure (string_of_int !class_num) true env env loc s in
  let sty = Ctype.expand_head env sign.csig_self in
  Ctype.hide_private_methods sty;
  let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
  let meths = List.map (fun (s,_,_) -> s) fields in
  unify_parents_struct env sign.csig_self desc;
  (desc, sign, meths)

let () =
  Typecore.type_object := type_object

(*******************************)

(* Approximate the class declaration as class ['params] id = object end *)
let approx_class sdecl =
  let open Ast_helper in
  let self' = Typ.any () in
  let clty' = Cty.signature ~loc:sdecl.pci_expr.pcty_loc (Csig.mk self' []) in
  { sdecl with pci_expr = clty' }

let approx_class_declarations env sdecls =
  fst (class_type_declarations env (List.map approx_class sdecls))

(*******************************)

(* Error report *)

open Format

let report_error env ppf = function
  | Repeated_parameter ->
      fprintf ppf "A type parameter occurs several times"
  | Unconsistent_constraint trace ->
      fprintf ppf "The class constraints are not consistent.@.";
      Printtyp.report_unification_error ppf env trace
        (fun ppf -> fprintf ppf "Type")
        (fun ppf -> fprintf ppf "is not compatible with type")
  | Field_type_mismatch (k, m, trace) ->
      Printtyp.report_unification_error ppf env trace
        (function ppf ->
           fprintf ppf "The %s %s@ has type" k m)
        (function ppf ->
           fprintf ppf "but is expected to have type")
  | Structure_expected clty ->
      fprintf ppf
        "@[This class expression is not a class structure; it has type@ %a@]"
        Printtyp.class_type clty
  | Cannot_apply _ ->
      fprintf ppf
        "This class expression is not a class function, it cannot be applied"
  | Apply_wrong_label l ->
      let mark_label = function
        | Nolabel -> "out label"
        |  l -> sprintf " label %s" (Btype.prefixed_label_name l) in
      fprintf ppf "This argument cannot be applied with%s" (mark_label l)
  | Pattern_type_clash ty ->
      (* XXX Trace *)
      (* XXX Revoir message d'erreur | Improve error message *)
      Printtyp.reset_and_mark_loops ty;
      fprintf ppf "@[%s@ %a@]"
        "This pattern cannot match self: it only matches values of type"
        Printtyp.type_expr ty
  | Unbound_class_2 cl ->
      fprintf ppf "@[The class@ %a@ is not yet completely defined@]"
      Printtyp.longident cl
  | Unbound_class_type_2 cl ->
      fprintf ppf "@[The class type@ %a@ is not yet completely defined@]"
      Printtyp.longident cl
  | Abbrev_type_clash (abbrev, actual, expected) ->
      (* XXX Afficher une trace ? | Print a trace? *)
      Printtyp.reset_and_mark_loops_list [abbrev; actual; expected];
      fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \
       but is used with type@ %a@]"
       Printtyp.type_expr abbrev
       Printtyp.type_expr actual
       Printtyp.type_expr expected
  | Constructor_type_mismatch (c, trace) ->
      Printtyp.report_unification_error ppf env trace
        (function ppf ->
           fprintf ppf "The expression \"new %s\" has type" c)
        (function ppf ->
           fprintf ppf "but is used with type")
  | Virtual_class (cl, imm, mets, vals) ->
      let print_mets ppf mets =
        List.iter (function met -> fprintf ppf "@ %s" met) mets in
      let missings =
        match mets, vals with
          [], _ -> "variables"
        | _, [] -> "methods"
        | _ -> "methods and variables"
      in
      let print_msg ppf =
        if imm then fprintf ppf "This object has virtual %s" missings
        else if cl then fprintf ppf "This class should be virtual"
        else fprintf ppf "This class type should be virtual"
      in
      fprintf ppf
        "@[%t.@ @[<2>The following %s are undefined :%a@]@]"
        print_msg missings print_mets (mets @ vals)
  | Parameter_arity_mismatch(lid, expected, provided) ->
      fprintf ppf
        "@[The class constructor %a@ expects %i type argument(s),@ \
           but is here applied to %i type argument(s)@]"
        Printtyp.longident lid expected provided
  | Parameter_mismatch trace ->
      Printtyp.report_unification_error ppf env trace
        (function ppf ->
           fprintf ppf "The type parameter")
        (function ppf ->
           fprintf ppf "does not meet its constraint: it should be")
  | Bad_parameters (id, params, cstrs) ->
      Printtyp.reset_and_mark_loops_list [params; cstrs];
      fprintf ppf
        "@[The abbreviation %a@ is used with parameters@ %a@ \
           which are incompatible with constraints@ %a@]"
        Printtyp.ident id Printtyp.type_expr params Printtyp.type_expr cstrs
  | Class_match_failure error ->
      Includeclass.report_error ppf error
  | Unbound_val lab ->
      fprintf ppf "Unbound instance variable %s" lab
  | Unbound_type_var (printer, reason) ->
      let print_common ppf kind ty0 real lab ty =
        let ty1 =
          if real then ty0 else Btype.newgenty(Tobject(ty0, ref None)) in
        List.iter Printtyp.mark_loops [ty; ty1];
        fprintf ppf
          "The %s %s@ has type@;<1 2>%a@ where@ %a@ is unbound"
            kind lab Printtyp.type_expr ty Printtyp.type_expr ty0
      in
      let print_reason ppf = function
      | Ctype.CC_Method (ty0, real, lab, ty) ->
          print_common ppf "method" ty0 real lab ty
      | Ctype.CC_Value (ty0, real, lab, ty) ->
          print_common ppf "instance variable" ty0 real lab ty
      in
      Printtyp.reset ();
      fprintf ppf
        "@[<v>@[Some type variables are unbound in this type:@;<1 2>%t@]@ \
              @[%a@]@]"
       printer print_reason reason
  | Make_nongen_seltype ty ->
      fprintf ppf
        "@[<v>@[Self type should not occur in the non-generic type@;<1 2>\
                %a@]@,\
           It would escape the scope of its class@]"
        Printtyp.type_scheme ty
  | Non_generalizable_class (id, clty) ->
      fprintf ppf
        "@[The type of this class,@ %a,@ \
           contains type variables that cannot be generalized@]"
        (Printtyp.class_declaration id) clty
  | Cannot_coerce_self ty ->
      fprintf ppf
        "@[The type of self cannot be coerced to@ \
           the type of the current class:@ %a.@.\
           Some occurrences are contravariant@]"
        Printtyp.type_scheme ty
  | Non_collapsable_conjunction (id, clty, trace) ->
      fprintf ppf
        "@[The type of this class,@ %a,@ \
           contains non-collapsible conjunctive types in constraints@]"
        (Printtyp.class_declaration id) clty;
      Printtyp.report_unification_error ppf env trace
        (fun ppf -> fprintf ppf "Type")
        (fun ppf -> fprintf ppf "is not compatible with type")
  | Final_self_clash trace ->
      Printtyp.report_unification_error ppf env trace
        (function ppf ->
           fprintf ppf "This object is expected to have type")
        (function ppf ->
           fprintf ppf "but actually has type")
  | Mutability_mismatch (_lab, mut) ->
      let mut1, mut2 =
        if mut = Immutable then "mutable", "immutable"
        else "immutable", "mutable" in
      fprintf ppf
        "@[The instance variable is %s;@ it cannot be redefined as %s@]"
        mut1 mut2
  | No_overriding (_, "") ->
      fprintf ppf "@[This inheritance does not override any method@ %s@]"
        "instance variable"
  | No_overriding (kind, name) ->
      fprintf ppf "@[The %s `%s'@ has no previous definition@]" kind name
  | Duplicate (kind, name) ->
      fprintf ppf "@[The %s `%s'@ has multiple definitions in this object@]"
                    kind name

let report_error env ppf err =
  Printtyp.wrap_printing_env env (fun () -> report_error env ppf err)

let () =
  Location.register_error_of_exn
    (function
      | Error (loc, env, err) ->
        Some (Location.error_of_printer loc (report_error env) err)
      | Error_forward err ->
        Some err
      | _ ->
        None
    )

end
module Typemod : sig 
#1 "typemod.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Type-checking of the module language and typed ast plugin hooks *)

open Types
open Format

val type_module:
        Env.t -> Parsetree.module_expr -> Typedtree.module_expr
val type_structure:
        Env.t -> Parsetree.structure -> Location.t ->
         Typedtree.structure * Types.signature * Env.t
val type_toplevel_phrase:
        Env.t -> Parsetree.structure ->
         Typedtree.structure * Types.signature * Env.t

val type_implementation_more: ?check_exists:unit -> 
  string -> string -> string -> Env.t -> Parsetree.structure ->
  Typedtree.structure * Typedtree.module_coercion * Env.t * Types.signature

val type_implementation:
  string -> string -> string -> Env.t -> Parsetree.structure ->
  Typedtree.structure * Typedtree.module_coercion
  
val type_interface:
        string -> Env.t -> Parsetree.signature -> Typedtree.signature
val transl_signature:
        Env.t -> Parsetree.signature -> Typedtree.signature
val check_nongen_schemes:
        Env.t -> Types.signature -> unit
val type_open_:
        ?used_slot:bool ref -> ?toplevel:bool -> Asttypes.override_flag ->
        Env.t -> Location.t -> Longident.t Asttypes.loc -> Path.t * Env.t
val modtype_of_package:
        Env.t -> Location.t ->
        Path.t -> Longident.t list -> type_expr list -> module_type
val simplify_signature: signature -> signature

val path_of_module : Typedtree.module_expr -> Path.t option

val save_signature:
  string -> Typedtree.signature -> string -> string ->
  Env.t -> Cmi_format.cmi_infos -> unit

val package_units:
  Env.t -> string list -> string -> string -> Typedtree.module_coercion

type error =
    Cannot_apply of module_type
  | Not_included of Includemod.error list
  | Cannot_eliminate_dependency of module_type
  | Signature_expected
  | Structure_expected of module_type
  | With_no_component of Longident.t
  | With_mismatch of Longident.t * Includemod.error list
  | With_makes_applicative_functor_ill_typed of
      Longident.t * Path.t * Includemod.error list
  | With_changes_module_alias of Longident.t * Ident.t * Path.t
  | With_cannot_remove_constrained_type
  | Repeated_name of string * string
  | Non_generalizable of type_expr
  | Non_generalizable_class of Ident.t * class_declaration
  | Non_generalizable_module of module_type
  | Implementation_is_required of string
  | Interface_not_compiled of string
  | Not_allowed_in_functor_body
  | Not_a_packed_module of type_expr
  | Incomplete_packed_module of type_expr
  | Scoping_pack of Longident.t * type_expr
  | Recursive_module_require_explicit_type
  | Apply_generative
  | Cannot_scrape_alias of Path.t

exception Error of Location.t * Env.t * error
exception Error_forward of Location.error


val super_report_error_no_wrap_printing_env: formatter -> error -> unit


val report_error: Env.t -> formatter -> error -> unit


module ImplementationHooks : Misc.HookSig
  with type t = Typedtree.structure * Typedtree.module_coercion
module InterfaceHooks : Misc.HookSig
  with type t = Typedtree.signature

end = struct
#1 "typemod.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Misc
open Longident
open Path
open Asttypes
open Parsetree
open Types
open Format

type error =
    Cannot_apply of module_type
  | Not_included of Includemod.error list
  | Cannot_eliminate_dependency of module_type
  | Signature_expected
  | Structure_expected of module_type
  | With_no_component of Longident.t
  | With_mismatch of Longident.t * Includemod.error list
  | With_makes_applicative_functor_ill_typed of
      Longident.t * Path.t * Includemod.error list
  | With_changes_module_alias of Longident.t * Ident.t * Path.t
  | With_cannot_remove_constrained_type
  | Repeated_name of string * string
  | Non_generalizable of type_expr
  | Non_generalizable_class of Ident.t * class_declaration
  | Non_generalizable_module of module_type
  | Implementation_is_required of string
  | Interface_not_compiled of string
  | Not_allowed_in_functor_body
  | Not_a_packed_module of type_expr
  | Incomplete_packed_module of type_expr
  | Scoping_pack of Longident.t * type_expr
  | Recursive_module_require_explicit_type
  | Apply_generative
  | Cannot_scrape_alias of Path.t

exception Error of Location.t * Env.t * error
exception Error_forward of Location.error

module ImplementationHooks = Misc.MakeHooks(struct
    type t = Typedtree.structure * Typedtree.module_coercion
  end)
module InterfaceHooks = Misc.MakeHooks(struct
    type t = Typedtree.signature
  end)

open Typedtree

let fst3 (x,_,_) = x

let rec path_concat head p =
  match p with
    Pident tail -> Pdot (Pident head, Ident.name tail, 0)
  | Pdot (pre, s, pos) -> Pdot (path_concat head pre, s, pos)
  | Papply _ -> assert false

(* Extract a signature from a module type *)

let extract_sig env loc mty =
  match Env.scrape_alias env mty with
    Mty_signature sg -> sg
  | Mty_alias(_, path) ->
      raise(Error(loc, env, Cannot_scrape_alias path))
  | _ -> raise(Error(loc, env, Signature_expected))

let extract_sig_open env loc mty =
  match Env.scrape_alias env mty with
    Mty_signature sg -> sg
  | Mty_alias(_, path) ->
      raise(Error(loc, env, Cannot_scrape_alias path))
  | mty -> raise(Error(loc, env, Structure_expected mty))

(* Compute the environment after opening a module *)

let type_open_ ?used_slot ?toplevel ovf env loc lid =
  let path = Typetexp.lookup_module ~load:true env lid.loc lid.txt in
  match Env.open_signature ~loc ?used_slot ?toplevel ovf path env with
  | Some env -> path, env
  | None ->
      let md = Env.find_module path env in
      ignore (extract_sig_open env lid.loc md.md_type);
      assert false

let type_open ?toplevel env sod =
  let (path, newenv) =
    Builtin_attributes.warning_scope sod.popen_attributes
      (fun () ->
         type_open_ ?toplevel sod.popen_override env sod.popen_loc
           sod.popen_lid
      )
  in
  let od =
    {
      open_override = sod.popen_override;
      open_path = path;
      open_txt = sod.popen_lid;
      open_attributes = sod.popen_attributes;
      open_loc = sod.popen_loc;
    }
  in
  (path, newenv, od)

(* Record a module type *)
let rm node =
  Stypes.record (Stypes.Ti_mod node);
  node

(* Forward declaration, to be filled in by type_module_type_of *)
let type_module_type_of_fwd :
    (Env.t -> Parsetree.module_expr ->
      Typedtree.module_expr * Types.module_type) ref
  = ref (fun _env _m -> assert false)

(* Merge one "with" constraint in a signature *)

let rec add_rec_types env = function
    Sig_type(id, decl, Trec_next) :: rem ->
      add_rec_types (Env.add_type ~check:true id decl env) rem
  | _ -> env

let check_type_decl env loc id row_id newdecl decl rs rem =
  let env = Env.add_type ~check:true id newdecl env in
  let env =
    match row_id with
    | None -> env
    | Some id -> Env.add_type ~check:false id newdecl env
  in
  let env = if rs = Trec_not then env else add_rec_types env rem in
  Includemod.type_declarations ~loc env id newdecl decl;
  Typedecl.check_coherence env loc id newdecl

let update_rec_next rs rem =
  match rs with
    Trec_next -> rem
  | Trec_first | Trec_not ->
      match rem with
        Sig_type (id, decl, Trec_next) :: rem ->
          Sig_type (id, decl, rs) :: rem
      | Sig_module (id, mty, Trec_next) :: rem ->
          Sig_module (id, mty, rs) :: rem
      | _ -> rem

let make p n i =
  let open Variance in
  set May_pos p (set May_neg n (set May_weak n (set Inj i null)))

let rec iter_path_apply p ~f =
  match p with
  | Pident _ -> ()
  | Pdot (p, _, _) -> iter_path_apply p ~f
  | Papply (p1, p2) ->
     iter_path_apply p1 ~f;
     iter_path_apply p2 ~f;
     f p1 p2 (* after recursing, so we know both paths are well typed *)

let path_is_strict_prefix =
  let rec list_is_strict_prefix l ~prefix =
    match l, prefix with
    | [], [] -> false
    | _ :: _, [] -> true
    | [], _ :: _ -> false
    | s1 :: t1, s2 :: t2 ->
       String.equal s1 s2 && list_is_strict_prefix t1 ~prefix:t2
  in
  fun path ~prefix ->
    match Path.flatten path, Path.flatten prefix with
    | `Contains_apply, _ | _, `Contains_apply -> false
    | `Ok (ident1, l1), `Ok (ident2, l2) ->
       Ident.same ident1 ident2
       && list_is_strict_prefix l1 ~prefix:l2

let iterator_with_env env =
  let env = ref env in
  let super = Btype.type_iterators in
  env, { super with
    Btype.it_signature = (fun self sg ->
      (* add all items to the env before recursing down, to handle recursive
         definitions *)
      let env_before = !env in
      List.iter (fun i -> env := Env.add_item i !env) sg;
      super.Btype.it_signature self sg;
      env := env_before
    );
    Btype.it_module_type = (fun self -> function
    | Mty_functor (param, mty_arg, mty_body) ->
      may (self.Btype.it_module_type self) mty_arg;
      let env_before = !env in
      env := Env.add_module ~arg:true param (Btype.default_mty mty_arg) !env;
      self.Btype.it_module_type self mty_body;
      env := env_before;
    | mty ->
      super.Btype.it_module_type self mty
    )
  }

let retype_applicative_functor_type ~loc env funct arg =
  let mty_functor = (Env.find_module funct env).md_type in
  let mty_arg = (Env.find_module arg env).md_type in
  let mty_param =
    match Env.scrape_alias env mty_functor with
    | Mty_functor (_, Some mty_param, _) -> mty_param
    | _ -> assert false (* could trigger due to MPR#7611 *)
  in
  let aliasable = not (Env.is_functor_arg arg env) in
  ignore(Includemod.modtypes ~loc env
           (Mtype.strengthen ~aliasable env mty_arg arg) mty_param)

(* When doing a deep destructive substitution with type M.N.t := .., we change M
   and M.N and so we have to check that uses of the modules other than just
   extracting components from them still make sense. There are only two such
   kinds of uses:
   - applicative functor types: F(M).t might not be well typed anymore
   - aliases: module A = M still makes sense but it doesn't mean the same thing
     anymore, so it's forbidden until it's clear what we should do with it.
   This function would be called with M.N.t and N.t to check for these uses. *)
let check_usage_of_path_of_substituted_item paths env signature ~loc ~lid =
  let iterator =
    let env, super = iterator_with_env env in
    { super with
      Btype.it_signature_item = (fun self -> function
      | Sig_module (id, { md_type = Mty_alias (_, aliased_path); _ }, _)
        when List.exists
               (fun path -> path_is_strict_prefix path ~prefix:aliased_path)
               paths
        ->
         let e = With_changes_module_alias (lid.txt, id, aliased_path) in
         raise(Error(loc, !env, e))
      | sig_item ->
         super.Btype.it_signature_item self sig_item
      );
      Btype.it_path = (fun referenced_path ->
        iter_path_apply referenced_path ~f:(fun funct arg ->
          if List.exists
               (fun path -> path_is_strict_prefix path ~prefix:arg)
               paths
          then
            let env = !env in
            try retype_applicative_functor_type ~loc env funct arg
            with Includemod.Error explanation ->
              raise(Error(loc, env,
                          With_makes_applicative_functor_ill_typed
                            (lid.txt, referenced_path, explanation)))
        )
      );
    }
  in
  iterator.Btype.it_signature iterator signature;
  Btype.unmark_iterators.Btype.it_signature Btype.unmark_iterators signature

let type_decl_is_alias sdecl = (* assuming no explicit constraint *)
  match sdecl.ptype_manifest with
  | Some {ptyp_desc = Ptyp_constr (lid, stl)}
       when List.length stl = List.length sdecl.ptype_params ->
     begin
       match
         List.iter2 (fun x (y, _) ->
             match x, y with
               {ptyp_desc=Ptyp_var sx}, {ptyp_desc=Ptyp_var sy}
                  when sx = sy -> ()
             | _, _ -> raise Exit)
           stl sdecl.ptype_params;
       with
       | exception Exit -> None
       | () -> Some lid
     end
  | _ -> None
;;

let params_are_constrained =
  let rec loop = function
    | [] -> false
    | hd :: tl ->
       match (Btype.repr hd).desc with
       | Tvar _ -> List.memq hd tl || loop tl
       | _ -> true
  in
  loop
;;

let merge_constraint initial_env loc sg constr =
  let lid =
    match constr with
    | Pwith_type (lid, _) | Pwith_module (lid, _)
    | Pwith_typesubst (lid, _) | Pwith_modsubst (lid, _) -> lid
  in
  let destructive_substitution =
    match constr with
    | Pwith_type _ | Pwith_module _ -> false
    | Pwith_typesubst _ | Pwith_modsubst _ -> true
  in
  let real_ids = ref [] in
  let rec merge env sg namelist row_id =
    match (sg, namelist, constr) with
      ([], _, _) ->
        raise(Error(loc, env, With_no_component lid.txt))
    | (Sig_type(id, decl, rs) :: rem, [s],
       Pwith_type (_, ({ptype_kind = Ptype_abstract} as sdecl)))
      when Ident.name id = s && Typedecl.is_fixed_type sdecl ->
        let decl_row =
          { type_params =
              List.map (fun _ -> Btype.newgenvar()) sdecl.ptype_params;
            type_arity = List.length sdecl.ptype_params;
            type_kind = Type_abstract;
            type_private = Private;
            type_manifest = None;
            type_variance =
              List.map
                (fun (_, v) ->
                   let (c, n) =
                     match v with
                     | Covariant -> true, false
                     | Contravariant -> false, true
                     | Invariant -> false, false
                   in
                   make (not n) (not c) false
                )
                sdecl.ptype_params;
            type_loc = sdecl.ptype_loc;
            type_newtype_level = None;
            type_attributes = [];
            type_immediate = false;
            type_unboxed = unboxed_false_default_false;
          }
        and id_row = Ident.create (s^"#row") in
        let initial_env =
          Env.add_type ~check:false id_row decl_row initial_env
        in
        let tdecl = Typedecl.transl_with_constraint
                        initial_env id (Some(Pident id_row)) decl sdecl in
        let newdecl = tdecl.typ_type in
        check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem;
        let decl_row = {decl_row with type_params = newdecl.type_params} in
        let rs' = if rs = Trec_first then Trec_not else rs in
        (Pident id, lid, Twith_type tdecl),
        Sig_type(id_row, decl_row, rs') :: Sig_type(id, newdecl, rs) :: rem
    | (Sig_type(id, decl, rs) :: rem , [s], Pwith_type (_, sdecl))
      when Ident.name id = s ->
        let tdecl =
          Typedecl.transl_with_constraint initial_env id None decl sdecl in
        let newdecl = tdecl.typ_type in
        check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem;
        (Pident id, lid, Twith_type tdecl), Sig_type(id, newdecl, rs) :: rem
    | (Sig_type(id, _, _) :: rem, [s], (Pwith_type _ | Pwith_typesubst _))
      when Ident.name id = s ^ "#row" ->
        merge env rem namelist (Some id)
    | (Sig_type(id, decl, rs) :: rem, [s], Pwith_typesubst (_, sdecl))
      when Ident.name id = s ->
        (* Check as for a normal with constraint, but discard definition *)
        let tdecl =
          Typedecl.transl_with_constraint initial_env id None decl sdecl in
        let newdecl = tdecl.typ_type in
        check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem;
        real_ids := [Pident id];
        (Pident id, lid, Twith_typesubst tdecl),
        update_rec_next rs rem
    | (Sig_module(id, md, rs) :: rem, [s], Pwith_module (_, lid'))
      when Ident.name id = s ->
        let path, md' = Typetexp.find_module initial_env loc lid'.txt in
        let md'' = {md' with md_type = Mtype.remove_aliases env md'.md_type} in
        let newmd = Mtype.strengthen_decl ~aliasable:false env md'' path in
        ignore(Includemod.modtypes ~loc env newmd.md_type md.md_type);
        (Pident id, lid, Twith_module (path, lid')),
        Sig_module(id, newmd, rs) :: rem
    | (Sig_module(id, md, rs) :: rem, [s], Pwith_modsubst (_, lid'))
      when Ident.name id = s ->
        let path, md' = Typetexp.find_module initial_env loc lid'.txt in
        let newmd = Mtype.strengthen_decl ~aliasable:false env md' path in
        ignore(Includemod.modtypes ~loc env newmd.md_type md.md_type);
        real_ids := [Pident id];
        (Pident id, lid, Twith_modsubst (path, lid')),
        update_rec_next rs rem
    | (Sig_module(id, md, rs) :: rem, s :: namelist, _)
      when Ident.name id = s ->
        let ((path, _path_loc, tcstr), newsg) =
          merge env (extract_sig env loc md.md_type) namelist None in
        let path = path_concat id path in
        real_ids := path :: !real_ids;
        let item = Sig_module(id, {md with md_type=Mty_signature newsg}, rs) in
        (path, lid, tcstr),
        item :: rem
    | (item :: rem, _, _) ->
        let (cstr, items) = merge (Env.add_item item env) rem namelist row_id
        in
        cstr, item :: items
  in
  try
    let names = Longident.flatten lid.txt in
    let (tcstr, sg) = merge initial_env sg names None in
    if destructive_substitution then (
      match List.rev !real_ids with
      | [] -> assert false
      | last :: rest ->
        (* The last item is the one that's removed. We don't need to check how
           it's used since it's replaced by a more specific type/module. *)
        assert (match last with Pident _ -> true | _ -> false);
        match rest with
        | [] -> ()
        | _ :: _ ->
          check_usage_of_path_of_substituted_item
            rest initial_env sg ~loc ~lid;
    );
    let sg =
    match tcstr with
    | (_, _, Twith_typesubst tdecl) ->
       let how_to_extend_subst =
         let sdecl =
           match constr with
           | Pwith_typesubst (_, sdecl) -> sdecl
           | _ -> assert false
         in
         match type_decl_is_alias sdecl with
         | Some lid ->
            let replacement =
              try Env.lookup_type lid.txt initial_env
              with Not_found -> assert false
            in
            fun s path -> Subst.add_type_path path replacement s
         | None ->
            let body =
              match tdecl.typ_type.type_manifest with
              | None -> assert false
              | Some x -> x
            in
            let params = tdecl.typ_type.type_params in
            if params_are_constrained params
            then raise(Error(loc, initial_env, With_cannot_remove_constrained_type));
            fun s path -> Subst.add_type_function path ~params ~body s
       in
       let sub = List.fold_left how_to_extend_subst Subst.identity !real_ids in
       Subst.signature sub sg
    | (_, _, Twith_modsubst (real_path, _)) ->
       let sub =
         List.fold_left
           (fun s path -> Subst.add_module_path path real_path s)
           Subst.identity
           !real_ids
       in
       Subst.signature sub sg
    | _ ->
       sg
    in
    (tcstr, sg)
  with Includemod.Error explanation ->
    raise(Error(loc, initial_env, With_mismatch(lid.txt, explanation)))

(* Add recursion flags on declarations arising from a mutually recursive
   block. *)

let map_rec fn decls rem =
  match decls with
  | [] -> rem
  | d1 :: dl -> fn Trec_first d1 :: map_end (fn Trec_next) dl rem

let map_rec_type ~rec_flag fn decls rem =
  match decls with
  | [] -> rem
  | d1 :: dl ->
      let first =
        match rec_flag with
        | Recursive -> Trec_first
        | Nonrecursive -> Trec_not
      in
      fn first d1 :: map_end (fn Trec_next) dl rem

let rec map_rec_type_with_row_types ~rec_flag fn decls rem =
  match decls with
  | [] -> rem
  | d1 :: dl ->
      if Btype.is_row_name (Ident.name d1.typ_id) then
        fn Trec_not d1 :: map_rec_type_with_row_types ~rec_flag fn dl rem
      else
        map_rec_type ~rec_flag fn decls rem

(* Add type extension flags to extension constructors *)
let map_ext fn exts rem =
  match exts with
  | [] -> rem
  | d1 :: dl -> fn Text_first d1 :: map_end (fn Text_next) dl rem

(* Auxiliary for translating recursively-defined module types.
   Return a module type that approximates the shape of the given module
   type AST.  Retain only module, type, and module type
   components of signatures.  For types, retain only their arity,
   making them abstract otherwise. *)

let rec approx_modtype env smty =
  match smty.pmty_desc with
    Pmty_ident lid ->
      let (path, _info) = Typetexp.find_modtype env smty.pmty_loc lid.txt in
      Mty_ident path
  | Pmty_alias lid ->
      let path = Typetexp.lookup_module env smty.pmty_loc lid.txt in
      Mty_alias(Mta_absent, path)
  | Pmty_signature ssg ->
      Mty_signature(approx_sig env ssg)
  | Pmty_functor(param, sarg, sres) ->
      let arg = may_map (approx_modtype env) sarg in
      let (id, newenv) =
        Env.enter_module ~arg:true param.txt (Btype.default_mty arg) env in
      let res = approx_modtype newenv sres in
      Mty_functor(id, arg, res)
  | Pmty_with(sbody, _constraints) ->
      approx_modtype env sbody
  | Pmty_typeof smod ->
      let (_, mty) = !type_module_type_of_fwd env smod in
      mty
  | Pmty_extension ext ->
      raise (Error_forward (Builtin_attributes.error_of_extension ext))

and approx_module_declaration env pmd =
  {
    Types.md_type = approx_modtype env pmd.pmd_type;
    md_attributes = pmd.pmd_attributes;
    md_loc = pmd.pmd_loc;
  }

and approx_sig env ssg =
  match ssg with
    [] -> []
  | item :: srem ->
      match item.psig_desc with
      | Psig_type (rec_flag, sdecls) ->
          let decls = Typedecl.approx_type_decl sdecls in
          let rem = approx_sig env srem in
          map_rec_type ~rec_flag
            (fun rs (id, info) -> Sig_type(id, info, rs)) decls rem
      | Psig_module pmd ->
          let id = Ident.create pmd.pmd_name.txt in
          let md = approx_module_declaration env pmd in
          let newenv = Env.enter_module_declaration id md env in
          Sig_module(id, md, Trec_not) :: approx_sig newenv srem
      | Psig_recmodule sdecls ->
          let decls =
            List.map
              (fun pmd ->
                 (Ident.create pmd.pmd_name.txt,
                  approx_module_declaration env pmd)
              )
              sdecls
          in
          let newenv =
            List.fold_left
              (fun env (id, md) -> Env.add_module_declaration ~check:false
                  id md env)
              env decls in
          map_rec (fun rs (id, md) -> Sig_module(id, md, rs)) decls
                  (approx_sig newenv srem)
      | Psig_modtype d ->
          let info = approx_modtype_info env d in
          let (id, newenv) = Env.enter_modtype d.pmtd_name.txt info env in
          Sig_modtype(id, info) :: approx_sig newenv srem
      | Psig_open sod ->
          let (_path, mty, _od) = type_open env sod in
          approx_sig mty srem
      | Psig_include sincl ->
          let smty = sincl.pincl_mod in
          let mty = approx_modtype env smty in
          let sg = Subst.signature Subst.identity
              (extract_sig env smty.pmty_loc mty) in
          let newenv = Env.add_signature sg env in
          sg @ approx_sig newenv srem
      | Psig_class sdecls | Psig_class_type sdecls ->
          let decls = Typeclass.approx_class_declarations env sdecls in
          let rem = approx_sig env srem in
          List.flatten
            (map_rec
               (fun rs decl ->
                  let open Typeclass in
                  [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs);
                   Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs);
                   Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs)])
              decls [rem])
      | _ ->
          approx_sig env srem

and approx_modtype_info env sinfo =
  {
   mtd_type = may_map (approx_modtype env) sinfo.pmtd_type;
   mtd_attributes = sinfo.pmtd_attributes;
   mtd_loc = sinfo.pmtd_loc;
  }

let approx_modtype env smty =
  Warnings.without_warnings
    (fun () -> approx_modtype env smty)

(* Additional validity checks on type definitions arising from
   recursive modules *)

let check_recmod_typedecls env sdecls decls =
  let recmod_ids = List.map fst3 decls in
  List.iter2
    (fun pmd (id, _, mty) ->
       let mty = mty.mty_type in
      List.iter
        (fun path ->
          Typedecl.check_recmod_typedecl env pmd.pmd_type.pmty_loc recmod_ids
                                         path (Env.find_type path env))
        (Mtype.type_paths env (Pident id) mty))
    sdecls decls

(* Auxiliaries for checking uniqueness of names in signatures and structures *)

module StringSet =
  Set.Make(struct type t = string let compare (x:t) y = String.compare x y end)

let check cl loc set_ref name =
  if StringSet.mem name !set_ref
  then raise(Error(loc, Env.empty, Repeated_name(cl, name)))
  else set_ref := StringSet.add name !set_ref

type names =
  {
    types: StringSet.t ref;
    modules: StringSet.t ref;
    modtypes: StringSet.t ref;
    typexts: StringSet.t ref;
  }

let new_names () =
  {
    types = ref StringSet.empty;
    modules = ref StringSet.empty;
    modtypes = ref StringSet.empty;
    typexts = ref StringSet.empty;
  }


let check_name check names name = check names name.loc name.txt
let check_type names loc s = check "type" loc names.types s
let check_module names loc s = check "module" loc names.modules s
let check_modtype names loc s = check "module type" loc names.modtypes s
let check_typext names loc s = check "extension constructor" loc names.typexts s


let check_sig_item names loc = function
  | Sig_type(id, _, _) -> check_type names loc (Ident.name id)
  | Sig_module(id, _, _) -> check_module names loc (Ident.name id)
  | Sig_modtype(id, _) -> check_modtype names loc (Ident.name id)
  | Sig_typext(id, _, _) -> check_typext names loc (Ident.name id)
  | _ -> ()

(* Simplify multiple specifications of a value or an extension in a signature.
   (Other signature components, e.g. types, modules, etc, are checked for
   name uniqueness.)  If multiple specifications with the same name,
   keep only the last (rightmost) one. *)

let simplify_signature sg =
  let rec aux = function
    | [] -> [], StringSet.empty
    | (Sig_value(id, _descr) as component) :: sg ->
        let (sg, val_names) as k = aux sg in
        let name = Ident.name id in
        if StringSet.mem name val_names then k
        else (component :: sg, StringSet.add name val_names)
    | component :: sg ->
        let (sg, val_names) = aux sg in
        (component :: sg, val_names)
  in
  let (sg, _) = aux sg in
  sg

(* Check and translate a module type expression *)

let transl_modtype_longident loc env lid =
  let (path, _info) = Typetexp.find_modtype env loc lid in
  path

let transl_module_alias loc env lid =
  Typetexp.lookup_module env loc lid

let mkmty desc typ env loc attrs =
  let mty = {
    mty_desc = desc;
    mty_type = typ;
    mty_loc = loc;
    mty_env = env;
    mty_attributes = attrs;
    } in
  Cmt_format.add_saved_type (Cmt_format.Partial_module_type mty);
  mty

let mksig desc env loc =
  let sg = { sig_desc = desc; sig_loc = loc; sig_env = env } in
  Cmt_format.add_saved_type (Cmt_format.Partial_signature_item sg);
  sg

(* let signature sg = List.map (fun item -> item.sig_type) sg *)

let rec transl_modtype env smty =
  Builtin_attributes.warning_scope smty.pmty_attributes
    (fun () -> transl_modtype_aux env smty)

and transl_modtype_aux env smty =
  let loc = smty.pmty_loc in
  match smty.pmty_desc with
    Pmty_ident lid ->
      let path = transl_modtype_longident loc env lid.txt in
      mkmty (Tmty_ident (path, lid)) (Mty_ident path) env loc
        smty.pmty_attributes
  | Pmty_alias lid ->
      let path = transl_module_alias loc env lid.txt in
      mkmty (Tmty_alias (path, lid)) (Mty_alias(Mta_absent, path)) env loc
        smty.pmty_attributes
  | Pmty_signature ssg ->
      let sg = transl_signature env ssg in
      mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc
        smty.pmty_attributes
  | Pmty_functor(param, sarg, sres) ->
      let arg = Misc.may_map (transl_modtype env) sarg in
      let ty_arg = Misc.may_map (fun m -> m.mty_type) arg in
      let (id, newenv) =
        Env.enter_module ~arg:true param.txt (Btype.default_mty ty_arg) env in
      Ctype.init_def(Ident.current_time()); (* PR#6513 *)
      let res = transl_modtype newenv sres in
      mkmty (Tmty_functor (id, param, arg, res))
      (Mty_functor(id, ty_arg, res.mty_type)) env loc
        smty.pmty_attributes
  | Pmty_with(sbody, constraints) ->
      let body = transl_modtype env sbody in
      let init_sg = extract_sig env sbody.pmty_loc body.mty_type in
      let (rev_tcstrs, final_sg) =
        List.fold_left
          (fun (rev_tcstrs,sg) sdecl ->
            let (tcstr, sg) = merge_constraint env smty.pmty_loc sg sdecl
            in
            (tcstr :: rev_tcstrs, sg)
        )
        ([],init_sg) constraints in
      mkmty (Tmty_with ( body, List.rev rev_tcstrs))
        (Mtype.freshen (Mty_signature final_sg)) env loc
        smty.pmty_attributes
  | Pmty_typeof smod ->
      let env = Env.in_signature false env in
      let tmty, mty = !type_module_type_of_fwd env smod in
      mkmty (Tmty_typeof tmty) mty env loc smty.pmty_attributes
  | Pmty_extension ext ->
      raise (Error_forward (Builtin_attributes.error_of_extension ext))

and transl_signature env sg =
  let names = new_names () in
  let rec transl_sig env sg =
    Ctype.init_def(Ident.current_time());
    match sg with
      [] -> [], [], env
    | item :: srem ->
        let loc = item.psig_loc in
        match item.psig_desc with
        | Psig_value sdesc ->
            let (tdesc, newenv) =
              Typedecl.transl_value_decl env item.psig_loc sdesc
            in
            let (trem,rem, final_env) = transl_sig newenv srem in
            mksig (Tsig_value tdesc) env loc :: trem,
            Sig_value(tdesc.val_id, tdesc.val_val) :: rem,
              final_env
        | Psig_type (rec_flag, sdecls) ->
            List.iter
              (fun decl -> check_name check_type names decl.ptype_name)
              sdecls;
            let (decls, newenv) =
              Typedecl.transl_type_decl env rec_flag sdecls
            in
            let (trem, rem, final_env) = transl_sig newenv srem in
            mksig (Tsig_type (rec_flag, decls)) env loc :: trem,
            map_rec_type_with_row_types ~rec_flag
              (fun rs td -> Sig_type(td.typ_id, td.typ_type, rs)) decls rem,
            final_env
        | Psig_typext styext ->
            List.iter
              (fun pext -> check_name check_typext names pext.pext_name)
              styext.ptyext_constructors;
            let (tyext, newenv) =
              Typedecl.transl_type_extension false env item.psig_loc styext
            in
            let (trem, rem, final_env) = transl_sig newenv srem in
            let constructors = tyext.tyext_constructors in
              mksig (Tsig_typext tyext) env loc :: trem,
              map_ext (fun es ext ->
                Sig_typext(ext.ext_id, ext.ext_type, es)) constructors rem,
              final_env
        | Psig_exception sext ->
            check_name check_typext names sext.pext_name;
            let (ext, newenv) = Typedecl.transl_exception env sext in
            let (trem, rem, final_env) = transl_sig newenv srem in
            mksig (Tsig_exception ext) env loc :: trem,
            Sig_typext(ext.ext_id, ext.ext_type, Text_exception) :: rem,
            final_env
        | Psig_module pmd ->
            check_name check_module names pmd.pmd_name;
            let id = Ident.create pmd.pmd_name.txt in
            let tmty =
              Builtin_attributes.warning_scope pmd.pmd_attributes
                (fun () -> transl_modtype env pmd.pmd_type)
            in
            let md = {
              md_type=tmty.mty_type;
              md_attributes=pmd.pmd_attributes;
              md_loc=pmd.pmd_loc;
            }
            in
            let newenv = Env.enter_module_declaration id md env in
            let (trem, rem, final_env) = transl_sig newenv srem in
            mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name; md_type=tmty;
                                md_loc=pmd.pmd_loc;
                                md_attributes=pmd.pmd_attributes})
              env loc :: trem,
            Sig_module(id, md, Trec_not) :: rem,
            final_env
        | Psig_recmodule sdecls ->
            List.iter
              (fun pmd -> check_name check_module names pmd.pmd_name)
              sdecls;
            let (decls, newenv) =
              transl_recmodule_modtypes env sdecls in
            let (trem, rem, final_env) = transl_sig newenv srem in
            mksig (Tsig_recmodule decls) env loc :: trem,
            map_rec (fun rs md ->
                let d = {Types.md_type = md.md_type.mty_type;
                         md_attributes = md.md_attributes;
                         md_loc = md.md_loc;
                        } in
                Sig_module(md.md_id, d, rs))
              decls rem,
            final_env
        | Psig_modtype pmtd ->
            let newenv, mtd, sg =
              transl_modtype_decl names env pmtd
            in
            let (trem, rem, final_env) = transl_sig newenv srem in
            mksig (Tsig_modtype mtd) env loc :: trem,
            sg :: rem,
            final_env
        | Psig_open sod ->
            let (_path, newenv, od) = type_open env sod in
            let (trem, rem, final_env) = transl_sig newenv srem in
            mksig (Tsig_open od) env loc :: trem,
            rem, final_env
        | Psig_include sincl ->
            let smty = sincl.pincl_mod in
            let tmty =
              Builtin_attributes.warning_scope sincl.pincl_attributes
                (fun () -> transl_modtype env smty)
            in
            let mty = tmty.mty_type in
            let sg = Subst.signature Subst.identity
                       (extract_sig env smty.pmty_loc mty) in
            List.iter (check_sig_item names item.psig_loc) sg;
            let newenv = Env.add_signature sg env in
            let incl =
              { incl_mod = tmty;
                incl_type = sg;
                incl_attributes = sincl.pincl_attributes;
                incl_loc = sincl.pincl_loc;
              }
            in
            let (trem, rem, final_env) = transl_sig newenv srem  in
            mksig (Tsig_include incl) env loc :: trem,
            sg @ rem,
            final_env
        | Psig_class cl ->
            List.iter
              (fun {pci_name} -> check_name check_type names pci_name)
              cl;
            let (classes, newenv) = Typeclass.class_descriptions env cl in
            let (trem, rem, final_env) = transl_sig newenv srem in
            mksig (Tsig_class
                     (List.map (fun decr ->
                          decr.Typeclass.cls_info) classes)) env loc
            :: trem,
            List.flatten
              (map_rec
                 (fun rs cls ->
                    let open Typeclass in
                    [Sig_class(cls.cls_id, cls.cls_decl, rs);
                     Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs);
                     Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs);
                     Sig_type(cls.cls_typesharp_id, cls.cls_abbr, rs)])
                 classes [rem]),
            final_env
        | Psig_class_type cl ->
            List.iter
              (fun {pci_name} -> check_name check_type names pci_name)
              cl;
            let (classes, newenv) = Typeclass.class_type_declarations env cl in
            let (trem,rem, final_env) = transl_sig newenv srem in
            mksig (Tsig_class_type
                     (List.map (fun decl -> decl.Typeclass.clsty_info) classes))
              env loc :: trem,
            List.flatten
              (map_rec
                 (fun rs decl ->
                    let open Typeclass in
                    [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs);
                     Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs);
                     Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs)])
                 classes [rem]),
            final_env
        | Psig_attribute x ->
            Builtin_attributes.warning_attribute x;
            let (trem,rem, final_env) = transl_sig env srem in
            mksig (Tsig_attribute x) env loc :: trem, rem, final_env
        | Psig_extension (ext, _attrs) ->
            raise (Error_forward (Builtin_attributes.error_of_extension ext))
  in
  let previous_saved_types = Cmt_format.get_saved_types () in
  Builtin_attributes.warning_scope []
    (fun () ->
       let (trem, rem, final_env) = transl_sig (Env.in_signature true env) sg in
       let rem = simplify_signature rem in
       let sg = { sig_items = trem; sig_type =  rem; sig_final_env = final_env } in
       Cmt_format.set_saved_types
         ((Cmt_format.Partial_signature sg) :: previous_saved_types);
       sg
    )

and transl_modtype_decl names env pmtd =
  Builtin_attributes.warning_scope pmtd.pmtd_attributes
    (fun () -> transl_modtype_decl_aux names env pmtd)

and transl_modtype_decl_aux names env
    {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} =
  check_name check_modtype names pmtd_name;
  let tmty = Misc.may_map (transl_modtype env) pmtd_type in
  let decl =
    {
     Types.mtd_type=may_map (fun t -> t.mty_type) tmty;
     mtd_attributes=pmtd_attributes;
     mtd_loc=pmtd_loc;
    }
  in
  let (id, newenv) = Env.enter_modtype pmtd_name.txt decl env in
  let mtd =
    {
     mtd_id=id;
     mtd_name=pmtd_name;
     mtd_type=tmty;
     mtd_attributes=pmtd_attributes;
     mtd_loc=pmtd_loc;
    }
  in
  newenv, mtd, Sig_modtype(id, decl)

and transl_recmodule_modtypes env sdecls =
  let make_env curr =
    List.fold_left
      (fun env (id, _, mty) -> Env.add_module ~arg:true id mty env)
      env curr in
  let make_env2 curr =
    List.fold_left
      (fun env (id, _, mty) -> Env.add_module ~arg:true id mty.mty_type env)
      env curr in
  let transition env_c curr =
    List.map2
      (fun pmd (id, id_loc, _mty) ->
        let tmty =
          Builtin_attributes.warning_scope pmd.pmd_attributes
            (fun () -> transl_modtype env_c pmd.pmd_type)
        in
        (id, id_loc, tmty))
      sdecls curr in
  let ids = List.map (fun x -> Ident.create x.pmd_name.txt) sdecls in
  let approx_env =
    (*
       cf #5965
       We use a dummy module type in order to detect a reference to one
       of the module being defined during the call to approx_modtype.
       It will be detected in Env.lookup_module.
    *)
    List.fold_left
      (fun env id ->
         let dummy = Mty_ident (Path.Pident (Ident.create "#recmod#")) in
         Env.add_module ~arg:true id dummy env
      )
      env ids
  in
  Ctype.init_def(Ident.current_time()); (* PR#7082 *)
  let init =
    List.map2
      (fun id pmd ->
        (id, pmd.pmd_name, approx_modtype approx_env pmd.pmd_type))
      ids sdecls
  in
  let env0 = make_env init in
  let dcl1 =
    Warnings.without_warnings
      (fun () -> transition env0 init)
  in
  let env1 = make_env2 dcl1 in
  check_recmod_typedecls env1 sdecls dcl1;
  let dcl2 = transition env1 dcl1 in
(*
  List.iter
    (fun (id, mty) ->
      Format.printf "%a: %a@." Printtyp.ident id Printtyp.modtype mty)
    dcl2;
*)
  let env2 = make_env2 dcl2 in
  check_recmod_typedecls env2 sdecls dcl2;
  let dcl2 =
    List.map2
      (fun pmd (id, id_loc, mty) ->
        {md_id=id; md_name=id_loc; md_type=mty;
         md_loc=pmd.pmd_loc;
         md_attributes=pmd.pmd_attributes})
      sdecls dcl2
  in
  (dcl2, env2)

(* Try to convert a module expression to a module path. *)

exception Not_a_path

let rec path_of_module mexp =
  match mexp.mod_desc with
    Tmod_ident (p,_) -> p
  | Tmod_apply(funct, arg, _coercion) when !Clflags.applicative_functors ->
      Papply(path_of_module funct, path_of_module arg)
  | Tmod_constraint (mexp, _, _, _) ->
      path_of_module mexp
  | _ -> raise Not_a_path

let path_of_module mexp =
 try Some (path_of_module mexp) with Not_a_path -> None

(* Check that all core type schemes in a structure are closed *)

let rec closed_modtype env = function
    Mty_ident _ -> true
  | Mty_alias _ -> true
  | Mty_signature sg ->
      let env = Env.add_signature sg env in
      List.for_all (closed_signature_item env) sg
  | Mty_functor(id, param, body) ->
      let env = Env.add_module ~arg:true id (Btype.default_mty param) env in
      closed_modtype env body

and closed_signature_item env = function
    Sig_value(_id, desc) -> Ctype.closed_schema env desc.val_type
  | Sig_module(_id, md, _) -> closed_modtype env md.md_type
  | _ -> true

let check_nongen_scheme env sig_item =
  match sig_item with
    Sig_value(_id, vd) ->
      if not (Ctype.closed_schema env vd.val_type) then
        raise (Error (vd.val_loc, env, Non_generalizable vd.val_type))
  | Sig_module (_id, md, _) ->
      if not (closed_modtype env md.md_type) then
        raise(Error(md.md_loc, env, Non_generalizable_module md.md_type))
  | _ -> ()

let check_nongen_schemes env sg =
  List.iter (check_nongen_scheme env) sg

(* Helpers for typing recursive modules *)

let anchor_submodule name anchor =
  match anchor with None -> None | Some p -> Some(Pdot(p, name, nopos))
let anchor_recmodule id =
  Some (Pident id)

let enrich_type_decls anchor decls oldenv newenv =
  match anchor with
    None -> newenv
  | Some p ->
      List.fold_left
        (fun e info ->
          let id = info.typ_id in
          let info' =
            Mtype.enrich_typedecl oldenv (Pdot(p, Ident.name id, nopos))
              info.typ_type
          in
            Env.add_type ~check:true id info' e)
        oldenv decls

let enrich_module_type anchor name mty env =
  match anchor with
    None -> mty
  | Some p -> Mtype.enrich_modtype env (Pdot(p, name, nopos)) mty

let check_recmodule_inclusion env bindings =
  (* PR#4450, PR#4470: consider
        module rec X : DECL = MOD  where MOD has inferred type ACTUAL
     The "natural" typing condition
        E, X: ACTUAL |- ACTUAL <: DECL
     leads to circularities through manifest types.
     Instead, we "unroll away" the potential circularities a finite number
     of times.  The (weaker) condition we implement is:
        E, X: DECL,
           X1: ACTUAL,
           X2: ACTUAL{X <- X1}/X1
           ...
           Xn: ACTUAL{X <- X(n-1)}/X(n-1)
        |- ACTUAL{X <- Xn}/Xn <: DECL{X <- Xn}
     so that manifest types rooted at X(n+1) are expanded in terms of X(n),
     avoiding circularities.  The strengthenings ensure that
     Xn.t = X(n-1).t = ... = X2.t = X1.t.
     N can be chosen arbitrarily; larger values of N result in more
     recursive definitions being accepted.  A good choice appears to be
     the number of mutually recursive declarations. *)

  let subst_and_strengthen env s id mty =
    Mtype.strengthen ~aliasable:false env (Subst.modtype s mty)
      (Subst.module_path s (Pident id)) in

  let rec check_incl first_time n env s =
    if n > 0 then begin
      (* Generate fresh names Y_i for the rec. bound module idents X_i *)
      let bindings1 =
        List.map
          (fun (id, _, _mty_decl, _modl, mty_actual, _attrs, _loc) ->
             (id, Ident.rename id, mty_actual))
          bindings in
      (* Enter the Y_i in the environment with their actual types substituted
         by the input substitution s *)
      let env' =
        List.fold_left
          (fun env (id, id', mty_actual) ->
             let mty_actual' =
               if first_time
               then mty_actual
               else subst_and_strengthen env s id mty_actual in
             Env.add_module ~arg:false id' mty_actual' env)
          env bindings1 in
      (* Build the output substitution Y_i <- X_i *)
      let s' =
        List.fold_left
          (fun s (id, id', _mty_actual) ->
             Subst.add_module id (Pident id') s)
          Subst.identity bindings1 in
      (* Recurse with env' and s' *)
      check_incl false (n-1) env' s'
    end else begin
      (* Base case: check inclusion of s(mty_actual) in s(mty_decl)
         and insert coercion if needed *)
      let check_inclusion (id, id_loc, mty_decl, modl, mty_actual, attrs, loc) =
        let mty_decl' = Subst.modtype s mty_decl.mty_type
        and mty_actual' = subst_and_strengthen env s id mty_actual in
        let coercion =
          try
            Includemod.modtypes ~loc:modl.mod_loc env mty_actual' mty_decl'
          with Includemod.Error msg ->
            raise(Error(modl.mod_loc, env, Not_included msg)) in
        let modl' =
            { mod_desc = Tmod_constraint(modl, mty_decl.mty_type,
                Tmodtype_explicit mty_decl, coercion);
              mod_type = mty_decl.mty_type;
              mod_env = env;
              mod_loc = modl.mod_loc;
              mod_attributes = [];
             } in
        {
         mb_id = id;
         mb_name = id_loc;
         mb_expr = modl';
         mb_attributes = attrs;
         mb_loc = loc;
        }
      in
      List.map check_inclusion bindings
    end
  in check_incl true (List.length bindings) env Subst.identity

(* Helper for unpack *)

let rec package_constraints env loc mty constrs =
  if constrs = [] then mty
  else let sg = extract_sig env loc mty in
  let sg' =
    List.map
      (function
        | Sig_type (id, ({type_params=[]} as td), rs)
          when List.mem_assoc [Ident.name id] constrs ->
            let ty = List.assoc [Ident.name id] constrs in
            Sig_type (id, {td with type_manifest = Some ty}, rs)
        | Sig_module (id, md, rs) ->
            let rec aux = function
              | (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id ->
                  (l, t) :: aux rest
              | _ :: rest -> aux rest
              | [] -> []
            in
            let md =
              {md with
               md_type = package_constraints env loc md.md_type (aux constrs)
              }
            in
            Sig_module (id, md, rs)
        | item -> item
      )
      sg
  in
  Mty_signature sg'

let modtype_of_package env loc p nl tl =
  try match (Env.find_modtype p env).mtd_type with
  | Some mty when nl <> [] ->
      package_constraints env loc mty
        (List.combine (List.map Longident.flatten nl) tl)
  | _ ->
      if nl = [] then Mty_ident p
      else raise(Error(loc, env, Signature_expected))
  with Not_found ->
    let error = Typetexp.Unbound_modtype (Ctype.lid_of_path p) in
    raise(Typetexp.Error(loc, env, error))

let package_subtype env p1 nl1 tl1 p2 nl2 tl2 =
  let mkmty p nl tl =
    let ntl =
      List.filter (fun (_n,t) -> Ctype.free_variables t = [])
        (List.combine nl tl) in
    let (nl, tl) = List.split ntl in
    modtype_of_package env Location.none p nl tl
  in
  let mty1 = mkmty p1 nl1 tl1 and mty2 = mkmty p2 nl2 tl2 in
  try Includemod.modtypes ~loc:Location.none env mty1 mty2 = Tcoerce_none
  with Includemod.Error _msg -> false
    (* raise(Error(Location.none, env, Not_included msg)) *)

let () = Ctype.package_subtype := package_subtype

let wrap_constraint env arg mty explicit =
  let coercion =
    try
      Includemod.modtypes ~loc:arg.mod_loc env arg.mod_type mty
    with Includemod.Error msg ->
      raise(Error(arg.mod_loc, env, Not_included msg)) in
  { mod_desc = Tmod_constraint(arg, mty, explicit, coercion);
    mod_type = mty;
    mod_env = env;
    mod_attributes = [];
    mod_loc = arg.mod_loc }

(* Type a module value expression *)

let rec type_module ?(alias=false) sttn funct_body anchor env smod =
  Builtin_attributes.warning_scope smod.pmod_attributes
    (fun () -> type_module_aux ~alias sttn funct_body anchor env smod)

and type_module_aux ~alias sttn funct_body anchor env smod =
  match smod.pmod_desc with
    Pmod_ident lid ->
      let path =
        Typetexp.lookup_module ~load:(not alias) env smod.pmod_loc lid.txt in
      let md = { mod_desc = Tmod_ident (path, lid);
                 mod_type = Mty_alias(Mta_absent, path);
                 mod_env = env;
                 mod_attributes = smod.pmod_attributes;
                 mod_loc = smod.pmod_loc } in
      let aliasable = not (Env.is_functor_arg path env) in
      let md =
        if alias && aliasable then
          (Env.add_required_global (Path.head path); md)
        else match (Env.find_module path env).md_type with
          Mty_alias(_, p1) when not alias ->
            let p1 = Env.normalize_path (Some smod.pmod_loc) env p1 in
            let mty = Includemod.expand_module_alias env [] p1 in
            { md with
              mod_desc = Tmod_constraint (md, mty, Tmodtype_implicit,
                                          Tcoerce_alias (p1, Tcoerce_none));
              mod_type =
                if sttn then Mtype.strengthen ~aliasable:true env mty p1
                else mty }
        | mty ->
            let mty =
              if sttn then Mtype.strengthen ~aliasable env mty path
              else mty
            in
            { md with mod_type = mty }
      in rm md
  | Pmod_structure sstr ->
      let (str, sg, _finalenv) =
        type_structure funct_body anchor env sstr smod.pmod_loc in
      let md =
        rm { mod_desc = Tmod_structure str;
             mod_type = Mty_signature sg;
             mod_env = env;
             mod_attributes = smod.pmod_attributes;
             mod_loc = smod.pmod_loc }
      in
      let sg' = simplify_signature sg in
      if List.length sg' = List.length sg then md else
      wrap_constraint (Env.implicit_coercion env) md (Mty_signature sg')
        Tmodtype_implicit
  | Pmod_functor(name, smty, sbody) ->
      let mty = may_map (transl_modtype env) smty in
      let ty_arg = may_map (fun m -> m.mty_type) mty in
      let (id, newenv), funct_body =
        match ty_arg with None -> (Ident.create "*", env), false
        | Some mty -> Env.enter_module ~arg:true name.txt mty env, true in
      Ctype.init_def(Ident.current_time()); (* PR#6981 *)
      let body = type_module sttn funct_body None newenv sbody in
      rm { mod_desc = Tmod_functor(id, name, mty, body);
           mod_type = Mty_functor(id, ty_arg, body.mod_type);
           mod_env = env;
           mod_attributes = smod.pmod_attributes;
           mod_loc = smod.pmod_loc }
  | Pmod_apply(sfunct, sarg) ->
      let arg = type_module true funct_body None env sarg in
      let path = path_of_module arg in
      let funct =
        type_module (sttn && path <> None) funct_body None env sfunct in
      begin match Env.scrape_alias env funct.mod_type with
        Mty_functor(param, mty_param, mty_res) as mty_functor ->
          let generative, mty_param =
            (mty_param = None, Btype.default_mty mty_param) in
          if generative then begin
            if sarg.pmod_desc <> Pmod_structure [] then
              raise (Error (sfunct.pmod_loc, env, Apply_generative));
            if funct_body && Mtype.contains_type env funct.mod_type then
              raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
          end;
          let coercion =
            try
              Includemod.modtypes ~loc:sarg.pmod_loc env arg.mod_type mty_param
            with Includemod.Error msg ->
              raise(Error(sarg.pmod_loc, env, Not_included msg)) in
          let mty_appl =
            match path with
              Some path ->
                Subst.modtype (Subst.add_module param path Subst.identity)
                              mty_res
            | None ->
                if generative then mty_res else
                try
                  Mtype.nondep_supertype
                    (Env.add_module ~arg:true param arg.mod_type env)
                    param mty_res
                with Not_found ->
                  raise(Error(smod.pmod_loc, env,
                              Cannot_eliminate_dependency mty_functor))
          in
          rm { mod_desc = Tmod_apply(funct, arg, coercion);
               mod_type = mty_appl;
               mod_env = env;
               mod_attributes = smod.pmod_attributes;
               mod_loc = smod.pmod_loc }
      | Mty_alias(_, path) ->
          raise(Error(sfunct.pmod_loc, env, Cannot_scrape_alias path))
      | _ ->
          raise(Error(sfunct.pmod_loc, env, Cannot_apply funct.mod_type))
      end
  | Pmod_constraint(sarg, smty) ->
      let arg = type_module ~alias true funct_body anchor env sarg in
      let mty = transl_modtype env smty in
      rm {(wrap_constraint env arg mty.mty_type (Tmodtype_explicit mty)) with
          mod_loc = smod.pmod_loc;
          mod_attributes = smod.pmod_attributes;
         }

  | Pmod_unpack sexp ->
      if !Clflags.principal then Ctype.begin_def ();
      let exp = Typecore.type_exp env sexp in
      if !Clflags.principal then begin
        Ctype.end_def ();
        Ctype.generalize_structure exp.exp_type
      end;
      let mty =
        match Ctype.expand_head env exp.exp_type with
          {desc = Tpackage (p, nl, tl)} ->
            if List.exists (fun t -> Ctype.free_variables t <> []) tl then
              raise (Error (smod.pmod_loc, env,
                            Incomplete_packed_module exp.exp_type));
            if !Clflags.principal &&
              not (Typecore.generalizable (Btype.generic_level-1) exp.exp_type)
            then
              Location.prerr_warning smod.pmod_loc
                (Warnings.Not_principal "this module unpacking");
            modtype_of_package env smod.pmod_loc p nl tl
        | {desc = Tvar _} ->
            raise (Typecore.Error
                     (smod.pmod_loc, env, Typecore.Cannot_infer_signature))
        | _ ->
            raise (Error(smod.pmod_loc, env, Not_a_packed_module exp.exp_type))
      in
      if funct_body && Mtype.contains_type env mty then
        raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
      rm { mod_desc = Tmod_unpack(exp, mty);
           mod_type = mty;
           mod_env = env;
           mod_attributes = smod.pmod_attributes;
           mod_loc = smod.pmod_loc }
  | Pmod_extension ext ->
      raise (Error_forward (Builtin_attributes.error_of_extension ext))

and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
  let names = new_names () in

  let type_str_item env srem {pstr_loc = loc; pstr_desc = desc} =
    match desc with
    | Pstr_eval (sexpr, attrs) ->
        let expr =
          Builtin_attributes.warning_scope attrs
            (fun () -> Typecore.type_expression env sexpr)
        in
        Tstr_eval (expr, attrs), [], env
    | Pstr_value(rec_flag, sdefs) ->
        let scope =
          match rec_flag with
          | Recursive ->
              Some (Annot.Idef {scope with
                                Location.loc_start = loc.Location.loc_start})
          | Nonrecursive ->
              let start =
                match srem with
                | [] -> loc.Location.loc_end
                | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start
              in
              Some (Annot.Idef {scope with Location.loc_start = start})
        in
        let (defs, newenv) =
          Typecore.type_binding env rec_flag sdefs scope in
        let () = if rec_flag = Recursive then
          Typecore.check_recursive_bindings env defs
        in
        (* Note: Env.find_value does not trigger the value_used event. Values
           will be marked as being used during the signature inclusion test. *)
        Tstr_value(rec_flag, defs),
        List.map (fun id -> Sig_value(id, Env.find_value (Pident id) newenv))
          (let_bound_idents defs),
        newenv
    | Pstr_primitive sdesc ->
        let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in
        Tstr_primitive desc, [Sig_value(desc.val_id, desc.val_val)], newenv
    | Pstr_type (rec_flag, sdecls) ->
        List.iter
          (fun decl -> check_name check_type names decl.ptype_name)
          sdecls;
        let (decls, newenv) = Typedecl.transl_type_decl env rec_flag sdecls in
        Tstr_type (rec_flag, decls),
        map_rec_type_with_row_types ~rec_flag
          (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs))
          decls [],
        enrich_type_decls anchor decls env newenv
    | Pstr_typext styext ->
        List.iter
          (fun pext -> check_name check_typext names pext.pext_name)
          styext.ptyext_constructors;
        let (tyext, newenv) =
          Typedecl.transl_type_extension true env loc styext
        in
        (Tstr_typext tyext,
         map_ext
           (fun es ext -> Sig_typext(ext.ext_id, ext.ext_type, es))
           tyext.tyext_constructors [],
         newenv)
    | Pstr_exception sext ->
        check_name check_typext names sext.pext_name;
        let (ext, newenv) = Typedecl.transl_exception env sext in
        Tstr_exception ext,
        [Sig_typext(ext.ext_id, ext.ext_type, Text_exception)],
        newenv
    | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs;
                   pmb_loc;
                  } ->
        check_name check_module names name;
        let id = Ident.create name.txt in (* create early for PR#6752 *)
        let modl =
          Builtin_attributes.warning_scope attrs
            (fun () ->
               type_module ~alias:true true funct_body
                 (anchor_submodule name.txt anchor) env smodl
            )
        in
        let md =
          { md_type = enrich_module_type anchor name.txt modl.mod_type env;
            md_attributes = attrs;
            md_loc = pmb_loc;
          }
        in
        (*prerr_endline (Ident.unique_toplevel_name id);*)
        Mtype.lower_nongen (Ident.binding_time id - 1) md.md_type;
        let newenv = Env.enter_module_declaration id md env in
        Tstr_module {mb_id=id; mb_name=name; mb_expr=modl;
                     mb_attributes=attrs;  mb_loc=pmb_loc;
                    },
        [Sig_module(id,
                    {md_type = modl.mod_type;
                     md_attributes = attrs;
                     md_loc = pmb_loc;
                    }, Trec_not)],
        newenv
    | Pstr_recmodule sbind ->
        let sbind =
          List.map
            (function
              | {pmb_name = name;
                 pmb_expr = {pmod_desc=Pmod_constraint(expr, typ)};
                 pmb_attributes = attrs;
                 pmb_loc = loc;
                } ->
                  name, typ, expr, attrs, loc
              | mb ->
                  raise (Error (mb.pmb_expr.pmod_loc, env,
                                Recursive_module_require_explicit_type))
            )
            sbind
        in
        List.iter
          (fun (name, _, _, _, _) -> check_name check_module names name)
          sbind;
        let (decls, newenv) =
          transl_recmodule_modtypes env
            (List.map (fun (name, smty, _smodl, attrs, loc) ->
                 {pmd_name=name; pmd_type=smty;
                  pmd_attributes=attrs; pmd_loc=loc}) sbind
            ) in
        let bindings1 =
          List.map2
            (fun {md_id=id; md_type=mty} (name, _, smodl, attrs, loc) ->
               let modl =
                 Builtin_attributes.warning_scope attrs
                   (fun () ->
                      type_module true funct_body (anchor_recmodule id)
                        newenv smodl
                   )
               in
               let mty' =
                 enrich_module_type anchor (Ident.name id) modl.mod_type newenv
               in
               (id, name, mty, modl, mty', attrs, loc))
            decls sbind in
        let newenv = (* allow aliasing recursive modules from outside *)
          List.fold_left
            (fun env md ->
               let mdecl =
                 {
                   md_type = md.md_type.mty_type;
                   md_attributes = md.md_attributes;
                   md_loc = md.md_loc;
                 }
               in
               Env.add_module_declaration ~check:true md.md_id mdecl env
            )
            env decls
        in
        let bindings2 =
          check_recmodule_inclusion newenv bindings1 in
        Tstr_recmodule bindings2,
        map_rec (fun rs mb ->
            Sig_module(mb.mb_id, {
                md_type=mb.mb_expr.mod_type;
                md_attributes=mb.mb_attributes;
                md_loc=mb.mb_loc;
              }, rs))
           bindings2 [],
        newenv
    | Pstr_modtype pmtd ->
        (* check that it is non-abstract *)
        let newenv, mtd, sg =
          transl_modtype_decl names env pmtd
        in
        Tstr_modtype mtd, [sg], newenv
    | Pstr_open sod ->
        let (_path, newenv, od) = type_open ~toplevel env sod in
        Tstr_open od, [], newenv
    | Pstr_class cl ->
        List.iter
          (fun {pci_name} -> check_name check_type names pci_name)
          cl;
        let (classes, new_env) = Typeclass.class_declarations env cl in
        Tstr_class
          (List.map (fun cls ->
               (cls.Typeclass.cls_info,
                cls.Typeclass.cls_pub_methods)) classes),
(* TODO: check with Jacques why this is here
      Tstr_class_type
          (List.map (fun (_,_, i, d, _,_,_,_,_,_,c) -> (i, c)) classes) ::
      Tstr_type
          (List.map (fun (_,_,_,_, i, d, _,_,_,_,_) -> (i, d)) classes) ::
      Tstr_type
          (List.map (fun (_,_,_,_,_,_, i, d, _,_,_) -> (i, d)) classes) ::
*)
        List.flatten
          (map_rec
            (fun rs cls ->
              let open Typeclass in
              [Sig_class(cls.cls_id, cls.cls_decl, rs);
               Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs);
               Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs);
               Sig_type(cls.cls_typesharp_id, cls.cls_abbr, rs)])
             classes []),
        new_env
    | Pstr_class_type cl ->
        List.iter
          (fun {pci_name} -> check_name check_type names pci_name)
          cl;
        let (classes, new_env) = Typeclass.class_type_declarations env cl in
        Tstr_class_type
          (List.map (fun cl ->
               (cl.Typeclass.clsty_ty_id,
                cl.Typeclass.clsty_id_loc,
                cl.Typeclass.clsty_info)) classes),
(*  TODO: check with Jacques why this is here
           Tstr_type
             (List.map (fun (_, _, i, d, _, _) -> (i, d)) classes) ::
           Tstr_type
             (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) :: *)
        List.flatten
          (map_rec
             (fun rs decl ->
                let open Typeclass in
                [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs);
                 Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs);
                 Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs)])
             classes []),
        new_env
    | Pstr_include sincl ->
        let smodl = sincl.pincl_mod in
        let modl =
          Builtin_attributes.warning_scope sincl.pincl_attributes
            (fun () -> type_module true funct_body None env smodl)
        in
        (* Rename all identifiers bound by this signature to avoid clashes *)
        let sg = Subst.signature Subst.identity
            (extract_sig_open env smodl.pmod_loc modl.mod_type) in
        List.iter (check_sig_item names loc) sg;
        let new_env = Env.add_signature sg env in
        let incl =
          { incl_mod = modl;
            incl_type = sg;
            incl_attributes = sincl.pincl_attributes;
            incl_loc = sincl.pincl_loc;
          }
        in
        Tstr_include incl, sg, new_env
    | Pstr_extension (ext, _attrs) ->
        raise (Error_forward (Builtin_attributes.error_of_extension ext))
    | Pstr_attribute x ->
        Builtin_attributes.warning_attribute x;
        Tstr_attribute x, [], env
  in
  let rec type_struct env sstr =
    Ctype.init_def(Ident.current_time());
    match sstr with
    | [] -> ([], [], env)
    | pstr :: srem ->
        let previous_saved_types = Cmt_format.get_saved_types () in
        let desc, sg, new_env = type_str_item env srem pstr in
        let str = { str_desc = desc; str_loc = pstr.pstr_loc; str_env = env } in
        Cmt_format.set_saved_types (Cmt_format.Partial_structure_item str
                                    :: previous_saved_types);
        let (str_rem, sig_rem, final_env) = type_struct new_env srem in
        (str :: str_rem, sg @ sig_rem, final_env)
  in
  if !Clflags.annotations then
    (* moved to genannot *)
    List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr;
  let previous_saved_types = Cmt_format.get_saved_types () in
  let run () =
    let (items, sg, final_env) = type_struct env sstr in
    let str = { str_items = items; str_type = sg; str_final_env = final_env } in
    Cmt_format.set_saved_types
      (Cmt_format.Partial_structure str :: previous_saved_types);
    str, sg, final_env
  in
  if toplevel then run ()
  else Builtin_attributes.warning_scope [] run

let type_toplevel_phrase env s =
  Env.reset_required_globals ();
  let (str, sg, env) =
    type_structure ~toplevel:true false None env s Location.none in
  let (str, _coerce) = ImplementationHooks.apply_hooks
      { Misc.sourcefile = "//toplevel//" } (str, Tcoerce_none)
  in
  (str, sg, env)

let type_module_alias = type_module ~alias:true true false None
let type_module = type_module true false None
let type_structure = type_structure false None

(* Normalize types in a signature *)

let rec normalize_modtype env = function
    Mty_ident _
  | Mty_alias _ -> ()
  | Mty_signature sg -> normalize_signature env sg
  | Mty_functor(_id, _param, body) -> normalize_modtype env body

and normalize_signature env = List.iter (normalize_signature_item env)

and normalize_signature_item env = function
    Sig_value(_id, desc) -> Ctype.normalize_type env desc.val_type
  | Sig_module(_id, md, _) -> normalize_modtype env md.md_type
  | _ -> ()

(* Extract the module type of a module expression *)

let type_module_type_of env smod =
  let tmty =
    match smod.pmod_desc with
    | Pmod_ident lid -> (* turn off strengthening in this case *)
        let path, md = Typetexp.find_module env smod.pmod_loc lid.txt in
        rm { mod_desc = Tmod_ident (path, lid);
             mod_type = md.md_type;
             mod_env = env;
             mod_attributes = smod.pmod_attributes;
             mod_loc = smod.pmod_loc }
    | _ -> type_module env smod in
  let mty = tmty.mod_type in
  (* PR#6307: expand aliases at root and submodules *)
  let mty = Mtype.remove_aliases env mty in
  (* PR#5036: must not contain non-generalized type variables *)
  if not (closed_modtype env mty) then
    raise(Error(smod.pmod_loc, env, Non_generalizable_module mty));
  tmty, mty

(* For Typecore *)

let type_package env m p nl =
  (* Same as Pexp_letmodule *)
  (* remember original level *)
  let lv = Ctype.get_current_level () in
  Ctype.begin_def ();
  Ident.set_current_time lv;
  let context = Typetexp.narrow () in
  let modl = type_module env m in
  Ctype.init_def(Ident.current_time());
  Typetexp.widen context;
  let (mp, env) =
    match modl.mod_desc with
      Tmod_ident (mp,_) -> (mp, env)
    | Tmod_constraint ({mod_desc=Tmod_ident (mp,_)}, _, Tmodtype_implicit, _)
        -> (mp, env)  (* PR#6982 *)
    | _ ->
      let (id, new_env) = Env.enter_module ~arg:true "%M" modl.mod_type env in
      (Pident id, new_env)
  in
  let rec mkpath mp = function
    | Lident name -> Pdot(mp, name, nopos)
    | Ldot (m, name) -> Pdot(mkpath mp m, name, nopos)
    | _ -> assert false
  in
  let tl' =
    List.map
      (fun name -> Btype.newgenty (Tconstr (mkpath mp name,[],ref Mnil)))
      (* beware of interactions with Printtyp and short-path:
         mp.name may have an arity > 0, cf. PR#7534 *)
      nl in
  (* go back to original level *)
  Ctype.end_def ();
  if nl = [] then
    (wrap_constraint env modl (Mty_ident p) Tmodtype_implicit, [])
  else let mty = modtype_of_package env modl.mod_loc p nl tl' in
  List.iter2
    (fun n ty ->
      try Ctype.unify env ty (Ctype.newvar ())
      with Ctype.Unify _ ->
        raise (Error(m.pmod_loc, env, Scoping_pack (n,ty))))
    nl tl';
  (wrap_constraint env modl mty Tmodtype_implicit, tl')

(* Fill in the forward declarations *)
let () =
  Typecore.type_module := type_module_alias;
  Typetexp.transl_modtype_longident := transl_modtype_longident;
  Typetexp.transl_modtype := transl_modtype;
  Typecore.type_open := type_open_ ?toplevel:None;
  Typecore.type_package := type_package;
  type_module_type_of_fwd := type_module_type_of


(* Typecheck an implementation file *)

let type_implementation_more ?check_exists sourcefile outputprefix modulename initial_env ast =
  Cmt_format.clear ();
  try
  Typecore.reset_delayed_checks ();
  Env.reset_required_globals ();
  if !Clflags.print_types then (* #7656 *)
    Warnings.parse_options false "-32-34-37-38-60";
  let (str, sg, finalenv) =
    type_structure initial_env ast (Location.in_file sourcefile) in
  let simple_sg = simplify_signature sg in
  if !Clflags.print_types then begin
    Typecore.force_delayed_checks ();
    Printtyp.wrap_printing_env initial_env
      (fun () -> fprintf std_formatter "%a@." Printtyp.signature simple_sg);
    (str, Tcoerce_none, finalenv, simple_sg)   (* result is ignored by Compile.implementation *)
  end else begin
    let sourceintf =
      Filename.remove_extension sourcefile ^ !Config.interface_suffix in
 
    let mli_status = !Clflags.assume_no_mli in 
    if (mli_status = Clflags.Mli_na && Sys.file_exists sourceintf) || (mli_status = Clflags.Mli_exists) then begin
      
      let intf_file =
        try
          find_in_path_uncap !Config.load_path (modulename ^ ".cmi")
        with Not_found ->
          raise(Error(Location.in_file sourcefile, Env.empty,
                      Interface_not_compiled sourceintf)) in
      let dclsig = Env.read_signature modulename intf_file in
      let coercion =
        Includemod.compunit initial_env sourcefile sg intf_file dclsig in
      Typecore.force_delayed_checks ();
      (* It is important to run these checks after the inclusion test above,
         so that value declarations which are not used internally but exported
         are not reported as being unused. *)
      Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename
        (Cmt_format.Implementation str) (Some sourcefile) initial_env None;
      (str, coercion, finalenv, dclsig)
        (* identifier is useless might read from serialized cmi files*)      
    end else begin
      let coercion =
        Includemod.compunit initial_env sourcefile sg
                            "(inferred signature)" simple_sg in
      check_nongen_schemes finalenv simple_sg;
      normalize_signature finalenv simple_sg;
      Typecore.force_delayed_checks ();
      (* See comment above. Here the target signature contains all
         the value being exported. We can still capture unused
         declarations like "let x = true;; let x = 1;;", because in this
         case, the inferred signature contains only the last declaration. *)
      if not !Clflags.dont_write_files then begin
        let deprecated = Builtin_attributes.deprecated_of_str ast in
        let cmi =
          Env.save_signature ?check_exists ~deprecated
            simple_sg modulename (outputprefix ^ ".cmi")
        in
        Cmt_format.save_cmt  (outputprefix ^ ".cmt") modulename
          (Cmt_format.Implementation str)
          (Some sourcefile) initial_env (Some cmi);
      end;
      (str, coercion, finalenv, simple_sg)
    end
    end
  with e ->
    Cmt_format.save_cmt  (outputprefix ^ ".cmt") modulename
      (Cmt_format.Partial_implementation
         (Array.of_list (Cmt_format.get_saved_types ())))
      (Some sourcefile) initial_env None;
    raise e

let type_implementation sourcefile outputprefix modulename initial_env ast =
  let (a,b,_,_) = 
    type_implementation_more sourcefile outputprefix modulename initial_env ast in 
  a,b    

let type_implementation sourcefile outputprefix modulename initial_env ast =
  ImplementationHooks.apply_hooks { Misc.sourcefile }
    (type_implementation sourcefile outputprefix modulename initial_env ast)

let save_signature modname tsg outputprefix source_file initial_env cmi =
  Cmt_format.save_cmt  (outputprefix ^ ".cmti") modname
    (Cmt_format.Interface tsg) (Some source_file) initial_env (Some cmi)

let type_interface sourcefile env ast =
  InterfaceHooks.apply_hooks { Misc.sourcefile } (transl_signature env ast)

(* "Packaging" of several compilation units into one unit
   having them as sub-modules.  *)

let rec package_signatures subst = function
    [] -> []
  | (name, sg) :: rem ->
      let sg' = Subst.signature subst sg in
      let oldid = Ident.create_persistent name
      and newid = Ident.create name in
      Sig_module(newid, {md_type=Mty_signature sg';
                         md_attributes=[];
                         md_loc=Location.none;
                        },
                 Trec_not) ::
      package_signatures (Subst.add_module oldid (Pident newid) subst) rem

let package_units initial_env objfiles cmifile modulename =
  (* Read the signatures of the units *)
  let units =
    List.map
      (fun f ->
         let pref = chop_extensions f in
         let modname = String.capitalize_ascii(Filename.basename pref) in
         let sg = Env.read_signature modname (pref ^ ".cmi") in
         if Filename.check_suffix f ".cmi" &&
            not(Mtype.no_code_needed_sig Env.initial_safe_string sg)
         then raise(Error(Location.none, Env.empty,
                          Implementation_is_required f));
         (modname, Env.read_signature modname (pref ^ ".cmi")))
      objfiles in
  (* Compute signature of packaged unit *)
  Ident.reinit();
  let sg = package_signatures Subst.identity units in
  (* See if explicit interface is provided *)
  let prefix = Filename.remove_extension cmifile in
  let mlifile = prefix ^ !Config.interface_suffix in

  let mli_status = !Clflags.assume_no_mli in 
  if (mli_status = Clflags.Mli_na && Sys.file_exists mlifile) || (mli_status = Clflags.Mli_exists) then begin
  
    if not (Sys.file_exists cmifile) then begin
      raise(Error(Location.in_file mlifile, Env.empty,
                  Interface_not_compiled mlifile))
    end;
    let dclsig = Env.read_signature modulename cmifile in
    Cmt_format.save_cmt  (prefix ^ ".cmt") modulename
      (Cmt_format.Packed (sg, objfiles)) None initial_env  None ;
    Includemod.compunit initial_env "(obtained by packing)" sg mlifile dclsig
  end else begin
    (* Determine imports *)
    let unit_names = List.map fst units in
    let imports =
      List.filter
        (fun (name, _crc) -> not (List.mem name unit_names))
        (Env.imports()) in
    (* Write packaged signature *)
    if not !Clflags.dont_write_files then begin
      let cmi =
        Env.save_signature_with_imports ~deprecated:None
          sg modulename
          (prefix ^ ".cmi") imports
      in
      Cmt_format.save_cmt (prefix ^ ".cmt")  modulename
        (Cmt_format.Packed (cmi.Cmi_format.cmi_sign, objfiles)) None initial_env (Some cmi)
    end;
    Tcoerce_none
  end

(* Error report *)

open Printtyp

let report_error ppf = function
    Cannot_apply mty ->
      fprintf ppf
        "@[This module is not a functor; it has type@ %a@]" modtype mty
  | Not_included errs ->
      fprintf ppf
        "@[<v>Signature mismatch:@ %a@]" Includemod.report_error errs
  | Cannot_eliminate_dependency mty ->
      fprintf ppf
        "@[This functor has type@ %a@ \
           The parameter cannot be eliminated in the result type.@  \
           Please bind the argument to a module identifier.@]" modtype mty
  | Signature_expected -> fprintf ppf "This module type is not a signature"
  | Structure_expected mty ->
      fprintf ppf
        "@[This module is not a structure; it has type@ %a" modtype mty
  | With_no_component lid ->
      fprintf ppf
        "@[The signature constrained by `with' has no component named %a@]"
        longident lid
  | With_mismatch(lid, explanation) ->
      fprintf ppf
        "@[<v>\
           @[In this `with' constraint, the new definition of %a@ \
             does not match its original definition@ \
             in the constrained signature:@]@ \
           %a@]"
        longident lid Includemod.report_error explanation
  | With_makes_applicative_functor_ill_typed(lid, path, explanation) ->
      fprintf ppf
        "@[<v>\
           @[This `with' constraint on %a makes the applicative functor @ \
             type %s ill-typed in the constrained signature:@]@ \
           %a@]"
        longident lid (Path.name path) Includemod.report_error explanation
  | With_changes_module_alias(lid, id, path) ->
      fprintf ppf
        "@[<v>\
           @[This `with' constraint on %a changes %s, which is aliased @ \
             in the constrained signature (as %s)@].@]"
        longident lid (Path.name path) (Ident.name id)
  | With_cannot_remove_constrained_type ->
      fprintf ppf
        "@[<v>Destructive substitutions are not supported for constrained @ \
              types (other than when replacing a type constructor with @ \
              a type constructor with the same arguments).@]"
  | Repeated_name(kind, name) ->
      fprintf ppf
        "@[Multiple definition of the %s name %s.@ \
           Names must be unique in a given structure or signature.@]" kind name
  | Non_generalizable typ ->
      fprintf ppf
        "@[The type of this expression,@ %a,@ \
           contains type variables that cannot be generalized@]" type_scheme typ
  | Non_generalizable_class (id, desc) ->
      fprintf ppf
        "@[The type of this class,@ %a,@ \
           contains type variables that cannot be generalized@]"
        (class_declaration id) desc
  | Non_generalizable_module mty ->
      fprintf ppf
        "@[The type of this module,@ %a,@ \
           contains type variables that cannot be generalized@]" modtype mty
  | Implementation_is_required intf_name ->
      fprintf ppf
        "@[The interface %a@ declares values, not just types.@ \
           An implementation must be provided.@]"
        Location.print_filename intf_name
  | Interface_not_compiled intf_name ->
      fprintf ppf
        "@[Could not find the .cmi file for interface@ %a.@]"
        Location.print_filename intf_name
  | Not_allowed_in_functor_body ->
      fprintf ppf
        "@[This expression creates fresh types.@ %s@]"
        "It is not allowed inside applicative functors."
  | Not_a_packed_module ty ->
      fprintf ppf
        "This expression is not a packed module. It has type@ %a"
        type_expr ty
  | Incomplete_packed_module ty ->
      fprintf ppf
        "The type of this packed module contains variables:@ %a"
        type_expr ty
  | Scoping_pack (lid, ty) ->
      fprintf ppf
        "The type %a in this module cannot be exported.@ " longident lid;
      fprintf ppf
        "Its type contains local dependencies:@ %a" type_expr ty
  | Recursive_module_require_explicit_type ->
      fprintf ppf "Recursive modules require an explicit module type."
  | Apply_generative ->
      fprintf ppf "This is a generative functor. It can only be applied to ()"
  | Cannot_scrape_alias p ->
      fprintf ppf
        "This is an alias for module %a, which is missing"
        path p


let super_report_error_no_wrap_printing_env = report_error


let report_error env ppf err =
  Printtyp.wrap_printing_env env (fun () -> report_error ppf err)

let () =
  Location.register_error_of_exn
    (function
      | Error (loc, env, err) ->
        Some (Location.error_of_printer loc (report_error env) err)
      | Error_forward err ->
        Some err
      | _ ->
        None
    )

end
module Compmisc : sig 
#1 "compmisc.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*       Fabrice Le Fessant, EPI Gallium, INRIA Paris-Rocquencourt        *)
(*                                                                        *)
(*   Copyright 2013 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

val init_path : ?dir:string -> bool -> unit
val initial_env : unit -> Env.t

val read_color_env : Format.formatter -> unit

end = struct
#1 "compmisc.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*       Fabrice Le Fessant, EPI Gallium, INRIA Paris-Rocquencourt        *)
(*                                                                        *)
(*   Copyright 2013 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Compenv

(* Initialize the search path.
   [dir] is always searched first (default: the current directory),
   then the directories specified with the -I option (in command-line order),
   then the standard library directory (unless the -nostdlib option is given).
 *)

let init_path ?(dir="") native =
  let dirs =
    if !Clflags.use_threads then "+threads" :: !Clflags.include_dirs
    else if !Clflags.use_vmthreads && not native then
      "+vmthreads" :: !Clflags.include_dirs
    else
      !Clflags.include_dirs
  in
  let dirs =
    !last_include_dirs @ dirs @ Config.flexdll_dirs @ !first_include_dirs
  in
  let exp_dirs =
    List.map (Misc.expand_directory Config.standard_library) dirs in
 
    Config.load_path :=
      (if !Clflags.no_implicit_current_dir then 
         List.rev_append exp_dirs (Clflags.std_include_dir ())
       else 
         dir :: List.rev_append exp_dirs (Clflags.std_include_dir ()));

  Env.reset_cache ()

(* Return the initial environment in which compilation proceeds. *)

(* Note: do not do init_path() in initial_env, this breaks
   toplevel initialization (PR#1775) *)

let open_implicit_module m env =
  let open Asttypes in
  let lid = {loc = Location.in_file "command line";
             txt = Longident.parse m } in
  snd (Typemod.type_open_ Override env lid.loc lid)

let initial_env () =
  Ident.reinit();
  let initial =
    if Config.safe_string then Env.initial_safe_string
    else if !Clflags.unsafe_string then Env.initial_unsafe_string
    else Env.initial_safe_string
  in
  let env =
    if !Clflags.nopervasives then initial else
    open_implicit_module "Pervasives" initial
  in
  List.fold_left (fun env m ->
    open_implicit_module m env
  ) env (!implicit_modules @ List.rev !Clflags.open_modules)


let read_color_env ppf =
  try
    match Clflags.parse_color_setting (Sys.getenv "OCAML_COLOR") with
    | None ->
        Location.print_warning Location.none ppf
          (Warnings.Bad_env_variable
             ("OCAML_COLOR",
              "expected \"auto\", \"always\" or \"never\""));
    | Some x -> match !Clflags.color with
      | None -> Clflags.color := Some x
      | Some _ -> ()
  with
    Not_found -> ()

end
module Ext_digest : sig 
#1 "ext_digest.mli"
(* Copyright (C) 2019- Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


 val length : int 

 val hex_length : int
end = struct
#1 "ext_digest.ml"
(* Copyright (C) 2019- Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


 let length = 16

 let hex_length = 32
end
module Ext_modulename : sig 
#1 "ext_modulename.mli"
(* Copyright (C) 2017 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)




(** Given an JS bundle name, generate a meaningful
  bounded module name
*)
val js_id_name_of_hint_name : string -> string 
end = struct
#1 "ext_modulename.ml"
(* Copyright (C) 2017 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








let good_hint_name module_name offset =
  let len = String.length module_name in 
  len > offset && 
  (function | 'a' .. 'z' | 'A' .. 'Z' -> true | _ -> false) 
    (String.unsafe_get module_name offset) &&
  Ext_string.for_all_from module_name (offset + 1) 
    (function 
      | 'a' .. 'z' 
      | 'A' .. 'Z' 
      | '0' .. '9' 
      | '_' 
         -> true
      | _ -> false)

let rec collect_start buf s off len = 
  if off >= len then ()
  else 
    let next = succ off in 
    match String.unsafe_get  s off with     
    | 'a' .. 'z' as c ->
    Ext_buffer.add_char buf (Ext_char.uppercase_ascii c)
    ;
      collect_next buf s next len
    | 'A' .. 'Z' as c -> 
      Ext_buffer.add_char buf c ;
      collect_next buf s next len
    | _ -> collect_start buf s next len
and collect_next buf s off len = 
  if off >= len then ()  
  else 
    let next = off + 1 in 
    match String.unsafe_get s off with 
    | 'a' .. 'z'
    | 'A' .. 'Z'
    | '0' .. '9'
    | '_'
    as c ->
      Ext_buffer.add_char buf c ;
      collect_next buf s next len 
    | '.'
    | '-' -> 
      collect_start buf s next len      
    | _ -> 
      collect_next buf s next len 

(** This is for a js exeternal module, we can change it when printing
   for example
   {[
     var React$1 = require('react');
     React$1.render(..)
   ]}
   Given a name, if duplicated, they should  have the same id
*)
let js_id_name_of_hint_name module_name =       
  let i = Ext_string.rindex_neg module_name '/' in 
  if i >= 0 then
    let offset = succ i in 
    if good_hint_name module_name offset then 
      Ext_string.capitalize_ascii
        (Ext_string.tail_from module_name offset)
    else 
      let str_len = String.length module_name in 
      let buf = Ext_buffer.create str_len in 
      collect_start buf module_name offset str_len ;
      if Ext_buffer.is_empty buf then 
        Ext_string.capitalize_ascii module_name
      else Ext_buffer.contents buf 
  else 
  if good_hint_name module_name 0 then
    Ext_string.capitalize_ascii module_name
  else 
    let str_len = (String.length module_name) in 
    let buf = Ext_buffer.create str_len in 
    collect_start buf module_name 0 str_len ;    
    if Ext_buffer.is_empty buf then module_name
    else  Ext_buffer.contents buf 

end
module Ast_compatible : sig 
#1 "ast_compatible.mli"
(* Copyright (C) 2018 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

 
type poly_var_label = Asttypes.label Asttypes.loc
type arg_label = Asttypes.arg_label
type label = arg_label
external convert: arg_label -> label = "%identity"




val no_label: arg_label

type loc = Location.t 
type attrs = Parsetree.attribute list 
open Parsetree


val const_exp_string:
  ?loc:Location.t -> 
  ?attrs:attrs ->    
  ?delimiter:string -> 
  string -> 
  expression

val const_exp_int:
  ?loc:Location.t -> 
  ?attrs:attrs -> 
  int -> 
  expression 

val const_exp_int_list_as_array:  
  int list -> 
  expression 

val const_exp_string_list_as_array:  
  string list -> 
  expression 

  
val apply_simple:
  ?loc:Location.t -> 
  ?attrs:attrs -> 
  expression ->   
  expression list -> 
  expression 

val app1:
  ?loc:Location.t -> 
  ?attrs:attrs -> 
  expression ->   
  expression -> 
  expression 

val app2:
  ?loc:Location.t -> 
  ?attrs:attrs -> 
  expression ->   
  expression -> 
  expression -> 
  expression 

val app3:
  ?loc:Location.t -> 
  ?attrs:attrs -> 
  expression ->   
  expression -> 
  expression -> 
  expression ->   
  expression 

(** Note this function would slightly 
  change its semantics depending on compiler versions
  for newer version: it means always label
  for older version: it could be optional (which we should avoid)
*)  
val apply_labels:  
  ?loc:Location.t -> 
  ?attrs:attrs -> 
  expression ->   
  (string * expression) list -> 
  (* [(label,e)] [label] is strictly interpreted as label *)
  expression 

val fun_ :  
  ?loc:Location.t -> 
  ?attrs:attrs -> 
  pattern -> 
  expression -> 
  expression

val opt_label : string -> arg_label

val label_fun :
  ?loc:Location.t ->
  ?attrs:attrs ->
  label:arg_label ->
  pattern ->
  expression ->
  expression

val is_arg_label_simple :
  arg_label -> bool

val arrow :
  ?loc:Location.t -> 
  ?attrs:attrs -> 
  core_type -> 
  core_type ->
  core_type

val label_arrow :
  ?loc:Location.t -> 
  ?attrs:attrs -> 
  string -> 
  core_type -> 
  core_type ->
  core_type

val opt_arrow:
  ?loc:Location.t -> 
  ?attrs:attrs -> 
  string -> 
  core_type -> 
  core_type ->
  core_type

val object_: 
  ?loc:loc -> 
  ?attrs:attrs ->
  (string * attributes * core_type) list -> 
  (*FIXME shall we use [string loc] instead?*)
  Asttypes.closed_flag ->
  core_type  

val rec_type_str:  
  ?loc:loc -> 
  type_declaration list -> 
  structure_item

val nonrec_type_str:  
  ?loc:loc -> 
  type_declaration list -> 
  structure_item

val rec_type_str:  
  ?loc:loc -> 
  type_declaration list -> 
  structure_item

val nonrec_type_sig:  
  ?loc:loc -> 
  type_declaration list -> 
  signature_item 

val rec_type_sig:  
  ?loc:loc -> 
  type_declaration list -> 
  signature_item

type param_type = 
  {label : arg_label ;
   ty :  Parsetree.core_type ; 
   attr :Parsetree.attributes;
   loc : loc
  }

val mk_fn_type:  
  param_type list -> 
  core_type -> 
  core_type

type object_field = 
 
  Parsetree.object_field 
val object_field : Asttypes.label Asttypes.loc ->  attributes -> core_type -> object_field
  

val hash_label : poly_var_label -> int 
val label_of_name : poly_var_label -> string 

type args  = 
  (arg_label * Parsetree.expression) list 

end = struct
#1 "ast_compatible.ml"
(* Copyright (C) 2018 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type loc = Location.t 
type attrs = Parsetree.attribute list 
open Parsetree
let default_loc = Location.none

 
type poly_var_label = Asttypes.label Asttypes.loc

type arg_label = Asttypes.arg_label = 
  | Nolabel
  | Labelled of string
  | Optional of string
let no_label : arg_label = Nolabel
let is_arg_label_simple (s : arg_label) = s = (Nolabel : arg_label)  
type label = arg_label 
external convert : arg_label -> label = "%identity"


let arrow ?(loc=default_loc) ?(attrs = []) a b  =
  Ast_helper.Typ.arrow ~loc ~attrs no_label a b  

let apply_simple
 ?(loc = default_loc) 
 ?(attrs = [])
  fn args : expression = 
  { pexp_loc = loc; 
    pexp_attributes = attrs;
    pexp_desc = 
      Pexp_apply(
        fn, 
        (Ext_list.map args (fun x -> no_label, x) ) ) }

let app1        
  ?(loc = default_loc)
  ?(attrs = [])
  fn arg1 : expression = 
  { pexp_loc = loc; 
    pexp_attributes = attrs;
    pexp_desc = 
      Pexp_apply(
        fn, 
        [no_label, arg1]
        ) }

let app2
  ?(loc = default_loc)
  ?(attrs = [])
  fn arg1 arg2 : expression = 
  { pexp_loc = loc; 
    pexp_attributes = attrs;
    pexp_desc = 
      Pexp_apply(
        fn, 
        [
          no_label, arg1;
          no_label, arg2 ]
        ) }

let app3
  ?(loc = default_loc)
  ?(attrs = [])
  fn arg1 arg2 arg3 : expression = 
  { pexp_loc = loc; 
    pexp_attributes = attrs;
    pexp_desc = 
      Pexp_apply(
        fn, 
        [
          no_label, arg1;
          no_label, arg2;
          no_label, arg3
        ]
        ) }

let fun_         
  ?(loc = default_loc) 
  ?(attrs = [])
  pat
  exp = 
  {
    pexp_loc = loc; 
    pexp_attributes = attrs;
    pexp_desc = Pexp_fun(no_label,None, pat, exp)
  }

let opt_label s =

  Asttypes.Optional s


let label_fun
  ?(loc = default_loc)
  ?(attrs = [])
  ~label
  pat
  exp =
  {
    pexp_loc = loc;
    pexp_attributes = attrs;
    pexp_desc = Pexp_fun(label, None, pat, exp)
  }

 

let const_exp_string 
  ?(loc = default_loc)
  ?(attrs = [])
  ?delimiter
  (s : string) : expression = 
  {
    pexp_loc = loc; 
    pexp_attributes = attrs;
    pexp_desc = Pexp_constant(Pconst_string(s,delimiter))
  }


let const_exp_int 
  ?(loc = default_loc)
  ?(attrs = [])
  (s : int) : expression = 
  {
    pexp_loc = loc; 
    pexp_attributes = attrs;
    pexp_desc = Pexp_constant(Pconst_integer (string_of_int s, None))
  }


let apply_labels
 ?(loc = default_loc) 
 ?(attrs = [])
  fn (args : (string * expression) list) : expression = 
  { pexp_loc = loc; 
    pexp_attributes = attrs;
    pexp_desc = 
      Pexp_apply(
        fn, 
        Ext_list.map args (fun (l,a) -> Asttypes.Labelled l, a)   ) }

let object_ 
  ?(loc= default_loc)
  ?(attrs = [])
  (fields : (string * attributes * core_type) list)
  (* FIXME after upgrade *)
  flg : core_type = 
  {
    ptyp_desc = 
      Ptyp_object(
        Ext_list.map fields (fun (a,b,c) -> 
          Parsetree.Otag ({txt = a; loc = c.ptyp_loc},b,c)),flg);
    ptyp_loc = loc;
    ptyp_attributes = attrs
  }

 

let label_arrow ?(loc=default_loc) ?(attrs=[]) s a b : core_type = 
  {
      ptyp_desc = Ptyp_arrow(
 
      Asttypes.Labelled s
      
      ,
      a,
      b);
      ptyp_loc = loc;
      ptyp_attributes = attrs
  }

let opt_arrow ?(loc=default_loc) ?(attrs=[]) s a b : core_type = 
  {
      ptyp_desc = Ptyp_arrow( 
 
        Asttypes.Optional s
        
        ,
        a,
        b);
      ptyp_loc = loc;
      ptyp_attributes = attrs
  }    

let rec_type_str ?(loc=default_loc)  tds : structure_item = 
  {
    pstr_loc = loc;
    pstr_desc = Pstr_type ( 
 
      Recursive,
      
      tds)
  }

let nonrec_type_str ?(loc=default_loc)  tds : structure_item = 
  {
    pstr_loc = loc;
    pstr_desc = Pstr_type ( 
 
      Nonrecursive,
      
      tds)
  }  

let rec_type_sig ?(loc=default_loc)  tds : signature_item = 
  {
    psig_loc = loc;
    psig_desc = Psig_type ( 
 
      Recursive,
      
      tds)
  }

(* FIXME: need address migration of `[@nonrec]` attributes in older ocaml *)  
let nonrec_type_sig ?(loc=default_loc)  tds : signature_item = 
  {
    psig_loc = loc;
    psig_desc = Psig_type ( 
 
      Nonrecursive,
      
      tds)
  }  


let const_exp_int_list_as_array xs = 
  Ast_helper.Exp.array 
  (Ext_list.map  xs (fun x -> const_exp_int x ))  

let const_exp_string_list_as_array xs =   
  Ast_helper.Exp.array 
  (Ext_list.map xs (fun x -> const_exp_string x ) )  

type param_type = 
  {label : arg_label ;
   ty :  Parsetree.core_type ; 
   attr :Parsetree.attributes;
   loc : loc
  }

 let mk_fn_type 
  (new_arg_types_ty : param_type list)
  (result : core_type) : core_type = 
  Ext_list.fold_right new_arg_types_ty result (fun {label; ty; attr ; loc} acc -> 
    {
      ptyp_desc = Ptyp_arrow(label,ty,acc);
      ptyp_loc = loc; 
      ptyp_attributes = attr
    }
  )

type object_field = 
 
  Parsetree.object_field 
  

let object_field   l attrs ty = 

  Parsetree.Otag 
 (l,attrs,ty)  


 
let hash_label (x : poly_var_label) : int = Ext_pervasives.hash_variant x.txt
let label_of_name (x : poly_var_label) : string = x.txt


type args  = 
  (arg_label * Parsetree.expression) list 

end
module Ext_utf8 : sig 
#1 "ext_utf8.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type byte =
  | Single of int
  | Cont of int
  | Leading of int * int
  | Invalid


val classify : char -> byte 

val follow : 
    string -> 
    int -> 
    int -> 
    int ->
    int * int 


(** 
  return [-1] if failed 
*)
val next :  string -> remaining:int -> int -> int 


exception Invalid_utf8 of string 
 
 
val decode_utf8_string : string -> int list
end = struct
#1 "ext_utf8.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type byte =
  | Single of int
  | Cont of int
  | Leading of int * int
  | Invalid

(** [classify chr] returns the {!byte} corresponding to [chr] *)
let classify chr =
  let c = int_of_char chr in
  (* Classify byte according to leftmost 0 bit *)
  if c land 0b1000_0000 = 0 then Single c else
    (* c 0b0____*)
  if c land 0b0100_0000 = 0 then Cont (c land 0b0011_1111) else
    (* c 0b10___*)
  if c land 0b0010_0000 = 0 then Leading (1, c land 0b0001_1111) else
    (* c 0b110__*)
  if c land 0b0001_0000 = 0 then Leading (2, c land 0b0000_1111) else
    (* c 0b1110_ *)
  if c land 0b0000_1000 = 0 then Leading (3, c land 0b0000_0111) else
    (* c 0b1111_0___*)
  if c land 0b0000_0100 = 0 then Leading (4, c land 0b0000_0011) else
    (* c 0b1111_10__*)
  if c land 0b0000_0010 = 0 then Leading (5, c land 0b0000_0001)
  (* c 0b1111_110__ *)
  else Invalid

exception Invalid_utf8 of string 

(* when the first char is [Leading],
  TODO: need more error checking 
  when out of bond
 *)
let rec follow s n (c : int) offset = 
  if n = 0 then (c, offset)
  else 
    begin match classify s.[offset+1] with
      | Cont cc -> follow s (n-1) ((c lsl 6) lor (cc land 0x3f)) (offset+1)
      | _ -> raise (Invalid_utf8 "Continuation byte expected")
    end


let rec next s ~remaining  offset = 
  if remaining = 0 then offset 
  else 
    begin match classify s.[offset+1] with
      | Cont cc -> next s ~remaining:(remaining-1) (offset+1)
      | _ ->  -1 
      | exception _ ->  -1 (* it can happen when out of bound *)
    end




let decode_utf8_string s =
  let lst = ref [] in
  let add elem = lst := elem :: !lst in
  let rec  decode_utf8_cont s i s_len =
    if i = s_len  then ()
    else 
      begin 
        match classify s.[i] with
        | Single c -> 
          add c; decode_utf8_cont s (i+1) s_len
        | Cont _ -> raise (Invalid_utf8 "Unexpected continuation byte")
        | Leading (n, c) ->
          let (c', i') = follow s n c i in add c';
          decode_utf8_cont s (i' + 1) s_len
        | Invalid -> raise (Invalid_utf8 "Invalid byte")
      end
  in decode_utf8_cont s 0 (String.length s); 
  List.rev !lst


(** To decode {j||j} we need verify in the ast so that we have better error 
    location, then we do the decode later
*)  

let verify s loc = 
  assert false
end
module Ast_utf8_string : sig 
#1 "ast_utf8_string.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


type error 


type exn += Error of int  (* offset *) * error 

val pp_error :  Format.formatter -> error -> unit  


  
(* module Interp : sig *)
(*   val check_and_transform : int -> string -> int -> cxt -> unit *)
(*   val transform_test : string -> segments *)
(* end *)
val transform_test : string -> string 

val transform : Location.t -> string -> string      


end = struct
#1 "ast_utf8_string.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



type error = 
  | Invalid_code_point 
  | Unterminated_backslash
  | Invalid_escape_code of char 
  | Invalid_hex_escape
  | Invalid_unicode_escape

let pp_error fmt err = 
  Format.pp_print_string fmt @@  match err with 
  | Invalid_code_point -> "Invalid code point"
  | Unterminated_backslash -> "\\ ended unexpectedly"
  | Invalid_escape_code c -> "Invalid escape code: " ^ String.make 1 c 
  | Invalid_hex_escape -> 
    "Invalid \\x escape"
  | Invalid_unicode_escape -> "Invalid \\u escape"



type exn += Error of int  (* offset *) * error 




let error ~loc error = 
  raise (Error (loc, error))

(** Note the [loc] really should be the utf8-offset, it has nothing to do with our 
    escaping mechanism
*)
(* we can not just print new line in ES5 
   seems we don't need 
   escape "\b" "\f" 
   we need escape "\n" "\r" since 
   ocaml multiple-line allows [\n]
   visual input while es5 string 
   does not*)

let rec check_and_transform (loc : int ) buf s byte_offset s_len =
  if byte_offset = s_len then ()
  else 
    let current_char = s.[byte_offset] in 
    match Ext_utf8.classify current_char with 
    | Single 92 (* '\\' *) -> 
      escape_code (loc + 1) buf s (byte_offset+1) s_len
    | Single 34 ->
      Buffer.add_string buf "\\\"";
      check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
    | Single 39 -> 
      Buffer.add_string buf "\\'";
      check_and_transform (loc + 1) buf s (byte_offset + 1) s_len 
    | Single 10 ->          
      Buffer.add_string buf "\\n";
      check_and_transform (loc + 1) buf s (byte_offset + 1) s_len 
    | Single 13 -> 
      Buffer.add_string buf "\\r";
      check_and_transform (loc + 1) buf s (byte_offset + 1) s_len 
    | Single _ -> 
      Buffer.add_char buf current_char;
      check_and_transform (loc + 1) buf s (byte_offset + 1) s_len 

    | Invalid 
    | Cont _ -> error ~loc Invalid_code_point
    | Leading (n,_) -> 
      let i' = Ext_utf8.next s ~remaining:n  byte_offset in
      if i' < 0 then 
        error ~loc Invalid_code_point
      else 
        begin 
          for k = byte_offset to i' do 
            Buffer.add_char buf s.[k]; 
          done;   
          check_and_transform (loc + 1 ) buf s (i' + 1) s_len 
        end
(* we share the same escape sequence with js *)        
and escape_code loc buf s offset s_len = 
  if offset >= s_len then 
    error ~loc Unterminated_backslash
  else
    Buffer.add_char buf '\\'; 
  let cur_char = s.[offset] in
  match cur_char with 
  | '\\'
  | 'b' 
  | 't' 
  | 'n' 
  | 'v'
  | 'f'
  | 'r' 
  | '0' 
  | '$'
    -> 
    begin 
      Buffer.add_char buf cur_char ;
      check_and_transform (loc + 1) buf s (offset + 1) s_len 
    end 
  | 'u' -> 
    begin 
      Buffer.add_char buf cur_char;
      unicode (loc + 1) buf s (offset + 1) s_len 
    end 
  | 'x' -> begin 
      Buffer.add_char buf cur_char ; 
      two_hex (loc + 1) buf s (offset + 1) s_len 
    end 
  | _ -> error ~loc (Invalid_escape_code cur_char)
and two_hex loc buf s offset s_len = 
  if offset + 1 >= s_len then 
    error ~loc Invalid_hex_escape;
  (*Location.raise_errorf ~loc "\\x need at least two chars";*)
  let a, b = s.[offset], s.[offset + 1] in 
  if Ext_char.valid_hex a && Ext_char.valid_hex b then 
    begin 
      Buffer.add_char buf a ; 
      Buffer.add_char buf b ; 
      check_and_transform (loc + 2) buf s (offset + 2) s_len 
    end
  else
    error ~loc Invalid_hex_escape
(*Location.raise_errorf ~loc "%c%c is not a valid hex code" a b*)

and unicode loc buf s offset s_len = 
  if offset + 3 >= s_len then 
    error ~loc Invalid_unicode_escape
  (*Location.raise_errorf ~loc "\\u need at least four chars"*)
  ;
  let a0,a1,a2,a3 = s.[offset], s.[offset+1], s.[offset+2], s.[offset+3] in
  if 
    Ext_char.valid_hex a0 &&
    Ext_char.valid_hex a1 &&
    Ext_char.valid_hex a2 &&
    Ext_char.valid_hex a3 then 
    begin 
      Buffer.add_char buf a0;
      Buffer.add_char buf a1;
      Buffer.add_char buf a2;
      Buffer.add_char buf a3;  
      check_and_transform (loc + 4) buf s  (offset + 4) s_len 
    end 
  else
    error ~loc Invalid_unicode_escape 
(*Location.raise_errorf ~loc "%c%c%c%c is not a valid unicode point"
  a0 a1 a2 a3 *)
(* http://www.2ality.com/2015/01/es6-strings.html
   console.log('\uD83D\uDE80'); (* ES6*)
   console.log('\u{1F680}');
*)   









let transform_test s =
  let s_len = String.length s in 
  let buf = Buffer.create (s_len * 2) in
  check_and_transform 0 buf s 0 s_len;
  Buffer.contents buf

let transform loc s = 
  let s_len = String.length s in 
  let buf = Buffer.create (s_len * 2) in
  try
    check_and_transform 0 buf s 0 s_len;
    Buffer.contents buf 
  with
    Error (offset, error)
    ->  Location.raise_errorf ~loc "Offset: %d, %a" offset pp_error error



end
module Bs_loc : sig 
#1 "bs_loc.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type t = Location.t = {
  loc_start : Lexing.position;
  loc_end : Lexing.position ; 
  loc_ghost : bool
} 

val is_ghost : t -> bool
val merge : t -> t -> t 
val none : t 


end = struct
#1 "bs_loc.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


type t = Location.t = {
  loc_start : Lexing.position;
  loc_end : Lexing.position ; 
  loc_ghost : bool
} 

let is_ghost x = x.loc_ghost

let merge (l: t) (r : t) = 
  if is_ghost l then r 
  else if is_ghost r then l 
  else match l,r with 
  | {loc_start ; }, {loc_end; _} (* TODO: improve*)
    -> 
    {loc_start ;loc_end; loc_ghost = false}

let none = Location.none

end
module Ast_utf8_string_interp : sig 
#1 "ast_utf8_string_interp.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



 type kind =
  | String
  | Var of int * int (* int records its border length *)

type error = private
  | Invalid_code_point
  | Unterminated_backslash
  | Invalid_escape_code of char
  | Invalid_hex_escape
  | Invalid_unicode_escape
  | Unterminated_variable
  | Unmatched_paren
  | Invalid_syntax_of_var of string 

(** Note the position is about code point *)
type pos = { lnum : int ; offset : int ; byte_bol : int }

type segment = {
  start : pos;
  finish : pos ;
  kind : kind;
  content : string ;
} 

type segments = segment list  

type cxt = {
  mutable segment_start : pos ;
  buf : Buffer.t ;
  s_len : int ;
  mutable segments : segments;
  mutable pos_bol : int; (* record the abs position of current beginning line *)
  mutable byte_bol : int ; 
  mutable pos_lnum : int ; (* record the line number *)
}

type exn += Error of pos *  pos * error 

val empty_segment : segment -> bool

val transform_test : string -> segment list



val transform : 
  Parsetree.expression -> 
  string -> 
  string -> 
  Parsetree.expression

val is_unicode_string :   
  string -> 
  bool

val is_unescaped :   
  string -> 
  bool
end = struct
#1 "ast_utf8_string_interp.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type error =
  | Invalid_code_point
  | Unterminated_backslash
  | Invalid_escape_code of char
  | Invalid_hex_escape
  | Invalid_unicode_escape
  | Unterminated_variable
  | Unmatched_paren
  | Invalid_syntax_of_var of string

type kind =
  | String
  | Var of int * int
(* [Var (loffset, roffset)]
  For parens it used to be (2,-1)
  for non-parens it used to be (1,0)
*)

(** Note the position is about code point *)
type pos = {
  lnum : int ;
  offset : int ;
  byte_bol : int (* Note it actually needs to be in sync with OCaml's lexing semantics *)
}


type segment = {
  start : pos;
  finish : pos ;
  kind : kind;
  content : string ;
}

type segments = segment list


type cxt = {
  mutable segment_start : pos ;
  buf : Buffer.t ;
  s_len : int ;
  mutable segments : segments;
  mutable pos_bol : int; (* record the abs position of current beginning line *)
  mutable byte_bol : int ;
  mutable pos_lnum : int ; (* record the line number *)
}


type exn += Error of pos *  pos * error

let pp_error fmt err =
  Format.pp_print_string fmt @@  match err with
  | Invalid_code_point -> "Invalid code point"
  | Unterminated_backslash -> "\\ ended unexpectedly"
  | Invalid_escape_code c -> "Invalid escape code: " ^ String.make 1 c
  | Invalid_hex_escape ->
    "Invalid \\x escape"
  | Invalid_unicode_escape -> "Invalid \\u escape"
  | Unterminated_variable -> "$ unterminated"
  | Unmatched_paren -> "Unmatched paren"
  | Invalid_syntax_of_var s -> "`" ^s ^ "' is not a valid syntax of interpolated identifer"
let valid_lead_identifier_char x =
  match x with
  | 'a'..'z' | '_' -> true
  | _ -> false

let valid_identifier_char x =
  match x with
  | 'a'..'z'
  | 'A'..'Z'
  | '0'..'9'
  | '_' | '\''-> true
  | _ -> false
(** Invariant: [valid_lead_identifier] has to be [valid_identifier] *)

let valid_identifier s =
  let s_len = String.length s in
  if s_len = 0 then false
  else
    valid_lead_identifier_char s.[0] &&
    Ext_string.for_all_from s 1  valid_identifier_char


let is_space x =
  match x with
  | ' ' | '\n' | '\t' -> true
  | _ -> false



(**
   FIXME: multiple line offset
   if there is no line offset. Note {|{j||} border will never trigger a new line
*)
let update_position border
    ({lnum ; offset;byte_bol } : pos)
    (pos : Lexing.position)=
  if lnum = 0 then
    {pos with pos_cnum = pos.pos_cnum + border + offset  }
    (** When no newline, the column number is [border + offset] *)
  else
    {
      pos with
      pos_lnum = pos.pos_lnum + lnum ;
      pos_bol = pos.pos_cnum + border + byte_bol;
      pos_cnum = pos.pos_cnum + border + byte_bol + offset;
      (** when newline, the column number is [offset] *)
    }
let update border
    (start : pos)
    (finish : pos) (loc : Location.t) : Location.t =
  let start_pos = loc.loc_start in
  { loc  with
    loc_start =
      update_position  border start start_pos;
    loc_end =
      update_position border finish start_pos
  }


(** Note [Var] kind can not be mpty  *)
let empty_segment {content } =
  Ext_string.is_empty content



let update_newline ~byte_bol loc  cxt =
  cxt.pos_lnum <- cxt.pos_lnum + 1 ;
  cxt.pos_bol <- loc;
  cxt.byte_bol <- byte_bol

let pos_error cxt ~loc error =
  raise (Error
           (cxt.segment_start,
            { lnum = cxt.pos_lnum ; offset = loc - cxt.pos_bol ; byte_bol = cxt.byte_bol}, error))

let add_var_segment cxt loc loffset roffset =
  let content =  Buffer.contents cxt.buf in
  Buffer.clear cxt.buf ;
  let next_loc = {
    lnum = cxt.pos_lnum ; offset = loc - cxt.pos_bol ;
    byte_bol = cxt.byte_bol } in
  if valid_identifier content then
    begin
      cxt.segments <-
        { start = cxt.segment_start;
          finish =  next_loc ;
          kind = Var (loffset, roffset);
          content} :: cxt.segments ;
      cxt.segment_start <- next_loc
    end
  else pos_error cxt ~loc (Invalid_syntax_of_var content)

let add_str_segment cxt loc   =
  let content =  Buffer.contents cxt.buf in
  Buffer.clear cxt.buf ;
  let next_loc = {
    lnum = cxt.pos_lnum ; offset = loc - cxt.pos_bol ;
    byte_bol = cxt.byte_bol } in
  cxt.segments <-
    { start = cxt.segment_start;
      finish =  next_loc ;
      kind = String;
      content} :: cxt.segments ;
  cxt.segment_start <- next_loc





let rec check_and_transform (loc : int )  s byte_offset ({s_len; buf} as cxt : cxt) =
  if byte_offset = s_len then
    add_str_segment cxt loc
  else
    let current_char = s.[byte_offset] in
    match Ext_utf8.classify current_char with
    | Single 92 (* '\\' *) ->
      escape_code (loc + 1)  s (byte_offset+1) cxt
    | Single 34 ->
      Buffer.add_string buf "\\\"";
      check_and_transform (loc + 1)  s (byte_offset + 1) cxt
    | Single 39 ->
      Buffer.add_string buf "\\'";
      check_and_transform (loc + 1)  s (byte_offset + 1) cxt
    | Single 10 ->

      Buffer.add_string buf "\\n";
      let loc = loc + 1 in
      let byte_offset = byte_offset + 1 in
      update_newline ~byte_bol:byte_offset loc cxt ; (* Note variable could not have new-line *)
      check_and_transform loc  s byte_offset cxt
    | Single 13 ->
      Buffer.add_string buf "\\r";
      check_and_transform (loc + 1)  s (byte_offset + 1) cxt
    | Single 36 -> (* $ *)
      add_str_segment cxt loc  ;
      let offset = byte_offset + 1 in
      if offset >= s_len then
        pos_error ~loc cxt  Unterminated_variable
      else
        let cur_char = s.[offset] in
        if cur_char = '(' then
          expect_var_paren  (loc + 2)  s (offset + 1) cxt
        else
          expect_simple_var (loc + 1)  s offset cxt
    | Single _ ->
      Buffer.add_char buf current_char;
      check_and_transform (loc + 1)  s (byte_offset + 1) cxt

    | Invalid
    | Cont _ -> pos_error ~loc cxt Invalid_code_point
    | Leading (n,_) ->
      let i' = Ext_utf8.next s ~remaining:n  byte_offset in
      if i' < 0 then
        pos_error cxt ~loc Invalid_code_point
      else
        begin
          for k = byte_offset to i' do
            Buffer.add_char buf s.[k];
          done;
          check_and_transform (loc + 1 )  s (i' + 1) cxt
        end
(**Lets keep identifier simple, so that we could generating a function easier in the future
   for example
   let f = [%fn{| $x + $y = $x_add_y |}]
*)
and expect_simple_var  loc  s offset ({buf; s_len} as cxt) =
  let v = ref offset in
  (* prerr_endline @@ Ext_pervasives.dump (s, has_paren, (is_space s.[!v]), !v); *)
  if not (offset < s_len  && valid_lead_identifier_char s.[offset]) then
    pos_error cxt ~loc (Invalid_syntax_of_var Ext_string.empty)
  else
    begin
      while !v < s_len && valid_identifier_char s.[!v]  do (* TODO*)
        let cur_char = s.[!v] in
        Buffer.add_char buf cur_char;
        incr v ;
      done;
      let added_length = !v - offset in
      let loc = added_length + loc in
      add_var_segment cxt loc 1 0 ;
      check_and_transform loc  s (added_length + offset) cxt
    end
and expect_var_paren  loc  s offset ({buf; s_len} as cxt) =
  let v = ref offset in
  (* prerr_endline @@ Ext_pervasives.dump (s, has_paren, (is_space s.[!v]), !v); *)
  while !v < s_len &&  s.[!v] <> ')' do
    let cur_char = s.[!v] in
    Buffer.add_char buf cur_char;
    incr v ;
  done;
  let added_length = !v - offset in
  let loc = added_length +  1 + loc  in
  if !v < s_len && s.[!v] = ')' then
    begin
      add_var_segment cxt loc 2 (-1) ;
      check_and_transform loc  s (added_length + 1 + offset) cxt
    end
  else
    pos_error cxt ~loc Unmatched_paren





(* we share the same escape sequence with js *)
and escape_code loc  s offset ({ buf; s_len} as cxt) =
  if offset >= s_len then
    pos_error cxt ~loc Unterminated_backslash
  else
    Buffer.add_char buf '\\';
  let cur_char = s.[offset] in
  match cur_char with
  | '\\'
  | 'b'
  | 't'
  | 'n'
  | 'v'
  | 'f'
  | 'r'
  | '0'
  | '$'
    ->
    begin
      Buffer.add_char buf cur_char ;
      check_and_transform (loc + 1)  s (offset + 1) cxt
    end
  | 'u' ->
    begin
      Buffer.add_char buf cur_char;
      unicode (loc + 1) s (offset + 1) cxt
    end
  | 'x' -> begin
      Buffer.add_char buf cur_char ;
      two_hex (loc + 1)  s (offset + 1) cxt
    end
  | _ -> pos_error cxt ~loc (Invalid_escape_code cur_char)
and two_hex loc  s offset ({buf ; s_len} as cxt) =
  if offset + 1 >= s_len then
    pos_error cxt ~loc Invalid_hex_escape;
  let a, b = s.[offset], s.[offset + 1] in
  if Ext_char.valid_hex a && Ext_char.valid_hex b then
    begin
      Buffer.add_char buf a ;
      Buffer.add_char buf b ;
      check_and_transform (loc + 2)  s (offset + 2) cxt
    end
  else
    pos_error cxt ~loc Invalid_hex_escape


and unicode loc  s offset ({buf ; s_len} as cxt) =
  if offset + 3 >= s_len then
    pos_error cxt ~loc Invalid_unicode_escape
  ;
  let a0,a1,a2,a3 = s.[offset], s.[offset+1], s.[offset+2], s.[offset+3] in
  if
    Ext_char.valid_hex a0 &&
    Ext_char.valid_hex a1 &&
    Ext_char.valid_hex a2 &&
    Ext_char.valid_hex a3 then
    begin
      Buffer.add_char buf a0;
      Buffer.add_char buf a1;
      Buffer.add_char buf a2;
      Buffer.add_char buf a3;
      check_and_transform (loc + 4) s  (offset + 4) cxt
    end
  else
    pos_error cxt ~loc Invalid_unicode_escape
let transform_test s =
  let s_len = String.length s in
  let buf = Buffer.create (s_len * 2) in
  let cxt =
    { segment_start = {lnum = 0; offset = 0; byte_bol = 0};
      buf ;
      s_len;
      segments = [];
      pos_lnum = 0;
      byte_bol = 0;
      pos_bol = 0;

    } in
  check_and_transform 0 s 0 cxt;
  List.rev cxt.segments


(** TODO: test empty var $() $ failure,
    Allow identifers x.A.y *)

open Ast_helper

(** Longident.parse "Pervasives.^" *)
let concat_ident  : Longident.t =
  Ldot (Lident "Pervasives", "^") (* FIXME: remove deps on `Pervasives` *)
   (* JS string concatMany *)
    (* Ldot (Ldot (Lident "Js", "String2"), "concat") *)

(* Longident.parse "Js.String.make"     *)
let to_string_ident : Longident.t =
    Ldot (Ldot (Lident "Js", "String2"), "make")


let escaped_j_delimiter =  "*j" (* not user level syntax allowed *)
let unescaped_j_delimiter = "j"
let unescaped_js_delimiter = "js"

let escaped = Some escaped_j_delimiter

let concat_exp
  (a : Parsetree.expression)
  (b : Parsetree.expression) : Parsetree.expression =
  let loc = Bs_loc.merge a.pexp_loc b.pexp_loc in
  Ast_compatible.apply_simple ~loc
  (Exp.ident { txt =concat_ident; loc})
    [a ;
     b]

let border = String.length "{j|"

let aux loc (segment : segment) =
  match segment with
  | {start ; finish; kind ; content}
    ->
    begin match kind with
      | String ->
        let loc = update border start finish  loc  in
        Ast_compatible.const_exp_string
          content ?delimiter:escaped ~loc
      | Var (soffset, foffset) ->
        let loc = {
          loc with
          loc_start = update_position  (soffset + border) start loc.loc_start ;
          loc_end = update_position (foffset + border) finish loc.loc_start
        } in
        Ast_compatible.apply_simple ~loc
          (Exp.ident ~loc {loc ; txt = to_string_ident })
          [
            Exp.ident ~loc {loc ; txt = Lident content}
          ]
    end


let transform_interp loc s =
  let s_len = String.length s in
  let buf = Buffer.create (s_len * 2 ) in
  try
    let cxt : cxt =
      { segment_start = {lnum = 0; offset = 0; byte_bol = 0};
        buf ;
        s_len;
        segments = [];
        pos_lnum = 0;
        byte_bol = 0;
        pos_bol = 0;

      } in

    check_and_transform 0 s 0 cxt;
    let rev_segments =  cxt.segments in
    match rev_segments with
    | [] ->
      Ast_compatible.const_exp_string ~loc ""  ?delimiter:escaped
    | [ segment] ->
      aux loc segment
    | a::rest ->
      Ext_list.fold_left rest (aux loc a) (fun acc x ->
          concat_exp (aux loc x) acc )        
  with
    Error (start,pos, error)
    ->
    Location.raise_errorf ~loc:(update border start pos loc )
      "%a"  pp_error error


let transform (e : Parsetree.expression) s delim : Parsetree.expression =
    if Ext_string.equal delim unescaped_js_delimiter then
        let js_str = Ast_utf8_string.transform e.pexp_loc s in
        { e with pexp_desc =
                       Pexp_constant (

            Pconst_string

                         (js_str, escaped))}
    else if Ext_string.equal delim unescaped_j_delimiter then
            transform_interp e.pexp_loc s
    else e

let is_unicode_string opt = Ext_string.equal opt escaped_j_delimiter

let is_unescaped s =
  Ext_string.equal s unescaped_j_delimiter
  || Ext_string.equal s unescaped_js_delimiter
end
module Ext_option : sig 
#1 "ext_option.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Utilities for [option] type *)

val map : 'a option -> ('a -> 'b) -> 'b option

val iter : 'a option -> ('a -> unit) -> unit

val exists : 'a option -> ('a -> bool) -> bool
end = struct
#1 "ext_option.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








let map v f = 
  match v with 
  | None -> None
  | Some x -> Some (f x )

let iter v f =   
  match v with 
  | None -> ()
  | Some x -> f x 

let exists v f =    
  match v with 
  | None -> false
  | Some x -> f x 
end
module Ext_json_types
= struct
#1 "ext_json_types.ml"
(* Copyright (C) 2015-2017 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type loc = Lexing.position
type json_str = 
  { str : string ; loc : loc}

type json_flo  =
  { flo : string ; loc : loc}
type json_array =
  { content : t array ; 
    loc_start : loc ; 
    loc_end : loc ; 
  }

and json_map = 
  { map : t String_map.t ; loc :  loc }
and t = 
  | True of loc 
  | False of loc 
  | Null of loc 
  | Flo of json_flo
  | Str of json_str
  | Arr  of json_array
  | Obj of json_map
   

end
module Ext_position : sig 
#1 "ext_position.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


type t = Lexing.position = {
    pos_fname : string ;
    pos_lnum : int ;
    pos_bol : int ;
    pos_cnum : int
}

(** [offset pos newpos]
    return a new position
    here [newpos] is zero based, the use case is that
    at position [pos], we get a string and Lexing from that string,
    therefore, we get a [newpos] and we need rebase it on top of 
    [pos]
*)
val offset : t -> t -> t 

val lexbuf_from_channel_with_fname:
    in_channel -> string -> 
    Lexing.lexbuf

val print : Format.formatter -> t -> unit 
end = struct
#1 "ext_position.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


type t = Lexing.position = {
    pos_fname : string ;
    pos_lnum : int ;
    pos_bol : int ;
    pos_cnum : int
}

let offset (x : t) (y:t) =
  {
    x with 
    pos_lnum =
       x.pos_lnum + y.pos_lnum - 1;
    pos_cnum = 
      x.pos_cnum + y.pos_cnum;
    pos_bol = 
      if y.pos_lnum = 1 then 
        x.pos_bol
      else x.pos_cnum + y.pos_bol
  }

let print fmt (pos : t) =
  Format.fprintf fmt "(line %d, column %d)" pos.pos_lnum (pos.pos_cnum - pos.pos_bol)



let lexbuf_from_channel_with_fname ic fname = 
  let x = Lexing.from_function (fun buf n -> input ic buf 0 n) in 
  let pos : t = {
    pos_fname = fname ; 
    pos_lnum = 1; 
    pos_bol = 0;
    pos_cnum = 0 (* copied from zero_pos*)
  } in 
  x.lex_start_p <- pos;
  x.lex_curr_p <- pos ; 
  x


end
module Ext_json_parse : sig 
#1 "ext_json_parse.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type error

val report_error : Format.formatter -> error -> unit 

exception Error of Lexing.position * Lexing.position * error

val parse_json_from_string : string -> Ext_json_types.t 

val parse_json_from_chan :
  string ->  in_channel -> Ext_json_types.t 

val parse_json_from_file  : string -> Ext_json_types.t


end = struct
#1 "ext_json_parse.ml"
# 1 "ext/ext_json_parse.mll"
 
type error =
  | Illegal_character of char
  | Unterminated_string
  | Unterminated_comment
  | Illegal_escape of string
  | Unexpected_token 
  | Expect_comma_or_rbracket
  | Expect_comma_or_rbrace
  | Expect_colon
  | Expect_string_or_rbrace 
  | Expect_eof 
  (* | Trailing_comma_in_obj *)
  (* | Trailing_comma_in_array *)


let fprintf  = Format.fprintf
let report_error ppf = function
  | Illegal_character c ->
      fprintf ppf "Illegal character (%s)" (Char.escaped c)
  | Illegal_escape s ->
      fprintf ppf "Illegal backslash escape in string or character (%s)" s
  | Unterminated_string -> 
      fprintf ppf "Unterminated_string"
  | Expect_comma_or_rbracket ->
    fprintf ppf "Expect_comma_or_rbracket"
  | Expect_comma_or_rbrace -> 
    fprintf ppf "Expect_comma_or_rbrace"
  | Expect_colon -> 
    fprintf ppf "Expect_colon"
  | Expect_string_or_rbrace  -> 
    fprintf ppf "Expect_string_or_rbrace"
  | Expect_eof  -> 
    fprintf ppf "Expect_eof"
  | Unexpected_token 
    ->
    fprintf ppf "Unexpected_token"
  (* | Trailing_comma_in_obj  *)
  (*   -> fprintf ppf "Trailing_comma_in_obj" *)
  (* | Trailing_comma_in_array  *)
  (*   -> fprintf ppf "Trailing_comma_in_array" *)
  | Unterminated_comment 
    -> fprintf ppf "Unterminated_comment"
         

exception Error of Lexing.position * Lexing.position * error


let () = 
  Printexc.register_printer
    (function x -> 
     match x with 
     | Error (loc_start,loc_end,error) -> 
       Some (Format.asprintf 
          "@[%a:@ %a@ -@ %a)@]" 
          report_error  error
          Ext_position.print loc_start
          Ext_position.print loc_end
       )

     | _ -> None
    )





type token = 
  | Comma
  | Eof
  | False
  | Lbrace
  | Lbracket
  | Null
  | Colon
  | Number of string
  | Rbrace
  | Rbracket
  | String of string
  | True   
  
let error  (lexbuf : Lexing.lexbuf) e = 
  raise (Error (lexbuf.lex_start_p, lexbuf.lex_curr_p, e))


let lexeme_len (x : Lexing.lexbuf) =
  x.lex_curr_pos - x.lex_start_pos

let update_loc ({ lex_curr_p; _ } as lexbuf : Lexing.lexbuf) diff =
  lexbuf.lex_curr_p <-
    {
      lex_curr_p with
      pos_lnum = lex_curr_p.pos_lnum + 1;
      pos_bol = lex_curr_p.pos_cnum - diff;
    }

let char_for_backslash = function
  | 'n' -> '\010'
  | 'r' -> '\013'
  | 'b' -> '\008'
  | 't' -> '\009'
  | c -> c

let dec_code c1 c2 c3 =
  100 * (Char.code c1 - 48) + 10 * (Char.code c2 - 48) + (Char.code c3 - 48)

let hex_code c1 c2 =
  let d1 = Char.code c1 in
  let val1 =
    if d1 >= 97 then d1 - 87
    else if d1 >= 65 then d1 - 55
    else d1 - 48 in
  let d2 = Char.code c2 in
  let val2 =
    if d2 >= 97 then d2 - 87
    else if d2 >= 65 then d2 - 55
    else d2 - 48 in
  val1 * 16 + val2

let lf = '\010'

# 124 "ext/ext_json_parse.ml"
let __ocaml_lex_tables = {
  Lexing.lex_base = 
   "\000\000\239\255\240\255\241\255\000\000\025\000\011\000\244\255\
    \245\255\246\255\247\255\248\255\249\255\000\000\000\000\000\000\
    \041\000\001\000\254\255\005\000\005\000\253\255\001\000\002\000\
    \252\255\000\000\000\000\003\000\251\255\001\000\003\000\250\255\
    \079\000\089\000\099\000\121\000\131\000\141\000\153\000\163\000\
    \001\000\253\255\254\255\023\000\255\255\006\000\246\255\189\000\
    \248\255\215\000\255\255\249\255\249\000\181\000\252\255\009\000\
    \063\000\075\000\234\000\251\255\032\001\250\255";
  Lexing.lex_backtrk = 
   "\255\255\255\255\255\255\255\255\013\000\013\000\016\000\255\255\
    \255\255\255\255\255\255\255\255\255\255\016\000\016\000\016\000\
    \016\000\016\000\255\255\000\000\012\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\013\000\255\255\013\000\255\255\013\000\255\255\
    \255\255\255\255\255\255\001\000\255\255\255\255\255\255\008\000\
    \255\255\255\255\255\255\255\255\006\000\006\000\255\255\006\000\
    \001\000\002\000\255\255\255\255\255\255\255\255";
  Lexing.lex_default = 
   "\001\000\000\000\000\000\000\000\255\255\255\255\255\255\000\000\
    \000\000\000\000\000\000\000\000\000\000\255\255\255\255\255\255\
    \255\255\255\255\000\000\255\255\020\000\000\000\255\255\255\255\
    \000\000\255\255\255\255\255\255\000\000\255\255\255\255\000\000\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \042\000\000\000\000\000\255\255\000\000\047\000\000\000\047\000\
    \000\000\051\000\000\000\000\000\255\255\255\255\000\000\255\255\
    \255\255\255\255\255\255\000\000\255\255\000\000";
  Lexing.lex_trans = 
   "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\019\000\018\000\018\000\019\000\017\000\019\000\255\255\
    \048\000\019\000\255\255\057\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \019\000\000\000\003\000\000\000\000\000\019\000\000\000\000\000\
    \050\000\000\000\000\000\043\000\008\000\006\000\033\000\016\000\
    \004\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\
    \005\000\005\000\007\000\004\000\005\000\005\000\005\000\005\000\
    \005\000\005\000\005\000\005\000\005\000\032\000\044\000\033\000\
    \056\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\
    \005\000\005\000\005\000\021\000\057\000\000\000\000\000\000\000\
    \020\000\000\000\000\000\012\000\000\000\011\000\032\000\056\000\
    \000\000\025\000\049\000\000\000\000\000\032\000\014\000\024\000\
    \028\000\000\000\000\000\057\000\026\000\030\000\013\000\031\000\
    \000\000\000\000\022\000\027\000\015\000\029\000\023\000\000\000\
    \000\000\000\000\039\000\010\000\039\000\009\000\032\000\038\000\
    \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\
    \038\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\037\000\000\000\037\000\000\000\
    \035\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\
    \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\
    \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\
    \036\000\036\000\036\000\036\000\036\000\036\000\036\000\255\255\
    \035\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\
    \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\
    \038\000\038\000\038\000\038\000\038\000\000\000\000\000\255\255\
    \000\000\056\000\000\000\000\000\055\000\058\000\058\000\058\000\
    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\054\000\
    \000\000\054\000\000\000\000\000\000\000\000\000\054\000\000\000\
    \002\000\041\000\000\000\000\000\000\000\255\255\046\000\053\000\
    \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\
    \053\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\255\255\059\000\059\000\059\000\059\000\059\000\059\000\
    \059\000\059\000\059\000\059\000\000\000\000\000\000\000\000\000\
    \000\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\
    \060\000\060\000\060\000\054\000\000\000\000\000\000\000\000\000\
    \000\000\054\000\060\000\060\000\060\000\060\000\060\000\060\000\
    \000\000\000\000\000\000\000\000\000\000\054\000\000\000\000\000\
    \000\000\054\000\000\000\054\000\000\000\000\000\000\000\052\000\
    \061\000\061\000\061\000\061\000\061\000\061\000\061\000\061\000\
    \061\000\061\000\060\000\060\000\060\000\060\000\060\000\060\000\
    \000\000\061\000\061\000\061\000\061\000\061\000\061\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\061\000\061\000\061\000\061\000\061\000\061\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\255\255\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\255\255\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000";
  Lexing.lex_check = 
   "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\000\000\000\000\017\000\000\000\000\000\019\000\020\000\
    \045\000\019\000\020\000\055\000\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \000\000\255\255\000\000\255\255\255\255\019\000\255\255\255\255\
    \045\000\255\255\255\255\040\000\000\000\000\000\004\000\000\000\
    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
    \000\000\000\000\000\000\006\000\006\000\006\000\006\000\006\000\
    \006\000\006\000\006\000\006\000\006\000\004\000\043\000\005\000\
    \056\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\
    \005\000\005\000\005\000\016\000\057\000\255\255\255\255\255\255\
    \016\000\255\255\255\255\000\000\255\255\000\000\005\000\056\000\
    \255\255\014\000\045\000\255\255\255\255\004\000\000\000\023\000\
    \027\000\255\255\255\255\057\000\025\000\029\000\000\000\030\000\
    \255\255\255\255\015\000\026\000\000\000\013\000\022\000\255\255\
    \255\255\255\255\032\000\000\000\032\000\000\000\005\000\032\000\
    \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
    \032\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\
    \033\000\033\000\033\000\034\000\034\000\034\000\034\000\034\000\
    \034\000\034\000\034\000\034\000\034\000\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\035\000\255\255\035\000\255\255\
    \034\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\
    \035\000\035\000\035\000\036\000\036\000\036\000\036\000\036\000\
    \036\000\036\000\036\000\036\000\036\000\037\000\037\000\037\000\
    \037\000\037\000\037\000\037\000\037\000\037\000\037\000\047\000\
    \034\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\
    \038\000\038\000\038\000\039\000\039\000\039\000\039\000\039\000\
    \039\000\039\000\039\000\039\000\039\000\255\255\255\255\047\000\
    \255\255\049\000\255\255\255\255\049\000\053\000\053\000\053\000\
    \053\000\053\000\053\000\053\000\053\000\053\000\053\000\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\049\000\
    \255\255\049\000\255\255\255\255\255\255\255\255\049\000\255\255\
    \000\000\040\000\255\255\255\255\255\255\020\000\045\000\049\000\
    \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\
    \049\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\047\000\058\000\058\000\058\000\058\000\058\000\058\000\
    \058\000\058\000\058\000\058\000\255\255\255\255\255\255\255\255\
    \255\255\052\000\052\000\052\000\052\000\052\000\052\000\052\000\
    \052\000\052\000\052\000\049\000\255\255\255\255\255\255\255\255\
    \255\255\049\000\052\000\052\000\052\000\052\000\052\000\052\000\
    \255\255\255\255\255\255\255\255\255\255\049\000\255\255\255\255\
    \255\255\049\000\255\255\049\000\255\255\255\255\255\255\049\000\
    \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\
    \060\000\060\000\052\000\052\000\052\000\052\000\052\000\052\000\
    \255\255\060\000\060\000\060\000\060\000\060\000\060\000\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\060\000\060\000\060\000\060\000\060\000\060\000\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\047\000\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\049\000\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    \255\255";
  Lexing.lex_base_code = 
   "";
  Lexing.lex_backtrk_code = 
   "";
  Lexing.lex_default_code = 
   "";
  Lexing.lex_trans_code = 
   "";
  Lexing.lex_check_code = 
   "";
  Lexing.lex_code = 
   "";
}

let rec lex_json buf lexbuf =
    __ocaml_lex_lex_json_rec buf lexbuf 0
and __ocaml_lex_lex_json_rec buf lexbuf __ocaml_lex_state =
  match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with
      | 0 ->
# 142 "ext/ext_json_parse.mll"
          ( lex_json buf lexbuf)
# 314 "ext/ext_json_parse.ml"

  | 1 ->
# 143 "ext/ext_json_parse.mll"
                   ( 
    update_loc lexbuf 0;
    lex_json buf  lexbuf
  )
# 322 "ext/ext_json_parse.ml"

  | 2 ->
# 147 "ext/ext_json_parse.mll"
                ( comment buf lexbuf)
# 327 "ext/ext_json_parse.ml"

  | 3 ->
# 148 "ext/ext_json_parse.mll"
         ( True)
# 332 "ext/ext_json_parse.ml"

  | 4 ->
# 149 "ext/ext_json_parse.mll"
          (False)
# 337 "ext/ext_json_parse.ml"

  | 5 ->
# 150 "ext/ext_json_parse.mll"
         (Null)
# 342 "ext/ext_json_parse.ml"

  | 6 ->
# 151 "ext/ext_json_parse.mll"
       (Lbracket)
# 347 "ext/ext_json_parse.ml"

  | 7 ->
# 152 "ext/ext_json_parse.mll"
       (Rbracket)
# 352 "ext/ext_json_parse.ml"

  | 8 ->
# 153 "ext/ext_json_parse.mll"
       (Lbrace)
# 357 "ext/ext_json_parse.ml"

  | 9 ->
# 154 "ext/ext_json_parse.mll"
       (Rbrace)
# 362 "ext/ext_json_parse.ml"

  | 10 ->
# 155 "ext/ext_json_parse.mll"
       (Comma)
# 367 "ext/ext_json_parse.ml"

  | 11 ->
# 156 "ext/ext_json_parse.mll"
        (Colon)
# 372 "ext/ext_json_parse.ml"

  | 12 ->
# 157 "ext/ext_json_parse.mll"
                      (lex_json buf lexbuf)
# 377 "ext/ext_json_parse.ml"

  | 13 ->
# 159 "ext/ext_json_parse.mll"
         ( Number (Lexing.lexeme lexbuf))
# 382 "ext/ext_json_parse.ml"

  | 14 ->
# 161 "ext/ext_json_parse.mll"
      (
  let pos = Lexing.lexeme_start_p lexbuf in
  scan_string buf pos lexbuf;
  let content = (Buffer.contents  buf) in 
  Buffer.clear buf ;
  String content 
)
# 393 "ext/ext_json_parse.ml"

  | 15 ->
# 168 "ext/ext_json_parse.mll"
       (Eof )
# 398 "ext/ext_json_parse.ml"

  | 16 ->
let
# 169 "ext/ext_json_parse.mll"
       c
# 404 "ext/ext_json_parse.ml"
= Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos in
# 169 "ext/ext_json_parse.mll"
          ( error lexbuf (Illegal_character c ))
# 408 "ext/ext_json_parse.ml"

  | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; 
      __ocaml_lex_lex_json_rec buf lexbuf __ocaml_lex_state

and comment buf lexbuf =
    __ocaml_lex_comment_rec buf lexbuf 40
and __ocaml_lex_comment_rec buf lexbuf __ocaml_lex_state =
  match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with
      | 0 ->
# 171 "ext/ext_json_parse.mll"
              (lex_json buf lexbuf)
# 420 "ext/ext_json_parse.ml"

  | 1 ->
# 172 "ext/ext_json_parse.mll"
     (comment buf lexbuf)
# 425 "ext/ext_json_parse.ml"

  | 2 ->
# 173 "ext/ext_json_parse.mll"
       (error lexbuf Unterminated_comment)
# 430 "ext/ext_json_parse.ml"

  | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; 
      __ocaml_lex_comment_rec buf lexbuf __ocaml_lex_state

and scan_string buf start lexbuf =
    __ocaml_lex_scan_string_rec buf start lexbuf 45
and __ocaml_lex_scan_string_rec buf start lexbuf __ocaml_lex_state =
  match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with
      | 0 ->
# 177 "ext/ext_json_parse.mll"
      ( () )
# 442 "ext/ext_json_parse.ml"

  | 1 ->
# 179 "ext/ext_json_parse.mll"
  (
        let len = lexeme_len lexbuf - 2 in
        update_loc lexbuf len;

        scan_string buf start lexbuf
      )
# 452 "ext/ext_json_parse.ml"

  | 2 ->
# 186 "ext/ext_json_parse.mll"
      (
        let len = lexeme_len lexbuf - 3 in
        update_loc lexbuf len;
        scan_string buf start lexbuf
      )
# 461 "ext/ext_json_parse.ml"

  | 3 ->
let
# 191 "ext/ext_json_parse.mll"
                                               c
# 467 "ext/ext_json_parse.ml"
= Lexing.sub_lexeme_char lexbuf (lexbuf.Lexing.lex_start_pos + 1) in
# 192 "ext/ext_json_parse.mll"
      (
        Buffer.add_char buf (char_for_backslash c);
        scan_string buf start lexbuf
      )
# 474 "ext/ext_json_parse.ml"

  | 4 ->
let
# 196 "ext/ext_json_parse.mll"
                 c1
# 480 "ext/ext_json_parse.ml"
= Lexing.sub_lexeme_char lexbuf (lexbuf.Lexing.lex_start_pos + 1)
and
# 196 "ext/ext_json_parse.mll"
                               c2
# 485 "ext/ext_json_parse.ml"
= Lexing.sub_lexeme_char lexbuf (lexbuf.Lexing.lex_start_pos + 2)
and
# 196 "ext/ext_json_parse.mll"
                                             c3
# 490 "ext/ext_json_parse.ml"
= Lexing.sub_lexeme_char lexbuf (lexbuf.Lexing.lex_start_pos + 3)
and
# 196 "ext/ext_json_parse.mll"
                                                    s
# 495 "ext/ext_json_parse.ml"
= Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos (lexbuf.Lexing.lex_start_pos + 4) in
# 197 "ext/ext_json_parse.mll"
      (
        let v = dec_code c1 c2 c3 in
        if v > 255 then
          error lexbuf (Illegal_escape s) ;
        Buffer.add_char buf (Char.chr v);

        scan_string buf start lexbuf
      )
# 506 "ext/ext_json_parse.ml"

  | 5 ->
let
# 205 "ext/ext_json_parse.mll"
                        c1
# 512 "ext/ext_json_parse.ml"
= Lexing.sub_lexeme_char lexbuf (lexbuf.Lexing.lex_start_pos + 2)
and
# 205 "ext/ext_json_parse.mll"
                                         c2
# 517 "ext/ext_json_parse.ml"
= Lexing.sub_lexeme_char lexbuf (lexbuf.Lexing.lex_start_pos + 3) in
# 206 "ext/ext_json_parse.mll"
      (
        let v = hex_code c1 c2 in
        Buffer.add_char buf (Char.chr v);

        scan_string buf start lexbuf
      )
# 526 "ext/ext_json_parse.ml"

  | 6 ->
let
# 212 "ext/ext_json_parse.mll"
             c
# 532 "ext/ext_json_parse.ml"
= Lexing.sub_lexeme_char lexbuf (lexbuf.Lexing.lex_start_pos + 1) in
# 213 "ext/ext_json_parse.mll"
      (
        Buffer.add_char buf '\\';
        Buffer.add_char buf c;

        scan_string buf start lexbuf
      )
# 541 "ext/ext_json_parse.ml"

  | 7 ->
# 220 "ext/ext_json_parse.mll"
      (
        update_loc lexbuf 0;
        Buffer.add_char buf lf;

        scan_string buf start lexbuf
      )
# 551 "ext/ext_json_parse.ml"

  | 8 ->
# 227 "ext/ext_json_parse.mll"
      (
        let ofs = lexbuf.lex_start_pos in
        let len = lexbuf.lex_curr_pos - ofs in
        Buffer.add_subbytes buf lexbuf.lex_buffer ofs len;

        scan_string buf start lexbuf
      )
# 562 "ext/ext_json_parse.ml"

  | 9 ->
# 235 "ext/ext_json_parse.mll"
      (
        error lexbuf Unterminated_string
      )
# 569 "ext/ext_json_parse.ml"

  | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; 
      __ocaml_lex_scan_string_rec buf start lexbuf __ocaml_lex_state

;;

# 239 "ext/ext_json_parse.mll"
 






let rec parse_json lexbuf =
  let buf = Buffer.create 64 in 
  let look_ahead = ref None in
  let token () : token = 
    match !look_ahead with 
    | None ->  
      lex_json buf lexbuf 
    | Some x -> 
      look_ahead := None ;
      x 
  in
  let push e = look_ahead := Some e in 
  let rec json (lexbuf : Lexing.lexbuf) : Ext_json_types.t = 
    match token () with 
    | True -> True lexbuf.lex_start_p
    | False -> False lexbuf.lex_start_p
    | Null -> Null lexbuf.lex_start_p
    | Number s ->  Flo {flo = s; loc = lexbuf.lex_start_p}  
    | String s -> Str { str = s; loc =    lexbuf.lex_start_p}
    | Lbracket -> parse_array  lexbuf.lex_start_p lexbuf.lex_curr_p [] lexbuf
    | Lbrace -> parse_map lexbuf.lex_start_p String_map.empty lexbuf
    |  _ -> error lexbuf Unexpected_token
(** Note if we remove [trailing_comma] support 
    we should report errors (actually more work), for example 
    {[
    match token () with 
    | Rbracket ->
      if trailing_comma then
        error lexbuf Trailing_comma_in_array
      else
    ]} 
    {[
    match token () with 
    | Rbrace -> 
      if trailing_comma then
        error lexbuf Trailing_comma_in_obj
      else

    ]}   
 *)
  and parse_array   loc_start loc_finish acc lexbuf 
    : Ext_json_types.t =
    match token () with 
    | Rbracket ->
        Arr {loc_start ; content = Ext_array.reverse_of_list acc ; 
              loc_end = lexbuf.lex_curr_p }
    | x -> 
      push x ;
      let new_one = json lexbuf in 
      begin match token ()  with 
      | Comma -> 
          parse_array  loc_start loc_finish (new_one :: acc) lexbuf 
      | Rbracket 
        -> Arr {content = (Ext_array.reverse_of_list (new_one::acc));
                     loc_start ; 
                     loc_end = lexbuf.lex_curr_p }
      | _ -> 
        error lexbuf Expect_comma_or_rbracket
      end
  and parse_map loc_start  acc lexbuf : Ext_json_types.t = 
    match token () with 
    | Rbrace -> 
        Obj { map = acc ; loc = loc_start}
    | String key -> 
      begin match token () with 
      | Colon ->
        let value = json lexbuf in
        begin match token () with 
        | Rbrace -> Obj {map = String_map.add acc key value  ; loc = loc_start}
        | Comma -> 
          parse_map loc_start  (String_map.add acc key value ) lexbuf 
        | _ -> error lexbuf Expect_comma_or_rbrace
        end
      | _ -> error lexbuf Expect_colon
      end
    | _ -> error lexbuf Expect_string_or_rbrace
  in 
  let v = json lexbuf in 
  match token () with 
  | Eof -> v 
  | _ -> error lexbuf Expect_eof

let parse_json_from_string s = 
  parse_json (Lexing.from_string s )

let parse_json_from_chan fname in_chan = 
  let lexbuf = 
    Ext_position.lexbuf_from_channel_with_fname
    in_chan fname in 
  parse_json lexbuf 

let parse_json_from_file s = 
  let in_chan = open_in s in 
  let lexbuf = 
    Ext_position.lexbuf_from_channel_with_fname
    in_chan s in 
  match parse_json lexbuf with 
  | exception e -> close_in in_chan ; raise e
  | v  -> close_in in_chan;  v





# 688 "ext/ext_json_parse.ml"

end
module External_arg_spec : sig 
#1 "external_arg_spec.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type cst = private
  | Arg_int_lit of int 
  | Arg_string_lit of string 
  | Arg_js_null
  | Arg_js_true
  | Arg_js_false
  | Arg_js_json of string


type label = private
  | Label of string * cst option 
  | Empty of cst option
  | Optional of string 
  (* it will be ignored , side effect will be recorded *)

type attr = 
  | NullString of (int * string) list (* `a does not have any value*)
  | NonNullString of (int * string) list (* `a of int *)
  | Int of (int * int ) list (* ([`a | `b ] [@bs.int])*)
  | Arg_cst of cst
  | Fn_uncurry_arity of int (* annotated with [@bs.uncurry ] or [@bs.uncurry 2]*)
  (* maybe we can improve it as a combination of {!Asttypes.constant} and tuple *)
  | Extern_unit
  | Nothing
  | Ignore
  | Unwrap

type t = 
  {
    arg_type : attr;
    arg_label :label
  }

val cst_json : Location.t -> string -> cst 
val cst_int : int -> cst 
val cst_string : string -> cst 

val empty_label : label
val empty_lit : cst -> label 
val label :  string -> cst option -> label
val optional  : string -> label
val empty_kind : attr -> t

end = struct
#1 "external_arg_spec.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

(** type definitions for external argument *)

type cst = 
  | Arg_int_lit of int 
  | Arg_string_lit of string 

  | Arg_js_null
  | Arg_js_true
  | Arg_js_false
  | Arg_js_json of string
type label = 
  | Label of string * cst option 
  | Empty of cst option
  | Optional of string 
  (* it will be ignored , side effect will be recorded *)

type attr = 
  | NullString of (int * string) list (* `a does not have any value*)
  | NonNullString of (int * string) list (* `a of int *)
  | Int of (int * int ) list (* ([`a | `b ] [@bs.int])*)
  | Arg_cst of cst
  | Fn_uncurry_arity of int (* annotated with [@bs.uncurry ] or [@bs.uncurry 2]*)
    (* maybe we can improve it as a combination of {!Asttypes.constant} and tuple *)
  | Extern_unit
  | Nothing
  | Ignore
  | Unwrap

type t = 
  {
    arg_type : attr;
    arg_label : label
  }


exception Error of Location.t * Ext_json_parse.error

let pp_invaild_json fmt err = 
  Format.fprintf fmt "@[Invalid json literal:  %a@]@." 
    Ext_json_parse.report_error err

let () = 
  Location.register_error_of_exn (function 
    | Error (loc,err) ->       
      Some (Location.error_of_printer loc pp_invaild_json err)
    | _ -> None
    )


let cst_json (loc : Location.t) s : cst  =
  match Ext_json_parse.parse_json_from_string s with 
  | True _ -> Arg_js_true
  | False _ -> Arg_js_false 
  | Null _ -> Arg_js_null 
  | _ -> Arg_js_json s 
  | exception Ext_json_parse.Error (start,finish,error_info)
    ->
    let loc1 = {
      loc with
       loc_start = 
        Ext_position.offset loc.loc_start start; 
       loc_end =   
       Ext_position.offset loc.loc_start finish;
    } in 
     raise (Error (loc1 , error_info))

let cst_int i = Arg_int_lit i 
let cst_string s = Arg_string_lit s 
let empty_label = Empty None 
let empty_lit s = Empty (Some s) 
let label s cst = Label(s,cst)
let optional s = Optional s 

let empty_kind arg_type = { arg_label = empty_label ; arg_type }

end
module Lam_pointer_info : sig 
#1 "lam_pointer_info.mli"
(* Copyright (C) 2018- Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


type t = 
  | Pt_constructor of string 
  | Pt_variant of string 
  | Pt_module_alias
  | Pt_na 

end = struct
#1 "lam_pointer_info.ml"
(* Copyright (C) 2018- Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


type t = 
  | Pt_constructor of string 
  | Pt_variant of string 
  | Pt_module_alias
  | Pt_na 

end
module Lam_tag_info
= struct
#1 "lam_tag_info.ml"
(* Copyright (C) 2018-Present Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

(* Similiar to {!Lambda.tag_info}
  In particular, 
  it reduces some branches e.g, 
  [Blk_some], [Blk_some_not_nested]
*)
type t = 
  | Blk_constructor of string * int
  | Blk_tuple
  | Blk_array
  | Blk_variant of string 
  | Blk_record of string array 
  | Blk_module of string list option
  | Blk_extension_slot
  | Blk_na

  | Blk_record_inlined of string array * string * int
  | Blk_record_ext of string array

end
module Lam_constant : sig 
#1 "lam_constant.mli"
(* Copyright (C) 2018- Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type t =
  | Const_js_null
  | Const_js_undefined
  | Const_js_true
  | Const_js_false
  | Const_int of int
  | Const_char of char
  | Const_string of string  (* use record later *)
  | Const_unicode of string
  | Const_float of string
  | Const_int32 of int32
  | Const_int64 of int64
  | Const_nativeint of nativeint
  | Const_pointer of int * Lam_pointer_info.t
  | Const_block of int * Lam_tag_info.t * t list
  | Const_float_array of string list
  | Const_immstring of string
  | Const_some of t 
    (* eventually we can remove it, since we know
      [constant] is [undefined] or not 
    *) 
val eq_approx : t -> t -> bool
val lam_none : t   
end = struct
#1 "lam_constant.ml"
(* Copyright (C) 2018- Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

 type t =
  | Const_js_null
  | Const_js_undefined
  | Const_js_true
  | Const_js_false
  | Const_int of int
  | Const_char of char
  | Const_string of string  (* use record later *)
  | Const_unicode of string
  | Const_float of string
  | Const_int32 of int32
  | Const_int64 of int64
  | Const_nativeint of nativeint
  | Const_pointer of int * Lam_pointer_info.t
  | Const_block of int * Lam_tag_info.t * t list
  | Const_float_array of string list
  | Const_immstring of string
  | Const_some of t 
    (* eventually we can remove it, since we know
      [constant] is [undefined] or not 
    *) 


let rec eq_approx (x : t) (y : t) = 
  match x with 
  | Const_js_null -> y = Const_js_null
  | Const_js_undefined -> y =  Const_js_undefined
  | Const_js_true -> y = Const_js_true
  | Const_js_false -> y =  Const_js_false
  | Const_int ix -> 
    (match y with Const_int iy -> ix = iy | _ -> false)
  | Const_char ix ->   
    (match y with Const_char iy -> ix = iy | _ -> false)
  | Const_string ix -> 
    (match y with Const_string iy -> ix = iy | _ -> false)
  | Const_unicode ix ->   
    (match y with Const_unicode iy -> ix = iy | _ -> false)
  | Const_float  ix -> 
    (match y with Const_float iy -> ix = iy | _ -> false)
  | Const_int32 ix ->   
    (match y with Const_int32 iy -> ix = iy | _ -> false)
  | Const_int64 ix ->   
    (match y with Const_int64 iy -> ix = iy | _ -> false)
  | Const_nativeint ix ->   
    (match y with Const_nativeint iy -> ix = iy | _ -> false)
  | Const_pointer (ix,_) ->   
    (match y with Const_pointer (iy,_) -> ix = iy | _ -> false)
  | Const_block(ix,_,ixs) -> 
    (match y with Const_block(iy,_,iys) -> ix = iy && Ext_list.for_all2_no_exn ixs iys eq_approx
    | _ -> false)
  | Const_float_array ixs ->   
    (match y with Const_float_array iys -> 
      Ext_list.for_all2_no_exn ixs iys Ext_string.equal
    | _ -> false
    )
  | Const_immstring ix ->   
   (match y with Const_immstring iy -> ix = iy | _ -> false)
  | Const_some ix ->  
    (match y with Const_some iy -> eq_approx ix iy | _ -> false)


let lam_none : t = 
   Const_js_undefined 

end
module External_ffi_types : sig 
#1 "external_ffi_types.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type module_bind_name =
  | Phint_name of string
  (* explicit hint name *)
  | Phint_nothing

type external_module_name =
  { bundle : string ;
    module_bind_name : module_bind_name
  }

type pipe = bool
type js_call = {
  name : string;
  external_module_name : external_module_name option;
  splice : bool ;
  scopes : string list
}

type js_send = {
  name : string ;
  splice : bool ;
  pipe : pipe  ;
  js_send_scopes : string list;
} (* we know it is a js send, but what will happen if you pass an ocaml objct *)

type js_var = {
  name : string ;
  external_module_name : external_module_name option;
  scopes : string list
}

type js_new_val = {
  name : string ;
  external_module_name : external_module_name option;
  scopes : string list;
}

type js_module_as_fn =
  { external_module_name : external_module_name;
    splice : bool
  }

type arg_type = External_arg_spec.attr

type arg_label = External_arg_spec.label


type obj_create = External_arg_spec.t list

type js_get =
  { js_get_name : string   ;
    js_get_scopes :  string list;
  }

type js_set =
  { js_set_name : string  ;
    js_set_scopes : string list
  }


type js_get_index =   {
  js_get_index_scopes : string list
}

type js_set_index = {
  js_set_index_scopes : string list
}



type external_spec  =
  | Js_var of js_var
  | Js_module_as_var of  external_module_name
  | Js_module_as_fn of js_module_as_fn
  | Js_module_as_class of external_module_name
  | Js_call of js_call
  | Js_send of js_send
  | Js_new of js_new_val
  | Js_set of js_set
  | Js_get of js_get
  | Js_get_index of js_get_index
  | Js_set_index of js_set_index

type return_wrapper =
  | Return_unset
  | Return_identity
  | Return_undefined_to_opt
  | Return_null_to_opt
  | Return_null_undefined_to_opt
  | Return_replaced_with_unit

type t  =
  | Ffi_bs of
      External_arg_spec.t list  *
      return_wrapper *
      external_spec
  | Ffi_obj_create of obj_create
  | Ffi_inline_const of Lam_constant.t
  | Ffi_normal
  (* When it's normal, it is handled as normal c functional ffi call *)


val name_of_ffi : external_spec -> string

val check_ffi : ?loc:Location.t ->  external_spec -> bool

val to_string : t -> string

(** Note *)
val from_string : string -> t

val inline_string_primitive : 
  string -> 
  string option -> 
  string list 

val inline_bool_primitive :   
  bool -> 
  string list

val inline_int_primitive :   
  int -> 
  string list
end = struct
#1 "external_ffi_types.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type module_bind_name =
  | Phint_name of string
    (* explicit hint name *)

  | Phint_nothing


type external_module_name =
  { bundle : string ;
    module_bind_name : module_bind_name
  }

type pipe = bool
type js_call = {
  name : string;
  external_module_name : external_module_name option;
  splice : bool ;
  scopes : string list ;
}

type js_send = {
  name : string ;
  splice : bool ;
  pipe : pipe   ;
  js_send_scopes : string list;
} (* we know it is a js send, but what will happen if you pass an ocaml objct *)

type js_var = {
  name : string ;
  external_module_name : external_module_name option;
  scopes : string list ;
}

type js_new_val = {
  name : string ;
  external_module_name : external_module_name option;
  scopes : string list;
}

type js_module_as_fn =
  { external_module_name : external_module_name;
    splice : bool ;
  }
type js_get =
  { js_get_name : string   ;
    js_get_scopes :  string list;
  }

type js_set =
  { js_set_name : string  ;
    js_set_scopes : string list
  }

type js_get_index =   {
  js_get_index_scopes : string list
}

type js_set_index = {
  js_set_index_scopes : string list
}
(** TODO: information between [arg_type] and [arg_label] are duplicated,
  design a more compact representation so that it is also easy to seralize by hand
*)
type arg_type = External_arg_spec.attr

type arg_label = External_arg_spec.label


(**TODO: maybe we can merge [arg_label] and [arg_type] *)
type obj_create = External_arg_spec.t list

type external_spec =
  | Js_var of js_var
  | Js_module_as_var of  external_module_name
  | Js_module_as_fn of js_module_as_fn
  | Js_module_as_class of external_module_name
  | Js_call of js_call
  | Js_send of js_send
  | Js_new of js_new_val
  | Js_set of js_set
  | Js_get of js_get
  | Js_get_index of js_get_index
  | Js_set_index of js_set_index

(* let not_inlineable (x : external_spec) =     *)


let name_of_ffi ffi =
  match ffi with
  | Js_get_index _scope -> "[@@bs.get_index ..]"
  | Js_set_index _scope -> "[@@bs.set_index ..]"
  | Js_get { js_get_name = s} -> Printf.sprintf "[@@bs.get %S]" s
  | Js_set { js_set_name = s} -> Printf.sprintf "[@@bs.set %S]" s
  | Js_call v  -> Printf.sprintf "[@@bs.val %S]" v.name
  | Js_send v  -> Printf.sprintf "[@@bs.send %S]" v.name
  | Js_module_as_fn v  -> Printf.sprintf "[@@bs.val %S]" v.external_module_name.bundle
  | Js_new v  -> Printf.sprintf "[@@bs.new %S]" v.name
  | Js_module_as_class v
    -> Printf.sprintf "[@@bs.module] %S " v.bundle
  | Js_module_as_var v
    ->
    Printf.sprintf "[@@bs.module] %S " v.bundle
  | Js_var v (* FIXME: could be [@@bs.module "xx"] as well *)
    ->
    Printf.sprintf "[@@bs.val] %S " v.name

type return_wrapper =
  | Return_unset
  | Return_identity
  | Return_undefined_to_opt
  | Return_null_to_opt
  | Return_null_undefined_to_opt
  | Return_replaced_with_unit
type t  =
  | Ffi_bs of External_arg_spec.t list  *
     return_wrapper * external_spec
  (**  [Ffi_bs(args,return,attr) ]
       [return] means return value is unit or not,
        [true] means is [unit]
  *)
  | Ffi_obj_create of obj_create
  | Ffi_inline_const of Lam_constant.t
  | Ffi_normal
  (* When it's normal, it is handled as normal c functional ffi call *)



let valid_js_char =
  let a = Array.init 256 (fun i ->
      let c = Char.chr i in
      (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || (c >= '0' && c <= '9') || c = '_' || c = '$'
    ) in
  (fun c -> Array.unsafe_get a (Char.code c))

let valid_first_js_char =
  let a = Array.init 256 (fun i ->
      let c = Char.chr i in
      (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || c = '_' || c = '$'
    ) in
  (fun c -> Array.unsafe_get a (Char.code c))

(** Approximation could be improved *)
let valid_ident (s : string) =
  let len = String.length s in
  len > 0 && valid_js_char s.[0] && valid_first_js_char s.[0] &&
  (let module E = struct exception E end in
   try
     for i = 1 to len - 1 do
       if not (valid_js_char (String.unsafe_get s i)) then
         raise E.E
     done ;
     true
   with E.E -> false )

let is_package_relative_path (x : string) = 
     Ext_string.starts_with x "./" ||
     Ext_string.starts_with x "../"
  
let valid_global_name ?loc txt =
  if not (valid_ident txt) then
    let v = Ext_string.split_by ~keep_empty:true (fun x -> x = '.') txt in
    Ext_list.iter v
      (fun s ->
         if not (valid_ident s) then
           Location.raise_errorf ?loc "Not a valid global name %s"  txt
      ) 

(*
  We loose such check (see #2583),
  it also helps with the implementation deriving abstract [@bs.as]
*)

let valid_method_name ?loc txt =
    ()
  (* if not (valid_ident txt) then
    Location.raise_errorf ?loc "Not a valid method name %s"  txt *)



let check_external_module_name ?loc x =
  match x with
  | {bundle = ""; _ }
  | { module_bind_name = Phint_name "" } ->
    Location.raise_errorf ?loc "empty name encountered"
  | _ -> ()



let check_ffi ?loc ffi : bool =  
  let xrelative = ref false in 
  let upgrade bool =    
    if not (!xrelative) then xrelative := bool in 
  begin match ffi with
  | Js_var {name; external_module_name} ->     
    upgrade (is_package_relative_path name);
    Ext_option.iter external_module_name (fun name -> 
    upgrade (is_package_relative_path name.bundle));
    valid_global_name ?loc  name
  | Js_send {name }
  | Js_set  {js_set_name = name}
  | Js_get { js_get_name = name}
    ->  valid_method_name ?loc name
  | Js_get_index  _ (* TODO: check scopes *)
  | Js_set_index _
    -> ()

  | Js_module_as_var external_module_name
  | Js_module_as_fn {external_module_name; splice = _}
  | Js_module_as_class external_module_name
    -> 
      upgrade (is_package_relative_path external_module_name.bundle);
      check_external_module_name external_module_name
  | Js_new {external_module_name ;  name}
  | Js_call {external_module_name ;  name ; splice = _; scopes = _ }
    ->
    Ext_option.iter external_module_name (fun external_module_name ->
        upgrade (is_package_relative_path external_module_name.bundle));
    Ext_option.iter external_module_name (fun name ->
        check_external_module_name ?loc name
      );

    valid_global_name ?loc name 
  end; 
  !xrelative

let bs_prefix = "BS:"
let bs_prefix_length = String.length bs_prefix


(** TODO: Make sure each version is not prefix of each other
    Solution:
    1. fixed length
    2. non-prefix approach
*)
let bs_external = bs_prefix ^ Bs_version.version


let bs_external_length = String.length bs_external


let to_string  t =
  bs_external ^ Marshal.to_string t []


(* TODO:  better error message when version mismatch *)
let from_string s : t =
  let s_len = String.length s in
  if s_len >= bs_prefix_length &&
     String.unsafe_get s 0 = 'B' &&
     String.unsafe_get s 1 = 'S' &&
     String.unsafe_get s 2 = ':' then
    if Ext_string.starts_with s bs_external then
      Marshal.from_string s bs_external_length
    else
      Ext_fmt.failwithf
        ~loc:__LOC__
        "Compiler version mismatch. The project might have been built with one version of BuckleScript, and then with another. Please wipe the artifacts and do a clean build."
  else Ffi_normal


let inline_string_primitive (s : string) (op : string option) : string list = 
  let lam : Lam_constant.t = 
    match op with 
    | Some op
    when Ast_utf8_string_interp.is_unicode_string op ->
      Const_unicode s
    | _ ->
      (Const_string s) in 
  [""; to_string (Ffi_inline_const lam )]

(* Let's only do it for string ATM
    for boolean, and ints, a good optimizer should     
    do it by default?
    But it may not work after layers of indirection
    e.g, submodule
*)
let inline_bool_primitive b : string list = 
  let lam : Lam_constant.t = 
    if  b then Lam_constant.Const_js_true 
    else Lam_constant.Const_js_false
  in 
  [""; to_string (Ffi_inline_const lam )]

(* FIXME: check overflow ?*)
let inline_int_primitive i : string list =   
  [""; 
    to_string 
    (Ffi_inline_const 
      (Lam_constant.Const_int32 (Int32.of_int i)))
  ]
end
module Ext_arg : sig 
#1 "ext_arg.mli"
val bad_argf : ('a, unit, string, 'b) format4 -> 'a

end = struct
#1 "ext_arg.ml"
let bad_argf fmt = Format.ksprintf (fun x -> raise (Arg.Bad x ) ) fmt
end
module Js_packages_info : sig 
#1 "js_packages_info.mli"
(* Copyright (C) 2017 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


type module_system = 
  | NodeJS  
  | Es6
  | Es6_global  

  
val runtime_dir_of_module_system :  
  module_system ->
  string

val runtime_package_path:  
  module_system ->
  string ->
  string

type package_info 
  = 
  { 
    module_system : module_system ;
    path :  string 
  }

type t 

val is_runtime_package:
  t ->
  bool

val same_package_by_name :   
  t ->
  t -> 
  bool 

val iter : 
  t -> 
  (package_info -> unit) ->
  unit 

val empty : t 
val from_name : string -> t 
val is_empty : t -> bool 

val dump_packages_info : 
  Format.formatter -> t -> unit


(** used by command line option 
  e.g [-bs-package-output commonjs:xx/path]
*)
val add_npm_package_path :   
  t ->
  string -> 
  t  

type package_found_info =     
  {

    rel_path : string ;  
    pkg_rel_path : string   
  }

type info_query =
  | Package_script 
  | Package_not_found 
  | Package_found of package_found_info

val get_output_dir:  
  t ->
  package_dir:string ->
  module_system ->
  string

val query_package_infos:  
  t ->
  module_system ->
  info_query
(** Note here we compare the package info by order
  in theory, we can compare it by set semantics
*)



end = struct
#1 "js_packages_info.ml"
(* Copyright (C) 2017 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

[@@@ocaml.warning "+9"]

type path = string

type module_system =
  | NodeJS 
  | Es6
  | Es6_global (* ignore node_modules, just calcluating relative path *)
  

(* ocamlopt could not optimize such simple case..*)
let compatible (dep : module_system) 
    (query : module_system) =
  match query with 
  | NodeJS -> dep = NodeJS 
  | Es6  -> dep = Es6
  | Es6_global  
    -> dep = Es6_global || dep = Es6
(* As a dependency Leaf Node, it is the same either [global] or [not] *)


type package_info =
  { module_system : module_system ; path :  string }

type package_name  = 
  | Pkg_empty 
  | Pkg_runtime 
  | Pkg_normal of string



let runtime_package_name = "bs-platform"


let (//) = Filename.concat    

(* in runtime lib, [es6] and [es6] are treated the same wway *)
let runtime_dir_of_module_system (ms : module_system ) = 
  match ms with 
  | NodeJS -> "js"
  | Es6 | Es6_global -> "es6"

let runtime_package_path 
    (ms : module_system) 
    js_file =        
  runtime_package_name // "lib" // runtime_dir_of_module_system ms // js_file


type t =
  { 
    name : package_name ;
    module_systems: package_info  list
  }

let same_package_by_name (x : t) (y : t) = x.name = y.name 

let is_runtime_package (x : t) = 
    x.name = Pkg_runtime

let iter (x : t) cb =    
  Ext_list.iter x.module_systems cb 

(* let equal (x : t) ({name; module_systems}) = 
    x.name = name && 
    Ext_list.for_all2_no_exn
      x.module_systems module_systems
      (fun (a0,a1) (b0,b1) -> a0 = b0 && a1 = b1) *)

(* we don't want force people to use package *) 

(** 
   TODO: not allowing user to provide such specific package name 
   For empty package, [-bs-package-output] does not make sense
   it is only allowed to generate commonjs file in the same directory
*)  
let empty : t = 
  { name = Pkg_empty ;
    module_systems =  []
  }

let from_name (name : string) =
  if name = runtime_package_name then 
    {
      name = Pkg_runtime ; module_systems = [] 
    }
  else 
    {
      name = Pkg_normal name  ;
      module_systems = [] 
    }

let is_empty  (x : t) =
  x.name = Pkg_empty
  

let string_of_module_system (ms : module_system) = 
  match ms with 
  | NodeJS -> "NodeJS"
  | Es6 -> "Es6"
  | Es6_global -> "Es6_global"
  

let module_system_of_string package_name : module_system option = 
  match package_name with
  | "commonjs" -> Some NodeJS
  | "es6" -> Some Es6
  | "es6-global" -> Some Es6_global
  | _ -> None 

let dump_package_info 
    (fmt : Format.formatter)
    ({module_system = ms; path =  name} : package_info)
  = 
  Format.fprintf
    fmt 
    "@[%s:@ %s@]"
    (string_of_module_system ms)
    name 

let dump_package_name fmt (x : package_name) = 
  match x with 
  | Pkg_empty -> Format.fprintf fmt "@empty_pkg@"
  | Pkg_normal s -> Format.pp_print_string fmt s 
  | Pkg_runtime -> Format.pp_print_string fmt runtime_package_name

let dump_packages_info 
    (fmt : Format.formatter) 
    ({name ; module_systems = ls } : t) = 
  Format.fprintf fmt "@[%a;@ @[%a@]@]"
    dump_package_name
    name
    (Format.pp_print_list
       ~pp_sep:(fun fmt () -> Format.pp_print_space fmt ())
       dump_package_info 
    ) ls

type package_found_info =     
  {

    rel_path : string ;     
    pkg_rel_path : string
  }
type info_query =
  | Package_script 
  | Package_not_found 
  | Package_found of package_found_info

(* Note that package-name has to be exactly the same as 
  npm package name, otherwise the path resolution will be wrong *)
let query_package_infos 
    ({name; module_systems } : t) 
    (module_system  : module_system) : info_query =
  match name with 
  | Pkg_empty -> 
    Package_script 
  | Pkg_normal name ->
    (match Ext_list.find_first module_systems (fun k -> 
        compatible k.module_system  module_system)  with
    | Some k -> 
      let rel_path = k.path in 
      let pkg_rel_path = name // rel_path in 
      Package_found 
        { 
          rel_path ;
          pkg_rel_path 
        }
    | None -> Package_not_found)
  | Pkg_runtime -> 
    match Ext_list.find_first module_systems (fun k -> 
        compatible k.module_system  module_system)  with
    | Some k -> 
      let rel_path = k.path in 
      let pkg_rel_path = runtime_package_name // rel_path in 
      Package_found 
        { 
          rel_path ;
          pkg_rel_path 
        }
    | None -> Package_not_found



let get_js_path 
    (x : t )
    module_system 
  = 
  match Ext_list.find_first x.module_systems (fun k -> 
      compatible k.module_system  module_system) with
  | Some k ->  k.path
  | None -> assert false

(* for a single pass compilation, [output_dir]
   can be cached
*)
let get_output_dir 
    (info: t )
    ~package_dir module_system 
  =
  Filename.concat package_dir 
    (get_js_path info module_system)




let add_npm_package_path (packages_info : t) (s : string)  : t =
  if is_empty packages_info then 
    Ext_arg.bad_argf "please set package name first using -bs-package-name "
  else   
    let module_system, path =
      match Ext_string.split ~keep_empty:false s ':' with
      | [ module_system; path]  ->
        (match module_system_of_string module_system with
         | Some x -> x
         | None ->
           Ext_arg.bad_argf "invalid module system %s" module_system), path
      | [path] ->
        NodeJS, path
      | module_system :: path -> 
        (match module_system_of_string module_system with 
        | Some x -> x
        | None -> Ext_arg.bad_argf "invalid module system %s" module_system), (String.concat ":" path)
      | _ ->
        Ext_arg.bad_argf "invalid npm package path: %s" s
    in
    { packages_info with module_systems = {module_system; path}::packages_info.module_systems}

(* support es6 modules instead
   TODO: enrich ast to support import export 
   http://www.ecma-international.org/ecma-262/6.0/#sec-imports
   For every module, we need [Ident.t] for accessing and [filename] for import, 
   they are not necessarily the same.

   Es6 modules is not the same with commonjs, we use commonjs currently
   (play better with node)

   FIXME: the module order matters?
*)


end
module Lam_compat : sig 
#1 "lam_compat.mli"
(* Copyright (C) 2018 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


 type array_kind = Lambda.array_kind = 
      Pgenarray | Paddrarray | Pintarray | Pfloatarray
  (*TODO: only [Pfloatarray] makes sense *)


type boxed_integer = Lambda.boxed_integer = 
    Pnativeint | Pint32 | Pint64


type comparison = Lambda.comparison = 
    Ceq | Cneq | Clt | Cgt | Cle | Cge

type bigarray_kind = Lambda.bigarray_kind = 
    Pbigarray_unknown
  | Pbigarray_float32 | Pbigarray_float64
  | Pbigarray_sint8 | Pbigarray_uint8
  | Pbigarray_sint16 | Pbigarray_uint16
  | Pbigarray_int32 | Pbigarray_int64
  | Pbigarray_caml_int | Pbigarray_native_int
  | Pbigarray_complex32 | Pbigarray_complex64


type bigarray_layout = Lambda.bigarray_layout = 
    Pbigarray_unknown_layout
  | Pbigarray_c_layout
  | Pbigarray_fortran_layout



type compile_time_constant = Lambda.compile_time_constant = 
 

  | Big_endian
  | Word_size
  | Int_size
  | Max_wosize
  | Ostype_unix
  | Ostype_win32
  | Ostype_cygwin
  | Backend_type


type let_kind = Lambda.let_kind
= Strict
| Alias
| StrictOpt
| Variable

type meth_kind = Lambda.meth_kind
= Self
| Public of string option
| Cached


type field_dbg_info = Lambda.field_dbg_info =
  | Fld_na
  | Fld_record of string
  | Fld_module of string 
 
  | Fld_record_inline of string 
  | Fld_record_extension of string 
  
  
type set_field_dbg_info = Lambda.set_field_dbg_info = 
  | Fld_set_na
  | Fld_record_set of string 
     
  | Fld_record_inline_set of string  
  | Fld_record_extension_set of string
  

val cmp_int32 : comparison -> int32 -> int32 -> bool 
val cmp_int64 : comparison -> int64 -> int64 -> bool 
val cmp_nativeint : comparison -> nativeint -> nativeint -> bool
val cmp_float : comparison -> float -> float -> bool 
val cmp_int : comparison -> int -> int -> bool 

val eq_comparison : comparison -> comparison -> bool
val eq_array_kind : array_kind -> array_kind -> bool
val eq_boxed_integer: boxed_integer -> boxed_integer -> bool
val eq_compile_time_constant : compile_time_constant -> compile_time_constant -> bool
end = struct
#1 "lam_compat.ml"
(* Copyright (C) 2018 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


type array_kind = Lambda.array_kind = 
      Pgenarray | Paddrarray | Pintarray | Pfloatarray


let eq_array_kind (p : array_kind) (p1 : array_kind) = 
  match p with 
  | Pgenarray -> p1 = Pgenarray
  | Paddrarray -> p1 = Paddrarray 
  | Pintarray -> p1 = Pintarray
  | Pfloatarray -> p1 = Pfloatarray       

type boxed_integer = Lambda.boxed_integer = 
    Pnativeint | Pint32 | Pint64


let eq_boxed_integer (p : boxed_integer) (p1 : boxed_integer ) = 
  match p with 
  | Pnativeint -> p1 = Pnativeint 
  | Pint32 -> p1 = Pint32
  | Pint64 -> p1 = Pint64    

type comparison = Lambda.comparison = 
    Ceq | Cneq | Clt | Cgt | Cle | Cge


let eq_comparison ( p : comparison) (p1:comparison) = 
  match p with 
  | Cge -> p1 =  Cge
  | Cgt -> p1 =  Cgt
  | Cle -> p1 =  Cle
  | Clt -> p1 =  Clt 
  | Ceq -> p1 =  Ceq 
  | Cneq -> p1 =  Cneq 



let cmp_int32 (cmp : comparison) (a : int32) b : bool =
  match cmp with
  | Ceq -> a = b
  | Cneq -> a <> b
  | Cgt -> a > b
  | Cle -> a <= b
  | Clt -> a < b
  | Cge -> a >= b

let cmp_int64 (cmp : comparison) (a : int64) b : bool =
  match cmp with
  | Ceq -> a = b
  | Cneq -> a <> b
  | Cgt -> a > b
  | Cle -> a <= b
  | Clt -> a < b
  | Cge -> a >= b

let cmp_nativeint (cmp : comparison) (a : nativeint) b : bool =
  match cmp with
  | Ceq -> a = b
  | Cneq -> a <> b
  | Cgt -> a > b
  | Cle -> a <= b
  | Clt -> a < b
  | Cge -> a >= b

let cmp_float (cmp : comparison) (a : float) b : bool =
  match cmp with
  | Ceq -> a = b
  | Cneq -> a <> b
  | Cgt -> a > b
  | Cle -> a <= b
  | Clt -> a < b
  | Cge -> a >= b

let cmp_int (cmp : comparison) (a : int) b : bool =
  match cmp with
  | Ceq -> a = b
  | Cneq -> a <> b
  | Cgt -> a > b
  | Cle -> a <= b
  | Clt -> a < b
  | Cge -> a >= b



type bigarray_kind = Lambda.bigarray_kind = 
    Pbigarray_unknown
  | Pbigarray_float32 | Pbigarray_float64
  | Pbigarray_sint8 | Pbigarray_uint8
  | Pbigarray_sint16 | Pbigarray_uint16
  | Pbigarray_int32 | Pbigarray_int64
  | Pbigarray_caml_int | Pbigarray_native_int
  | Pbigarray_complex32 | Pbigarray_complex64


let eq_bigarray_kind (p : bigarray_kind) (p1 : bigarray_kind) = 
  match p with   
  | Pbigarray_unknown -> p1 = Pbigarray_unknown
  | Pbigarray_float32 -> p1 = Pbigarray_float32
  | Pbigarray_float64 -> p1 =  Pbigarray_float64
  | Pbigarray_sint8 -> p1 = Pbigarray_sint8
  | Pbigarray_uint8 -> p1 = Pbigarray_uint8
  | Pbigarray_sint16 -> p1 = Pbigarray_sint16 
  | Pbigarray_uint16 -> p1 = Pbigarray_uint16
  | Pbigarray_int32  -> p1 = Pbigarray_int32
  | Pbigarray_int64 -> p1 = Pbigarray_int64
  | Pbigarray_caml_int -> p1 = Pbigarray_caml_int
  | Pbigarray_native_int -> p1 = Pbigarray_native_int
  | Pbigarray_complex32  -> p1 = Pbigarray_complex32
  | Pbigarray_complex64 -> p1 = Pbigarray_complex64
  
  
type bigarray_layout = Lambda.bigarray_layout = 
    Pbigarray_unknown_layout
  | Pbigarray_c_layout
  | Pbigarray_fortran_layout




let eq_bigarray_layout (p : bigarray_layout) (p1 : bigarray_layout) = 
  match p with 
  | Pbigarray_unknown_layout -> p1 = Pbigarray_unknown_layout
  | Pbigarray_c_layout -> p1 = Pbigarray_c_layout
  | Pbigarray_fortran_layout -> p1 = Pbigarray_fortran_layout  

type compile_time_constant = Lambda.compile_time_constant = 
   
    | Big_endian
    | Word_size
    | Int_size
    | Max_wosize
    | Ostype_unix
    | Ostype_win32
    | Ostype_cygwin
    | Backend_type
  
  

(** relies on the fact that [compile_time_constant] is enum type *)
let eq_compile_time_constant ( p : compile_time_constant) (p1 : compile_time_constant) = 
  p = p1

type let_kind = Lambda.let_kind
= Strict
| Alias
| StrictOpt
| Variable


type meth_kind = Lambda.meth_kind
  = Self
| Public of string option
| Cached

type field_dbg_info = Lambda.field_dbg_info =
  | Fld_na
  | Fld_record of string
  | Fld_module of string 
 
  | Fld_record_inline of string 
  | Fld_record_extension of string 
  

type set_field_dbg_info = Lambda.set_field_dbg_info = 
  | Fld_set_na
  | Fld_record_set of string 
     
  | Fld_record_inline_set of string  
  | Fld_record_extension_set of string
  
end
module Primitive_compat : sig 
#1 "primitive_compat.mli"
(* Copyright (C) 2018- Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


 type t = {
  prim_name : string;
  prim_arity : int ; 
  prim_native_name : string;
}


val of_primitive_description:
  Primitive.description -> 
  t 
end = struct
#1 "primitive_compat.ml"
(* Copyright (C) 2018- Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

 type t = {
   prim_name : string;
   prim_arity : int ; 
   prim_native_name : string
 }
    
let of_primitive_description (x : Primitive.description) =  
  {
    prim_name = x.prim_name;
    prim_arity = x.prim_arity;
    prim_native_name = x.prim_native_name
  }
end
module Lam_primitive : sig 
#1 "lam_primitive.mli"
(* Copyright (C) 2018 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



type ident = Ident.t 

type record_representation = Types.record_representation =  
    | Record_regular
    | Record_float

    | Record_unboxed of bool    (* Unboxed single-field record, inlined or not *)
    | Record_inlined of { tag : int; name : string; num_nonconsts : int}               (* Inlined record *)
    | Record_extension                    (* Inlined record under extension *)
  

type t = 
  | Pbytes_to_string
  | Pbytes_of_string
  | Pglobal_exception of ident 
  | Pmakeblock of int * Lam_tag_info.t * Asttypes.mutable_flag
  | Pfield of int * Lambda.field_dbg_info
  | Psetfield of int  * Lambda.set_field_dbg_info
  | Pfloatfield of int * Lambda.field_dbg_info
  | Psetfloatfield of int * Lambda.set_field_dbg_info
  | Pduprecord of record_representation * int
  | Plazyforce

  | Pccall of  Primitive_compat.t
  | Pjs_call of
    (* Location.t *  [loc] is passed down *)
    string *  (* prim_name *)
    External_arg_spec.t list * (* arg_types *)
    External_ffi_types.external_spec  (* ffi *)
  | Pjs_object_create of External_ffi_types.obj_create

  | Praise 
  | Psequand | Psequor | Pnot
  | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint
  | Pandint | Porint | Pxorint
  | Plslint | Plsrint | Pasrint
  | Pintcomp of Lam_compat.comparison
  | Poffsetint of int
  | Poffsetref of int
  | Pintoffloat | Pfloatofint
  | Pnegfloat 
  (* | Pabsfloat *)
  | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
  | Pfloatcomp of Lam_compat.comparison
  | Pjscomp of Lam_compat.comparison
  | Pjs_apply (*[f;arg0;arg1; arg2; ... argN]*)
  | Pjs_runtime_apply (* [f; [...]] *)
  | Pstringlength 
  | Pstringrefu 
  | Pstringrefs
  | Pstringadd    
  | Pbyteslength
  | Pbytesrefu
  | Pbytessetu 
  | Pbytesrefs
  | Pbytessets
  (* Array operations *)
  | Pmakearray of Lam_compat.array_kind
  | Parraylength 
  | Parrayrefu 
  | Parraysetu 
  | Parrayrefs 
  | Parraysets 
  (* Test if the argument is a block or an immediate integer *)
  | Pisint
  (* Test if the (integer) argument is outside an interval *)
  | Pisout
  (* Bitvect operations *)
  | Pbittest
  (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *)
  | Pbintofint of Lam_compat.boxed_integer
  | Pintofbint of Lam_compat.boxed_integer
  | Pcvtbint of Lam_compat.boxed_integer (*source*) * Lam_compat.boxed_integer (*destination*)
  | Pnegbint of Lam_compat.boxed_integer
  | Paddbint of Lam_compat.boxed_integer
  | Psubbint of Lam_compat.boxed_integer
  | Pmulbint of Lam_compat.boxed_integer
  | Pdivbint of Lam_compat.boxed_integer
  | Pmodbint of Lam_compat.boxed_integer
  | Pandbint of Lam_compat.boxed_integer
  | Porbint of Lam_compat.boxed_integer
  | Pxorbint of Lam_compat.boxed_integer
  | Plslbint of Lam_compat.boxed_integer
  | Plsrbint of Lam_compat.boxed_integer
  | Pasrbint of Lam_compat.boxed_integer
  | Pbintcomp of Lam_compat.boxed_integer * Lam_compat.comparison
  (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *)
  | Pbigarrayref of bool * int * Lam_compat.bigarray_kind * Lam_compat.bigarray_layout
  | Pbigarrayset of bool * int * Lam_compat.bigarray_kind * Lam_compat.bigarray_layout
  (* size of the nth dimension of a big array *)
  | Pbigarraydim of int
  (* load/set 16,32,64 bits from a string: (unsafe)*)
  | Pstring_load_16 of bool
  | Pstring_load_32 of bool
  | Pstring_load_64 of bool
  | Pstring_set_16 of bool
  | Pstring_set_32 of bool
  | Pstring_set_64 of bool
  (* load/set 16,32,64 bits from a
     (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *)
  | Pbigstring_load_16 of bool
  | Pbigstring_load_32 of bool
  | Pbigstring_load_64 of bool
  | Pbigstring_set_16 of bool
  | Pbigstring_set_32 of bool
  | Pbigstring_set_64 of bool
  (* Compile time constants *)
  | Pctconst of Lam_compat.compile_time_constant
  (* byte swap *)
  | Pbswap16
  | Pbbswap of Lam_compat.boxed_integer
  (* Integer to external pointer *)

  | Pdebugger
  | Pjs_unsafe_downgrade of string * Location.t
  | Pinit_mod
  | Pupdate_mod

  | Praw_js_code_exp of string 
  | Praw_js_code_stmt of string 
  | Praw_js_function of string * string list
  | Pjs_fn_make of int 
  | Pjs_fn_run of int 
  | Pjs_fn_method of int 
  | Pjs_fn_runmethod of int 
  | Pundefined_to_opt
  | Pnull_to_opt
  | Pnull_undefined_to_opt 
  
  | Pis_null
  | Pis_undefined
  | Pis_null_undefined

  | Pjs_typeof
  | Pjs_function_length 
  | Pcaml_obj_length
  | Pwrap_exn (* convert either JS exception or OCaml exception into OCaml format *)  

  (* | Pcreate_exception of string  *)
  | Pcreate_extension of string 
  | Pis_not_none
  | Pval_from_option
  | Pval_from_option_not_nest
  | Psome
  | Psome_not_nest


  | Pfield_computed (* Mostly used in object compilation *)
  | Psetfield_computed

val eq_primitive_approx : t -> t -> bool  
end = struct
#1 "lam_primitive.ml"
(* Copyright (C) 2018 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

[@@@ocaml.warning "+9"]

type ident = Ident.t
  
type record_representation = Types.record_representation =  
    | Record_regular
    | Record_float

    | Record_unboxed of bool    (* Unboxed single-field record, inlined or not *)
    | Record_inlined of {tag : int; name : string; num_nonconsts : int}               (* Inlined record *)
    | Record_extension                    (* Inlined record under extension *)
  

type t =
  | Pbytes_to_string
  | Pbytes_of_string
  | Pglobal_exception of ident
  (* Operations on heap blocks *)
  | Pmakeblock of int * Lam_tag_info.t * Asttypes.mutable_flag
  | Pfield of int * Lam_compat.field_dbg_info
  | Psetfield of int * Lam_compat.set_field_dbg_info
  (* could have field info at least for record *)
  | Pfloatfield of int * Lam_compat.field_dbg_info
  | Psetfloatfield of int * Lam_compat.set_field_dbg_info
  | Pduprecord of record_representation * int
  (* Force lazy values *)
  | Plazyforce
  (* External call *)
  | Pccall of  Primitive_compat.t
  | Pjs_call of
      string *  (* prim_name *)
      External_arg_spec.t list * (* arg_types *)
      External_ffi_types.external_spec  (* ffi *)
  | Pjs_object_create of External_ffi_types.obj_create
  (* Exceptions *)
  | Praise
  (* Boolean operations *)
  | Psequand | Psequor | Pnot
  (* Integer operations *)
  | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint
  | Pandint | Porint | Pxorint
  | Plslint | Plsrint | Pasrint
  | Pintcomp of Lam_compat.comparison
  | Poffsetint of int
  | Poffsetref of int
  (* Float operations *)
  | Pintoffloat | Pfloatofint
  | Pnegfloat 
  (* | Pabsfloat *) (* is {!Pervasives.abs_float} %abs_float*)
  | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
  | Pfloatcomp of Lam_compat.comparison
  | Pjscomp of Lam_compat.comparison
  | Pjs_apply (*[f;arg0;arg1; arg2; ... argN]*)
  | Pjs_runtime_apply (* [f; [...]] *)
  (* String operations *)
  | Pstringlength
  | Pstringrefu
  | Pstringrefs
  | Pstringadd
  | Pbyteslength
  | Pbytesrefu
  | Pbytessetu
  | Pbytesrefs
  | Pbytessets
  (* Array operations *)
  | Pmakearray of Lam_compat.array_kind
  | Parraylength 
  | Parrayrefu
  | Parraysetu
  | Parrayrefs
  | Parraysets
  (* Test if the argument is a block or an immediate integer *)
  | Pisint
  (* Test if the (integer) argument is outside an interval *)
  | Pisout
  (* Bitvect operations *)
  | Pbittest
  (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *)
  | Pbintofint of Lam_compat.boxed_integer
  | Pintofbint of Lam_compat.boxed_integer
  | Pcvtbint of Lam_compat.boxed_integer (*source*) * Lam_compat.boxed_integer (*destination*)
  | Pnegbint of Lam_compat.boxed_integer
  | Paddbint of Lam_compat.boxed_integer
  | Psubbint of Lam_compat.boxed_integer
  | Pmulbint of Lam_compat.boxed_integer
  | Pdivbint of Lam_compat.boxed_integer
  | Pmodbint of Lam_compat.boxed_integer
  | Pandbint of Lam_compat.boxed_integer
  | Porbint of Lam_compat.boxed_integer
  | Pxorbint of Lam_compat.boxed_integer
  | Plslbint of Lam_compat.boxed_integer
  | Plsrbint of Lam_compat.boxed_integer
  | Pasrbint of Lam_compat.boxed_integer
  | Pbintcomp of Lam_compat.boxed_integer * Lam_compat.comparison
  (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *)
  | Pbigarrayref of bool * int * Lam_compat.bigarray_kind * Lam_compat.bigarray_layout
  | Pbigarrayset of bool * int * Lam_compat.bigarray_kind * Lam_compat.bigarray_layout
  (* size of the nth dimension of a big array *)
  | Pbigarraydim of int
  (* load/set 16,32,64 bits from a string: (unsafe)*)
  | Pstring_load_16 of bool
  | Pstring_load_32 of bool
  | Pstring_load_64 of bool
  | Pstring_set_16 of bool
  | Pstring_set_32 of bool
  | Pstring_set_64 of bool
  (* load/set 16,32,64 bits from a
     (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *)
  | Pbigstring_load_16 of bool
  | Pbigstring_load_32 of bool
  | Pbigstring_load_64 of bool
  | Pbigstring_set_16 of bool
  | Pbigstring_set_32 of bool
  | Pbigstring_set_64 of bool
  (* Compile time constants *)
  | Pctconst of Lam_compat.compile_time_constant
  (* byte swap *)
  | Pbswap16
  | Pbbswap of Lam_compat.boxed_integer
  (* Integer to external pointer *)

  | Pdebugger
  | Pjs_unsafe_downgrade of string * Location.t
  | Pinit_mod
  | Pupdate_mod
  | Praw_js_code_exp of string
  | Praw_js_code_stmt of string
  | Praw_js_function of string * string list
  | Pjs_fn_make of int
  | Pjs_fn_run of int
  | Pjs_fn_method of int
  | Pjs_fn_runmethod of int

  | Pundefined_to_opt
  | Pnull_to_opt
  | Pnull_undefined_to_opt
  | Pis_null
  | Pis_undefined
  | Pis_null_undefined
  | Pjs_typeof
  | Pjs_function_length
  | Pcaml_obj_length
  | Pwrap_exn (* convert either JS exception or OCaml exception into OCaml format *)

  (* | Pcreate_exception of string  *)
  | Pcreate_extension of string
  | Pis_not_none (* no info about its type *)
  | Pval_from_option
  | Pval_from_option_not_nest
  | Psome
  | Psome_not_nest  

  | Pfield_computed (* Mostly used in object compilation *)
  | Psetfield_computed




let eq_record_representation ( p : record_representation) ( p1 : record_representation) = 
  match p with 
  | Record_float -> p1 = Record_float
  | Record_regular -> p1 = Record_regular
 
  | Record_unboxed b0 -> 
    (match p1 with 
    |Record_unboxed b1 -> b0 = b1 | _ -> false)
  | Record_inlined {tag = a0; name = a1; num_nonconsts = a2 } -> 
    (match p1 with 
    |Record_inlined {tag = b0; name = b1; num_nonconsts = b2} ->
       a0 = b0 && a1 = b1 && a2 = b2
    | _ -> false)
  | Record_extension -> 
    p1 = Record_extension   

let eq_primitive_approx ( lhs : t) (rhs : t) = 
  match lhs with 
  | Pcreate_extension a -> begin match rhs with Pcreate_extension b -> a = (b : string) | _ -> false end
  | Pwrap_exn -> rhs = Pwrap_exn
  | Pbytes_to_string ->  rhs = Pbytes_to_string 
  | Pbytes_of_string ->  rhs = Pbytes_of_string
  | Praise -> rhs = Praise
  | Psequand -> rhs = Psequand
  | Psequor -> rhs = Psequor 
  | Pnot -> rhs = Pnot 
  | Pnegint -> rhs = Pnegint
  | Paddint -> rhs = Paddint 
  | Psubint -> rhs = Psubint
  | Pmulint -> rhs = Pmulint
  | Pdivint -> rhs = Pdivint
  | Pmodint -> rhs = Pmodint 
  | Pandint -> rhs = Pandint
  | Porint  -> rhs = Porint
  | Pxorint -> rhs = Pxorint
  | Plslint -> rhs = Plslint
  | Plsrint -> rhs = Plsrint
  | Pasrint -> rhs = Pasrint      
  | Pval_from_option -> rhs = Pval_from_option
  | Pval_from_option_not_nest -> rhs = Pval_from_option_not_nest
  | Plazyforce -> rhs = Plazyforce
  | Pintoffloat -> rhs = Pintoffloat
  | Pfloatofint -> rhs = Pfloatofint
  | Pnegfloat -> rhs =  Pnegfloat
  (* | Pabsfloat -> rhs = Pabsfloat *)
  | Paddfloat -> rhs = Paddfloat
  | Psubfloat -> rhs = Psubfloat
  | Pmulfloat -> rhs = Pmulfloat
  | Pdivfloat -> rhs = Pdivfloat
  | Pjs_apply -> rhs = Pjs_apply
  | Pjs_runtime_apply -> rhs = Pjs_runtime_apply
  | Pstringlength ->  rhs = Pstringlength
  | Pstringrefu ->  rhs = Pstringrefu
  | Pstringrefs ->  rhs = Pstringrefs
  | Pstringadd  ->  rhs = Pstringadd   
  | Pbyteslength -> rhs = Pbyteslength
  | Pbytesrefu ->   rhs = Pbytesrefu
  | Pbytessetu ->   rhs = Pbytessetu
  | Pbytesrefs ->   rhs = Pbytesrefs
  | Pbytessets ->   rhs = Pbytessets  
  | Pundefined_to_opt -> rhs = Pundefined_to_opt
  | Pnull_to_opt -> rhs = Pnull_to_opt
  | Pnull_undefined_to_opt -> rhs = Pnull_undefined_to_opt  
  | Pis_null -> rhs = Pis_null
  | Pis_not_none -> rhs = Pis_not_none 
  | Psome -> rhs = Psome
  | Psome_not_nest -> rhs = Psome_not_nest 
  | Pis_undefined -> rhs = Pis_undefined
  | Pis_null_undefined -> rhs = Pis_null_undefined
  | Pjs_typeof -> rhs = Pjs_typeof
  | Pisint -> rhs = Pisint
  | Pisout -> rhs = Pisout
  | Pbittest -> rhs = Pbittest
  | Pdebugger -> rhs = Pdebugger    
  | Pinit_mod -> rhs = Pinit_mod
  | Pupdate_mod -> rhs = Pupdate_mod
  | Pbswap16 -> rhs = Pbswap16
  | Pjs_function_length -> rhs = Pjs_function_length
  (* | Pjs_string_of_small_array -> rhs = Pjs_string_of_small_array *)
  (* | Pjs_is_instance_array -> rhs = Pjs_is_instance_array *)
  | Pcaml_obj_length -> rhs = Pcaml_obj_length
  (* | Pcaml_obj_set_length -> rhs = Pcaml_obj_set_length *)
  | Pccall {prim_name = n0 ;  prim_native_name = nn0; _} -> 
   (match rhs with 
   | Pccall {prim_name = n1; prim_native_name = nn1; _} 
    -> n0 = n1 && nn0 = nn1 
   | _ -> false )    
  | Pfield (n0, _dbg_info0) ->  (match rhs with Pfield (n1, _dbg_info1) ->  n0 = n1  | _ -> false )    
  | Psetfield(i0, _dbg_info0) -> (match rhs with Psetfield(i1, _dbg_info1) ->  i0 = i1  | _ -> false)
  | Pglobal_exception ident -> (match rhs with Pglobal_exception ident2 ->  Ident.same ident ident2 | _ -> false )
  | Pmakeblock (i, _tag_info, mutable_flag) -> (match rhs with Pmakeblock(i1,_,mutable_flag1) ->  i = i1 && mutable_flag = mutable_flag1  | _ -> false)
  | Pfloatfield (i0,_dbg_info) -> (match rhs with Pfloatfield (i1,_) -> i0 = i1   | _ -> false)
  | Psetfloatfield (i0,_dbg_info) ->  (match rhs with Psetfloatfield(i1,_) -> i0 = i1  | _ -> false)
  | Pduprecord (record_repesentation0,i1) -> (match rhs with Pduprecord(record_repesentation1,i2) ->  eq_record_representation record_repesentation0 record_repesentation1 && i1 = i2    | _ -> false)
  | Pjs_call (prim_name, arg_types, ffi) ->  ( match rhs with Pjs_call(prim_name1, arg_types1,ffi1) -> prim_name = prim_name1 && arg_types = arg_types1 && ffi = ffi1 | _ -> false)
  | Pjs_object_create obj_create -> (match rhs with Pjs_object_create obj_create1 -> obj_create = obj_create1 | _ -> false )
  | Pintcomp comparison -> (match rhs with Pintcomp comparison1 -> Lam_compat.eq_comparison comparison  comparison1  | _ -> false )    
  | Pfloatcomp comparison -> (match rhs with Pfloatcomp comparison1 -> Lam_compat.eq_comparison comparison  comparison1 | _ -> false)
  | Pjscomp comparison ->  (match rhs with  Pjscomp comparison1 -> Lam_compat.eq_comparison comparison  comparison1  | _ -> false )    
  | Poffsetint i0 ->   (match rhs with  Poffsetint i1 -> i0 = i1 | _ -> false )   
  | Poffsetref i0 ->  (match rhs with Poffsetref i1 -> i0 = i1   | _ -> false)
  | Pmakearray array_kind -> (match rhs with Pmakearray array_kind1 -> Lam_compat.eq_array_kind array_kind array_kind1 | _ -> false  )
  | Parraylength  -> rhs = Parraylength
  | Parrayrefu  -> rhs = Parrayrefu
  | Parraysetu  -> rhs = Parraysetu
  | Parrayrefs -> rhs = Parrayrefs
  | Parraysets -> rhs = Parraysets
  | Pbintofint  boxed_integer -> (match rhs with Pbintofint boxed_integer1 -> Lam_compat.eq_boxed_integer boxed_integer boxed_integer1 | _ -> false )
  | Pintofbint  boxed_integer -> (match rhs with Pintofbint boxed_integer1 -> Lam_compat.eq_boxed_integer boxed_integer boxed_integer1 | _ -> false )
  | Pnegbint  boxed_integer -> (match rhs with Pnegbint boxed_integer1 -> Lam_compat.eq_boxed_integer boxed_integer boxed_integer1 | _ -> false )
  | Paddbint  boxed_integer -> (match rhs with Paddbint boxed_integer1 -> Lam_compat.eq_boxed_integer boxed_integer boxed_integer1 | _ -> false )
  | Psubbint  boxed_integer -> (match rhs with Psubbint boxed_integer1 -> Lam_compat.eq_boxed_integer boxed_integer boxed_integer1 | _ -> false )
  | Pmulbint  boxed_integer -> (match rhs with Pmulbint boxed_integer1 -> Lam_compat.eq_boxed_integer boxed_integer boxed_integer1 | _ -> false )
  | Pdivbint  boxed_integer -> (match rhs with Pdivbint boxed_integer1 -> Lam_compat.eq_boxed_integer boxed_integer boxed_integer1 | _ -> false )
  | Pmodbint  boxed_integer -> (match rhs with Pmodbint boxed_integer1 -> Lam_compat.eq_boxed_integer boxed_integer boxed_integer1 | _ -> false )
  | Pandbint  boxed_integer -> (match rhs with Pandbint boxed_integer1 -> Lam_compat.eq_boxed_integer boxed_integer boxed_integer1 | _ -> false )
  | Porbint boxed_integer ->   (match rhs with Porbint  boxed_integer1 -> Lam_compat.eq_boxed_integer boxed_integer boxed_integer1 | _ -> false )
  | Pxorbint  boxed_integer -> (match rhs with Pxorbint boxed_integer1 -> Lam_compat.eq_boxed_integer boxed_integer boxed_integer1 | _ -> false )
  | Plslbint  boxed_integer -> (match rhs with Plslbint boxed_integer1 -> Lam_compat.eq_boxed_integer boxed_integer boxed_integer1 | _ -> false )
  | Plsrbint  boxed_integer -> (match rhs with Plsrbint boxed_integer1 -> Lam_compat.eq_boxed_integer boxed_integer boxed_integer1 | _ -> false )
  | Pasrbint  boxed_integer -> (match rhs with Pasrbint boxed_integer1 -> Lam_compat.eq_boxed_integer boxed_integer boxed_integer1 | _ -> false )
  | Pbbswap boxed_integer ->   (match rhs with Pbbswap boxed_integer1  -> Lam_compat.eq_boxed_integer boxed_integer boxed_integer1 | _ -> false )
  | Pcvtbint  (boxed_integer, boxed_integer1) -> (match rhs with Pcvtbint (boxed_integer10, boxed_integer11) -> Lam_compat.eq_boxed_integer boxed_integer boxed_integer10 && Lam_compat.eq_boxed_integer boxed_integer1 boxed_integer11 | _ -> false )
  | Pbintcomp  (boxed_integer , comparison) -> (match rhs with Pbintcomp(boxed_integer1, comparison1) -> Lam_compat.eq_boxed_integer boxed_integer boxed_integer1 && Lam_compat.eq_comparison comparison comparison1 | _ -> false)  
  | Pbigarraydim dim -> (match rhs with Pbigarraydim dim1 -> dim = dim1 | _ -> false )
  | Pstring_load_16 str ->  (match  rhs with Pstring_load_16 str1 -> str = str1  | _ -> false )
  | Pstring_load_32 b -> (match rhs with Pstring_load_32 b1 -> b = b1 | _ -> false )    
  | Pstring_load_64 b -> (match rhs with Pstring_load_64 b1 -> b = b1 | _ -> false )    
  | Pstring_set_16 b -> (match rhs with Pstring_set_16 b1 -> b = b1 | _ -> false )    
  | Pstring_set_32 b -> (match rhs with Pstring_set_32 b1 -> b = b1 | _ -> false )    
  | Pstring_set_64 b -> (match rhs with Pstring_set_64 b1 -> b = b1 | _ -> false )      
  | Pbigstring_load_16 b -> (match rhs with Pbigstring_load_16 b1 -> b = b1 | _ -> false )      
  | Pbigstring_load_32 b -> (match rhs with Pbigstring_load_32 b1 -> b = b1 | _ -> false )      
  | Pbigstring_load_64 b -> (match rhs with Pbigstring_load_64 b1 -> b = b1 | _ -> false )      
  | Pbigstring_set_16 b -> (match rhs with Pbigstring_set_16 b1 -> b = b1 | _ -> false )      
  | Pbigstring_set_32 b -> (match rhs with Pbigstring_set_32 b1 -> b = b1 | _ -> false )      
  | Pbigstring_set_64 b -> (match rhs with Pbigstring_set_64 b1 -> b = b1 | _ -> false )      
  | Pctconst compile_time_constant -> (match rhs with Pctconst compile_time_constant1 -> Lam_compat.eq_compile_time_constant compile_time_constant compile_time_constant1 | _ -> false)
  | Pjs_unsafe_downgrade ( s,_loc) -> (match rhs with Pjs_unsafe_downgrade (s1,_) -> s = s1 | _ -> false)  
  | Pjs_fn_make i -> (match rhs with Pjs_fn_make i1 -> i = i1 | _ -> false)
  | Pjs_fn_run i -> (match rhs with Pjs_fn_run i1 -> i = i1 | _ -> false)
  | Pjs_fn_method i -> (match rhs with Pjs_fn_method i1 -> i = i1 | _ ->  false )
  | Pjs_fn_runmethod i -> (match rhs with Pjs_fn_runmethod i1 -> i = i1 | _ -> false ) 

  | Pbigarrayref  _ 
  | Pbigarrayset _ 
  | Praw_js_function _
  | Praw_js_code_exp _ 
  | Praw_js_code_stmt _ -> false (* TOO lazy, here comparison is only approximation*)
  
  | Pfield_computed -> rhs = Pfield_computed
  | Psetfield_computed -> rhs = Psetfield_computed
end
module Lam : sig 
#1 "lam.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)





type ident = Ident.t


type switch  =
  { sw_numconsts: bool;
    sw_consts: (int * t) list;
    sw_numblocks: bool;
    sw_blocks: (int * t) list;
    sw_failaction : t option}
and apply_status =
  | App_na
  | App_ml_full
  | App_js_full      
and apply_info = private
  { fn : t ; 
    args : t list ; 
    loc : Location.t;
    status : apply_status
  }

and prim_info = private
  { primitive : Lam_primitive.t ; 
    args : t list ; 
    loc : Location.t 
  }
and function_info = private
  { arity : int ; 
    params : ident list ;
    body : t 
  }
and  t =  private
  | Lvar of ident
  | Lglobal_module of ident
  | Lconst of Lam_constant.t
  | Lapply of apply_info
  | Lfunction of function_info
  | Llet of Lam_compat.let_kind * ident * t * t
  | Lletrec of (ident * t) list * t
  | Lprim of prim_info
  | Lswitch of t * switch
  | Lstringswitch of t * (string * t) list * t option
  | Lstaticraise of int * t list
  | Lstaticcatch of t * (int * ident list) * t
  | Ltrywith of t * ident * t
  | Lifthenelse of t * t * t
  | Lsequence of t * t
  | Lwhile of t * t
  | Lfor of ident * t * t * Asttypes.direction_flag * t
  | Lassign of ident * t
  | Lsend of Lambda.meth_kind * t * t * t list * Location.t
  (* | Levent of t * Lambda.lambda_event 
     [Levent] in the branch hurt pattern match, 
     we should use record for trivial debugger info
  *)


val inner_map :  t -> (t -> t) -> t




val handle_bs_non_obj_ffi:
  External_arg_spec.t list ->
  External_ffi_types.return_wrapper ->
  External_ffi_types.external_spec -> 
  t list -> 
  Location.t -> 
  string -> 
  t

(**************************************************************)
(** Smart constructors *)
val var : ident -> t
val global_module : ident -> t 
val const : Lam_constant.t -> t

val apply : t -> t list -> Location.t -> apply_status -> t
val function_ : 
  arity:int ->
  params:ident list -> 
  body:t -> t

val let_ : Lam_compat.let_kind -> ident -> t -> t -> t
val letrec : (ident * t) list -> t -> t

(**  constant folding *)
val if_ : t -> t -> t -> t 

(** constant folding*)
val switch : t -> switch  -> t 
(** constant folding*)
val stringswitch : t -> (string * t) list -> t option -> t 

val true_ : t 
val false_ : t 
val unit : t 

(** convert [l || r] to [if l then true else r]*)
val sequor : t -> t -> t
(** convert [l && r] to [if l then r else false *)
val sequand : t -> t -> t

(** constant folding *)
val not_ : Location.t ->  t -> t 

(** drop unused block *)
val seq : t -> t -> t
val while_ : t -> t -> t
(* val event : t -> Lambda.lambda_event -> t   *)
val try_ : t -> ident -> t  -> t 
val assign : ident -> t -> t 

val send : 
  Lambda.meth_kind ->
  t -> t -> t list -> 
  Location.t -> t 

(** constant folding *)  
val prim : primitive:Lam_primitive.t -> args:t list -> Location.t  ->  t


val staticcatch : 
  t -> int * ident list -> t -> t

val staticraise : 
  int -> t list -> t

val for_ : 
  ident ->
  t  ->
  t -> Asttypes.direction_flag -> t -> t 


(**************************************************************)

val eq_approx : t -> t -> bool 
end = struct
#1 "lam.ml"
(* Copyright (C) 2018 - Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type ident = Ident.t

type apply_status =
  | App_na
  | App_ml_full
  | App_js_full


module Types = struct
  type switch =
    { sw_numconsts: bool; (* TODO: refine its representation *)
      sw_consts: (int * t) list;
      sw_numblocks: bool;
      sw_blocks: (int * t) list;
      sw_failaction : t option}
  (* 
    Invariant: 
    length (sw_consts) <= sw_numconsts 
    when length (sw_consts) >= sw_numconsts -> true 
    Note that failaction would appear in both
     {[
       match x with
       | ..
         | ..
           | _ -> 2
     ]}
     since compiler would first test [x] is a const pointer
     or not then the [default] applies to each branch.

     In most cases: {[
       let sw =
         {sw_numconsts = cstr.cstr_consts; sw_consts = consts;
          sw_numblocks = cstr.cstr_nonconsts; sw_blocks = nonconsts;
          sw_failaction = None} in
     ]}

     but there are some edge cases (see https://caml.inria.fr/mantis/view.php?id=6033)
     one predicate used is
     {[
       (sw.sw_numconsts - List.length sw.sw_consts) +
       (sw.sw_numblocks - List.length sw.sw_blocks) > 1
     ]}
     if [= 1] with [some fail] -- called once
     if [= 0] could not have [some fail]
  *)
  and prim_info =
    { primitive : Lam_primitive.t ;
      args : t list ;
      loc : Location.t;
    }
  and apply_info =
    { fn : t ;
      args : t list ;
      loc : Location.t;
      status : apply_status
    }
  and function_info =
    { arity : int ;
      params : ident list ;
      body : t
    }
  and t =
    | Lvar of ident
    | Lglobal_module of ident
    | Lconst of Lam_constant.t
    | Lapply of apply_info
    | Lfunction of function_info
    | Llet of Lam_compat.let_kind * ident * t * t
    | Lletrec of (ident * t) list * t
    | Lprim of prim_info
    | Lswitch of t * switch
    | Lstringswitch of t * (string * t) list * t option
    | Lstaticraise of int * t list
    | Lstaticcatch of t * (int * ident list) * t
    | Ltrywith of t * ident * t
    | Lifthenelse of t * t * t
    | Lsequence of t * t
    | Lwhile of t * t
    | Lfor of ident * t * t * Asttypes.direction_flag * t
    | Lassign of ident * t
    | Lsend of Lam_compat.meth_kind * t * t * t list * Location.t
end

module X = struct
  type switch
    = Types.switch
    =
      { sw_numconsts: bool;
        sw_consts: (int * t) list;
        sw_numblocks: bool;
        sw_blocks: (int * t) list;
        sw_failaction : t option}
  and prim_info
    =  Types.prim_info
    =
      { primitive : Lam_primitive.t ;
        args : t list ;
        loc : Location.t;
      }
  and apply_info
    = Types.apply_info
    =
      { fn : t ;
        args : t list ;
        loc : Location.t;
        status : apply_status
      }

  and function_info
    = Types.function_info
    =
      { arity : int ;
        params : ident list ;
        body : t
      }
  and t
    = Types.t
    =
      | Lvar of ident
      | Lglobal_module of ident
      | Lconst of Lam_constant.t
      | Lapply of apply_info
      | Lfunction of function_info
      | Llet of Lam_compat.let_kind * ident * t * t
      | Lletrec of (ident * t) list * t
      | Lprim of prim_info
      | Lswitch of t * switch
      | Lstringswitch of t * (string * t) list * t option
      | Lstaticraise of int * t list
      | Lstaticcatch of t * (int * ident list) * t
      | Ltrywith of t * ident * t
      | Lifthenelse of t * t * t
      | Lsequence of t * t
      | Lwhile of t * t
      | Lfor of ident * t * t * Asttypes.direction_flag * t
      | Lassign of ident * t
      | Lsend of Lam_compat.meth_kind * t * t * t list * Location.t
end
include Types




(** apply [f] to direct successor which has type [Lam.t] *)

let inner_map 
   (l : t) (f : t -> X.t ) : X.t =
  match l  with
  | Lvar (_ : ident)
  | Lconst (_ : Lam_constant.t) ->
    ( (* Obj.magic *) l : X.t)
  | Lapply ({fn; args; loc; status} )  ->
    let fn = f fn in
    let args = Ext_list.map args f in
    Lapply { fn ; args; loc; status }
  | Lfunction({body; arity;  params } ) ->
    let body = f body in
    Lfunction {body; arity;  params}
  | Llet(str, id, arg, body) ->
    let arg = f arg in let body =  f body in
    Llet(str,id,arg,body)
  | Lletrec(decl, body) ->
    let body = f body in
    let decl = Ext_list.map_snd decl f in
    Lletrec(decl,body)
  | Lglobal_module _ -> (l : X.t)
  | Lprim {args; primitive ; loc}  ->
    let args = Ext_list.map args f in
    Lprim { args; primitive; loc}

  | Lswitch(arg, {sw_consts; sw_numconsts; sw_blocks; sw_numblocks; sw_failaction}) ->
    let arg = f arg in
    let sw_consts = Ext_list.map_snd  sw_consts f in
    let sw_blocks = Ext_list.map_snd  sw_blocks f in
    let sw_failaction = Ext_option.map sw_failaction f in
    Lswitch(arg, { sw_consts; sw_blocks; sw_failaction; sw_numblocks; sw_numconsts})
  | Lstringswitch (arg,cases,default) ->
    let arg = f arg  in
    let cases = Ext_list.map_snd  cases f in
    let default = Ext_option.map default f in
    Lstringswitch(arg,cases,default)
  | Lstaticraise (id,args) ->
    let args = Ext_list.map args f in
    Lstaticraise(id,args)
  | Lstaticcatch(e1, vars , e2) ->
    let e1 = f e1 in
    let e2 = f e2 in
    Lstaticcatch(e1, vars, e2)
  | Ltrywith(e1, exn, e2) ->
    let e1  = f e1 in
    let e2 =  f e2 in
    Ltrywith(e1,exn,e2)
  | Lifthenelse(e1, e2, e3) ->
    let e1 = f e1 in let e2 =  f e2 in let e3 =  f e3 in
    Lifthenelse(e1,e2,e3)
  | Lsequence(e1, e2) ->
    let e1 = f e1 in let e2 =  f e2 in
    Lsequence(e1,e2)
  | Lwhile(e1, e2) ->
    let e1 = f e1 in let e2 =  f e2 in
    Lwhile(e1,e2)
  | Lfor(v, e1, e2, dir, e3) ->
    let e1 = f e1 in let e2 =  f e2 in let e3 =  f e3 in
    Lfor(v,e1,e2,dir,e3)
  | Lassign(id, e) ->
    let e = f e in
    Lassign(id,e)
  | Lsend (k, met, obj, args, loc) ->
    let met = f met in
    let obj = f obj in
    let args = Ext_list.map args f in
    Lsend(k,met,obj,args,loc)








exception Not_simple_form

(**


   [is_eta_conversion_exn params inner_args outer_args]
   case 1:
   {{
    (fun params -> wrap (primitive (inner_args)) args
   }}
   when [inner_args] are the same as [params], it can be simplified as
   [wrap (primitive args)]

    where [wrap] used to be simple instructions
    Note that [external] functions are forced to do eta-conversion
    when combined with [|>] operator, we need to make sure beta-reduction
    is applied though since `[@bs.splice]` needs such guarantee.
    Since `[@bs.splice] is the tail position
*)
let rec is_eta_conversion_exn
    params inner_args outer_args : t list =
  match params, inner_args, outer_args with
  | x::xs, Lvar y::ys, r::rest
    when Ident.same x y ->
    r :: is_eta_conversion_exn xs ys rest
  | x::xs,
    (Lprim ({primitive = Pjs_fn_make _;
             args = [Lvar y] } as p ) ::ys),
    r :: rest when Ident.same x y ->
    Lprim ({p with args = [ r]}) ::
    is_eta_conversion_exn xs ys rest
  | [], [], [] -> []
  | _, _, _ -> raise_notrace Not_simple_form

(** FIXME: more robust inlining check later, we should inline it before we add stub code*)
let apply fn args loc status : t =
  match fn with
  | Lfunction {
               params;
               body = Lprim {primitive =
                               (Pundefined_to_opt |
                                Pnull_to_opt |
                                Pnull_undefined_to_opt |
                                Pis_null |
                                Pis_null_undefined |
                                Pjs_typeof ) as wrap;
                             args = [Lprim ({primitive; args = inner_args} as primitive_call)]
                            }
              } ->
    begin match is_eta_conversion_exn params inner_args args with
      | args
        ->
        Lprim {primitive = wrap ; args = [Lprim { primitive_call with args ; loc = loc }] ; loc }
      | exception Not_simple_form ->
        Lapply { fn; args; loc; status }
    end
  | Lfunction {
               params;
               body =Lprim ({primitive; args = inner_args}as primitive_call) }
    ->
    begin match is_eta_conversion_exn params inner_args args with
      | args
        ->
        Lprim { primitive_call with args ; loc = loc }
      | exception _ ->
        Lapply { fn; args;  loc;    status }
    end
  | Lfunction {
               params;
               body = Lsequence (Lprim ({primitive; args = inner_args}as primitive_call), (Lconst _ as const )) }
    ->
    begin match is_eta_conversion_exn params inner_args args with
      | args
        ->
        Lsequence(Lprim { primitive_call with args ; loc = loc }, const)
      | exception _ ->
        Lapply { fn; args;  loc;    status }
    end
  (* | Lfunction {params;body} when Ext_list.same_length params args ->
      Ext_list.fold_right2 (fun p arg acc ->
        Llet(Strict,p,arg,acc)
      ) params args body *) (* TODO: more rigirous analysis on [let_kind] *)
  | _ ->
    Lapply { fn; args;  loc  ; status }


let rec 
  eq_approx (l1 : t) (l2 : t) =
  match l1 with 
  | Lglobal_module i1 -> 
    (match l2 with  Lglobal_module i2 -> Ident.same i1  i2  | _ -> false)
  | Lvar i1 -> 
    (match l2 with  Lvar i2 ->  Ident.same i1 i2 | _ -> false)
  | Lconst c1 -> 
    (match l2 with  Lconst c2 -> Lam_constant.eq_approx c1 c2  | _ -> false)
  | Lapply app1 -> 
    (match l2 with Lapply app2 ->
    eq_approx app1.fn app2.fn  && eq_approx_list app1.args app2.args
    |_ -> false)
  | Lifthenelse (a,b,c) -> 
    (match l2 with  
     |Lifthenelse (a0,b0,c0) ->
       eq_approx a a0 && eq_approx b b0 && eq_approx c c0
     | _ -> false)
  | Lsequence (a,b) -> 
    (match l2 with Lsequence (a0,b0) ->
    eq_approx a a0 && eq_approx b b0
    | _ -> false)
  | Lwhile (p,b) -> 
    (match l2 with  Lwhile (p0,b0) -> eq_approx p p0 && eq_approx b b0
    | _ -> false)
  | Lassign(v0,l0) -> 
    (match l2 with  Lassign(v1,l1) -> Ident.same v0 v1 && eq_approx l0 l1
    | _ -> false)  
  | Lstaticraise(id,ls) -> 
    (match l2 with  Lstaticraise(id1,ls1) -> 
      id  = id1 && eq_approx_list ls ls1
    | _ -> false)
  | Lprim info1 -> 
    (match l2 with 
    Lprim info2 ->
    Lam_primitive.eq_primitive_approx info1.primitive info2.primitive &&
    eq_approx_list info1.args info2.args
    | _ -> false)
  | Lstringswitch _ -> false  
  | Lfunction _  
  | Llet (_,_,_,_)
  | Lletrec _
  | Lswitch _   
  | Lstaticcatch _ 
  | Ltrywith _ 
  | Lfor (_,_,_,_,_) 
  | Lsend _
    -> false    

and eq_approx_list ls ls1 =  Ext_list.for_all2_no_exn ls ls1 eq_approx




let switch lam (lam_switch : switch) : t =
  match lam with
  | Lconst ((Const_pointer (i,_) |  (Const_int i)))
    ->
    Ext_list.assoc_by_int   lam_switch.sw_consts i lam_switch.sw_failaction
  | Lconst (Const_block (i,_,_)) ->
    Ext_list.assoc_by_int lam_switch.sw_blocks i lam_switch.sw_failaction 
  | _ ->
    Lswitch(lam,lam_switch)

let stringswitch (lam : t) cases default : t =
  match lam with
  | Lconst (Const_string a) ->
    Ext_list.assoc_by_string  cases a default
  | _ -> Lstringswitch(lam, cases, default)


let true_ : t =
  Lconst (Const_js_true)

let false_ : t =
  Lconst (Const_js_false)

let unit : t =
  Lconst (Const_pointer( 0, Pt_constructor "()"))




let rec seq (a : t) b : t =
   match a with
  | Lprim 
    {primitive = Pmakeblock(_); 
     args= x::xs} -> 
    seq (Ext_list.fold_left xs x seq ) b 
  | _ -> 
  Lsequence (a, b)


let var id : t = Lvar id
let global_module id = Lglobal_module id
let const ct : t = Lconst ct
let function_ ~arity  ~params ~body : t =
  Lfunction { arity;  params ; body}

let let_ kind id e body :  t
  = Llet (kind,id,e,body)
let letrec bindings body : t =
  Lletrec(bindings,body)
let while_ a b : t  =
  Lwhile(a,b)

let try_  body id  handler : t =
  Ltrywith(body,id,handler)

let for_ v e1 e2 dir e3 : t  =
  Lfor(v,e1,e2,dir,e3)

let assign v l : t = Lassign(v,l)
let send u m o ll v : t =
  Lsend(u, m, o, ll, v)
let staticcatch  a b c : t = Lstaticcatch(a,b,c)
let staticraise a b : t = Lstaticraise(a,b)


module Lift = struct
  let int i : t =
    Lconst ((Const_int i))


  let int32 i : t =
    Lconst ((Const_int32 i))

  let bool b = if b then true_ else false_

  (* ATTENTION: [float, nativeint] constant propogaton is not done
     yet , due to cross platform problem
  *)
  let float b  : t =
    Lconst ((Const_float b))

  let nativeint b : t =
    Lconst ((Const_nativeint b))

  let int32 b : t =
    Lconst ((Const_int32 b))

  let int64 b : t =
    Lconst ((Const_int64 b))
  let string b : t =
    Lconst ((Const_string (b)))
  let char b : t =
    Lconst ((Const_char b))
end



let prim ~primitive:(prim : Lam_primitive.t) ~args loc  : t =
  let default () : t = Lprim { primitive = prim ;args; loc} in
  match args with
  | [Lconst a] ->
    begin match prim, a  with
      | Pnegint, ((Const_int a))
        -> Lift.int (- a)
      (* | Pfloatofint, ( (Const_int a)) *)
      (*   -> Lift.float (float_of_int a) *)
      | Pintoffloat, ( (Const_float a))
        ->
        Lift.int (int_of_float (float_of_string a))
      (* | Pnegfloat -> Lift.float (-. a) *)
      (* | Pabsfloat -> Lift.float (abs_float a) *)
      | Pstringlength, Const_string a
        ->
        Lift.int (String.length a)
      (* | Pnegbint Pnativeint, ( (Const_nativeint i)) *)
      (*   ->   *)
      (*   Lift.nativeint (Nativeint.neg i) *)
      | Pnegbint Pint32, Const_int32 a
        ->
        Lift.int32 (Int32.neg a)
      | Pnegbint Pint64, Const_int64 a
        ->
        Lift.int64 (Int64.neg a)
      | Pnot, Const_js_true -> false_
      | Pnot, Const_js_false -> true_
      | Pnot , Const_pointer (a,_)
        -> Lift.bool (a = 0 )
      | _ -> default ()
    end


  | [Lconst a ; Lconst b] ->
    begin match prim, a, b  with
      | Pbintcomp(_, cmp),  (Const_int32 a),  (Const_int32 b)
        -> Lift.bool (Lam_compat.cmp_int32 cmp a b)
      | Pbintcomp(_, cmp),  (Const_int64 a),  (Const_int64 b)
        -> Lift.bool (Lam_compat.cmp_int64  cmp a b)
      | Pbintcomp(_, cmp),  (Const_nativeint a),  (Const_nativeint b)
        -> Lift.bool (Lam_compat.cmp_nativeint  cmp a b)
      | Pfloatcomp  cmp,  (Const_float a),  (Const_float b)
        -> (** FIXME: could raise? *)
          Lift.bool (Lam_compat.cmp_float  cmp (float_of_string a) (float_of_string b))
      | Pintcomp cmp ,
        ( (Const_int a) | Const_pointer (a,_)),
        ( (Const_int b) | Const_pointer (b,_))
        -> Lift.bool (Lam_compat.cmp_int cmp a b)
      | (Paddint
        | Psubint
        | Pmulint
        | Pdivint
        | Pmodint
        | Pandint
        | Porint
        | Pxorint
        | Plslint
        | Plsrint
        | Pasrint), (Const_int a),   (Const_int b)
        ->
        (* WE SHOULD keep it as [int], to preserve types *)
        let aa,bb = Int32.of_int a, Int32.of_int  b in
        let int_ v = Lift.int (Int32.to_int v ) in
        begin match prim with
          | Paddint -> int_ (Int32.add aa bb)
          | Psubint -> int_ (Int32.sub aa bb)
          | Pmulint -> int_ (Int32.mul aa  bb)
          | Pdivint ->
            if bb = 0l then default ()
            else int_ (Int32.div aa bb)
          | Pmodint ->
            if bb = 0l then default ()
            else int_ (Int32.rem aa bb)
          | Pandint -> int_ (Int32.logand aa bb)
          | Porint -> int_ (Int32.logor aa bb)
          | Pxorint -> int_ (Int32.logxor aa bb)
          | Plslint -> int_ (Int32.shift_left  aa b )
          | Plsrint -> int_ (Int32.shift_right_logical aa  b)
          | Pasrint -> int_ (Int32.shift_right aa b)
          | _ -> default ()
        end
      | (Paddbint Pint32
        | Psubbint Pint32
        | Pmulbint Pint32
        | Pdivbint Pint32
        | Pmodbint Pint32
        | Pandbint Pint32
        | Porbint Pint32
        | Pxorbint Pint32
        ),  (Const_int32 aa),   (Const_int32 bb)
        ->
        begin match prim with
          | Paddbint _  -> Lift.int32 (Int32.add aa bb)
          | Psubbint _  -> Lift.int32 (Int32.sub aa bb)
          | Pmulbint _ -> Lift.int32 (Int32.mul aa  bb)
          | Pdivbint _ ->  (try Lift.int32 (Int32.div aa  bb) with _  -> default ())
          | Pmodbint _ -> (try Lift.int32 (Int32.rem aa  bb) with _ -> default ())
          | Pandbint _ -> Lift.int32 (Int32.logand aa bb)
          | Porbint _ -> Lift.int32 (Int32.logor aa bb)
          | Pxorbint _ -> Lift.int32 (Int32.logxor aa bb)
          | _ -> default ()
        end
      | Plslbint Pint32,  (Const_int32 aa),  (Const_int b)
        -> Lift.int32 (Int32.shift_left  aa b )
      | Plsrbint Pint32,  (Const_int32 aa),  (Const_int b)
        -> Lift.int32 (Int32.shift_right_logical  aa b )
      | Pasrbint Pint32,  (Const_int32 aa),  (Const_int b)
        -> Lift.int32 (Int32.shift_right  aa b )

      | (Paddbint Pint64
        | Psubbint Pint64
        | Pmulbint Pint64
        | Pdivbint Pint64
        | Pmodbint Pint64
        | Pandbint Pint64
        | Porbint Pint64
        | Pxorbint Pint64
        ),  (Const_int64 aa),   (Const_int64 bb)
        ->
        begin match prim with
          | Paddbint _  -> Lift.int64 (Int64.add aa bb)
          | Psubbint _  -> Lift.int64 (Int64.sub aa bb)
          | Pmulbint _ -> Lift.int64 (Int64.mul aa  bb)
          | Pdivbint _ -> (try Lift.int64 (Int64.div aa  bb) with _ -> default ())
          | Pmodbint _ -> (try Lift.int64 (Int64.rem aa  bb) with _ -> default ())
          | Pandbint _ -> Lift.int64 (Int64.logand aa bb)
          | Porbint _ -> Lift.int64 (Int64.logor aa bb)
          | Pxorbint _ -> Lift.int64 (Int64.logxor aa bb)
          | _ -> default ()
        end
      | Plslbint Pint64,  (Const_int64 aa),  (Const_int b)
        -> Lift.int64 (Int64.shift_left  aa b )
      | Plsrbint Pint64,  (Const_int64 aa),  (Const_int b)
        -> Lift.int64 (Int64.shift_right_logical  aa b )
      | Pasrbint Pint64,  (Const_int64 aa),  (Const_int b)
        -> Lift.int64 (Int64.shift_right  aa b )

      | Psequand, Const_js_false, 
        (Const_js_true | Const_js_false) ->
        false_
      | Psequand, Const_js_true, Const_js_true ->
        true_
      | Psequand, Const_js_true, Const_js_false ->
        false_
      | Psequor, Const_js_true, (Const_js_true | Const_js_false) ->
        true_
      | Psequor, Const_js_false, Const_js_true -> true_
      | Psequor, Const_js_false, Const_js_false -> false_        
      | Pstringadd, (Const_string (a)),
        (Const_string (b))
        ->
        Lift.string (a ^ b)
      | (Pstringrefs | Pstringrefu), (Const_string(a)),
        ((Const_int b)| Const_pointer (b,_))
        ->
        begin try Lift.char (String.get a b)
          with  _ -> default ()
        end
      | _ -> default ()
    end

  | _ -> default ()

let not_ loc x  : t =
  prim ~primitive:Pnot ~args:[x] loc


let has_boolean_type (x : t) = 
  match x with 
  | Lprim {primitive =
    Pnot | Psequand |
    Psequor 
    | Pisout 
    | Pintcomp _ 
    | Pis_not_none
    | Pfloatcomp _; loc}
  | Lprim {primitive = 
    Pccall {prim_name = "caml_string_equal" | "caml_string_notequal"};
    loc
    }
   -> Some loc
  | _ -> None

(** [complete_range sw_consts 0 7]
    is complete with [0,1,.. 7]
*)  
let rec complete_range  (sw_consts : (int * _) list) ~(start : int) ~finish=   
  match sw_consts with 
  | [] -> finish < start
  | (i,_)::rest 
    -> 
      start <= finish &&
      i = start &&
      complete_range  rest ~start:(start + 1) ~finish


let if_ (a : t) (b : t) (c : t) : t =
  match a with
  | Lconst v ->
    begin match v with
      | Const_pointer (x, _)  | (Const_int x)
        ->
        if x <> 0 then b else c
      | (Const_char x) ->
        if Char.code x <> 0 then b else c
      | (Const_int32 x) ->
        if x <> 0l then b else c
      |  (Const_int64 x) ->
        if x <> 0L then b else c
      | (Const_nativeint x) ->
        if x <> 0n then b else c
      | Const_js_false
      | Const_js_null
      | Const_js_undefined -> c
      | Const_js_true
      | Const_string _
      | Const_float _
      | Const_unicode _
      | Const_block _
      | Const_some _ 
      | Const_float_array _
      | Const_immstring _ -> b
    end
  
  | _ -> 
    match  b, c with 
    | Lconst(Const_js_true), Lconst(Const_js_false)
      -> 
      if has_boolean_type a != None then a 
      else Lifthenelse (a,b,c)
    | Lconst(Const_js_false), Lconst(Const_js_true)
      ->  
      (match  has_boolean_type a with
       | Some loc ->  not_ loc a 
       | None -> Lifthenelse (a,b,c))     
    | Lprim {primitive = Praise } , _ ->    
      begin match c with 
        | Lconst _ -> Lifthenelse(a,b,c)
        | _ -> seq (Lifthenelse (a,b,unit)) c
      end 
    | _ -> 
      (match a with 
       | Lprim {primitive = Pisout; args = [Lconst(Const_int range); Lvar xx] } 
         -> 
         begin match c with 
           | Lswitch ( Lvar yy as switch_arg, 
                       ({sw_blocks = []; sw_numblocks = true; sw_consts ;
                         sw_numconsts; sw_failaction = None} as body)
                     )
             when Ident.same xx yy 
               && complete_range sw_consts ~start:0 ~finish:range
             ->  
             Lswitch(switch_arg, 
                     { body with sw_failaction = Some b; sw_numconsts = false })
           |  _ -> Lifthenelse(a,b,c)      
         end
       | _ ->  Lifthenelse (a,b,c))



(** TODO: the smart constructor is not exploited yet*)
(** [l || r ] *)
let sequor l r = if_ l true_ r

(** [l && r ] *)
let sequand l r = if_ l r false_  

(******************************************************************)
(** only [handle_bs_non_obj_ffi] will be used outside *)
(**
   [no_auto_uncurried_arg_types xs]
   check if the FFI have [@@bs.uncurry] attribute.
   if it does not we wrap it in a nomral way otherwise
*)
let rec no_auto_uncurried_arg_types
    (xs : External_arg_spec.t list)  =
  match xs with
  | [] -> true
  | {arg_type = Fn_uncurry_arity _ } :: _ ->
    false
  | _ :: xs -> no_auto_uncurried_arg_types xs


let result_wrap loc (result_type : External_ffi_types.return_wrapper) result  =
  match result_type with
  | Return_replaced_with_unit
    -> seq result unit
  | Return_null_to_opt -> prim ~primitive:Pnull_to_opt ~args:[result] loc
  | Return_null_undefined_to_opt -> prim ~primitive:Pnull_undefined_to_opt ~args:[result] loc
  | Return_undefined_to_opt -> prim ~primitive:Pundefined_to_opt ~args:[result] loc
  | Return_unset
  | Return_identity ->
    result

let rec transform_uncurried_arg_type loc (arg_types : External_arg_spec.t list)
    (args : t list ) =
  match arg_types,args with
  | { arg_type = Fn_uncurry_arity n ; arg_label } :: xs,
    y::ys ->
    let (o_arg_types, o_args) =
      transform_uncurried_arg_type loc xs ys in
    { External_arg_spec.arg_type = Nothing ; arg_label } :: o_arg_types ,
    prim ~primitive:(Pjs_fn_make n) ~args:[y] loc :: o_args
  |  x  ::xs, y::ys ->
    begin match x with
      | {arg_type = Arg_cst _ }  ->
        let o_arg_types, o_args = transform_uncurried_arg_type loc xs args in
        x :: o_arg_types , o_args
      | _ ->
        let o_arg_types, o_args = transform_uncurried_arg_type loc xs ys in
        x :: o_arg_types , y:: o_args
    end
  | [] , []
  | _::_, []
  | [], _::_ as ok -> ok


let handle_bs_non_obj_ffi
    (arg_types : External_arg_spec.t list)
    (result_type : External_ffi_types.return_wrapper)
    ffi
    args
    loc
    prim_name =
  if no_auto_uncurried_arg_types arg_types then
    result_wrap loc result_type @@ prim ~primitive:(Pjs_call(prim_name, arg_types, ffi))
      ~args loc
  else
    let n_arg_types, n_args =
      transform_uncurried_arg_type loc  arg_types args in
    result_wrap loc result_type @@
    prim ~primitive:(Pjs_call (prim_name, n_arg_types, ffi))
      ~args:n_args loc


end
module Lam_arity : sig 
#1 "lam_arity.mli"
(* Copyright (C) Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


type t = private
  | Arity_info of int list  * bool
    (**
      when the first argument is true, it is for sure 
      the last one means it can take any params later, 
      for an exception: it is (Arity_info([], true))
       approximation sound but not complete       
   *)
  | Arity_na 

val equal : t -> t -> bool  
val print : Format.formatter -> t -> unit   

val print_arities_tbl : 
  Format.formatter -> 
  (Ident.t, t ref) Hashtbl.t -> 
  unit 

val merge : int -> t -> t   

val non_function_arity_info : t

val raise_arity_info : t 

val na : t
val info : int list -> bool -> t 

val first_arity_na :  t -> bool
val get_first_arity : t -> int option 

(** when [NA] return  empty list*)
val extract_arity : t -> int list 

val merge_arities : 
  int list -> 
  int list -> 
  bool -> 
  bool -> 
  t
end = struct
#1 "lam_arity.ml"
(* Copyright (C) Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


type t = 
  | Arity_info of  int  list  * bool
  (**
     the last one means it can take any params later, 
     for an exception: it is (Determin (true,[], true))
     1. approximation sound but not complete 

  *)
  | Arity_na

let equal (x : t ) y =     
  match x with 
  | Arity_na -> y = Arity_na 
  | Arity_info (xs,a) -> 
    begin match y with  
      | Arity_info (ys,b) -> 
        a = b && Ext_list.for_all2_no_exn xs ys (fun x y -> x =y)
      | Arity_na -> false  
    end
let pp = Format.fprintf

let print (fmt : Format.formatter) (x : t) = 
  match x with 
  | Arity_na -> pp fmt "?"
  | Arity_info (ls,tail) -> 
    begin 
      pp fmt "@[";
      pp fmt "[";
      Format.pp_print_list ~pp_sep:(fun fmt () -> pp fmt ",")
        (fun fmt  x -> Format.pp_print_int fmt x)
        fmt ls ;
      if tail 
      then pp fmt "@ *";
      pp fmt "]@]";
    end

let print_arities_tbl 
    (fmt : Format.formatter) 
    (arities_tbl : (Ident.t, t ref) Hashtbl.t) = 
  Hashtbl.fold (fun (i:Ident.t) (v : t ref) _ -> 
      pp Format.err_formatter "@[%s -> %a@]@."i.name print !v ) arities_tbl ()





let merge 
    (n : int )
    (x : t) : t = 
  match x with 
  | Arity_na -> Arity_info ( [n], false)
  | Arity_info (xs,tail) -> Arity_info ( n :: xs, tail)


let non_function_arity_info =   
  Arity_info ([], false)

let raise_arity_info =   
  Arity_info ([],true)

let na = Arity_na

let info args b1 = 
  Arity_info ( args, b1)


let first_arity_na ( x : t ) =   
  match x with 
  | Arity_na 
  | Arity_info ( [], _) -> true
  | _ -> false

let get_first_arity (x : t) =   
  match x with 
  | Arity_na 
  | Arity_info ( [], _) -> None
  | Arity_info ( x::_, _) ->  Some x

let extract_arity ( x : t) =   
  match x with 
  | Arity_na  -> []
  | Arity_info(xs,_) ->  xs 

(* let update_arity (x : t) xs =    *)

let rec
  merge_arities_aux 
    (acc : int list) 
    (xs : int list) (ys : int list) (tail : bool) (tail2 : bool) = 
  match xs,ys with
  | [], [] -> 
    info (List.rev acc) (tail && tail2) 
  | [], y::ys when tail  -> 
    merge_arities_aux (y::acc)   [] ys tail tail2
  | x::xs, [] when tail2 -> 
    merge_arities_aux (x::acc)   [] xs tail tail2
  | x::xs, y::ys when x = y ->
    merge_arities_aux (y :: acc)   xs ys tail tail2
  | _, _  -> 
  info (List.rev acc) false

let merge_arities  xs ys t t2 = 
  merge_arities_aux []  xs ys t t2

end
module Lam_print : sig 
#1 "lam_print.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

val lambda : Format.formatter -> Lam.t -> unit

val primitive: Format.formatter -> Lam_primitive.t -> unit



val env_lambda : Env.t -> Format.formatter -> Lam.t -> unit

val seriaize : 'a -> string -> Lam.t -> unit

val lambda_to_string : Lam.t -> string 

val primitive_to_string : Lam_primitive.t -> string
end = struct
#1 "lam_print.ml"
(***********************************************************************)
(*                                                                     *)
(*                                OCaml                                *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)
[@@@ocaml.warning "-40"]
open Format
open Asttypes
open Primitive
open Types



let rec struct_const ppf (cst : Lam_constant.t) =
  match cst with 
  | Const_js_true -> fprintf ppf "#true"
  | Const_js_false -> fprintf ppf "#false"
  | Const_js_null -> fprintf ppf "#null"
  | Const_js_undefined -> fprintf ppf "#undefined"
  |  (Const_int n) -> fprintf ppf "%i" n
  |  (Const_char c) -> fprintf ppf "%C" c
  |  (Const_string s) -> fprintf ppf "%S" s
  |  (Const_unicode s) -> fprintf ppf "%S" s
  | Const_immstring s -> fprintf ppf "#%S" s
  |  (Const_float f) -> fprintf ppf "%s" f
  |  (Const_int32 n) -> fprintf ppf "%lil" n
  |  (Const_int64 n) -> fprintf ppf "%LiL" n
  |  (Const_nativeint n) -> fprintf ppf "%nin" n
  | Const_pointer (n,_) -> fprintf ppf "%ia" n
  | Const_some n -> fprintf ppf "[some-c]%a" struct_const n
  | Const_block(tag,_, []) ->
    fprintf ppf "[%i]" tag
  | Const_block(tag,_, sc1::scl) ->
    let sconsts ppf scl =
      List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl in
    fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl
  | Const_float_array [] ->
    fprintf ppf "[| |]"
  | Const_float_array (f1 :: fl) ->
    let floats ppf fl =
      List.iter (fun f -> fprintf ppf "@ %s" f) fl in
    fprintf ppf "@[<1>[|@[%s%a@]|]@]" f1 floats fl

let boxed_integer_name (i : Lam_compat.boxed_integer) =
  match i with 
  | Pnativeint -> "nativeint"
  | Pint32 -> "int32"
  | Pint64 -> "int64"

let print_boxed_integer name ppf bi =
  fprintf ppf "%s_%s" (boxed_integer_name bi) name

let print_boxed_integer_conversion ppf bi1 bi2 =
  fprintf ppf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1)

let boxed_integer_mark name (i : Lam_compat.boxed_integer) = 
  match i with 
  | Pnativeint -> Printf.sprintf "Nativeint.%s" name
  | Pint32 -> Printf.sprintf "Int32.%s" name
  | Pint64 -> Printf.sprintf "Int64.%s" name

let print_boxed_integer name ppf bi =
  fprintf ppf "%s" (boxed_integer_mark name bi);;

let print_bigarray name unsafe (kind : Lam_compat.bigarray_kind) ppf 
    (layout : Lam_compat.bigarray_layout) =
  fprintf ppf "Bigarray.%s[%s,%s]"
    (if unsafe then "unsafe_"^ name else name)
    (match kind with
     | Lam_compat.Pbigarray_unknown -> "generic"
     | Pbigarray_float32 -> "float32"
     | Pbigarray_float64 -> "float64"
     | Pbigarray_sint8 -> "sint8"
     | Pbigarray_uint8 -> "uint8"
     | Pbigarray_sint16 -> "sint16"
     | Pbigarray_uint16 -> "uint16"
     | Pbigarray_int32 -> "int32"
     | Pbigarray_int64 -> "int64"
     | Pbigarray_caml_int -> "camlint"
     | Pbigarray_native_int -> "nativeint"
     | Pbigarray_complex32 -> "complex32"
     | Pbigarray_complex64 -> "complex64")
    (match layout with
     | Lam_compat.Pbigarray_unknown_layout -> "unknown"
     | Pbigarray_c_layout -> "C"
     | Pbigarray_fortran_layout -> "Fortran")

let record_rep ppf r =
  match r with
  | Record_regular -> fprintf ppf "regular"
  | Record_float -> fprintf ppf "float"

  | Record_inlined {tag = i} -> fprintf ppf "inlined %d" i 
  | Record_unboxed b -> fprintf ppf "unboxed %b" b
  | Record_extension -> fprintf ppf "ext"

;;

let string_of_loc_kind (loc : Lambda.loc_kind) =
  match loc with 
  | Loc_FILE -> "loc_FILE"
  | Loc_LINE -> "loc_LINE"
  | Loc_MODULE -> "loc_MODULE"
  | Loc_POS -> "loc_POS"
  | Loc_LOC -> "loc_LOC"

let primitive ppf (prim : Lam_primitive.t) = match prim with 
  (* | Pcreate_exception s -> fprintf ppf "[exn-create]%S" s  *)
  | Pcreate_extension s -> fprintf ppf "[ext-create]%S" s 
  | Pwrap_exn -> fprintf ppf "#exn"
  | Pcaml_obj_length -> fprintf ppf "#obj_length"
  | Pinit_mod -> fprintf ppf "init_mod!"
  | Pupdate_mod -> fprintf ppf "update_mod!"
  | Pbytes_to_string -> fprintf ppf "bytes_to_string"
  | Pbytes_of_string -> fprintf ppf "bytes_of_string"
  | Pjs_apply -> fprintf ppf "#apply"
  | Pjs_runtime_apply -> fprintf ppf "#runtime_apply"
  | Pjs_unsafe_downgrade (s,_loc) -> fprintf ppf "##%s" s 
  | Pjs_function_length -> fprintf ppf "#function_length"
  | Pjs_fn_run i -> fprintf ppf "#fn_run_%i" i 
  | Pjs_fn_make i -> fprintf ppf "js_fn_make_%i" i
  | Pjs_fn_method i -> fprintf ppf "js_fn_method_%i" i 
  | Pjs_fn_runmethod i -> fprintf ppf "js_fn_runmethod_%i" i 
  | Pdebugger -> fprintf ppf "debugger"
  | Praw_js_function _ -> fprintf ppf "[raw.fun]"
  | Praw_js_code_exp _ -> fprintf ppf "[raw.exp]"
  | Praw_js_code_stmt _ -> fprintf ppf "[raw.stmt]"
  | Pglobal_exception id ->
    fprintf ppf "global exception %a" Ident.print id       
  | Pjs_typeof -> fprintf ppf "[typeof]"
  | Pnull_to_opt -> fprintf ppf "[null->opt]"              
  | Pundefined_to_opt -> fprintf ppf "[undefined->opt]"     
  | Pnull_undefined_to_opt -> 
    fprintf ppf "[null/undefined->opt]"         
  | Pis_null -> fprintf ppf "[?null]"
  | Pis_not_none -> fprintf ppf "[?none]"
  | Psome -> fprintf ppf "[some]"
  | Psome_not_nest -> fprintf ppf "[some-not-nest]"
  | Pval_from_option -> fprintf ppf "[?unbox]"
  | Pval_from_option_not_nest -> fprintf ppf "[?unbox-not-nest]"
  | Pis_undefined -> fprintf ppf "[?undefined]"
  | Pis_null_undefined -> fprintf ppf "[?null?undefined]"
  (* | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id *)
  | Pmakeblock(tag, _, Immutable) -> fprintf ppf "makeblock %i" tag
  | Pmakeblock(tag, _, Mutable) -> fprintf ppf "makemutable %i" tag
  | Pfield (n,_) -> fprintf ppf "field %i" n
  | Pfield_computed -> 
    fprintf ppf "field_computed"
  | Psetfield_computed -> 
    fprintf ppf "setfield_computed"
  | Psetfield(n,  _) ->
    let instr = "setfield " in
    fprintf ppf "%s%i" instr n
  | Pfloatfield (n,_) -> fprintf ppf "floatfield %i" n
  | Psetfloatfield (n,_) -> fprintf ppf "setfloatfield %i" n
  | Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size
  | Plazyforce -> fprintf ppf "force"
  | Pccall p -> fprintf ppf "%s" p.prim_name
  | Pjs_call (prim_name, _, _) -> 
    fprintf ppf  "%s[js]" prim_name 
  | Pjs_object_create obj_create -> 
    fprintf ppf "[js.obj]"
  | Praise  -> fprintf ppf "raise"
  | Psequand -> fprintf ppf "&&"
  | Psequor -> fprintf ppf "||"
  | Pnot -> fprintf ppf "not"
  | Pnegint -> fprintf ppf "~"
  | Paddint -> fprintf ppf "+"
  | Pstringadd -> fprintf ppf "+*"                 
  | Psubint -> fprintf ppf "-"
  | Pmulint -> fprintf ppf "*"
  | Pdivint -> fprintf ppf "/"
  | Pmodint -> fprintf ppf "mod"
  | Pandint -> fprintf ppf "and"
  | Porint -> fprintf ppf "or"
  | Pxorint -> fprintf ppf "xor"
  | Plslint -> fprintf ppf "lsl"
  | Plsrint -> fprintf ppf "lsr"
  | Pasrint -> fprintf ppf "asr"
  | Pintcomp(Ceq) -> fprintf ppf "==[int]"
  | Pintcomp(Cneq) -> fprintf ppf "!=[int]"
  | Pintcomp(Clt) -> fprintf ppf "<"
  | Pintcomp(Cle) -> fprintf ppf "<="
  | Pintcomp(Cgt) -> fprintf ppf ">"
  | Pintcomp(Cge) -> fprintf ppf ">="
  | Poffsetint n -> fprintf ppf "%i+" n
  | Poffsetref n -> fprintf ppf "+:=%i"n
  | Pintoffloat -> fprintf ppf "int_of_float"
  | Pfloatofint -> fprintf ppf "float_of_int"
  | Pnegfloat -> fprintf ppf "~."
  (* | Pabsfloat -> fprintf ppf "abs." *)
  | Paddfloat -> fprintf ppf "+."
  | Psubfloat -> fprintf ppf "-."
  | Pmulfloat -> fprintf ppf "*."
  | Pdivfloat -> fprintf ppf "/."
  | Pfloatcomp(Ceq) -> fprintf ppf "==."
  | Pfloatcomp(Cneq) -> fprintf ppf "!=."
  | Pfloatcomp(Clt) -> fprintf ppf "<."
  | Pfloatcomp(Cle) -> fprintf ppf "<=."
  | Pfloatcomp(Cgt) -> fprintf ppf ">."
  | Pfloatcomp(Cge) -> fprintf ppf ">=."
  | Pjscomp(Ceq) -> fprintf ppf "#=="
  | Pjscomp(Cneq) -> fprintf ppf "#!="
  | Pjscomp(Clt) -> fprintf ppf "#<"
  | Pjscomp(Cle) -> fprintf ppf "#<="
  | Pjscomp(Cgt) -> fprintf ppf "#>"
  | Pjscomp(Cge) -> fprintf ppf "#>="

  | Pstringlength -> fprintf ppf "string.length"
  | Pstringrefu -> fprintf ppf "string.unsafe_get"
  | Pstringrefs -> fprintf ppf "string.get"
  | Pbyteslength -> fprintf ppf "bytes.length"
  | Pbytesrefu -> fprintf ppf "bytes.unsafe_get"
  | Pbytessetu -> fprintf ppf "bytes.unsafe_set"
  | Pbytesrefs -> fprintf ppf "bytes.get"
  | Pbytessets -> fprintf ppf "bytes.set"

  | Parraylength  -> fprintf ppf "array.length"
  | Pmakearray _ -> fprintf ppf "makearray "
  | Parrayrefu  -> fprintf ppf "array.unsafe_get"
  | Parraysetu  -> fprintf ppf "array.unsafe_set"
  | Parrayrefs  -> fprintf ppf "array.get"
  | Parraysets  -> fprintf ppf "array.set"
  | Pctconst c ->
    let const_name = match c with
      | Big_endian -> "big_endian"
      | Word_size -> "word_size"
      | Ostype_unix -> "ostype_unix"
      | Ostype_win32 -> "ostype_win32"
      | Ostype_cygwin -> "ostype_cygwin" 
     
      | Int_size -> "int_size"
      | Max_wosize -> "max_wosize"
      | Backend_type -> "backend_type"

    in
    fprintf ppf "sys.constant_%s" const_name
  | Pisint -> fprintf ppf "isint"
  | Pisout -> fprintf ppf "isout"
  | Pbittest -> fprintf ppf "testbit"
  | Pbintofint bi -> print_boxed_integer "of_int" ppf bi
  | Pintofbint bi -> print_boxed_integer "to_int" ppf bi
  | Pcvtbint (bi1, bi2) -> print_boxed_integer_conversion ppf bi1 bi2
  | Pnegbint bi -> print_boxed_integer "neg" ppf bi
  | Paddbint bi -> print_boxed_integer "add" ppf bi
  | Psubbint bi -> print_boxed_integer "sub" ppf bi
  | Pmulbint bi -> print_boxed_integer "mul" ppf bi
  | Pdivbint bi -> print_boxed_integer "div" ppf bi
  | Pmodbint bi -> print_boxed_integer "mod" ppf bi
  | Pandbint bi -> print_boxed_integer "and" ppf bi
  | Porbint bi -> print_boxed_integer "or" ppf bi
  | Pxorbint bi -> print_boxed_integer "xor" ppf bi
  | Plslbint bi -> print_boxed_integer "lsl" ppf bi
  | Plsrbint bi -> print_boxed_integer "lsr" ppf bi
  | Pasrbint bi -> print_boxed_integer "asr" ppf bi
  | Pbintcomp(bi, Ceq) -> print_boxed_integer "==[bint]" ppf bi
  | Pbintcomp(bi, Cneq) -> print_boxed_integer "!=" ppf bi
  | Pbintcomp(bi, Clt) -> print_boxed_integer "<" ppf bi
  | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi
  | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi
  | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi
  | Pbigarrayref(unsafe, n, kind, layout) ->
    print_bigarray "get" unsafe kind ppf layout
  | Pbigarrayset(unsafe, n, kind, layout) ->
    print_bigarray "set" unsafe kind ppf layout
  | Pbigarraydim(n) -> fprintf ppf "Bigarray.dim_%i" n
  | Pstring_load_16(unsafe) ->
    if unsafe then fprintf ppf "string.unsafe_get16"
    else fprintf ppf "string.get16"
  | Pstring_load_32(unsafe) ->
    if unsafe then fprintf ppf "string.unsafe_get32"
    else fprintf ppf "string.get32"
  | Pstring_load_64(unsafe) ->
    if unsafe then fprintf ppf "string.unsafe_get64"
    else fprintf ppf "string.get64"
  | Pstring_set_16(unsafe) ->
    if unsafe then fprintf ppf "string.unsafe_set16"
    else fprintf ppf "string.set16"
  | Pstring_set_32(unsafe) ->
    if unsafe then fprintf ppf "string.unsafe_set32"
    else fprintf ppf "string.set32"
  | Pstring_set_64(unsafe) ->
    if unsafe then fprintf ppf "string.unsafe_set64"
    else fprintf ppf "string.set64"
  | Pbigstring_load_16(unsafe) ->
    if unsafe then fprintf ppf "bigarray.array1.unsafe_get16"
    else fprintf ppf "bigarray.array1.get16"
  | Pbigstring_load_32(unsafe) ->
    if unsafe then fprintf ppf "bigarray.array1.unsafe_get32"
    else fprintf ppf "bigarray.array1.get32"
  | Pbigstring_load_64(unsafe) ->
    if unsafe then fprintf ppf "bigarray.array1.unsafe_get64"
    else fprintf ppf "bigarray.array1.get64"
  | Pbigstring_set_16(unsafe) ->
    if unsafe then fprintf ppf "bigarray.array1.unsafe_set16"
    else fprintf ppf "bigarray.array1.set16"
  | Pbigstring_set_32(unsafe) ->
    if unsafe then fprintf ppf "bigarray.array1.unsafe_set32"
    else fprintf ppf "bigarray.array1.set32"
  | Pbigstring_set_64(unsafe) ->
    if unsafe then fprintf ppf "bigarray.array1.unsafe_set64"
    else fprintf ppf "bigarray.array1.set64"
  | Pbswap16 -> fprintf ppf "bswap16"
  | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi


type print_kind = 
  | Alias 
  | Strict 
  | StrictOpt 
  | Variable 
  | Recursive 

let kind = function
  | Alias -> "a"
  | Strict -> ""
  | StrictOpt -> "o"
  | Variable -> "v" 
  | Recursive -> "r"

let to_print_kind (k : Lam_compat.let_kind) : print_kind = 
  match k with 
  | Alias -> Alias 
  | Strict -> Strict
  | StrictOpt -> StrictOpt
  | Variable -> Variable

let rec aux (acc : (print_kind * Ident.t * Lam.t ) list) (lam : Lam.t) = 
  match lam with 
  | Llet (str3, id3, arg3, body3) ->
    aux ((to_print_kind str3,id3, arg3)::acc) body3
  | Lletrec (bind_args, body) ->
    aux 
      (Ext_list.map_append 
        bind_args
        acc
        (fun (id,l) -> (Recursive,id,l)) ) body
  | e ->  (acc , e) 

type left_var = 
  {
    kind : print_kind ;
    id : Ident.t
  }

type left = 
  | Id of left_var
  | Nop




let  flatten (lam : Lam.t) : (print_kind * Ident.t * Lam.t ) list * Lam.t = 
  match lam with 
  | Llet(str,id, arg, body) ->
    aux [to_print_kind str, id, arg] body
  | Lletrec(bind_args, body) ->
    aux 
      (Ext_list.map bind_args (fun (id,l) -> (Recursive, id,l))) 
      body
  | _ -> assert false


let get_string ((id : Ident.t), (pos : int)) (env : Env.t) : string = 
  match  Env.find_module (Pident id) env with 
  | {md_type = Mty_signature signature  ; _ } -> 
    (* Env.prefix_idents, could be cached  *)
    let serializable_sigs = 
      List.filter (fun x ->
          match x with 
          | Sig_typext _ 
          | Sig_module _
          | Sig_class _ -> true
          | Sig_value(_, {val_kind = Val_prim _}) -> false
          | Sig_value _ -> true
          | _ -> false
        ) signature  in
    (begin match Ext_list.nth_opt  serializable_sigs  pos  with 
       | Some (Sig_value (i,_) 
       | Sig_module (i,_,_) 
       | Sig_typext (i,_,_) 
       | Sig_modtype(i,_) 
       | Sig_class (i,_,_) 
       | Sig_class_type(i,_,_) 
       | Sig_type(i,_,_)) -> i 
       | None -> assert false
     end).name
  | _ -> assert false



let lambda use_env env ppf v  =
  let rec lam ppf (l : Lam.t) = match l with 
    | Lvar id ->
      Ident.print ppf id
    | Lam.Lglobal_module id -> 
      fprintf ppf "global %a" Ident.print id
    | Lconst cst ->
      struct_const ppf cst
    | Lapply { fn; args; } ->
      let lams ppf args =
        List.iter (fun l -> fprintf ppf "@ %a" lam l) args in
      fprintf ppf "@[<2>(apply@ %a%a)@]" lam fn lams args
    | Lfunction{params; body; _} ->
      let pr_params ppf params =
          List.iter (fun param -> fprintf ppf "@ %a" Ident.print param) params
          (* | Tupled -> *)
          (*     fprintf ppf " ("; *)
          (*     let first = ref true in *)
          (*     List.iter *)
          (*       (fun param -> *)
          (*         if !first then first := false else fprintf ppf ",@ "; *)
          (*         Ident.print ppf param) *)
          (*       params; *)
          (*     fprintf ppf ")"  *)
      in
      fprintf ppf "@[<2>(function%a@ %a)@]" pr_params params lam body
    | Llet _ | Lletrec _ as x ->
      let args, body =   flatten x  in
      let bindings ppf id_arg_list =
        let spc = ref false in
        List.iter
          (fun (k, id, l) ->
             if !spc then fprintf ppf "@ " else spc := true;
             fprintf ppf "@[<2>%a =%s@ %a@]" Ident.print id (kind k) lam l)
          id_arg_list in
      fprintf ppf
        "@[<2>(let@ (@[<hv 1>%a@]" bindings (List.rev args);
      fprintf ppf ")@ %a)@]"  lam body
    | Lprim { 
        primitive = Pfield (n,_); 
        args = [ Lglobal_module id ]
        ;  _} when use_env ->
      fprintf ppf "%s.%s/%d" id.name (get_string (id,n) env) n

    | Lprim { 
        primitive  = Psetfield (n,_); 
        args = [ Lglobal_module id  ;
                 e ]
        ;  _} when use_env  ->
      fprintf ppf "@[<2>(%s.%s/%d <- %a)@]" id.name (get_string (id,n) env) n
        lam e
    | Lprim{primitive = prim; args = largs;  _} ->
      let lams ppf largs =
        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
      fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs
    | Lswitch(larg, sw) ->
      let switch ppf (sw : Lam.switch) =
        let spc = ref false in
        List.iter
          (fun (n, l) ->
             if !spc then fprintf ppf "@ " else spc := true;
             fprintf ppf "@[<hv 1>case int %i:@ %a@]" n lam l)
          sw.sw_consts;
        List.iter
          (fun (n, l) ->
             if !spc then fprintf ppf "@ " else spc := true;
             fprintf ppf "@[<hv 1>case tag %i:@ %a@]" n lam l)
          sw.sw_blocks ;
        begin match sw.sw_failaction with
          | None  -> ()
          | Some l ->
            if !spc then fprintf ppf "@ " else spc := true;
            fprintf ppf "@[<hv 1>default:@ %a@]" lam l
        end in
      fprintf ppf
        "@[<1>(%s %a@ @[<v 0>%a@])@]"
        (match sw.sw_failaction with None -> "switch*" | _ -> "switch")
        lam larg switch sw
    | Lstringswitch(arg, cases, default) ->
      let switch ppf cases =
        let spc = ref false in
        List.iter
          (fun (s, l) ->
             if !spc then fprintf ppf "@ " else spc := true;
             fprintf ppf "@[<hv 1>case \"%s\":@ %a@]" (String.escaped s) lam l)
          cases;
        begin match default with
          | Some default ->
            if !spc then fprintf ppf "@ " else spc := true;
            fprintf ppf "@[<hv 1>default:@ %a@]" lam default
          | None -> ()
        end in
      fprintf ppf
        "@[<1>(stringswitch %a@ @[<v 0>%a@])@]" lam arg switch cases
    | Lstaticraise (i, ls)  ->
      let lams ppf largs =
        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
      fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls;
    | Lstaticcatch(lbody, (i, vars), lhandler) ->
      fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]"
        lam lbody i
        (fun ppf vars -> match vars with
           | [] -> ()
           | _ ->
             List.iter
               (fun x -> fprintf ppf " %a" Ident.print x)
               vars)
        vars
        lam lhandler
    | Ltrywith(lbody, param, lhandler) ->
      fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]"
        lam lbody Ident.print param lam lhandler
    | Lifthenelse(lcond, lif, lelse) ->
      fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse
    | Lsequence(l1, l2) ->
      fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2
    | Lwhile(lcond, lbody) ->
      fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody
    | Lfor(param, lo, hi, dir, body) ->
      fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]"
        Ident.print param lam lo
        (match dir with Upto -> "to" | Downto -> "downto")
        lam hi lam body
    | Lassign(id, expr) ->
      fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr
    | Lsend (k, met, obj, largs, _) ->
      let args ppf largs =
        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
      let kind =
        if k = Self then "self" else if k = Cached then "cache" else "" in
      fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs

  and sequence ppf = function
    | Lsequence(l1, l2) ->
      fprintf ppf "%a@ %a" sequence l1 sequence l2
    | l ->
      lam ppf l
  in 
  lam ppf v

let structured_constant = struct_const

let env_lambda = lambda true 
let lambda = lambda false Env.empty

let rec flatten_seq acc (lam : Lam.t) =
  match lam with 
  | Lsequence(l1,l2) -> 
    flatten_seq (flatten_seq acc l1) l2
  | x -> x :: acc 

exception Not_a_module

let rec flat (acc : (left * Lam.t) list ) (lam : Lam.t) = 
  match lam with 
  | Llet (str,id,arg,body) ->
    flat ( (Id {kind = to_print_kind str;  id}, arg) :: acc) body 
  | Lletrec (bind_args, body) ->
    flat 
      (Ext_list.map_append bind_args acc
        (fun (id, arg ) -> (Id {kind = Recursive;  id}, arg)) ) 
      body 
  | Lsequence (l,r) -> 
    flat (flat acc l) r
  | x -> (Nop, x) :: acc 

let lambda_as_module env  ppf (lam : Lam.t) = 
  try
    (* match lam with *)
    (* | Lprim {primitive = Psetglobal id ; args =  [biglambda]; _} *)
    (* might be wrong in toplevel *) 
    (* -> *)

    begin match flat [] lam  with 
      | (Nop, Lprim {primitive = Pmakeblock (_, _, _); args =  toplevels; _})
        :: rest ->
        (* let spc = ref false in *)
        List.iter
          (fun (left, l) ->
             match left with 
             | Id { kind = k; id } ->
               fprintf ppf "@[<2>%a =%s@ %a@]@." Ident.print id (kind k) (env_lambda env) l
             | Nop -> 

               fprintf ppf "@[<2>%a@]@."   (env_lambda env) l
          )

        @@ List.rev rest


      | _ -> raise Not_a_module
    end
  (* | _ -> raise Not_a_module *)
  with _ -> 
    env_lambda env ppf lam;
    fprintf ppf "; lambda-failure"

let seriaize env (filename : string) (lam : Lam.t) : unit =
  let ou = open_out filename  in
  let old = Format.get_margin () in
  let () = Format.set_margin 10000 in
  let fmt = Format.formatter_of_out_channel ou in
  begin
    (* lambda_as_module env fmt lambda; *)
    lambda fmt lam;
    Format.pp_print_flush fmt ();
    close_out ou;
    Format.set_margin old
  end



let lambda_to_string = Format.asprintf "%a" lambda   


let primitive_to_string = Format.asprintf "%a" primitive
end
module Js_cmj_format : sig 
#1 "js_cmj_format.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Define intemediate format to be serialized for cross module optimization
 *)

(** In this module, 
    currently only arity information is  exported, 

    Short term: constant literals are also exported 

    Long term:
    Benefit? since Google Closure Compiler already did such huge amount of work
    TODO: simple expression, literal small function  can be stored, 
    but what would happen if small function captures other environment
    for example 

    {[
      let f  = fun x -> g x 
    ]}

    {[
      let f = g 
    ]}
*)

type arity = 
  | Single of Lam_arity.t
  | Submodule of Lam_arity.t array

type cmj_value = {
  arity : arity ; 
  persistent_closed_lambda : Lam.t option ; 
  (* Either constant or closed functor *)
}

type effect = string option

type cmj_case = Ext_namespace.file_kind 

type t 


val mk:
  values: cmj_value String_map.t -> 
  effect: effect -> 
  npm_package_path: Js_packages_info.t ->
  cmj_case:cmj_case -> 
  t

val query_by_name : 
  t ->
  string -> 
  arity * Lam.t option 

val is_pure : 
  t -> bool 

val get_npm_package_path :  
  t -> 
  Js_packages_info.t  

val get_cmj_case :   
  t ->
  cmj_case 

val single_na : arity
val pure_dummy : t
val no_pure_dummy : t


val from_file : string -> t

val from_file_with_digest :
   string -> t * Digest.t

val from_string : string -> t

(* Note writing the file if its content is not chnaged  
*)
val to_file : 
  string -> check_exists:bool -> t -> unit

val pp_cmj: t -> unit 
end = struct
#1 "js_cmj_format.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



[@@@ocaml.warning "+9"]


type arity = 
  | Single of Lam_arity.t
  | Submodule of Lam_arity.t array

(* TODO: add a magic number *)
type cmj_value = {
  arity : arity ;
  persistent_closed_lambda : Lam.t option ; 
  (** Either constant or closed functor *)
}

type effect = string option


let single_na = Single Lam_arity.na
(** we don't force people to use package *)
type cmj_case = Ext_namespace.file_kind
  
type keyed_cmj_values 
  =  (string * cmj_value) array

type t = {
  values : keyed_cmj_values ;
  pure : bool;
  npm_package_path : Js_packages_info.t ;
  cmj_case : cmj_case; 
}
let empty_values = [||]
let mk ~values ~effect ~npm_package_path ~cmj_case : t = 
  {
    values = String_map.to_sorted_array values; 
    pure = effect = None ; 
    npm_package_path;
    cmj_case
  }

let cmj_magic_number =  "BUCKLE20171012"
let cmj_magic_number_length = 
  String.length cmj_magic_number

let pure_dummy = 
  {
    values = empty_values;
    pure = true;
    npm_package_path = Js_packages_info.empty;
    cmj_case = Little_js;
  }

let no_pure_dummy = 
  {
    values = empty_values;
    pure = false;
    npm_package_path = Js_packages_info.empty;  
    cmj_case = Little_js; (** TODO: consistent with Js_config.bs_suffix default *)
  }

let digest_length = 16 (*16 chars *)

let verify_magic_in_beg ic =
  let buffer = really_input_string ic cmj_magic_number_length in 
  if buffer <> cmj_magic_number then
    Ext_fmt.failwithf ~loc:__LOC__ 
      "cmj files have incompatible versions, please rebuilt using the new compiler : %s" 
        __LOC__


(* Serialization .. *)
let from_file name : t =
  let ic = open_in_bin name in 
  verify_magic_in_beg ic ; 
  let _digest = Digest.input ic in 
  let v  : t = input_value ic in 
  close_in ic ;
  v 

let from_file_with_digest name : t * Digest.t =
  let ic = open_in_bin name in 
  verify_magic_in_beg ic ; 
  let digest = Digest.input ic in 
  let v  : t = input_value ic in 
  close_in ic ;
  v,digest 


let from_string s : t = 
  let magic_number = String.sub s 0 cmj_magic_number_length in 
  if magic_number = cmj_magic_number then 
    Marshal.from_string s  (digest_length + cmj_magic_number_length)
  else 
    Ext_fmt.failwithf ~loc:__LOC__ 
      "cmj files have incompatible versions, please rebuilt using the new compiler : %s"
        __LOC__

let fixed_length = cmj_magic_number_length + digest_length

let rec for_sure_not_changed (name : string) (header : string) =   
  if Sys.file_exists name then 
    let ic = open_in_bin name in 
    let holder =
      really_input_string ic fixed_length in 
    close_in ic; 
    holder = header
  else false  
    
(* This may cause some build system always rebuild
  maybe should not be turned on by default
*) 
let to_file name ~check_exists (v : t) = 
  let s = Marshal.to_string v [] in 
  let cur_digest = Digest.string s in 
  let header = cmj_magic_number ^ cur_digest in 
  if  not (check_exists && for_sure_not_changed name header) then 
    let oc = open_out_bin name in 
    output_string oc header;    
    output_string oc s;
    close_out oc 

let keyComp (a : string) (b,_) = 
    String_map.compare_key  a b 

let not_found = single_na, None 
let get_result  midVal = 
  let (_,cmj_value) = midVal in 
  cmj_value.arity,
  if Js_config.get_cross_module_inline () then cmj_value.persistent_closed_lambda
  else None 

let rec binarySearchAux arr lo hi (key : string) = 
  let mid = (lo + hi)/2 in 
  let midVal = Array.unsafe_get arr mid in 
  let c = keyComp key midVal in 
  if c = 0 then 
    get_result midVal
  else if c < 0 then  (*  a[lo] =< key < a[mid] <= a[hi] *)
    if hi = mid then  
      let loVal = (Array.unsafe_get arr lo) in 
      if fst loVal = key then get_result loVal
      else not_found
    else binarySearchAux arr lo mid key 
  else  (*  a[lo] =< a[mid] < key <= a[hi] *)
  if lo = mid then 
    let hiVal = (Array.unsafe_get arr hi) in 
    if fst hiVal = key  then get_result hiVal
    else not_found
  else binarySearchAux arr mid hi key

let binarySearch (sorted : keyed_cmj_values) (key : string) =  
  let len = Array.length sorted in 
  if len = 0 then not_found
  else 
    let lo = Array.unsafe_get sorted 0 in 
    let c = keyComp key lo in 
    if c < 0 then not_found
    else
      let hi = Array.unsafe_get sorted (len - 1) in 
      let c2 = keyComp key hi in 
      if c2 > 0 then not_found
      else binarySearchAux sorted 0 (len - 1) key 


(* FIXME: better error message when ocamldep
  get self-cycle
*)    
let query_by_name (cmj_table : t ) name =   
  let values = cmj_table.values in    
  binarySearch values name 

let is_pure (cmj_table : t ) = 
  cmj_table.pure

let get_npm_package_path (cmj_table : t) = 
  cmj_table.npm_package_path

let get_cmj_case (cmj_table : t) =  
  cmj_table.cmj_case


(* start dumping *)

let f fmt = Printf.fprintf stdout fmt 

let pp_cmj_case  (cmj_case : cmj_case) : unit = 
  match cmj_case with 
  | Little_js -> 
    f  "case : little, .js \n"
  | Little_bs -> 
    f  "case : little, .bs.js \n"    
  | Upper_js -> 
    f  "case: upper, .js  \n"
  | Upper_bs -> 
    f  "case: upper, .bs.js  \n"    

let pp_cmj 
    ({ values ; pure; npm_package_path ; cmj_case} : t) = 
  f  "package info: %s\n"  
    (Format.asprintf "%a" Js_packages_info.dump_packages_info npm_package_path)        
  ;
  pp_cmj_case  cmj_case;

  f "effect: %s\n"
      (if pure then "pure" else "not pure");
   Ext_array.iter values 
    (fun (k , {arity; persistent_closed_lambda}) -> 
       match arity with             
       | Single arity ->
         f "%s: %s\n" k (Format.asprintf "%a" Lam_arity.print arity);
         (match persistent_closed_lambda with 
          | None -> 
            f "%s: not saved\n" k 
          | Some lam -> 
            begin 
              f "%s: ======[start]\n" k ;
              f "%s\n" (Lam_print.lambda_to_string lam);
              f "%s: ======[finish]\n" k
            end )         
       | Submodule xs -> 
         (match persistent_closed_lambda with 
          | None -> f "%s: not saved\n" k 
          | Some lam -> 
            begin 
              f "%s: ======[start]\n" k ;
              f "%s" (Lam_print.lambda_to_string lam);
              f "%s: ======[finish]\n" k
            end 
         );
         Array.iteri 
         (fun i arity -> f "%s[%i] : %s \n" 
          k i 
          (Format.asprintf "%a" Lam_arity.print arity ))
         xs
    )    
end
module Config_util : sig 
#1 "config_util.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** A simple wrapper around [Config] module in compiler-libs, so that the search path
    is the same
*)


val find_opt : string -> string option
(** [find filename] Input is a file name, output is absolute path *)


end = struct
#1 "config_util.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






let find_in_path_uncap path name =
  let uname = Ext_string.uncapitalize_ascii name in
  let rec try_dir = function
    | [] -> None
    | dir::rem ->      
      let ufullname = Filename.concat dir uname in
      if Sys.file_exists ufullname then Some ufullname
      else 
        let fullname = Filename.concat dir name   in
        if Sys.file_exists fullname then Some fullname
        else try_dir rem
  in try_dir path



(* ATTENTION: lazy to wait [Config.load_path] populated *)
let find_opt file =  find_in_path_uncap !Config.load_path file 





end
module Js_cmj_load : sig 
#1 "js_cmj_load.mli"
(* Copyright (C) Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


 (** This module is platform dependent, on browser environment, 
    it depends on {!Js_cmj_datasets}, for non-browser environment, it fails
 *)



(** return path and meta data *)
val find_cmj : string -> string * Js_cmj_format.t

end = struct
#1 "js_cmj_load.ml"
(* Copyright (C) Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

(* strategy:
   If not installed, use the distributed [cmj] files, 
   make sure that the distributed files are platform independent
*)
let find_cmj file : string * Js_cmj_format.t = 
  match Config_util.find_opt file with
  | Some f
    -> 
    f, Js_cmj_format.from_file f             
  | None -> 
    (* ONLY read the stored cmj data in browser environment *)

        Bs_exception.error (Cmj_not_found file)
        


end
module Js_reserved_map : sig 
#1 "js_reserved_map.mli"
(* Copyright (C) 2019-Present Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


 val is_reserved : 
  string -> bool 
end = struct
#1 "js_reserved_map.ml"

(* Copyright (C) 2019-Present Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

let sorted_keywords = [|
  "AbortController";
  "AbortSignal";
  "ActiveXObject";
  "AnalyserNode";
  "AnimationEvent";
  "Array";
  "ArrayBuffer";
  "Atomics";
  "Attr";
  "Audio";
  "AudioBuffer";
  "AudioBufferSourceNode";
  "AudioContext";
  "AudioDestinationNode";
  "AudioListener";
  "AudioNode";
  "AudioParam";
  "AudioParamMap";
  "AudioProcessingEvent";
  "AudioScheduledSourceNode";
  "AudioWorkletNode";
  "BarProp";
  "BaseAudioContext";
  "BatteryManager";
  "BeforeInstallPromptEvent";
  "BeforeUnloadEvent";
  "BigInt";
  "BigInt64Array";
  "BigUint64Array";
  "BiquadFilterNode";
  "Blob";
  "BlobEvent";
  "BluetoothUUID";
  "Boolean";
  "BroadcastChannel";
  "Buffer";
  "ByteLengthQueuingStrategy";
  "CDATASection";
  "CSS";
  "CSSConditionRule";
  "CSSFontFaceRule";
  "CSSGroupingRule";
  "CSSImageValue";
  "CSSImportRule";
  "CSSKeyframeRule";
  "CSSKeyframesRule";
  "CSSKeywordValue";
  "CSSMathInvert";
  "CSSMathMax";
  "CSSMathMin";
  "CSSMathNegate";
  "CSSMathProduct";
  "CSSMathSum";
  "CSSMathValue";
  "CSSMatrixComponent";
  "CSSMediaRule";
  "CSSNamespaceRule";
  "CSSNumericArray";
  "CSSNumericValue";
  "CSSPageRule";
  "CSSPerspective";
  "CSSPositionValue";
  "CSSRotate";
  "CSSRule";
  "CSSRuleList";
  "CSSScale";
  "CSSSkew";
  "CSSSkewX";
  "CSSSkewY";
  "CSSStyleDeclaration";
  "CSSStyleRule";
  "CSSStyleSheet";
  "CSSStyleValue";
  "CSSSupportsRule";
  "CSSTransformComponent";
  "CSSTransformValue";
  "CSSTranslate";
  "CSSUnitValue";
  "CSSUnparsedValue";
  "CSSVariableReferenceValue";
  "CanvasCaptureMediaStreamTrack";
  "CanvasGradient";
  "CanvasPattern";
  "CanvasRenderingContext2D";
  "ChannelMergerNode";
  "ChannelSplitterNode";
  "CharacterData";
  "ClipboardEvent";
  "CloseEvent";
  "Comment";
  "CompositionEvent";
  "ConstantSourceNode";
  "ConvolverNode";
  "CountQueuingStrategy";
  "Crypto";
  "CryptoKey";
  "CustomElementRegistry";
  "CustomEvent";
  "DOMError";
  "DOMException";
  "DOMImplementation";
  "DOMMatrix";
  "DOMMatrixReadOnly";
  "DOMParser";
  "DOMPoint";
  "DOMPointReadOnly";
  "DOMQuad";
  "DOMRect";
  "DOMRectList";
  "DOMRectReadOnly";
  "DOMStringList";
  "DOMStringMap";
  "DOMTokenList";
  "DataTransfer";
  "DataTransferItem";
  "DataTransferItemList";
  "DataView";
  "Date";
  "DelayNode";
  "DeviceMotionEvent";
  "DeviceOrientationEvent";
  "Document";
  "DocumentFragment";
  "DocumentType";
  "DragEvent";
  "DynamicsCompressorNode";
  "Element";
  "EnterPictureInPictureEvent";
  "Error";
  "ErrorEvent";
  "EvalError";
  "Event";
  "EventSource";
  "EventTarget";
  "File";
  "FileList";
  "FileReader";
  "Float32Array";
  "Float64Array";
  "FocusEvent";
  "FontFace";
  "FontFaceSetLoadEvent";
  "FormData";
  "Function";
  "GainNode";
  "Gamepad";
  "GamepadButton";
  "GamepadEvent";
  "GamepadHapticActuator";
  "HTMLAllCollection";
  "HTMLAnchorElement";
  "HTMLAreaElement";
  "HTMLAudioElement";
  "HTMLBRElement";
  "HTMLBaseElement";
  "HTMLBodyElement";
  "HTMLButtonElement";
  "HTMLCanvasElement";
  "HTMLCollection";
  "HTMLContentElement";
  "HTMLDListElement";
  "HTMLDataElement";
  "HTMLDataListElement";
  "HTMLDetailsElement";
  "HTMLDialogElement";
  "HTMLDirectoryElement";
  "HTMLDivElement";
  "HTMLDocument";
  "HTMLElement";
  "HTMLEmbedElement";
  "HTMLFieldSetElement";
  "HTMLFontElement";
  "HTMLFormControlsCollection";
  "HTMLFormElement";
  "HTMLFrameElement";
  "HTMLFrameSetElement";
  "HTMLHRElement";
  "HTMLHeadElement";
  "HTMLHeadingElement";
  "HTMLHtmlElement";
  "HTMLIFrameElement";
  "HTMLImageElement";
  "HTMLInputElement";
  "HTMLLIElement";
  "HTMLLabelElement";
  "HTMLLegendElement";
  "HTMLLinkElement";
  "HTMLMapElement";
  "HTMLMarqueeElement";
  "HTMLMediaElement";
  "HTMLMenuElement";
  "HTMLMetaElement";
  "HTMLMeterElement";
  "HTMLModElement";
  "HTMLOListElement";
  "HTMLObjectElement";
  "HTMLOptGroupElement";
  "HTMLOptionElement";
  "HTMLOptionsCollection";
  "HTMLOutputElement";
  "HTMLParagraphElement";
  "HTMLParamElement";
  "HTMLPictureElement";
  "HTMLPreElement";
  "HTMLProgressElement";
  "HTMLQuoteElement";
  "HTMLScriptElement";
  "HTMLSelectElement";
  "HTMLShadowElement";
  "HTMLSlotElement";
  "HTMLSourceElement";
  "HTMLSpanElement";
  "HTMLStyleElement";
  "HTMLTableCaptionElement";
  "HTMLTableCellElement";
  "HTMLTableColElement";
  "HTMLTableElement";
  "HTMLTableRowElement";
  "HTMLTableSectionElement";
  "HTMLTemplateElement";
  "HTMLTextAreaElement";
  "HTMLTimeElement";
  "HTMLTitleElement";
  "HTMLTrackElement";
  "HTMLUListElement";
  "HTMLUnknownElement";
  "HTMLVideoElement";
  "HashChangeEvent";
  "Headers";
  "History";
  "IDBCursor";
  "IDBCursorWithValue";
  "IDBDatabase";
  "IDBFactory";
  "IDBIndex";
  "IDBKeyRange";
  "IDBObjectStore";
  "IDBOpenDBRequest";
  "IDBRequest";
  "IDBTransaction";
  "IDBVersionChangeEvent";
  "IIRFilterNode";
  "IdleDeadline";
  "Image";
  "ImageBitmap";
  "ImageBitmapRenderingContext";
  "ImageCapture";
  "ImageData";
  "Infinity";
  "InputDeviceCapabilities";
  "InputDeviceInfo";
  "InputEvent";
  "Int16Array";
  "Int32Array";
  "Int8Array";
  "IntersectionObserver";
  "IntersectionObserverEntry";
  "Intl";
  "JSON";
  "KeyboardEvent";
  "Location";
  "MIDIAccess";
  "MIDIConnectionEvent";
  "MIDIInput";
  "MIDIInputMap";
  "MIDIMessageEvent";
  "MIDIOutput";
  "MIDIOutputMap";
  "MIDIPort";
  "Map";
  "Math";
  "MediaCapabilities";
  "MediaCapabilitiesInfo";
  "MediaDeviceInfo";
  "MediaDevices";
  "MediaElementAudioSourceNode";
  "MediaEncryptedEvent";
  "MediaError";
  "MediaList";
  "MediaQueryList";
  "MediaQueryListEvent";
  "MediaRecorder";
  "MediaSettingsRange";
  "MediaSource";
  "MediaStream";
  "MediaStreamAudioDestinationNode";
  "MediaStreamAudioSourceNode";
  "MediaStreamEvent";
  "MediaStreamTrack";
  "MediaStreamTrackEvent";
  "MessageChannel";
  "MessageEvent";
  "MessagePort";
  "MimeType";
  "MimeTypeArray";
  "MouseEvent";
  "MutationEvent";
  "MutationObserver";
  "MutationRecord";
  "NaN";
  "NamedNodeMap";
  "Navigator";
  "NetworkInformation";
  "Node";
  "NodeFilter";
  "NodeIterator";
  "NodeList";
  "Notification";
  "Number";
  "Object";
  "OfflineAudioCompletionEvent";
  "OfflineAudioContext";
  "OffscreenCanvas";
  "OffscreenCanvasRenderingContext2D";
  "Option";
  "OscillatorNode";
  "OverconstrainedError";
  "PageTransitionEvent";
  "PannerNode";
  "Path2D";
  "PaymentInstruments";
  "PaymentManager";
  "PaymentRequestUpdateEvent";
  "Performance";
  "PerformanceEntry";
  "PerformanceLongTaskTiming";
  "PerformanceMark";
  "PerformanceMeasure";
  "PerformanceNavigation";
  "PerformanceNavigationTiming";
  "PerformanceObserver";
  "PerformanceObserverEntryList";
  "PerformancePaintTiming";
  "PerformanceResourceTiming";
  "PerformanceServerTiming";
  "PerformanceTiming";
  "PeriodicWave";
  "PermissionStatus";
  "Permissions";
  "PhotoCapabilities";
  "PictureInPictureWindow";
  "Plugin";
  "PluginArray";
  "PointerEvent";
  "PopStateEvent";
  "ProcessingInstruction";
  "ProgressEvent";
  "Promise";
  "PromiseRejectionEvent";
  "Proxy";
  "PushManager";
  "PushSubscription";
  "PushSubscriptionOptions";
  "RTCCertificate";
  "RTCDTMFSender";
  "RTCDTMFToneChangeEvent";
  "RTCDataChannel";
  "RTCDataChannelEvent";
  "RTCIceCandidate";
  "RTCPeerConnection";
  "RTCPeerConnectionIceEvent";
  "RTCRtpContributingSource";
  "RTCRtpReceiver";
  "RTCRtpSender";
  "RTCRtpTransceiver";
  "RTCSessionDescription";
  "RTCStatsReport";
  "RTCTrackEvent";
  "RadioNodeList";
  "Range";
  "RangeError";
  "ReadableStream";
  "ReferenceError";
  "Reflect";
  "RegExp";
  "RemotePlayback";
  "ReportingObserver";
  "Request";
  "ResizeObserver";
  "ResizeObserverEntry";
  "Response";
  "SVGAElement";
  "SVGAngle";
  "SVGAnimateElement";
  "SVGAnimateMotionElement";
  "SVGAnimateTransformElement";
  "SVGAnimatedAngle";
  "SVGAnimatedBoolean";
  "SVGAnimatedEnumeration";
  "SVGAnimatedInteger";
  "SVGAnimatedLength";
  "SVGAnimatedLengthList";
  "SVGAnimatedNumber";
  "SVGAnimatedNumberList";
  "SVGAnimatedPreserveAspectRatio";
  "SVGAnimatedRect";
  "SVGAnimatedString";
  "SVGAnimatedTransformList";
  "SVGAnimationElement";
  "SVGCircleElement";
  "SVGClipPathElement";
  "SVGComponentTransferFunctionElement";
  "SVGDefsElement";
  "SVGDescElement";
  "SVGDiscardElement";
  "SVGElement";
  "SVGEllipseElement";
  "SVGFEBlendElement";
  "SVGFEColorMatrixElement";
  "SVGFEComponentTransferElement";
  "SVGFECompositeElement";
  "SVGFEConvolveMatrixElement";
  "SVGFEDiffuseLightingElement";
  "SVGFEDisplacementMapElement";
  "SVGFEDistantLightElement";
  "SVGFEDropShadowElement";
  "SVGFEFloodElement";
  "SVGFEFuncAElement";
  "SVGFEFuncBElement";
  "SVGFEFuncGElement";
  "SVGFEFuncRElement";
  "SVGFEGaussianBlurElement";
  "SVGFEImageElement";
  "SVGFEMergeElement";
  "SVGFEMergeNodeElement";
  "SVGFEMorphologyElement";
  "SVGFEOffsetElement";
  "SVGFEPointLightElement";
  "SVGFESpecularLightingElement";
  "SVGFESpotLightElement";
  "SVGFETileElement";
  "SVGFETurbulenceElement";
  "SVGFilterElement";
  "SVGForeignObjectElement";
  "SVGGElement";
  "SVGGeometryElement";
  "SVGGradientElement";
  "SVGGraphicsElement";
  "SVGImageElement";
  "SVGLength";
  "SVGLengthList";
  "SVGLineElement";
  "SVGLinearGradientElement";
  "SVGMPathElement";
  "SVGMarkerElement";
  "SVGMaskElement";
  "SVGMatrix";
  "SVGMetadataElement";
  "SVGNumber";
  "SVGNumberList";
  "SVGPathElement";
  "SVGPatternElement";
  "SVGPoint";
  "SVGPointList";
  "SVGPolygonElement";
  "SVGPolylineElement";
  "SVGPreserveAspectRatio";
  "SVGRadialGradientElement";
  "SVGRect";
  "SVGRectElement";
  "SVGSVGElement";
  "SVGScriptElement";
  "SVGSetElement";
  "SVGStopElement";
  "SVGStringList";
  "SVGStyleElement";
  "SVGSwitchElement";
  "SVGSymbolElement";
  "SVGTSpanElement";
  "SVGTextContentElement";
  "SVGTextElement";
  "SVGTextPathElement";
  "SVGTextPositioningElement";
  "SVGTitleElement";
  "SVGTransform";
  "SVGTransformList";
  "SVGUnitTypes";
  "SVGUseElement";
  "SVGViewElement";
  "Screen";
  "ScreenOrientation";
  "ScriptProcessorNode";
  "SecurityPolicyViolationEvent";
  "Selection";
  "Set";
  "ShadowRoot";
  "SharedArrayBuffer";
  "SharedWorker";
  "SourceBuffer";
  "SourceBufferList";
  "SpeechSynthesisErrorEvent";
  "SpeechSynthesisEvent";
  "SpeechSynthesisUtterance";
  "StaticRange";
  "StereoPannerNode";
  "Storage";
  "StorageEvent";
  "String";
  "StylePropertyMap";
  "StylePropertyMapReadOnly";
  "StyleSheet";
  "StyleSheetList";
  "SubtleCrypto";
  "Symbol";
  "SyncManager";
  "SyntaxError";
  "TaskAttributionTiming";
  "Text";
  "TextDecoder";
  "TextDecoderStream";
  "TextEncoder";
  "TextEncoderStream";
  "TextEvent";
  "TextMetrics";
  "TextTrack";
  "TextTrackCue";
  "TextTrackCueList";
  "TextTrackList";
  "TimeRanges";
  "Touch";
  "TouchEvent";
  "TouchList";
  "TrackEvent";
  "TransformStream";
  "TransitionEvent";
  "TreeWalker";
  "TypeError";
  "UIEvent";
  "URIError";
  "URL";
  "URLSearchParams";
  "Uint16Array";
  "Uint32Array";
  "Uint8Array";
  "Uint8ClampedArray";
  "UserActivation";
  "VTTCue";
  "ValidityState";
  "VisualViewport";
  "WaveShaperNode";
  "WeakMap";
  "WeakSet";
  "WebAssembly";
  "WebGL2RenderingContext";
  "WebGLActiveInfo";
  "WebGLBuffer";
  "WebGLContextEvent";
  "WebGLFramebuffer";
  "WebGLProgram";
  "WebGLQuery";
  "WebGLRenderbuffer";
  "WebGLRenderingContext";
  "WebGLSampler";
  "WebGLShader";
  "WebGLShaderPrecisionFormat";
  "WebGLSync";
  "WebGLTexture";
  "WebGLTransformFeedback";
  "WebGLUniformLocation";
  "WebGLVertexArrayObject";
  "WebKitCSSMatrix";
  "WebKitMutationObserver";
  "WebSocket";
  "WheelEvent";
  "Window";
  "Worker";
  "WritableStream";
  "XDomainRequest";
  "XMLDocument";
  "XMLHttpRequest";
  "XMLHttpRequestEventTarget";
  "XMLHttpRequestUpload";
  "XMLSerializer";
  "XPathEvaluator";
  "XPathExpression";
  "XPathResult";
  "XSLTProcessor";
  "__dirname";
  "__esModule";
  "__filename";
  "abstract";
  "arguments";
  "await";
  "boolean";
  "break";
  "byte";
  "case";
  "catch";
  "char";
  "class";
  "clearImmediate";
  "clearInterval";
  "clearTimeout";
  "console";
  "const";
  "continue";
  "debugger";
  "decodeURI";
  "decodeURIComponent";
  "default";
  "delete";
  "do";
  "document";
  "double";
  "else";
  "encodeURI";
  "encodeURIComponent";
  "enum";
  "escape";
  "eval";
  "event";
  "export";
  "exports";
  "extends";
  "false";
  "fetch";
  "final";
  "finally";
  "float";
  "for";
  "function";
  "global";
  "goto";
  "if";
  "implements";
  "import";
  "in";
  "instanceof";
  "int";
  "interface";
  "isFinite";
  "isNaN";
  "let";
  "location";
  "long";
  "module";
  "native";
  "navigator";
  "new";
  "null";
  "package";
  "parseFloat";
  "parseInt";
  "private";
  "process";
  "protected";
  "public";
  "require";
  "return";
  "setImmediate";
  "setInterval";
  "setTimeout";
  "short";
  "static";
  "super";
  "switch";
  "synchronized";
  "then";
  "this";
  "throw";
  "transient";
  "true";
  "try";
  "typeof";
  "undefined";
  "unescape";
  "var";
  "void";
  "volatile";
  "while";
  "window";
  "with";
  "yield";
  |]


type element = string 

let rec binarySearchAux (arr : element array) (lo : int) (hi : int) key : bool =   
    let mid = (lo + hi)/2 in 
    let midVal = Array.unsafe_get arr mid in 
    (* let c = cmp key midVal [@bs] in  *)
    if key = midVal then true 
    else if key < midVal then  (*  a[lo] =< key < a[mid] <= a[hi] *)
      if hi = mid then  
        (Array.unsafe_get arr lo) = key 
      else binarySearchAux arr lo mid key 
    else  (*  a[lo] =< a[mid] < key <= a[hi] *)
      if lo = mid then 
        (Array.unsafe_get arr hi) = key 
      else binarySearchAux arr mid hi key 

let binarySearch (sorted : element array) (key : element)  : bool =  
  let len = Array.length sorted in 
  if len = 0 then false
  else 
    let lo = Array.unsafe_get sorted 0 in 
    (* let c = cmp key lo [@bs] in  *)
    if key < lo then false
    else
    let hi = Array.unsafe_get sorted (len - 1) in 
    (* let c2 = cmp key hi [@bs]in  *)
    if key > hi then false
    else binarySearchAux sorted 0 (len - 1) key 

let is_reserved s = binarySearch sorted_keywords s     

end
module Ext_ident : sig 
#1 "ext_ident.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** A wrapper around [Ident] module in compiler-libs*)

 val is_js : Ident.t -> bool 

val is_js_object : Ident.t -> bool

(** create identifiers for predefined [js] global variables *)
val create_js : string -> Ident.t

val create : string -> Ident.t

 val make_js_object : Ident.t -> unit 

val reset : unit -> unit

val create_tmp :  ?name:string -> unit -> Ident.t

val make_unused : unit -> Ident.t 



(**
   Invariant: if name is not converted, the reference should be equal
*)
val convert : string -> string



val is_js_or_global : Ident.t -> bool



val compare : Ident.t -> Ident.t -> int
val equal : Ident.t -> Ident.t -> bool 

end = struct
#1 "ext_ident.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








let js_flag = 0b1_000 (* check with ocaml compiler *)

(* let js_module_flag = 0b10_000 (\* javascript external modules *\) *)
(* TODO:
    check name conflicts with javascript conventions
   {[
     Ext_ident.convert "^";;
     - : string = "$caret"
   ]}
*)
let js_object_flag = 0b100_000 (* javascript object flags *)

let is_js (i : Ident.t) =
  i.flags land js_flag <> 0

let is_js_or_global (i : Ident.t) =
  i.flags land (8 lor 1) <> 0


let is_js_object (i : Ident.t) =
  i.flags land js_object_flag <> 0

let make_js_object (i : Ident.t) =
  i.flags <- i.flags lor js_object_flag

(* It's a js function hard coded by js api, so when printing,
   it should preserve the name
*)
let create_js (name : string) : Ident.t  =
  { name = name; flags = js_flag ; stamp = 0}

let create = Ident.create

(* FIXME: no need for `$' operator *)
let create_tmp ?(name=Literals.tmp) () = create name


let js_module_table : Ident.t String_hashtbl.t = String_hashtbl.create 31

(* This is for a js exeternal module, we can change it when printing
   for example
   {[
     var React$1 = require('react');
     React$1.render(..)
   ]}

   Given a name, if duplicated, they should  have the same id
*)
let create_js_module (name : string) : Ident.t =
  let name =
    String.concat "" @@ Ext_list.map 
    (Ext_string.split name '-')  Ext_string.capitalize_ascii in
  (* TODO: if we do such transformation, we should avoid       collision for example:
      react-dom
      react--dom
      check collision later
  *)
  match String_hashtbl.find_exn js_module_table name  with
  | exception Not_found ->
    let ans = Ident.create name in
    (* let ans = { v with flags = js_module_flag} in  *)
    String_hashtbl.add js_module_table name ans;
    ans
  | v -> (* v *) Ident.rename v






exception Not_normal_letter of int
let name_mangle name =

  let len = String.length name  in
  try
    for i  = 0 to len - 1 do
      match String.unsafe_get name i with
      | 'a' .. 'z' | 'A' .. 'Z'
      | '0' .. '9' | '_' | '$'
        -> ()
      | _ -> raise (Not_normal_letter i)
    done;
    name (* Normal letter *)
  with
  | Not_normal_letter 0 ->

    let buffer = Buffer.create len in
    for j = 0 to  len - 1 do
      let c = String.unsafe_get name j in
      match c with
      | '*' -> Buffer.add_string buffer "$star"
      | '\'' -> Buffer.add_string buffer "$prime"
      | '!' -> Buffer.add_string buffer "$bang"
      | '>' -> Buffer.add_string buffer "$great"
      | '<' -> Buffer.add_string buffer "$less"
      | '=' -> Buffer.add_string buffer "$eq"
      | '+' -> Buffer.add_string buffer "$plus"
      | '-' -> Buffer.add_string buffer "$neg"
      | '@' -> Buffer.add_string buffer "$at"
      | '^' -> Buffer.add_string buffer "$caret"
      | '/' -> Buffer.add_string buffer "$slash"
      | '|' -> Buffer.add_string buffer "$pipe"
      | '.' -> Buffer.add_string buffer "$dot"
      | '%' -> Buffer.add_string buffer "$percent"
      | '~' -> Buffer.add_string buffer "$tilde"
      | '#' -> Buffer.add_string buffer "$hash"
      | ':' -> Buffer.add_string buffer "$colon"
      | 'a'..'z' | 'A'..'Z'| '_'
      | '$'
      | '0'..'9'-> Buffer.add_char buffer  c
      | _ -> Buffer.add_string buffer "$unknown"
    done; Buffer.contents buffer
  | Not_normal_letter i ->
    String.sub name 0 i ^
    (let buffer = Buffer.create len in
     for j = i to  len - 1 do
       let c = String.unsafe_get name j in
       match c with
       | '*' -> Buffer.add_string buffer "$star"
       | '\'' -> Buffer.add_string buffer "$prime"
       | '!' -> Buffer.add_string buffer "$bang"
       | '>' -> Buffer.add_string buffer "$great"
       | '<' -> Buffer.add_string buffer "$less"
       | '=' -> Buffer.add_string buffer "$eq"
       | '+' -> Buffer.add_string buffer "$plus"
       | '-' -> Buffer.add_string buffer "$"
        (* Note ocaml compiler also has [self-] *)
       | '@' -> Buffer.add_string buffer "$at"
       | '^' -> Buffer.add_string buffer "$caret"
       | '/' -> Buffer.add_string buffer "$slash"
       | '|' -> Buffer.add_string buffer "$pipe"
       | '.' -> Buffer.add_string buffer "$dot"
       | '%' -> Buffer.add_string buffer "$percent"
       | '~' -> Buffer.add_string buffer "$tilde"
       | '#' -> Buffer.add_string buffer "$hash"
       | ':' -> Buffer.add_string buffer "$colon"
       | '$' -> Buffer.add_string buffer "$dollar"
       | 'a'..'z' | 'A'..'Z'| '_'
       | '0'..'9'-> Buffer.add_char buffer  c
       | _ -> Buffer.add_string buffer "$unknown"
     done; Buffer.contents buffer)
(* TODO:
    check name conflicts with javascript conventions
   {[
     Ext_ident.convert "^";;
     - : string = "$caret"
   ]}
   [convert name] if [name] is a js keyword,add "$$"
   otherwise do the name mangling to make sure ocaml identifier it is
   a valid js identifier
*)
let convert (name : string) =
  if  Js_reserved_map.is_reserved name  then 
    "$$" ^ name
  else name_mangle name

(** keyword could be used in property *)

(* It is currently made a persistent ident to avoid fresh ids
    which would result in different signature files
    - other solution: use lazy values
*)
let make_unused () = create "_"



let reset () =
  String_hashtbl.clear js_module_table


(* Has to be total order, [x < y]
   and [x > y] should be consistent
   flags are not relevant here
*)
let compare (x : Ident.t ) ( y : Ident.t) =
  let u = x.stamp - y.stamp in
  if u = 0 then
    Ext_string.compare x.name y.name
  else u

let equal ( x : Ident.t) ( y : Ident.t) =
  if x.stamp <> 0 then x.stamp = y.stamp
  else y.stamp = 0 && x.name = y.name


end
module Set_gen
= struct
#1 "set_gen.ml"
(***********************************************************************)
(*                                                                     *)
(*                                OCaml                                *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the GNU Library General Public License, with    *)
(*  the special exception on linking described in file ../LICENSE.     *)
(*                                                                     *)
(***********************************************************************)

(** balanced tree based on stdlib distribution *)

type ('a, 'id) t0 = 
  | Empty 
  | Node of ('a, 'id) t0 * 'a * ('a, 'id) t0 * int 

type ('a, 'id) enumeration0 = 
  | End | More of 'a * ('a, 'id) t0 * ('a, 'id) enumeration0


let rec cons_enum s e = 
  match s with 
  | Empty -> e 
  | Node(l,v,r,_) -> cons_enum l (More(v,r,e))

let rec height = function
  | Empty -> 0 
  | Node(_,_,_,h) -> h   

(* Smallest and greatest element of a set *)

let rec min_elt = function
    Empty -> raise Not_found
  | Node(Empty, v, r, _) -> v
  | Node(l, v, r, _) -> min_elt l

let rec max_elt = function
    Empty -> raise Not_found
  | Node(l, v, Empty, _) -> v
  | Node(l, v, r, _) -> max_elt r




let empty = Empty

let is_empty = function Empty -> true | _ -> false

let rec cardinal_aux acc  = function
  | Empty -> acc 
  | Node (l,_,r, _) -> 
    cardinal_aux  (cardinal_aux (acc + 1)  r ) l 

let cardinal s = cardinal_aux 0 s 

let rec elements_aux accu = function
  | Empty -> accu
  | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l

let elements s =
  elements_aux [] s

let choose = min_elt

let rec iter  x f = match x with
  | Empty -> ()
  | Node(l, v, r, _) -> iter l f ; f v; iter r f 

let rec fold s accu f =
  match s with
  | Empty -> accu
  | Node(l, v, r, _) -> fold r (f v (fold l accu f)) f 

let rec for_all x p = match x with
  | Empty -> true
  | Node(l, v, r, _) -> p v && for_all l p && for_all r p 

let rec exists x p = match x with
  | Empty -> false
  | Node(l, v, r, _) -> p v || exists l p  || exists r p


let max_int3 (a : int) b c = 
  if a >= b then 
    if a >= c then a 
    else c
  else 
  if b >=c then b
  else c     
let max_int_2 (a : int) b =  
  if a >= b then a else b 



exception Height_invariant_broken
exception Height_diff_borken 

let rec check_height_and_diff = 
  function 
  | Empty -> 0
  | Node(l,_,r,h) -> 
    let hl = check_height_and_diff l in
    let hr = check_height_and_diff r in
    if h <>  max_int_2 hl hr + 1 then raise Height_invariant_broken
    else  
      let diff = (abs (hl - hr)) in  
      if  diff > 2 then raise Height_diff_borken 
      else h     

let check tree = 
  ignore (check_height_and_diff tree)
(* 
    Invariants: 
    1. {[ l < v < r]}
    2. l and r balanced 
    3. [height l] - [height r] <= 2
*)
let create l v r = 
  let hl = match l with Empty -> 0 | Node (_,_,_,h) -> h in
  let hr = match r with Empty -> 0 | Node (_,_,_,h) -> h in
  Node(l,v,r, if hl >= hr then hl + 1 else hr + 1)         

(* Same as create, but performs one step of rebalancing if necessary.
    Invariants:
    1. {[ l < v < r ]}
    2. l and r balanced 
    3. | height l - height r | <= 3.

    Proof by indunction

    Lemma: the height of  [bal l v r] will bounded by [max l r] + 1 
*)
let internal_bal l v r =
  let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
  let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
  if hl > hr + 2 then begin
    match l with
      Empty -> assert false
    | Node(ll, lv, lr, _) ->   
      if height ll >= height lr then
        (* [ll] >~ [lr] 
           [ll] >~ [r] 
           [ll] ~~ [ lr ^ r]  
        *)
        create ll lv (create lr v r)
      else begin
        match lr with
          Empty -> assert false
        | Node(lrl, lrv, lrr, _)->
          (* [lr] >~ [ll]
             [lr] >~ [r]
             [ll ^ lrl] ~~ [lrr ^ r]   
          *)
          create (create ll lv lrl) lrv (create lrr v r)
      end
  end else if hr > hl + 2 then begin
    match r with
      Empty -> assert false
    | Node(rl, rv, rr, _) ->
      if height rr >= height rl then
        create (create l v rl) rv rr
      else begin
        match rl with
          Empty -> assert false
        | Node(rll, rlv, rlr, _) ->
          create (create l v rll) rlv (create rlr rv rr)
      end
  end else
    Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1))    

let rec remove_min_elt = function
    Empty -> invalid_arg "Set.remove_min_elt"
  | Node(Empty, v, r, _) -> r
  | Node(l, v, r, _) -> internal_bal (remove_min_elt l) v r

let singleton x = Node(Empty, x, Empty, 1)    

(* 
   All elements of l must precede the elements of r.
       Assume | height l - height r | <= 2.
   weak form of [concat] 
*)

let internal_merge l r =
  match (l, r) with
  | (Empty, t) -> t
  | (t, Empty) -> t
  | (_, _) -> internal_bal l (min_elt r) (remove_min_elt r)

(* Beware: those two functions assume that the added v is *strictly*
    smaller (or bigger) than all the present elements in the tree; it
    does not test for equality with the current min (or max) element.
    Indeed, they are only used during the "join" operation which
    respects this precondition.
*)

let rec add_min_element v = function
  | Empty -> singleton v
  | Node (l, x, r, h) ->
    internal_bal (add_min_element v l) x r

let rec add_max_element v = function
  | Empty -> singleton v
  | Node (l, x, r, h) ->
    internal_bal l x (add_max_element v r)

(** 
    Invariants:
    1. l < v < r 
    2. l and r are balanced 

    Proof by induction
    The height of output will be ~~ (max (height l) (height r) + 2)
    Also use the lemma from [bal]
*)
let rec internal_join l v r =
  match (l, r) with
    (Empty, _) -> add_min_element v r
  | (_, Empty) -> add_max_element v l
  | (Node(ll, lv, lr, lh), Node(rl, rv, rr, rh)) ->
    if lh > rh + 2 then 
      (* proof by induction:
         now [height of ll] is [lh - 1] 
      *)
      internal_bal ll lv (internal_join lr v r) 
    else
    if rh > lh + 2 then internal_bal (internal_join l v rl) rv rr 
    else create l v r


(*
    Required Invariants: 
    [t1] < [t2]  
*)
let internal_concat t1 t2 =
  match (t1, t2) with
  | (Empty, t) -> t
  | (t, Empty) -> t
  | (_, _) -> internal_join t1 (min_elt t2) (remove_min_elt t2)

let rec filter x p = match x with 
  | Empty -> Empty
  | Node(l, v, r, _) ->
    (* call [p] in the expected left-to-right order *)
    let l' = filter l p in
    let pv = p v in
    let r' = filter r p in
    if pv then internal_join l' v r' else internal_concat l' r'


let rec partition x p = match x with 
  | Empty -> (Empty, Empty)
  | Node(l, v, r, _) ->
    (* call [p] in the expected left-to-right order *)
    let (lt, lf) = partition l p in
    let pv = p v in
    let (rt, rf) = partition r p in
    if pv
    then (internal_join lt v rt, internal_concat lf rf)
    else (internal_concat lt rt, internal_join lf v rf)

let of_sorted_list l =
  let rec sub n l =
    match n, l with
    | 0, l -> Empty, l
    | 1, x0 :: l -> Node (Empty, x0, Empty, 1), l
    | 2, x0 :: x1 :: l -> Node (Node(Empty, x0, Empty, 1), x1, Empty, 2), l
    | 3, x0 :: x1 :: x2 :: l ->
      Node (Node(Empty, x0, Empty, 1), x1, Node(Empty, x2, Empty, 1), 2),l
    | n, l ->
      let nl = n / 2 in
      let left, l = sub nl l in
      match l with
      | [] -> assert false
      | mid :: l ->
        let right, l = sub (n - nl - 1) l in
        create left mid right, l
  in
  fst (sub (List.length l) l)

let of_sorted_array l =   
  let rec sub start n l  =
    if n = 0 then Empty else 
    if n = 1 then 
      let x0 = Array.unsafe_get l start in
      Node (Empty, x0, Empty, 1)
    else if n = 2 then     
      let x0 = Array.unsafe_get l start in 
      let x1 = Array.unsafe_get l (start + 1) in 
      Node (Node(Empty, x0, Empty, 1), x1, Empty, 2) else
    if n = 3 then 
      let x0 = Array.unsafe_get l start in 
      let x1 = Array.unsafe_get l (start + 1) in
      let x2 = Array.unsafe_get l (start + 2) in
      Node (Node(Empty, x0, Empty, 1), x1, Node(Empty, x2, Empty, 1), 2)
    else 
      let nl = n / 2 in
      let left = sub start nl l in
      let mid = start + nl in 
      let v = Array.unsafe_get l mid in 
      let right = sub (mid + 1) (n - nl - 1) l in        
      create left v right
  in
  sub 0 (Array.length l) l 

let is_ordered ~cmp tree =
  let rec is_ordered_min_max tree =
    match tree with
    | Empty -> `Empty
    | Node(l,v,r,_) -> 
      begin match is_ordered_min_max l with
        | `No -> `No 
        | `Empty ->
          begin match is_ordered_min_max r with
            | `No  -> `No
            | `Empty -> `V (v,v)
            | `V(l,r) ->
              if cmp v l < 0 then
                `V(v,r)
              else
                `No
          end
        | `V(min_v,max_v)->
          begin match is_ordered_min_max r with
            | `No -> `No
            | `Empty -> 
              if cmp max_v v < 0 then 
                `V(min_v,v)
              else
                `No 
            | `V(min_v_r, max_v_r) ->
              if cmp max_v min_v_r < 0 then
                `V(min_v,max_v_r)
              else `No
          end
      end  in 
  is_ordered_min_max tree <> `No 

let invariant ~cmp t = 
  check t ; 
  is_ordered ~cmp t 

let rec compare_aux ~cmp e1 e2 =
  match (e1, e2) with
    (End, End) -> 0
  | (End, _)  -> -1
  | (_, End) -> 1
  | (More(v1, r1, e1), More(v2, r2, e2)) ->
    let c = cmp v1 v2 in
    if c <> 0
    then c
    else compare_aux ~cmp (cons_enum r1 e1) (cons_enum r2 e2)

let compare ~cmp s1 s2 =
  compare_aux ~cmp (cons_enum s1 End) (cons_enum s2 End)


module type S = sig
  type elt 
  type t
  val empty: t
  val is_empty: t -> bool
  val iter: t ->  (elt -> unit) -> unit
  val fold: t -> 'a -> (elt -> 'a -> 'a) -> 'a
  val for_all: t -> (elt -> bool) ->  bool
  val exists: t -> (elt -> bool) -> bool
  val singleton: elt -> t
  val cardinal: t -> int
  val elements: t -> elt list
  val min_elt: t -> elt
  val max_elt: t -> elt
  val choose: t -> elt
  val of_sorted_list : elt list -> t 
  val of_sorted_array : elt array -> t
  val partition: t -> (elt -> bool) ->  t * t

  val mem: t -> elt -> bool
  val add: t -> elt -> t
  val remove: t -> elt -> t
  val union: t -> t -> t
  val inter: t -> t -> t
  val diff: t -> t -> t
  val compare: t -> t -> int
  val equal: t -> t -> bool
  val subset: t -> t -> bool
  val filter: t -> (elt -> bool) ->  t

  val split: t -> elt -> t * bool * t
  val find:  t -> elt -> elt
  val of_list: elt list -> t
  val of_sorted_list : elt list ->  t
  val of_sorted_array : elt array -> t 
  val of_array : elt array -> t 
  val invariant : t -> bool 
  val print : Format.formatter -> t -> unit 
end 

end
module Ident_set : sig 
#1 "ident_set.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


include Set_gen.S with type elt = Ident.t





end = struct
#1 "ident_set.ml"
# 1 "ext/set.cppo.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


# 31 "ext/set.cppo.ml"
type elt = Ident.t
let compare_elt (x : elt) (y : elt) = 
  let a =  Pervasives.compare (x.stamp : int) y.stamp in 
  if a <> 0 then a 
  else 
    let b = Pervasives.compare (x.name : string) y.name in 
    if b <> 0 then b 
    else Pervasives.compare (x.flags : int) y.flags     

let print_elt = Ident.print

# 49 "ext/set.cppo.ml"
type ('a, 'id) t0 = ('a, 'id) Set_gen.t0 = 
  | Empty 
  | Node of ('a, 'id) t0 * 'a * ('a, 'id) t0 * int 

type ('a, 'id) enumeration0 = ('a, 'id) Set_gen.enumeration0 = 
  | End 
  | More of 'a * ('a, 'id) t0 * ('a, 'id) enumeration0
    
type  t = (elt, unit) t0
type enumeration = (elt, unit) Set_gen.enumeration0
let empty = Set_gen.empty 
let is_empty = Set_gen.is_empty
let iter = Set_gen.iter
let fold = Set_gen.fold
let for_all = Set_gen.for_all 
let exists = Set_gen.exists 
let singleton = Set_gen.singleton 
let cardinal = Set_gen.cardinal
let elements = Set_gen.elements
let min_elt = Set_gen.min_elt
let max_elt = Set_gen.max_elt
let choose = Set_gen.choose 
let of_sorted_list = Set_gen.of_sorted_list
let of_sorted_array = Set_gen.of_sorted_array
let partition = Set_gen.partition 
let filter = Set_gen.filter 
let of_sorted_list = Set_gen.of_sorted_list
let of_sorted_array = Set_gen.of_sorted_array

let rec split (tree : t) x : t * bool * t =  match tree with 
  | Empty ->
    (Empty, false, Empty)
  | Node(l, v, r, _) ->
    let c = compare_elt x v in
    if c = 0 then (l, true, r)
    else if c < 0 then
      let (ll, pres, rl) = split l x in (ll, pres, Set_gen.internal_join rl v r)
    else
      let (lr, pres, rr) = split r x in (Set_gen.internal_join l v lr, pres, rr)
let rec add (tree : t) x : t =  match tree with 
  | Empty -> Node(Empty, x, Empty, 1)
  | Node(l, v, r, _) as t ->
    let c = compare_elt x v in
    if c = 0 then t else
    if c < 0 then Set_gen.internal_bal (add l x ) v r else Set_gen.internal_bal l v (add r x )

let rec union (s1 : t) (s2 : t) : t  =
  match (s1, s2) with
  | (Empty, t2) -> t2
  | (t1, Empty) -> t1
  | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
    if h1 >= h2 then
      if h2 = 1 then add s1 v2 else begin
        let (l2, _, r2) = split s2 v1 in
        Set_gen.internal_join (union l1 l2) v1 (union r1 r2)
      end
    else
    if h1 = 1 then add s2 v1 else begin
      let (l1, _, r1) = split s1 v2 in
      Set_gen.internal_join (union l1 l2) v2 (union r1 r2)
    end    

let rec inter (s1 : t)  (s2 : t) : t  =
  match (s1, s2) with
  | (Empty, t2) -> Empty
  | (t1, Empty) -> Empty
  | (Node(l1, v1, r1, _), t2) ->
    begin match split t2 v1 with
      | (l2, false, r2) ->
        Set_gen.internal_concat (inter l1 l2) (inter r1 r2)
      | (l2, true, r2) ->
        Set_gen.internal_join (inter l1 l2) v1 (inter r1 r2)
    end 

let rec diff (s1 : t) (s2 : t) : t  =
  match (s1, s2) with
  | (Empty, t2) -> Empty
  | (t1, Empty) -> t1
  | (Node(l1, v1, r1, _), t2) ->
    begin match split t2 v1 with
      | (l2, false, r2) ->
        Set_gen.internal_join (diff l1 l2) v1 (diff r1 r2)
      | (l2, true, r2) ->
        Set_gen.internal_concat (diff l1 l2) (diff r1 r2)    
    end


let rec mem (tree : t) x =  match tree with 
  | Empty -> false
  | Node(l, v, r, _) ->
    let c = compare_elt x v in
    c = 0 || mem (if c < 0 then l else r) x

let rec remove (tree : t)  x : t = match tree with 
  | Empty -> Empty
  | Node(l, v, r, _) ->
    let c = compare_elt x v in
    if c = 0 then Set_gen.internal_merge l r else
    if c < 0 then Set_gen.internal_bal (remove l x) v r else Set_gen.internal_bal l v (remove r x )

let compare s1 s2 = Set_gen.compare ~cmp:compare_elt s1 s2 


let equal s1 s2 =
  compare s1 s2 = 0

let rec subset (s1 : t) (s2 : t) =
  match (s1, s2) with
  | Empty, _ ->
    true
  | _, Empty ->
    false
  | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) ->
    let c = compare_elt v1 v2 in
    if c = 0 then
      subset l1 l2 && subset r1 r2
    else if c < 0 then
      subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2
    else
      subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2




let rec find (tree : t) x = match tree with
  | Empty -> raise Not_found
  | Node(l, v, r, _) ->
    let c = compare_elt x v in
    if c = 0 then v
    else find (if c < 0 then l else r) x 



let of_list l =
  match l with
  | [] -> empty
  | [x0] -> singleton x0
  | [x0; x1] -> add (singleton x0) x1 
  | [x0; x1; x2] -> add (add (singleton x0)  x1) x2 
  | [x0; x1; x2; x3] -> add (add (add (singleton x0) x1 ) x2 ) x3 
  | [x0; x1; x2; x3; x4] -> add (add (add (add (singleton x0) x1) x2 ) x3 ) x4 
  | _ -> of_sorted_list (List.sort_uniq compare_elt l)

let of_array l = 
  Ext_array.fold_left l empty (fun  acc x -> add acc x ) 

(* also check order *)
let invariant t =
  Set_gen.check t ;
  Set_gen.is_ordered ~cmp:compare_elt t          

let print fmt s = 
  Format.fprintf 
   fmt   "@[<v>{%a}@]@."
    (fun fmt s   -> 
       iter s
         (fun e -> Format.fprintf fmt "@[<v>%a@],@ " 
         print_elt e) 
    )
    s     






end
module Js_call_info : sig 
#1 "js_call_info.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Type for collecting call site information, used in JS IR *) 

type arity = 
  | Full 
  | NA 


type call_info = 
  | Call_ml (* called by plain ocaml expression *)
  | Call_builtin_runtime (* built-in externals *)
  | Call_na 
  (* either from [@@bs.val] or not available, 
     such calls does not follow such rules
     {[ fun x y -> f x y === f ]} when [f] is an atom     
  *) 


type t = { 
  call_info : call_info;
  arity : arity;

}

val dummy : t
val builtin_runtime_call : t

val ml_full_call : t 

end = struct
#1 "js_call_info.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








type arity = 
  | Full 
  | NA 

type call_info = 
  | Call_ml (* called by plain ocaml expression *)
  | Call_builtin_runtime (* built-in externals *)
  | Call_na 
  (* either from [@@bs.val] or not available, 
     such calls does not follow such rules
     {[ fun x y -> (f x y) === f ]} when [f] is an atom     

  *) 

type t = { 
  call_info : call_info;
  arity : arity
}

let dummy = { arity = NA; call_info = Call_na }

let builtin_runtime_call = {arity = Full; call_info = Call_builtin_runtime}

let ml_full_call = {arity = Full; call_info = Call_ml}

end
module Js_closure : sig 
#1 "js_closure.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Define a type used in JS IR to help convert lexical scope to JS [var] 
    based scope convention
 *)

type t = {
  mutable outer_loop_mutable_values :  Ident_set.t 
}

val empty : unit -> t

val get_lexical_scope : t -> Ident_set.t

val set_lexical_scope : t -> Ident_set.t -> unit

end = struct
#1 "js_closure.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








type t = {
  mutable outer_loop_mutable_values :  Ident_set.t ;
}

let empty () = {
  outer_loop_mutable_values  = Ident_set.empty
}

let set_lexical_scope t v = t.outer_loop_mutable_values <- v 

let get_lexical_scope t = t.outer_loop_mutable_values 

end
module Js_fun_env : sig 
#1 "js_fun_env.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Define type t used in JS IR to collect some meta data 
    for a function,like its closures, etc 
*)

type t 

val make :  ?immutable_mask:bool array  -> int -> t

val is_tailcalled : t -> bool

val is_empty : t -> bool 

val set_unbounded :  t -> Ident_set.t -> unit



val set_lexical_scope : t -> Ident_set.t -> unit

val get_lexical_scope : t -> Ident_set.t

val to_string : t -> string

val mark_unused : t -> int -> unit 

val get_unused : t -> int -> bool

val get_mutable_params : Ident.t list -> t -> Ident.t list

val get_unbounded : t -> Ident_set.t

val get_length : t -> int

end = struct
#1 "js_fun_env.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(* Make it mutable so that we can do
   in-place change without constructing a new one
  -- however, it's a design choice -- to be reviewed later
*)

type immutable_mask = 
  | All_immutable_and_no_tail_call 
     (** iff not tailcalled 
         if tailcalled, in theory, it does not need change params, 
         for example
         {[
         let rec f  (n : int ref) = 
            if !n > 0 then decr n; print_endline "hi"
            else  f n
         ]}
         in this case, we still create [Immutable_mask], 
         since the inline behavior is slightly different
      *)
  | Immutable_mask of bool array

type t = { 
  mutable unbounded : Ident_set.t;
  mutable bound_loop_mutable_values : Ident_set.t; 
  used_mask : bool array;
  immutable_mask : immutable_mask; 
}
(** Invariant: unused param has to be immutable *)

let make ?immutable_mask n = { 
  unbounded =  Ident_set.empty ;
  used_mask = Array.make n false;
  immutable_mask = 
    (match immutable_mask with 
     | Some x -> Immutable_mask x 
     | None -> All_immutable_and_no_tail_call
    );
  bound_loop_mutable_values =Ident_set.empty;
}

let is_tailcalled x = 
  x.immutable_mask <> All_immutable_and_no_tail_call

let mark_unused  t i = 
  t.used_mask.(i) <- true

let get_unused t i = 
  t.used_mask.(i)

let get_length t = Array.length t.used_mask

let to_string env =  
  String.concat "," 
    (Ext_list.map (Ident_set.elements  env.unbounded ) 
      (fun id  -> Printf.sprintf "%s/%d" id.name id.stamp)
       )

let get_mutable_params (params : Ident.t list) (x : t ) = 
  match x.immutable_mask with 
  | All_immutable_and_no_tail_call -> []
  | Immutable_mask xs -> 
      Ext_list.filter_mapi params
        (fun p i -> if not xs.(i) then Some p else None) 


let get_unbounded t = t.unbounded

let set_unbounded env v = 
  (* Ext_log.err "%s -- set @." (to_string env); *)
  (* if Ident_set.is_empty env.bound then *)
  env.unbounded <- v 
 (* else assert false *)

let set_lexical_scope env bound_loop_mutable_values = 
  env.bound_loop_mutable_values <- bound_loop_mutable_values

let get_lexical_scope env =  
  env.bound_loop_mutable_values

(* TODO:  can be refined if it 
    only enclose toplevel variables 
 *)
let is_empty t = Ident_set.is_empty t.unbounded

end
module Js_op
= struct
#1 "js_op.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)










(** Define some basic types used in JS IR *)

type binop =
  | Eq  
  (* acutally assignment ..
     TODO: move it into statement, so that all expressions 
     are side efffect free (except function calls)
   *)

  | Or
  | And
  | EqEqEq
  | NotEqEq
  (* | InstanceOf *)

  | Lt
  | Le
  | Gt
  | Ge

  | Bor
  | Bxor
  | Band
  | Lsl
  | Lsr
  | Asr

  | Plus
  | Minus
  | Mul
  | Div
  | Mod

(**
note that we don't need raise [Div_by_zero] in BuckleScript

{[
let add x y = x + y  (* | 0 *)
let minus x y = x - y (* | 0 *)
let mul x y = x * y   (* caml_mul | Math.imul *)
let div x y = x / y (* caml_div (x/y|0)*)
let imod x y = x mod y  (* caml_mod (x%y) (zero_divide)*)

let bor x y = x lor y   (* x  | y *)
let bxor x y = x lxor y (* x ^ y *)
let band x y = x land y (* x & y *)
let ilnot  y  = lnot y (* let lnot x = x lxor (-1) *)
let ilsl x y = x lsl y (* x << y*)
let ilsr x y = x lsr y  (* x >>> y | 0 *)
let iasr  x y = x asr y (* x >> y *)
]}


Note that js treat unsigned shift 0 bits in a special way
   Unsigned shifts convert their left-hand side to Uint32, 
   signed shifts convert it to Int32.
   Shifting by 0 digits returns the converted value.
   {[
    function ToUint32(x) {
        return x >>> 0;
    }
    function ToInt32(x) {
        return x >> 0;
    }
   ]}
   So in Js, [-1 >>>0] will be the largest Uint32, while [-1>>0] will remain [-1]
   and [-1 >>> 0 >> 0 ] will be [-1]
*)
type int_op = 
    
  | Bor
  | Bxor
  | Band
  | Lsl
  | Lsr
  | Asr

  | Plus
      (* for [+], given two numbers 
         x + y | 0
       *)
  | Minus
      (* x - y | 0 *)
  | Mul
      (* *)
  | Div
      (* x / y | 0 *)
  | Mod
      (* x  % y *)

(* https://developer.mozilla.org/en-US/docs/Web/JavaScript/Guide/Expressions_and_Operators#Bitwise_operators
    {[
    ~
    ]}
    ~0xff -> -256
    design; make sure each operation type is consistent
 *)
type level = 
  | Log 
  | Info
  | Warn
  | Error

type kind = 
  | Ml
  | Runtime 
  | External of string

type property = Lam_compat.let_kind = 
  | Strict
  | Alias
  | StrictOpt 
  | Variable


type property_name = (* private *)
  (* TODO: FIXME [caml_uninitialized_obj] seems to be a bug*)
  (* | Key of *)
   string
  (* | Int_key of int  *)
  (* | Tag  *)
  (* | Length *)

type 'a access = 
  | Getter
  | Setter
type jsint = Int32.t

type int_or_char = 
    { i : jsint; 
      (* we can not use [int] on 32 bit platform, if we dont use 
          [Int32.t], we need a configuration step          
      *)
      c : char option
    }

 (* literal char *)
type float_lit = { f :  string }
type number = 
  | Float of float_lit 
  | Int of int_or_char
  | Uint of int32
  | Nint of nativeint
  (* becareful when constant folding +/-, 
     since we treat it as js nativeint, bitwise operators:
     https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Operators/Bitwise_Operators
     The operands of all bitwise operators are converted to signed 32-bit integers in two's complement format.'
  *)      

type mutable_flag = 
  | Mutable
  | Immutable
  | NA

(* 
    {[
    let rec x = 1 :: y 
    and y = 1 :: x
    ]}
 *)
type recursive_info = 
  | SingleRecursive 
  | NonRecursie
  | NA

type used_stats = 
  | Dead_pure 
        (* only [Dead] should be taken serious, 
            other status can be converted during
            inlining
            -- all exported symbols can not be dead
            -- once a symbole is called Dead_pure, 
            it can not be alive anymore, we should avoid iterating it
            
          *)
  | Dead_non_pure 
      (* we still need iterating it, 
         just its bindings does not make sense any more *)
  | Exported (* Once it's exported, shall we change its status anymore? *)
      (* In general, we should count in one pass, and eliminate code in another 
         pass, you can not do it in a single pass, however, some simple 
         dead code can be detected in a single pass
       *)
  | Once_pure (* used only once so that, if we do the inlining, it will be [Dead] *)
  | Used (**)
  | Scanning_pure
  | Scanning_non_pure
  | NA


type ident_info = {
    (* mutable recursive_info : recursive_info; *)
    mutable used_stats : used_stats;
  }

type exports = Ident.t list 

type module_id = { id : Ident.t; kind  : kind}

type required_modules = module_id list


type tag_info = Lam_tag_info.t

type length_object = 
  | Array 
  | String
  | Bytes
  | Function
  | Caml_block

type code_info = 
  | Exp (* of int option *)
  | Stmt
(** TODO: define constant - for better constant folding  *)
(* type constant =  *)
(*   | Const_int of int *)
(*   | Const_ *)

end
module J
= struct
#1 "j.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Javascript IR
  
    It's a subset of Javascript AST specialized for OCaml lambda backend

    Note it's not exactly the same as Javascript, the AST itself follows lexical
    convention and [Block] is just a sequence of statements, which means it does 
    not introduce new scope
*)

type label = string

and binop = Js_op.binop

and int_op = Js_op.int_op
 
and kind = Js_op.kind

and property = Js_op.property

and number = Js_op.number 

and mutable_flag = Js_op.mutable_flag 

and ident_info = Js_op.ident_info

and exports = Js_op.exports

and tag_info = Js_op.tag_info 
 
and required_modules = Js_op.required_modules

and code_info = Js_op.code_info 


(** object literal, if key is ident, in this case, it might be renamed by 
    Google Closure  optimizer,
    currently we always use quote
 *)
and property_name =  Js_op.property_name
and jsint = Js_op.jsint
and ident = Ident.t 

and vident = 
  | Id of ident
  | Qualified of ident * kind * string option
    (* Since camldot is only available for toplevel module accessors,
       we don't need print  `A.length$2`
       just print `A.length` - it's guarateed to be unique
       
       when the third one is None, it means the whole module 

       TODO: 
       invariant, when [kind] is [Runtime], then we can ignore [ident], 
       since all [runtime] functions are unique, when do the 
       pattern match we can ignore the first one for simplicity
       for example       
       {[
         Qualified (_, Runtime, Some "caml_int_compare")         
       ]}       
     *)

and exception_ident = ident 

and for_ident = ident 

and for_direction = Asttypes.direction_flag

and property_map = 
    (property_name * expression) list
and length_object = Js_op.length_object
and expression_desc =
  | Length of expression * length_object
  | Char_of_int of expression
  | Char_to_int of expression 
  | Is_null_or_undefined of expression 
    (** where we use a trick [== null ] *)
  | String_append of expression * expression 
  | Bool of bool (* js true/false*)
  (* https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Operators/Operator_Precedence 
     [typeof] is an operator     
  *)
  | Typeof of expression
  | Js_not of expression (* !v *)
  (* TODO: Add some primitives so that [js inliner] can do a better job *)  
  | Seq of expression * expression
  | Cond of expression * expression * expression
  | Bin of binop * expression * expression

  (* [int_op] will guarantee return [int32] bits 
     https://developer.mozilla.org/en/docs/Web/JavaScript/Reference/Operators/Bitwise_Operators  *)
  (* | Int32_bin of int_op * expression * expression *)
  | FlatCall of expression * expression 
    (* f.apply(null,args) -- Fully applied guaranteed 
       TODO: once we know args's shape --
       if it's know at compile time, we can turn it into
       f(args[0], args[1], ... )
     *)
  | Call of expression * expression list * Js_call_info.t
    (* Analysze over J expression is hard since, 
        some primitive  call is translated 
        into a plain call, it's better to keep them
    *) 
  | String_index of expression * expression 
    (* str.[i])*)
  | Array_index of expression * expression 
    (* arr.(i)
       Invariant: 
       The second argument has to be type of [int],
       This can be constructed either in a static way [E.array_index_by_int] or a dynamic way 
       [E.array_index]
     *)
  | Static_index of expression * string 
    (* The third argument bool indicates whether we should 
       print it as 
       a["idd"] -- false
       or 
       a.idd  -- true
       There are several kinds of properties
       1. OCaml module dot (need to be escaped or not)
          All exported declarations have to be OCaml identifiers
       2. Javascript dot (need to be preserved/or using quote)
     *)
  | New of expression * expression list option (* TODO: option remove *)
  | Var of vident
  | Fun of bool * ident list  * block * Js_fun_env.t
  (* The first parameter by default is false, 
     it will be true when it's a method
  *)
  | Str of bool * string 
    (* A string is UTF-8 encoded, the string may contain
       escape sequences.
       The first argument is used to mark it is non-pure, please
       don't optimize it, since it does have side effec, 
       examples like "use asm;" and our compiler may generate "error;..." 
       which is better to leave it alone
       The last argument is passed from as `j` from `{j||j}`
     *)
  | Unicode of string 
    (* It is escaped string, print delimited by '"'*)   
  | Raw_js_code of string * code_info
  | Raw_js_function of string * string list
  (* literally raw JS code 
  *)
  | Array of expression list * mutable_flag
  | Optional_block of expression * bool 
    (* [true] means [identity] *)
  | Caml_block of expression list * mutable_flag * expression * tag_info 
  (* The third argument is [tag] , forth is [tag_info] *)
  (* | Caml_uninitialized_obj of expression * expression *)
  (* [tag] and [size] tailed  for [Obj.new_block] *)

  (* For setter, it still return the value of expression, 
     we can not use 
     {[
       type 'a access = Get | Set of 'a
     ]}
     in another module, since it will break our code generator
     [Caml_block_tag] can return [undefined], 
     you have to use [E.tag] in a safe way     
  *)
  | Caml_block_tag of expression
  (* | Caml_block_set_tag of expression * expression *)
  (* | Caml_block_set_length of expression * expression *)
  (* It will just fetch tag, to make it safe, when creating it, 
     we need apply "|0", we don't do it in the 
     last step since "|0" can potentially be optimized
  *)      
  | Number of number
  | Object of property_map
  | Undefined 
  | Null
and for_ident_expression = expression (* pure*)

and finish_ident_expression = expression (* pure *)
(* https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Statements/block
   block can be nested, specified in ES3 
 *)

(* Delay some units like [primitive] into JS layer ,
   benefit: better cross module inlining, and smaller IR size?
 *)

(* 
  [closure] captured loop mutable values in the outer loop

  check if it contains loop mutable values, happens in nested loop
  when closured, it's no longer loop mutable value. 
  which means the outer loop mutable value can not peek into the inner loop
  {[
  var i = f ();
  for(var finish = 32; i < finish; ++i){
  }
  ]}
  when [for_ident_expression] is [None], [var i] has to 
  be initialized outside, so 

  {[
  var i = f ()
  (function (xxx){
  for(var finish = 32; i < finish; ++i)
  }(..i))
  ]}
  This happens rare it's okay

  this is because [i] has to be initialized outside, if [j] 
  contains a block side effect
  TODO: create such example
*)

(* Since in OCaml, 
   
  [for i = 0 to k end do done ]
  k is only evaluated once , to encode this invariant in JS IR,
  make sure [ident] is defined in the first b

  TODO: currently we guarantee that [bound] was only 
  excecuted once, should encode this in AST level
*)

(* Can be simplified to keep the semantics of OCaml
   For (var i, e, ...){
     let  j = ... 
   }

   if [i] or [j] is captured inside closure

   for (var i , e, ...){
     (function (){
     })(i)
   }
*)

(* Single return is good for ininling..
   However, when you do tail-call optmization
   you loose the expression oriented semantics
   Block is useful for implementing goto
   {[
   xx:{
   break xx;
   }
   ]}
*)


and statement_desc =
  | Block of block
  | Variable of variable_declaration
        (* Function declaration and Variable declaration  *)
  | Exp of expression
  | If of expression * block * block option
  | While of label option *  expression * block 
        * Js_closure.t (* check if it contains loop mutable values, happens in nested loop *)
  | ForRange of for_ident_expression option * finish_ident_expression * 
        for_ident  *  for_direction * block
        * Js_closure.t  
  | Continue of label 
  | Break (* only used when inline a fucntion *)
  | Return of return_expression   (* Here we need track back a bit ?, move Return to Function ...
                              Then we can only have one Return, which is not good *)
  | Int_switch of expression * int case_clause list * block option 
  | String_switch of expression * string case_clause list * block option 
  | Throw of expression
  | Try of block * (exception_ident * block) option * block option
  | Debugger
and return_expression = {
 (* since in ocaml, it's expression oriented langauge, [return] in
    general has no jumps, it only happens when we do 
    tailcall conversion, in that case there is a jump.
    However, currently  a single [break] is good to cover
    our compilation strategy 

    Attention: we should not insert [break] arbitrarily, otherwise 
    it would break the semantics
    A more robust signature would be 
    {[ goto : label option ; ]}
  *)
  return_value : expression
}   

and expression = {
  expression_desc : expression_desc; 
  comment : string option;
} 

and statement = { 
  statement_desc :  statement_desc; 
  comment : string option;
}

and variable_declaration = { 
  ident : ident ;
  value : expression  option;
  property : property;
  ident_info : ident_info;
}

and 'a case_clause = { 
  switch_case : 'a ; 
  switch_body : block ;
  should_break :  bool ;  (* true means break *)
}

(* TODO: For efficency: block should not be a list, it should be able to 
   be concatenated in both ways 
 *)
and block =  statement list

and program = {
  block : block ;
  exports : exports ;
  export_set : Ident_set.t ;

}
and deps_program = 
  {
    program : program ; 
    modules : required_modules ;
    side_effect : string option (* None: no, Some reason  *)
  }

end
module Js_fold
= struct
#1 "js_fold.ml"
(* BuckleScript compiler
 * Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, with linking exception;
 * either version 2.1 of the License, or (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 *)
(* Author: Hongbo Zhang  *)
(** GENERATED CODE for fold visitor patten of JS IR  *)
open J
  
class virtual fold =
  object ((o : 'self_type))
    method string : string -> 'self_type = o#unknown
    method option :
      'a. ('self_type -> 'a -> 'self_type) -> 'a option -> 'self_type =
      fun _f_a -> function | None -> o | Some _x -> let o = _f_a o _x in o
    method list :
      'a. ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type =
      fun _f_a ->
        function
        | [] -> o
        | _x :: _x_i1 -> let o = _f_a o _x in let o = o#list _f_a _x_i1 in o
    method int : int -> 'self_type = o#unknown
    method bool : bool -> 'self_type = function | false -> o | true -> o
    method vident : vident -> 'self_type =
      function
      | Id _x -> let o = o#ident _x in o
      | Qualified (_x, _x_i1, _x_i2) ->
          let o = o#ident _x in
          let o = o#kind _x_i1 in
          let o = o#option (fun o -> o#string) _x_i2 in o
    method variable_declaration : variable_declaration -> 'self_type =
      fun { ident = _x; value = _x_i1; property = _x_i2; ident_info = _x_i3 }
        ->
        let o = o#ident _x in
        let o = o#option (fun o -> o#expression) _x_i1 in
        let o = o#property _x_i2 in let o = o#ident_info _x_i3 in o
    method tag_info : tag_info -> 'self_type = o#unknown
    method statement_desc : statement_desc -> 'self_type =
      function
      | Block _x -> let o = o#block _x in o
      | Variable _x -> let o = o#variable_declaration _x in o
      | Exp _x -> let o = o#expression _x in o
      | If (_x, _x_i1, _x_i2) ->
          let o = o#expression _x in
          let o = o#block _x_i1 in
          let o = o#option (fun o -> o#block) _x_i2 in o
      | While (_x, _x_i1, _x_i2, _x_i3) ->
          let o = o#option (fun o -> o#label) _x in
          let o = o#expression _x_i1 in
          let o = o#block _x_i2 in let o = o#unknown _x_i3 in o
      | ForRange (_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5) ->
          let o = o#option (fun o -> o#for_ident_expression) _x in
          let o = o#finish_ident_expression _x_i1 in
          let o = o#for_ident _x_i2 in
          let o = o#for_direction _x_i3 in
          let o = o#block _x_i4 in let o = o#unknown _x_i5 in o
      | Continue _x -> let o = o#label _x in o
      | Break -> o
      | Return _x -> let o = o#return_expression _x in o
      | Int_switch (_x, _x_i1, _x_i2) ->
          let o = o#expression _x in
          let o =
            o#list
              (fun o ->
                 (* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
                 (** Javascript IR
  
    It's a subset of Javascript AST specialized for OCaml lambda backend

    Note it's not exactly the same as Javascript, the AST itself follows lexical
    convention and [Block] is just a sequence of statements, which means it does 
    not introduce new scope
*)
                 (** object literal, if key is ident, in this case, it might be renamed by 
    Google Closure  optimizer,
    currently we always use quote
 *)
                 (* Since camldot is only available for toplevel module accessors,
       we don't need print  `A.length$2`
       just print `A.length` - it's guarateed to be unique
       
       when the third one is None, it means the whole module 

       TODO: 
       invariant, when [kind] is [Runtime], then we can ignore [ident], 
       since all [runtime] functions are unique, when do the 
       pattern match we can ignore the first one for simplicity
       for example       
       {[
         Qualified (_, Runtime, Some "caml_int_compare")         
       ]}       
     *)
                 (** where we use a trick [== null ] *) (* js true/false*)
                 (* https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Operators/Operator_Precedence 
     [typeof] is an operator     
  *)
                 (* !v *)
                 (* TODO: Add some primitives so that [js inliner] can do a better job *)
                 (* [int_op] will guarantee return [int32] bits 
     https://developer.mozilla.org/en/docs/Web/JavaScript/Reference/Operators/Bitwise_Operators  *)
                 (* | Int32_bin of int_op * expression * expression *)
                 (* f.apply(null,args) -- Fully applied guaranteed 
       TODO: once we know args's shape --
       if it's know at compile time, we can turn it into
       f(args[0], args[1], ... )
     *)
                 (* Analysze over J expression is hard since, 
        some primitive  call is translated 
        into a plain call, it's better to keep them
    *)
                 (* str.[i])*)
                 (* arr.(i)
       Invariant: 
       The second argument has to be type of [int],
       This can be constructed either in a static way [E.array_index_by_int] or a dynamic way 
       [E.array_index]
     *)
                 (* The third argument bool indicates whether we should 
       print it as 
       a["idd"] -- false
       or 
       a.idd  -- true
       There are several kinds of properties
       1. OCaml module dot (need to be escaped or not)
          All exported declarations have to be OCaml identifiers
       2. Javascript dot (need to be preserved/or using quote)
     *)
                 (* TODO: option remove *)
                 (* The first parameter by default is false, 
     it will be true when it's a method
  *)
                 (* A string is UTF-8 encoded, the string may contain
       escape sequences.
       The first argument is used to mark it is non-pure, please
       don't optimize it, since it does have side effec, 
       examples like "use asm;" and our compiler may generate "error;..." 
       which is better to leave it alone
       The last argument is passed from as `j` from `{j||j}`
     *)
                 (* It is escaped string, print delimited by '"'*)
                 (* literally raw JS code 
  *) (* [true] means [identity] *)
                 (* The third argument is [tag] , forth is [tag_info] *)
                 (* | Caml_uninitialized_obj of expression * expression *)
                 (* [tag] and [size] tailed  for [Obj.new_block] *)
                 (* For setter, it still return the value of expression, 
     we can not use 
     {[
       type 'a access = Get | Set of 'a
     ]}
     in another module, since it will break our code generator
     [Caml_block_tag] can return [undefined], 
     you have to use [E.tag] in a safe way     
  *)
                 (* | Caml_block_set_tag of expression * expression *)
                 (* | Caml_block_set_length of expression * expression *)
                 (* It will just fetch tag, to make it safe, when creating it, 
     we need apply "|0", we don't do it in the 
     last step since "|0" can potentially be optimized
  *)
                 (* pure*) (* pure *)
                 (* https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Statements/block
   block can be nested, specified in ES3 
 *)
                 (* Delay some units like [primitive] into JS layer ,
   benefit: better cross module inlining, and smaller IR size?
 *)
                 (* 
  [closure] captured loop mutable values in the outer loop

  check if it contains loop mutable values, happens in nested loop
  when closured, it's no longer loop mutable value. 
  which means the outer loop mutable value can not peek into the inner loop
  {[
  var i = f ();
  for(var finish = 32; i < finish; ++i){
  }
  ]}
  when [for_ident_expression] is [None], [var i] has to 
  be initialized outside, so 

  {[
  var i = f ()
  (function (xxx){
  for(var finish = 32; i < finish; ++i)
  }(..i))
  ]}
  This happens rare it's okay

  this is because [i] has to be initialized outside, if [j] 
  contains a block side effect
  TODO: create such example
*)
                 (* Since in OCaml, 
   
  [for i = 0 to k end do done ]
  k is only evaluated once , to encode this invariant in JS IR,
  make sure [ident] is defined in the first b

  TODO: currently we guarantee that [bound] was only 
  excecuted once, should encode this in AST level
*)
                 (* Can be simplified to keep the semantics of OCaml
   For (var i, e, ...){
     let  j = ... 
   }

   if [i] or [j] is captured inside closure

   for (var i , e, ...){
     (function (){
     })(i)
   }
*)
                 (* Single return is good for ininling..
   However, when you do tail-call optmization
   you loose the expression oriented semantics
   Block is useful for implementing goto
   {[
   xx:{
   break xx;
   }
   ]}
*)
                 (* Function declaration and Variable declaration  *)
                 (* check if it contains loop mutable values, happens in nested loop *)
                 (* only used when inline a fucntion *)
                 (* Here we need track back a bit ?, move Return to Function ...
                              Then we can only have one Return, which is not good *)
                 o#case_clause (fun o -> o#int))
              _x_i1 in
          let o = o#option (fun o -> o#block) _x_i2 in o
      | String_switch (_x, _x_i1, _x_i2) ->
          let o = o#expression _x in
          let o =
            o#list (fun o -> o#case_clause (fun o -> o#string)) _x_i1 in
          let o = o#option (fun o -> o#block) _x_i2 in o
      | Throw _x -> let o = o#expression _x in o
      | Try (_x, _x_i1, _x_i2) ->
          let o = o#block _x in
          let o =
            o#option
              (fun o (_x, _x_i1) ->
                 let o = o#exception_ident _x in let o = o#block _x_i1 in o)
              _x_i1 in
          let o = o#option (fun o -> o#block) _x_i2 in o
      | Debugger -> o
    method statement : statement -> 'self_type =
      fun { statement_desc = _x; comment = _x_i1 } ->
        let o = o#statement_desc _x in
        let o = o#option (fun o -> o#string) _x_i1 in o
    method return_expression : return_expression -> 'self_type =
      fun { return_value = _x } -> let o = o#expression _x in o
    method required_modules : required_modules -> 'self_type = o#unknown
    method property_name : property_name -> 'self_type = o#unknown
    method property_map : property_map -> 'self_type =
      o#list
        (fun o (_x, _x_i1) ->
           let o = o#property_name _x in let o = o#expression _x_i1 in o)
    method property : property -> 'self_type = o#unknown
    method program : program -> 'self_type =
      fun { block = _x; exports = _x_i1; export_set = _x_i2 } ->
        let o = o#block _x in
        let o = o#exports _x_i1 in let o = o#unknown _x_i2 in o
    method number : number -> 'self_type = o#unknown
    method mutable_flag : mutable_flag -> 'self_type = o#unknown
    method length_object : length_object -> 'self_type = o#unknown
    method label : label -> 'self_type = o#string
    method kind : kind -> 'self_type = o#unknown
    method jsint : jsint -> 'self_type = o#unknown
    method int_op : int_op -> 'self_type = o#unknown
    method ident_info : ident_info -> 'self_type = o#unknown
    method ident : ident -> 'self_type = o#unknown
    method for_ident_expression : for_ident_expression -> 'self_type =
      o#expression
    method for_ident : for_ident -> 'self_type = o#ident
    method for_direction : for_direction -> 'self_type = o#unknown
    method finish_ident_expression : finish_ident_expression -> 'self_type =
      o#expression
    method expression_desc : expression_desc -> 'self_type =
      function
      | Length (_x, _x_i1) ->
          let o = o#expression _x in let o = o#length_object _x_i1 in o
      | Char_of_int _x -> let o = o#expression _x in o
      | Char_to_int _x -> let o = o#expression _x in o
      | Is_null_or_undefined _x -> let o = o#expression _x in o
      | String_append (_x, _x_i1) ->
          let o = o#expression _x in let o = o#expression _x_i1 in o
      | Bool _x -> let o = o#bool _x in o
      | Typeof _x -> let o = o#expression _x in o
      | Js_not _x -> let o = o#expression _x in o
      | Seq (_x, _x_i1) ->
          let o = o#expression _x in let o = o#expression _x_i1 in o
      | Cond (_x, _x_i1, _x_i2) ->
          let o = o#expression _x in
          let o = o#expression _x_i1 in let o = o#expression _x_i2 in o
      | Bin (_x, _x_i1, _x_i2) ->
          let o = o#binop _x in
          let o = o#expression _x_i1 in let o = o#expression _x_i2 in o
      | FlatCall (_x, _x_i1) ->
          let o = o#expression _x in let o = o#expression _x_i1 in o
      | Call (_x, _x_i1, _x_i2) ->
          let o = o#expression _x in
          let o = o#list (fun o -> o#expression) _x_i1 in
          let o = o#unknown _x_i2 in o
      | String_index (_x, _x_i1) ->
          let o = o#expression _x in let o = o#expression _x_i1 in o
      | Array_index (_x, _x_i1) ->
          let o = o#expression _x in let o = o#expression _x_i1 in o
      | Static_index (_x, _x_i1) ->
          let o = o#expression _x in let o = o#string _x_i1 in o
      | New (_x, _x_i1) ->
          let o = o#expression _x in
          let o = o#option (fun o -> o#list (fun o -> o#expression)) _x_i1
          in o
      | Var _x -> let o = o#vident _x in o
      | Fun (_x, _x_i1, _x_i2, _x_i3) ->
          let o = o#bool _x in
          let o = o#list (fun o -> o#ident) _x_i1 in
          let o = o#block _x_i2 in let o = o#unknown _x_i3 in o
      | Str (_x, _x_i1) -> let o = o#bool _x in let o = o#string _x_i1 in o
      | Unicode _x -> let o = o#string _x in o
      | Raw_js_code (_x, _x_i1) ->
          let o = o#string _x in let o = o#code_info _x_i1 in o
      | Raw_js_function (_x, _x_i1) ->
          let o = o#string _x in
          let o = o#list (fun o -> o#string) _x_i1 in o
      | Array (_x, _x_i1) ->
          let o = o#list (fun o -> o#expression) _x in
          let o = o#mutable_flag _x_i1 in o
      | Optional_block (_x, _x_i1) ->
          let o = o#expression _x in let o = o#bool _x_i1 in o
      | Caml_block (_x, _x_i1, _x_i2, _x_i3) ->
          let o = o#list (fun o -> o#expression) _x in
          let o = o#mutable_flag _x_i1 in
          let o = o#expression _x_i2 in let o = o#tag_info _x_i3 in o
      | Caml_block_tag _x -> let o = o#expression _x in o
      | Number _x -> let o = o#number _x in o
      | Object _x -> let o = o#property_map _x in o
      | Undefined -> o
      | Null -> o
    method expression : expression -> 'self_type =
      fun { expression_desc = _x; comment = _x_i1 } ->
        let o = o#expression_desc _x in
        let o = o#option (fun o -> o#string) _x_i1 in o
    method exports : exports -> 'self_type = o#unknown
    method exception_ident : exception_ident -> 'self_type = o#ident
    method deps_program : deps_program -> 'self_type =
      fun { program = _x; modules = _x_i1; side_effect = _x_i2 } ->
        let o = o#program _x in
        let o = o#required_modules _x_i1 in
        let o = o#option (fun o -> o#string) _x_i2 in o
    method code_info : code_info -> 'self_type = o#unknown
    method case_clause :
      (* since in ocaml, it's expression oriented langauge, [return] in
    general has no jumps, it only happens when we do 
    tailcall conversion, in that case there is a jump.
    However, currently  a single [break] is good to cover
    our compilation strategy 

    Attention: we should not insert [break] arbitrarily, otherwise 
    it would break the semantics
    A more robust signature would be 
    {[ goto : label option ; ]}
  *)
        'a. ('self_type -> 'a -> 'self_type) -> 'a case_clause -> 'self_type =
      fun _f_a { switch_case = _x; switch_body = _x_i1; should_break = _x_i2
        } ->
        let o = _f_a o _x in
        let o = o#block _x_i1 in let o = o#bool _x_i2 in o
    method block : block -> 'self_type = (* true means break *)
      (* TODO: For efficency: block should not be a list, it should be able to 
   be concatenated in both ways 
 *)
      o#list (fun o -> o#statement)
    method binop : binop -> 'self_type = o#unknown
    method unknown : 'a. 'a -> 'self_type = fun _ -> o
  end
  


end
module Js_analyzer : sig 
#1 "js_analyzer.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Analyzing utilities for [J] module *) 

(** for example, whether it has side effect or not.
*)

val free_variables_of_statement : 
  Ident_set.t -> Ident_set.t -> J.statement -> Ident_set.t

val free_variables_of_expression : 
  Ident_set.t -> Ident_set.t -> J.finish_ident_expression -> Ident_set.t

val no_side_effect_expression_desc :
  J.expression_desc -> bool   
val no_side_effect_expression : 
  J.expression -> bool
(** [no_side_effect] means this expression has no side effect, 
    but it might *depend on value store*, so you can not just move it around,

    for example,
    when you want to do a deep copy, the expression passed to you is pure
    but you still have to call the function to make a copy, 
    since it maybe changed later
*)

val no_side_effect_statement : 
  J.statement -> bool
(** 
    here we say 
   {[ var x = no_side_effect_expression ]}
    is [no side effect], but it is actually side effect, 
    since  we are defining a variable, however, if it is not exported or used, 
    then it's fine, so we delay this check later
*)

val eq_expression :
  J.expression -> J.expression -> bool

val eq_statement : 
  J.statement -> J.statement -> bool

val eq_block :  
  J.block -> J.block -> bool 
  
val rev_flatten_seq : J.expression -> J.block 

val rev_toplevel_flatten : J.block -> J.block
(** return the block in reverse order *)

val is_constant : J.expression -> bool


(** Simple expression, 
    no computation involved so that  it is okay to be duplicated
*)

val is_okay_to_duplicate
  : J.expression -> bool
end = struct
#1 "js_analyzer.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)










(* Assume that functions already calculated closure correctly 
   Maybe in the future, we should add a dirty flag, to mark the calcuated 
   closure is correct or not

   Note such shaking is done in the toplevel, so that it requires us to 
   flatten the statement first 
*)
let free_variables used_idents defined_idents = 
  object (self)
    inherit Js_fold.fold as super
    val defined_idents = defined_idents
    val used_idents = used_idents 
    method! variable_declaration st = 
      match st with 
      | { ident; value = None}
        -> 
        {< defined_idents = Ident_set.add defined_idents ident >}
      | { ident; value = Some v}
        -> 
        {< defined_idents = Ident_set.add defined_idents ident >} # expression v
    method! ident id = 
      if Ident_set.mem defined_idents id then self
      else {<used_idents = Ident_set.add used_idents id>}
    method! expression exp = 

      match exp.expression_desc with
      | Fun(_, _,_, env)
        (** a optimization to avoid walking into funciton again
            if it's already comuted
        *)
        ->
        {< used_idents = 
             Ident_set.union (Js_fun_env.get_unbounded env) used_idents  >}

      | _
        ->
        super#expression exp

    method get_depenencies = 
      Ident_set.diff used_idents defined_idents
    method get_used_idents = used_idents
    method get_defined_idents = defined_idents 
  end 

let free_variables_of_statement used_idents defined_idents st = 
  ((free_variables used_idents defined_idents)#statement st) # get_depenencies

let free_variables_of_expression used_idents defined_idents st = 
  ((free_variables used_idents defined_idents)#expression st) # get_depenencies

let rec no_side_effect_expression_desc (x : J.expression_desc)  = 
  match x with 
  | Raw_js_function _
  | Undefined
  | Null
  | Bool _ 
  | Var _ 
  | Unicode _ -> true 
  | Fun _ -> true
  | Number _ -> true (* Can be refined later *)
  | String_index (a,b)
  | Array_index (a,b) -> no_side_effect a && no_side_effect b 
  | Is_null_or_undefined b -> no_side_effect b 
  | Str (b,_) -> b    
  | Array (xs,_mutable_flag)  
  | Caml_block (xs, _mutable_flag, _, _)
    ->
    (** create [immutable] block,
        does not really mean that this opreation itself is [pure].

        the block is mutable does not mean this operation is non-pure
    *)
    Ext_list.for_all xs no_side_effect 
  | Optional_block (x,_) -> no_side_effect x   
  | Object kvs -> 
    Ext_list.for_all_snd  kvs no_side_effect
  | String_append (a,b)
  | Seq (a,b) -> no_side_effect a && no_side_effect b 
  | Length (e, _)
  | Char_of_int e 
  | Char_to_int e 
  | Caml_block_tag e 
  | Typeof e
    -> no_side_effect e 
  | Bin (op, a, b) -> 
    op <> Eq && no_side_effect a && no_side_effect b     
  | Js_not _
  | Cond _ 
  | FlatCall _ 
  | Call _ 
  | Static_index _ 
  | New _ 
  | Raw_js_code _ 
  (* | Caml_block_set_tag _  *)
  (* actually true? *)
    -> false 
and no_side_effect (x : J.expression)  = 
  no_side_effect_expression_desc x.expression_desc

let no_side_effect_expression (x : J.expression) = no_side_effect x 

let no_side_effect init = 
  object (self)
    inherit Js_fold.fold as super
    val no_side_effect = init
    method get_no_side_effect = no_side_effect

    method! statement s = 
      if not no_side_effect then self else 
        match s.statement_desc with 
        | Throw _ 
        | Debugger 
        | Break 
        | Variable _ 
        | Continue _ ->  
          {< no_side_effect = false>}
        | Exp e -> self#expression e 
        | Int_switch _ | String_switch _ | ForRange _ 
        | If _ | While _   | Block _ | Return _ | Try _  -> super#statement s 
    method! list f x = 
      if not self#get_no_side_effect then self else super#list f x 
    method! expression s = 
      if not no_side_effect then self
      else  {< no_side_effect = no_side_effect_expression s >}

    (** only expression would cause side effec *)
  end
let no_side_effect_statement st = ((no_side_effect true)#statement st)#get_no_side_effect

(* TODO: generate [fold2] 
   This make sense, for example:
   {[
     let string_of_formatting_gen : type a b c d e f .
       (a, b, c, d, e, f) formatting_gen -> string =
       fun formatting_gen -> match formatting_gen with
         | Open_tag (Format (_, str)) -> str
         | Open_box (Format (_, str)) -> str

   ]}
*)
let rec eq_expression 
    ({expression_desc = x0}  : J.expression) 
    ({expression_desc = y0}  : J.expression) = 
  begin match x0  with 
    | Null -> y0 = Null
    | Undefined -> y0 = Undefined
    | Number (Int i) -> 
      begin match y0 with  
        | Number (Int j)   -> i = j 
        | _ -> false 
      end
    | Number (Float i) -> 
      begin match y0 with 
        | Number (Float j) ->
          false (* conservative *)
        | _ -> false 
      end    
    | String_index (a0,a1) -> 
      begin match y0 with 
        | String_index(b0,b1) -> 
          eq_expression a0 b0 && eq_expression a1 b1
        | _ -> false 
      end
    | Array_index (a0,a1) -> 
      begin match y0 with 
        | Array_index(b0,b1) -> 
          eq_expression a0 b0 && eq_expression a1 b1
        | _ -> false 
      end
    | Call (a0,args00,_) -> 
      begin match y0 with 
        | Call(b0,args10,_) ->
          eq_expression a0 b0 &&  eq_expression_list args00 args10
        | _ -> false 
      end 
    | Var (Id i) -> 
      begin match y0 with 
        | Var (Id j) ->
          Ident.same i j
        | _ -> false
      end
    | Bin (op0, a0,b0) -> 
      begin match y0 with 
        | Bin(op1,a1,b1) -> 
          op0 = op1 && eq_expression a0 a1 && eq_expression b0 b1
        | _ -> false 
      end 
    | Str(a0,b0) -> 
      begin match y0 with 
        | Str(a1,b1) -> a0 = a1  && b0 = b1
        | _ -> false 
      end     
    | Var (Qualified (id0,k0,opts0)) -> 
      begin match y0 with 
        | Var (Qualified (id1,k1,opts1)) ->
          Ident.same id0 id1 &&
          k0 = k1 &&
          opts0 = opts1
        | _ -> false
      end
    | Static_index (e0,p0) -> 
      begin match y0 with 
        | Static_index(e1,p1) -> 
          p0 = p1 && eq_expression e0 e1
        |  _ -> false 
      end
    | Seq (a0,b0) -> 
      begin match y0 with       
        | Seq(a1,b1) -> 
          eq_expression a0 a1 && eq_expression b0 b1
        | _ -> false 
      end
    | Bool a0 -> 
      begin match y0 with 
        | Bool b0 -> a0 = b0
        | _ -> false 
      end
    | Optional_block (a0,b0) -> 
      begin match y0 with   
      | Optional_block (a1,b1) -> b0 = b1 && eq_expression a0 a1
      | _ -> false 
      end 
    | Caml_block (ls0,flag0,tag0,_) ->    
      begin match y0 with 
      | Caml_block(ls1,flag1,tag1,_) -> 
        eq_expression_list ls0 ls1 &&
        flag0 = flag1 &&
        eq_expression tag0 tag1 
      | _ -> false 
      end 
    | Length _ 
    | Char_of_int _
    | Char_to_int _ 
    | Is_null_or_undefined _ 
    | String_append _ 
    | Typeof _ 
    | Js_not _ 
    | Cond _ 
    | FlatCall  _
  
    | New _ 
    | Fun _ 
    | Unicode _ 
    | Raw_js_code _
    | Raw_js_function _
    | Array _ 
    | Caml_block_tag _ 
    
    | Object _ 
    | Number (Uint _ | Nint _)

      ->  false 
  end
and eq_expression_list xs ys =
  Ext_list.for_all2_no_exn xs ys eq_expression
and eq_block (xs : J.block) (ys : J.block) =
  Ext_list.for_all2_no_exn xs ys eq_statement
and eq_statement 
    ({statement_desc = x0} : J.statement)
    ({statement_desc = y0} : J.statement) = 
  match x0  with 
  | Exp a -> 
    begin match y0 with 
      | Exp b -> eq_expression a b 
      | _ -> false
    end
  | Return { return_value = a ; _} -> 
    begin match y0 with 
      | Return { return_value = b; _} ->
        eq_expression a b
      | _ -> false 
    end
  | Debugger -> y0 = Debugger  
  | Break -> y0 = Break 
  | Block xs0 -> 
    begin match y0 with 
    | Block ys0 -> 
      eq_block xs0 ys0
    | _ -> false 
  end
  | Variable _ 
  | If _ 
  | While _ 
  | ForRange _ 
  | Continue _ 
  
  | Int_switch _ 
  | String_switch _ 
  | Throw _ 
  | Try _ 
    -> 
    false 

let rev_flatten_seq (x : J.expression) = 
  let rec aux acc (x : J.expression) : J.block = 
    match x.expression_desc with
    | Seq(a,b) -> aux (aux acc a) b 
    | _ -> { statement_desc = Exp x; comment = None} :: acc in
  aux [] x 

(* TODO: optimization, 
    counter the number to know if needed do a loop gain instead of doing a diff 
*)

let rev_toplevel_flatten block = 
  let rec aux  acc (xs : J.block) : J.block  = 
    match xs with 
    | [] -> acc
    | {statement_desc =
         Variable (
           {ident_info = {used_stats = Dead_pure } ; _} 
         | {ident_info = {used_stats = Dead_non_pure}; value = None })
      } :: xs -> aux acc xs 
    | {statement_desc = Block b; _ } ::xs -> aux (aux acc b ) xs 

    | x :: xs -> aux (x :: acc) xs  in
  aux [] block

let rec is_constant (x : J.expression)  = 
  match x.expression_desc with 
  | Array_index (a,b) -> is_constant a && is_constant b 
  | Str (b,_) -> b
  | Number _ -> true (* Can be refined later *)
  | Array (xs,_mutable_flag)  -> Ext_list.for_all xs  is_constant 
  | Caml_block(xs, Immutable, tag, _) 
    -> Ext_list.for_all xs is_constant && is_constant tag 
  | Bin (op, a, b) -> 
    is_constant a && is_constant b     
  | _ -> false 


let rec is_okay_to_duplicate (e : J.expression) = 
  match e.expression_desc with  
  | Var _ 
  | Bool _ 
  | Str _ 
  | Number _ -> true
  | Static_index (e, _s) -> is_okay_to_duplicate e 
  | _ -> false 

end
module Js_op_util : sig 
#1 "js_op_util.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Some basic utilties around {!Js_op} module *)

val op_prec : Js_op.binop -> int * int * int

val op_str : Js_op.binop -> string

val op_int_prec : Js_op.int_op -> int * int * int

val op_int_str : Js_op.int_op -> string

val str_of_used_stats : Js_op.used_stats -> string

val update_used_stats : J.ident_info -> Js_op.used_stats -> unit

val same_vident : J.vident -> J.vident -> bool

val of_lam_mutable_flag : Asttypes.mutable_flag -> Js_op.mutable_flag 

end = struct
#1 "js_op_util.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)









(* Refer https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Operators/Operator_Precedence
  for precedence   
*)

let op_prec (op : Js_op.binop ) =
  match op with
  | Eq -> 1, 13, 1
  | Or -> 3, 3, 3
  | And -> 4, 4, 4
  | EqEqEq | NotEqEq -> 8, 8, 9
  | Gt | Ge | Lt | Le (* | InstanceOf *) -> 9, 9, 10
  | Bor -> 5, 5, 5
  | Bxor -> 6, 6, 6
  | Band -> 7, 7, 7
  | Lsl | Lsr | Asr -> 10, 10, 11
  | Plus | Minus -> 11, 11, 12
  | Mul | Div | Mod -> 12, 12, 13

let op_int_prec (op : Js_op.int_op) = 
  match op with
  | Bor -> 5, 5, 5
  | Bxor -> 6, 6, 6
  | Band -> 7, 7, 7
  | Lsl | Lsr | Asr -> 10, 10, 11
  | Plus | Minus -> 11, 11, 12
  | Mul | Div | Mod -> 12, 12, 13


let op_str (op : Js_op.binop) =
  match op with
  | Bor     -> "|"
  | Bxor    -> "^"
  | Band    -> "&"
  | Lsl     -> "<<"
  | Lsr     -> ">>>"
  | Asr     -> ">>"
  | Plus    -> "+"
  | Minus   -> "-"
  | Mul     -> "*"
  | Div     -> "/"
  | Mod     -> "%"

  | Eq      -> "="
  | Or      -> "||"
  | And     -> "&&"
  | EqEqEq  -> "==="
  | NotEqEq -> "!=="
  | Lt      -> "<"
  | Le      -> "<="
  | Gt      -> ">"
  | Ge      -> ">="
  (* | InstanceOf -> "instanceof" *)

let op_int_str (op : Js_op.int_op) = 
  match op with
  | Bor     -> "|"
  | Bxor    -> "^"
  | Band    -> "&"
  | Lsl     -> "<<"
  | Lsr     -> ">>>"
  | Asr     -> ">>"
  | Plus    -> "+"
  | Minus   -> "-"
  | Mul     -> "*"
  | Div     -> "/"
  | Mod     -> "%"
  
let str_of_used_stats x = 
  match (x : Js_op.used_stats) with
  | Js_op.Dead_pure ->  "Dead_pure"
  | Dead_non_pure -> "Dead_non_pure"
  | Exported -> "Exported" 
  | Once_pure -> "Once_pure"
  | Used -> "Used"
  | Scanning_pure -> "Scanning_pure"
  | Scanning_non_pure -> "Scanning_non_pure"
  | NA -> "NA"

let update_used_stats (ident_info : J.ident_info) used_stats = 
  match ident_info.used_stats with 
  | Dead_pure | Dead_non_pure | Exported  -> ()
  | Scanning_pure 
  | Scanning_non_pure
  | Used
  | Once_pure
  | NA  -> 
    ident_info.used_stats <- used_stats

let same_kind (x : Js_op.kind) (y : Js_op.kind)  =
  match x , y with
  | Ml, Ml
  | Runtime, Runtime -> true
  | External (u : string), External v ->  u = v 
  | _, _ -> false

let same_str_opt ( x : string option  ) (y : string option) = 
  match x ,y with
  | None, None -> true
  | Some x0, Some y0 -> x0 = y0
  | None, Some _ 
  | Some _ , None 
    -> false 
  
let same_vident (x : J.vident) (y : J.vident) = 
  match x, y with 
  | Id x0, Id y0 -> Ident.same x0 y0
  | Qualified(x0,k0,str_opt0), Qualified(y0,k1,str_opt1) -> 
      Ident.same x0 y0 && same_kind k0 k1 && same_str_opt str_opt0 str_opt1
  | Id _, Qualified _ 
  | Qualified _, Id _ -> false

let of_lam_mutable_flag (x : Asttypes.mutable_flag)  : Js_op.mutable_flag = 
  match x with 
  | Immutable -> Immutable
  | Mutable -> Mutable

end
module Js_runtime_modules
= struct
#1 "js_runtime_modules.ml"
(* Copyright (C) 2017 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

let builtin_exceptions = "Caml_builtin_exceptions"
let exceptions = "Caml_exceptions"
let io = "Caml_io"
let sys = "Caml_sys"
let lexer = "Caml_lexer"
let parser = "Caml_parser"
let obj_runtime = "Caml_obj"
let array = "Caml_array"
let format = "Caml_format"
let string = "Caml_string"
let bytes = "Caml_bytes"
let char = "Caml_char"
let float = "Caml_float"
let hash_primitive = "Caml_hash_primitive" 
let hash = "Caml_hash"
let oo = "Caml_oo"
let curry = "Curry"
let caml_oo_curry = "Caml_oo_curry"
let caml_primitive = "Caml_primitive"
let int64 = "Caml_int64"
let md5 = "Caml_md5"
let weak = "Caml_weak"

let gc = "Caml_gc"
let int32 = "Caml_int32"
let block = "Block"
let caml_chrome_block = "Caml_chrome_debugger"
let option = "Caml_option"
let module_ = "Caml_module"
let external_polyfill = "Caml_external_polyfill"
let caml_js_exceptions = "Caml_js_exceptions"
let caml_splice_call = "Caml_splice_call"
end
module Lam_compile_util : sig 
#1 "lam_compile_util.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)









(** Some utilities for lambda compilation*)

val jsop_of_comp : Lam_compat.comparison -> Js_op.binop

val comment_of_tag_info : Lam_tag_info.t -> string option

val comment_of_pointer_info : Lam_pointer_info.t -> string option

end = struct
#1 "lam_compile_util.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)










let jsop_of_comp (cmp : Lam_compat.comparison) : Js_op.binop = 
  match cmp with 
  | Ceq -> EqEqEq (* comparison*)
  | Cneq -> NotEqEq
  | Clt -> Lt 
  | Cgt  -> Gt 
  | Cle -> Le 
  | Cge  -> Ge

let comment_of_tag_info  (x : Lam_tag_info.t) = 
  match x with 
  | Blk_constructor (n, _) -> Some n 
  | Blk_tuple -> Some "tuple"
  | Blk_variant x -> Some ("`" ^  x)
  | Blk_record _ -> Some "record"

  | Blk_record_inlined (_,ctor,_) -> Some ctor
  | Blk_record_ext _ -> None
  
  | Blk_array -> Some "array"
  | Blk_module _ ->  
     (* Turn it on next time to save some noise diff*)
    Some "module"
  | Blk_extension_slot -> None
  | Blk_na -> None 
let comment_of_pointer_info (x :  Lam_pointer_info.t)= 
  match x with 
  | Pt_constructor x -> Some x 
  | Pt_variant x -> Some x 
  | Pt_module_alias -> None (* FIXME *)
  | Pt_na -> None

end
module Js_exp_make : sig 
#1 "js_exp_make.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Creator utilities for the [J] module *) 






(** check if a javascript ast is constant 

    The better signature might be 
    {[
      J.expresssion -> Js_output.t
    ]}
    for exmaple
    {[
      e ?print_int(3) :  0
                         --->
                         if(e){print_int(3)}
    ]}
*)
type t = J.expression 

val remove_pure_sub_exp : t -> t option

val var : ?comment:string  -> J.ident -> t 

val js_global : ?comment:string -> string -> t

(* val runtime_var_dot : ?comment:string -> string -> string -> t *)

(* val runtime_var_vid : string -> string -> J.vident *)

(** [ml_var_dot ocaml_module name]
*)
val ml_var_dot : ?comment:string -> Ident.t -> string -> t

(** [external_var_dot ~external_name ~dot id]
  Used in FFI
*)
val external_var_dot : 
  ?comment:string ->  
  external_name:string -> 
  ?dot:string -> 
  Ident.t ->
  t

val runtime_call : 
  ?comment:string -> 
  string -> (* module_name *)
  string -> (* fn_name *)
  t list -> (* args *)
  t

val runtime_ref : 
  string -> 
  string -> 
  t  

val public_method_call : string -> t -> t -> Int32.t -> t list -> t


val str : 
  ?pure:bool -> 
  ?comment:string -> 
  string -> 
  t 

val unicode : 
  ?comment:string -> 
  string -> 
  t
  
val ocaml_fun : ?comment:string ->
  ?immutable_mask:bool array -> J.ident list -> J.block -> t

val method_ : ?comment:string ->
  ?immutable_mask:bool array -> J.ident list -> J.block -> t

val econd : ?comment:string -> t -> t -> t -> t

val int : ?comment:string -> ?c:char ->  int32 -> t 
val nint : ?comment:string -> nativeint -> t 
val small_int : int -> t
val float : ?comment:string -> string -> t

val empty_string_literal : t 
(* TODO: we can do hash consing for small integers *)
val zero_int_literal : t
val one_int_literal : t
val zero_float_lit : t 
val obj_int_tag_literal : t

(** [is_out e range] is equivalent to [e > range or e <0]

*)
val is_out : ?comment:string -> t -> t -> t

val dot : ?comment:string -> t -> string -> t

val array_length : ?comment:string -> t -> t 

val string_length : ?comment:string -> t -> t 

val bytes_length :  ?comment:string -> t -> t 

val function_length : ?comment:string -> t -> t 

val char_of_int : ?comment:string -> t -> t 

val char_to_int : ?comment:string -> t -> t 

val string_append : ?comment:string -> t -> t -> t 
(**
   When in ES6 mode, we can use Symbol to guarantee its uniquess,
   we can not tag [js] object, since it can be frozen 
*)



(* val var_dot : ?comment:string -> Ident.t -> string -> t *)

(* val bind_var_call : ?comment:string -> Ident.t -> string -> t list -> t  *)

(* val bind_call : ?comment:string -> J.expression -> string -> J.expression list -> t *)
val js_global_dot : ?comment:string -> string -> string -> t



val string_index : ?comment:string -> t -> t -> t 

val array_index : 
  ?comment:string -> 
  t -> 
  t ->
  t
  
val array_index_by_int : 
  ?comment:string -> 
  t -> 
  Int32.t ->
   t

(** 
    [assign_by_int  e i v]
    if the expression [e] is a temporay block 
    which has no side effect,
    write to it does not really make sense, 
    optimize it away *)
val assign_by_int : 
  ?comment:string -> 
  t -> 
  Js_op.jsint -> 
  t -> 
  t

val assign_by_exp : 
  ?comment:string -> 
  t -> 
  t -> 
  t -> 
  t 

val assign :  ?comment:string -> t -> t -> t 

val triple_equal : ?comment:string -> t -> t -> t 
(* TODO: reduce [triple_equal] use *)    

val float_equal : ?comment:string -> t -> t -> t 
val int_equal : ?comment:string -> t -> t -> t 
val string_equal : ?comment:string -> t -> t -> t 
val eq_null_undefined_boolean: ?comment:string -> t -> t -> t 
val neq_null_undefined_boolean: ?comment:string -> t -> t -> t 
val is_type_number : ?comment:string -> t -> t 
val typeof : ?comment:string -> t -> t 

val to_int32 : ?comment:string -> t -> t 
val to_uint32 : ?comment:string -> t -> t 

val unchecked_int32_add : ?comment:string -> t -> t -> t 
val int32_add : ?comment:string -> t -> t -> t 
val unchecked_int32_minus : ?comment:string -> t -> t -> t 
val int32_minus : ?comment:string -> t -> t -> t 
val int32_mul : ?comment:string -> t -> t -> t 
val unchecked_int32_mul : ?comment:string -> t -> t -> t 

val int32_div : checked:bool -> ?comment:string -> t -> t -> t 
val int32_mod : checked:bool -> ?comment:string -> t -> t -> t 

val int32_lsl : ?comment:string -> t -> t -> t 
val int32_lsr : ?comment:string -> t -> t -> t 
val int32_asr : ?comment:string -> t -> t -> t 

val int32_bxor : ?comment:string -> t -> t -> t 
val int32_band : ?comment:string -> t -> t -> t 
val int32_bor : ?comment:string -> t -> t -> t 

val float_add : ?comment:string -> t -> t -> t 
val float_minus : ?comment:string -> t -> t -> t 
val float_mul : ?comment:string -> t -> t -> t 
val float_div : ?comment:string -> t -> t -> t 
val float_notequal : ?comment:string -> t -> t -> t 
val float_mod : ?comment:string -> t -> t -> t 

val int_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t 
val bool_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t 
val string_comp : Js_op.binop -> ?comment:string -> t -> t -> t 
val float_comp :  Lam_compat.comparison -> ?comment:string -> t -> t -> t 
val js_comp :  Lam_compat.comparison -> ?comment:string -> t -> t -> t 


val not : t -> t

val call : ?comment:string  -> info:Js_call_info.t -> t -> t list -> t 

val flat_call : ?comment:string -> t -> t -> t 

val new_ : ?comment:string -> J.expression -> J.expression list -> t

val array : 
  ?comment:string -> 
  J.mutable_flag -> 
  J.expression list ->
  t

val optional_block :
  J.expression -> 
  J.expression 
  
val optional_not_nest_block : 
  J.expression -> 
  J.expression  

val make_block : 
  ?comment:string ->
  J.expression -> (* tag *)
  J.tag_info ->  (* tag_info *)
  J.expression list -> 
  J.mutable_flag ->
  t


val seq : ?comment:string -> t -> t -> t 
val fuse_to_seq : t -> t list -> t 

val obj : 
  ?comment:string -> 
  J.property_map -> 
  t 

val true_ : t 

val false_ : t

val bool : bool -> t



val unit :   t
(** [unit] in ocaml will be compiled into [0]  in js *)

val undefined : t

val tag : ?comment:string -> J.expression -> t


(** Note that this is coupled with how we encode block, if we use the 
    `Object.defineProperty(..)` since the array already hold the length,
    this should be a nop 
*)


val obj_length : ?comment:string -> J.expression -> t


val and_ : ?comment:string -> t -> t -> t 
val or_ : ?comment:string -> t -> t -> t 

(** we don't expose a general interface, since a general interface is generally not safe *)

(** used combined with [caml_update_dummy]*)
val dummy_obj : ?comment:string ->  unit -> t 

(** convert a block to expresion by using IIFE *)    
val of_block : ?comment:string -> ?e:J.expression -> J.statement list -> t

val raw_js_code : ?comment:string -> J.code_info ->  string -> t
val raw_js_function : ?comment:string -> string -> string list -> t
val nil : t 
val is_null : ?comment:string -> t -> t 


val is_undef : ?comment:string -> t -> t 
val for_sure_js_null_undefined : J.expression -> bool
val is_null_undefined : ?comment:string -> t -> t 

val resolve_and_apply : 
  ?comment:string -> 
  string ->
  t list ->
  t

end = struct
#1 "js_exp_make.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






let no_side_effect = Js_analyzer.no_side_effect_expression

type t = J.expression 

(*
  [remove_pure_sub_exp x]
  Remove pure part of the expression (minor optimization)
  and keep the non-pure part while preserve the semantics 
  (modulo return value)
  It will return None if  [x] is pure
 *)
let rec remove_pure_sub_exp (x : t)  : t option = 
  match x.expression_desc with 
  | Var _
  | Str _
  | Number _ -> None (* Can be refined later *)
  | Array_index (a,b) -> 
      if is_pure_sub_exp a && is_pure_sub_exp b then None 
      else Some x           
  | Array (xs,_mutable_flag)  ->
    if Ext_list.for_all xs is_pure_sub_exp then None 
    else Some x 
  | Seq (a,b) -> 
      (match remove_pure_sub_exp a , remove_pure_sub_exp b with 
      | None, None  ->  None
      | Some u, Some v ->  
        Some { x with expression_desc =  Seq(u,v)}
      (* may still have some simplification*)
      | None, (Some _ as v) ->  v
      | (Some _ as u), None -> u)
  | _ -> Some x 
and is_pure_sub_exp (x : t ) = remove_pure_sub_exp x = None

(* let mk ?comment exp : t = 
  {expression_desc = exp ; comment  } *)

let var ?comment  id  : t = 
  {expression_desc = Var (Id id); comment }

(* only used in property access, 
    Invariant: it should not call an external module .. *)

let js_global ?comment  (v : string) =
  var ?comment (Ext_ident.create_js v )
  
let undefined  : t = 
    {expression_desc = Undefined ; comment = None}

let nil : t = 
    {expression_desc = Null ; comment = None}

let call ?comment ~info e0 args : t = 
  {expression_desc = Call(e0,args,info); comment }

(* TODO: optimization when es is known at compile time
    to be an array
*)  
let flat_call ?comment e0 es : t = 
  {expression_desc = FlatCall (e0,es); comment }

let runtime_var_dot ?comment (x : string)  (e1 : string) : J.expression = 
  { expression_desc = 
     Var (Qualified(Ident.create_persistent x,Runtime, Some e1));
    comment }


let ml_var_dot ?comment ( id  : Ident.t) e : J.expression =     
  {expression_desc = Var (Qualified(id, Ml, Some e)); comment }

(** 
   module as a value 
   {[
     var http = require("http")
   ]}
*)
let external_var_dot ?comment  ~external_name:name ?dot (id : Ident.t) : t = 
  {expression_desc = Var (Qualified(id, External name,  dot)); comment }


(* let ml_var ?comment (id : Ident.t) : t  = 
  {expression_desc = Var (Qualified (id, Ml, None)); comment} *)

(* Static_index .....................**)        
let runtime_call ?comment module_name fn_name args = 
  call ?comment 
    ~info:Js_call_info.builtin_runtime_call
    (runtime_var_dot  module_name fn_name) args

let runtime_ref module_name fn_name = 
  runtime_var_dot  module_name fn_name

let str ?(pure=true)  ?comment s : t =  
  {expression_desc = Str (pure,s); comment}

let unicode ?comment s : t = 
  {expression_desc = Unicode (s); comment}

let raw_js_code ?comment info s : t =
  {expression_desc = Raw_js_code (s,info) ; comment }

let raw_js_function ?comment arg block : t = 
  {expression_desc = Raw_js_function(arg,block); comment}
  
let array ?comment mt es : t  = 
  {expression_desc = Array (es,mt) ; comment}

let sep = " : "
let merge_outer_comment comment (e : t )  = 
  match e.comment with
  | None -> {e with comment = Some comment}
  | Some s -> { e with 
                comment 
                = Some (comment ^ sep ^ s)} 

let some_comment = None

let optional_block e  : J.expression =                 
  { expression_desc = Optional_block (e,false) ; 
    comment = some_comment
  }

  
let optional_not_nest_block e : J.expression = 
  {
    expression_desc = Optional_block(e,true);
    comment = None
  } 

let make_block ?comment 
  (tag : t) 
  (tag_info : J.tag_info) 
  (es : t list) 
  (mutable_flag : J.mutable_flag) : t = 
  let comment = 
    match comment with 
    | None -> Lam_compile_util.comment_of_tag_info tag_info 
    | _ -> comment in
  let es = 
    match tag_info with 
    | Blk_record des
   
    | Blk_record_inlined (des, _,_)
    
      when Array.length des <> 0 
      -> 
      Ext_list.mapi es (fun i e  -> merge_outer_comment des.(i) e) 
         
    | Blk_record_ext des
      when Array.length des <> 0 
      -> 
      Ext_list.mapi es (fun i e  -> 
        if i <> 0 then merge_outer_comment des.(i-1) e else e) 
         
    (* TODO: may overriden its previous comments *)
    | Blk_module (Some des) 
      ->  Ext_list.map2 des es merge_outer_comment             
    | _ -> es 
  in
  {
    expression_desc = Caml_block( es, mutable_flag, tag,tag_info) ;
    comment 
  }    


module L = Literals

(* ATTENTION: this is relevant to how we encode string, boolean *)           
let typeof ?comment (e : t) : t = 
  match e.expression_desc with 
  | Number _ 
  | Length _ 
    -> str ?comment L.js_type_number
  | Str _ 
    -> str ?comment L.js_type_string
  | Array _
    -> str ?comment L.js_type_object
  | Bool _ -> str ?comment L.js_type_boolean
  | _ -> {expression_desc = Typeof e ; comment }




let new_ ?comment e0 args : t = 
  { expression_desc = New (e0,  Some args ); comment}


let unit : t = 
  {expression_desc = Number (Int {i = 0l; c = None}) ; comment = Some "()" }



(* let math ?comment v args  : t = 
  {comment ; expression_desc = Math(v,args)} *)

(* we can do constant folding here, but need to make sure the result is consistent
   {[
     let f x = string_of_int x        
     ;; f 3            
   ]}     
   {[
     string_of_int 3
   ]}
   Used in [string_of_int] and format "%d"
   TODO: optimize
*)

(* Attention: Shared *mutable state* is evil, 
  [Js_fun_env.empty] is a mutable state ..
*)    

let ocaml_fun 
    ?comment  
    ?immutable_mask
    params block  : t = 
  let len = List.length params in
  {
    expression_desc = 
      Fun (false, params,block, Js_fun_env.make ?immutable_mask len ); 
    comment
  }

let method_
    ?comment  
    ?immutable_mask
    params block  : t = 
  let len = List.length params in
  {
    expression_desc = 
      Fun (true, params,block, Js_fun_env.make ?immutable_mask len ); 
    comment
  }

(** ATTENTION: This is coupuled with {!Caml_obj.caml_update_dummy} *)
let dummy_obj ?comment ()  : t = 
  {comment  ; expression_desc = Array ([],Mutable)}


(* TODO: complete 
    pure ...
*)        
let rec seq ?comment (e0 : t) (e1 : t) : t = 
  match e0.expression_desc, e1.expression_desc with 
  | (Seq( a, {expression_desc = Number _ ;  })
    | Seq( {expression_desc = Number _ ;  },a)), _
    -> 
    seq ?comment a e1
  | _, ( Seq( {expression_desc = Number _ ;  }, a)) -> 
    (* Return value could not be changed*)
    seq ?comment e0 a
  | _, ( Seq(a,( {expression_desc = Number _ ;  } as v ) ))-> 
    (* Return value could not be changed*)
    seq ?comment (seq  e0 a) v
  | (Number _ | Var _) , _ -> e1 
  | _ -> 
    {expression_desc = Seq(e0,e1); comment}

let fuse_to_seq x xs = 
  if xs = [] then x  
  else Ext_list.fold_left xs x seq 

let empty_string_literal : t = 
  {expression_desc = Str (true,""); comment = None}  

let zero_int_literal : t =   
  {expression_desc = Number (Int {i = 0l; c = None}) ; comment = None}
let one_int_literal : t = 
  {expression_desc = Number (Int {i = 1l; c = None}) ; comment = None}
let two_int_literal : t = 
  {expression_desc = Number (Int {i = 2l; c = None}) ; comment = None}
let three_int_literal : t = 
  {expression_desc = Number (Int {i = 3l; c = None}) ; comment = None}
let four_int_literal : t =   
  {expression_desc = Number (Int {i = 4l; c = None}) ; comment = None}
let five_int_literal : t = 
  {expression_desc = Number (Int {i = 5l; c = None}) ; comment = None}
let six_int_literal : t = 
  {expression_desc = Number (Int {i = 6l; c = None}) ; comment = None}
let seven_int_literal : t = 
  {expression_desc = Number (Int {i = 7l; c = None}) ; comment = None}
let eight_int_literal : t = 
  {expression_desc = Number (Int {i = 8l; c = None}) ; comment = None}
let nine_int_literal : t = 
  {expression_desc = Number (Int {i = 9l; c = None}) ; comment = None}

let obj_int_tag_literal : t =
  {expression_desc = Number (Int {i = 248l; c = None}) ; comment = None}

let int ?comment ?c  i : t = 
  {expression_desc = Number (Int {i; c}) ; comment}

let small_int i : t = 
  match i with 
  | 0 -> zero_int_literal
  | 1 -> one_int_literal
  | 2 -> two_int_literal
  | 3 -> three_int_literal
  | 4 -> four_int_literal
  | 5 -> five_int_literal
  | 6 -> six_int_literal
  | 7 -> seven_int_literal
  | 8 -> eight_int_literal
  | 9 -> nine_int_literal
  | 248 -> obj_int_tag_literal
  | i -> int (Int32.of_int i) 


let array_index ?comment (e0 : t)  (e1 : t) : t =
  match e0.expression_desc, e1.expression_desc with
  | Array (l,_) , Number (Int {i; _}) (* Float i -- should not appear here *)
    when no_side_effect e0-> 
    (match Ext_list.nth_opt l  (Int32.to_int i) with 
    | None -> { expression_desc = Array_index (e0,e1); comment} 
    | Some x -> x ) (* FIX #3084*)
  | _ ->
    { expression_desc = Array_index (e0,e1); comment} 

let array_index_by_int ?comment (e0 : t)  (e1 : int32) : t = 
  match e0.expression_desc with
  | Array (l,_) (* Float i -- should not appear here *)
  | Caml_block (l,_, _, _) when no_side_effect e0
     -> 
    (match Ext_list.nth_opt l  (Int32.to_int e1)  with
    | Some x-> x 
    | None -> 
      { expression_desc = Array_index (e0, int ?comment e1); comment = None}     
    )
  | _ -> { expression_desc = Array_index (e0, int ?comment e1); comment = None} 

let string_index ?comment (e0 : t)  (e1 : t) : t = 
  match e0.expression_desc, e1.expression_desc with
  | Str (_,s) , Number (Int {i; _}) 
    ->  (* Don't optimize {j||j} *)
    let i = Int32.to_int i  in
    if i >= 0 && i < String.length s then 
      (* TODO: check exception when i is out of range..
         RangeError?
      *)
      str (String.make 1 s.[i])
    else     { expression_desc = String_index (e0,e1); comment} 
  | _ ->
    { expression_desc = String_index (e0,e1); comment} 



let assign ?comment e0 e1 : t = 
    {expression_desc = Bin(Eq, e0,e1); comment}

    

let assign_by_exp
  ?comment (e0 : t)  index
  assigned_value : t = 
  match e0.expression_desc with
  | Array _  (* Temporary block -- address not held *)
  | Caml_block _ when no_side_effect e0 && no_side_effect index -> 
    assigned_value
  | _ ->  
    assign { expression_desc = 
        Array_index (e0, index); comment = None} assigned_value

let assign_by_int
  ?comment
  e0 (index : int32) value = 
  assign_by_exp ?comment e0 (int ?comment index) value


(** used in normal property
    like [e.length], no dependency introduced
*)
let dot ?comment (e0 : t)  (e1 : string) : t = 
  { expression_desc = Static_index (e0,  e1); comment} 




(* This is a property access not external module *)

let array_length ?comment (e : t) : t = 
  match e.expression_desc with 
  (* TODO: use array instead? *)
  | (Array (l, _) | Caml_block(l,_,_,_)) when no_side_effect e 
    -> int ?comment (Int32.of_int (List.length l))
  | _ -> { expression_desc = Length (e, Array) ; comment }

let string_length ?comment (e : t) : t =
  match e.expression_desc with 
  | Str(_,v) -> int ?comment (Int32.of_int (String.length v)) 
  (* No optimization for {j||j}*)
  | _ -> { expression_desc = Length (e, String) ; comment }

(* TODO: use [Buffer] instead? *)  
let bytes_length ?comment (e : t) : t = 
  match e.expression_desc with 
  | Array (l, _) -> int ?comment (Int32.of_int (List.length l))
  | _ -> { expression_desc = Length (e, Bytes) ; comment }

let function_length ?comment (e : t) : t = 
  match e.expression_desc with 
  | Fun(b, params, _, _) -> 
    let params_length = 
      List.length params in
    int ?comment 
      (Int32.of_int 
         (if b then params_length - 1 
          else params_length))
  | _ -> { expression_desc = Length (e, Function) ; comment }

(** no dependency introduced *)
let js_global_dot ?comment (x : string)  (e1 : string) : t = 
  { expression_desc = Static_index (js_global x,  e1); comment} 

let char_of_int ?comment (v : t) : t = 
  match v.expression_desc with
  | Number (Int {i; _}) ->
    str  (String.make 1(Char.chr (Int32.to_int i)))
  | Char_to_int v -> v 
  | _ ->  {comment ; expression_desc = Char_of_int v}

let char_to_int ?comment (v : t) : t = 
  match v.expression_desc with 
  | Str (_, x) -> (* No optimization for .. *)
    assert (String.length x = 1) ;
    int ~comment:(Printf.sprintf "%S"  x )  
      (Int32.of_int @@ Char.code x.[0])
  | Char_of_int v -> v 
  | _ -> {comment; expression_desc = Char_to_int v }



let rec string_append ?comment (e : t) (el : t) : t = 
  match e.expression_desc , el.expression_desc  with 
  | Str(_,a), String_append ({expression_desc = Str(_,b)}, c) ->
    string_append ?comment (str (a ^ b)) c 
  | String_append (c,{expression_desc = Str(_,b)}), Str(_,a) ->
    string_append ?comment c (str (b ^ a))
  | String_append (a,{expression_desc = Str(_,b)}),
    String_append ({expression_desc = Str(_,c)} ,d) ->
    string_append ?comment (string_append a (str (b ^ c))) d 
  | Str (_,a), Str (_,b) -> str ?comment (a ^ b)
  | _, _ -> {comment ; expression_desc = String_append(e,el)}


let obj ?comment properties : t = 
  {expression_desc = Object properties; comment }

(* currently only in method call, no dependency introduced
*)


(* Static_index .....................**)        




(* var (Jident.create_js "true") *)
let true_ : t = {comment = None; expression_desc = Bool true }

let false_ : t = {comment = None; expression_desc = Bool false }

let bool v = if  v then true_ else false_

(** Arith operators *)
(* Static_index .....................**)        

let float ?comment f : t = 
  {expression_desc = Number (Float {f}); comment}

let zero_float_lit : t = 
  {expression_desc = Number (Float {f = "0." }); comment = None}


let float_mod ?comment e1 e2 : J.expression = 
  { comment ; 
    expression_desc = Bin (Mod, e1,e2)
  }


(** Here we have to use JS [===], and therefore, we are introducing 
    Js boolean, so be sure to convert it back to OCaml bool
    TODO:
    {[
      if (A0 === A0) {
        tmp = 3;
      } else {
        throw [
        Caml_builtin_exceptions.assert_failure,
        /* tuple */[
          "inline_record_test.ml",
          51,
          52
        ]
        ];
      }
    ]}
*)
let rec triple_equal ?comment (e0 : t) (e1 : t ) : t =
  match e0.expression_desc, e1.expression_desc with
  | (Null| Undefined), 
    (Char_of_int _ | Char_to_int _ 
    | Bool _ | Number _ | Typeof _
    | Fun _ | Array _ | Caml_block _ )
    when  no_side_effect e1 -> 
    false_ (* TODO: rename it as [caml_false] *)
  | 
    (Char_of_int _ | Char_to_int _ 
    | Bool _ | Number _ | Typeof _
    | Fun _ | Array _ | Caml_block _ ),  (Null|Undefined)
    when no_side_effect e0 -> 
    false_
  | Str (_,x), Str (_,y) ->  (* CF*)
    bool (Ext_string.equal x y)
  | Char_to_int a , Char_to_int b -> 
    triple_equal ?comment a b 
  | Char_to_int a , Number (Int {i; c = Some v}) 
  | Number (Int {i; c = Some v}), Char_to_int a  -> 
    triple_equal ?comment a (str (String.make 1 v))
  | Number (Int {i = i0; _}), Number (Int {i = i1; _}) 
    -> 
    bool (i0 = i1)      
  | Char_of_int a , Char_of_int b 
  | Optional_block (a,_), Optional_block (b,_)
    -> 
    triple_equal ?comment a b     
  | Undefined, Optional_block _  
  | Optional_block _, Undefined   
  | Null, Undefined   
  | Undefined, Null -> false_
  | Null, Null
  | Undefined, Undefined -> true_
  | _ -> 
     {expression_desc = Bin(EqEqEq, e0,e1); comment}

let bin ?comment (op : J.binop) (e0 : t) (e1 : t) : t =
  match op, e0.expression_desc, e1.expression_desc with
  | EqEqEq,_,_ -> triple_equal ?comment e0 e1
  | Ge, Length (e,_), Number (Int {i = 0l}) when no_side_effect e -> 
    true_ (** x.length >=0 | [x] is pure  -> true*)
  | Gt, Length (e,_), Number (Int {i = 0l}) -> 
    (* [e] is kept so no side effect check needed *)
    {expression_desc = Bin(NotEqEq,e0, e1); comment }
  | _ -> {expression_desc = Bin(op,e0,e1); comment}


(* TODO: Constant folding, Google Closure will do that?,
   Even if Google Clsoure can do that, we will see how it interact with other
   optimizations
   We wrap all boolean functions here, since OCaml boolean is a 
   bit different from Javascript, so that we can change it in the future

   {[ a && (b && c) === (a && b ) && c ]}
     is not used: benefit is not clear 
     | Int_of_boolean e10, Bin(And, {expression_desc = Int_of_boolean e20 }, e3) 
      -> 
      and_ ?comment 
        { e1 with expression_desc 
                  = 
                    J.Int_of_boolean { expression_desc = Bin (And, e10,e20); comment = None}
        }
        e3
   Note that 
   {[ "" && 3 ]}
     return  "" instead of false, so [e1] is indeed useful
   optimization if [e1 = e2], then and_ e1 e2 -> e2
     be careful for side effect        
*)

let rec and_ ?comment (e1 : t) (e2 : t) : t = 
  match e1.expression_desc, e2.expression_desc with 
  | Var i, Var j when Js_op_util.same_vident  i j 
    -> 
    e1
  | Var i, Bin (And,   {expression_desc = Var j ; _}, _)     
    when Js_op_util.same_vident  i j 
    ->
    e2          
  | Var i,  Bin (And , l, ({expression_desc = Var j ; _} as r))
    when Js_op_util.same_vident  i j -> 
    { e2 with expression_desc = Bin(And, r,l)}
  | _, _ ->     
    { expression_desc = Bin(And, e1,e2) ; comment }


let rec or_ ?comment (e1 : t) (e2 : t) = 
  match e1.expression_desc, e2.expression_desc with 
  | Var i, Var j when Js_op_util.same_vident  i j 
    -> 
    e1
  | Var i, 
    Bin (Or,   {expression_desc = Var j ; _}, _)    
    when Js_op_util.same_vident  i j 
    -> e2          
  | Var i, 
    Bin (Or ,  l, ({expression_desc = Var j ; _} as r))
    when Js_op_util.same_vident  i j
     ->
    { e2 with expression_desc = Bin(Or,r,l)}
  | _, _ ->     
    {expression_desc = Bin(Or, e1,e2); comment }


(* return a value of type boolean *)
(* TODO: 
     when comparison with Int
     it is right that !(x > 3 ) -> x <= 3 *)
let rec not ( e : t) : t =
  match e.expression_desc with 
  | Number (Int {i; _}) -> bool (i = 0l )
  | Js_not e -> e 
  | Bool b -> if b then false_ else true_
  | Bin(EqEqEq , e0,e1) -> {e with expression_desc = Bin(NotEqEq, e0,e1)}
  | Bin(NotEqEq , e0,e1) -> {e with expression_desc = Bin(EqEqEq, e0,e1)}
  | Bin(Lt, a, b) -> {e with expression_desc = Bin (Ge,a,b)}
  | Bin(Ge,a,b) -> {e with expression_desc = Bin (Lt,a,b)}
  | Bin(Le,a,b) -> {e with expression_desc = Bin (Gt,a,b)}
  | Bin(Gt,a,b) -> {e with expression_desc = Bin (Le,a,b)}
  | x -> {expression_desc = Js_not e ; comment = None}





let rec econd ?comment (pred : t) (ifso : t) (ifnot : t) : t = 
  match pred.expression_desc , ifso.expression_desc, ifnot.expression_desc with
  | Bool false,  _, _ -> ifnot
  | Number ((Int { i = 0l; _}) ), _, _ 
    -> ifnot  
  | (Number _ | Array _ | Caml_block _ | Optional_block _), _, _ 
    when no_side_effect pred 
    -> ifso  (* a block can not be false in OCAML, CF - relies on flow inference*)
  | Bool true, _, _ -> ifso   
  | _, (Cond (pred1, ifso1, ifnot1)), _
    when Js_analyzer.eq_expression ifnot1 ifnot
    ->
    (* {[
         if b then (if p1 then branch_code0 else branch_code1)
         else branch_code1         
       ]}
       is equivalent to         
       {[
         if b && p1 then branch_code0 else branch_code1           
       ]}         
    *)      
    econd (and_ pred pred1) ifso1 ifnot
  | _, (Cond (pred1, ifso1, ifnot1)), _
    when Js_analyzer.eq_expression ifso1 ifnot
    ->
    econd (and_ pred (not pred1)) ifnot1 ifnot
  | _, _, (Cond (pred1, ifso1, ifnot1))
    when Js_analyzer.eq_expression ifso ifso1 
    ->
    econd (or_ pred pred1) ifso ifnot1
  | _, _, (Cond (pred1, ifso1, ifnot1))
    when Js_analyzer.eq_expression ifso ifnot1
    ->
    econd (or_ pred (not pred1)) ifso ifso1

  | Js_not e, _, _ 
    ->
    econd ?comment e ifnot ifso 
  | _ -> 
    if Js_analyzer.eq_expression ifso ifnot then
      if no_side_effect pred then ifso else seq  ?comment pred ifso
    else
      {expression_desc = Cond(pred,ifso,ifnot); comment}


let rec float_equal ?comment (e0 : t) (e1 : t) : t = 
  match e0.expression_desc, e1.expression_desc with     
  | Number (Int {i = i0 ; _}), Number (Int {i = i1; }) -> 
    bool (i0 = i1)
  | (Bin(Bor, 
         {expression_desc = Number(Int {i = 0l; _})}, 
         ({expression_desc = Caml_block_tag _; _} as a ))
    |
      Bin(Bor, 
          ({expression_desc = Caml_block_tag _; _} as a),
          {expression_desc = Number (Int {i = 0l; _})})), 
    Number (Int {i = 0l; _})
    ->  (** (x.tag | 0) === 0  *)
    not  a     
  | (Bin(Bor, 
         {expression_desc = Number(Int {i = 0l; _})}, 
         ({expression_desc = Caml_block_tag _; _} as a ))
    |
      Bin(Bor, 
          ({expression_desc = Caml_block_tag _; _} as a),
          {expression_desc = Number (Int {i = 0l; _})}))
  , Number _  ->  (* for sure [i <> 0 ]*)
    (* since a is integer, if we guarantee there is no overflow 
       of a
       then [a | 0] is a nop unless a is undefined
       (which is applicable when applied to tag),
       obviously tag can not be overflowed. 
       if a is undefined, then [ a|0===0 ] is true 
       while [a === 0 ] is not true
       [a|0 === non_zero] is false and [a===non_zero] is false
       so we can not eliminate when the tag is zero          
    *)
    float_equal ?comment a e1
  | Number (Float {f = f0; _}), Number (Float {f = f1 ; }) when f0 = f1 -> 
    true_

  | Char_to_int a , Char_to_int b ->
    float_equal ?comment a b
  | Char_to_int a , Number (Int {i; c = Some v})
  | Number (Int {i; c = Some v}), Char_to_int a  ->
    float_equal ?comment a (str (String.make 1 v))
  | Char_of_int a , Char_of_int b ->
    float_equal ?comment a b

  | _ ->  
      {expression_desc = Bin(EqEqEq, e0,e1); comment}


let int_equal = float_equal 



let rec string_equal ?comment (e0 : t) (e1 : t) : t = 
  match e0.expression_desc, e1.expression_desc with     
  | Str (_, a0), Str(_, b0) 
    -> bool  (Ext_string.equal a0 b0)
  | Unicode a0, Unicode b0 -> bool (Ext_string.equal a0 b0)
  | _ , _ 
    ->
      {expression_desc = Bin(EqEqEq, e0,e1); comment}     


let is_type_number ?comment (e : t) : t = 
  string_equal ?comment (typeof e) (str "number")    


(* we are calling [Caml_primitive.primitive_name], since it's under our
   control, we should make it follow the javascript name convention, and
   call plain [dot]
*)          


let tag ?comment e : t = 
  {expression_desc = 
     Bin (Bor, {expression_desc = Caml_block_tag e; comment }, zero_int_literal );
   comment = None }    


(* according to the compiler, [Btype.hash_variant], 
   it's reduced to 31 bits for hash
*)

let public_method_call meth_name obj label cache args = 
  let len = List.length args in 
  (* econd (int_equal (tag obj ) obj_int_tag_literal) *)
  if len <= 7 then          
    runtime_call Js_runtime_modules.caml_oo_curry 
      ("js" ^ string_of_int (len + 1) )
      (label:: ( int cache) :: obj::args)
  else 
    runtime_call Js_runtime_modules.caml_oo_curry "js"
      [label; 
       int cache;
       obj ;  
       array NA (obj::args)
      ]

(* TODO: handle arbitrary length of args .. 
   we can reduce part of the overhead by using
   `__js` -- a easy ppx {{ x ##.hh }} 
   the downside is that no way to swap ocaml/js implementation 
   for object part, also need encode arity..
   how about x#|getElementById|2|
*)


(* Note that [lsr] or [bor] are js semantics *)
let rec int32_bor ?comment (e1 : J.expression) (e2 : J.expression) : J.expression = 
  match e1.expression_desc, e2.expression_desc with 
  | Number (Int {i = i1} | Uint i1), Number (Int {i = i2})
    -> int ?comment (Int32.logor i1 i2)

  | _, (Bin(Lsr,e2, {expression_desc = Number(Int{i=0l} | Uint 0l | Nint 0n) ; _})) ->
    int32_bor  e1 e2
  | (Bin(Lsr,e1, {expression_desc = Number(Int{i=0l} | Uint 0l | Nint 0n) ; _})), _ ->
    int32_bor  e1 e2
  | (Bin(Lsr,_, {expression_desc = Number(Int{i} | Uint i ) ; _})),
    Number(Int{i=0l} | Uint 0l | Nint 0n)
    when i > 0l  -> (* a >>> 3 | 0 -> a >>> 3 *)
    e1

  | Bin (Bor, e1, {expression_desc = Number(Int{i=0l} | Uint 0l | Nint 0n) ; _} ), 
    Number(Int{i=0l} | Uint 0l | Nint 0n) ->
    int32_bor e1 e2  
  | _ -> 
    { comment ; 
      expression_desc = Bin (Bor, e1,e2)
    }

(* Arithmatic operations
   TODO: distinguish between int and float
   TODO: Note that we have to use Int64 to avoid integer overflow, this is fine
   since Js only have .

   like code below 
   {[
     MAX_INT_VALUE - (MAX_INT_VALUE - 100) + 20
   ]}

   {[
     MAX_INT_VALUE - x + 30
   ]}

   check: Re-association: avoid integer overflow
*) 
let  to_int32  ?comment (e : J.expression)  : J.expression = 
  int32_bor ?comment e zero_int_literal
(* TODO: if we already know the input is int32, [x|0] can be reduced into [x] *)
let nint ?comment n : J.expression =
  {expression_desc = Number (Nint n); comment }

let uint32 ?comment n : J.expression =
  {expression_desc = Number (Uint n); comment }



let string_comp cmp ?comment  e0 e1 = 
  bin ?comment cmp e0 e1

let obj_length ?comment e : t = 
  to_int32 {expression_desc = Length (e, Caml_block); comment }

let rec int_comp (cmp : Lam_compat.comparison) ?comment  (e0 : t) (e1 : t) = 
  match cmp, e0.expression_desc, e1.expression_desc with
  | _, Call ({
      expression_desc = 
        Var (Qualified 
               (_, Runtime, 
                Some ("caml_int_compare" | "caml_int32_compare"))); _}, 
      [l;r], _), 
    Number (Int {i = 0l})
    -> int_comp cmp l r (* = 0 > 0 < 0 *)
  | Ceq, Call ({
      expression_desc = 
        Var (Qualified 
               (ident, Runtime, 
                Some ("caml_compare"))); _} as fn, 
      ([l;r] as args), call_info), 
    Number (Int {i = 0l})
    -> 
      {e0 with expression_desc =
         Call( 
            {fn with expression_desc = 
              Var(Qualified (ident,Runtime, Some "caml_equal")) 
            } , args, call_info)}
  | Ceq, Optional_block _,  Undefined
  | Ceq, Undefined, Optional_block _
    -> false_           
  | Ceq, _, _ -> int_equal e0 e1 

  | Cneq, Optional_block _, Undefined
  | Cneq, Undefined , Optional_block _
  | Cneq, Caml_block _ ,  Number _ 
  | Cneq, Number _, Caml_block _  
    -> true_
  | _ ->          
    bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1

let bool_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = 
  match e0, e1 with 
  | {expression_desc = Bool l}, {expression_desc = Bool r}  ->
    bool (match cmp with 
    | Ceq  -> l = r
    | Cneq -> l <> r
    | Clt  -> l < r 
    | Cgt  -> l > r 
    | Cle  -> l <= r 
    | Cge  -> l >= r
    )
  | {expression_desc = Bool true}, rest 
  | rest, {expression_desc = Bool false}  -> 
    begin match cmp with 
    | Clt -> seq rest false_
    | Cge -> seq rest true_
    | Cle 
    | Cgt 
    | Ceq 
    | Cneq -> bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1 
    end 
  | rest, {expression_desc = Bool true} 
  | {expression_desc = Bool false}, rest 
    ->
    begin match cmp with  
    | Cle -> seq rest true_
    | Cgt -> seq rest false_
    | Clt
    | Cge 
    | Ceq 
    | Cneq -> bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1
    end
  | _ , _ ->
    bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1
let float_comp cmp ?comment  e0 e1 = 
  bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1

let js_comp cmp ?comment  e0 e1 = 
  bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1


let rec int32_lsr ?comment
    (e1 : J.expression) 
    (e2 : J.expression) : J.expression =
  let aux i1 i =
    uint32 (Int32.shift_right_logical i1 i) in    
  match e1.expression_desc, e2.expression_desc with
  | Number (Int { i = i1} | Uint i1 ), Number( Int {i = i2} | Uint i2)
    -> aux i1 (Int32.to_int i2)
  | Number (Nint i1), Number( Int {i = i2} | Uint i2)
    ->
    aux (Nativeint.to_int32 i1) (Int32.to_int i2)    
  | Number (Nint i1), Number (Nint i2)
    ->
    aux (Nativeint.to_int32 i1) (Nativeint.to_int i2)
  | (Bin(Lsr, _, _)), Number (Int {i = 0l} | Uint 0l | Nint 0n) 
    ->  e1 (* TODO: more opportunities here *)
  | Bin(Bor, e1, {expression_desc = Number (Int {i=0l;_} | Uint 0l | Nint 0n) ; _}),
    Number (Int {i = 0l} | Uint 0l | Nint 0n) 
    -> int32_lsr ?comment e1 e2
  | _, _ ->
    { comment ; 
      expression_desc = Bin (Lsr, e1,e2) (* uint32 *)
    }

let to_uint32 ?comment (e : J.expression)  : J.expression =
  int32_lsr ?comment e zero_int_literal


(* TODO: 
   we can apply a more general optimization here, 
   do some algebraic rewerite rules to rewrite [triple_equal]           
*)        
let rec is_out ?comment (e : t) (range : t) : t  = 
  begin match range.expression_desc, e.expression_desc with 

    | Number (Int {i = 1l}), Var _ 
      ->         
      not (or_ (triple_equal e zero_int_literal) (triple_equal e one_int_literal))                  
    | Number (Int {i = 1l}), 
      (
        Bin (Plus , {expression_desc = Number (Int {i ; _}) }, {expression_desc = Var _; _})
      | Bin (Plus, {expression_desc = Var _; _}, {expression_desc = Number (Int {i ; _}) }))

      ->
      not (or_ (triple_equal e (int (Int32.neg i ))) (triple_equal e (int (Int32.sub Int32.one  i))))        
    | Number (Int {i = 1l}), 
      Bin (Minus ,  ({expression_desc = Var _; _} as x), {expression_desc = Number (Int {i ; _}) })        
      ->           
      not (or_ (triple_equal x (int (Int32.add i  1l ))) (triple_equal x (int i)))        
    (* (x - i >>> 0 ) > k *)          
    | Number (Int {i = k}), 
      Bin (Minus ,  ({expression_desc = Var _; _} as x), 
           {expression_desc = Number (Int {i ; _}) })        
      ->           
      (or_ (int_comp Cgt x (int (Int32.add i  k)))  (int_comp Clt x  (int i)))
    | Number (Int {i = k}), Var _  
      -> 
      (* Note that js support [ 1 < x < 3], 
         we can optimize it into [ not ( 0<= x <=  k)]           
      *)        
      or_ (int_comp Cgt e (int ( k)))  (int_comp Clt e  zero_int_literal)

    | _, Bin (Bor ,
              ({expression_desc =
                  (Bin((Plus | Minus ) ,
                       {expression_desc = Number (Int {i ; _}) }, {expression_desc = Var _; _})
                  |Bin((Plus | Minus ) ,
                       {expression_desc = Var _; _}, {expression_desc = Number (Int {i ; _}) } ))
               } as e), {expression_desc = Number (Int {i=0l} | Uint 0l | Nint 0n); _})
      ->  
      (* TODO: check correctness *)
      is_out ?comment e range 
    | _, _ ->
      int_comp ?comment Cgt (to_uint32 e)  range 
  end

let rec float_add ?comment (e1 : t) (e2 : t) = 
  match e1.expression_desc, e2.expression_desc with 
  | Number (Int {i;_}), Number (Int {i = j;_}) -> 
    int ?comment (Int32.add i  j)
  | _, Number (Int {i = j; c}) when j < 0l -> 
    float_minus ?comment e1 
      {e2 with expression_desc = Number (Int {i = Int32.neg j; c})}       

  | Bin(Plus, a1 , ({expression_desc = Number (Int {i = k; _})}  )), 
    Number (Int { i =j; _}) -> 
    {comment ; expression_desc = Bin(Plus, a1,  (int (Int32.add k  j)))}
  (* bin ?comment Plus a1 (int (k + j)) *)

  (* TODO remove commented code  ?? *)
  (* | Bin(Plus, a0 , ({expression_desc = Number (Int a1)}  )), *)
  (*     Bin(Plus, b0 , ({expression_desc = Number (Int b1)}  )) *)
  (*   ->  *)
  (*   bin ?comment Plus a1 (int (a1 + b1)) *)

  (* | _, Bin(Plus,  b0, ({expression_desc = Number _}  as v)) *)
  (*   -> *)
  (*     bin ?comment Plus (bin ?comment Plus e1 b0) v *)
  (* | Bin(Plus, a1 , ({expression_desc = Number _}  as v)), _ *)
  (* | Bin(Plus, ({expression_desc = Number _}  as v),a1), _ *)
  (*   ->  *)
  (*     bin ?comment Plus (bin ?comment Plus a1 e2 ) v  *)
  (* | Number _, _ *)
  (*   ->  *)
  (*     bin ?comment Plus  e2 e1 *)
  | _ -> {comment ; expression_desc = Bin(Plus, e1,e2)}
(* bin ?comment Plus e1 e2 *)
(* associative is error prone due to overflow *)
and float_minus ?comment  (e1 : t) (e2 : t) : t = 
  match e1.expression_desc, e2.expression_desc with 
  | Number (Int {i;_}), Number (Int {i = j;_}) -> 
    int ?comment (Int32.sub i  j)
  | _ ->  {comment ; expression_desc = Bin(Minus, e1,e2)}
(* bin ?comment Minus e1 e2 *)



let unchecked_int32_add ?comment e1 e2 = 
  float_add ?comment e1 e2

let int32_add ?comment e1 e2 = 
  to_int32 @@ float_add ?comment e1 e2


let int32_minus ?comment e1 e2 : J.expression = 
  to_int32 @@  float_minus ?comment e1 e2

let unchecked_int32_minus ?comment e1 e2 : J.expression = 
  float_minus ?comment e1 e2



let float_div ?comment e1 e2 = 
  bin ?comment Div e1 e2 
let float_notequal ?comment e1 e2 = 
  bin ?comment NotEqEq e1 e2


let int32_asr ?comment e1 e2 : J.expression = 
  { comment ; 
    expression_desc = Bin (Asr, e1,e2)
  }

(** Division by zero is undefined behavior*)
let int32_div ~checked ?comment 
    (e1 : t) (e2 : t) : t = 
  match e1.expression_desc, e2.expression_desc with 
  | Length _ , Number (Int {i = 2l} | Uint 2l | Nint 2n)
    -> int32_asr e1 one_int_literal 
  | e1_desc , Number (Int {i = i1} ) when i1 <> 0l
    -> 
    begin match e1_desc with 
      | Number(Int {i = i0})
        -> 
        int (Int32.div i0 i1)
      | _ -> to_int32 (float_div ?comment e1 e2)
    end
  | _, _ -> 
    if checked  then 
      runtime_call Js_runtime_modules.int32 "div" [e1; e2]
    else to_int32 (float_div ?comment e1 e2)


let int32_mod ~checked ?comment e1 (e2 : t) : J.expression = 
  match e2.expression_desc with 
  | Number (Int {i }) when i <> 0l 
    -> 
    { comment ; 
      expression_desc = Bin (Mod, e1,e2)
    }

  | _ -> 
    if checked then 
      runtime_call Js_runtime_modules.int32 "mod_" [e1;e2]
    else 
      { comment ; 
        expression_desc = Bin (Mod, e1,e2)
      }


let float_mul ?comment e1 e2 = 
  bin ?comment Mul e1 e2 




let int32_lsl ?comment (e1 : J.expression) (e2 : J.expression) : J.expression = 
  match e1, e2  with 
  | {expression_desc = Number (Int {i = i0} | Uint i0)}, 
    {expression_desc = Number (Int {i = i1} | Uint i1)}
    -> int ?comment (Int32.shift_left i0 (Int32.to_int i1))
  | _ -> 
    { comment ; 
      expression_desc = Bin (Lsl, e1,e2)
    }

let  is_pos_pow n = 
  let module M = struct exception E end in 
  let rec aux c (n : Int32.t) = 
    if n <= 0l then -2 
    else if n = 1l then c 
    else if Int32.logand n 1l =  0l then   
      aux (c + 1) (Int32.shift_right n 1 )
    else raise_notrace M.E in 
  try aux 0 n  with M.E -> -1

let int32_mul ?comment 
    (e1 : J.expression) 
    (e2 : J.expression) : J.expression = 
  match e1, e2 with 
  | {expression_desc = Number (Int {i = 0l}|  Uint 0l | Nint 0n); _}, x
    when Js_analyzer.no_side_effect_expression x -> 
    zero_int_literal
  | x, {expression_desc = Number (Int {i = 0l}|  Uint 0l | Nint 0n); _} 
    when Js_analyzer.no_side_effect_expression x -> 
    zero_int_literal
  | {expression_desc = Number (Int{i = i0}); _}, {expression_desc = Number (Int {i = i1}); _}
    -> int (Int32.mul i0 i1)
  | e , {expression_desc = Number (Int {i = i0} | Uint i0 ); _}
  | {expression_desc = Number (Int {i = i0} | Uint i0 ); _}, e 
    -> 
    let i =  is_pos_pow i0  in 
    if i >= 0 then 
      int32_lsl e (small_int i)
    else 
      runtime_call ?comment Js_runtime_modules.int32 Literals.imul [e1;e2]
  | _ -> 
    runtime_call ?comment Js_runtime_modules.int32 Literals.imul [e1;e2]

let unchecked_int32_mul ?comment e1 e2 : J.expression = 
  { comment ; 
    expression_desc = Bin (Mul, e1,e2)
  }



let rec int32_bxor ?comment (e1 : t) (e2 : t) : J.expression = 
  match e1.expression_desc, e2.expression_desc with 
  | Number (Int {i = i1}), Number (Int {i = i2})
    -> int ?comment (Int32.logxor i1 i2)
  | _, (Bin(Lsr,e2, {expression_desc = Number(Int{i=0l} | Uint 0l | Nint 0n) ; _})) ->
    int32_bxor  e1 e2
  | (Bin(Lsr,e1, {expression_desc = Number(Int{i=0l} | Uint 0l | Nint 0n) ; _})), _ ->
    int32_bxor  e1 e2

  | _ -> 
    { comment ; 
      expression_desc = Bin (Bxor, e1,e2)
    }

let rec int32_band ?comment (e1 : J.expression) (e2 : J.expression) : J.expression = 
  match e1.expression_desc with 
  | Bin (Bor ,a, {expression_desc = Number (Int {i = 0l})})
    -> 
    (* Note that in JS
       {[ -1 >>> 0 & 0xffffffff = -1]} is the same as 
       {[ (-1 >>> 0 | 0 ) & 0xffffff ]}
    *)
    int32_band a e2
  | _  ->
    { comment ; 
      expression_desc = Bin (Band, e1,e2)
    }


(* let int32_bin ?comment op e1 e2 : J.expression =  *)
(*   {expression_desc = Int32_bin(op,e1, e2); comment} *)


(* TODO -- alpha conversion 
    remember to add parens..
*)
let of_block ?comment ?e block : t = 
  call ~info:Js_call_info.ml_full_call
    {
      comment ;
      expression_desc = 
        Fun (false, [], 
             begin match e with 
               | None -> block 
               | Some e -> 
                 Ext_list.append block  
                   [{J.statement_desc = Return {return_value = e } ;
                     comment}]
             end
            , Js_fun_env.make 0)
    } []

let is_null ?comment (x : t) =   
  triple_equal ?comment x nil 


let is_undef ?comment x = triple_equal ?comment x undefined

let for_sure_js_null_undefined (x : t) = 
  match x.expression_desc with 
  | Null | Undefined
    -> true
  | _ -> false
  
let is_null_undefined ?comment (x: t) : t = 
  match x.expression_desc with 
  | Null | Undefined
    -> true_
  | Number _ | Array _ | Caml_block _ -> false_
  | _ ->      
      { comment ; 
        expression_desc = Is_null_or_undefined x 
      }

let eq_null_undefined_boolean ?comment (a : t) (b : t) = 
  match a.expression_desc, b.expression_desc with 
  | (Null | Undefined),   
    (Char_of_int _ | Char_to_int _ 
    | Bool _ | Number _ | Typeof _
    | Fun _ | Array _ | Caml_block _ )
     -> 
    false_
  | (Char_of_int _ | Char_to_int _ 
    | Bool _ | Number _ | Typeof _
    | Fun _ | Array _ | Caml_block _ ), 
      (Null | Undefined)
     -> 
    false_
  | (Null, Undefined)
  | (Undefined, Null) -> false_
  | (Null, Null)
  | (Undefined, Undefined)
    -> true_
  | _ ->       
       {expression_desc = Bin(EqEqEq, a, b); comment}
    


let neq_null_undefined_boolean ?comment (a : t) (b : t) = 
  match a.expression_desc, b.expression_desc with 
  | (Null | Undefined),   
    (Char_of_int _ | Char_to_int _ 
    | Bool _ | Number _ | Typeof _
    | Fun _ | Array _ | Caml_block _ )
     -> 
    true_
  | (Char_of_int _ | Char_to_int _ 
    | Bool _ | Number _ | Typeof _
    | Fun _ | Array _ | Caml_block _ ), 
      (Null | Undefined)
     -> 
    true_
  | (Null , Null )
  | (Undefined, Undefined)
   -> false_
  | (Null, Undefined)
  | (Undefined, Null)
   -> true_
  | _ ->       
       {expression_desc = Bin(NotEqEq, a, b); comment}



(** TODO: in the future add a flag
  to set globalThis
*)       
let resolve_and_apply 
    ?comment (s : string) (args : t list) : t =  
  call ~info:Js_call_info.builtin_runtime_call
    (runtime_call
       Js_runtime_modules.external_polyfill
       "resolve" 
       [str s ]
    ) args 




end
module Js_stmt_make : sig 
#1 "js_stmt_make.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Creator utilities for the [J] module *) 


type t = J.statement 


(** empty statement, block of length 0 *)  
val empty_stmt :  
  t

val throw_stmt :
  ?comment:string  ->
  J.expression ->
  t

val if_ : 
  ?comment:string  ->
  ?declaration: Lam_compat.let_kind * Ident.t ->
  (* when it's not None, we also need make a variable declaration in the
     begininnig, however, we can optmize such case
  *)
  ?else_:J.block ->  
  J.expression -> 
  J.block -> 
  t

(**   
  turn a block into  a single statement,
  avoid nested block
*)  
val block : 
  ?comment:string  -> 
  J.block ->
  t

(** [int_switch ~declaration e clauses]

  The [declaration] is attached to peepwhole 
  such pattern 

  {[
    var x ;
    x = yy
  ]}
  
  into
  {[
    var x = yy;
  ]}
*)  
val int_switch :
  ?comment:string -> 
  ?declaration:Lam_compat.let_kind * Ident.t -> 
  ?default:J.block -> 
  J.expression -> 
  int J.case_clause list -> 
  t 

val string_switch : 
  ?comment:string -> 
  ?declaration:Lam_compat.let_kind * Ident.t -> 
  ?default:J.block ->
  J.expression -> 
  string J.case_clause list ->
  t

(** Just declaration without initialization *)  
val declare_variable : 
  ?comment:string ->
  ?ident_info:J.ident_info ->
  kind:Lam_compat.let_kind -> 
  Ident.t ->
  t

(*** Declaration with initialization *)
val define_variable : 
  ?comment:string ->
  ?ident_info:J.ident_info ->
  kind:Lam_compat.let_kind -> 
  Ident.t ->
  J.expression ->
  t

(** created an alias expression *)  
val alias_variable :
  ?comment:string ->
  exp:J.expression ->
  Ident.t ->
  t

val assign :
  ?comment:string  ->
  J.ident ->
  J.expression ->
  t

(** Used in cases like 
  {[
    let x = while true do 
      ...
    done in ..
  ]}
*)  
val assign_unit :
  ?comment:string  ->
  J.ident ->
  t

(** used in cases like 
  {[
    let x = while true do 
      ...
    done in ..
  ]}
*)  
val declare_unit :
  ?comment:string  ->
  J.ident ->
  t

val while_ :
  ?comment:string ->
  ?label:J.label ->
  ?env:Js_closure.t ->
  J.expression ->
  J.block ->
  t

val for_ : 
  ?comment:string ->
  ?env:Js_closure.t ->
  J.for_ident_expression option ->
  J.finish_ident_expression ->
  J.for_ident  ->
  J.for_direction ->
  J.block ->
  t

val try_ :
  ?comment:string  ->
  ?with_:J.ident * J.block ->
  ?finally:J.block ->
  J.block ->
  t

val exp :
  ?comment:string  ->
  J.expression ->
  t

val return_stmt :
  ?comment:string  ->
  J.expression ->
  t


val return_unit : t list
(** for ocaml function which returns unit 
    it will be compiled into [return 0] in js *)

(** if [label] is not set, it will default to empty *)  
val continue_stmt :
  ?comment:string  ->
  ?label:J.label ->
  unit  ->
  t
val continue_ : t   

val debugger_block :  t list

end = struct
#1 "js_stmt_make.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






module E = Js_exp_make 

type t = J.statement 

let return_stmt ?comment e : t = 
  {statement_desc = Return {return_value = e; } ; comment}

let return_unit  : t list =              
    [{ statement_desc = Return {return_value = E.unit; } ; 
      comment = None}]
  
let empty_stmt  : t = 
  { statement_desc = Block []; comment = None}
(* let empty_block : J.block = [] *)
let throw_stmt ?comment v : t = 
  { statement_desc = Throw v; comment}

(* avoid nested block *)
let  rec block ?comment  (b : J.block)   : t =  
  match b with 
  | [{statement_desc = Block bs }  ] -> block bs
  | [b] -> b
  | [] -> empty_stmt 
  | _ -> {statement_desc = Block b  ; comment}

(* It's a statement, we can discard some values *)       
let rec exp ?comment (e : E.t) : t = 
  match e.expression_desc with 
  | (Seq( {expression_desc = Number _}, b) 
    | Seq( b, {expression_desc = Number _})) -> exp ?comment b 
  | Number _ -> block []
  (* TODO: we can do more *)      
  (* | _ when is_pure e ->  block [] *)
  |  _ -> 
    { statement_desc = Exp e; comment}

let declare_variable ?comment  ?ident_info  ~kind (ident:Ident.t)  : t=
  let property : J.property =  kind in
  let ident_info  : J.ident_info  = 
    match ident_info with
    | None ->  {used_stats = NA}
    | Some x -> x in
  {statement_desc = 
     Variable { ident; value = None; property ; 
                ident_info ;};
   comment}

let define_variable ?comment  ?ident_info 
  ~kind (v:Ident.t) exp : t=
  let property : J.property =  kind in
  let ident_info  : J.ident_info  = 
    match ident_info with
    | None ->  {used_stats = NA}
    | Some x -> x in
  {statement_desc = 
     Variable { ident = v; value =  Some exp; property ; 
                ident_info ;};
   comment}

let alias_variable ?comment  ~exp (v:Ident.t)  : t=
  {statement_desc = 
     Variable {
       ident = v; value = Some exp; property = Alias;
       ident_info = {used_stats = NA }   };
   comment}   


let int_switch 
    ?(comment : string option)  
    ?(declaration : (J.property * Ident.t) option )
    ?(default : J.block option)
    (e : J.expression)  
    (clauses : int J.case_clause list): t = 
  match e.expression_desc with 
  | Number (Int {i; _}) -> 
    let continuation =  
      match Ext_list.find_opt clauses
              (fun x ->
                 if x.switch_case = Int32.to_int i then
                   Some x.switch_body else None ) 
      with 
      | Some case -> case 
      | None -> 
        match default with
        | Some x ->  x 
        | None -> assert false in
    (match declaration, continuation with 
     | Some (kind, did), 
       [ {statement_desc = 
            Exp {
              expression_desc = 
                Bin(Eq,  {expression_desc = Var (Id id) ; _}, e0); _}; _}]
       when Ident.same did id 
       -> 
       define_variable ?comment ~kind id e0
     | Some(kind,did), _ 
       -> 
       block (declare_variable ?comment ~kind did :: continuation)
     | None, _ -> block continuation)    
  | _ -> 
    match declaration with 
    | Some (kind, did) -> 
      block [declare_variable ?comment ~kind did ;
             { statement_desc = J.Int_switch (e,clauses, default); comment}]
    | None ->  { statement_desc = J.Int_switch (e,clauses, default); comment}    

let string_switch 
  ?(comment:string option) 
  ?(declaration : (J.property * Ident.t) option) 
  ?(default : J.block option)
  (e : J.expression)  
  (clauses : string J.case_clause list): t= 
  match e.expression_desc with 
  | Str (_,s) -> 
    let continuation = 
      match Ext_list.find_opt clauses (fun  x ->
                 if x.switch_case = s then 
                   Some x.switch_body
                 else None  
              ) with 
      | Some case ->  case
      | None -> 
        match default with 
        | Some x -> x 
        | None -> assert false in
    (match declaration, continuation with 
     | Some (kind, did),
       [ {statement_desc = Exp {expression_desc = Bin(Eq,  {expression_desc = Var (Id id); _}, e0);_} ; _}]
       when Ident.same did id 
       -> 
       define_variable ?comment ~kind id e0
     | Some(kind,did), _ 
       -> 
       block @@ declare_variable ?comment ~kind did :: continuation
     | None, _ -> block continuation)    
  | _  -> 
    match declaration with 
    | Some (kind,did) -> 
      block [declare_variable ?comment ~kind did ;
             { statement_desc = String_switch (e,clauses, default); comment}]
    | None -> { statement_desc = String_switch (e,clauses, default); comment}


(* TODO: it also make sense  to extract some common statements 
    between those two branches, it does happen since in OCaml you 
    have to write some duplicated code due to the types system restriction
    example:
   {[
     | Format_subst (pad_opt, fmtty, rest) ->
       buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
       bprint_pad_opt buf pad_opt; buffer_add_char buf '(';
       bprint_fmtty buf fmtty; buffer_add_char buf '%'; buffer_add_char buf ')';
       fmtiter rest false;

       | Scan_char_set (width_opt, char_set, rest) ->
       buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
       bprint_pad_opt buf width_opt; bprint_char_set buf char_set;
       fmtiter rest false;
   ]}

   To hit this branch, we also need [declaration] passed down 
           TODO: check how we compile [Lifthenelse]
    The declaration argument is introduced to merge assignment in both branches           

  Note we can transfer code as below:
  {[
    if (x){
      return /throw e;
    } else {
      blabla
    }
  ]}
  into 
  {[
    if (x){
      return /throw e;
    } 
    blabla    
  ]}
  Not clear the benefit
*)
let rec if_ ?comment  ?declaration ?else_ (e : J.expression) (then_ : J.block)   : t = 
  let declared = ref false in
  let common_prefix_blocks = ref [] in 
  let add_prefix b = common_prefix_blocks := b :: !common_prefix_blocks in 
  let rec aux ?comment (e : J.expression) (ifso : J.block) (ifnot : J.block ): t  =
    match e.expression_desc with 
    | Bool boolean -> 
      block (if boolean then ifso else ifnot) 
    | Js_not pred_not
      -> aux ?comment pred_not ifnot ifso
    | _ -> 
      match ifso, ifnot with 
      |  [], [] -> exp e 
      |  [], _ ->
        {
          statement_desc = If ( E.not e, ifnot, None); comment
        }
      | [ {statement_desc = Return {return_value = ret_ifso; _}; _}], 
        [ {statement_desc = Return {return_value = ret_ifnot; _}; _} as _ifnot_stmt]
        ->      
        return_stmt (E.econd e ret_ifso ret_ifnot ) 
      | [ {statement_desc = 
             Exp
               {expression_desc = Bin(Eq, ({expression_desc = Var (Id var_ifso); _} as lhs_ifso), rhs_ifso); _};
           _}], 
        [ {statement_desc = 
             Exp (
               { expression_desc =
                   Bin(Eq, 
                       {expression_desc = Var (Id var_ifnot); _}, lhs_ifnot); _}); _}]
        when Ident.same var_ifso var_ifnot -> 
        (match declaration with 
         | Some (kind,id)  when Ident.same id var_ifso -> 
           declared := true;
           define_variable ~kind var_ifso (E.econd e rhs_ifso lhs_ifnot)      
         | _ -> 
           exp (E.assign lhs_ifso (E.econd e rhs_ifso lhs_ifnot)))
      | [ {statement_desc = Exp exp_ifso; _}],  
        [ {statement_desc = Exp exp_ifnot; _}]
        ->
        exp (E.econd e exp_ifso exp_ifnot)
              
      | [ {statement_desc = If (pred1, ifso1, Some ifnot1) }],
        _ when Js_analyzer.eq_block ifnot1 ifnot
        ->
        aux ?comment (E.and_ e pred1) ifso1 ifnot1 
      | [ {statement_desc = If (pred1, ifso1, Some ifnot1) }],
        _  when Js_analyzer.eq_block ifso1 ifnot
        ->
        aux ?comment (E.and_ e (E.not pred1)) ifnot1 ifso1 
      | _ , 
        [ {statement_desc = If (pred1,  ifso1, Some (else_ )) }]
        when Js_analyzer.eq_block ifso ifso1 
        ->
        aux ?comment (E.or_ e pred1) ifso else_
      | _  , 
        [ {statement_desc = If (pred1, ifso1, Some ifnot1 ) }]
        when Js_analyzer.eq_block ifso ifnot1
        ->
        aux ?comment (E.or_ e (E.not pred1)) ifso ifso1 
      | ifso1::ifso_rest,  ifnot1::ifnot_rest
        when Js_analyzer.eq_statement ifnot1 ifso1 && Js_analyzer.no_side_effect_expression e
        ->
        (** here we do agressive optimization, because it can help optimization later,
            move code outside of branch is generally helpful later
        *)
        add_prefix ifso1 ; 
        aux ?comment e ifso_rest ifnot_rest 
      | _ -> 
        { statement_desc =
            If (e, 
                ifso,
                if ifnot = [] then None 
                else Some  ifnot); 
          comment } in
  let if_block = 
    aux ?comment e then_ (match else_ with None -> [] | Some v -> v)  in
  let prefix = !common_prefix_blocks in 
  match !declared, declaration with 
  | true , _ 
  | _    , None  ->  
    if prefix = [] then if_block
    else 
      block (List.rev_append prefix [if_block])
  | false, Some (kind, id) -> 
    block (declare_variable ~kind id :: List.rev_append prefix [if_block] )





let assign ?comment  id e : t = 
  {
    statement_desc = J.Exp ( E.assign (E.var id) e ) ;
    comment
  }
let assign_unit ?comment  id :  t = 
  {
    statement_desc = J.Exp( E.assign (E.var id) E.unit);
    comment
  }
let declare_unit ?comment  id :  t = 
  {
    statement_desc = 
      J.Variable { ident =  id; 
                   value = Some E.unit;
                   property = Variable;
                   ident_info = {used_stats = NA}
                 };
    comment
  }

let rec while_  ?comment  ?label ?env (e : E.t) (st : J.block) : t = 
  let env = 
    match env with 
    | None -> Js_closure.empty ()
    | Some x -> x in
  {
    statement_desc = While (label, e, st, env);
    comment
  }

let for_ ?comment   ?env 
    for_ident_expression
    finish_ident_expression id direction (b : J.block) : t =
  let env = 
    match env with 
    | None -> Js_closure.empty ()
    | Some x -> x 
  in
  {
    statement_desc = 
      ForRange (for_ident_expression, finish_ident_expression, id, direction, b, env);
    comment
  }

let try_ ?comment   ?with_ ?finally body : t = 
  {
    statement_desc = Try (body, with_, finally) ;
    comment
  }

(* TODO: 
    actually, only loops can be labelled
*)    
let continue_stmt  ?comment   ?(label="") unit  : t = 
  { 
    statement_desc = J.Continue  label;
    comment;
  }
  
let continue_ : t = {
  statement_desc = Continue "" ;
  comment = None
}

let debugger_block : t list = 
  [{ statement_desc = Debugger ; 
    comment = None 
  }]

end
module Hash_set_gen
= struct
#1 "hash_set_gen.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


(* We do dynamic hashing, and resize the table and rehash the elements
   when buckets become too long. *)

type 'a t =
  { mutable size: int;                        (* number of entries *)
    mutable data: 'a list array;  (* the buckets *)
    initial_size: int;                        (* initial array size *)
  }




let create  initial_size =
  let s = Ext_util.power_2_above 16 initial_size in
  { initial_size = s; size = 0; data = Array.make s [] }

let clear h =
  h.size <- 0;
  let len = Array.length h.data in
  for i = 0 to len - 1 do
    Array.unsafe_set h.data i  []
  done

let reset h =
  h.size <- 0;
  h.data <- Array.make h.initial_size [ ]


let copy h = { h with data = Array.copy h.data }

let length h = h.size

let iter h f =
  let rec do_bucket = function
    | [ ] ->
      ()
    | k ::  rest ->
      f k ; do_bucket rest in
  let d = h.data in
  for i = 0 to Array.length d - 1 do
    do_bucket (Array.unsafe_get d i)
  done

let fold h init f =
  let rec do_bucket b accu =
    match b with
      [ ] ->
      accu
    | k ::  rest ->
      do_bucket rest (f k  accu) in
  let d = h.data in
  let accu = ref init in
  for i = 0 to Array.length d - 1 do
    accu := do_bucket (Array.unsafe_get d i) !accu
  done;
  !accu

let resize indexfun h =
  let odata = h.data in
  let osize = Array.length odata in
  let nsize = osize * 2 in
  if nsize < Sys.max_array_length then begin
    let ndata = Array.make nsize [ ] in
    h.data <- ndata;          (* so that indexfun sees the new bucket count *)
    let rec insert_bucket = function
        [ ] -> ()
      | key :: rest ->
        let nidx = indexfun h key in
        ndata.(nidx) <- key :: ndata.(nidx);
        insert_bucket rest
    in
    for i = 0 to osize - 1 do
      insert_bucket (Array.unsafe_get odata i)
    done
  end

let elements set = 
  fold set [] (fun k  acc ->  k :: acc) 




let stats h =
  let mbl =
    Ext_array.fold_left h.data 0 (fun m b -> max m (List.length b)) in
  let histo = Array.make (mbl + 1) 0 in
  Ext_array.iter h.data
    (fun b ->
       let l = List.length b in
       histo.(l) <- histo.(l) + 1)
    ;
  {Hashtbl.num_bindings = h.size;
   num_buckets = Array.length h.data;
   max_bucket_length = mbl;
   bucket_histogram = histo }

let rec small_bucket_mem eq_key key lst =
  match lst with 
  | [] -> false 
  | key1::rest -> 
    eq_key key   key1 ||
    match rest with 
    | [] -> false 
    | key2 :: rest -> 
      eq_key key   key2 ||
      match rest with 
      | [] -> false 
      | key3 :: rest -> 
        eq_key key   key3 ||
        small_bucket_mem eq_key key rest 

let rec remove_bucket eq_key key (h : _ t) buckets = 
  match buckets with 
  | [ ] ->
    [ ]
  | k :: next ->
    if  eq_key k   key
    then begin h.size <- h.size - 1; next end
    else k :: remove_bucket eq_key key h next    

module type S =
sig
  type key
  type t
  val create: int ->  t
  val clear : t -> unit
  val reset : t -> unit
  val copy: t -> t
  val remove:  t -> key -> unit
  val add :  t -> key -> unit
  val of_array : key array -> t 
  val check_add : t -> key -> bool
  val mem : t -> key -> bool
  val iter: t -> (key -> unit) -> unit
  val fold: t -> 'b  -> (key -> 'b -> 'b) -> 'b
  val length:  t -> int
  val stats:  t -> Hashtbl.statistics
  val elements : t -> key list 
end

end
module Hash_set : sig 
#1 "hash_set.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

(** Ideas are based on {!Hashtbl}, 
    however, {!Hashtbl.add} does not really optimize and has a bad semantics for {!Hash_set}, 
    This module fixes the semantics of [add].
    [remove] is not optimized since it is not used too much 
*)





module Make ( H : Hashtbl.HashedType) : (Hash_set_gen.S with type key = H.t)
(** A naive t implementation on top of [hashtbl], the value is [unit]*)


end = struct
#1 "hash_set.ml"
# 1 "ext/hash_set.cppo.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
# 43 "ext/hash_set.cppo.ml"
module Make (H: Hashtbl.HashedType) : (Hash_set_gen.S with type key = H.t) = struct 
type key = H.t 
let eq_key = H.equal
let key_index (h :  _ Hash_set_gen.t ) key =
  (H.hash  key) land (Array.length h.data - 1)
type t = key Hash_set_gen.t



# 64 "ext/hash_set.cppo.ml"
let create = Hash_set_gen.create
let clear = Hash_set_gen.clear
let reset = Hash_set_gen.reset
let copy = Hash_set_gen.copy
let iter = Hash_set_gen.iter
let fold = Hash_set_gen.fold
let length = Hash_set_gen.length
let stats = Hash_set_gen.stats
let elements = Hash_set_gen.elements



let remove (h : _ Hash_set_gen.t) key =  
  let i = key_index h key in
  let h_data = h.data in
  let old_h_size = h.size in 
  let new_bucket = Hash_set_gen.remove_bucket eq_key key h (Array.unsafe_get h_data i) in
  if old_h_size <> h.size then  
    Array.unsafe_set h_data i new_bucket



let add (h : _ Hash_set_gen.t) key =
  let i = key_index h key  in 
  let h_data = h.data in 
  let old_bucket = (Array.unsafe_get h_data i) in
  if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then 
    begin 
      Array.unsafe_set h_data i (key :: old_bucket);
      h.size <- h.size + 1 ;
      if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h
    end

let of_array arr = 
  let len = Array.length arr in 
  let tbl = create len in 
  for i = 0 to len - 1  do
    add tbl (Array.unsafe_get arr i);
  done ;
  tbl 
  
    
let check_add (h : _ Hash_set_gen.t) key =
  let i = key_index h key  in 
  let h_data = h.data in  
  let old_bucket = (Array.unsafe_get h_data i) in
  if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then 
    begin 
      Array.unsafe_set h_data i  (key :: old_bucket);
      h.size <- h.size + 1 ;
      if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h;
      true 
    end
  else false 


let mem (h :  _ Hash_set_gen.t) key =
  Hash_set_gen.small_bucket_mem eq_key key (Array.unsafe_get h.data (key_index h key)) 

# 124 "ext/hash_set.cppo.ml"
end
  

end
module Hashtbl_make : sig 
#1 "hashtbl_make.mli"


module Make (Key : Hashtbl.HashedType) : Hashtbl_gen.S with type key = Key.t

end = struct
#1 "hashtbl_make.ml"
# 22 "ext/hashtbl.cppo.ml"
module Make (Key : Hashtbl.HashedType) = struct 
  type key = Key.t 
  type 'a t = (key, 'a)  Hashtbl_gen.t 
  let key_index (h : _ t ) (key : key) =
    (Key.hash  key ) land (Array.length h.data - 1)
  let eq_key = Key.equal   


# 33 "ext/hashtbl.cppo.ml"
type ('a, 'b) bucketlist = ('a,'b) Hashtbl_gen.bucketlist
let create = Hashtbl_gen.create
let clear = Hashtbl_gen.clear
let reset = Hashtbl_gen.reset
let copy = Hashtbl_gen.copy
let iter = Hashtbl_gen.iter
let to_list = Hashtbl_gen.to_list
let fold = Hashtbl_gen.fold
let length = Hashtbl_gen.length
let stats = Hashtbl_gen.stats



let add (h : _ t) key info =
  let i = key_index h key in
  let h_data = h.data in   
  Array.unsafe_set h_data i (Cons(key, info, (Array.unsafe_get h_data i)));
  h.size <- h.size + 1;
  if h.size > Array.length h_data lsl 1 then Hashtbl_gen.resize key_index h

(* after upgrade to 4.04 we should provide an efficient [replace_or_init] *)
let modify_or_init (h : _ t) key modf default =
  let rec find_bucket (bucketlist : _ bucketlist)  =
    match bucketlist with
    | Cons(k,i,next) ->
      if eq_key k key then begin modf i; false end
      else find_bucket next 
    | Empty -> true in
  let i = key_index h key in 
  let h_data = h.data in 
  if find_bucket (Array.unsafe_get h_data i) then
    begin 
      Array.unsafe_set h_data i  (Cons(key,default (), Array.unsafe_get h_data i));
      h.size <- h.size + 1 ;
      if h.size > Array.length h_data lsl 1 then Hashtbl_gen.resize key_index h 
    end


let rec remove_bucket key (h : _ t) (bucketlist : _ bucketlist) : _ bucketlist = 
  match bucketlist with  
  | Empty ->
    Empty
  | Cons(k, i, next) ->
    if eq_key k key 
    then begin h.size <- h.size - 1; next end
    else Cons(k, i, remove_bucket key h next) 

let remove (h : _ t ) key =
  let i = key_index h key in
  let h_data = h.data in 
  let old_h_szie = h.size in 
  let new_bucket = remove_bucket key h (Array.unsafe_get h_data i) in  
  if old_h_szie <> h.size then 
    Array.unsafe_set h_data i  new_bucket

let rec find_rec key (bucketlist : _ bucketlist) = match bucketlist with  
  | Empty ->
    raise Not_found
  | Cons(k, d, rest) ->
    if eq_key key k then d else find_rec key rest

let find_exn (h : _ t) key =
  match Array.unsafe_get h.data (key_index h key) with
  | Empty -> raise Not_found
  | Cons(k1, d1, rest1) ->
    if eq_key key k1 then d1 else
      match rest1 with
      | Empty -> raise Not_found
      | Cons(k2, d2, rest2) ->
        if eq_key key k2 then d2 else
          match rest2 with
          | Empty -> raise Not_found
          | Cons(k3, d3, rest3) ->
            if eq_key key k3  then d3 else find_rec key rest3

let find_opt (h : _ t) key =
  Hashtbl_gen.small_bucket_opt eq_key key (Array.unsafe_get h.data (key_index h key))

let find_key_opt (h : _ t) key =
  Hashtbl_gen.small_bucket_key_opt eq_key key (Array.unsafe_get h.data (key_index h key))
  
let find_default (h : _ t) key default = 
  Hashtbl_gen.small_bucket_default eq_key key default (Array.unsafe_get h.data (key_index h key))
let find_all (h : _ t) key =
  let rec find_in_bucket (bucketlist : _ bucketlist) = match bucketlist with 
    | Empty ->
      []
    | Cons(k, d, rest) ->
      if eq_key k key 
      then d :: find_in_bucket rest
      else find_in_bucket rest in
  find_in_bucket (Array.unsafe_get h.data (key_index h key))

let replace h key info =
  let rec replace_bucket (bucketlist : _ bucketlist) : _ bucketlist = match bucketlist with 
    | Empty ->
      raise_notrace Not_found
    | Cons(k, i, next) ->
      if eq_key k key
      then Cons(key, info, next)
      else Cons(k, i, replace_bucket next) in
  let i = key_index h key in
  let h_data = h.data in 
  let l = Array.unsafe_get h_data i in
  try
    Array.unsafe_set h_data i  (replace_bucket l)
  with Not_found ->
    begin 
      Array.unsafe_set h_data i (Cons(key, info, l));
      h.size <- h.size + 1;
      if h.size > Array.length h_data lsl 1 then Hashtbl_gen.resize key_index h;
    end 

let mem (h : _ t) key =
  let rec mem_in_bucket (bucketlist : _ bucketlist) = match bucketlist with 
    | Empty ->
      false
    | Cons(k, d, rest) ->
      eq_key k key  || mem_in_bucket rest in
  mem_in_bucket (Array.unsafe_get h.data (key_index h key))


let of_list2 ks vs = 
  let len = List.length ks in 
  let map = create len in 
  List.iter2 (fun k v -> add map k v) ks vs ; 
  map

# 162 "ext/hashtbl.cppo.ml"
end

end
module Lam_module_ident : sig 
#1 "lam_module_ident.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)











(** A type for qualified identifiers in Lambda IR 
 *)

type t = Js_op.module_id = 
  private {
  id : Ident.t ; 
  kind : Js_op.kind 
  }


val id : t -> Ident.t 

val name : t -> string

val mk : J.kind -> Ident.t -> t

val of_ml : Ident.t -> t

val of_external : Ident.t -> string -> t

val of_runtime : Ident.t -> t 

module Hash : Hashtbl_gen.S with type key = t
module Hash_set : Hash_set_gen.S with type key = t
end = struct
#1 "lam_module_ident.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)









type t = Js_op.module_id = 
  { id : Ident.t ; kind : Js_op.kind }



let id x = x.id 

let of_ml id = { id ; kind =  Ml}

let of_external id name =  {id ; kind = External name}

let of_runtime id = { id ; kind = Runtime }

let mk kind id = {id; kind}

let name  x : string  = 
  match (x.kind : J.kind) with 
  | Ml  | Runtime ->  x.id.name
  | External v -> v  

module Cmp = struct 
  type nonrec t = t
  let equal (x : t) y = 
    match x.kind with 
    | External x_kind-> 
      begin match y.kind with 
        | External y_kind -> 
          x_kind = (y_kind : string)
        | _ -> false 
      end
    | Ml 
    | Runtime -> Ext_ident.equal x.id y.id 
  (* #1556
     Note the main difference between [Ml] and [Runtime] is 
     that we have more assumptions about [Runtime] module, 
     like its purity etc, and its name uniqueues, in the pattern match 
     {[
       Qualified (_,Runtime, Some "caml_int_compare")
     ]}
     and we could do more optimziations.
     However, here if it is [hit] 
     (an Ml module = an Runtime module), which means both exists, 
     so adding either does not matter
     if it is not hit, fine
  *)
  (* | Ml -> y.kind = Ml &&  *)
  (* | Runtime ->  *)
  (*   y.kind = Runtime  && Ext_ident.equal x.id y.id *)
  let hash (x : t) = 
    match x.kind with 
    | External x_kind -> Bs_hash_stubs.hash_string x_kind 
    | Ml 
    | Runtime -> 
      let x_id = x.id in 
      Bs_hash_stubs.hash_stamp_and_name x_id.stamp x_id.name 
end

module Hash = Hashtbl_make.Make (Cmp)

module Hash_set = Hash_set.Make (Cmp)

end
module Ext_log : sig 
#1 "ext_log.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** A Poor man's logging utility
    
    Example:
    {[ 
    err __LOC__ "xx"
    ]}
 *)



type 'a logging =  ('a, Format.formatter, unit, unit, unit, unit) format6 -> 'a


val err : string -> 'a logging
val ierr : bool -> string -> 'a logging 
val warn : string -> 'a logging
val iwarn : bool -> string -> 'a logging 

val dwarn : 
  ?__POS__:(string * int * int *int) ->
  'a logging 
  
val info : string -> 'a logging
val iinfo : bool -> string -> 'a logging

end = struct
#1 "ext_log.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)










type 'a logging =  ('a, Format.formatter, unit, unit, unit, unit) format6 -> 'a

let err str f  =
  Format.fprintf Format.err_formatter ("%s " ^^ f ^^ "@.") str  

let ierr b str f  =
  if b then 
    Format.fprintf Format.err_formatter ("%s " ^^ f) str  
  else
    Format.ifprintf Format.err_formatter ("%s " ^^ f) str  

let warn str f  =
  Format.fprintf Format.err_formatter ("WARN: %s " ^^ f ^^ "@.") str  



let iwarn b str f  = 
  if b then 
    Format.fprintf Format.err_formatter ("WARN: %s " ^^ f) str  
  else 
    Format.ifprintf Format.err_formatter ("WARN: %s " ^^ f) str 

(* TODO: add {[@.]} later for all *)
let dwarn ?(__POS__: (string * int * int * int) option) f  = 
  if Js_config.is_same_file () then   
    match __POS__ with 
    | None -> Format.fprintf Format.err_formatter ("WARN: " ^^ f ^^ "@.")
    | Some (file,line,_,_) -> 
      Format.fprintf Format.err_formatter ("WARN: %s,%d " ^^ f ^^ "@.") file line  
  else 
    Format.ifprintf Format.err_formatter ("WARN: " ^^ f ^^ "@.") 

let info str f  =
  Format.fprintf Format.err_formatter ("INFO: %s " ^^ f) str  

let iinfo b str f  =
  if b then 
    Format.fprintf Format.err_formatter ("INFO: %s " ^^ f) str  
  else
    Format.fprintf Format.err_formatter ("INFO: %s " ^^ f) str  


end
module Ocaml_types : sig 
#1 "ocaml_types.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Utilities for quering typing information from {!Env.t}, this part relies
    on compiler API
*)

type t

val empty : t 
val length : t -> int 



(* Input path is a global module 
    TODO: it should be fine for local module*)
val find_serializable_signatures_by_path :
  Ident.t -> Env.t -> t option

val get_name : t -> int -> string

val map : (string -> 'a) -> t -> 'a list 

end = struct
#1 "ocaml_types.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type t = Types.signature

let empty  = []
let length  = List.length 
let name_of_signature_item (x : Types.signature_item )=
  match x with 
  | Sig_value (i,_) 
  | Sig_module (i,_,_) -> i 
  | Sig_typext (i,_,_) -> i 
  | Sig_modtype(i,_) -> i 
  | Sig_class (i,_,_) -> i 
  | Sig_class_type(i,_,_) -> i 
  | Sig_type(i,_,_) -> i   


(** It should be safe to replace Pervasives[], 
    we should test cases  like module aliases if it is serializable or not 
    {[ module Pervasives = List ]} 
*)
let serializable_signature (x : Types.signature_item) =
  match x with 
  | Sig_value(_, {val_kind = Val_prim _}) -> false
  | Sig_typext _ 
  | Sig_module _
  | Sig_class _ 
  | Sig_value _ -> true
  | Sig_modtype _ | Sig_class_type _ | Sig_type _ -> false



let filter_serializable_signatures signature  : t  = 
  List.filter serializable_signature signature

(* Input path is a global module 
    TODO: it should be fine for local module
*)
let find_serializable_signatures_by_path v (env : Env.t) 
  : t option = 
  match Env.find_module (Pident v) env with 
  | exception Not_found -> None 
  | {md_type = Mty_signature signature; _} -> 
    Some (filter_serializable_signatures signature)
  (** TODO: refine *)
  | _ -> Ext_log.err __LOC__  "@[impossible path %s@]@."
           (Ident.name v) ; assert false 

let rec dump_summary fmt (x : Env.summary) = 
  match x with 
  | Env_empty -> ()
  | Env_value(s,id,value_description) -> 
    dump_summary fmt s ;
    Printtyp.value_description id fmt value_description
  | _ -> ()

(** Used in [ Lglobal_module] *)
let get_name  (serializable_sigs : t) (pos : int) = 
  Ident.name 
    (name_of_signature_item 
      (match Ext_list.nth_opt  serializable_sigs  pos with Some x -> x 
      | None -> assert false))

let map (f : string -> 'a ) (xs : t) = 
  Ext_list.map xs 
    (fun x -> f (name_of_signature_item x ).name )






end
module Translattribute : sig 
#1 "translattribute.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                      Pierre Chambart, OCamlPro                         *)
(*                                                                        *)
(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

val check_attribute
   : Typedtree.expression
  -> string Location.loc * _
  -> unit

val check_attribute_on_module
   : Typedtree.module_expr
  -> string Location.loc * _
  -> unit

val add_inline_attribute
   : Lambda.lambda
  -> Location.t
  -> Parsetree.attributes
  -> Lambda.lambda

val get_inline_attribute
   : Parsetree.attributes
  -> Lambda.inline_attribute

val add_specialise_attribute
   : Lambda.lambda
  -> Location.t
  -> Parsetree.attributes
  -> Lambda.lambda

val get_specialise_attribute
   : Parsetree.attributes
  -> Lambda.specialise_attribute

val get_and_remove_inlined_attribute
   : Typedtree.expression
  -> Lambda.inline_attribute * Typedtree.expression

val get_and_remove_inlined_attribute_on_module
   : Typedtree.module_expr
  -> Lambda.inline_attribute * Typedtree.module_expr

val get_and_remove_specialised_attribute
   : Typedtree.expression
  -> Lambda.specialise_attribute * Typedtree.expression

val get_tailcall_attribute
   : Typedtree.expression
  -> bool * Typedtree.expression

end = struct
#1 "translattribute.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                      Pierre Chambart, OCamlPro                         *)
(*                                                                        *)
(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Typedtree
open Lambda
open Location

let is_inline_attribute = function
  | {txt=("inline"|"ocaml.inline")}, _ -> true
  | _ -> false

let is_inlined_attribute = function
  | {txt=("inlined"|"ocaml.inlined")}, _ -> true
  | {txt=("unrolled"|"ocaml.unrolled")}, _ when Config.flambda -> true
  | _ -> false

let is_specialise_attribute = function
  | {txt=("specialise"|"ocaml.specialise")}, _ when Config.flambda -> true
  | _ -> false

let is_specialised_attribute = function
  | {txt=("specialised"|"ocaml.specialised")}, _ when Config.flambda -> true
  | _ -> false

let find_attribute p attributes =
  let inline_attribute, other_attributes =
    List.partition p attributes
  in
  let attr =
    match inline_attribute with
    | [] -> None
    | [attr] -> Some attr
    | _ :: ({txt;loc}, _) :: _ ->
      Location.prerr_warning loc (Warnings.Duplicated_attribute txt);
      None
  in
  attr, other_attributes

let is_unrolled = function
  | {txt="unrolled"|"ocaml.unrolled"} -> true
  | {txt="inline"|"ocaml.inline"|"inlined"|"ocaml.inlined"} -> false
  | _ -> assert false

let parse_inline_attribute attr =
  match attr with
  | None -> Default_inline
  | Some ({txt;loc} as id, payload) ->
    let open Parsetree in
    if is_unrolled id then begin
      (* the 'unrolled' attributes must be used as [@unrolled n]. *)
      let warning txt = Warnings.Attribute_payload
          (txt, "It must be an integer literal")
      in
      match payload with
      | PStr [{pstr_desc = Pstr_eval ({pexp_desc},[])}] -> begin
          match pexp_desc with
          | Pexp_constant (Pconst_integer(s, None)) -> begin
              try
                Unroll (Misc.Int_literal_converter.int s)
              with Failure _ ->
                Location.prerr_warning loc (warning txt);
                Default_inline
            end
          | _ ->
            Location.prerr_warning loc (warning txt);
            Default_inline
        end
      | _ ->
        Location.prerr_warning loc (warning txt);
        Default_inline
    end else begin
      (* the 'inline' and 'inlined' attributes can be used as
         [@inline], [@inline never] or [@inline always].
         [@inline] is equivalent to [@inline always] *)
      let warning txt =
        Warnings.Attribute_payload
          (txt, "It must be either empty, 'always' or 'never'")
      in
      match payload with
      | PStr [] -> Always_inline
      | PStr [{pstr_desc = Pstr_eval ({pexp_desc},[])}] -> begin
          match pexp_desc with
          | Pexp_ident { txt = Longident.Lident "never" } ->
            Never_inline
          | Pexp_ident { txt = Longident.Lident "always" } ->
            Always_inline
          | _ ->
            Location.prerr_warning loc (warning txt);
            Default_inline
        end
      | _ ->
        Location.prerr_warning loc (warning txt);
        Default_inline
    end

let parse_specialise_attribute attr =
  match attr with
  | None -> Default_specialise
  | Some ({txt; loc}, payload) ->
    let open Parsetree in
    let warning txt =
      Warnings.Attribute_payload
      (txt, "It must be either empty, 'always' or 'never'")
    in
    match payload with
    | PStr [] -> Always_specialise
    | PStr [{pstr_desc = Pstr_eval ({pexp_desc},[])}] -> begin
        (* the 'specialise' and 'specialised' attributes can be used as
           [@specialise], [@specialise never] or [@specialise always].
           [@specialise] is equivalent to [@specialise always] *)
        match pexp_desc with
        | Pexp_ident { txt = Longident.Lident "never" } ->
          Never_specialise
        | Pexp_ident { txt = Longident.Lident "always" } ->
          Always_specialise
        | _ ->
          Location.prerr_warning loc (warning txt);
          Default_specialise
      end
    | _ ->
      Location.prerr_warning loc (warning txt);
      Default_specialise

let get_inline_attribute l =
  let attr, _ = find_attribute is_inline_attribute l in
  parse_inline_attribute attr

let get_specialise_attribute l =
  let attr, _ = find_attribute is_specialise_attribute l in
  parse_specialise_attribute attr

let add_inline_attribute expr loc attributes =
  match expr, get_inline_attribute attributes with
  | expr, Default_inline -> expr
  | Lfunction({ attr = { stub = false } as attr } as funct), inline ->
      begin match attr.inline with
      | Default_inline -> ()
      | Always_inline | Never_inline | Unroll _ ->
          Location.prerr_warning loc
            (Warnings.Duplicated_attribute "inline")
      end;
      let attr = { attr with inline } in
      Lfunction { funct with attr = attr }
  | expr, (Always_inline | Never_inline | Unroll _) ->
      Location.prerr_warning loc
        (Warnings.Misplaced_attribute "inline");
      expr

let add_specialise_attribute expr loc attributes =
  match expr, get_specialise_attribute attributes with
  | expr, Default_specialise -> expr
  | Lfunction({ attr = { stub = false } as attr } as funct), specialise ->
      begin match attr.specialise with
      | Default_specialise -> ()
      | Always_specialise | Never_specialise ->
          Location.prerr_warning loc
            (Warnings.Duplicated_attribute "specialise")
      end;
      let attr = { attr with specialise } in
      Lfunction { funct with attr }
  | expr, (Always_specialise | Never_specialise) ->
      Location.prerr_warning loc
        (Warnings.Misplaced_attribute "specialise");
      expr

(* Get the [@inlined] attribute payload (or default if not present).
   It also returns the expression without this attribute. This is
   used to ensure that this attribute is not misplaced: If it
   appears on any expression, it is an error, otherwise it would
   have been removed by this function *)
let get_and_remove_inlined_attribute e =
  let attr, exp_attributes =
    find_attribute is_inlined_attribute e.exp_attributes
  in
  let inlined = parse_inline_attribute attr in
  inlined, { e with exp_attributes }

let get_and_remove_inlined_attribute_on_module e =
  let attr, mod_attributes =
    find_attribute is_inlined_attribute e.mod_attributes
  in
  let inlined = parse_inline_attribute attr in
  inlined, { e with mod_attributes }

let get_and_remove_specialised_attribute e =
  let attr, exp_attributes =
    find_attribute is_specialised_attribute e.exp_attributes
  in
  let specialised = parse_specialise_attribute attr in
  specialised, { e with exp_attributes }

(* It also removes the attribute from the expression, like
   get_inlined_attribute *)
let get_tailcall_attribute e =
  let is_tailcall_attribute = function
    | {txt=("tailcall"|"ocaml.tailcall")}, _ -> true
    | _ -> false
  in
  let tailcalls, exp_attributes =
    List.partition is_tailcall_attribute e.exp_attributes
  in
  match tailcalls with
  | [] -> false, e
  | _ :: r ->
      begin match r with
      | [] -> ()
      | ({txt;loc}, _) :: _ ->
          Location.prerr_warning loc (Warnings.Duplicated_attribute txt)
      end;
      true, { e with exp_attributes }

let check_attribute e ({ txt; loc }, _) =
  match txt with
  | "inline" | "ocaml.inline"
  | "specialise" | "ocaml.specialise" -> begin
      match e.exp_desc with
      | Texp_function _ -> ()
      | _ ->
          Location.prerr_warning loc
            (Warnings.Misplaced_attribute txt)
    end
  | "inlined" | "ocaml.inlined"
  | "specialised" | "ocaml.specialised"
  | "tailcall" | "ocaml.tailcall" ->
      (* Removed by the Texp_apply cases *)
      Location.prerr_warning loc
        (Warnings.Misplaced_attribute txt)
  | _ -> ()

let check_attribute_on_module e ({ txt; loc }, _) =
  match txt with
  | "inline" | "ocaml.inline" ->  begin
      match e.mod_desc with
      | Tmod_functor _ -> ()
      | _ ->
          Location.prerr_warning loc
            (Warnings.Misplaced_attribute txt)
    end
  | "inlined" | "ocaml.inlined" ->
      (* Removed by the Texp_apply cases *)
      Location.prerr_warning loc
        (Warnings.Misplaced_attribute txt)
  | _ -> ()

end
module Printlambda : sig 
#1 "printlambda.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Lambda

open Format

val structured_constant: formatter -> structured_constant -> unit
val lambda: formatter -> lambda -> unit
val program: formatter -> program -> unit
val primitive: formatter -> primitive -> unit
val name_of_primitive : primitive -> string
val value_kind : value_kind -> string

end = struct
#1 "printlambda.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Format
open Asttypes
open Primitive
open Types
open Lambda


let rec struct_const ppf = function
  | Const_base(Const_int n) -> fprintf ppf "%i" n
  | Const_base(Const_char c) -> fprintf ppf "%C" c
  | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s
  | Const_immstring s -> fprintf ppf "#%S" s
  | Const_base(Const_float f) -> fprintf ppf "%s" f
  | Const_base(Const_int32 n) -> fprintf ppf "%lil" n
  | Const_base(Const_int64 n) -> fprintf ppf "%LiL" n
  | Const_base(Const_nativeint n) -> fprintf ppf "%nin" n
  | Const_pointer (n,_) -> fprintf ppf "%ia" n
  | Const_block(tag, _, []) ->
      fprintf ppf "[%i]" tag
  | Const_block(tag, _,sc1::scl) ->
      let sconsts ppf scl =
        List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl in
      fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl
  | Const_float_array [] ->
      fprintf ppf "[| |]"
  | Const_float_array (f1 :: fl) ->
      let floats ppf fl =
        List.iter (fun f -> fprintf ppf "@ %s" f) fl in
      fprintf ppf "@[<1>[|@[%s%a@]|]@]" f1 floats fl

let array_kind = function
  | Pgenarray -> "gen"
  | Paddrarray -> "addr"
  | Pintarray -> "int"
  | Pfloatarray -> "float"

let boxed_integer_name = function
  | Pnativeint -> "nativeint"
  | Pint32 -> "int32"
  | Pint64 -> "int64"

let value_kind = function
  | Pgenval -> ""
  | Pintval -> "[int]"
  | Pfloatval -> "[float]"
  | Pboxedintval bi -> Printf.sprintf "[%s]" (boxed_integer_name bi)

let field_kind = function
  | Pgenval -> "*"
  | Pintval -> "int"
  | Pfloatval -> "float"
  | Pboxedintval bi -> boxed_integer_name bi

let print_boxed_integer_conversion ppf bi1 bi2 =
  fprintf ppf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1)

let boxed_integer_mark name = function
  | Pnativeint -> Printf.sprintf "Nativeint.%s" name
  | Pint32 -> Printf.sprintf "Int32.%s" name
  | Pint64 -> Printf.sprintf "Int64.%s" name

let print_boxed_integer name ppf bi =
  fprintf ppf "%s" (boxed_integer_mark name bi);;

let print_bigarray name unsafe kind ppf layout =
  fprintf ppf "Bigarray.%s[%s,%s]"
    (if unsafe then "unsafe_"^ name else name)
    (match kind with
     | Pbigarray_unknown -> "generic"
     | Pbigarray_float32 -> "float32"
     | Pbigarray_float64 -> "float64"
     | Pbigarray_sint8 -> "sint8"
     | Pbigarray_uint8 -> "uint8"
     | Pbigarray_sint16 -> "sint16"
     | Pbigarray_uint16 -> "uint16"
     | Pbigarray_int32 -> "int32"
     | Pbigarray_int64 -> "int64"
     | Pbigarray_caml_int -> "camlint"
     | Pbigarray_native_int -> "nativeint"
     | Pbigarray_complex32 -> "complex32"
     | Pbigarray_complex64 -> "complex64")
    (match layout with
    |  Pbigarray_unknown_layout -> "unknown"
     | Pbigarray_c_layout -> "C"
     | Pbigarray_fortran_layout -> "Fortran")

let record_rep ppf r =
  match r with
  | Record_regular -> fprintf ppf "regular"
  | Record_inlined {tag = i} -> fprintf ppf "inlined(%i)" i
  | Record_unboxed false -> fprintf ppf "unboxed"
  | Record_unboxed true -> fprintf ppf "inlined(unboxed)"
  | Record_float -> fprintf ppf "float"
  | Record_extension -> fprintf ppf "ext"
;;

let string_of_loc_kind = function
  | Loc_FILE -> "loc_FILE"
  | Loc_LINE -> "loc_LINE"
  | Loc_MODULE -> "loc_MODULE"
  | Loc_POS -> "loc_POS"
  | Loc_LOC -> "loc_LOC"

let block_shape ppf shape = match shape with
  | None | Some [] -> ()
  | Some l when List.for_all ((=) Pgenval) l -> ()
  | Some [elt] ->
      Format.fprintf ppf " (%s)" (field_kind elt)
  | Some (h :: t) ->
      Format.fprintf ppf " (%s" (field_kind h);
      List.iter (fun elt ->
          Format.fprintf ppf ",%s" (field_kind elt))
        t;
      Format.fprintf ppf ")"

let primitive ppf = function
  | Pidentity -> fprintf ppf "id"
  | Pbytes_to_string -> fprintf ppf "bytes_to_string"
  | Pbytes_of_string -> fprintf ppf "bytes_of_string"
  | Pignore -> fprintf ppf "ignore"
  | Prevapply -> fprintf ppf "revapply"
  | Pdirapply -> fprintf ppf "dirapply"
  | Ploc kind -> fprintf ppf "%s" (string_of_loc_kind kind)
  | Pgetglobal id -> fprintf ppf "global %a" Ident.print id
  | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id
  | Pmakeblock(tag, _, Immutable, shape) ->
      fprintf ppf "makeblock %i%a" tag block_shape shape
  | Pmakeblock(tag, _, Mutable, shape) ->
      fprintf ppf "makemutable %i%a" tag block_shape shape
  | Pfield (n,_) -> fprintf ppf "field %i" n
  | Pfield_computed -> fprintf ppf "field_computed"
  | Psetfield(n, ptr, init, _) ->
      let instr =
        match ptr with
        | Pointer -> "ptr"
        | Immediate -> "imm"
      in
      let init =
        match init with
        | Heap_initialization -> "(heap-init)"
        | Root_initialization -> "(root-init)"
        | Assignment -> ""
      in
      fprintf ppf "setfield_%s%s %i" instr init n
  | Psetfield_computed (ptr, init) ->
      let instr =
        match ptr with
        | Pointer -> "ptr"
        | Immediate -> "imm"
      in
      let init =
        match init with
        | Heap_initialization -> "(heap-init)"
        | Root_initialization -> "(root-init)"
        | Assignment -> ""
      in
      fprintf ppf "setfield_%s%s_computed" instr init
  | Pfloatfield (n,_) -> fprintf ppf "floatfield %i" n
  | Psetfloatfield (n, init, _) ->
      let init =
        match init with
        | Heap_initialization -> "(heap-init)"
        | Root_initialization -> "(root-init)"
        | Assignment -> ""
      in
      fprintf ppf "setfloatfield%s %i" init n
  | Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size
  | Plazyforce -> fprintf ppf "force"
  | Pccall p -> fprintf ppf "%s" p.prim_name
  | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k)
  | Psequand -> fprintf ppf "&&"
  | Psequor -> fprintf ppf "||"
  | Pnot -> fprintf ppf "not"
  | Pnegint -> fprintf ppf "~"
  | Paddint -> fprintf ppf "+"
  | Psubint -> fprintf ppf "-"
  | Pmulint -> fprintf ppf "*"
  | Pdivint Safe -> fprintf ppf "/"
  | Pdivint Unsafe -> fprintf ppf "/u"
  | Pmodint Safe -> fprintf ppf "mod"
  | Pmodint Unsafe -> fprintf ppf "mod_unsafe"
  | Pandint -> fprintf ppf "and"
  | Porint -> fprintf ppf "or"
  | Pxorint -> fprintf ppf "xor"
  | Plslint -> fprintf ppf "lsl"
  | Plsrint -> fprintf ppf "lsr"
  | Pasrint -> fprintf ppf "asr"
  | Pintcomp(Ceq) -> fprintf ppf "=="
  | Pintcomp(Cneq) -> fprintf ppf "!="
  | Pintcomp(Clt) -> fprintf ppf "<"
  | Pintcomp(Cle) -> fprintf ppf "<="
  | Pintcomp(Cgt) -> fprintf ppf ">"
  | Pintcomp(Cge) -> fprintf ppf ">="
  | Poffsetint n -> fprintf ppf "%i+" n
  | Poffsetref n -> fprintf ppf "+:=%i"n
  | Pintoffloat -> fprintf ppf "int_of_float"
  | Pfloatofint -> fprintf ppf "float_of_int"
  | Pnegfloat -> fprintf ppf "~."
  | Pabsfloat -> fprintf ppf "abs."
  | Paddfloat -> fprintf ppf "+."
  | Psubfloat -> fprintf ppf "-."
  | Pmulfloat -> fprintf ppf "*."
  | Pdivfloat -> fprintf ppf "/."
  | Pfloatcomp(Ceq) -> fprintf ppf "==."
  | Pfloatcomp(Cneq) -> fprintf ppf "!=."
  | Pfloatcomp(Clt) -> fprintf ppf "<."
  | Pfloatcomp(Cle) -> fprintf ppf "<=."
  | Pfloatcomp(Cgt) -> fprintf ppf ">."
  | Pfloatcomp(Cge) -> fprintf ppf ">=."
  | Pstringlength -> fprintf ppf "string.length"
  | Pstringrefu -> fprintf ppf "string.unsafe_get"
  | Pstringrefs -> fprintf ppf "string.get"
  | Pbyteslength -> fprintf ppf "bytes.length"
  | Pbytesrefu -> fprintf ppf "bytes.unsafe_get"
  | Pbytessetu -> fprintf ppf "bytes.unsafe_set"
  | Pbytesrefs -> fprintf ppf "bytes.get"
  | Pbytessets -> fprintf ppf "bytes.set"

  | Parraylength k -> fprintf ppf "array.length[%s]" (array_kind k)
  | Pmakearray (k, Mutable) -> fprintf ppf "makearray[%s]" (array_kind k)
  | Pmakearray (k, Immutable) -> fprintf ppf "makearray_imm[%s]" (array_kind k)
  | Pduparray (k, Mutable) -> fprintf ppf "duparray[%s]" (array_kind k)
  | Pduparray (k, Immutable) -> fprintf ppf "duparray_imm[%s]" (array_kind k)
  | Parrayrefu k -> fprintf ppf "array.unsafe_get[%s]" (array_kind k)
  | Parraysetu k -> fprintf ppf "array.unsafe_set[%s]" (array_kind k)
  | Parrayrefs k -> fprintf ppf "array.get[%s]" (array_kind k)
  | Parraysets k -> fprintf ppf "array.set[%s]" (array_kind k)
  | Pctconst c ->
     let const_name = match c with
       | Big_endian -> "big_endian"
       | Word_size -> "word_size"
       | Int_size -> "int_size"
       | Max_wosize -> "max_wosize"
       | Ostype_unix -> "ostype_unix"
       | Ostype_win32 -> "ostype_win32"
       | Ostype_cygwin -> "ostype_cygwin"
       | Backend_type -> "backend_type" in
     fprintf ppf "sys.constant_%s" const_name
  | Pisint -> fprintf ppf "isint"
  | Pisout -> fprintf ppf "isout"
  | Pbittest -> fprintf ppf "testbit"
  | Pbintofint bi -> print_boxed_integer "of_int" ppf bi
  | Pintofbint bi -> print_boxed_integer "to_int" ppf bi
  | Pcvtbint (bi1, bi2) -> print_boxed_integer_conversion ppf bi1 bi2
  | Pnegbint bi -> print_boxed_integer "neg" ppf bi
  | Paddbint bi -> print_boxed_integer "add" ppf bi
  | Psubbint bi -> print_boxed_integer "sub" ppf bi
  | Pmulbint bi -> print_boxed_integer "mul" ppf bi
  | Pdivbint { size = bi; is_safe = Safe } ->
      print_boxed_integer "div" ppf bi
  | Pdivbint { size = bi; is_safe = Unsafe } ->
      print_boxed_integer "div_unsafe" ppf bi
  | Pmodbint { size = bi; is_safe = Safe } ->
      print_boxed_integer "mod" ppf bi
  | Pmodbint { size = bi; is_safe = Unsafe } ->
      print_boxed_integer "mod_unsafe" ppf bi
  | Pandbint bi -> print_boxed_integer "and" ppf bi
  | Porbint bi -> print_boxed_integer "or" ppf bi
  | Pxorbint bi -> print_boxed_integer "xor" ppf bi
  | Plslbint bi -> print_boxed_integer "lsl" ppf bi
  | Plsrbint bi -> print_boxed_integer "lsr" ppf bi
  | Pasrbint bi -> print_boxed_integer "asr" ppf bi
  | Pbintcomp(bi, Ceq) -> print_boxed_integer "==" ppf bi
  | Pbintcomp(bi, Cneq) -> print_boxed_integer "!=" ppf bi
  | Pbintcomp(bi, Clt) -> print_boxed_integer "<" ppf bi
  | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi
  | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi
  | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi
  | Pbigarrayref(unsafe, _n, kind, layout) ->
      print_bigarray "get" unsafe kind ppf layout
  | Pbigarrayset(unsafe, _n, kind, layout) ->
      print_bigarray "set" unsafe kind ppf layout
  | Pbigarraydim(n) -> fprintf ppf "Bigarray.dim_%i" n
  | Pstring_load_16(unsafe) ->
     if unsafe then fprintf ppf "string.unsafe_get16"
     else fprintf ppf "string.get16"
  | Pstring_load_32(unsafe) ->
     if unsafe then fprintf ppf "string.unsafe_get32"
     else fprintf ppf "string.get32"
  | Pstring_load_64(unsafe) ->
     if unsafe then fprintf ppf "string.unsafe_get64"
     else fprintf ppf "string.get64"
  | Pstring_set_16(unsafe) ->
     if unsafe then fprintf ppf "string.unsafe_set16"
     else fprintf ppf "string.set16"
  | Pstring_set_32(unsafe) ->
     if unsafe then fprintf ppf "string.unsafe_set32"
     else fprintf ppf "string.set32"
  | Pstring_set_64(unsafe) ->
     if unsafe then fprintf ppf "string.unsafe_set64"
     else fprintf ppf "string.set64"
  | Pbigstring_load_16(unsafe) ->
     if unsafe then fprintf ppf "bigarray.array1.unsafe_get16"
     else fprintf ppf "bigarray.array1.get16"
  | Pbigstring_load_32(unsafe) ->
     if unsafe then fprintf ppf "bigarray.array1.unsafe_get32"
     else fprintf ppf "bigarray.array1.get32"
  | Pbigstring_load_64(unsafe) ->
     if unsafe then fprintf ppf "bigarray.array1.unsafe_get64"
     else fprintf ppf "bigarray.array1.get64"
  | Pbigstring_set_16(unsafe) ->
     if unsafe then fprintf ppf "bigarray.array1.unsafe_set16"
     else fprintf ppf "bigarray.array1.set16"
  | Pbigstring_set_32(unsafe) ->
     if unsafe then fprintf ppf "bigarray.array1.unsafe_set32"
     else fprintf ppf "bigarray.array1.set32"
  | Pbigstring_set_64(unsafe) ->
     if unsafe then fprintf ppf "bigarray.array1.unsafe_set64"
     else fprintf ppf "bigarray.array1.set64"
  | Pbswap16 -> fprintf ppf "bswap16"
  | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi
  | Pint_as_pointer -> fprintf ppf "int_as_pointer"
  | Popaque -> fprintf ppf "opaque"

let name_of_primitive = function
  | Pidentity -> "Pidentity"
  | Pbytes_of_string -> "Pbytes_of_string"
  | Pbytes_to_string -> "Pbytes_to_string"
  | Pignore -> "Pignore"
  | Prevapply -> "Prevapply"
  | Pdirapply -> "Pdirapply"
  | Ploc _ -> "Ploc"
  | Pgetglobal _ -> "Pgetglobal"
  | Psetglobal _ -> "Psetglobal"
  | Pmakeblock _ -> "Pmakeblock"
  | Pfield _ -> "Pfield"
  | Pfield_computed -> "Pfield_computed"
  | Psetfield _ -> "Psetfield"
  | Psetfield_computed _ -> "Psetfield_computed"
  | Pfloatfield _ -> "Pfloatfield"
  | Psetfloatfield _ -> "Psetfloatfield"
  | Pduprecord _ -> "Pduprecord"
  | Plazyforce -> "Plazyforce"
  | Pccall _ -> "Pccall"
  | Praise _ -> "Praise"
  | Psequand -> "Psequand"
  | Psequor -> "Psequor"
  | Pnot -> "Pnot"
  | Pnegint -> "Pnegint"
  | Paddint -> "Paddint"
  | Psubint -> "Psubint"
  | Pmulint -> "Pmulint"
  | Pdivint _ -> "Pdivint"
  | Pmodint _ -> "Pmodint"
  | Pandint -> "Pandint"
  | Porint -> "Porint"
  | Pxorint -> "Pxorint"
  | Plslint -> "Plslint"
  | Plsrint -> "Plsrint"
  | Pasrint -> "Pasrint"
  | Pintcomp _ -> "Pintcomp"
  | Poffsetint _ -> "Poffsetint"
  | Poffsetref _ -> "Poffsetref"
  | Pintoffloat -> "Pintoffloat"
  | Pfloatofint -> "Pfloatofint"
  | Pnegfloat -> "Pnegfloat"
  | Pabsfloat -> "Pabsfloat"
  | Paddfloat -> "Paddfloat"
  | Psubfloat -> "Psubfloat"
  | Pmulfloat -> "Pmulfloat"
  | Pdivfloat -> "Pdivfloat"
  | Pfloatcomp _ -> "Pfloatcomp"
  | Pstringlength -> "Pstringlength"
  | Pstringrefu -> "Pstringrefu"
  | Pstringrefs -> "Pstringrefs"
  | Pbyteslength -> "Pbyteslength"
  | Pbytesrefu -> "Pbytesrefu"
  | Pbytessetu -> "Pbytessetu"
  | Pbytesrefs -> "Pbytesrefs"
  | Pbytessets -> "Pbytessets"
  | Parraylength _ -> "Parraylength"
  | Pmakearray _ -> "Pmakearray"
  | Pduparray _ -> "Pduparray"
  | Parrayrefu _ -> "Parrayrefu"
  | Parraysetu _ -> "Parraysetu"
  | Parrayrefs _ -> "Parrayrefs"
  | Parraysets _ -> "Parraysets"
  | Pctconst _ -> "Pctconst"
  | Pisint -> "Pisint"
  | Pisout -> "Pisout"
  | Pbittest -> "Pbittest"
  | Pbintofint _ -> "Pbintofint"
  | Pintofbint _ -> "Pintofbint"
  | Pcvtbint _ -> "Pcvtbint"
  | Pnegbint _ -> "Pnegbint"
  | Paddbint _ -> "Paddbint"
  | Psubbint _ -> "Psubbint"
  | Pmulbint _ -> "Pmulbint"
  | Pdivbint _ -> "Pdivbint"
  | Pmodbint _ -> "Pmodbint"
  | Pandbint _ -> "Pandbint"
  | Porbint _ -> "Porbint"
  | Pxorbint _ -> "Pxorbint"
  | Plslbint _ -> "Plslbint"
  | Plsrbint _ -> "Plsrbint"
  | Pasrbint _ -> "Pasrbint"
  | Pbintcomp _ -> "Pbintcomp"
  | Pbigarrayref _ -> "Pbigarrayref"
  | Pbigarrayset _ -> "Pbigarrayset"
  | Pbigarraydim _ -> "Pbigarraydim"
  | Pstring_load_16 _ -> "Pstring_load_16"
  | Pstring_load_32 _ -> "Pstring_load_32"
  | Pstring_load_64 _ -> "Pstring_load_64"
  | Pstring_set_16 _ -> "Pstring_set_16"
  | Pstring_set_32 _ -> "Pstring_set_32"
  | Pstring_set_64 _ -> "Pstring_set_64"
  | Pbigstring_load_16 _ -> "Pbigstring_load_16"
  | Pbigstring_load_32 _ -> "Pbigstring_load_32"
  | Pbigstring_load_64 _ -> "Pbigstring_load_64"
  | Pbigstring_set_16 _ -> "Pbigstring_set_16"
  | Pbigstring_set_32 _ -> "Pbigstring_set_32"
  | Pbigstring_set_64 _ -> "Pbigstring_set_64"
  | Pbswap16 -> "Pbswap16"
  | Pbbswap _ -> "Pbbswap"
  | Pint_as_pointer -> "Pint_as_pointer"
  | Popaque -> "Popaque"

let function_attribute ppf { inline; specialise; is_a_functor; stub } =
  if is_a_functor then
    fprintf ppf "is_a_functor@ ";
  if stub then
    fprintf ppf "stub@ ";
  begin match inline with
  | Default_inline -> ()
  | Always_inline -> fprintf ppf "always_inline@ "
  | Never_inline -> fprintf ppf "never_inline@ "
  | Unroll i -> fprintf ppf "unroll(%i)@ " i
  end;
  begin match specialise with
  | Default_specialise -> ()
  | Always_specialise -> fprintf ppf "always_specialise@ "
  | Never_specialise -> fprintf ppf "never_specialise@ "
  end

let apply_tailcall_attribute ppf tailcall =
  if tailcall then
    fprintf ppf " @@tailcall"

let apply_inlined_attribute ppf = function
  | Default_inline -> ()
  | Always_inline -> fprintf ppf " always_inline"
  | Never_inline -> fprintf ppf " never_inline"
  | Unroll i -> fprintf ppf " never_inline(%i)" i

let apply_specialised_attribute ppf = function
  | Default_specialise -> ()
  | Always_specialise -> fprintf ppf " always_specialise"
  | Never_specialise -> fprintf ppf " never_specialise"

let rec lam ppf = function
  | Lvar id ->
      Ident.print ppf id
  | Lconst cst ->
      struct_const ppf cst
  | Lapply ap ->
      let lams ppf largs =
        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
      fprintf ppf "@[<2>(apply@ %a%a%a%a%a)@]" lam ap.ap_func lams ap.ap_args
        apply_tailcall_attribute ap.ap_should_be_tailcall
        apply_inlined_attribute ap.ap_inlined
        apply_specialised_attribute ap.ap_specialised
  | Lfunction{kind; params; body; attr} ->
      let pr_params ppf params =
        match kind with
        | Curried ->
            List.iter (fun param -> fprintf ppf "@ %a" Ident.print param) params
        | Tupled ->
            fprintf ppf " (";
            let first = ref true in
            List.iter
              (fun param ->
                if !first then first := false else fprintf ppf ",@ ";
                Ident.print ppf param)
              params;
            fprintf ppf ")" in
      fprintf ppf "@[<2>(function%a@ %a%a)@]" pr_params params
        function_attribute attr lam body
  | Llet(str, k, id, arg, body) ->
      let kind = function
          Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v"
      in
      let rec letbody = function
        | Llet(str, k, id, arg, body) ->
            fprintf ppf "@ @[<2>%a =%s%s@ %a@]"
              Ident.print id (kind str) (value_kind k) lam arg;
            letbody body
        | expr -> expr in
      fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a =%s%s@ %a@]"
        Ident.print id (kind str) (value_kind k) lam arg;
      let expr = letbody body in
      fprintf ppf ")@]@ %a)@]" lam expr
  | Lletrec(id_arg_list, body) ->
      let bindings ppf id_arg_list =
        let spc = ref false in
        List.iter
          (fun (id, l) ->
            if !spc then fprintf ppf "@ " else spc := true;
            fprintf ppf "@[<2>%a@ %a@]" Ident.print id lam l)
          id_arg_list in
      fprintf ppf
        "@[<2>(letrec@ (@[<hv 1>%a@])@ %a)@]" bindings id_arg_list lam body
  | Lprim(prim, largs, _) ->
      let lams ppf largs =
        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
      fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs
  | Lswitch(larg, sw, _loc) ->
      let switch ppf sw =
        let spc = ref false in
        List.iter
         (fun (n, l) ->
           if !spc then fprintf ppf "@ " else spc := true;
           fprintf ppf "@[<hv 1>case int %i:@ %a@]" n lam l)
         sw.sw_consts;
        List.iter
          (fun (n, l) ->
            if !spc then fprintf ppf "@ " else spc := true;
            fprintf ppf "@[<hv 1>case tag %i:@ %a@]" n lam l)
          sw.sw_blocks ;
        begin match sw.sw_failaction with
        | None  -> ()
        | Some l ->
            if !spc then fprintf ppf "@ " else spc := true;
            fprintf ppf "@[<hv 1>default:@ %a@]" lam l
        end in
      fprintf ppf
       "@[<1>(%s %a@ @[<v 0>%a@])@]"
       (match sw.sw_failaction with None -> "switch*" | _ -> "switch")
       lam larg switch sw
  | Lstringswitch(arg, cases, default, _) ->
      let switch ppf cases =
        let spc = ref false in
        List.iter
         (fun (s, l) ->
           if !spc then fprintf ppf "@ " else spc := true;
           fprintf ppf "@[<hv 1>case \"%s\":@ %a@]" (String.escaped s) lam l)
          cases;
        begin match default with
        | Some default ->
            if !spc then fprintf ppf "@ " else spc := true;
            fprintf ppf "@[<hv 1>default:@ %a@]" lam default
        | None -> ()
        end in
      fprintf ppf
       "@[<1>(stringswitch %a@ @[<v 0>%a@])@]" lam arg switch cases
  | Lstaticraise (i, ls)  ->
      let lams ppf largs =
        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
      fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls;
  | Lstaticcatch(lbody, (i, vars), lhandler) ->
      fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]"
        lam lbody i
        (fun ppf vars -> match vars with
          | [] -> ()
          | _ ->
              List.iter
                (fun x -> fprintf ppf " %a" Ident.print x)
                vars)
        vars
        lam lhandler
  | Ltrywith(lbody, param, lhandler) ->
      fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]"
        lam lbody Ident.print param lam lhandler
  | Lifthenelse(lcond, lif, lelse) ->
      fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse
  | Lsequence(l1, l2) ->
      fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2
  | Lwhile(lcond, lbody) ->
      fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody
  | Lfor(param, lo, hi, dir, body) ->
      fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]"
       Ident.print param lam lo
       (match dir with Upto -> "to" | Downto -> "downto")
       lam hi lam body
  | Lassign(id, expr) ->
      fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr
  | Lsend (k, met, obj, largs, _) ->
      let args ppf largs =
        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
      let kind =
        if k = Self then "self" else if k = Cached then "cache" else "" in
      fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs
  | Levent(expr, ev) ->
      let kind =
       match ev.lev_kind with
       | Lev_before -> "before"
       | Lev_after _  -> "after"
       | Lev_function -> "funct-body"
       | Lev_pseudo -> "pseudo"
       | Lev_module_definition ident ->
         Format.asprintf "module-defn(%a)" Ident.print ident
      in
      fprintf ppf "@[<2>(%s %s(%i)%s:%i-%i@ %a)@]" kind
              ev.lev_loc.Location.loc_start.Lexing.pos_fname
              ev.lev_loc.Location.loc_start.Lexing.pos_lnum
              (if ev.lev_loc.Location.loc_ghost then "<ghost>" else "")
              ev.lev_loc.Location.loc_start.Lexing.pos_cnum
              ev.lev_loc.Location.loc_end.Lexing.pos_cnum
              lam expr
  | Lifused(id, expr) ->
      fprintf ppf "@[<2>(ifused@ %a@ %a)@]" Ident.print id lam expr

and sequence ppf = function
  | Lsequence(l1, l2) ->
      fprintf ppf "%a@ %a" sequence l1 sequence l2
  | l ->
      lam ppf l

let structured_constant = struct_const

let lambda = lam

let program ppf { code } = lambda ppf code

end
module Switch : sig 
#1 "switch.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Luc Maranget, projet Moscova, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 2000 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(*
  This module transforms generic switches in combinations
  of if tests and switches.
*)

(* For detecting action sharing, object style *)

(* Store for actions in object style:
  act_store : store an action, returns index in table
              In case an action with equal key exists, returns index
              of the stored action. Otherwise add entry in table.
  act_store_shared : This stored action will always be shared.
  act_get   : retrieve table
  act_get_shared : retrieve table, with sharing explicit
*)

type 'a shared = Shared of 'a | Single of 'a

type 'a t_store =
    {act_get : unit -> 'a array ;
     act_get_shared : unit -> 'a shared array ;
     act_store : 'a -> int ;
     act_store_shared : 'a -> int ; }

exception Not_simple

module type Stored = sig
  type t
  type key
  val compare_key : key -> key -> int
  val make_key : t -> key option
end

module Store(A:Stored) :
    sig
      val mk_store : unit -> A.t t_store
    end

(* Arguments to the Make functor *)
module type S =
  sig
    (* type of basic tests *)
    type primitive
    (* basic tests themselves *)
    val eqint : primitive
    val neint : primitive
    val leint : primitive
    val ltint : primitive
    val geint : primitive
    val gtint : primitive
    (* type of actions *)
    type act

    (* Various constructors, for making a binder,
        adding one integer, etc. *)
    val bind : act -> (act -> act) -> act
    val make_const : int -> act
    val make_offset : act -> int -> act
    val make_prim : primitive -> act list -> act
    val make_isout : act -> act -> act
    val make_isin : act -> act -> act
    val make_if : act -> act -> act -> act
   (* construct an actual switch :
      make_switch arg cases acts
      NB:  cases is in the value form *)
    val make_switch :
        Location.t -> act -> int array -> act array -> act
   (* Build last minute sharing of action stuff *)
   val make_catch : act -> int * (act -> act)
   val make_exit : int -> act

  end


(*
  Make.zyva arg low high cases actions where
    - arg is the argument of the switch.
    - low, high are the interval limits.
    - cases is a list of sub-interval and action indices
    - actions is an array of actions.

  All these arguments specify a switch construct and zyva
  returns an action that performs the switch.
*)
module Make :
  functor (Arg : S) ->
    sig
(* Standard entry point, sharing is tracked *)
      val zyva :
          Location.t ->
          (int * int) ->
           Arg.act ->
           (int * int * int) array ->
           Arg.act t_store ->
           Arg.act

(* Output test sequence, sharing tracked *)
     val test_sequence :
           Arg.act ->
           (int * int * int) array ->
           Arg.act t_store ->
           Arg.act
    end

end = struct
#1 "switch.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Luc Maranget, projet Moscova, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 2000 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)


type 'a shared = Shared of 'a | Single of 'a

type 'a t_store =
    {act_get : unit -> 'a array ;
     act_get_shared : unit -> 'a shared array ;
     act_store : 'a -> int ;
     act_store_shared : 'a -> int ; }

exception Not_simple

module type Stored = sig
  type t
  type key
  val compare_key : key -> key -> int
  val make_key : t -> key option
end

module Store(A:Stored) = struct
  module AMap =
    Map.Make(struct type t = A.key let compare = A.compare_key end)

  type intern =
      { mutable map : (bool * int)  AMap.t ;
        mutable next : int ;
        mutable acts : (bool * A.t) list; }

  let mk_store () =
    let st =
      { map = AMap.empty ;
        next = 0 ;
        acts = [] ; } in

    let add mustshare act =
      let i = st.next in
      st.acts <- (mustshare,act) :: st.acts ;
      st.next <- i+1 ;
      i in

    let store mustshare act = match A.make_key act with
    | Some key ->
        begin try
          let (shared,i) = AMap.find key st.map in
          if not shared then st.map <- AMap.add key (true,i) st.map ;
          i
        with Not_found ->
          let i = add mustshare act in
          st.map <- AMap.add key (mustshare,i) st.map ;
          i
        end
    | None ->
        add mustshare act

    and get () = Array.of_list (List.rev_map (fun (_,act) -> act) st.acts)

    and get_shared () =
      let acts =
        Array.of_list
          (List.rev_map
             (fun (shared,act) ->
               if shared then Shared act else Single act)
             st.acts) in
      AMap.iter
        (fun _ (shared,i) ->
          if shared then match acts.(i) with
          | Single act -> acts.(i) <- Shared act
          | Shared _ -> ())
        st.map ;
      acts in
    {act_store = store false ; act_store_shared = store true ;
     act_get = get; act_get_shared = get_shared; }
end



module type S =
 sig
   type primitive
   val eqint : primitive
   val neint : primitive
   val leint : primitive
   val ltint : primitive
   val geint : primitive
   val gtint : primitive
   type act

   val bind : act -> (act -> act) -> act
   val make_const : int -> act
   val make_offset : act -> int -> act
   val make_prim : primitive -> act list -> act
   val make_isout : act -> act -> act
   val make_isin : act -> act -> act
   val make_if : act -> act -> act -> act
   val make_switch : Location.t -> act -> int array -> act array -> act
   val make_catch : act -> int * (act -> act)
   val make_exit : int -> act
 end

(* The module will ``produce good code for the case statement'' *)
(*
  Adaptation of
   R.L. Berstein
   ``Producing good code for the case statement''
   Sofware Practice and Experience, 15(10) (1985)
 and
   D.L. Spuler
    ``Two-Way Comparison Search Trees, a Generalisation of Binary Search Trees
      and Split Trees''
    ``Compiler Code Generation for Multiway Branch Statement as
      a Static Search Problem''
   Technical Reports, James Cook University
*)
(*
  Main adaptation is considering interval tests
 (implemented as one addition + one unsigned test and branch)
  which leads to exhaustive search for finding the optimal
  test sequence in small cases and heuristics otherwise.
*)
module Make (Arg : S) =
  struct

    type 'a inter =
        {cases : (int * int * int) array ;
          actions : 'a array}

type 'a t_ctx =  {off : int ; arg : 'a}

let cut = ref 8
and more_cut = ref 16

(*
let pint chan i =
  if i = min_int then Printf.fprintf chan "-oo"
  else if i=max_int then Printf.fprintf chan "oo"
  else Printf.fprintf chan "%d" i

let pcases chan cases =
  for i =0 to Array.length cases-1 do
    let l,h,act = cases.(i) in
    if l=h then
      Printf.fprintf chan "%d:%d " l act
    else
      Printf.fprintf chan "%a..%a:%d " pint l pint h act
  done

let prerr_inter i = Printf.fprintf stderr
        "cases=%a" pcases i.cases
*)

let get_act cases i =
  let _,_,r = cases.(i) in
  r
and get_low cases i =
  let r,_,_ = cases.(i) in
  r

type ctests = {
    mutable n : int ;
    mutable ni : int ;
  }

let too_much = {n=max_int ; ni=max_int}

(*
let ptests chan {n=n ; ni=ni} =
  Printf.fprintf chan "{n=%d ; ni=%d}" n ni

let pta chan t =
  for i =0 to Array.length t-1 do
    Printf.fprintf chan "%d: %a\n" i ptests t.(i)
  done
*)

let less_tests c1 c2 =
  if c1.n < c2.n then
    true
  else if c1.n = c2.n then begin
    if c1.ni < c2.ni then
      true
    else
      false
  end else
    false

and eq_tests c1 c2 = c1.n = c2.n && c1.ni=c2.ni

let less2tests (c1,d1) (c2,d2) =
  if eq_tests c1 c2 then
    less_tests d1 d2
  else
    less_tests c1 c2

let add_test t1 t2 =
  t1.n <- t1.n + t2.n ;
  t1.ni <- t1.ni + t2.ni ;

type t_ret = Inter of int * int  | Sep of int | No

(*
let pret chan = function
  | Inter (i,j)-> Printf.fprintf chan "Inter %d %d" i j
  | Sep i -> Printf.fprintf chan "Sep %d" i
  | No -> Printf.fprintf chan "No"
*)

let coupe cases i =
  let l,_,_ = cases.(i) in
  l,
  Array.sub cases 0 i,
  Array.sub cases i (Array.length cases-i)


let case_append c1 c2 =
  let len1 = Array.length c1
  and len2 = Array.length c2 in
  match len1,len2 with
  | 0,_ -> c2
  | _,0 -> c1
  | _,_ ->
      let l1,h1,act1 = c1.(Array.length c1-1)
      and l2,h2,act2 = c2.(0) in
      if act1 = act2 then
        let r = Array.make (len1+len2-1) c1.(0) in
        for i = 0 to len1-2 do
          r.(i) <- c1.(i)
        done ;

        let l =
          if len1-2 >= 0 then begin
            let _,h,_ = r.(len1-2) in
            if h+1 < l1 then
              h+1
            else
              l1
          end else
            l1
        and h =
          if 1 < len2-1 then begin
            let l,_,_ = c2.(1) in
            if h2+1 < l then
              l-1
            else
              h2
          end else
            h2 in
        r.(len1-1) <- (l,h,act1) ;
        for i=1 to len2-1  do
          r.(len1-1+i) <- c2.(i)
        done ;
        r
      else if h1 > l1 then
        let r = Array.make (len1+len2) c1.(0) in
        for i = 0 to len1-2 do
          r.(i) <- c1.(i)
        done ;
        r.(len1-1) <- (l1,l2-1,act1) ;
        for i=0 to len2-1  do
          r.(len1+i) <- c2.(i)
        done ;
        r
      else if h2 > l2 then
        let r = Array.make (len1+len2) c1.(0) in
        for i = 0 to len1-1 do
          r.(i) <- c1.(i)
        done ;
        r.(len1) <- (h1+1,h2,act2) ;
        for i=1 to len2-1  do
          r.(len1+i) <- c2.(i)
        done ;
        r
      else
        Array.append c1 c2


let coupe_inter i j cases =
  let lcases = Array.length cases in
  let low,_,_ = cases.(i)
  and _,high,_ = cases.(j) in
  low,high,
  Array.sub cases i (j-i+1),
  case_append (Array.sub cases 0 i) (Array.sub cases (j+1) (lcases-(j+1)))

type kind = Kvalue of int | Kinter of int | Kempty

(*
let pkind chan = function
  | Kvalue i ->Printf.fprintf chan "V%d" i
  | Kinter i -> Printf.fprintf chan "I%d" i
  | Kempty -> Printf.fprintf chan "E"

let rec pkey chan  = function
  | [] -> ()
  | [k] -> pkind chan k
  | k::rem ->
      Printf.fprintf chan "%a %a" pkey rem pkind k
*)

let t = Hashtbl.create 17

let make_key  cases =
  let seen = ref []
  and count = ref 0 in
  let rec got_it act = function
    | [] ->
        seen := (act,!count):: !seen ;
        let r = !count in
        incr count ;
        r
    | (act0,index) :: rem ->
        if act0 = act then
          index
        else
          got_it act rem in

  let make_one l h act =
    if l=h then
      Kvalue (got_it act !seen)
    else
      Kinter (got_it act !seen) in

  let rec make_rec i pl =
    if i < 0 then
      []
    else
      let l,h,act = cases.(i) in
      if pl = h+1 then
        make_one l h act::make_rec (i-1) l
      else
        Kempty::make_one l h act::make_rec (i-1) l in

  let l,h,act = cases.(Array.length cases-1) in
  make_one l h act::make_rec (Array.length cases-2) l


    let same_act t =
      let len = Array.length t in
      let a = get_act t (len-1) in
      let rec do_rec i =
        if i < 0 then true
        else
          let b = get_act t i in
          b=a && do_rec (i-1) in
      do_rec (len-2)


(*
  Interval test x in [l,h] works by checking x-l in [0,h-l]
   * This may be false for arithmetic modulo 2^31
   * Subtracting l may change the relative ordering of values
     and invalid the invariant that matched values are given in
     increasing order

   To avoid this, interval check is allowed only when the
   integers indeed present in the whole case interval are
   in [-2^16 ; 2^16]

   This condition is checked by zyva
*)

let inter_limit = 1 lsl 16

let ok_inter = ref false

let rec opt_count top cases =
  let key = make_key cases in
  try
    Hashtbl.find t key
  with
  | Not_found ->
      let r =
        let lcases = Array.length cases in
        match lcases with
        | 0 -> assert false
        | _ when same_act cases -> No, ({n=0; ni=0},{n=0; ni=0})
        | _ ->
            if lcases < !cut then
              enum top cases
            else if lcases < !more_cut then
              heuristic cases
            else
              divide cases in
      Hashtbl.add t key r ;
      r

and divide cases =
  let lcases = Array.length cases in
  let m = lcases/2 in
  let _,left,right = coupe cases m in
  let ci = {n=1 ; ni=0}
  and cm = {n=1 ; ni=0}
  and _,(cml,cleft) = opt_count false left
  and _,(cmr,cright) = opt_count false right in
  add_test ci cleft ;
  add_test ci cright ;
  if less_tests cml cmr then
    add_test cm cmr
  else
    add_test cm cml ;
  Sep m,(cm, ci)

and heuristic cases =
  let lcases = Array.length cases in

  let sep,csep = divide cases

  and inter,cinter =
    if !ok_inter then begin
      let _,_,act0 = cases.(0)
      and _,_,act1 = cases.(lcases-1) in
      if act0 = act1 then begin
        let low, high, inside, outside = coupe_inter 1 (lcases-2) cases in
        let _,(cmi,cinside) = opt_count false inside
        and _,(cmo,coutside) = opt_count false outside
        and cmij = {n=1 ; ni=(if low=high then 0 else 1)}
        and cij = {n=1 ; ni=(if low=high then 0 else 1)} in
        add_test cij cinside ;
        add_test cij coutside ;
        if less_tests cmi cmo then
          add_test cmij cmo
        else
          add_test cmij cmi ;
        Inter (1,lcases-2),(cmij,cij)
      end else
        Inter (-1,-1),(too_much, too_much)
    end else
      Inter (-1,-1),(too_much, too_much) in
  if less2tests csep cinter then
    sep,csep
  else
    inter,cinter


and enum top cases =
  let lcases = Array.length cases in
  let lim, with_sep =
    let best = ref (-1) and best_cost = ref (too_much,too_much) in

    for i = 1 to lcases-(1) do
      let _,left,right = coupe cases i in
      let ci = {n=1 ; ni=0}
      and cm = {n=1 ; ni=0}
      and _,(cml,cleft) = opt_count false left
      and _,(cmr,cright) = opt_count false right in
      add_test ci cleft ;
      add_test ci cright ;
      if less_tests cml cmr then
        add_test cm cmr
      else
        add_test cm cml ;

      if
        less2tests (cm,ci) !best_cost
      then begin
        if top then
          Printf.fprintf stderr "Get it: %d\n" i ;
        best := i ;
        best_cost := (cm,ci)
      end
    done ;
    !best, !best_cost in

  let ilow, ihigh, with_inter =
    if not !ok_inter then
      let rlow = ref (-1) and rhigh = ref (-1)
      and best_cost= ref (too_much,too_much) in
      for i=1 to lcases-2 do
        let low, high, inside, outside = coupe_inter i i cases in
         if low=high then begin
           let _,(cmi,cinside) = opt_count false inside
           and _,(cmo,coutside) = opt_count false outside
           and cmij = {n=1 ; ni=0}
           and cij = {n=1 ; ni=0} in
           add_test cij cinside ;
           add_test cij coutside ;
           if less_tests cmi cmo then
             add_test cmij cmo
           else
             add_test cmij cmi ;
           if less2tests (cmij,cij) !best_cost then begin
             rlow := i ;
             rhigh := i ;
             best_cost := (cmij,cij)
           end
         end
      done ;
      !rlow, !rhigh, !best_cost
    else
      let rlow = ref (-1) and rhigh = ref (-1)
      and best_cost= ref (too_much,too_much) in
      for i=1 to lcases-2 do
        for j=i to lcases-2 do
          let low, high, inside, outside = coupe_inter i j cases in
          let _,(cmi,cinside) = opt_count false inside
          and _,(cmo,coutside) = opt_count false outside
          and cmij = {n=1 ; ni=(if low=high then 0 else 1)}
          and cij = {n=1 ; ni=(if low=high then 0 else 1)} in
          add_test cij cinside ;
          add_test cij coutside ;
          if less_tests cmi cmo then
            add_test cmij cmo
          else
            add_test cmij cmi ;
          if less2tests (cmij,cij) !best_cost then begin
            rlow := i ;
            rhigh := j ;
            best_cost := (cmij,cij)
          end
        done
      done ;
      !rlow, !rhigh, !best_cost in
  let r = ref (Inter (ilow,ihigh)) and rc = ref with_inter in
  if less2tests with_sep !rc then begin
    r := Sep lim ; rc := with_sep
  end ;
  !r, !rc

    let make_if_test test arg i ifso ifnot =
      Arg.make_if
        (Arg.make_prim test [arg ; Arg.make_const i])
        ifso ifnot

    let make_if_lt arg i  ifso ifnot = match i with
    | 1 ->
        make_if_test Arg.leint arg 0 ifso ifnot
    | _ ->
        make_if_test Arg.ltint arg i ifso ifnot

    and make_if_ge arg i  ifso ifnot = match i with
    | 1 ->
        make_if_test Arg.gtint arg 0 ifso ifnot
    | _ ->
        make_if_test Arg.geint arg i ifso ifnot

    and make_if_eq  arg i ifso ifnot =
      make_if_test Arg.eqint arg i ifso ifnot

    and make_if_ne  arg i ifso ifnot =
      make_if_test Arg.neint arg i ifso ifnot

    let do_make_if_out h arg ifso ifno =
      Arg.make_if (Arg.make_isout h arg) ifso ifno

    let make_if_out ctx l d mk_ifso mk_ifno = match l with
    | 0 ->
        do_make_if_out
          (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx)
    | _ ->
        Arg.bind
          (Arg.make_offset ctx.arg (-l))
          (fun arg ->
            let ctx = {off= (-l+ctx.off) ; arg=arg} in
            do_make_if_out
              (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx))

    let do_make_if_in h arg ifso ifno =
      Arg.make_if (Arg.make_isin h arg) ifso ifno

    let make_if_in ctx l d mk_ifso mk_ifno = match l with
    | 0 ->
        do_make_if_in
          (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx)
    | _ ->
        Arg.bind
          (Arg.make_offset ctx.arg (-l))
          (fun arg ->
            let ctx = {off= (-l+ctx.off) ; arg=arg} in
            do_make_if_in
              (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx))

    let rec c_test ctx ({cases=cases ; actions=actions} as s) =
      let lcases = Array.length cases in
      assert(lcases > 0) ;
      if lcases = 1 then
        actions.(get_act cases 0) ctx

      else begin

        let w,_c = opt_count false cases in
(*
  Printf.fprintf stderr
  "off=%d tactic=%a for %a\n"
  ctx.off pret w pcases cases ;
  *)
    match w with
    | No -> actions.(get_act cases 0) ctx
    | Inter (i,j) ->
        let low,high,inside, outside = coupe_inter i j cases in
        let _,(cinside,_) = opt_count false inside
        and _,(coutside,_) = opt_count false outside in
(* Costs are retrieved to put the code with more remaining tests
   in the privileged (positive) branch of ``if'' *)
        if low=high then begin
          if less_tests coutside cinside then
            make_if_eq
              ctx.arg
              (low+ctx.off)
              (c_test ctx {s with cases=inside})
              (c_test ctx {s with cases=outside})
          else
            make_if_ne
              ctx.arg
              (low+ctx.off)
              (c_test ctx {s with cases=outside})
              (c_test ctx {s with cases=inside})
        end else begin
          if less_tests coutside cinside then
            make_if_in
              ctx
              (low+ctx.off)
              (high-low)
              (fun ctx -> c_test ctx {s with cases=inside})
              (fun ctx -> c_test ctx {s with cases=outside})
          else
            make_if_out
              ctx
              (low+ctx.off)
              (high-low)
              (fun ctx -> c_test ctx {s with cases=outside})
              (fun ctx -> c_test ctx {s with cases=inside})
        end
    | Sep i ->
        let lim,left,right = coupe cases i in
        let _,(cleft,_) = opt_count false left
        and _,(cright,_) = opt_count false right in
        let left = {s with cases=left}
        and right = {s with cases=right} in

        if i=1 && (lim+ctx.off)=1 && get_low cases 0+ctx.off=0 then
          make_if_ne
            ctx.arg 0
            (c_test ctx right) (c_test ctx left)
        else if less_tests cright cleft then
          make_if_lt
            ctx.arg (lim+ctx.off)
            (c_test ctx left) (c_test ctx right)
        else
          make_if_ge
             ctx.arg (lim+ctx.off)
            (c_test ctx right) (c_test ctx left)

  end


(* Minimal density of switches *)
let theta = ref 0.33333

(* Minimal number of tests to make a switch *)
let switch_min = ref 3

(* Particular case 0, 1, 2 *)
let particular_case cases i j =
  j-i = 2 &&
  (let l1,_h1,act1 = cases.(i)
  and  l2,_h2,_act2 = cases.(i+1)
  and  l3,h3,act3 = cases.(i+2) in
  l1+1=l2 && l2+1=l3 && l3=h3 &&
  act1 <> act3)

let approx_count cases i j =
  let l = j-i+1 in
  if l < !cut then
     let _,(_,{n=ntests}) = opt_count false (Array.sub cases i l) in
     ntests
  else
    l-1

(* Sends back a boolean that says whether is switch is worth or not *)

let dense {cases} i j =
  if i=j then true
  else
    let l,_,_ = cases.(i)
    and _,h,_ = cases.(j) in
    let ntests =  approx_count cases i j in
(*
  (ntests+1) >= theta * (h-l+1)
*)
    particular_case cases i j ||
    (ntests >= !switch_min &&
    float_of_int ntests +. 1.0 >=
    !theta *. (float_of_int h -. float_of_int l +. 1.0))

(* Compute clusters by dynamic programming
   Adaptation of the correction to Bernstein
   ``Correction to `Producing Good Code for the Case Statement' ''
   S.K. Kannan and T.A. Proebsting
   Software Practice and Experience Vol. 24(2) 233 (Feb 1994)
*)

let comp_clusters s =
  let len = Array.length s.cases in
  let min_clusters = Array.make len max_int
  and k = Array.make len 0 in
  let get_min i = if i < 0 then 0 else min_clusters.(i) in

  for i = 0 to len-1 do
    for j = 0 to i do
      if
        dense s j i &&
        get_min (j-1) + 1 < min_clusters.(i)
      then begin
        k.(i) <- j ;
        min_clusters.(i) <- get_min (j-1) + 1
      end
    done ;
  done ;
  min_clusters.(len-1),k

(* Assume j > i *)
let make_switch loc {cases=cases ; actions=actions} i j =
  let ll,_,_ = cases.(i)
  and _,hh,_ = cases.(j) in
  let tbl = Array.make (hh-ll+1) 0
  and t = Hashtbl.create 17
  and index = ref 0 in
  let get_index act =
    try
      Hashtbl.find t act
    with
    | Not_found ->
        let i = !index in
        incr index ;
        Hashtbl.add t act i ;
        i in

  for k=i to j do
    let l,h,act = cases.(k) in
    let index = get_index act in
    for kk=l-ll to h-ll do
      tbl.(kk) <- index
    done
  done ;
  let acts = Array.make !index actions.(0) in
  Hashtbl.iter
    (fun act i -> acts.(i) <- actions.(act))
    t ;
  (fun ctx ->
    match -ll-ctx.off with
    | 0 -> Arg.make_switch loc ctx.arg tbl acts
    | _ ->
        Arg.bind
          (Arg.make_offset ctx.arg (-ll-ctx.off))
          (fun arg -> Arg.make_switch loc arg tbl acts))


let make_clusters loc ({cases=cases ; actions=actions} as s) n_clusters k =
  let len = Array.length cases in
  let r = Array.make n_clusters (0,0,0)
  and t = Hashtbl.create 17
  and index = ref 0
  and bidon = ref (Array.length actions) in
  let get_index act =
    try
      let i,_ = Hashtbl.find t act in
      i
    with
    | Not_found ->
        let i = !index in
        incr index ;
        Hashtbl.add
          t act
          (i,(fun _ -> actions.(act))) ;
        i
  and add_index act =
    let i = !index in
    incr index ;
    incr bidon ;
    Hashtbl.add t !bidon (i,act) ;
    i in

  let rec zyva j ir =
    let i = k.(j) in
    begin if i=j then
      let l,h,act = cases.(i) in
      r.(ir) <- (l,h,get_index act)
    else (* assert i < j *)
      let l,_,_ = cases.(i)
      and _,h,_ = cases.(j) in
      r.(ir) <- (l,h,add_index (make_switch loc s i j))
    end ;
    if i > 0 then zyva (i-1) (ir-1) in

  zyva (len-1) (n_clusters-1) ;
  let acts = Array.make !index (fun _ -> assert false) in
  Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ;
  {cases = r ; actions = acts}
;;


let do_zyva loc (low,high) arg cases actions =
  let old_ok = !ok_inter in
  ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ;
  if !ok_inter <> old_ok then Hashtbl.clear t ;

  let s = {cases=cases ; actions=actions} in

(*
  Printf.eprintf "ZYVA: %B [low=%i,high=%i]\n" !ok_inter low high ;
  pcases stderr cases ;
  prerr_endline "" ;
*)
  let n_clusters,k = comp_clusters s in
  let clusters = make_clusters loc s n_clusters k in
  c_test {arg=arg ; off=0} clusters

let abstract_shared actions =
  let handlers = ref (fun x -> x) in
  let actions =
    Array.map
      (fun act -> match  act with
      | Single act -> act
      | Shared act ->
          let i,h = Arg.make_catch act in
          let oh = !handlers in
          handlers := (fun act -> h (oh act)) ;
          Arg.make_exit i)
      actions in
  !handlers,actions

let zyva loc lh arg cases actions =
  assert (Array.length cases > 0) ;
  let actions = actions.act_get_shared () in
  let hs,actions = abstract_shared actions in
  hs (do_zyva loc lh arg cases actions)

and test_sequence arg cases actions =
  assert (Array.length cases > 0) ;
  let actions = actions.act_get_shared () in
  let hs,actions = abstract_shared actions in
  let old_ok = !ok_inter in
  ok_inter := false ;
  if !ok_inter <> old_ok then Hashtbl.clear t ;
  let s =
    {cases=cases ;
    actions=Array.map (fun act -> (fun _ -> act)) actions} in
(*
  Printf.eprintf "SEQUENCE: %B\n" !ok_inter ;
  pcases stderr cases ;
  prerr_endline "" ;
*)
  hs (c_test {arg=arg ; off=0} s)
;;

end

end
module Matching : sig 
#1 "matching.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Compilation of pattern-matching *)

open Typedtree
open Lambda


(* Entry points to match compiler *)
val for_function:
        Location.t -> int ref option -> lambda -> (pattern * lambda) list ->
        partial -> lambda
val for_trywith:
        lambda -> (pattern * lambda) list -> lambda
val for_let:
        Location.t -> lambda -> pattern -> lambda -> lambda
val for_multiple_match:
        Location.t -> lambda list -> (pattern * lambda) list -> partial ->
        lambda

val for_tupled_function:
        Location.t -> Ident.t list -> (pattern list * lambda) list ->
        partial -> lambda

exception Cannot_flatten

val flatten_pattern: int -> pattern -> pattern list

(* Expand stringswitch to  string test tree *)
val expand_stringswitch:
    Location.t -> lambda -> (string * lambda) list -> lambda option -> lambda

val inline_lazy_force : lambda -> Location.t -> lambda

end = struct
#1 "matching.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Compilation of pattern matching *)

open Misc
open Asttypes
open Types
open Typedtree
open Lambda
open Parmatch
open Printf


let dbg = false

(*  See Peyton-Jones, ``The Implementation of functional programming
    languages'', chapter 5. *)
(*
  Well, it was true at the beginning of the world.
  Now, see Lefessant-Maranget ``Optimizing Pattern-Matching'' ICFP'2001
*)

(*
   Compatibility predicate that considers potential rebindings of constructors
   of an extension type.

   "may_compat p q" returns false when p and q never admit a common instance;
   returns true when they may have a common instance.
*)

module MayCompat =
  Parmatch.Compat (struct let equal = Types.may_equal_constr end)
let may_compat = MayCompat.compat
and may_compats = MayCompat.compats

(*
   Many functions on the various data structures of the algorithm :
     - Pattern matrices.
     - Default environments: mapping from matrices to exit numbers.
     - Contexts:  matrices whose column are partitioned into
       left and right.
     - Jump summaries: mapping from exit numbers to contexts
*)


let string_of_lam lam =
  Printlambda.lambda Format.str_formatter lam ;
  Format.flush_str_formatter ()

type matrix = pattern list list

let add_omega_column pss = List.map (fun ps -> omega::ps) pss

type ctx = {left:pattern list ; right:pattern list}

let pretty_ctx ctx =
  List.iter
    (fun {left=left ; right=right} ->
      prerr_string "LEFT:" ;
      pretty_line left ;
      prerr_string " RIGHT:" ;
      pretty_line right ;
      prerr_endline "")
    ctx

let le_ctx c1 c2 =
  le_pats c1.left c2.left &&
  le_pats c1.right c2.right

let lshift {left=left ; right=right} = match right with
| x::xs -> {left=x::left ; right=xs}
| _ ->  assert false

let lforget {left=left ; right=right} = match right with
| _::xs -> {left=omega::left ; right=xs}
|  _ -> assert false

let rec small_enough n = function
  | [] -> true
  | _::rem ->
      if n <= 0 then false
      else small_enough (n-1) rem

let ctx_lshift ctx =
  if small_enough 31 ctx then
    List.map lshift ctx
  else (* Context pruning *) begin
    get_mins le_ctx (List.map lforget ctx)
  end

let  rshift {left=left ; right=right} = match left with
| p::ps -> {left=ps ; right=p::right}
| _ -> assert false

let ctx_rshift ctx = List.map rshift ctx

let rec nchars n ps =
  if n <= 0 then [],ps
  else match ps with
  | p::rem ->
    let chars, cdrs = nchars (n-1) rem in
    p::chars,cdrs
  | _ -> assert false

let  rshift_num n {left=left ; right=right} =
  let shifted,left = nchars n left in
  {left=left ; right = shifted@right}

let ctx_rshift_num n ctx = List.map (rshift_num n) ctx

(* Recombination of contexts (eg: (_,_)::p1::p2::rem ->  (p1,p2)::rem)
  All mutable fields are replaced by '_', since side-effects in
  guards can alter these fields *)

let combine {left=left ; right=right} = match left with
| p::ps -> {left=ps ; right=set_args_erase_mutable p right}
| _ -> assert false

let ctx_combine ctx = List.map combine ctx

let ncols = function
  | [] -> 0
  | ps::_ -> List.length ps


exception NoMatch
exception OrPat

let filter_matrix matcher pss =

  let rec filter_rec = function
    | (p::ps)::rem ->
        begin match p.pat_desc with
        | Tpat_alias (p,_,_) ->
            filter_rec ((p::ps)::rem)
        | Tpat_var _ ->
            filter_rec ((omega::ps)::rem)
        | _ ->
            begin
              let rem = filter_rec rem in
              try
                matcher p ps::rem
              with
              | NoMatch -> rem
              | OrPat   ->
                match p.pat_desc with
                | Tpat_or (p1,p2,_) -> filter_rec [(p1::ps) ;(p2::ps)]@rem
                | _ -> assert false
            end
        end
    | [] -> []
    | _ ->
        pretty_matrix pss ;
        fatal_error "Matching.filter_matrix" in
  filter_rec pss

let make_default matcher env =
  let rec make_rec = function
    | [] -> []
    | ([[]],i)::_ -> [[[]],i]
    | (pss,i)::rem ->
        let rem = make_rec rem in
        match filter_matrix matcher pss with
        | [] -> rem
        | ([]::_) -> ([[]],i)::rem
        | pss -> (pss,i)::rem in
  make_rec env

let ctx_matcher p =
  let p = normalize_pat p in
  match p.pat_desc with
  | Tpat_construct (_, cstr,omegas) ->
      (fun q rem -> match q.pat_desc with
      | Tpat_construct (_, cstr',args)
(* NB:  may_constr_equal considers (potential) constructor rebinding *)
        when Types.may_equal_constr cstr cstr' ->
          p,args@rem
      | Tpat_any -> p,omegas @ rem
      | _ -> raise NoMatch)
  | Tpat_constant cst ->
      (fun q rem -> match q.pat_desc with
      | Tpat_constant cst' when const_compare cst cst' = 0 ->
          p,rem
      | Tpat_any -> p,rem
      | _ -> raise NoMatch)
  | Tpat_variant (lab,Some omega,_) ->
      (fun q rem -> match q.pat_desc with
      | Tpat_variant (lab',Some arg,_) when lab=lab' ->
          p,arg::rem
      | Tpat_any -> p,omega::rem
      | _ -> raise NoMatch)
  | Tpat_variant (lab,None,_) ->
      (fun q rem -> match q.pat_desc with
      | Tpat_variant (lab',None,_) when lab=lab' ->
          p,rem
      | Tpat_any -> p,rem
      | _ -> raise NoMatch)
  | Tpat_array omegas ->
      let len = List.length omegas in
      (fun q rem -> match q.pat_desc with
      | Tpat_array args when List.length args = len -> p,args @ rem
      | Tpat_any -> p, omegas @ rem
      | _ -> raise NoMatch)
  | Tpat_tuple omegas ->
      let len = List.length omegas  in
      (fun q rem -> match q.pat_desc with
      | Tpat_tuple args when List.length args = len -> p,args @ rem
      | Tpat_any -> p, omegas @ rem
      | _ -> raise NoMatch)
  | Tpat_record (((_, lbl, _) :: _) as l,_) -> (* Records are normalized *)
      let len = Array.length lbl.lbl_all in
      (fun q rem -> match q.pat_desc with
      | Tpat_record (((_, lbl', _) :: _) as l',_)
        when Array.length lbl'.lbl_all = len ->
          let l' = all_record_args l' in
          p, List.fold_right (fun (_, _,p) r -> p::r) l' rem
      | Tpat_any -> p,List.fold_right (fun (_, _,p) r -> p::r) l rem
      | _ -> raise NoMatch)
  | Tpat_lazy omega ->
      (fun q rem -> match q.pat_desc with
      | Tpat_lazy arg -> p, (arg::rem)
      | Tpat_any      -> p, (omega::rem)
      | _             -> raise NoMatch)
 | _ -> fatal_error "Matching.ctx_matcher"




let filter_ctx q ctx =

  let matcher = ctx_matcher q in

  let rec filter_rec = function
    | ({right=p::ps} as l)::rem ->
        begin match p.pat_desc with
        | Tpat_or (p1,p2,_) ->
            filter_rec ({l with right=p1::ps}::{l with right=p2::ps}::rem)
        | Tpat_alias (p,_,_) ->
            filter_rec ({l with right=p::ps}::rem)
        | Tpat_var _ ->
            filter_rec ({l with right=omega::ps}::rem)
        | _ ->
            begin let rem = filter_rec rem in
            try
              let to_left, right = matcher p ps in
              {left=to_left::l.left ; right=right}::rem
            with
            | NoMatch -> rem
            end
        end
    | [] -> []
    | _ ->  fatal_error "Matching.filter_ctx" in

  filter_rec ctx

let select_columns pss ctx =
  let n = ncols pss in
  List.fold_right
    (fun ps r ->
      List.fold_right
        (fun {left=left ; right=right} r ->
          let transfert, right = nchars n right in
          try
            {left = lubs transfert ps @ left ; right=right}::r
          with
          | Empty -> r)
        ctx r)
    pss []

let ctx_lub p ctx =
  List.fold_right
    (fun {left=left ; right=right} r ->
      match right with
      | q::rem ->
          begin try
            {left=left ; right = lub p q::rem}::r
          with
          | Empty -> r
          end
      | _ -> fatal_error "Matching.ctx_lub")
    ctx []

let ctx_match ctx pss =
  List.exists
    (fun {right=qs} ->  List.exists (fun ps -> may_compats qs ps)  pss)
    ctx

type jumps = (int * ctx list) list

let pretty_jumps (env : jumps) = match env with
| [] -> ()
| _ ->
    List.iter
      (fun (i,ctx) ->
        Printf.fprintf stderr "jump for %d\n" i ;
        pretty_ctx ctx)
      env


let rec jumps_extract i = function
  | [] -> [],[]
  | (j,pss) as x::rem as all ->
      if i=j then pss,rem
      else if j < i then [],all
      else
        let r,rem = jumps_extract i rem in
        r,(x::rem)

let rec jumps_remove i = function
  | [] -> []
  | (j,_)::rem when i=j -> rem
  | x::rem -> x::jumps_remove i rem

let jumps_empty = []
and jumps_is_empty = function
  |  [] -> true
  |  _ -> false

let jumps_singleton i = function
  | []  -> []
  | ctx ->  [i,ctx]

let jumps_add i pss jumps = match pss with
| [] -> jumps
| _  ->
    let rec add = function
      | [] -> [i,pss]
      | (j,qss) as x::rem as all ->
          if j > i then x::add rem
      else if j < i then (i,pss)::all
      else (i,(get_mins le_ctx (pss@qss)))::rem in
    add jumps


let rec jumps_union (env1:(int*ctx list)list) env2 = match env1,env2 with
| [],_ -> env2
| _,[] -> env1
| ((i1,pss1) as x1::rem1), ((i2,pss2) as x2::rem2) ->
    if i1=i2 then
      (i1,get_mins le_ctx (pss1@pss2))::jumps_union rem1 rem2
    else if i1 > i2 then
      x1::jumps_union rem1 env2
    else
      x2::jumps_union env1 rem2


let rec merge = function
  | env1::env2::rem ->  jumps_union env1 env2::merge rem
  | envs -> envs

let rec jumps_unions envs = match envs with
  | [] -> []
  | [env] -> env
  | _ -> jumps_unions (merge envs)

let jumps_map f env =
  List.map
    (fun (i,pss) -> i,f pss)
    env

(* Pattern matching before any compilation *)

type pattern_matching =
  { mutable cases : (pattern list * lambda) list;
    args : (lambda * let_kind) list ;
    default : (matrix * int) list}

(* Pattern matching after application of both the or-pat rule and the
   mixture rule *)

type pm_or_compiled =
  {body : pattern_matching ;
   handlers : (matrix * int * Ident.t list * pattern_matching) list ;
   or_matrix : matrix ; }

type pm_half_compiled =
  | PmOr of pm_or_compiled
  | PmVar of pm_var_compiled
  | Pm of pattern_matching

and pm_var_compiled =
    {inside : pm_half_compiled ; var_arg : lambda ; }

type pm_half_compiled_info =
    {me : pm_half_compiled ;
     matrix : matrix ;
     top_default : (matrix * int) list ; }

let pretty_cases cases =
  List.iter
    (fun (ps,_l) ->
      List.iter
        (fun p ->
          Parmatch.top_pretty Format.str_formatter p ;
          prerr_string " " ;
          prerr_string (Format.flush_str_formatter ()))
        ps ;
(*
      prerr_string " -> " ;
      Printlambda.lambda Format.str_formatter l ;
      prerr_string (Format.flush_str_formatter ()) ;
*)
      prerr_endline "")
    cases

let pretty_def def =
  prerr_endline "+++++ Defaults +++++" ;
  List.iter
    (fun (pss,i) ->
      Printf.fprintf stderr "Matrix for %d\n"  i ;
      pretty_matrix pss)
    def ;
  prerr_endline "+++++++++++++++++++++"

let pretty_pm pm =
  pretty_cases pm.cases ;
  if pm.default <> [] then
    pretty_def pm.default


let rec pretty_precompiled = function
  | Pm pm ->
      prerr_endline "++++ PM ++++" ;
      pretty_pm pm
  | PmVar x ->
      prerr_endline "++++ VAR ++++" ;
      pretty_precompiled x.inside
  | PmOr x ->
      prerr_endline "++++ OR ++++" ;
      pretty_pm x.body ;
      pretty_matrix x.or_matrix ;
      List.iter
        (fun (_,i,_,pm) ->
          eprintf "++ Handler %d ++\n" i ;
          pretty_pm pm)
        x.handlers

let pretty_precompiled_res first nexts =
  pretty_precompiled first ;
  List.iter
    (fun (e, pmh) ->
      eprintf "** DEFAULT %d **\n" e ;
      pretty_precompiled pmh)
    nexts



(* Identifying some semantically equivalent lambda-expressions,
   Our goal here is also to
   find alpha-equivalent (simple) terms *)

(* However, as shown by PR#6359 such sharing may hinders the
   lambda-code invariant that all bound idents are unique,
   when switches are compiled to test sequences.
   The definitive fix is the systematic introduction of exit/catch
   in case action sharing is present.
*)


module StoreExp =
  Switch.Store
    (struct
      type t = lambda
      type key = lambda
      let compare_key = Pervasives.compare
      let make_key = Lambda.make_key
    end)


let make_exit i = Lstaticraise (i,[])

(* Introduce a catch, if worth it *)
let make_catch d k = match d with
| Lstaticraise (_,[]) -> k d
| _ ->
    let e = next_raise_count () in
    Lstaticcatch (k (make_exit e),(e,[]),d)

(* Introduce a catch, if worth it, delayed version *)
let rec as_simple_exit = function
  | Lstaticraise (i,[]) -> Some i
  | Llet (Alias,_k,_,_,e) -> as_simple_exit e
  | _ -> None


let make_catch_delayed handler = match as_simple_exit handler with
| Some i -> i,(fun act -> act)
| None ->
    let i = next_raise_count () in
(*
    Printf.eprintf "SHARE LAMBDA: %i\n%s\n" i (string_of_lam handler);
*)
    i,
    (fun body -> match body with
    | Lstaticraise (j,_) ->
        if i=j then handler else body
    | _ -> Lstaticcatch (body,(i,[]),handler))


let raw_action l =
  match make_key l with | Some l -> l | None -> l


let tr_raw act = match make_key act with
| Some act -> act
| None -> raise Exit

let same_actions = function
  | [] -> None
  | [_,act] -> Some act
  | (_,act0) :: rem ->
      try
        let raw_act0 = tr_raw act0 in
        let rec s_rec = function
          | [] -> Some act0
          | (_,act)::rem ->
              if raw_act0 = tr_raw act then
                s_rec rem
              else
                None in
        s_rec rem
      with
      | Exit -> None


(* Test for swapping two clauses *)

let up_ok_action act1 act2 =
  try
    let raw1 = tr_raw act1
    and raw2 = tr_raw act2 in
    raw1 = raw2
  with
  | Exit -> false

let up_ok (ps,act_p) l =
  List.for_all
    (fun (qs,act_q) ->
      up_ok_action act_p act_q || not (may_compats ps qs))
    l

(*
   The simplify function normalizes the first column of the match
     - records are expanded so that they possess all fields
     - aliases are removed and replaced by bindings in actions.
   However or-patterns are simplified differently,
     - aliases are not removed
     - or-patterns (_|p) are changed into _
*)

exception Var of pattern

let simplify_or p =
  let rec simpl_rec p = match p with
    | {pat_desc = Tpat_any|Tpat_var _} -> raise (Var p)
    | {pat_desc = Tpat_alias (q,id,s)} ->
        begin try
          {p with pat_desc = Tpat_alias (simpl_rec q,id,s)}
        with
        | Var q -> raise (Var {p with pat_desc = Tpat_alias (q,id,s)})
        end
    | {pat_desc = Tpat_or (p1,p2,o)} ->
        let q1 = simpl_rec p1 in
        begin try
          let q2 = simpl_rec p2 in
          {p with pat_desc = Tpat_or (q1, q2, o)}
        with
        | Var q2 -> raise (Var {p with pat_desc = Tpat_or (q1, q2, o)})
        end
    | {pat_desc = Tpat_record (lbls,closed)} ->
        let all_lbls = all_record_args lbls in
        {p with pat_desc=Tpat_record (all_lbls, closed)}
    | _ -> p in
  try
    simpl_rec p
  with
  | Var p -> p

let simplify_cases args cls = match args with
| [] -> assert false
| (arg,_)::_ ->
    let rec simplify = function
      | [] -> []
      | ((pat :: patl, action) as cl) :: rem ->
          begin match pat.pat_desc with
          | Tpat_var (id, _) ->
              (omega :: patl, bind Alias id arg action) ::
              simplify rem
          | Tpat_any ->
              cl :: simplify rem
          | Tpat_alias(p, id,_) ->
              simplify ((p :: patl, bind Alias id arg action) :: rem)
          | Tpat_record ([],_) ->
              (omega :: patl, action)::
              simplify rem
          | Tpat_record (lbls, closed) ->
              let all_lbls = all_record_args lbls in
              let full_pat =
                {pat with pat_desc=Tpat_record (all_lbls, closed)} in
              (full_pat::patl,action)::
              simplify rem
          | Tpat_or _ ->
              let pat_simple  = simplify_or pat in
              begin match pat_simple.pat_desc with
              | Tpat_or _ ->
                  (pat_simple :: patl, action) ::
                  simplify rem
              | _ ->
                  simplify ((pat_simple::patl,action) :: rem)
              end
          | _ -> cl :: simplify rem
          end
      | _ -> assert false in

    simplify cls



(* Once matchings are simplified one can easily find
   their nature *)

let rec what_is_cases cases = match cases with
| ({pat_desc=Tpat_any} :: _, _) :: rem -> what_is_cases rem
| (({pat_desc=(Tpat_var _|Tpat_or (_,_,_)|Tpat_alias (_,_,_))}::_),_)::_
  -> assert false (* applies to simplified matchings only *)
| (p::_,_)::_ -> p
| [] -> omega
| _ -> assert false



(* A few operations on default environments *)
let as_matrix cases = get_mins le_pats (List.map (fun (ps,_) -> ps) cases)

let cons_default matrix raise_num default =
  match matrix with
  | [] -> default
  | _ -> (matrix,raise_num)::default

let default_compat p def =
  List.fold_right
    (fun (pss,i) r ->
      let qss =
        List.fold_right
          (fun qs r -> match qs with
            | q::rem when may_compat p q -> rem::r
            | _ -> r)
          pss [] in
      match qss with
      | [] -> r
      | _  -> (qss,i)::r)
    def []

(* Or-pattern expansion, variables are a complication w.r.t. the article *)
let rec extract_vars r p = match p.pat_desc with
| Tpat_var (id, _) -> IdentSet.add id r
| Tpat_alias (p, id,_ ) ->
    extract_vars (IdentSet.add id r) p
| Tpat_tuple pats ->
    List.fold_left extract_vars r pats
| Tpat_record (lpats,_) ->
    List.fold_left
      (fun r (_, _, p) -> extract_vars r p)
      r lpats
| Tpat_construct (_, _, pats) ->
    List.fold_left extract_vars r pats
| Tpat_array pats ->
    List.fold_left extract_vars r pats
| Tpat_variant (_,Some p, _) -> extract_vars r p
| Tpat_lazy p -> extract_vars r p
| Tpat_or (p,_,_) -> extract_vars r p
| Tpat_constant _|Tpat_any|Tpat_variant (_,None,_) -> r

exception Cannot_flatten

let mk_alpha_env arg aliases ids =
  List.map
    (fun id -> id,
      if List.mem id aliases then
        match arg with
        | Some v -> v
        | _      -> raise Cannot_flatten
      else
        Ident.create (Ident.name id))
    ids

let rec explode_or_pat arg patl mk_action rem vars aliases = function
  | {pat_desc = Tpat_or (p1,p2,_)} ->
      explode_or_pat
        arg patl mk_action
        (explode_or_pat arg patl mk_action rem vars aliases p2)
        vars aliases p1
  | {pat_desc = Tpat_alias (p,id, _)} ->
      explode_or_pat arg patl mk_action rem vars (id::aliases) p
  | {pat_desc = Tpat_var (x, _)} ->
      let env = mk_alpha_env arg (x::aliases) vars in
      (omega::patl,mk_action (List.map snd env))::rem
  | p ->
      let env = mk_alpha_env arg aliases vars in
      (alpha_pat env p::patl,mk_action (List.map snd env))::rem

let pm_free_variables {cases=cases} =
  List.fold_right
    (fun (_,act) r -> IdentSet.union (free_variables act) r)
    cases IdentSet.empty


(* Basic grouping predicates *)
let pat_as_constr = function
  | {pat_desc=Tpat_construct (_, cstr,_)} -> cstr
  | _ -> fatal_error "Matching.pat_as_constr"

let group_constant = function
  | {pat_desc= Tpat_constant _} -> true
  | _                           -> false

and group_constructor = function
  | {pat_desc = Tpat_construct (_,_,_)} -> true
  | _ -> false

and group_variant = function
  | {pat_desc = Tpat_variant (_, _, _)} -> true
  | _ -> false

and group_var = function
  | {pat_desc=Tpat_any} -> true
  | _ -> false

and group_tuple = function
  | {pat_desc = (Tpat_tuple _|Tpat_any)} -> true
  | _ -> false

and group_record = function
  | {pat_desc = (Tpat_record _|Tpat_any)} -> true
  | _ -> false

and group_array = function
  | {pat_desc=Tpat_array _} -> true
  | _ -> false

and group_lazy = function
  | {pat_desc = Tpat_lazy _} -> true
  | _ -> false

let get_group p = match p.pat_desc with
| Tpat_any -> group_var
| Tpat_constant _ -> group_constant
| Tpat_construct _ -> group_constructor
| Tpat_tuple _ -> group_tuple
| Tpat_record _ -> group_record
| Tpat_array _ -> group_array
| Tpat_variant (_,_,_) -> group_variant
| Tpat_lazy _ -> group_lazy
|  _ -> fatal_error "Matching.get_group"



let is_or p = match p.pat_desc with
| Tpat_or _ -> true
| _ -> false

(* Conditions for appending to the Or matrix *)
let conda p q = not (may_compat p q)
and condb act ps qs =  not (is_guarded act) && Parmatch.le_pats qs ps

let or_ok p ps l =
  List.for_all
    (function
      | ({pat_desc=Tpat_or _} as q::qs,act) ->
          conda p q || condb act ps qs
      | _ -> true)
    l

(* Insert or append a pattern in the Or matrix *)

let equiv_pat p q = le_pat p q && le_pat q p

let rec get_equiv p l = match l with
  | (q::_,_) as cl::rem ->
      if equiv_pat p q then
        let others,rem = get_equiv p rem in
        cl::others,rem
      else
        [],l
  | _ -> [],l


let insert_or_append p ps act ors no =
  let rec attempt seen = function
    | (q::qs,act_q) as cl::rem ->
        if is_or q then begin
          if may_compat p q then
            if
              IdentSet.is_empty (extract_vars IdentSet.empty p) &&
              IdentSet.is_empty (extract_vars IdentSet.empty q) &&
              equiv_pat p q
            then (* attempt insert, for equivalent orpats with no variables *)
              let _, not_e = get_equiv q rem in
              if
                or_ok p ps not_e && (* check append condition for head of O *)
                List.for_all        (* check insert condition for tail of O *)
                  (fun cl -> match cl with
                  | (q::_,_) -> not (may_compat p q)
                  | _        -> assert false)
                  seen
              then (* insert *)
                List.rev_append seen ((p::ps,act)::cl::rem), no
              else (* fail to insert or append *)
                ors,(p::ps,act)::no
            else if condb act_q ps qs then (* check condition (b) for append *)
              attempt (cl::seen) rem
            else
              ors,(p::ps,act)::no
          else (* p # q, go on with append/insert *)
            attempt (cl::seen) rem
        end else (* q is not an or-pat, go on with append/insert *)
          attempt (cl::seen) rem
    | _  -> (* [] in fact *)
        (p::ps,act)::ors,no in (* success in appending *)
  attempt [] ors

(* Reconstruct default information from half_compiled  pm list *)

let rec rebuild_matrix pmh = match pmh with
  | Pm pm -> as_matrix pm.cases
  | PmOr {or_matrix=m} -> m
  | PmVar x -> add_omega_column  (rebuild_matrix x.inside)

let rec rebuild_default nexts def = match nexts with
| [] -> def
| (e, pmh)::rem ->
    (add_omega_column (rebuild_matrix pmh), e)::
    rebuild_default rem def

let rebuild_nexts arg nexts k =
  List.fold_right
    (fun (e, pm) k -> (e, PmVar {inside=pm ; var_arg=arg})::k)
    nexts k


(*
  Split a matching.
    Splitting is first directed by or-patterns, then by
    tests (e.g. constructors)/variable transitions.

    The approach is greedy, every split function attempts to
    raise rows as much as possible in the top matrix,
    then splitting applies again to the remaining rows.

    Some precompilation of or-patterns and
    variable pattern occurs. Mostly this means that bindings
    are performed now,  being replaced by let-bindings
    in actions (cf. simplify_cases).

    Additionally, if the match argument is a variable, matchings whose
    first column is made of variables only are splitted further
    (cf. precompile_var).

*)


let rec split_or argo cls args def =

  let cls = simplify_cases args cls in

  let rec do_split before ors no = function
    | [] ->
        cons_next
          (List.rev before) (List.rev ors) (List.rev no)
    | ((p::ps,act) as cl)::rem ->
        if up_ok cl no then
          if is_or p then
            let ors, no = insert_or_append p ps act ors no in
            do_split before ors no rem
          else begin
            if up_ok cl ors then
              do_split (cl::before) ors no rem
            else if or_ok p ps ors then
              do_split before (cl::ors) no rem
            else
              do_split before ors (cl::no) rem
          end
        else
          do_split before ors (cl::no) rem
    | _ -> assert false

  and cons_next yes yesor = function
    | [] ->
        precompile_or argo yes yesor args def []
    | rem ->
        let {me=next ; matrix=matrix ; top_default=def},nexts =
          do_split [] [] [] rem in
        let idef = next_raise_count () in
        precompile_or
          argo yes yesor args
          (cons_default matrix idef def)
          ((idef,next)::nexts) in

  do_split [] [] [] cls

(* Ultra-naive splitting, close to semantics, used for extension,
   as potential rebind prevents any kind of optimisation *)

and split_naive cls args def k =

  let rec split_exc cstr0 yes = function
    | [] ->
        let yes = List.rev yes in
        { me = Pm {cases=yes; args=args; default=def;} ;
          matrix = as_matrix yes ;
          top_default=def},
        k
    | (p::_,_ as cl)::rem ->
        if group_constructor p then
          let cstr = pat_as_constr p in
          if cstr = cstr0 then split_exc cstr0 (cl::yes) rem
          else
            let yes = List.rev yes in
            let {me=next ; matrix=matrix ; top_default=def}, nexts =
              split_exc cstr [cl] rem in
            let idef = next_raise_count () in
            let def = cons_default matrix idef def in
            { me = Pm {cases=yes; args=args; default=def} ;
              matrix = as_matrix yes ;
              top_default = def; },
            (idef,next)::nexts
        else
          let yes = List.rev yes in
          let {me=next ; matrix=matrix ; top_default=def}, nexts =
              split_noexc [cl] rem in
            let idef = next_raise_count () in
            let def = cons_default matrix idef def in
            { me = Pm {cases=yes; args=args; default=def} ;
              matrix = as_matrix yes ;
              top_default = def; },
            (idef,next)::nexts
    | _ -> assert false

  and split_noexc yes = function
    | [] -> precompile_var args (List.rev yes) def k
    | (p::_,_ as cl)::rem ->
        if group_constructor p then
          let yes= List.rev yes in
          let {me=next; matrix=matrix; top_default=def;},nexts =
            split_exc (pat_as_constr p) [cl] rem in
          let idef = next_raise_count () in
          precompile_var
            args yes
            (cons_default matrix idef def)
            ((idef,next)::nexts)
        else split_noexc (cl::yes) rem
    | _ -> assert false in

  match cls with
  | [] -> assert false
  | (p::_,_ as cl)::rem ->
      if group_constructor p then
        split_exc (pat_as_constr p) [cl] rem
      else
        split_noexc [cl] rem
  | _ -> assert false

and split_constr cls args def k =
  let ex_pat = what_is_cases cls in
  match ex_pat.pat_desc with
  | Tpat_any -> precompile_var args cls def k
  | Tpat_construct (_,{cstr_tag=Cstr_extension _},_) ->
      split_naive cls args def k
  | _ ->

      let group = get_group ex_pat in

      let rec split_ex yes no = function
        | [] ->
            let yes = List.rev yes and no = List.rev no in
            begin match no with
            | [] ->
                {me = Pm {cases=yes ; args=args ; default=def} ;
                  matrix = as_matrix yes ;
                  top_default = def},
                k
            | cl::rem ->
                begin match yes with
                | [] ->
                    (* Could not success in raising up a constr matching up *)
                    split_noex [cl] [] rem
                | _ ->
                    let {me=next ; matrix=matrix ; top_default=def}, nexts =
                      split_noex [cl] [] rem in
                    let idef = next_raise_count () in
                    let def = cons_default matrix idef def in
                    {me = Pm {cases=yes ; args=args ; default=def} ;
                      matrix = as_matrix yes ;
                      top_default = def },
                    (idef, next)::nexts
                end
            end
        | (p::_,_) as cl::rem ->
            if group p && up_ok cl no then
              split_ex (cl::yes) no rem
            else
              split_ex yes (cl::no) rem
        | _ -> assert false

      and split_noex yes no = function
        | [] ->
            let yes = List.rev yes and no = List.rev no in
            begin match no with
            | [] -> precompile_var args yes def k
            | cl::rem ->
                let {me=next ; matrix=matrix ; top_default=def}, nexts =
                  split_ex [cl] [] rem in
                let idef = next_raise_count () in
                precompile_var
                  args yes
                  (cons_default matrix idef def)
                  ((idef,next)::nexts)
            end
        | [ps,_ as cl]
            when List.for_all group_var ps && yes <> [] ->
       (* This enables an extra division in some frequent cases :
          last row is made of variables only *)
              split_noex yes (cl::no) []
        | (p::_,_) as cl::rem ->
            if not (group p) && up_ok cl no then
              split_noex (cl::yes) no rem
            else
              split_noex yes (cl::no) rem
        | _ -> assert false in

      match cls with
      | ((p::_,_) as cl)::rem ->
          if group p then split_ex [cl] [] rem
          else split_noex [cl] [] rem
      | _ ->  assert false

and precompile_var  args cls def k = match args with
| []  -> assert false
| _::((Lvar v as av,_) as arg)::rargs ->
    begin match cls with
    | [_] -> (* as splitted as it can *)
        dont_precompile_var args cls def k
    | _ ->
(* Precompile *)
        let var_cls =
          List.map
            (fun (ps,act) -> match ps with
            | _::ps -> ps,act | _     -> assert false)
            cls
        and var_def = make_default (fun _ rem -> rem) def in
        let {me=first ; matrix=matrix}, nexts =
          split_or (Some v) var_cls (arg::rargs) var_def in

(* Compute top information *)
        match nexts with
        | [] -> (* If you need *)
            dont_precompile_var args cls def k
        | _  ->
            let rfirst =
              {me = PmVar {inside=first ; var_arg = av} ;
                matrix = add_omega_column matrix ;
                top_default = rebuild_default nexts def ; }
            and rnexts = rebuild_nexts av nexts k in
            rfirst, rnexts
    end
|  _ ->
    dont_precompile_var args cls def k

and dont_precompile_var args cls def k =
  {me =  Pm {cases = cls ; args = args ; default = def } ;
    matrix=as_matrix cls ;
    top_default=def},k

and precompile_or argo cls ors args def k = match ors with
| [] -> split_constr cls args def k
| _  ->
    let rec do_cases = function
      | ({pat_desc=Tpat_or _} as orp::patl, action)::rem ->
          let others,rem = get_equiv orp rem in
          let orpm =
            {cases =
              (patl, action)::
              List.map
                (function
                  | (_::ps,action) -> ps,action
                  | _ -> assert false)
                others ;
              args = (match args with _::r -> r | _ -> assert false) ;
              default = default_compat orp def} in
          let vars =
            IdentSet.elements
              (IdentSet.inter
                 (extract_vars IdentSet.empty orp)
                 (pm_free_variables orpm)) in
          let or_num = next_raise_count () in
          let new_patl = Parmatch.omega_list patl in

          let mk_new_action vs =
            Lstaticraise
              (or_num, List.map (fun v -> Lvar v) vs) in

          let body,handlers = do_cases rem in
          explode_or_pat
            argo new_patl mk_new_action body vars [] orp,
          let mat = [[orp]] in
          ((mat, or_num, vars , orpm):: handlers)
      | cl::rem ->
          let new_ord,new_to_catch = do_cases rem in
          cl::new_ord,new_to_catch
      | [] -> [],[] in

    let end_body, handlers = do_cases ors in
    let matrix = as_matrix (cls@ors)
    and body = {cases=cls@end_body ; args=args ; default=def} in
    {me = PmOr {body=body ; handlers=handlers ; or_matrix=matrix} ;
      matrix=matrix ;
      top_default=def},
    k

let split_precompile argo pm =
  let {me=next}, nexts = split_or argo pm.cases pm.args pm.default  in
  if dbg && (nexts <> [] || (match next with PmOr _ -> true | _ -> false))
  then begin
    prerr_endline "** SPLIT **" ;
    pretty_pm pm ;
    pretty_precompiled_res  next nexts
  end ;
  next, nexts


(* General divide functions *)

let add_line patl_action pm = pm.cases <- patl_action :: pm.cases; pm

type cell =
  {pm : pattern_matching ;
  ctx : ctx list ;
  pat : pattern}

let add make_matching_fun division eq_key key patl_action args =
  try
    let (_,cell) = List.find (fun (k,_) -> eq_key key k) division in
    cell.pm.cases <- patl_action :: cell.pm.cases;
    division
  with Not_found ->
    let cell = make_matching_fun args in
    cell.pm.cases <- [patl_action] ;
    (key, cell) :: division


let divide make eq_key get_key get_args ctx pm =

  let rec divide_rec = function
    | (p::patl,action) :: rem ->
        let this_match = divide_rec rem in
        add
          (make p pm.default ctx)
          this_match eq_key (get_key p) (get_args p patl,action) pm.args
    | _ -> [] in

  divide_rec pm.cases


let divide_line make_ctx make get_args pat ctx pm =
  let rec divide_rec = function
    | (p::patl,action) :: rem ->
        let this_match = divide_rec rem in
        add_line (get_args p patl, action) this_match
    | _ -> make pm.default pm.args in

  {pm = divide_rec pm.cases ;
  ctx=make_ctx ctx ;
  pat=pat}



(* Then come various functions,
   There is one set of functions per matching style
   (constants, constructors etc.)

   - matcher functions are arguments to make_default (for default handlers)
   They may raise NoMatch or OrPat and perform the full
   matching (selection + arguments).


   - get_args and get_key are for the compiled matrices, note that
   selection and getting arguments are separated.

   - make_ _matching combines the previous functions for producing
   new  ``pattern_matching'' records.
*)



let rec matcher_const cst p rem = match p.pat_desc with
| Tpat_or (p1,p2,_) ->
    begin try
      matcher_const cst p1 rem with
    | NoMatch -> matcher_const cst p2 rem
    end
| Tpat_constant c1 when const_compare c1 cst = 0 -> rem
| Tpat_any    -> rem
| _ -> raise NoMatch

let get_key_constant caller = function
  | {pat_desc= Tpat_constant cst} -> cst
  | p ->
      prerr_endline ("BAD: "^caller) ;
      pretty_pat p ;
      assert false

let get_args_constant _ rem = rem

let make_constant_matching p def ctx = function
    [] -> fatal_error "Matching.make_constant_matching"
  | (_ :: argl) ->
      let def =
        make_default
          (matcher_const (get_key_constant "make" p)) def
      and ctx =
        filter_ctx p  ctx in
      {pm = {cases = []; args = argl ; default = def} ;
        ctx = ctx ;
        pat = normalize_pat p}




let divide_constant ctx m =
  divide
    make_constant_matching
    (fun c d -> const_compare c d = 0) (get_key_constant "divide")
    get_args_constant
    ctx m

(* Matching against a constructor *)


let make_field_args loc binding_kind arg first_pos last_pos argl =
  let rec make_args pos =
    if pos > last_pos
    then argl
    else (Lprim(Pfield (pos, Fld_na), [arg], loc), binding_kind) :: make_args (pos + 1)
  in make_args first_pos

let get_key_constr = function
  | {pat_desc=Tpat_construct (_, cstr,_)} -> cstr.cstr_tag
  | _ -> assert false

let get_args_constr p rem = match p with
| {pat_desc=Tpat_construct (_, _, args)} -> args @ rem
| _ -> assert false

(* NB: matcher_constr applies to default matrices.

       In that context, matching by constructors of extensible
       types degrades to arity checking, due to potential rebinding.
       This comparison is performed by Types.may_equal_constr.
*)

let matcher_constr cstr = match cstr.cstr_arity with
| 0 ->
    let rec matcher_rec q rem = match q.pat_desc with
    | Tpat_or (p1,p2,_) ->
        begin
          try matcher_rec p1 rem
          with NoMatch -> matcher_rec p2 rem
        end
    | Tpat_construct (_, cstr',[])
      when Types.may_equal_constr cstr cstr' -> rem
    | Tpat_any -> rem
    | _ -> raise NoMatch in
    matcher_rec
| 1 ->
    let rec matcher_rec q rem = match q.pat_desc with
    | Tpat_or (p1,p2,_) ->
        let r1 = try Some (matcher_rec p1 rem) with NoMatch -> None
        and r2 = try Some (matcher_rec p2 rem) with NoMatch -> None in
        begin match r1,r2 with
        | None, None -> raise NoMatch
        | Some r1, None -> r1
        | None, Some r2 -> r2
        | Some (a1::_), Some (a2::_) ->
            {a1 with
             pat_loc = Location.none ;
             pat_desc = Tpat_or (a1, a2, None)}::
            rem
        | _, _ -> assert false
        end
    | Tpat_construct (_, cstr', [arg])
      when Types.may_equal_constr cstr cstr' -> arg::rem
    | Tpat_any -> omega::rem
    | _ -> raise NoMatch in
    matcher_rec
| _ ->
    fun q rem -> match q.pat_desc with
    | Tpat_or (_,_,_) -> raise OrPat
    | Tpat_construct (_,cstr',args)
      when  Types.may_equal_constr cstr cstr' -> args @ rem
    | Tpat_any -> Parmatch.omegas cstr.cstr_arity @ rem
    | _        -> raise NoMatch

let is_none_bs_primitve : Lambda.primitive =
  Pccall 
    (Primitive.simple ~name:"#is_none" ~arity:1 ~alloc:false)

let val_from_option_bs_primitive : Lambda.primitive =
  Pccall 
    (Primitive.simple ~name:"#val_from_option" ~arity:1 ~alloc:true)

let val_from_unnest_option_bs_primitive : Lambda.primitive =
  Pccall
    (Primitive.simple ~name:"#val_from_unnest_option" ~arity:1 ~alloc:true)

let make_constr_matching p def ctx = function
    [] -> fatal_error "Matching.make_constr_matching"
  | ((arg, _mut) :: argl) ->
      let cstr = pat_as_constr p in
      let newargs =
        if cstr.cstr_inlined <> None then
          (arg, Alias) :: argl
        else match cstr.cstr_tag with
        | Cstr_block _ when
            !Clflags.bs_only &&
            Datarepr.constructor_has_optional_shape cstr
          ->
            begin
              let from_option = 
                match p.pat_desc with
                | Tpat_construct(_, _,
                                 [ {
                                   pat_type ; pat_env
                                 } ])
                  when Typeopt.cannot_inhabit_none_like_value pat_type pat_env
                  -> val_from_unnest_option_bs_primitive
                | _ -> val_from_option_bs_primitive in 
              (Lprim (from_option, [arg], p.pat_loc), Alias) :: argl
            end
        | Cstr_constant _
        | Cstr_block _ ->
            make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl
        | Cstr_unboxed -> (arg, Alias) :: argl
        | Cstr_extension _ ->
            make_field_args p.pat_loc Alias arg 1 cstr.cstr_arity argl in
      {pm=
        {cases = []; args = newargs;
          default = make_default (matcher_constr cstr) def} ;
        ctx =  filter_ctx p ctx ;
        pat=normalize_pat p}


let divide_constructor ctx pm =
  divide
    make_constr_matching
    (=) get_key_constr get_args_constr
    ctx pm

(* Matching against a variant *)

let rec matcher_variant_const lab p rem = match p.pat_desc with
| Tpat_or (p1, p2, _) ->
    begin
      try
        matcher_variant_const lab p1 rem
      with
      | NoMatch -> matcher_variant_const lab p2 rem
    end
| Tpat_variant (lab1,_,_) when lab1=lab -> rem
| Tpat_any -> rem
| _   -> raise NoMatch


let make_variant_matching_constant p lab def ctx = function
    [] -> fatal_error "Matching.make_variant_matching_constant"
  | (_ :: argl) ->
      let def = make_default (matcher_variant_const lab) def
      and ctx = filter_ctx p ctx in
      {pm={ cases = []; args = argl ; default=def} ;
        ctx=ctx ;
        pat = normalize_pat p}

let matcher_variant_nonconst lab p rem = match p.pat_desc with
| Tpat_or (_,_,_) -> raise OrPat
| Tpat_variant (lab1,Some arg,_) when lab1=lab -> arg::rem
| Tpat_any -> omega::rem
| _   -> raise NoMatch


let make_variant_matching_nonconst p lab def ctx = function
    [] -> fatal_error "Matching.make_variant_matching_nonconst"
  | ((arg, _mut) :: argl) ->
      let def = make_default (matcher_variant_nonconst lab) def
      and ctx = filter_ctx p ctx in
      {pm=
        {cases = []; args = (Lprim(Pfield (1, Fld_na), [arg], p.pat_loc), Alias) :: argl;
          default=def} ;
        ctx=ctx ;
        pat = normalize_pat p}

let divide_variant row ctx {cases = cl; args = al; default=def} =
  let row = Btype.row_repr row in
  let rec divide = function
      ({pat_desc = Tpat_variant(lab, pato, _)} as p:: patl, action) :: rem ->
        let variants = divide rem in
        if try Btype.row_field_repr (List.assoc lab row.row_fields) = Rabsent
        with Not_found -> true
        then
          variants
        else begin
          let tag = Btype.hash_variant lab in
          match pato with
            None ->
              add (make_variant_matching_constant p lab def ctx) variants
                (=) (Cstr_constant tag) (patl, action) al
          | Some pat ->
              add (make_variant_matching_nonconst p lab def ctx) variants
                (=) (Cstr_block tag) (pat :: patl, action) al
        end
    | _ -> []
  in
  divide cl

(*
  Three ``no-test'' cases
  *)

(* Matching against a variable *)

let get_args_var _ rem = rem


let make_var_matching def = function
  | [] ->  fatal_error "Matching.make_var_matching"
  | _::argl ->
      {cases=[] ;
        args = argl ;
        default= make_default get_args_var def}

let divide_var ctx pm =
  divide_line ctx_lshift make_var_matching get_args_var omega ctx pm

(* Matching and forcing a lazy value *)

let get_arg_lazy p rem = match p with
| {pat_desc = Tpat_any} -> omega :: rem
| {pat_desc = Tpat_lazy arg} -> arg :: rem
| _ ->  assert false

let matcher_lazy p rem = match p.pat_desc with
| Tpat_or (_,_,_)     -> raise OrPat
| Tpat_any
| Tpat_var _          -> omega :: rem
| Tpat_lazy arg       -> arg :: rem
| _                   -> raise NoMatch

(* Inlining the tag tests before calling the primitive that works on
   lazy blocks. This is also used in translcore.ml.
   No other call than Obj.tag when the value has been forced before.
*)

let prim_obj_tag =
  Primitive.simple ~name:"caml_obj_tag" ~arity:1 ~alloc:false

let get_mod_field modname field =
  lazy (
    try
      let mod_ident = Ident.create_persistent modname in
      let env = Env.open_pers_signature modname Env.initial_safe_string in
      let p = try
        match Env.lookup_value (Longident.Lident field) env with
        | (Path.Pdot(_,_,i), _) -> i
        | _ -> fatal_error ("Primitive "^modname^"."^field^" not found.")
      with Not_found ->
        fatal_error ("Primitive "^modname^"."^field^" not found.")
      in
      Lprim(Pfield (p, Fld_na),
            [Lprim(Pgetglobal mod_ident, [], Location.none)],
            Location.none)
    with Not_found -> fatal_error ("Module "^modname^" unavailable.")
  )

let code_force_lazy_block =
  get_mod_field "CamlinternalLazy" "force_lazy_block"
;;

(* inline_lazy_force inlines the beginning of the code of Lazy.force. When
   the value argument is tagged as:
   - forward, take field 0
   - lazy, call the primitive that forces (without testing again the tag)
   - anything else, return it

   Using Lswitch below relies on the fact that the GC does not shortcut
   Forward(val_out_of_heap).
*)

let inline_lazy_force_cond arg loc =
  let idarg = Ident.create "lzarg" in
  let varg = Lvar idarg in
  let tag = Ident.create "tag" in
  let force_fun = Lazy.force code_force_lazy_block in
  Llet(Strict, Pgenval, idarg, arg,
       Llet(Alias, Pgenval, tag, Lprim(Pccall prim_obj_tag, [varg], loc),
            Lifthenelse(
              (* if (tag == Obj.forward_tag) then varg.(0) else ... *)
              Lprim(Pintcomp Ceq,
                    [Lvar tag; Lconst(Const_base(Const_int Obj.forward_tag))],
                    loc),
              Lprim(Pfield (0, Fld_na), [varg], loc), (*TODO: lazy field *)
              Lifthenelse(
                (* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *)
                Lprim(Pintcomp Ceq,
                      [Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))],
                      loc),
                Lapply{ap_should_be_tailcall=false;
                       ap_loc=loc;
                       ap_func=force_fun;
                       ap_args=[varg];
                       ap_inlined=Default_inline;
                       ap_specialised=Default_specialise},
                (* ... arg *)
                  varg))))

let inline_lazy_force_switch arg loc =
  let idarg = Ident.create "lzarg" in
  let varg = Lvar idarg in
  let force_fun = Lazy.force code_force_lazy_block in
  Llet(Strict, Pgenval, idarg, arg,
       Lifthenelse(
         Lprim(Pisint, [varg], loc), varg,
         (Lswitch
            (varg,
             { sw_numconsts = 0; sw_consts = [];
               sw_numblocks = 256;  (* PR#6033 - tag ranges from 0 to 255 *)
               sw_blocks =
                 [ (Obj.forward_tag, Lprim(Pfield (0, Fld_na) (* TODO: lazy*), [varg], loc));
                   (Obj.lazy_tag,
                    Lapply{ap_should_be_tailcall=false;
                           ap_loc=loc;
                           ap_func=force_fun;
                           ap_args=[varg];
                           ap_inlined=Default_inline;
                           ap_specialised=Default_specialise}) ];
               sw_failaction = Some varg }, loc ))))

let inline_lazy_force arg loc =
  if !Clflags.native_code then
    (* Lswitch generates compact and efficient native code *)
    inline_lazy_force_switch arg loc
  else
    (* generating bytecode: Lswitch would generate too many rather big
       tables (~ 250 elts); conditionals are better *)
    inline_lazy_force_cond arg loc

let make_lazy_matching def = function
    [] -> fatal_error "Matching.make_lazy_matching"
  | (arg,_mut) :: argl ->
      { cases = [];
        args =
          (inline_lazy_force arg Location.none, Strict) :: argl;
        default = make_default matcher_lazy def }

let divide_lazy p ctx pm =
  divide_line
    (filter_ctx p)
    make_lazy_matching
    get_arg_lazy
    p ctx pm

(* Matching against a tuple pattern *)


let get_args_tuple arity p rem = match p with
| {pat_desc = Tpat_any} -> omegas arity @ rem
| {pat_desc = Tpat_tuple args} ->
    args @ rem
| _ ->  assert false

let matcher_tuple arity p rem = match p.pat_desc with
| Tpat_or (_,_,_)     -> raise OrPat
| Tpat_any
| Tpat_var _ -> omegas arity @ rem
| Tpat_tuple args when List.length args = arity -> args @ rem
| _ ->  raise NoMatch

let make_tuple_matching loc arity def = function
    [] -> fatal_error "Matching.make_tuple_matching"
  | (arg, _mut) :: argl ->
      let rec make_args pos =
        if pos >= arity
        then argl
        else (Lprim(Pfield (pos, Fld_na (* TODO: tuple *)), [arg], loc), Alias) :: make_args (pos + 1) in
      {cases = []; args = make_args 0 ;
        default=make_default (matcher_tuple arity) def}


let divide_tuple arity p ctx pm =
  divide_line
    (filter_ctx p)
    (make_tuple_matching p.pat_loc arity)
    (get_args_tuple  arity) p ctx pm

(* Matching against a record pattern *)


let record_matching_line num_fields lbl_pat_list =
  let patv = Array.make num_fields omega in
  List.iter (fun (_, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list;
  Array.to_list patv

let get_args_record num_fields p rem = match p with
| {pat_desc=Tpat_any} ->
    record_matching_line num_fields [] @ rem
| {pat_desc=Tpat_record (lbl_pat_list,_)} ->
    record_matching_line num_fields lbl_pat_list @ rem
| _ -> assert false

let matcher_record num_fields p rem = match p.pat_desc with
| Tpat_or (_,_,_) -> raise OrPat
| Tpat_any
| Tpat_var _      ->
  record_matching_line num_fields [] @ rem
| Tpat_record ([], _) when num_fields = 0 -> rem
| Tpat_record ((_, lbl, _) :: _ as lbl_pat_list, _)
  when Array.length lbl.lbl_all = num_fields ->
    record_matching_line num_fields lbl_pat_list @ rem
| _ -> raise NoMatch

let make_record_matching loc all_labels def = function
    [] -> fatal_error "Matching.make_record_matching"
  | ((arg, _mut) :: argl) ->
      let rec make_args pos =
        if pos >= Array.length all_labels then argl else begin
          let lbl = all_labels.(pos) in
          let access =
            match lbl.lbl_repres with
            | Record_regular  -> 
              Lprim (Pfield (lbl.lbl_pos, Fld_record lbl.lbl_name), [arg], loc) 
            | Record_inlined _ ->
              Lprim (Pfield (lbl.lbl_pos, Fld_record_inline lbl.lbl_name), [arg], loc)
            | Record_unboxed _ -> arg
            | Record_float -> Lprim (Pfloatfield (lbl.lbl_pos, Fld_record lbl.lbl_name), [arg], loc)
            | Record_extension -> Lprim (Pfield (lbl.lbl_pos + 1, Fld_record_extension lbl.lbl_name), [arg], loc) 
          in
          let str =
            match lbl.lbl_mut with
              Immutable -> Alias
            | Mutable -> StrictOpt in
          (access, str) :: make_args(pos + 1)
        end in
      let nfields = Array.length all_labels in
      let def= make_default (matcher_record nfields) def in
      {cases = []; args = make_args 0 ; default = def}


let divide_record all_labels p ctx pm =
  let get_args = get_args_record (Array.length all_labels) in
  divide_line
    (filter_ctx p)
    (make_record_matching p.pat_loc all_labels)
    get_args
    p ctx pm

(* Matching against an array pattern *)

let get_key_array = function
  | {pat_desc=Tpat_array patl} -> List.length patl
  | _ -> assert false

let get_args_array p rem = match p with
| {pat_desc=Tpat_array patl} -> patl@rem
| _ -> assert false

let matcher_array len p rem = match p.pat_desc with
| Tpat_or (_,_,_) -> raise OrPat
| Tpat_array args when List.length args=len -> args @ rem
| Tpat_any -> Parmatch.omegas len @ rem
| _ -> raise NoMatch

let make_array_matching kind p def ctx = function
  | [] -> fatal_error "Matching.make_array_matching"
  | ((arg, _mut) :: argl) ->
      let len = get_key_array p in
      let rec make_args pos =
        if pos >= len
        then argl
        else (Lprim(Parrayrefu kind,
                    [arg; Lconst(Const_base(Const_int pos))],
                    p.pat_loc),
              StrictOpt) :: make_args (pos + 1) in
      let def = make_default (matcher_array len) def
      and ctx = filter_ctx p ctx in
      {pm={cases = []; args = make_args 0 ; default = def} ;
        ctx=ctx ;
        pat = normalize_pat p}

let divide_array kind ctx pm =
  divide
    (make_array_matching kind)
    (=) get_key_array get_args_array ctx pm


(*
   Specific string test sequence
   Will be called by the bytecode compiler, from bytegen.ml.
   The strategy is first dichotomic search (we perform 3-way tests
   with compare_string), then sequence of equality tests
   when there are less then T=strings_test_threshold static strings to match.

  Increasing T entails (slightly) less code, decreasing T
  (slightly) favors runtime speed.
  T=8 looks a decent tradeoff.
*)

(* Utilities *)

let strings_test_threshold = 8

let prim_string_notequal =
  Pccall(Primitive.simple
           ~name:"caml_string_notequal"
           ~arity:2
           ~alloc:false)

let prim_string_compare =
  Pccall(Primitive.simple
           ~name:"caml_string_compare"
           ~arity:2
           ~alloc:false)

let bind_sw arg k = match arg with
| Lvar _ -> k arg
| _ ->
    let id = Ident.create "switch" in
    Llet (Strict,Pgenval,id,arg,k (Lvar id))


(* Sequential equality tests *)

let make_string_test_sequence loc arg sw d =
  let d,sw = match d with
  | None ->
      begin match sw with
      | (_,d)::sw -> d,sw
      | [] -> assert false
      end
  | Some d -> d,sw in
  bind_sw arg
    (fun arg ->
      List.fold_right
        (fun (s,lam) k ->
          Lifthenelse
            (Lprim
               (prim_string_notequal,
                [arg; Lconst (Const_immstring s)], loc),
             k,lam))
        sw d)

let rec split k xs = match xs with
| [] -> assert false
| x0::xs ->
    if k <= 1 then [],x0,xs
    else
      let xs,y0,ys = split (k-2) xs in
      x0::xs,y0,ys

let zero_lam  = Lconst (Const_base (Const_int 0))

let tree_way_test loc arg lt eq gt =
  Lifthenelse
    (Lprim (Pintcomp Clt,[arg;zero_lam], loc),lt,
     Lifthenelse(Lprim (Pintcomp Clt,[zero_lam;arg], loc),gt,eq))

(* Dichotomic tree *)


let rec do_make_string_test_tree loc arg sw delta d =
  let len = List.length sw in
  if len <= strings_test_threshold+delta then
    make_string_test_sequence loc arg sw d
  else
    let lt,(s,act),gt = split len sw in
    bind_sw
      (Lprim
         (prim_string_compare,
          [arg; Lconst (Const_immstring s)], loc))
      (fun r ->
        tree_way_test loc r
          (do_make_string_test_tree loc arg lt delta d)
          act
          (do_make_string_test_tree loc arg gt delta d))

(* Entry point *)
let expand_stringswitch loc arg sw d = match d with
| None ->
    bind_sw arg
      (fun arg -> do_make_string_test_tree loc arg sw 0 None)
| Some e ->
    bind_sw arg
      (fun arg ->
        make_catch e
          (fun d -> do_make_string_test_tree loc arg sw 1 (Some d)))

(**********************)
(* Generic test trees *)
(**********************)

(* Sharing *)

(* Add handler, if shared *)
let handle_shared () =
  let hs = ref (fun x -> x) in
  let handle_shared act = match act with
  | Switch.Single act -> act
  | Switch.Shared act ->
      let i,h = make_catch_delayed act in
      let ohs = !hs in
      hs := (fun act -> h (ohs act)) ;
      make_exit i in
  hs,handle_shared


let share_actions_tree sw d =
  let store = StoreExp.mk_store () in
(* Default action is always shared *)
  let d =
    match d with
    | None -> None
    | Some d -> Some (store.Switch.act_store_shared d) in
(* Store all other actions *)
  let sw =
    List.map  (fun (cst,act) -> cst,store.Switch.act_store act) sw in

(* Retrieve all actions, including potential default *)
  let acts = store.Switch.act_get_shared () in

(* Array of actual actions *)
  let hs,handle_shared = handle_shared () in
  let acts = Array.map handle_shared acts in

(* Reconstruct default and switch list *)
  let d = match d with
  | None -> None
  | Some d -> Some (acts.(d)) in
  let sw = List.map (fun (cst,j) -> cst,acts.(j)) sw in
  !hs,sw,d

(* Note: dichotomic search requires sorted input with no duplicates *)
let rec uniq_lambda_list sw = match sw with
  | []|[_] -> sw
  | (c1,_ as p1)::((c2,_)::sw2 as sw1) ->
      if const_compare c1 c2 = 0 then uniq_lambda_list (p1::sw2)
      else p1::uniq_lambda_list sw1

let sort_lambda_list l =
  let l =
    List.stable_sort (fun (x,_) (y,_) -> const_compare x y) l in
  uniq_lambda_list l

let rec cut n l =
  if n = 0 then [],l
  else match l with
    [] -> raise (Invalid_argument "cut")
  | a::l -> let l1,l2 = cut (n-1) l in a::l1, l2

let rec do_tests_fail loc fail tst arg = function
  | [] -> fail
  | (c, act)::rem ->
      Lifthenelse
        (Lprim (tst, [arg ; Lconst (Const_base c)], loc),
         do_tests_fail loc fail tst arg rem,
         act)

let rec do_tests_nofail loc tst arg = function
  | [] -> fatal_error "Matching.do_tests_nofail"
  | [_,act] -> act
  | (c,act)::rem ->
      Lifthenelse
        (Lprim (tst, [arg ; Lconst (Const_base c)], loc),
         do_tests_nofail loc tst arg rem,
         act)

let make_test_sequence loc fail tst lt_tst arg const_lambda_list =
  let const_lambda_list = sort_lambda_list const_lambda_list in
  let hs,const_lambda_list,fail =
    share_actions_tree const_lambda_list fail in

  let rec make_test_sequence const_lambda_list =
    if List.length const_lambda_list >= 4 && lt_tst <> Pignore then
      split_sequence const_lambda_list
    else match fail with
    | None -> do_tests_nofail loc tst arg const_lambda_list
    | Some fail -> do_tests_fail loc fail tst arg const_lambda_list

  and split_sequence const_lambda_list =
    let list1, list2 =
      cut (List.length const_lambda_list / 2) const_lambda_list in
    Lifthenelse(Lprim(lt_tst,
                      [arg; Lconst(Const_base (fst(List.hd list2)))],
                      loc),
                make_test_sequence list1, make_test_sequence list2)
  in
  hs (make_test_sequence const_lambda_list)


module SArg = struct
  type primitive = Lambda.primitive

  let eqint = Pintcomp Ceq
  let neint = Pintcomp Cneq
  let leint = Pintcomp Cle
  let ltint = Pintcomp Clt
  let geint = Pintcomp Cge
  let gtint = Pintcomp Cgt

  type act = Lambda.lambda

  let make_prim p args = Lprim (p,args,Location.none)
  let make_offset arg n = match n with
  | 0 -> arg
  | _ -> Lprim (Poffsetint n,[arg],Location.none)

  let bind arg body =
    let newvar,newarg = match arg with
    | Lvar v -> v,arg
    | _      ->
        let newvar = Ident.create "switcher" in
        newvar,Lvar newvar in
    bind Alias newvar arg (body newarg)
  let make_const i = Lconst (Const_base (Const_int i))
  let make_isout h arg = Lprim (Pisout, [h ; arg],Location.none)
  let make_isin h arg = Lprim (Pnot,[make_isout h arg],Location.none)
  let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot)
  let make_switch loc arg cases acts =
    let l = ref [] in
    for i = Array.length cases-1 downto 0 do
      l := (i,acts.(cases.(i))) ::  !l
    done ;
    Lswitch(arg,
            {sw_numconsts = Array.length cases ; sw_consts = !l ;
             sw_numblocks = 0 ; sw_blocks =  []  ;
             sw_failaction = None}, loc)
  let make_catch  = make_catch_delayed
  let make_exit = make_exit

end

(* Action sharing for Lswitch argument *)
let share_actions_sw sw =
(* Attempt sharing on all actions *)
  let store = StoreExp.mk_store () in
  let fail = match sw.sw_failaction with
  | None -> None
  | Some fail ->
      (* Fail is translated to exit, whatever happens *)
      Some (store.Switch.act_store_shared fail) in
  let consts =
    List.map
      (fun (i,e) -> i,store.Switch.act_store e)
      sw.sw_consts
  and blocks =
    List.map
      (fun (i,e) -> i,store.Switch.act_store e)
      sw.sw_blocks in
  let acts = store.Switch.act_get_shared () in
  let hs,handle_shared = handle_shared () in
  let acts = Array.map handle_shared acts in
  let fail = match fail with
  | None -> None
  | Some fail -> Some (acts.(fail)) in
  !hs,
  { sw with
    sw_consts = List.map (fun (i,j) -> i,acts.(j)) consts ;
    sw_blocks = List.map (fun (i,j) -> i,acts.(j)) blocks ;
    sw_failaction = fail; }

(* Reintroduce fail action in switch argument,
   for the sake of avoiding carrying over huge switches *)

let reintroduce_fail sw = match sw.sw_failaction with
| None ->
    let t = Hashtbl.create 17 in
    let seen (_,l) = match as_simple_exit l with
    | Some i ->
        let old = try Hashtbl.find t i with Not_found -> 0 in
        Hashtbl.replace t i (old+1)
    | None -> () in
    List.iter seen sw.sw_consts ;
    List.iter seen sw.sw_blocks ;
    let i_max = ref (-1)
    and max = ref (-1) in
    Hashtbl.iter
      (fun i c ->
        if c > !max then begin
          i_max := i ;
          max := c
        end) t ;
    if !max >= 3 then
      let default = !i_max in
      let remove =
        List.filter
          (fun (_,lam) -> match as_simple_exit lam with
          | Some j -> j <> default
          | None -> true) in
      {sw with
       sw_consts = remove sw.sw_consts ;
       sw_blocks = remove sw.sw_blocks ;
       sw_failaction = Some (make_exit default)}
    else sw
| Some _ -> sw


module Switcher = Switch.Make(SArg)
open Switch

let rec last def = function
  | [] -> def
  | [x,_] -> x
  | _::rem -> last def rem

let get_edges low high l = match l with
| [] -> low, high
| (x,_)::_ -> x, last high l


let as_interval_canfail fail low high l =
  let store = StoreExp.mk_store () in

  let do_store _tag act =

    let i =  store.act_store act in
(*
    eprintf "STORE [%s] %i %s\n" tag i (string_of_lam act) ;
*)
    i in

  let rec nofail_rec cur_low cur_high cur_act = function
    | [] ->
        if cur_high = high then
          [cur_low,cur_high,cur_act]
        else
          [(cur_low,cur_high,cur_act) ; (cur_high+1,high, 0)]
    | ((i,act_i)::rem) as all ->
        let act_index = do_store "NO" act_i in
        if cur_high+1= i then
          if act_index=cur_act then
            nofail_rec cur_low i cur_act rem
          else if act_index=0 then
            (cur_low,i-1, cur_act)::fail_rec i i rem
          else
            (cur_low, i-1, cur_act)::nofail_rec i i act_index rem
        else if act_index = 0 then
          (cur_low, cur_high, cur_act)::
          fail_rec (cur_high+1) (cur_high+1) all
        else
          (cur_low, cur_high, cur_act)::
          (cur_high+1,i-1,0)::
          nofail_rec i i act_index rem

  and fail_rec cur_low cur_high = function
    | [] -> [(cur_low, cur_high, 0)]
    | (i,act_i)::rem ->
        let index = do_store "YES" act_i in
        if index=0 then fail_rec cur_low i rem
        else
          (cur_low,i-1,0)::
          nofail_rec i i index rem in

  let init_rec = function
    | [] -> [low,high,0]
    | (i,act_i)::rem ->
        let index = do_store "INIT" act_i in
        if index=0 then
          fail_rec low i rem
        else
          if low < i then
            (low,i-1,0)::nofail_rec i i index rem
          else
            nofail_rec i i index rem in

  assert (do_store "FAIL" fail = 0) ; (* fail has action index 0 *)
  let r = init_rec l in
  Array.of_list r,  store

let as_interval_nofail l =
  let store = StoreExp.mk_store () in
  let rec some_hole = function
    | []|[_] -> false
    | (i,_)::((j,_)::_ as rem) ->
        j > i+1 || some_hole rem in
  let rec i_rec cur_low cur_high cur_act = function
    | [] ->
        [cur_low, cur_high, cur_act]
    | (i,act)::rem ->
        let act_index = store.act_store act in
        if act_index = cur_act then
          i_rec cur_low i cur_act rem
        else
          (cur_low, cur_high, cur_act)::
          i_rec i i act_index rem in
  let inters = match l with
  | (i,act)::rem ->
      let act_index =
        (* In case there is some hole and that a switch is emitted,
           action 0 will be used as the action of unreachable
           cases (cf. switch.ml, make_switch).
           Hence, this action will be shared *)
        if some_hole rem then
          store.act_store_shared act
        else
          store.act_store act in
      assert (act_index = 0) ;
      i_rec i i act_index rem
  | _ -> assert false in

  Array.of_list inters, store


let sort_int_lambda_list l =
  List.sort
    (fun (i1,_) (i2,_) ->
      if i1 < i2 then -1
      else if i2 < i1 then 1
      else 0)
    l

let as_interval fail low high l =
  let l = sort_int_lambda_list l in
  get_edges low high l,
  (match fail with
  | None -> as_interval_nofail l
  | Some act -> as_interval_canfail act low high l)

let call_switcher loc fail arg low high int_lambda_list =
  let edges, (cases, actions) =
    as_interval fail low high int_lambda_list in
  Switcher.zyva loc edges arg cases actions


let rec list_as_pat = function
  | [] -> fatal_error "Matching.list_as_pat"
  | [pat] -> pat
  | pat::rem ->
      {pat with pat_desc = Tpat_or (pat,list_as_pat rem,None)}


let complete_pats_constrs = function
  | p::_ as pats ->
      List.map
        (pat_of_constr p)
        (complete_constrs p (List.map get_key_constr pats))
  | _ -> assert false


(*
     Following two ``failaction'' function compute n, the trap handler
    to jump to in case of failure of elementary tests
*)

let mk_failaction_neg partial ctx def = match partial with
| Partial ->
    begin match def with
    | (_,idef)::_ ->
        Some (Lstaticraise (idef,[])),jumps_singleton idef ctx
    | [] ->
       (* Act as Total, this means
          If no appropriate default matrix exists,
          then this switch cannot fail *)
        None, jumps_empty
    end
| Total ->
    None, jumps_empty



(* In line with the article and simpler than before *)
let mk_failaction_pos partial seen ctx defs  =
  if dbg then begin
    prerr_endline "**POS**" ;
    pretty_def defs ;
    ()
  end ;
  let rec scan_def env to_test defs = match to_test,defs with
  | ([],_)|(_,[]) ->
      List.fold_left
        (fun  (klist,jumps) (pats,i)->
          let action = Lstaticraise (i,[]) in
          let klist =
            List.fold_right
              (fun pat r -> (get_key_constr pat,action)::r)
              pats klist
          and jumps =
            jumps_add i (ctx_lub (list_as_pat pats) ctx) jumps in
          klist,jumps)
        ([],jumps_empty) env
  | _,(pss,idef)::rem ->
      let now, later =
        List.partition
          (fun (_p,p_ctx) -> ctx_match p_ctx pss) to_test in
      match now with
      | [] -> scan_def env to_test rem
      | _  -> scan_def ((List.map fst now,idef)::env) later rem in

  let fail_pats = complete_pats_constrs seen in
  if List.length fail_pats < 32 then begin
    let fail,jmps =
      scan_def
        []
        (List.map
           (fun pat -> pat, ctx_lub pat ctx)
           fail_pats)
        defs in
    if dbg then begin
      eprintf "POSITIVE JUMPS [%i]:\n" (List.length fail_pats);
      pretty_jumps jmps
    end ;
    None,fail,jmps
  end else begin (* Too many non-matched constructors -> reduced information *)
    if dbg then eprintf "POS->NEG!!!\n%!" ;
    let fail,jumps =  mk_failaction_neg partial ctx defs in
    if dbg then
      eprintf "FAIL: %s\n"
        (match fail with
        | None -> "<none>"
        | Some lam -> string_of_lam lam) ;
    fail,[],jumps
  end

let combine_constant loc arg cst partial ctx def
    (const_lambda_list, total, _pats) =
  let fail, local_jumps =
    mk_failaction_neg partial ctx def in
  let lambda1 =
    match cst with
    | Const_int _ ->
        let int_lambda_list =
          List.map (function Const_int n, l -> n,l | _ -> assert false)
            const_lambda_list in
        call_switcher loc fail arg min_int max_int int_lambda_list
    | Const_char _ ->
        let int_lambda_list =
          List.map (function Const_char c, l -> (Char.code c, l)
            | _ -> assert false)
            const_lambda_list in
        call_switcher loc fail arg 0 255 int_lambda_list
    | Const_string _ ->
(* Note as the bytecode compiler may resort to dichotomic search,
   the clauses of stringswitch  are sorted with duplicates removed.
   This partly applies to the native code compiler, which requires
   no duplicates *)
        let const_lambda_list = sort_lambda_list const_lambda_list in
        let sw =
          List.map
            (fun (c,act) -> match c with
            | Const_string (s,_) -> s,act
            | _ -> assert false)
            const_lambda_list in
        let hs,sw,fail = share_actions_tree sw fail in
        hs (Lstringswitch (arg,sw,fail,loc))
    | Const_float _ ->
        make_test_sequence loc
          fail
          (Pfloatcomp Cneq) (Pfloatcomp Clt)
          arg const_lambda_list
    | Const_int32 _ ->
        make_test_sequence loc
          fail
          (Pbintcomp(Pint32, Cneq)) (Pbintcomp(Pint32, Clt))
          arg const_lambda_list
    | Const_int64 _ ->
        make_test_sequence loc
          fail
          (Pbintcomp(Pint64, Cneq)) (Pbintcomp(Pint64, Clt))
          arg const_lambda_list
    | Const_nativeint _ ->
        make_test_sequence loc
          fail
          (Pbintcomp(Pnativeint, Cneq)) (Pbintcomp(Pnativeint, Clt))
          arg const_lambda_list
  in lambda1,jumps_union local_jumps total



let split_cases tag_lambda_list =
  let rec split_rec = function
      [] -> ([], [])
    | (cstr, act) :: rem ->
        let (consts, nonconsts) = split_rec rem in
        match cstr with
          Cstr_constant n -> ((n, act) :: consts, nonconsts)
        | Cstr_block n    -> (consts, (n, act) :: nonconsts)
        | Cstr_unboxed    -> (consts, (0, act) :: nonconsts)
        | Cstr_extension _ -> assert false in
  let const, nonconst = split_rec tag_lambda_list in
  sort_int_lambda_list const,
  sort_int_lambda_list nonconst

let split_extension_cases tag_lambda_list =
  let rec split_rec = function
      [] -> ([], [])
    | (cstr, act) :: rem ->
        let (consts, nonconsts) = split_rec rem in
        match cstr with
          Cstr_extension(path, true) -> ((path, act) :: consts, nonconsts)
        | Cstr_extension(path, false) -> (consts, (path, act) :: nonconsts)
        | _ -> assert false in
  split_rec tag_lambda_list


let combine_constructor loc arg ex_pat cstr partial ctx def
    (tag_lambda_list, total1, pats) =
  if cstr.cstr_consts < 0 then begin
    (* Special cases for extensions *)
    let fail, local_jumps =
      mk_failaction_neg partial ctx def in
    let lambda1 =
      let consts, nonconsts = split_extension_cases tag_lambda_list in
      let default, consts, nonconsts =
        match fail with
        | None ->
            begin match consts, nonconsts with
            | _, (_, act)::rem -> act, consts, rem
            | (_, act)::rem, _ -> act, rem, nonconsts
            | _ -> assert false
            end
        | Some fail -> fail, consts, nonconsts in
      let nonconst_lambda =
        match nonconsts with
          [] -> default
        | _ ->
            let tag = Ident.create "tag" in
            let tests =
              List.fold_right
                (fun (path, act) rem ->
                   let ext = transl_extension_path ex_pat.pat_env path in
                   Lifthenelse(Lprim(Pintcomp Ceq, [Lvar tag; ext], loc),
                               act, rem))
                nonconsts
                default
            in
              Llet(Alias, Pgenval,tag, Lprim(Pfield (0, Fld_na), [arg], loc), tests)
      in
        List.fold_right
          (fun (path, act) rem ->
             let ext = transl_extension_path ex_pat.pat_env path in
             Lifthenelse(Lprim(Pintcomp Ceq, [arg; ext], loc),
                         act, rem))
          consts
          nonconst_lambda
    in
    lambda1, jumps_union local_jumps total1
  end else begin
    (* Regular concrete type *)
    let ncases = List.length tag_lambda_list
    and nconstrs =  cstr.cstr_consts + cstr.cstr_nonconsts in
    let sig_complete = ncases = nconstrs in
    let fail_opt,fails,local_jumps =
      if sig_complete then None,[],jumps_empty
      else
        mk_failaction_pos partial pats ctx def in

    let tag_lambda_list = fails @ tag_lambda_list in
    let (consts, nonconsts) = split_cases tag_lambda_list in
    let lambda1 =
      match fail_opt,same_actions tag_lambda_list with
      | None,Some act -> act (* Identical actions, no failure *)
      | _ ->
          match
            (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts)
          with
          | (1, 1, [0, act1], [0, act2]) ->
           (* Typically, match on lists, will avoid isint primitive in that
              case *)
              let arg = 
                if !Clflags.bs_only && Datarepr.constructor_has_optional_shape cstr then
                  Lprim(is_none_bs_primitve , [arg], loc)
                else arg
              in 
                Lifthenelse(arg, act2, act1)
          | (2,0, [(i1,act1); (_,act2)],[]) ->
            if i1 = 0 then Lifthenelse(arg, act2, act1)
            else Lifthenelse (arg,act1,act2)                
          | (n,0,_,[])  -> (* The type defines constant constructors only *)
              call_switcher loc fail_opt arg 0 (n-1) consts
          | (n, _, _, _) ->
              let act0  =
                (* = Some act when all non-const constructors match to act *)
                match fail_opt,nonconsts with
                | Some a,[] -> Some a
                | Some _,_ ->
                    if List.length nonconsts = cstr.cstr_nonconsts then
                      same_actions nonconsts
                    else None
                | None,_ -> same_actions nonconsts in
              match act0 with
              | Some act ->
                  Lifthenelse
                    (Lprim (Pisint, [arg], loc),
                     call_switcher loc
                       fail_opt arg
                       0 (n-1) consts,
                     act)
(* Emit a switch, as bytecode implements this sophisticated instruction *)
              | None ->
                  let sw =
                    {sw_numconsts = cstr.cstr_consts; sw_consts = consts;
                     sw_numblocks = cstr.cstr_nonconsts; sw_blocks = nonconsts;
                     sw_failaction = fail_opt} in
                  let hs,sw = share_actions_sw sw in
                  let sw = reintroduce_fail sw in
                  hs (Lswitch (arg,sw,loc)) in
    lambda1, jumps_union local_jumps total1
  end

let make_test_sequence_variant_constant fail arg int_lambda_list =
  let _, (cases, actions) =
    as_interval fail min_int max_int int_lambda_list in
  Switcher.test_sequence arg cases actions

let call_switcher_variant_constant loc fail arg int_lambda_list =
  call_switcher loc fail arg min_int max_int int_lambda_list


let call_switcher_variant_constr loc fail arg int_lambda_list =
  let v = Ident.create "variant" in
  Llet(Alias, Pgenval, v, Lprim(Pfield (0, Fld_na), [arg], loc),
       call_switcher loc
         fail (Lvar v) min_int max_int int_lambda_list)

let combine_variant loc row arg partial ctx def
                    (tag_lambda_list, total1, _pats) =
  let row = Btype.row_repr row in
  let num_constr = ref 0 in
  if row.row_closed then
    List.iter
      (fun (_, f) ->
        match Btype.row_field_repr f with
          Rabsent | Reither(true, _::_, _, _) -> ()
        | _ -> incr num_constr)
      row.row_fields
  else
    num_constr := max_int;
  let test_int_or_block arg if_int if_block =
    Lifthenelse(Lprim (Pisint, [arg], loc), if_int, if_block) in
  let sig_complete =  List.length tag_lambda_list = !num_constr
  and one_action = same_actions tag_lambda_list in
  let fail, local_jumps =
    if
      sig_complete  || (match partial with Total -> true | _ -> false)
    then
      None, jumps_empty
    else
      mk_failaction_neg partial ctx def in
  let (consts, nonconsts) = split_cases tag_lambda_list in
  let lambda1 = match fail, one_action with
  | None, Some act -> act
  | _,_ ->
      match (consts, nonconsts) with
      | ([_, act1], [_, act2]) when fail=None ->
          test_int_or_block arg act1 act2
      | (_, []) -> (* One can compare integers and pointers *)
          make_test_sequence_variant_constant fail arg consts
      | ([], _) ->
          let lam = call_switcher_variant_constr loc
              fail arg nonconsts in
          (* One must not dereference integers *)
          begin match fail with
          | None -> lam
          | Some fail -> test_int_or_block arg fail lam
          end
      | (_, _) ->
          let lam_const =
            call_switcher_variant_constant loc
              fail arg consts
          and lam_nonconst =
            call_switcher_variant_constr loc
              fail arg nonconsts in
          test_int_or_block arg lam_const lam_nonconst
  in
  lambda1, jumps_union local_jumps total1


let combine_array loc arg kind partial ctx def
    (len_lambda_list, total1, _pats)  =
  let fail, local_jumps = mk_failaction_neg partial  ctx def in
  let lambda1 =
    let newvar = Ident.create "len" in
    let switch =
      call_switcher loc
        fail (Lvar newvar)
        0 max_int len_lambda_list in
    bind
      Alias newvar (Lprim(Parraylength kind, [arg], loc)) switch in
  lambda1, jumps_union local_jumps total1

(* Insertion of debugging events *)

let rec event_branch repr lam =
  begin match lam, repr with
    (_, None) ->
      lam
  | (Levent(lam', ev), Some r) ->
      incr r;
      Levent(lam', {lev_loc = ev.lev_loc;
                    lev_kind = ev.lev_kind;
                    lev_repr = repr;
                    lev_env = ev.lev_env})
  | (Llet(str, k, id, lam, body), _) ->
      Llet(str, k, id, lam, event_branch repr body)
  | Lstaticraise _,_ -> lam
  | (_, Some _) ->
      Printlambda.lambda Format.str_formatter lam ;
      fatal_error
        ("Matching.event_branch: "^Format.flush_str_formatter ())
  end


(*
   This exception is raised when the compiler cannot produce code
   because control cannot reach the compiled clause,

   Unused is raised initially in compile_test.

   compile_list (for compiling switch results) catch Unused

   comp_match_handlers (for compiling splitted matches)
   may reraise Unused


*)

exception Unused

let compile_list compile_fun division =

  let rec c_rec totals = function
  | [] -> [], jumps_unions totals, []
  | (key, cell) :: rem ->
      begin match cell.ctx with
      | [] -> c_rec totals rem
      | _  ->
          try
            let (lambda1, total1) = compile_fun cell.ctx cell.pm in
            let c_rem, total, new_pats =
              c_rec
                (jumps_map ctx_combine total1::totals) rem in
            ((key,lambda1)::c_rem), total, (cell.pat::new_pats)
          with
          | Unused -> c_rec totals rem
      end in
  c_rec [] division


let compile_orhandlers compile_fun lambda1 total1 ctx to_catch =
  let rec do_rec r total_r = function
    | [] -> r,total_r
    | (mat,i,vars,pm)::rem ->
        begin try
          let ctx = select_columns mat ctx in
          let handler_i, total_i =
            compile_fun ctx pm in
          match raw_action r with
          | Lstaticraise (j,args) ->
              if i=j then
                List.fold_right2 (bind Alias) vars args handler_i,
                jumps_map (ctx_rshift_num (ncols mat)) total_i
              else
                do_rec r total_r rem
          | _ ->
              do_rec
                (Lstaticcatch (r,(i,vars), handler_i))
                (jumps_union
                   (jumps_remove i total_r)
                   (jumps_map (ctx_rshift_num (ncols mat)) total_i))
              rem
        with
        | Unused ->
            do_rec (Lstaticcatch (r, (i,vars), lambda_unit)) total_r rem
        end in
  do_rec lambda1 total1 to_catch


let compile_test compile_fun partial divide combine ctx to_match =
  let division = divide ctx to_match in
  let c_div = compile_list compile_fun division in
  match c_div with
  | [],_,_ ->
     begin match mk_failaction_neg partial ctx to_match.default with
     | None,_ -> raise Unused
     | Some l,total -> l,total
     end
  | _ ->
      combine ctx to_match.default c_div

(* Attempt to avoid some useless bindings by lowering them *)

(* Approximation of v present in lam *)
let rec approx_present v = function
  | Lconst _ -> false
  | Lstaticraise (_,args) ->
      List.exists (fun lam -> approx_present v lam) args
  | Lprim (_,args,_) ->
      List.exists (fun lam -> approx_present v lam) args
  | Llet (Alias, _k, _, l1, l2) ->
      approx_present v l1 || approx_present v l2
  | Lvar vv -> Ident.same v vv
  | _ -> true

let rec lower_bind v arg lam = match lam with
| Lifthenelse (cond, ifso, ifnot) ->
    let pcond = approx_present v cond
    and pso = approx_present v ifso
    and pnot = approx_present v ifnot in
    begin match pcond, pso, pnot with
    | false, false, false -> lam
    | false, true, false ->
        Lifthenelse (cond, lower_bind v arg ifso, ifnot)
    | false, false, true ->
        Lifthenelse (cond, ifso, lower_bind v arg ifnot)
    | _,_,_ -> bind Alias v arg lam
    end
| Lswitch (ls,({sw_consts=[i,act] ; sw_blocks = []} as sw), loc)
    when not (approx_present v ls) ->
      Lswitch (ls, {sw with sw_consts = [i,lower_bind v arg act]}, loc)
| Lswitch (ls,({sw_consts=[] ; sw_blocks = [i,act]} as sw), loc)
    when not (approx_present v ls) ->
      Lswitch (ls, {sw with sw_blocks = [i,lower_bind v arg act]}, loc)
| Llet (Alias, k, vv, lv, l) ->
    if approx_present v lv then
      bind Alias v arg lam
    else
      Llet (Alias, k, vv, lv, lower_bind v arg l)
| _ ->
    bind Alias v arg lam

let bind_check str v arg lam = match str,arg with
| _, Lvar _ ->bind str v arg lam
| Alias,_ -> lower_bind v arg lam
| _,_     -> bind str v arg lam

let comp_exit ctx m = match m.default with
| (_,i)::_ -> Lstaticraise (i,[]), jumps_singleton i ctx
| _        -> fatal_error "Matching.comp_exit"



let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs =
  match next_matchs with
  | [] -> comp_fun partial ctx arg first_match
  | rem ->
      let rec c_rec body total_body = function
        | [] -> body, total_body
        (* Hum, -1 means never taken
        | (-1,pm)::rem -> c_rec body total_body rem *)
        | (i,pm)::rem ->
            let ctx_i,total_rem = jumps_extract i total_body in
            begin match ctx_i with
            | [] -> c_rec body total_body rem
            | _ ->
                try
                  let li,total_i =
                    comp_fun
                      (match rem with [] -> partial | _ -> Partial)
                      ctx_i arg pm in
                  c_rec
                    (Lstaticcatch (body,(i,[]),li))
                    (jumps_union total_i total_rem)
                    rem
                with
                | Unused ->
                    c_rec (Lstaticcatch (body,(i,[]),lambda_unit))
                      total_rem  rem
            end in
   try
      let first_lam,total = comp_fun Partial ctx arg first_match in
      c_rec first_lam total rem
   with Unused -> match next_matchs with
   | [] -> raise Unused
   | (_,x)::xs ->  comp_match_handlers comp_fun partial ctx arg x xs

(* To find reasonable names for variables *)

let rec name_pattern default = function
    (pat :: _, _) :: rem ->
      begin match pat.pat_desc with
        Tpat_var (id, _) -> id
      | Tpat_alias(_, id, _) -> id
      | _ -> name_pattern default rem
      end
  | _ -> Ident.create default

let arg_to_var arg cls = match arg with
| Lvar v -> v,arg
| _ ->
    let v = name_pattern "match" cls in
    v,Lvar v


(*
  The main compilation function.
   Input:
      repr=used for inserting debug events
      partial=exhaustiveness information from Parmatch
      ctx=a context
      m=a pattern matching

   Output: a lambda term, a jump summary {..., exit number -> context, .. }
*)

let rec compile_match repr partial ctx m = match m with
| { cases = []; args = [] } -> comp_exit ctx m
| { cases = ([], action) :: rem } ->
    if is_guarded action then begin
      let (lambda, total) =
        compile_match None partial ctx { m with cases = rem } in
      event_branch repr (patch_guarded lambda action), total
    end else
      (event_branch repr action, jumps_empty)
| { args = (arg, str)::argl } ->
    let v,newarg = arg_to_var arg m.cases in
    let first_match,rem =
      split_precompile (Some v)
        { m with args = (newarg, Alias) :: argl } in
    let (lam, total) =
      comp_match_handlers
        ((if dbg then do_compile_matching_pr else do_compile_matching) repr)
        partial ctx newarg first_match rem in
    bind_check str v arg lam, total
| _ -> assert false


(* verbose version of do_compile_matching, for debug *)

and do_compile_matching_pr repr partial ctx arg x =
  prerr_string "COMPILE: " ;
  prerr_endline (match partial with Partial -> "Partial" | Total -> "Total") ;
  prerr_endline "MATCH" ;
  pretty_precompiled x ;
  prerr_endline "CTX" ;
  pretty_ctx ctx ;
  let (_, jumps) as r =  do_compile_matching repr partial ctx arg x in
  prerr_endline "JUMPS" ;
  pretty_jumps jumps ;
  r

and do_compile_matching repr partial ctx arg pmh = match pmh with
| Pm pm ->
  let pat = what_is_cases pm.cases in
  begin match pat.pat_desc with
  | Tpat_any ->
      compile_no_test
        divide_var ctx_rshift repr partial ctx pm
  | Tpat_tuple patl ->
      compile_no_test
        (divide_tuple (List.length patl) (normalize_pat pat)) ctx_combine
        repr partial ctx pm
  | Tpat_record ((_, lbl,_)::_,_) ->
      compile_no_test
        (divide_record lbl.lbl_all (normalize_pat pat))
        ctx_combine repr partial ctx pm
  | Tpat_constant cst ->
      compile_test
        (compile_match repr partial) partial
        divide_constant
        (combine_constant pat.pat_loc arg cst partial)
        ctx pm
  | Tpat_construct (_, cstr, _) ->
      compile_test
        (compile_match repr partial) partial
        divide_constructor
        (combine_constructor pat.pat_loc arg pat cstr partial)
        ctx pm
  | Tpat_array _ ->
      let kind = Typeopt.array_pattern_kind pat in
      compile_test (compile_match repr partial) partial
        (divide_array kind) (combine_array pat.pat_loc arg kind partial)
        ctx pm
  | Tpat_lazy _ ->
      compile_no_test
        (divide_lazy (normalize_pat pat))
        ctx_combine repr partial ctx pm
  | Tpat_variant(_, _, row) ->
      compile_test (compile_match repr partial) partial
        (divide_variant !row)
        (combine_variant pat.pat_loc !row arg partial)
        ctx pm
  | _ -> assert false
  end
| PmVar {inside=pmh ; var_arg=arg} ->
    let lam, total =
      do_compile_matching repr partial (ctx_lshift ctx) arg pmh in
    lam, jumps_map ctx_rshift total
| PmOr {body=body ; handlers=handlers} ->
    let lam, total = compile_match repr partial ctx body in
    compile_orhandlers (compile_match repr partial) lam total ctx handlers

and compile_no_test divide up_ctx repr partial ctx to_match =
  let {pm=this_match ; ctx=this_ctx } = divide ctx to_match in
  let lambda,total = compile_match repr partial this_ctx this_match in
  lambda, jumps_map up_ctx total




(* The entry points *)

(*
   If there is a guard in a matching or a lazy pattern,
   then set exhaustiveness info to Partial.
   (because of side effects, assume the worst).

   Notice that exhaustiveness information is trusted by the compiler,
   that is, a match flagged as Total should not fail at runtime.
   More specifically, for instance if match y with x::_ -> x is flagged
   total (as it happens during JoCaml compilation) then y cannot be []
   at runtime. As a consequence, the static Total exhaustiveness information
   have to be downgraded to Partial, in the dubious cases where guards
   or lazy pattern execute arbitrary code that may perform side effects
   and change the subject values.
LM:
   Lazy pattern was PR#5992, initial patch by lpw25.
   I have  generalized the patch, so as to also find mutable fields.
*)

let find_in_pat pred =
  let rec find_rec p =
    pred p.pat_desc ||
    begin match p.pat_desc with
    | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) | Tpat_lazy p ->
        find_rec p
    | Tpat_tuple ps|Tpat_construct (_,_,ps) | Tpat_array ps ->
        List.exists find_rec ps
    | Tpat_record (lpats,_) ->
        List.exists
          (fun (_, _, p) -> find_rec p)
          lpats
    | Tpat_or (p,q,_) ->
        find_rec p || find_rec q
    | Tpat_constant _ | Tpat_var _
    | Tpat_any | Tpat_variant (_,None,_) -> false
  end in
  find_rec

let is_lazy_pat = function
  | Tpat_lazy _ -> true
  | Tpat_alias _ | Tpat_variant _ | Tpat_record _
  | Tpat_tuple _|Tpat_construct _ | Tpat_array _
  | Tpat_or _ | Tpat_constant _ | Tpat_var _ | Tpat_any
      -> false

let is_lazy p = find_in_pat is_lazy_pat p

let have_mutable_field p = match p with
| Tpat_record (lps,_) ->
    List.exists
      (fun (_,lbl,_) ->
        match lbl.Types.lbl_mut with
        | Mutable -> true
        | Immutable -> false)
      lps
| Tpat_alias _ | Tpat_variant _ | Tpat_lazy _
| Tpat_tuple _|Tpat_construct _ | Tpat_array _
| Tpat_or _
| Tpat_constant _ | Tpat_var _ | Tpat_any
  -> false

let is_mutable p = find_in_pat have_mutable_field p

(* Downgrade Total when
   1. Matching accesses some mutable fields;
   2. And there are  guards or lazy patterns.
*)

let check_partial is_mutable is_lazy pat_act_list = function
  | Partial -> Partial
  | Total ->
      if
        pat_act_list = [] ||  (* allow empty case list *)
        List.exists
          (fun (pats, lam) ->
            is_mutable pats && (is_guarded lam || is_lazy pats))
          pat_act_list
      then Partial
      else Total

let check_partial_list =
  check_partial (List.exists is_mutable) (List.exists is_lazy)
let check_partial = check_partial is_mutable is_lazy

(* have toplevel handler when appropriate *)

let start_ctx n = [{left=[] ; right = omegas n}]

let check_total total lambda i handler_fun =
  if jumps_is_empty total then
    lambda
  else begin
    Lstaticcatch(lambda, (i,[]), handler_fun())
  end

let compile_matching repr handler_fun arg pat_act_list partial =
  let partial = check_partial pat_act_list partial in
  match partial with
  | Partial ->
      let raise_num = next_raise_count () in
      let pm =
        { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
          args = [arg, Strict] ;
          default = [[[omega]],raise_num]} in
      begin try
        let (lambda, total) = compile_match repr partial (start_ctx 1) pm in
        check_total total lambda raise_num handler_fun
      with
      | Unused -> assert false (* ; handler_fun() *)
      end
  | Total ->
      let pm =
        { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
          args = [arg, Strict] ;
          default = []} in
      let (lambda, total) = compile_match repr partial (start_ctx 1) pm in
      assert (jumps_is_empty total) ;
      lambda


let partial_function loc () =
  (* [Location.get_pos_info] is too expensive *)
  let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in
     
  let fname = 
    Filename.basename fname
  in   
    
  Lprim(Praise Raise_regular, [Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None),
          [transl_normal_path Predef.path_match_failure;
           Lconst(Const_block(0, Lambda.Blk_tuple,
              [Const_base(Const_string (fname, None));
               Const_base(Const_int line);
               Const_base(Const_int char)]))], loc)], loc)

let for_function loc repr param pat_act_list partial =
  compile_matching repr (partial_function loc) param pat_act_list partial

(* In the following two cases, exhaustiveness info is not available! *)
let for_trywith param pat_act_list =
  compile_matching None
    (fun () -> Lprim(Praise Raise_reraise, [param], Location.none))
    param pat_act_list Partial

let simple_for_let loc param pat body =
  compile_matching None (partial_function loc) param [pat, body] Partial


(* Optimize binding of immediate tuples

   The goal of the implementation of 'for_let' below, which replaces
   'simple_for_let', is to avoid tuple allocation in cases such as
   this one:

     let (x,y) =
        let foo = ... in
        if foo then (1, 2) else (3,4)
     in bar

   The compiler easily optimizes the simple `let (x,y) = (1,2) in ...`
   case (call to Matching.for_multiple_match from Translcore), but
   didn't optimize situations where the rhs tuples are hidden under
   a more complex context.

   The idea comes from Alain Frisch who suggested and implemented
   the following compilation method, based on Lassign:

     let x = dummy in let y = dummy in
     begin
      let foo = ... in
      if foo then
        (let x1 = 1 in let y1 = 2 in x <- x1; y <- y1)
      else
        (let x2 = 3 in let y2 = 4 in x <- x2; y <- y2)
     end;
     bar

   The current implementation from Gabriel Scherer uses Lstaticcatch /
   Lstaticraise instead:

     catch
       let foo = ... in
       if foo then
         (let x1 = 1 in let y1 = 2 in exit x1 y1)
       else
        (let x2 = 3 in let y2 = 4 in exit x2 y2)
     with x y ->
       bar

   The catch/exit is used to avoid duplication of the let body ('bar'
   in the example), on 'if' branches for example; it is useless for
   linear contexts such as 'let', but we don't need to be careful to
   generate nice code because Simplif will remove such useless
   catch/exit.
*)

let rec map_return f = function
  | Llet (str, k, id, l1, l2) -> Llet (str, k, id, l1, map_return f l2)
  | Lletrec (l1, l2) -> Lletrec (l1, map_return f l2)
  | Lifthenelse (lcond, lthen, lelse) ->
      Lifthenelse (lcond, map_return f lthen, map_return f lelse)
  | Lsequence (l1, l2) -> Lsequence (l1, map_return f l2)
  | Levent (l, ev) -> Levent (map_return f l, ev)
  | Ltrywith (l1, id, l2) -> Ltrywith (map_return f l1, id, map_return f l2)
  | Lstaticcatch (l1, b, l2) ->
      Lstaticcatch (map_return f l1, b, map_return f l2)
  | Lstaticraise _ | Lprim(Praise _, _, _) as l -> l
  | l -> f l

(* The 'opt' reference indicates if the optimization is worthy.

   It is shared by the different calls to 'assign_pat' performed from
   'map_return'. For example with the code
     let (x, y) = if foo then z else (1,2)
   the else-branch will activate the optimization for both branches.

   That means that the optimization is activated if *there exists* an
   interesting tuple in one hole of the let-rhs context. We could
   choose to activate it only if *all* holes are interesting. We made
   that choice because being optimistic is extremely cheap (one static
   exit/catch overhead in the "wrong cases"), while being pessimistic
   can be costly (one unnecessary tuple allocation).
*)

let assign_pat opt nraise catch_ids loc pat lam =
  let rec collect acc pat lam = match pat.pat_desc, lam with
  | Tpat_tuple patl, Lprim(Pmakeblock _, lams, _) ->
      opt := true;
      List.fold_left2 collect acc patl lams
  | Tpat_tuple patl, Lconst(Const_block(_, _, scl)) ->
      opt := true;
      let collect_const acc pat sc = collect acc pat (Lconst sc) in
      List.fold_left2 collect_const acc patl scl
  | _ ->
    (* pattern idents will be bound in staticcatch (let body), so we
       refresh them here to guarantee binders  uniqueness *)
    let pat_ids = pat_bound_idents pat in
    let fresh_ids = List.map (fun id -> id, Ident.rename id) pat_ids in
    (fresh_ids, alpha_pat fresh_ids pat, lam) :: acc
  in

  (* sublets were accumulated by 'collect' with the leftmost tuple
     pattern at the bottom of the list; to respect right-to-left
     evaluation order for tuples, we must evaluate sublets
     top-to-bottom. To preserve tail-rec, we will fold_left the
     reversed list. *)
  let rev_sublets = List.rev (collect [] pat lam) in
  let exit =
    (* build an Ident.tbl to avoid quadratic refreshing costs *)
    let add t (id, fresh_id) = Ident.add id fresh_id t in
    let add_ids acc (ids, _pat, _lam) = List.fold_left add acc ids in
    let tbl = List.fold_left add_ids Ident.empty rev_sublets in
    let fresh_var id = Lvar (Ident.find_same id tbl) in
    Lstaticraise(nraise, List.map fresh_var catch_ids)
  in
  let push_sublet code (_ids, pat, lam) = simple_for_let loc lam pat code in
  List.fold_left push_sublet exit rev_sublets

let for_let loc param pat body =
  match pat.pat_desc with
  | Tpat_any ->
      (* This eliminates a useless variable (and stack slot in bytecode)
         for "let _ = ...". See #6865. *)
      Lsequence(param, body)
  | Tpat_var (id, _) ->
      (* fast path, and keep track of simple bindings to unboxable numbers *)
      let k = Typeopt.value_kind pat.pat_env pat.pat_type in
      Llet(Strict, k, id, param, body)
  | _ ->
   
      (* Turn off such optimization to reduce diff in the beginning*)
      if !Clflags.bs_only then simple_for_let loc param pat body 
      else
      
      let opt = ref false in
      let nraise = next_raise_count () in
      let catch_ids = pat_bound_idents pat in
      let bind = map_return (assign_pat opt nraise catch_ids loc pat) param in
      if !opt then Lstaticcatch(bind, (nraise, catch_ids), body)
      else simple_for_let loc param pat body

(* Handling of tupled functions and matchings *)

(* Easy case since variables are available *)
let for_tupled_function loc paraml pats_act_list partial =
  let partial = check_partial_list pats_act_list partial in
  let raise_num = next_raise_count () in
  let omegas = [List.map (fun _ -> omega) paraml] in
  let pm =
    { cases = pats_act_list;
      args = List.map (fun id -> (Lvar id, Strict)) paraml ;
      default = [omegas,raise_num]
    } in
  try
    let (lambda, total) = compile_match None partial
        (start_ctx (List.length paraml)) pm in
    check_total total lambda raise_num (partial_function loc)
  with
  | Unused -> partial_function loc ()



let flatten_pattern size p = match p.pat_desc with
| Tpat_tuple args -> args
| Tpat_any -> omegas size
| _ -> raise Cannot_flatten

let rec flatten_pat_line size p k = match p.pat_desc with
| Tpat_any ->  omegas size::k
| Tpat_tuple args -> args::k
| Tpat_or (p1,p2,_) ->  flatten_pat_line size p1 (flatten_pat_line size p2 k)
| Tpat_alias (p,_,_) -> (* Note: if this 'as' pat is here, then this is a
                           useless binding, solves PR#3780 *)
    flatten_pat_line size p k
| _ -> fatal_error "Matching.flatten_pat_line"

let flatten_cases size cases =
  List.map
    (fun (ps,action) -> match ps with
    | [p] -> flatten_pattern size p,action
    | _ -> fatal_error "Matching.flatten_case")
    cases

let flatten_matrix size pss =
  List.fold_right
    (fun ps r -> match ps with
    | [p] -> flatten_pat_line size p r
    | _   -> fatal_error "Matching.flatten_matrix")
    pss []

let flatten_def size def =
  List.map
    (fun (pss,i) -> flatten_matrix size pss,i)
    def

let flatten_pm size args pm =
    {args = args ; cases = flatten_cases size pm.cases ;
     default = flatten_def size pm.default}


let flatten_precompiled size args  pmh = match pmh with
| Pm pm -> Pm (flatten_pm size args pm)
| PmOr {body=b ; handlers=hs ; or_matrix=m} ->
    PmOr
      {body=flatten_pm size args b ;
       handlers=
         List.map
          (fun (mat,i,vars,pm) -> flatten_matrix size mat,i,vars,pm)
          hs ;
       or_matrix=flatten_matrix size m ;}
| PmVar _ -> assert false

(*
   compiled_flattened is a ``comp_fun'' argument to comp_match_handlers.
   Hence it needs a fourth argument, which it ignores
*)

let compile_flattened repr partial ctx _ pmh = match pmh with
| Pm pm -> compile_match repr partial ctx pm
| PmOr {body=b ; handlers=hs} ->
    let lam, total = compile_match repr partial ctx b in
    compile_orhandlers (compile_match repr partial) lam total ctx hs
| PmVar _ -> assert false

let do_for_multiple_match loc paraml pat_act_list partial =
  let repr = None in
  let partial = check_partial pat_act_list partial in
  let raise_num,pm1 =
    match partial with
    | Partial ->
        let raise_num = next_raise_count () in
        raise_num,
        { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
          args = [Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None), paraml, loc), Strict];
          default = [[[omega]],raise_num] }
    | _ ->
        -1,
        { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
          args = [Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None), paraml, loc), Strict];
          default = [] } in

  try
    try
(* Once for checking that compilation is possible *)
      let next, nexts = split_precompile None pm1 in

      let size = List.length paraml
      and idl = List.map (fun _ -> Ident.create "match") paraml in
      let args =  List.map (fun id -> Lvar id, Alias) idl in

      let flat_next = flatten_precompiled size args next
      and flat_nexts =
        List.map
          (fun (e,pm) ->  e,flatten_precompiled size args pm)
          nexts in

      let lam, total =
        comp_match_handlers
          (compile_flattened repr)
          partial (start_ctx size) () flat_next flat_nexts in
      List.fold_right2 (bind Strict) idl paraml
        (match partial with
        | Partial ->
            check_total total lam raise_num (partial_function loc)
        | Total ->
            assert (jumps_is_empty total) ;
            lam)
    with Cannot_flatten ->
      let (lambda, total) = compile_match None partial (start_ctx 1) pm1 in
      begin match partial with
      | Partial ->
          check_total total lambda raise_num (partial_function loc)
      | Total ->
          assert (jumps_is_empty total) ;
          lambda
      end
  with Unused ->
    assert false (* ; partial_function loc () *)

(* PR#4828: Believe it or not, the 'paraml' argument below
   may not be side effect free. *)

let param_to_var param = match param with
| Lvar v -> v,None
| _ -> Ident.create "match",Some param

let bind_opt (v,eo) k = match eo with
| None -> k
| Some e ->  Lambda.bind Strict v e k

let for_multiple_match loc paraml pat_act_list partial =
  let v_paraml = List.map param_to_var paraml in
  let paraml = List.map (fun (v,_) -> Lvar v) v_paraml in
  List.fold_right bind_opt v_paraml
    (do_for_multiple_match loc paraml pat_act_list partial)

end
module Translobj : sig 
#1 "translobj.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Lambda

val oo_prim: string -> lambda

val share: structured_constant -> lambda
val meth: lambda -> string -> lambda * lambda list

val reset_labels: unit -> unit
val transl_label_init: (unit -> lambda * 'a) -> lambda * 'a
val transl_store_label_init:
    Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda

val method_ids: IdentSet.t ref (* reset when starting a new wrapper *)

val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda
val oo_add_class: Ident.t -> Env.t * bool

val reset: unit -> unit

end = struct
#1 "translobj.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Misc
open Asttypes
open Longident
open Lambda

(* Get oo primitives identifiers *)

let oo_prim name =
  try
    transl_normal_path
      (fst (Env.lookup_value (Ldot (Lident "CamlinternalOO", name)) Env.empty))
  with Not_found ->
    fatal_error ("Primitive " ^ name ^ " not found.")

(* Share blocks *)

let consts : (structured_constant, Ident.t) Hashtbl.t = Hashtbl.create 17

let share c =
  match c with
    Const_block (_n,_, l) when l <> [] ->
      begin try
        Lvar (Hashtbl.find consts c)
      with Not_found ->
        let id = Ident.create "shared" in
        Hashtbl.add consts c id;
        Lvar id
      end
  | _ -> Lconst c

(* Collect labels *)

let cache_required = ref false
let method_cache = ref lambda_unit
let method_count = ref 0
let method_table = ref []

let meth_tag s = Lconst(Const_base(Const_int(Btype.hash_variant s)))

let next_cache tag =
  let n = !method_count in
  incr method_count;
  (tag, [!method_cache; Lconst(Const_base(Const_int n))])

let rec is_path = function
    Lvar _ | Lprim (Pgetglobal _, [], _) | Lconst _ -> true
  | Lprim (Pfield _, [lam], _) -> is_path lam
  | Lprim ((Parrayrefu _ | Parrayrefs _), [lam1; lam2], _) ->
      is_path lam1 && is_path lam2
  | _ -> false

let meth obj lab =
  let tag = meth_tag lab in
  if not (!cache_required && !Clflags.native_code) then (tag, []) else
  if not (is_path obj) then next_cache tag else
  try
    let r = List.assoc obj !method_table in
    try
      (tag, List.assoc tag !r)
    with Not_found ->
      let p = next_cache tag in
      r := p :: !r;
      p
  with Not_found ->
    let p = next_cache tag in
    method_table := (obj, ref [p]) :: !method_table;
    p

let reset_labels () =
  Hashtbl.clear consts;
  method_count := 0;
  method_table := []

(* Insert labels *)

let int n = Lconst (Const_base (Const_int n))

let prim_makearray =
  Primitive.simple ~name:"caml_make_vect" ~arity:2 ~alloc:true

(* Also use it for required globals *)
let transl_label_init_general f =
  let expr, size = f () in
  let expr =
    Hashtbl.fold
      (fun c id expr -> Llet(Alias, Pgenval, id, Lconst c, expr))
      consts expr
  in
  (*let expr =
    List.fold_right
      (fun id expr -> Lsequence(Lprim(Pgetglobal id, [], Location.none), expr))
      (Env.get_required_globals ()) expr
  in
  Env.reset_required_globals ();*)
  reset_labels ();
  expr, size

let transl_label_init_flambda f =
  assert(Config.flambda);
  let method_cache_id = Ident.create "method_cache" in
  method_cache := Lvar method_cache_id;
  (* Calling f (usually Translmod.transl_struct) requires the
     method_cache variable to be initialised to be able to generate
     method accesses. *)
  let expr, size = f () in
  let expr =
    if !method_count = 0 then expr
    else
      Llet (Strict, Pgenval, method_cache_id,
        Lprim (Pccall prim_makearray,
               [int !method_count; int 0],
               Location.none),
        expr)
  in
  transl_label_init_general (fun () -> expr, size)

let transl_store_label_init glob size f arg =
  assert(not Config.flambda);
  assert(!Clflags.native_code);
  method_cache := Lprim(Pfield (size, Fld_na),
                        [Lprim(Pgetglobal glob, [], Location.none)],
                        Location.none);
  let expr = f arg in
  let (size, expr) =
    if !method_count = 0 then (size, expr) else
    (size+1,
     Lsequence(
     Lprim(Psetfield(size, Pointer, Root_initialization, Fld_set_na),
           [Lprim(Pgetglobal glob, [], Location.none);
            Lprim (Pccall prim_makearray,
                   [int !method_count; int 0],
                   Location.none)],
           Location.none),
     expr))
  in
  let lam, size = transl_label_init_general (fun () -> (expr, size)) in
  size, lam

let transl_label_init f =
  if !Clflags.native_code then
    transl_label_init_flambda f
  else
    transl_label_init_general f

(* Share classes *)

let wrapping = ref false
let top_env = ref Env.empty
let classes = ref []
let method_ids = ref IdentSet.empty

let oo_add_class id =
  classes := id :: !classes;
  (!top_env, !cache_required)

let oo_wrap env req f x =
  if !wrapping then
    if !cache_required then f x else
    try cache_required := true; let lam = f x in cache_required := false; lam
    with exn -> cache_required := false; raise exn
  else try
    wrapping := true;
    cache_required := req;
    top_env := env;
    classes := [];
    method_ids := IdentSet.empty;
    let lambda = f x in
    let lambda =
      List.fold_left
        (fun lambda id ->
          Llet(StrictOpt, Pgenval, id,
               Lprim(Pmakeblock(0, Lambda.default_tag_info, Mutable, None),
                     [lambda_unit; lambda_unit; lambda_unit],
                     Location.none),
               lambda))
        lambda !classes
    in
    wrapping := false;
    top_env := Env.empty;
    lambda
  with exn ->
    wrapping := false;
    top_env := Env.empty;
    raise exn

let reset () =
  Hashtbl.clear consts;
  cache_required := false;
  method_cache := lambda_unit;
  method_count := 0;
  method_table := [];
  wrapping := false;
  top_env := Env.empty;
  classes := [];
  method_ids := IdentSet.empty

end
module Translcore : sig 
#1 "translcore.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Translation from typed abstract syntax to lambda terms,
   for the core language *)

open Asttypes
open Typedtree
open Lambda

val transl_exp: expression -> lambda
val transl_apply: ?should_be_tailcall:bool
                  -> ?inlined:inline_attribute
                  -> ?specialised:specialise_attribute
                  -> lambda -> (arg_label * expression option) list
                  -> Location.t -> lambda
val transl_let: rec_flag -> value_binding list -> lambda -> lambda
val transl_primitive: Location.t -> Primitive.description -> Env.t
                      -> Types.type_expr -> Path.t option -> lambda

val transl_extension_constructor: Env.t -> Path.t option ->
  extension_constructor -> lambda

val used_primitives: (Path.t, Location.t) Hashtbl.t

type error =
    Free_super_var
  | Unknown_builtin_primitive of string
  | Unreachable_reached

exception Error of Location.t * error

open Format

val report_error: formatter -> error -> unit

(* Forward declaration -- to be filled in by Translmod.transl_module *)
val transl_module :
      (module_coercion -> Path.t option -> module_expr -> lambda) ref
val transl_object :
      (Ident.t -> string list -> class_expr -> lambda) ref

end = struct
#1 "translcore.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Translation from typed abstract syntax to lambda terms,
   for the core language *)

open Misc
open Asttypes
open Primitive
open Types
open Typedtree
open Typeopt
open Lambda

type error =
    Free_super_var
  | Unknown_builtin_primitive of string
  | Unreachable_reached

exception Error of Location.t * error

let use_dup_for_constant_arrays_bigger_than = 4

(* Forward declaration -- to be filled in by Translmod.transl_module *)
let transl_module =
  ref((fun _cc _rootpath _modl -> assert false) :
      module_coercion -> Path.t option -> module_expr -> lambda)

let transl_object =
  ref (fun _id _s _cl -> assert false :
       Ident.t -> string list -> class_expr -> lambda)

(* Compile an exception/extension definition *)

let prim_fresh_oo_id =
  Pccall (Primitive.simple ~name:"caml_fresh_oo_id" ~arity:1 ~alloc:false)

let transl_extension_constructor env path ext =
  let name =
    match path, !Clflags.for_package with
      None, _ -> Ident.name ext.ext_id
    | Some p, None -> Path.name p
    | Some p, Some pack -> Printf.sprintf "%s.%s" pack (Path.name p)
  in
  let loc = ext.ext_loc in
  match ext.ext_kind with
    Text_decl _ ->
      let tag_info = Blk_extension_slot in 
      Lprim (Pmakeblock (Obj.object_tag, tag_info, Immutable, None),
        [Lconst (Const_base (Const_string (name, None)));
         Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))], loc)],
        loc)
  | Text_rebind(path, _lid) ->
      transl_extension_path ~loc env path

(* Translation of primitives *)

type specialized = {
  gencomp : Lambda.primitive;
  intcomp : Lambda.primitive;
  boolcomp : Lambda.primitive;
  floatcomp : Lambda.primitive;
  stringcomp : Lambda.primitive;
  bytescomp : Lambda.primitive;
  nativeintcomp : Lambda.primitive;
  int32comp : Lambda.primitive;
  int64comp : Lambda.primitive;
  simplify_constant_constructor : bool
}

let arity2 name : Lambda.primitive = Lambda.Pccall (Primitive.simple ~name ~arity:2 ~alloc:true)
let more_bs_primitives ls =        
  if !Clflags.bs_only then 
      ("%bs_max",
    { gencomp = arity2 "caml_max" ;
      bytescomp = arity2 "caml_max"; (* FIXME bytescomp*)
     intcomp = arity2 "caml_int_max";
     boolcomp = arity2 "caml_bool_max" ; 
     floatcomp = arity2 "caml_float_max" ;
     stringcomp = arity2 "caml_string_max" ;
     nativeintcomp = arity2 "caml_nativeint_max" ;
     int32comp = arity2 "caml_int32_max" ;
     int64comp = arity2 "caml_int64_max" ;
     simplify_constant_constructor = false}) ::
    ("%bs_min",
    { gencomp = arity2 "caml_min";
      bytescomp = arity2 "caml_min";
      intcomp = arity2 "caml_int_min" ;
     boolcomp = arity2 "caml_bool_min" ;
     floatcomp = arity2 "caml_float_min" ;
     stringcomp = arity2 "caml_string_min"; 
     nativeintcomp = arity2 "caml_nativeint_min"; 
     int32comp = arity2 "caml_int32_min"; 
     int64comp = arity2 "caml_int64_min"; 
     simplify_constant_constructor = false}) ::
     (
       "%bs_equal_null",
       { gencomp = arity2 "caml_equal_null";  
         bytescomp = arity2 "caml_equal_null";  (* FIXME*)               
         intcomp = arity2 "caml_int_equal_null";                 
         boolcomp = arity2 "caml_bool_equal_null";                                    
         floatcomp = arity2 "caml_float_equal_null";                        
         stringcomp = arity2 "caml_string_equal_null";                
         nativeintcomp = arity2 "caml_nativeint_equal_null"; 
         int32comp = arity2 "caml_int32_equal_null"; 
         int64comp = arity2 "caml_int64_equal_null"; 
        simplify_constant_constructor = true}
     ) :: 
     (
       "%bs_equal_undefined",
       { gencomp = arity2 "caml_equal_undefined";                 
         bytescomp = arity2 "caml_equal_undefined"; (* FIXME*)
         intcomp = arity2 "caml_int_equal_undefined";                 
         boolcomp = arity2 "caml_bool_equal_undefined";                             
         floatcomp = arity2 "caml_float_equal_undefined";                        
         stringcomp = arity2 "caml_string_equal_undefined";                
         nativeintcomp = arity2 "caml_nativeint_equal_undefined"; 
         int32comp = arity2 "caml_int32_equal_undefined"; 
         int64comp = arity2 "caml_int64_equal_undefined"; 
         simplify_constant_constructor = true}
     ) :: 
     (
       "%bs_equal_nullable",
       { gencomp = arity2 "caml_equal_nullable";                 
         bytescomp = arity2 "caml_equal_nullable"; (* FIXME *)
         intcomp = arity2 "caml_int_equal_nullable";                 
         boolcomp = arity2 "caml_bool_equal_nullable";                                    
         floatcomp = arity2 "caml_float_equal_nullable";                        
         stringcomp = arity2 "caml_string_equal_nullable"; 
         nativeintcomp = arity2 "caml_nativeint_equal_nullable"; 
         int32comp = arity2 "caml_int32_equal_nullable"; 
         int64comp = arity2 "caml_int64_equal_nullable"; 
         simplify_constant_constructor = true}
     ) ::     
     ls
     else ls 


let comparisons_table = Lazy.from_fun @@ fun _ -> 
  create_hashtable 11 @@ more_bs_primitives [
  "%equal",
      {
        gencomp = Pccall(Primitive.simple ~name:"caml_equal" ~arity:2 ~alloc:true);
        intcomp = Pintcomp Ceq;
        boolcomp = if not !Clflags.bs_only then Pintcomp Ceq
        else Pccall (Primitive.simple ~name:"caml_bool_equal" ~arity:2
                      ~alloc:false); 
        floatcomp = Pfloatcomp Ceq;
        stringcomp = Pccall(Primitive.simple ~name:"caml_string_equal" ~arity:2
                ~alloc:false);
        bytescomp = Pccall(Primitive.simple ~name:"caml_bytes_equal" ~arity:2
                ~alloc:false);
        nativeintcomp = Pbintcomp(Pnativeint, Ceq);
        int32comp = Pbintcomp(Pint32, Ceq);
        int64comp = Pbintcomp(Pint64, Ceq);
        simplify_constant_constructor = true};
  "%notequal",
      { gencomp = Pccall(Primitive.simple ~name:"caml_notequal" ~arity:2 ~alloc:true);
        intcomp = Pintcomp Cneq;
        boolcomp = if not !Clflags.bs_only then Pintcomp Cneq
            else Pccall (Primitive.simple ~name:"caml_bool_notequal" ~arity:2
                  ~alloc:false) ;         
        floatcomp = Pfloatcomp Cneq;
        stringcomp = Pccall(Primitive.simple ~name:"caml_string_notequal" ~arity:2
                ~alloc:false);
        bytescomp = Pccall(Primitive.simple ~name:"caml_bytes_notequal" ~arity:2
                ~alloc:false);
        nativeintcomp = Pbintcomp(Pnativeint, Cneq);
        int32comp = Pbintcomp(Pint32, Cneq);
        int64comp = Pbintcomp(Pint64, Cneq);
        simplify_constant_constructor = true};
  "%lessthan",
      { gencomp = Pccall(Primitive.simple ~name:"caml_lessthan" ~arity:2 ~alloc:true);
        intcomp = Pintcomp Clt;
        boolcomp = if not !Clflags.bs_only then Pintcomp Clt
        else Pccall (Primitive.simple ~name:"caml_bool_lessthan" ~arity:2
                     ~alloc:false);
        floatcomp = Pfloatcomp Clt;
        stringcomp = Pccall(Primitive.simple ~name:"caml_string_lessthan" ~arity:2
                ~alloc:false);
        bytescomp = Pccall(Primitive.simple ~name:"caml_bytes_lessthan" ~arity:2
                ~alloc:false);
        nativeintcomp = Pbintcomp(Pnativeint, Clt);
        int32comp = Pbintcomp(Pint32, Clt);
        int64comp = Pbintcomp(Pint64, Clt);
        simplify_constant_constructor = false};
  "%greaterthan",
      { gencomp = Pccall(Primitive.simple ~name:"caml_greaterthan" ~arity:2 ~alloc:true);
        intcomp = Pintcomp Cgt;
        boolcomp = if not !Clflags.bs_only then Pintcomp Cgt
        else Pccall (Primitive.simple ~name:"caml_bool_greaterthan" ~arity:2
            ~alloc:false);
        floatcomp = Pfloatcomp Cgt;
        stringcomp = Pccall(Primitive.simple ~name:"caml_string_greaterthan" ~arity:2
                ~alloc: false);
        bytescomp = Pccall(Primitive.simple ~name:"caml_bytes_greaterthan" ~arity:2
                ~alloc: false);
        nativeintcomp = Pbintcomp(Pnativeint, Cgt);
        int32comp = Pbintcomp(Pint32, Cgt);
        int64comp = Pbintcomp(Pint64, Cgt);
        simplify_constant_constructor = false};
  "%lessequal",
      { gencomp = Pccall(Primitive.simple ~name:"caml_lessequal" ~arity:2 ~alloc:true);
        intcomp = Pintcomp Cle;
        boolcomp = if not !Clflags.bs_only then Pintcomp Cle
        else Pccall( Primitive.simple ~name:"caml_bool_lessequal" ~arity:2
                    ~alloc:false);
        floatcomp = Pfloatcomp Cle;
        stringcomp = Pccall(Primitive.simple ~name:"caml_string_lessequal" ~arity:2
                ~alloc:false);
        bytescomp = Pccall(Primitive.simple ~name:"caml_bytes_lessequal" ~arity:2
                ~alloc:false);
        nativeintcomp = Pbintcomp(Pnativeint, Cle);
        int32comp = Pbintcomp(Pint32, Cle);
        int64comp = Pbintcomp(Pint64, Cle);
        simplify_constant_constructor = false};
  "%greaterequal",
      { gencomp = Pccall(Primitive.simple ~name:"caml_greaterequal" ~arity:2 ~alloc:true);
        intcomp = Pintcomp Cge;
        boolcomp = if not !Clflags.bs_only then Pintcomp Cge
        else Pccall (Primitive.simple ~name:"caml_bool_greaterequal" ~arity:2
                    ~alloc:false);
        floatcomp = Pfloatcomp Cge;
        stringcomp = Pccall(Primitive.simple ~name:"caml_string_greaterequal" ~arity:2
                ~alloc:false);
        bytescomp = Pccall(Primitive.simple ~name:"caml_bytes_greaterequal" ~arity:2
                ~alloc:false);
        nativeintcomp = Pbintcomp(Pnativeint, Cge);
        int32comp = Pbintcomp(Pint32, Cge);
        int64comp = Pbintcomp(Pint64, Cge);
        simplify_constant_constructor = false};
  "%compare",
      let unboxed_compare name native_repr =
        Pccall( Primitive.make ~name ~alloc:false
                  ~native_name:(name^"_unboxed")
                  ~native_repr_args:[native_repr;native_repr]
                  ~native_repr_res:Untagged_int
              ) in
      { gencomp = Pccall(Primitive.simple ~name:"caml_compare" ~arity:2 ~alloc:true);
       (* Not unboxed since the comparison is done directly on tagged int *)
        intcomp = Pccall(Primitive.simple ~name:"caml_int_compare" ~arity:2 ~alloc:false);
        boolcomp = if not !Clflags.bs_only then
            Pccall(Primitive.simple ~name:"caml_int_compare" ~arity:2 ~alloc:false)
          else
            Pccall (Primitive.simple ~name: "caml_bool_compare"
             ~arity:2
             ~alloc:false);
        floatcomp = unboxed_compare "caml_float_compare" Unboxed_float;
        stringcomp = Pccall(Primitive.simple ~name:"caml_string_compare" ~arity:2
                ~alloc:false);
        bytescomp = Pccall(Primitive.simple ~name:"caml_bytes_compare" ~arity:2
                ~alloc:false);
        nativeintcomp = unboxed_compare "caml_nativeint_compare" (Unboxed_integer Pnativeint);
        int32comp = unboxed_compare "caml_int32_compare" (Unboxed_integer Pint32);
        int64comp = unboxed_compare "caml_int64_compare" (Unboxed_integer Pint64);
        simplify_constant_constructor = false}
]

let gen_array_kind =
  if Config.flat_float_array then Pgenarray else Paddrarray

let primitives_table = create_hashtable 57 [
  "%identity", Pidentity;
  "%bytes_to_string", Pbytes_to_string;
  "%bytes_of_string", Pbytes_of_string;
  "%ignore", Pignore;
  "%revapply", Prevapply;
  "%apply", Pdirapply;
  "%loc_LOC", Ploc Loc_LOC;
  "%loc_FILE", Ploc Loc_FILE;
  "%loc_LINE", Ploc Loc_LINE;
  "%loc_POS", Ploc Loc_POS;
  "%loc_MODULE", Ploc Loc_MODULE;
  "%field0", Pfield (0, Fld_na);
  "%field1", Pfield (1, Fld_na);
  "%setfield0", Psetfield(0, Pointer, Assignment, Fld_set_na);
  "%makeblock", Pmakeblock(0, Lambda.default_tag_info, Immutable, None);
  "%makemutable", Pmakeblock(0, Lambda.ref_tag_info, Mutable, None);
  "%raise", Praise Raise_regular;
  "%reraise", Praise Raise_reraise;
  "%raise_notrace", Praise Raise_notrace;
  "%sequand", Psequand;
  "%sequor", Psequor;
  "%boolnot", Pnot;
  "%big_endian", Pctconst Big_endian;
  "%backend_type", Pctconst Backend_type;
  "%word_size", Pctconst Word_size;
  "%int_size", Pctconst Int_size;
  "%max_wosize", Pctconst Max_wosize;
  "%ostype_unix", Pctconst Ostype_unix;
  "%ostype_win32", Pctconst Ostype_win32;
  "%ostype_cygwin", Pctconst Ostype_cygwin;
  "%negint", Pnegint;
  "%succint", Poffsetint 1;
  "%predint", Poffsetint(-1);
  "%addint", Paddint;
  "%subint", Psubint;
  "%mulint", Pmulint;
  "%divint", Pdivint Safe;
  "%modint", Pmodint Safe;
  "%andint", Pandint;
  "%orint", Porint;
  "%xorint", Pxorint;
  "%lslint", Plslint;
  "%lsrint", Plsrint;
  "%asrint", Pasrint;
  "%eq", Pintcomp Ceq;
  "%noteq", Pintcomp Cneq;
  "%ltint", Pintcomp Clt;
  "%leint", Pintcomp Cle;
  "%gtint", Pintcomp Cgt;
  "%geint", Pintcomp Cge;
  "%incr", Poffsetref(1);
  "%decr", Poffsetref(-1);
  "%intoffloat", Pintoffloat;
  "%floatofint", Pfloatofint;
  "%negfloat", Pnegfloat;
  "%absfloat", Pabsfloat;
  "%addfloat", Paddfloat;
  "%subfloat", Psubfloat;
  "%mulfloat", Pmulfloat;
  "%divfloat", Pdivfloat;
  "%eqfloat", Pfloatcomp Ceq;
  "%noteqfloat", Pfloatcomp Cneq;
  "%ltfloat", Pfloatcomp Clt;
  "%lefloat", Pfloatcomp Cle;
  "%gtfloat", Pfloatcomp Cgt;
  "%gefloat", Pfloatcomp Cge;
  "%string_length", Pstringlength;
  "%string_safe_get", Pstringrefs;
  "%string_safe_set", Pbytessets;
  "%string_unsafe_get", Pstringrefu;
  "%string_unsafe_set", Pbytessetu;
  "%bytes_length", Pbyteslength;
  "%bytes_safe_get", Pbytesrefs;
  "%bytes_safe_set", Pbytessets;
  "%bytes_unsafe_get", Pbytesrefu;
  "%bytes_unsafe_set", Pbytessetu;
  "%array_length", Parraylength gen_array_kind;
  "%array_safe_get", Parrayrefs gen_array_kind;
  "%array_safe_set", Parraysets gen_array_kind;
  "%array_unsafe_get", Parrayrefu gen_array_kind;
  "%array_unsafe_set", Parraysetu gen_array_kind;
  "%obj_size", Parraylength gen_array_kind;
  "%obj_field", Parrayrefu gen_array_kind;
  "%obj_set_field", Parraysetu gen_array_kind;
  "%floatarray_length", Parraylength Pfloatarray;
  "%floatarray_safe_get", Parrayrefs Pfloatarray;
  "%floatarray_safe_set", Parraysets Pfloatarray;
  "%floatarray_unsafe_get", Parrayrefu Pfloatarray;
  "%floatarray_unsafe_set", Parraysetu Pfloatarray;
  "%obj_is_int", Pisint;
  "%lazy_force", Plazyforce;
  "%nativeint_of_int", Pbintofint Pnativeint;
  "%nativeint_to_int", Pintofbint Pnativeint;
  "%nativeint_neg", Pnegbint Pnativeint;
  "%nativeint_add", Paddbint Pnativeint;
  "%nativeint_sub", Psubbint Pnativeint;
  "%nativeint_mul", Pmulbint Pnativeint;
  "%nativeint_div", Pdivbint { size = Pnativeint; is_safe = Safe };
  "%nativeint_mod", Pmodbint { size = Pnativeint; is_safe = Safe };
  "%nativeint_and", Pandbint Pnativeint;
  "%nativeint_or",  Porbint Pnativeint;
  "%nativeint_xor", Pxorbint Pnativeint;
  "%nativeint_lsl", Plslbint Pnativeint;
  "%nativeint_lsr", Plsrbint Pnativeint;
  "%nativeint_asr", Pasrbint Pnativeint;
  "%int32_of_int", Pbintofint Pint32;
  "%int32_to_int", Pintofbint Pint32;
  "%int32_neg", Pnegbint Pint32;
  "%int32_add", Paddbint Pint32;
  "%int32_sub", Psubbint Pint32;
  "%int32_mul", Pmulbint Pint32;
  "%int32_div", Pdivbint { size = Pint32; is_safe = Safe };
  "%int32_mod", Pmodbint { size = Pint32; is_safe = Safe };
  "%int32_and", Pandbint Pint32;
  "%int32_or",  Porbint Pint32;
  "%int32_xor", Pxorbint Pint32;
  "%int32_lsl", Plslbint Pint32;
  "%int32_lsr", Plsrbint Pint32;
  "%int32_asr", Pasrbint Pint32;
  "%int64_of_int", Pbintofint Pint64;
  "%int64_to_int", Pintofbint Pint64;
  "%int64_neg", Pnegbint Pint64;
  "%int64_add", Paddbint Pint64;
  "%int64_sub", Psubbint Pint64;
  "%int64_mul", Pmulbint Pint64;
  "%int64_div", Pdivbint { size = Pint64; is_safe = Safe };
  "%int64_mod", Pmodbint { size = Pint64; is_safe = Safe };
  "%int64_and", Pandbint Pint64;
  "%int64_or",  Porbint Pint64;
  "%int64_xor", Pxorbint Pint64;
  "%int64_lsl", Plslbint Pint64;
  "%int64_lsr", Plsrbint Pint64;
  "%int64_asr", Pasrbint Pint64;
  "%nativeint_of_int32", Pcvtbint(Pint32, Pnativeint);
  "%nativeint_to_int32", Pcvtbint(Pnativeint, Pint32);
  "%int64_of_int32", Pcvtbint(Pint32, Pint64);
  "%int64_to_int32", Pcvtbint(Pint64, Pint32);
  "%int64_of_nativeint", Pcvtbint(Pnativeint, Pint64);
  "%int64_to_nativeint", Pcvtbint(Pint64, Pnativeint);
  "%caml_ba_ref_1",
    Pbigarrayref(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_ref_2",
    Pbigarrayref(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_ref_3",
    Pbigarrayref(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_set_1",
    Pbigarrayset(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_set_2",
    Pbigarrayset(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_set_3",
    Pbigarrayset(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_unsafe_ref_1",
    Pbigarrayref(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_unsafe_ref_2",
    Pbigarrayref(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_unsafe_ref_3",
    Pbigarrayref(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_unsafe_set_1",
    Pbigarrayset(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_unsafe_set_2",
    Pbigarrayset(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_unsafe_set_3",
    Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_dim_1", Pbigarraydim(1);
  "%caml_ba_dim_2", Pbigarraydim(2);
  "%caml_ba_dim_3", Pbigarraydim(3);
  "%caml_string_get16", Pstring_load_16(false);
  "%caml_string_get16u", Pstring_load_16(true);
  "%caml_string_get32", Pstring_load_32(false);
  "%caml_string_get32u", Pstring_load_32(true);
  "%caml_string_get64", Pstring_load_64(false);
  "%caml_string_get64u", Pstring_load_64(true);
  "%caml_string_set16", Pstring_set_16(false);
  "%caml_string_set16u", Pstring_set_16(true);
  "%caml_string_set32", Pstring_set_32(false);
  "%caml_string_set32u", Pstring_set_32(true);
  "%caml_string_set64", Pstring_set_64(false);
  "%caml_string_set64u", Pstring_set_64(true);
  "%caml_bigstring_get16", Pbigstring_load_16(false);
  "%caml_bigstring_get16u", Pbigstring_load_16(true);
  "%caml_bigstring_get32", Pbigstring_load_32(false);
  "%caml_bigstring_get32u", Pbigstring_load_32(true);
  "%caml_bigstring_get64", Pbigstring_load_64(false);
  "%caml_bigstring_get64u", Pbigstring_load_64(true);
  "%caml_bigstring_set16", Pbigstring_set_16(false);
  "%caml_bigstring_set16u", Pbigstring_set_16(true);
  "%caml_bigstring_set32", Pbigstring_set_32(false);
  "%caml_bigstring_set32u", Pbigstring_set_32(true);
  "%caml_bigstring_set64", Pbigstring_set_64(false);
  "%caml_bigstring_set64u", Pbigstring_set_64(true);
  "%bswap16", Pbswap16;
  "%bswap_int32", Pbbswap(Pint32);
  "%bswap_int64", Pbbswap(Pint64);
  "%bswap_native", Pbbswap(Pnativeint);
  "%int_as_pointer", Pint_as_pointer;
  "%opaque", Popaque;
]

let find_primitive prim_name =
  Hashtbl.find primitives_table prim_name

let prim_restore_raw_backtrace =
  Primitive.simple ~name:"caml_restore_raw_backtrace" ~arity:2 ~alloc:false

let specialize_comparison table env ty =
  let {gencomp; intcomp; floatcomp; stringcomp; bytescomp;
           nativeintcomp; int32comp; int64comp; _} = table in
  match () with
  | () when is_base_type env ty Predef.path_int
         || is_base_type env ty Predef.path_char
         || (maybe_pointer_type env ty = Immediate)   -> intcomp
  | () when is_base_type env ty Predef.path_float     -> floatcomp
  | () when is_base_type env ty Predef.path_string    -> stringcomp
  | () when is_base_type env ty Predef.path_bytes     -> bytescomp
  | () when is_base_type env ty Predef.path_nativeint -> nativeintcomp
  | () when is_base_type env ty Predef.path_int32     -> int32comp
  | () when is_base_type env ty Predef.path_int64     -> int64comp
  | () when is_base_type env ty Predef.path_bool      -> table.boolcomp  
  | () -> gencomp

(* The following function computes the greatest lower bound in the
   semilattice of array kinds:
          gen
         /   \
      addr   float
       |
      int
   Note that the GLB is not guaranteed to exist, in which case we return
   our first argument instead of raising a fatal error because, although
   it cannot happen in a well-typed program, (ab)use of Obj.magic can
   probably trigger it.
*)
let glb_array_type t1 t2 =
  match t1, t2 with
  | Pfloatarray, (Paddrarray | Pintarray)
  | (Paddrarray | Pintarray), Pfloatarray -> t1

  | Pgenarray, x | x, Pgenarray -> x
  | Paddrarray, x | x, Paddrarray -> x
  | Pintarray, Pintarray -> Pintarray
  | Pfloatarray, Pfloatarray -> Pfloatarray

(* Specialize a primitive from available type information,
   raise Not_found if primitive is unknown  *)

let specialize_primitive p env ty (* ~has_constant_constructor *) =
  try
    let table = Hashtbl.find (Lazy.force comparisons_table) p.prim_name in
    
      match is_function_type env ty with
      | Some (lhs,_rhs) -> specialize_comparison table env lhs
      | None -> table.gencomp
  with Not_found ->
    let p = find_primitive p.prim_name in
    (* Try strength reduction based on the type of the argument *)
    let params = match is_function_type env ty with
      | None -> []
      | Some (p1, rhs) -> match is_function_type env rhs with
        | None -> [p1]
        | Some (p2, _) -> [p1;p2]
    in
    match (p, params) with
      (Psetfield(n, _, init, dbg_info), [_p1; p2]) ->
        Psetfield(n, maybe_pointer_type env p2, init, dbg_info)
    | (Parraylength t, [p])   ->
        Parraylength(glb_array_type t (array_type_kind env p))
    | (Parrayrefu t, p1 :: _) ->
        Parrayrefu(glb_array_type t (array_type_kind env p1))
    | (Parraysetu t, p1 :: _) ->
        Parraysetu(glb_array_type t (array_type_kind env p1))
    | (Parrayrefs t, p1 :: _) ->
        Parrayrefs(glb_array_type t (array_type_kind env p1))
    | (Parraysets t, p1 :: _) ->
        Parraysets(glb_array_type t (array_type_kind env p1))
    | (Pbigarrayref(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout),
       p1 :: _) ->
        let (k, l) = bigarray_type_kind_and_layout env p1 in
        Pbigarrayref(unsafe, n, k, l)
    | (Pbigarrayset(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout),
       p1 :: _) ->
        let (k, l) = bigarray_type_kind_and_layout env p1 in
        Pbigarrayset(unsafe, n, k, l)
    | (Pmakeblock(tag, tag_info, mut, None), fields) ->
        let shape = List.map (Typeopt.value_kind env) fields in
        Pmakeblock(tag, tag_info, mut, Some shape)
    | _ -> p

(* Eta-expand a primitive *)

let used_primitives = Hashtbl.create 7
let add_used_primitive loc env path =
  match path with
    Some (Path.Pdot _ as path) ->
      let path = Env.normalize_path (Some loc) env path in
      let unit = Path.head path in
      if Ident.global unit && not (Hashtbl.mem used_primitives path)
      then Hashtbl.add used_primitives path loc
  | _ -> ()

let transl_primitive loc p env ty path =
  let prim =
    try specialize_primitive p env ty (* ~has_constant_constructor:false *)
    with Not_found ->
      add_used_primitive loc env path;
      Pccall p
  in
  match prim with
  | Plazyforce ->
      let parm = Ident.create "prim" in
      Lfunction{kind = Curried; params = [parm];
                body = Matching.inline_lazy_force (Lvar parm) Location.none;
                loc = loc;
                attr = default_stub_attribute }
  | Ploc kind ->
    let lam = lam_of_loc kind loc in
    begin match p.prim_arity with
      | 0 -> lam
      | 1 -> (* TODO: we should issue a warning ? *)
        let param = Ident.create "prim" in
        Lfunction{kind = Curried; params = [param];
                  attr = default_stub_attribute;
                  loc = loc;
                  body = Lprim(Pmakeblock(0, Lambda.Blk_tuple, Immutable, None),
                               [lam; Lvar param], loc)}
      | _ -> assert false
    end
  | _ ->
      let rec make_params n =
        if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in
      let params = make_params p.prim_arity in
 
      if params = [] then Lprim (prim, [], loc) (* arity = 0 in Buckle? TODO: unneeded*)
      else
      
      Lfunction{ kind = Curried; params;
                 attr = default_stub_attribute;
                 loc = loc;
                 body = Lprim(prim, List.map (fun id -> Lvar id) params, loc) }

let transl_primitive_application loc prim env ty path args =
  let prim_name = prim.prim_name in
  try
    (
      match args with 
    | [arg1; _] when 
      is_base_type env arg1.exp_type Predef.path_bool
      && Hashtbl.mem (Lazy.force comparisons_table) prim_name
      -> 
      (Hashtbl.find (Lazy.force comparisons_table) prim_name).boolcomp
    | _ ->   
    let has_constant_constructor = match args with
        [_; {exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}]
      | [{exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}; _]
      | [_; {exp_desc = Texp_variant(_, None)}]
      | [{exp_desc = Texp_variant(_, None)}; _] -> true
      | _ -> false
    in
    if has_constant_constructor then
      match Hashtbl.find_opt (Lazy.force comparisons_table) prim_name with 
      | Some table when table.simplify_constant_constructor -> table.intcomp
      | Some _
      | None -> 
        specialize_primitive prim env ty (* ~has_constant_constructor*)
    else         
        specialize_primitive prim env ty
  )
  with Not_found ->
    if String.length prim_name > 0 && prim_name.[0] = '%' then
      raise(Error(loc, Unknown_builtin_primitive prim_name));
    add_used_primitive loc env path;
    Pccall prim

(* To propagate structured constants *)

exception Not_constant

let extract_constant = function
    Lconst sc -> sc
  | _ -> raise_notrace Not_constant

let extract_float = function
    Const_base(Const_float f) -> f
  | _ -> fatal_error "Translcore.extract_float"

(* Push the default values under the functional abstractions *)
(* Also push bindings of module patterns, since this sound *)

type binding =
  | Bind_value of value_binding list
  | Bind_module of Ident.t * string loc * module_expr

let rec push_defaults loc bindings cases partial =
  match cases with
    [{c_lhs=pat; c_guard=None;
      c_rhs={exp_desc = Texp_function { arg_label; param; cases; partial; } }
        as exp}] ->
      let cases = push_defaults exp.exp_loc bindings cases partial in
      [{c_lhs=pat; c_guard=None;
        c_rhs={exp with exp_desc = Texp_function { arg_label; param; cases;
          partial; }}}]
  | [{c_lhs=pat; c_guard=None;
      c_rhs={exp_attributes=[{txt="#default"},_];
             exp_desc = Texp_let
               (Nonrecursive, binds, ({exp_desc = Texp_function _} as e2))}}] ->
      push_defaults loc (Bind_value binds :: bindings)
                   [{c_lhs=pat;c_guard=None;c_rhs=e2}]
                   partial
  | [{c_lhs=pat; c_guard=None;
      c_rhs={exp_attributes=[{txt="#modulepat"},_];
             exp_desc = Texp_letmodule
               (id, name, mexpr, ({exp_desc = Texp_function _} as e2))}}] ->
      push_defaults loc (Bind_module (id, name, mexpr) :: bindings)
                   [{c_lhs=pat;c_guard=None;c_rhs=e2}]
                   partial
  | [case] ->
      let exp =
        List.fold_left
          (fun exp binds ->
            {exp with exp_desc =
             match binds with
             | Bind_value binds -> Texp_let(Nonrecursive, binds, exp)
             | Bind_module (id, name, mexpr) ->
                 Texp_letmodule (id, name, mexpr, exp)})
          case.c_rhs bindings
      in
      [{case with c_rhs=exp}]
  | {c_lhs=pat; c_rhs=exp; c_guard=_} :: _ when bindings <> [] ->
      let param = Typecore.name_pattern "param" cases in
      let name = Ident.name param in
      let exp =
        { exp with exp_loc = loc; exp_desc =
          Texp_match
            ({exp with exp_type = pat.pat_type; exp_desc =
              Texp_ident (Path.Pident param, mknoloc (Longident.Lident name),
                          {val_type = pat.pat_type; val_kind = Val_reg;
                           val_attributes = [];
                           Types.val_loc = Location.none;
                          })},
             cases, [], partial) }
      in
      push_defaults loc bindings
        [{c_lhs={pat with pat_desc = Tpat_var (param, mknoloc name)};
          c_guard=None; c_rhs=exp}]
        Total
  | _ ->
      cases

(* Insertion of debugging events *)

let event_before exp lam = match lam with
| Lstaticraise (_,_) -> lam
| _ ->
  if !Clflags.record_event_when_debug && !Clflags.debug && not !Clflags.bs_only
  then Levent(lam, {lev_loc = exp.exp_loc;
                    lev_kind = Lev_before;
                    lev_repr = None;
                    lev_env = Env.summary exp.exp_env})
  else lam

let event_after exp lam =
  if !Clflags.record_event_when_debug && !Clflags.debug && not !Clflags.bs_only
  then Levent(lam, {lev_loc = exp.exp_loc;
                    lev_kind = Lev_after exp.exp_type;
                    lev_repr = None;
                    lev_env = Env.summary exp.exp_env})
  else lam

let event_function exp lam =
  if !Clflags.record_event_when_debug && !Clflags.debug && not !Clflags.bs_only then
    let repr = Some (ref 0) in
    let (info, body) = lam repr in
    (info,
     Levent(body, {lev_loc = exp.exp_loc;
                   lev_kind = Lev_function;
                   lev_repr = repr;
                   lev_env = Env.summary exp.exp_env}))
  else
    lam None

let primitive_is_ccall = function
  (* Determine if a primitive is a Pccall or will be turned later into
     a C function call that may raise an exception *)
  | Pccall _ | Pstringrefs  | Pbytesrefs | Pbytessets | Parrayrefs _ |
    Parraysets _ | Pbigarrayref _ | Pbigarrayset _ | Pduprecord _ | Pdirapply |
    Prevapply -> true
  | _ -> false

(* Assertions *)

let assert_failed exp =
  let (fname, line, char) =
    Location.get_pos_info exp.exp_loc.Location.loc_start in
     
  let fname = 
    Filename.basename fname
  in   
     
  Lprim(Praise Raise_regular, [event_after exp
    (Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None),
          [transl_normal_path Predef.path_assert_failure;
           Lconst(Const_block(0, Lambda.Blk_tuple,
              [Const_base(Const_string (fname, None));
               Const_base(Const_int line);
               Const_base(Const_int char)]))], exp.exp_loc))], exp.exp_loc)
;;

let rec cut n l =
  if n = 0 then ([],l) else
  match l with [] -> failwith "Translcore.cut"
  | a::l -> let (l1,l2) = cut (n-1) l in (a::l1,l2)

(* Translation of expressions *)

let try_ids = Hashtbl.create 8

let rec transl_exp e =
  List.iter (Translattribute.check_attribute e) e.exp_attributes;
  let eval_once =
    (* Whether classes for immediate objects must be cached *)
    match e.exp_desc with
      Texp_function _ | Texp_for _ | Texp_while _ -> false
    | _ -> true
  in
  if eval_once then transl_exp0 e else
  Translobj.oo_wrap e.exp_env true transl_exp0 e

and transl_exp0 e =
  match e.exp_desc with
    Texp_ident(path, _, {val_kind = Val_prim p}) ->
      let public_send = p.prim_name = "%send" in
      if public_send || p.prim_name = "%sendself" then
        let kind = if public_send then Public None else Self in
        let obj = Ident.create "obj" and meth = Ident.create "meth" in
        Lfunction{kind = Curried; params = [obj; meth];
                  attr = default_stub_attribute;
                  loc = e.exp_loc;
                  body = Lsend(kind, Lvar meth, Lvar obj, [], e.exp_loc)}
      else if p.prim_name = "%sendcache" then
        let obj = Ident.create "obj" and meth = Ident.create "meth" in
        let cache = Ident.create "cache" and pos = Ident.create "pos" in
        Lfunction{kind = Curried; params = [obj; meth; cache; pos];
                  attr = default_stub_attribute;
                  loc = e.exp_loc;
                  body = Lsend(Cached, Lvar meth, Lvar obj,
                               [Lvar cache; Lvar pos], e.exp_loc)}
      else
        transl_primitive e.exp_loc p e.exp_env e.exp_type (Some path)
  | Texp_ident(_, _, {val_kind = Val_anc _}) ->
      raise(Error(e.exp_loc, Free_super_var))
  | Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) ->
      transl_value_path ~loc:e.exp_loc e.exp_env path
  | Texp_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident"
  | Texp_constant cst ->
      Lconst(Const_base cst)
  | Texp_let(rec_flag, pat_expr_list, body) ->
      transl_let rec_flag pat_expr_list (event_before body (transl_exp body))
  | Texp_function { arg_label = _; param; cases; partial; } ->
      let ((kind, params), body) =
        event_function e
          (function repr ->
            let pl = push_defaults e.exp_loc [] cases partial in
            transl_function e.exp_loc !Clflags.native_code repr partial
              param pl)
      in
      let attr = {
        default_function_attribute with
        inline = Translattribute.get_inline_attribute e.exp_attributes;
        specialise = Translattribute.get_specialise_attribute e.exp_attributes;
      }
      in
      let loc = e.exp_loc in
      Lfunction{kind; params; body; attr; loc}
  | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p});
                exp_type = prim_type } as funct, oargs)
    when List.length oargs >= p.prim_arity
    && List.for_all (fun (_, arg) -> arg <> None) oargs ->
      let args, args' = cut p.prim_arity oargs in
      let wrap f =
        if args' = []
        then event_after e f
        else
          let should_be_tailcall, funct =
            Translattribute.get_tailcall_attribute funct
          in
          let inlined, funct =
            Translattribute.get_and_remove_inlined_attribute funct
          in
          let specialised, funct =
            Translattribute.get_and_remove_specialised_attribute funct
          in
          let e = { e with exp_desc = Texp_apply(funct, oargs) } in
          event_after e
            (transl_apply ~should_be_tailcall ~inlined ~specialised
               f args' e.exp_loc)
      in
      let wrap0 f =
        if args' = [] then f else wrap f in
      let args =
         List.map (function _, Some x -> x | _ -> assert false) args in
      let argl = transl_list args in
      let public_send = p.prim_name = "%send"
        || not !Clflags.native_code && p.prim_name = "%sendcache"in
      if public_send || p.prim_name = "%sendself" then
        let kind = if public_send then Public None else Self in
        let obj = List.hd argl in
        wrap (Lsend (kind, List.nth argl 1, obj, [], e.exp_loc))
      else if p.prim_name = "%sendcache" then
        match argl with [obj; meth; cache; pos] ->
          wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc))
        | _ -> assert false
      else if p.prim_name = "%raise_with_backtrace" then begin
        let texn1 = List.hd args (* Should not fail by typing *) in
        let texn2,bt = match argl with
          | [a;b] -> a,b
          | _ -> assert false (* idem *)
        in
        let vexn = Ident.create "exn" in
        Llet(Strict, Pgenval, vexn, texn2,
             event_before e begin
               Lsequence(
                 wrap  (Lprim (Pccall prim_restore_raw_backtrace,
                               [Lvar vexn;bt],
                               e.exp_loc)),
                 wrap0 (Lprim(Praise Raise_reraise,
                              [event_after texn1 (Lvar vexn)],
                              e.exp_loc))
               )
             end
            )
      end
      else begin
        let prim = transl_primitive_application
            e.exp_loc p e.exp_env prim_type (Some path) args in
        match (prim, args) with
          (Praise k, [arg1]) ->
            let targ = List.hd argl in
            let k =
              match k, targ with
              | Raise_regular, Lvar id
                when Hashtbl.mem try_ids id ->
                  Raise_reraise
              | _ ->
                  k
            in
            wrap0 (Lprim(Praise k, [event_after arg1 targ], e.exp_loc))
        | (Ploc kind, []) ->
          lam_of_loc kind e.exp_loc
        | (Ploc kind, [arg1]) ->
          let lam = lam_of_loc kind arg1.exp_loc in
          Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None), lam :: argl, e.exp_loc)
        | (Ploc _, _) -> assert false
        | (_, _) ->
            begin match (prim, argl) with
            | (Plazyforce, [a]) ->
                wrap (Matching.inline_lazy_force a e.exp_loc)
            | (Plazyforce, _) -> assert false
            |_ -> let p = Lprim(prim, argl, e.exp_loc) in
               if primitive_is_ccall prim then wrap p else wrap0 p
            end
      end
  | Texp_apply(funct, oargs) ->
      let should_be_tailcall, funct =
        Translattribute.get_tailcall_attribute funct
      in
      let inlined, funct =
        Translattribute.get_and_remove_inlined_attribute funct
      in
      let specialised, funct =
        Translattribute.get_and_remove_specialised_attribute funct
      in
      let e = { e with exp_desc = Texp_apply(funct, oargs) } in
      event_after e
        (transl_apply ~should_be_tailcall ~inlined ~specialised
           (transl_exp funct) oargs e.exp_loc)
  | Texp_match(arg, pat_expr_list, exn_pat_expr_list, partial) ->
    transl_match e arg pat_expr_list exn_pat_expr_list partial
  | Texp_try(body, pat_expr_list) ->
      let id = Typecore.name_pattern "exn" pat_expr_list in
      Ltrywith(transl_exp body, id,
               Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list))
  | Texp_tuple el ->
      let ll, shape = transl_list_with_shape el in
      let tag_info = Lambda.Blk_tuple in 
      begin try
        Lconst(Const_block(0, tag_info, List.map extract_constant ll))
      with Not_constant ->
        Lprim(Pmakeblock(0, tag_info, Immutable, Some shape), ll, e.exp_loc)
      end
  | Texp_construct(lid, cstr, args) ->
      let ll, shape = transl_list_with_shape args in
      if cstr.cstr_inlined <> None then begin match ll with
        | [x] -> x
        | _ -> assert false
      end else begin match cstr.cstr_tag with
        Cstr_constant n ->
          Lconst(Const_pointer (n,
          match lid.txt with
          | Longident.Lident ("false"|"true") -> Pt_builtin_boolean
          | Longident.Ldot (Longident.Lident "*predef*", "None")
          | Longident.Lident "None"
             when Datarepr.constructor_has_optional_shape cstr
            -> Pt_shape_none
          | _ -> (Lambda.Pt_constructor cstr.cstr_name)        
          ))
      | Cstr_unboxed ->
          (match ll with [v] -> v | _ -> assert false)
      | Cstr_block n ->
          let tag_info : Lambda.tag_info =
            if Datarepr.constructor_has_optional_shape cstr then
              begin 
                match args with
                | [arg] when  Typeopt.cannot_inhabit_none_like_value arg.exp_type arg.exp_env
                  ->
                    (* Format.fprintf Format.err_formatter "@[special boxingl@]@."; *)
                    Blk_some_not_nested
                | _ ->
                    Blk_some
              end
            else (Lambda.Blk_constructor (cstr.cstr_name, cstr.cstr_nonconsts)) in      
          begin try
            Lconst(Const_block(n, tag_info, List.map extract_constant ll))
          with Not_constant ->
            Lprim(Pmakeblock(n, tag_info, Immutable, Some shape), ll, e.exp_loc)
          end
      | Cstr_extension(path, is_const) ->
          if is_const then
            transl_extension_path e.exp_env path
          else
            Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, Some (Pgenval :: shape)),
                  transl_extension_path e.exp_env path :: ll, e.exp_loc)
      end
  | Texp_extension_constructor (_, path) ->
      transl_extension_path e.exp_env path
  | Texp_variant(l, arg) ->
      let tag = Btype.hash_variant l in
      begin match arg with
        None -> Lconst(Const_pointer (tag, Lambda.Pt_variant l))
      | Some arg ->
          let lam = transl_exp arg in
          let tag_info = Lambda.Blk_variant l in 
          try
            Lconst(Const_block(0, tag_info, [Const_base(Const_int tag);
                                   extract_constant lam]))
          with Not_constant ->
            Lprim(Pmakeblock(0, tag_info, Immutable, None),
                  [Lconst(Const_base(Const_int tag)); lam], e.exp_loc)
      end
  | Texp_record {fields; representation; extended_expression} ->
      transl_record e.exp_loc e.exp_env fields representation
        extended_expression
  | Texp_field(arg, _, lbl) ->
      let targ = transl_exp arg in
      begin match lbl.lbl_repres with
          Record_regular -> 
          Lprim (Pfield (lbl.lbl_pos, Fld_record lbl.lbl_name), [targ], e.exp_loc) 
        | Record_inlined _ ->
          Lprim (Pfield (lbl.lbl_pos, Fld_record_inline lbl.lbl_name), [targ], e.exp_loc)
        | Record_unboxed _ -> targ
        | Record_float -> Lprim (Pfloatfield (lbl.lbl_pos, Fld_record lbl.lbl_name), [targ], e.exp_loc)
        | Record_extension ->
          Lprim (Pfield (lbl.lbl_pos + 1, Fld_record_extension lbl.lbl_name), [targ], e.exp_loc) 
      end
  | Texp_setfield(arg, _, lbl, newval) ->
      let access =
        match lbl.lbl_repres with
          Record_regular -> 
          Psetfield(lbl.lbl_pos, maybe_pointer newval, Assignment, Fld_record_set lbl.lbl_name)
        | Record_inlined _ -> 
          Psetfield(lbl.lbl_pos, maybe_pointer newval, Assignment, Fld_record_inline_set lbl.lbl_name)
        | Record_unboxed _ -> assert false
        | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment, Fld_record_set lbl.lbl_name)
        | Record_extension -> 
          Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, Assignment, Fld_record_extension_set lbl.lbl_name)
      in
      Lprim(access, [transl_exp arg; transl_exp newval], e.exp_loc)
  | Texp_array expr_list ->
      let kind = array_kind e in
      let ll = transl_list expr_list in
       
      if !Clflags.bs_only then 
         Lprim(Pmakearray (kind, Mutable), ll, e.exp_loc)
      else   

      begin try
        (* For native code the decision as to which compilation strategy to
           use is made later.  This enables the Flambda passes to lift certain
           kinds of array definitions to symbols. *)
        (* Deactivate constant optimization if array is small enough *)
        if List.length ll <= use_dup_for_constant_arrays_bigger_than
        then begin
          raise Not_constant
        end;
        begin match List.map extract_constant ll with
        | exception Not_constant when kind = Pfloatarray ->
            (* We cannot currently lift [Pintarray] arrays safely in Flambda
               because [caml_modify] might be called upon them (e.g. from
               code operating on polymorphic arrays, or functions such as
               [caml_array_blit].
               To avoid having different Lambda code for
               bytecode/Closure vs.  Flambda, we always generate
               [Pduparray] here, and deal with it in [Bytegen] (or in
               the case of Closure, in [Cmmgen], which already has to
               handle [Pduparray Pmakearray Pfloatarray] in the case
               where the array turned out to be inconstant).
               When not [Pfloatarray], the exception propagates to the handler
               below. *)
            let imm_array =
              Lprim (Pmakearray (kind, Immutable), ll, e.exp_loc)
            in
            Lprim (Pduparray (kind, Mutable), [imm_array], e.exp_loc)
        | cl ->
            let imm_array =
              match kind with
              | Paddrarray | Pintarray ->
                  Lconst(Const_block(0, Lambda.Blk_array, cl)) (* ATTENTION: ? [|1;2;3;4|]*)
              | Pfloatarray ->
                  Lconst(Const_float_array(List.map extract_float cl))
              | Pgenarray ->
                  raise Not_constant    (* can this really happen? *)
            in
            Lprim (Pduparray (kind, Mutable), [imm_array], e.exp_loc)
        end
      with Not_constant ->
        Lprim(Pmakearray (kind, Mutable), ll, e.exp_loc)
      end
  | Texp_ifthenelse(cond, ifso, Some ifnot) ->
      Lifthenelse(transl_exp cond,
                  event_before ifso (transl_exp ifso),
                  event_before ifnot (transl_exp ifnot))
  | Texp_ifthenelse(cond, ifso, None) ->
      Lifthenelse(transl_exp cond,
                  event_before ifso (transl_exp ifso),
                  lambda_unit)
  | Texp_sequence(expr1, expr2) ->
      Lsequence(transl_exp expr1, event_before expr2 (transl_exp expr2))
  | Texp_while(cond, body) ->
      Lwhile(transl_exp cond, event_before body (transl_exp body))
  | Texp_for(param, _, low, high, dir, body) ->
      Lfor(param, transl_exp low, transl_exp high, dir,
           event_before body (transl_exp body))
  | Texp_send(_, _, Some exp) -> transl_exp exp
  | Texp_send(expr, met, None) ->
      let obj = transl_exp expr in
      let lam =
        match met with
          Tmeth_val id -> Lsend (Self, Lvar id, obj, [], e.exp_loc)
        | Tmeth_name nm ->
            let (tag, cache) = Translobj.meth obj nm in
            let kind = if cache = [] then Public (Some nm) else Cached in
            Lsend (kind, tag, obj, cache, e.exp_loc)
      in
      event_after e lam
  | Texp_new (cl, {Location.loc=loc}, _) ->
      Lapply{ap_should_be_tailcall=false;
             ap_loc=loc;
             ap_func=Lprim(Pfield (0, Fld_na), [transl_class_path ~loc e.exp_env cl], loc);
             ap_args=[lambda_unit];
             ap_inlined=Default_inline;
             ap_specialised=Default_specialise}
  | Texp_instvar(path_self, path, _) ->
      Lprim(Pfield_computed,
            [transl_normal_path path_self; transl_normal_path path], e.exp_loc)
  | Texp_setinstvar(path_self, path, _, expr) ->
      transl_setinstvar e.exp_loc (transl_normal_path path_self) path expr
  | Texp_override(path_self, modifs) ->
      let cpy = Ident.create "copy" in
      Llet(Strict, Pgenval, cpy,
           Lapply{ap_should_be_tailcall=false;
                  ap_loc=Location.none;
                  ap_func=Translobj.oo_prim "copy";
                  ap_args=[transl_normal_path path_self];
                  ap_inlined=Default_inline;
                  ap_specialised=Default_specialise},
           List.fold_right
             (fun (path, _, expr) rem ->
                Lsequence(transl_setinstvar Location.none
                            (Lvar cpy) path expr, rem))
             modifs
             (Lvar cpy))
  | Texp_letmodule(id, loc, modl, body) ->
      let defining_expr =
        
        if !Clflags.bs_only then !transl_module Tcoerce_none None modl
        else
        
        Levent (!transl_module Tcoerce_none None modl, {
          lev_loc = loc.loc;
          lev_kind = Lev_module_definition id;
          lev_repr = None;
          lev_env = Env.summary Env.empty;
        })
      in
      Llet(Strict, Pgenval, id, defining_expr, transl_exp body)
  | Texp_letexception(cd, body) ->
      Llet(Strict, Pgenval,
           cd.ext_id, transl_extension_constructor e.exp_env None cd,
           transl_exp body)
  | Texp_pack modl ->
      !transl_module Tcoerce_none None modl
  | Texp_assert {exp_desc=Texp_construct(_, {cstr_name="false"}, _)} ->
      if !Clflags.no_assert_false then
        Lambda.lambda_assert_false
      else 
        assert_failed e  
  | Texp_assert (cond) ->
      if !Clflags.noassert
      then lambda_unit
      else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e)
  | Texp_lazy e ->
      (* when e needs no computation (constants, identifiers, ...), we
         optimize the translation just as Lazy.lazy_from_val would
         do *)
      begin match Typeopt.classify_lazy_argument e with
      | `Constant_or_function ->
        (* a constant expr of type <> float gets compiled as itself *)
         transl_exp e
      | `Float -> 
          (* We don't need to wrap with Popaque: this forward
             block will never be shortcutted since it points to a float. *)
          Lprim(Pmakeblock(Obj.forward_tag, Lambda.default_tag_info, Immutable, None),
                [transl_exp e], e.exp_loc)
      | `Identifier `Forward_value ->
         (* CR-someday mshinwell: Consider adding a new primitive
            that expresses the construction of forward_tag blocks.
            We need to use [Popaque] here to prevent unsound
            optimisation in Flambda, but the concept of a mutable
            block doesn't really match what is going on here.  This
            value may subsequently turn into an immediate... *)
         Lprim (Popaque,
                [Lprim(Pmakeblock(Obj.forward_tag, Lambda.default_tag_info, Immutable, None),
                       [transl_exp e], e.exp_loc)],
                e.exp_loc)
      | `Identifier `Other ->
         transl_exp e
      | `Other ->
         (* other cases compile to a lazy block holding a function *)
         let fn = Lfunction {kind = Curried; params = [Ident.create "param"];
                             attr = default_function_attribute;
                             loc = e.exp_loc;
                             body = transl_exp e} in
          Lprim(Pmakeblock(Config.lazy_tag, Lambda.default_tag_info, Mutable, None), [fn], e.exp_loc)
      end
  | Texp_object (cs, meths) ->
      let cty = cs.cstr_type in
      let cl = Ident.create "class" in
      !transl_object cl meths
        { cl_desc = Tcl_structure cs;
          cl_loc = e.exp_loc;
          cl_type = Cty_signature cty;
          cl_env = e.exp_env;
          cl_attributes = [];
         }
  | Texp_unreachable ->
      raise (Error (e.exp_loc, Unreachable_reached))

and transl_list expr_list =
  List.map transl_exp expr_list

and transl_list_with_shape expr_list =
  let transl_with_shape e =
    let shape = Typeopt.value_kind e.exp_env e.exp_type in
    transl_exp e, shape
  in
  List.split (List.map transl_with_shape expr_list)

and transl_guard guard rhs =
  let expr = event_before rhs (transl_exp rhs) in
  match guard with
  | None -> expr
  | Some cond ->
      event_before cond (Lifthenelse(transl_exp cond, expr, staticfail))

and transl_case {c_lhs; c_guard; c_rhs} =
  c_lhs, transl_guard c_guard c_rhs

and transl_cases cases =
  let cases =
    List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in
  List.map transl_case cases

and transl_case_try {c_lhs; c_guard; c_rhs} =
  match c_lhs.pat_desc with
  | Tpat_var (id, _)
  | Tpat_alias (_, id, _) ->
      Hashtbl.replace try_ids id ();
      Misc.try_finally
        (fun () -> c_lhs, transl_guard c_guard c_rhs)
        (fun () -> Hashtbl.remove try_ids id)
  | _ ->
      c_lhs, transl_guard c_guard c_rhs

and transl_cases_try cases =
  let cases =
    List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in
  List.map transl_case_try cases

and transl_tupled_cases patl_expr_list =
  let patl_expr_list =
    List.filter (fun (_,_,e) -> e.exp_desc <> Texp_unreachable)
      patl_expr_list in
  List.map (fun (patl, guard, expr) -> (patl, transl_guard guard expr))
    patl_expr_list

and transl_apply ?(should_be_tailcall=false) ?(inlined = Default_inline)
      ?(specialised = Default_specialise) lam sargs loc =
  let lapply funct args =
    match funct with
      Lsend(k, lmet, lobj, largs, loc) ->
        Lsend(k, lmet, lobj, largs @ args, loc)
    | Levent(Lsend(k, lmet, lobj, largs, loc), _) ->
        Lsend(k, lmet, lobj, largs @ args, loc)
    | Lapply ap ->
        Lapply {ap with ap_args = ap.ap_args @ args; ap_loc = loc}
    | lexp ->
        Lapply {ap_should_be_tailcall=should_be_tailcall;
                ap_loc=loc;
                ap_func=lexp;
                ap_args=args;
                ap_inlined=inlined;
                ap_specialised=specialised;}
  in
  let rec build_apply lam args = function
      (None, optional) :: l ->
        let defs = ref [] in
        let protect name lam =
          match lam with
            Lvar _ | Lconst _ -> lam
          | _ ->
              let id = Ident.create name in
              defs := (id, lam) :: !defs;
              Lvar id
        in
        let args, args' =
          if List.for_all (fun (_,opt) -> opt) args then [], args
          else args, [] in
        let lam =
          if args = [] then lam else lapply lam (List.rev_map fst args) in
        let handle = protect "func" lam
        and l = List.map (fun (arg, opt) -> may_map (protect "arg") arg, opt) l
        and id_arg = Ident.create "param" in
        let body =
          match build_apply handle ((Lvar id_arg, optional)::args') l with
            Lfunction{kind = Curried; params = ids; body = lam; attr; loc} ->
              Lfunction{kind = Curried; params = id_arg::ids; body = lam; attr;
                        loc}
          | Levent(Lfunction{kind = Curried; params = ids;
                             body = lam; attr; loc}, _) ->
              Lfunction{kind = Curried; params = id_arg::ids; body = lam; attr;
                        loc}
          | lam ->
              Lfunction{kind = Curried; params = [id_arg]; body = lam;
                        attr = default_stub_attribute; loc = loc}
        in
        List.fold_left
          (fun body (id, lam) -> Llet(Strict, Pgenval, id, lam, body))
          body !defs
    | (Some arg, optional) :: l ->
        build_apply lam ((arg, optional) :: args) l
    | [] ->
        lapply lam (List.rev_map fst args)
  in
  (build_apply lam [] (List.map (fun (l, x) ->
                                   may_map transl_exp x, Btype.is_optional l)
                                sargs)
     : Lambda.lambda)

and transl_function loc untuplify_fn repr partial param cases =
  match cases with
    [{c_lhs=pat; c_guard=None;
      c_rhs={exp_desc = Texp_function { arg_label = _; param = param'; cases;
        partial = partial'; }} as exp}]
    when Parmatch.inactive ~partial pat ->
      let ((_, params), body) =
        transl_function exp.exp_loc false repr partial' param' cases in
      ((Curried, param :: params),
       Matching.for_function loc None (Lvar param) [pat, body] partial)
  | {c_lhs={pat_desc = Tpat_tuple pl}} :: _ when untuplify_fn ->
      begin try
        let size = List.length pl in
        let pats_expr_list =
          List.map
            (fun {c_lhs; c_guard; c_rhs} ->
              (Matching.flatten_pattern size c_lhs, c_guard, c_rhs))
            cases in
        let params = List.map (fun _ -> Ident.create "param") pl in
        ((Tupled, params),
         Matching.for_tupled_function loc params
           (transl_tupled_cases pats_expr_list) partial)
      with Matching.Cannot_flatten ->
        ((Curried, [param]),
         Matching.for_function loc repr (Lvar param)
           (transl_cases cases) partial)
      end
  | _ ->
      ((Curried, [param]),
       Matching.for_function loc repr (Lvar param)
         (transl_cases cases) partial)

and transl_let rec_flag pat_expr_list body =
  match rec_flag with
    Nonrecursive ->
      let rec transl = function
        [] ->
          body
      | {vb_pat=pat; vb_expr=expr; vb_attributes=attr; vb_loc} :: rem ->
          let lam = transl_exp expr in
          let lam =
            Translattribute.add_inline_attribute lam vb_loc attr
          in
          let lam =
            Translattribute.add_specialise_attribute lam vb_loc attr
          in
          Matching.for_let pat.pat_loc lam pat (transl rem)
      in transl pat_expr_list
  | Recursive ->
      let idlist =
        List.map
          (fun {vb_pat=pat} -> match pat.pat_desc with
              Tpat_var (id,_) -> id
            | Tpat_alias ({pat_desc=Tpat_any}, id,_) -> id
            | _ -> assert false)
        pat_expr_list in
      let transl_case {vb_expr=expr; vb_attributes; vb_loc} id =
        let lam = transl_exp expr in
        let lam =
          Translattribute.add_inline_attribute lam vb_loc
            vb_attributes
        in
        let lam =
          Translattribute.add_specialise_attribute lam vb_loc
            vb_attributes
        in
        (id, lam) in
      Lletrec(List.map2 transl_case pat_expr_list idlist, body)

and transl_setinstvar loc self var expr =
  Lprim(Psetfield_computed (maybe_pointer expr, Assignment),
    [self; transl_normal_path var; transl_exp expr], loc)

and transl_record loc env fields repres opt_init_expr =
  let size = Array.length fields in
  (* Determine if there are "enough" fields (only relevant if this is a
     functional-style record update *)
  let no_init = match opt_init_expr with None -> true | _ -> false in
  if no_init || size < (if !Clflags.bs_only then 20 else Config.max_young_wosize) 
  (* TODO: More strategies
     3 + 2 * List.length lbl_expr_list >= size (density)
  *)
  then begin
    (* Allocate new record with given fields (and remaining fields
       taken from init_expr if any *)
    let init_id = Ident.create "init" in
    let lv =
      Array.mapi
        (fun i (lbl, definition) ->
           match definition with
           | Kept typ ->
               let field_kind = value_kind env typ in
               let access =
                 match repres with
                   Record_regular ->   Pfield (i, Fld_record lbl.lbl_name) 
                 | Record_inlined _ -> Pfield (i, Fld_record_inline lbl.lbl_name) 
                 | Record_unboxed _ -> assert false
                 | Record_extension -> Pfield (i + 1, Fld_record_extension lbl.lbl_name) 
                 | Record_float -> Pfloatfield (i, Fld_record lbl.lbl_name) in
               Lprim(access, [Lvar init_id], loc), field_kind
           | Overridden (_lid, expr) ->
               let field_kind = value_kind expr.exp_env expr.exp_type in
               transl_exp expr, field_kind)
        fields
    in
    let ll, shape = List.split (Array.to_list lv) in
    let mut =
      if Array.exists (fun (lbl, _) -> lbl.lbl_mut = Mutable) fields
      then Mutable
      else Immutable in
    let all_labels_info = fields |> Array.map (fun (x,_) -> x.Types.lbl_name) in    
    let lam =
      try
        if mut = Mutable then raise Not_constant;
        let cl = List.map extract_constant ll in
        match repres with
        | Record_regular -> Lconst(Const_block(0, Lambda.Blk_record all_labels_info, cl))
        | Record_inlined {tag;name;num_nonconsts} -> Lconst(Const_block(tag, Lambda.Blk_record_inlined (all_labels_info,name,num_nonconsts), cl))
        | Record_unboxed _ -> Lconst(match cl with [v] -> v | _ -> assert false)
        | Record_float ->
            if !Clflags.bs_only then Lconst(Const_block(0, Lambda.Blk_record all_labels_info, cl))
            else
            Lconst(Const_float_array(List.map extract_float cl))
        | Record_extension ->
            raise Not_constant
      with Not_constant ->
        match repres with
          Record_regular ->
            Lprim(Pmakeblock(0, Lambda.Blk_record all_labels_info, mut, Some shape), ll, loc)
        | Record_inlined {tag;name; num_nonconsts} ->
            Lprim(Pmakeblock(tag, Lambda.Blk_record_inlined (all_labels_info, name, num_nonconsts), mut, Some shape), ll, loc)
        | Record_unboxed _ -> (match ll with [v] -> v | _ -> assert false)
        | Record_float ->
            if !Clflags.bs_only then Lprim(Pmakeblock(0, Lambda.Blk_record all_labels_info, mut, Some shape), ll, loc)
            else
            Lprim(Pmakearray (Pfloatarray, mut), ll, loc)
        | Record_extension ->
            let path =
              let (label, _) = fields.(0) in
              match label.lbl_res.desc with
              | Tconstr(p, _, _) -> p
              | _ -> assert false
            in
            let slot = transl_extension_path env path in
            Lprim(Pmakeblock(0, Lambda.Blk_record_ext all_labels_info, mut, Some (Pgenval :: shape)), slot :: ll, loc) 
    in
    begin match opt_init_expr with
      None -> lam
    | Some init_expr -> Llet(Strict, Pgenval, init_id,
                             transl_exp init_expr, lam)
    end
  end else begin
    (* Take a shallow copy of the init record, then mutate the fields
       of the copy *)
    let copy_id = Ident.create "newrecord" in
    let update_field cont (lbl, definition) =
      match definition with
      | Kept _type -> cont
      | Overridden (_lid, expr) ->
          let upd =
            match repres with
              Record_regular -> 
              Psetfield(lbl.lbl_pos, maybe_pointer expr, Assignment, Fld_record_set lbl.lbl_name)
            | Record_inlined _ -> 
                Psetfield(lbl.lbl_pos, maybe_pointer expr, Assignment, Fld_record_inline_set lbl.lbl_name)
            | Record_unboxed _ -> assert false
            | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment, Fld_record_set lbl.lbl_name)
            | Record_extension -> 
                Psetfield(lbl.lbl_pos + 1, maybe_pointer expr, Assignment, Fld_record_extension_set lbl.lbl_name)
          in
          Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr], loc), cont)
    in
    begin match opt_init_expr with
      None -> assert false
    | Some init_expr ->
        Llet(Strict, Pgenval, copy_id,
             Lprim(Pduprecord (repres, size), [transl_exp init_expr], loc),
             Array.fold_left update_field (Lvar copy_id) fields)
    end
  end

and transl_match e arg pat_expr_list exn_pat_expr_list partial =
  let id = Typecore.name_pattern "exn" exn_pat_expr_list
  and cases = transl_cases pat_expr_list
  and exn_cases = transl_cases_try exn_pat_expr_list in
  let static_catch body val_ids handler =
    let static_exception_id = next_negative_raise_count () in
    Lstaticcatch
      (Ltrywith (Lstaticraise (static_exception_id, body), id,
                 Matching.for_trywith (Lvar id) exn_cases),
       (static_exception_id, val_ids),
       handler)
  in
  match arg, exn_cases with
  | {exp_desc = Texp_tuple argl}, [] ->
    Matching.for_multiple_match e.exp_loc (transl_list argl) cases partial
  | {exp_desc = Texp_tuple argl}, _ :: _ ->
    let val_ids = List.map (fun _ -> Typecore.name_pattern "val" []) argl in
    let lvars = List.map (fun id -> Lvar id) val_ids in
    static_catch (transl_list argl) val_ids
      (Matching.for_multiple_match e.exp_loc lvars cases partial)
  | arg, [] ->
    Matching.for_function e.exp_loc None (transl_exp arg) cases partial
  | arg, _ :: _ ->
    let val_id = Typecore.name_pattern "val" pat_expr_list in
    static_catch [transl_exp arg] [val_id]
      (Matching.for_function e.exp_loc None (Lvar val_id) cases partial)


(* Wrapper for class compilation *)

(*
let transl_exp = transl_exp_wrap

let transl_let rec_flag pat_expr_list body =
  match pat_expr_list with
    [] -> body
  | (_, expr) :: _ ->
      Translobj.oo_wrap expr.exp_env false
        (transl_let rec_flag pat_expr_list) body
*)

(* Error report *)

open Format

let report_error ppf = function
  | Free_super_var ->
      fprintf ppf
        "Ancestor names can only be used to select inherited methods"
  | Unknown_builtin_primitive prim_name ->
      fprintf ppf "Unknown builtin primitive \"%s\"" prim_name
  | Unreachable_reached ->
      fprintf ppf "Unreachable expression was reached"

let () =
  Location.register_error_of_exn
    (function
      | Error (loc, err) ->
          Some (Location.error_of_printer loc report_error err)
      | _ ->
        None
    )

end
module Translclass : sig 
#1 "translclass.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Typedtree
open Lambda

val transl_class :
  Ident.t list -> Ident.t ->
  string list -> class_expr -> Asttypes.virtual_flag -> lambda;;

type error = Tags of string * string

exception Error of Location.t * error

open Format

val report_error: formatter -> error -> unit

end = struct
#1 "translclass.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Asttypes
open Types
open Typedtree
open Lambda
open Translobj
open Translcore

(* XXX Rajouter des evenements... | Add more events... *)

type error = Tags of label * label

exception Error of Location.t * error

let lfunction params body =
  if params = [] then body else
  match body with
  | Lfunction {kind = Curried; params = params'; body = body'; attr; loc} ->
      Lfunction {kind = Curried; params = params @ params'; body = body'; attr;
                 loc}
  |  _ ->
      Lfunction {kind = Curried; params;
                 body;
                 attr = default_function_attribute;
                 loc = Location.none}

let lapply ap =
  match ap.ap_func with
    Lapply ap' ->
      Lapply {ap with ap_func = ap'.ap_func; ap_args = ap'.ap_args @ ap.ap_args}
  | _ ->
      Lapply ap

let mkappl (func, args) =
  Lapply {ap_should_be_tailcall=false;
          ap_loc=Location.none;
          ap_func=func;
          ap_args=args;
          ap_inlined=Default_inline;
          ap_specialised=Default_specialise};;

let lsequence l1 l2 =
  if l2 = lambda_unit then l1 else Lsequence(l1, l2)

let lfield v i = Lprim(Pfield (i, Fld_na), [Lvar v], Location.none)

let transl_label l = share (Const_immstring l)

let transl_meth_list lst =
  if lst = [] then Lconst (Const_pointer (0, Lambda.Pt_na)) else
  share (Const_block
            (0, Lambda.Blk_na, List.map (fun lab -> Const_immstring lab) lst))

let set_inst_var obj id expr =
  Lprim(Psetfield_computed (Typeopt.maybe_pointer expr, Assignment),
    [Lvar obj; Lvar id; transl_exp expr], Location.none)

let transl_val tbl create name =
  mkappl (oo_prim (if create then "new_variable" else "get_variable"),
          [Lvar tbl; transl_label name])

let transl_vals tbl create strict vals rem =
  List.fold_right
    (fun (name, id) rem ->
      Llet(strict, Pgenval, id, transl_val tbl create name, rem))
    vals rem

let meths_super tbl meths inh_meths =
  List.fold_right
    (fun (nm, id) rem ->
       try
         (nm, id,
          mkappl(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)]))
         :: rem
       with Not_found -> rem)
    inh_meths []

let bind_super tbl (vals, meths) cl_init =
  transl_vals tbl false StrictOpt vals
    (List.fold_right (fun (_nm, id, def) rem ->
         Llet(StrictOpt, Pgenval, id, def, rem))
       meths cl_init)

let create_object cl obj init =
  let obj' = Ident.create "self" in
  let (inh_init, obj_init, has_init) = init obj' in
  if obj_init = lambda_unit then
    (inh_init,
     mkappl (oo_prim (if has_init then "create_object_and_run_initializers"
                      else"create_object_opt"),
             [obj; Lvar cl]))
  else begin
   (inh_init,
    Llet(Strict, Pgenval, obj',
            mkappl (oo_prim "create_object_opt", [obj; Lvar cl]),
         Lsequence(obj_init,
                   if not has_init then Lvar obj' else
                   mkappl (oo_prim "run_initializers_opt",
                           [obj; Lvar obj'; Lvar cl]))))
  end

let name_pattern default p =
  match p.pat_desc with
  | Tpat_var (id, _) -> id
  | Tpat_alias(_, id, _) -> id
  | _ -> Ident.create default

let normalize_cl_path cl path =
  Env.normalize_path (Some cl.cl_loc) cl.cl_env path

let rec build_object_init cl_table obj params inh_init obj_init cl =
  match cl.cl_desc with
    Tcl_ident ( path, _, _) ->
      let obj_init = Ident.create "obj_init" in
      let envs, inh_init = inh_init in
      let env =
        match envs with None -> []
        | Some envs ->
            [Lprim(Pfield (List.length inh_init + 1, Fld_na),
                   [Lvar envs],
                   Location.none)]
      in
      ((envs, (obj_init, normalize_cl_path cl path)
        ::inh_init),
       mkappl(Lvar obj_init, env @ [obj]))
  | Tcl_structure str ->
      create_object cl_table obj (fun obj ->
        let (inh_init, obj_init, has_init) =
          List.fold_right
            (fun field (inh_init, obj_init, has_init) ->
               match field.cf_desc with
                 Tcf_inherit (_, cl, _, _, _) ->
                   let (inh_init, obj_init') =
                     build_object_init cl_table (Lvar obj) [] inh_init
                       (fun _ -> lambda_unit) cl
                   in
                   (inh_init, lsequence obj_init' obj_init, true)
               | Tcf_val (_, _, id, Tcfk_concrete (_, exp), _) ->
                   (inh_init, lsequence (set_inst_var obj id exp) obj_init,
                    has_init)
               | Tcf_method _ | Tcf_val _ | Tcf_constraint _ | Tcf_attribute _->
                   (inh_init, obj_init, has_init)
               | Tcf_initializer _ ->
                   (inh_init, obj_init, true)
            )
            str.cstr_fields
            (inh_init, obj_init obj, false)
        in
        (inh_init,
         List.fold_right
           (fun (id, expr) rem ->
              lsequence (Lifused (id, set_inst_var obj id expr)) rem)
           params obj_init,
         has_init))
  | Tcl_fun (_, pat, vals, cl, partial) ->
      let vals = List.map (fun (id, _, e) -> id,e) vals in
      let (inh_init, obj_init) =
        build_object_init cl_table obj (vals @ params) inh_init obj_init cl
      in
      (inh_init,
       let build params rem =
         let param = name_pattern "param" pat in
         Lfunction {kind = Curried; params = param::params;
                    attr = default_function_attribute;
                    loc = pat.pat_loc;
                    body = Matching.for_function
                             pat.pat_loc None (Lvar param) [pat, rem] partial}
       in
       begin match obj_init with
         Lfunction {kind = Curried; params; body = rem} -> build params rem
       | rem                                            -> build [] rem
       end)
  | Tcl_apply (cl, oexprs) ->
      let (inh_init, obj_init) =
        build_object_init cl_table obj params inh_init obj_init cl
      in
      (inh_init, transl_apply obj_init oexprs Location.none)
  | Tcl_let (rec_flag, defs, vals, cl) ->
      let vals = List.map (fun (id, _, e) -> id,e) vals in
      let (inh_init, obj_init) =
        build_object_init cl_table obj (vals @ params) inh_init obj_init cl
      in
      (inh_init, Translcore.transl_let rec_flag defs obj_init)
  | Tcl_open (_, _, _, _, cl)
  | Tcl_constraint (cl, _, _, _, _) ->
      build_object_init cl_table obj params inh_init obj_init cl

let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
  match cl.cl_desc with
    Tcl_let (_rec_flag, _defs, vals, cl) ->
      let vals = List.map (fun (id, _, e) -> id,e) vals in
      build_object_init_0 cl_table (vals@params) cl copy_env subst_env top ids
  | _ ->
      let self = Ident.create "self" in
      let env = Ident.create "env" in
      let obj = if ids = [] then lambda_unit else Lvar self in
      let envs = if top then None else Some env in
      let ((_,inh_init), obj_init) =
        build_object_init cl_table obj params (envs,[]) copy_env cl in
      let obj_init =
        if ids = [] then obj_init else lfunction [self] obj_init in
      (inh_init, lfunction [env] (subst_env env inh_init obj_init))


let bind_method tbl lab id cl_init =
  Llet(Strict, Pgenval, id, mkappl (oo_prim "get_method_label",
                           [Lvar tbl; transl_label lab]),
       cl_init)

let bind_methods tbl meths vals cl_init =
  let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in
  let len = List.length methl and nvals = List.length vals in
  if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else
  if len = 0 && nvals < 2 then transl_vals tbl true Strict vals cl_init else
  let ids = Ident.create "ids" in
  let i = ref (len + nvals) in
  let getter, names =
    if nvals = 0 then "get_method_labels", [] else
    "new_methods_variables", [transl_meth_list (List.map fst vals)]
  in
  Llet(Strict, Pgenval, ids,
       mkappl (oo_prim getter,
               [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
       List.fold_right
         (fun (_lab,id) lam -> decr i; Llet(StrictOpt, Pgenval, id,
                                           lfield ids !i, lam))
         (methl @ vals) cl_init)

let output_methods tbl methods lam =
  match methods with
    [] -> lam
  | [lab; code] ->
      lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code])) lam
  | _ ->
      lsequence (mkappl(oo_prim "set_methods",
                        [Lvar tbl; Lprim(Pmakeblock(0, Lambda.Blk_array, Immutable,None),
                                         methods, Location.none)]))
        lam

let rec ignore_cstrs cl =
  match cl.cl_desc with
    Tcl_constraint (cl, _, _, _, _) -> ignore_cstrs cl
  | Tcl_apply (cl, _) -> ignore_cstrs cl
  | _ -> cl

let rec index a = function
    [] -> raise Not_found
  | b :: l ->
      if b = a then 0 else 1 + index a l

let bind_id_as_val (id, _, _) = ("", id)

let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
  match cl.cl_desc with
    Tcl_ident ( path, _, _) ->
      begin match inh_init with
        (obj_init, _path')::inh_init ->
          let lpath = transl_class_path ~loc:cl.cl_loc cl.cl_env path in
          (inh_init,
           Llet (Strict, Pgenval, obj_init,
                 mkappl(Lprim(Pfield (1, Fld_na), [lpath], Location.none), Lvar cla ::
                        if top then [Lprim(Pfield (3, Fld_na), [lpath], Location.none)]
                        else []),
                 bind_super cla super cl_init))
      | _ ->
          assert false
      end
  | Tcl_structure str ->
      let cl_init = bind_super cla super cl_init in
      let (inh_init, cl_init, methods, values) =
        List.fold_right
          (fun field (inh_init, cl_init, methods, values) ->
            match field.cf_desc with
              Tcf_inherit (_, cl, _, vals, meths) ->
                let cl_init = output_methods cla methods cl_init in
                let inh_init, cl_init =
                  build_class_init cla false
                    (vals, meths_super cla str.cstr_meths meths)
                    inh_init cl_init msubst top cl in
                (inh_init, cl_init, [], values)
            | Tcf_val (name, _, id, _, over) ->
                let values =
                  if over then values else (name.txt, id) :: values
                in
                (inh_init, cl_init, methods, values)
            | Tcf_method (_, _, Tcfk_virtual _)
            | Tcf_constraint _
              ->
                (inh_init, cl_init, methods, values)
            | Tcf_method (name, _, Tcfk_concrete (_, exp)) ->
                let met_code = msubst true (transl_exp exp) in
                let met_code =
                  if !Clflags.native_code && List.length met_code = 1 then
                    (* Force correct naming of method for profiles *)
                    let met = Ident.create ("method_" ^ name.txt) in
                    [Llet(Strict, Pgenval, met, List.hd met_code, Lvar met)]
                  else met_code
                in
                (inh_init, cl_init,
                 Lvar(Meths.find name.txt str.cstr_meths) :: met_code @ methods,
                 values)
            | Tcf_initializer exp ->
                (inh_init,
                 Lsequence(mkappl (oo_prim "add_initializer",
                                   Lvar cla :: msubst false (transl_exp exp)),
                           cl_init),
                 methods, values)
            | Tcf_attribute _ ->
                (inh_init, cl_init, methods, values))
          str.cstr_fields
          (inh_init, cl_init, [], [])
      in
      let cl_init = output_methods cla methods cl_init in
      (inh_init, bind_methods cla str.cstr_meths values cl_init)
  | Tcl_fun (_, _pat, vals, cl, _) ->
      let (inh_init, cl_init) =
        build_class_init cla cstr super inh_init cl_init msubst top cl
      in
      let vals = List.map bind_id_as_val vals in
      (inh_init, transl_vals cla true StrictOpt vals cl_init)
  | Tcl_apply (cl, _exprs) ->
      build_class_init cla cstr super inh_init cl_init msubst top cl
  | Tcl_let (_rec_flag, _defs, vals, cl) ->
      let (inh_init, cl_init) =
        build_class_init cla cstr super inh_init cl_init msubst top cl
      in
      let vals = List.map bind_id_as_val vals in
      (inh_init, transl_vals cla true StrictOpt vals cl_init)
  | Tcl_constraint (cl, _, vals, meths, concr_meths) ->
      let virt_meths =
        List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in
      let concr_meths = Concr.elements concr_meths in
      let narrow_args =
        [Lvar cla;
         transl_meth_list vals;
         transl_meth_list virt_meths;
         transl_meth_list concr_meths] in
      let cl = ignore_cstrs cl in
      begin match cl.cl_desc, inh_init with
        Tcl_ident (path, _, _), (obj_init, path')::inh_init ->
          assert (Path.same (normalize_cl_path cl path) path');
          let lpath = transl_normal_path path' in
          let inh = Ident.create "inh"
          and ofs = List.length vals + 1
          and valids, methids = super in
          let cl_init =
            List.fold_left
              (fun init (nm, id, _) ->
                Llet(StrictOpt, Pgenval, id,
                     lfield inh (index nm concr_meths + ofs),
                     init))
              cl_init methids in
          let cl_init =
            List.fold_left
              (fun init (nm, id) ->
                Llet(StrictOpt, Pgenval, id,
                     lfield inh (index nm vals + 1), init))
              cl_init valids in
          (inh_init,
           Llet (Strict, Pgenval, inh,
                 mkappl(oo_prim "inherits", narrow_args @
                        [lpath; Lconst(Const_pointer((if top then 1 else 0),Lambda.Pt_na))]),
                 Llet(StrictOpt, Pgenval, obj_init, lfield inh 0, cl_init)))
      | _ ->
          let core cl_init =
            build_class_init cla true super inh_init cl_init msubst top cl
          in
          if cstr then core cl_init else
          let (inh_init, cl_init) =
            core (Lsequence (mkappl (oo_prim "widen", [Lvar cla]), cl_init))
          in
          (inh_init,
           Lsequence(mkappl (oo_prim "narrow", narrow_args),
                     cl_init))
      end
  | Tcl_open (_, _, _, _, cl) ->
      build_class_init cla cstr super inh_init cl_init msubst top cl

let rec build_class_lets cl =
  match cl.cl_desc with
    Tcl_let (rec_flag, defs, _vals, cl') ->
      let env, wrap = build_class_lets cl' in
      (env, fun x ->
          Translcore.transl_let rec_flag defs (wrap x))
  | _ ->
      (cl.cl_env, fun x -> x)

let rec get_class_meths cl =
  match cl.cl_desc with
    Tcl_structure cl ->
      Meths.fold (fun _ -> IdentSet.add) cl.cstr_meths IdentSet.empty
  | Tcl_ident _ -> IdentSet.empty
  | Tcl_fun (_, _, _, cl, _)
  | Tcl_let (_, _, _, cl)
  | Tcl_apply (cl, _)
  | Tcl_open (_, _, _, _, cl)
  | Tcl_constraint (cl, _, _, _, _) -> get_class_meths cl

(*
   XXX Il devrait etre peu couteux d'ecrire des classes :
   |   Writing classes should be cheap
     class c x y = d e f
*)
let rec transl_class_rebind obj_init cl vf =
  match cl.cl_desc with
    Tcl_ident (path, _, _) ->
      if vf = Concrete then begin
        try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit
        with Not_found -> raise Exit
      end;
      (normalize_cl_path cl path, obj_init)
  | Tcl_fun (_, pat, _, cl, partial) ->
      let path, obj_init = transl_class_rebind obj_init cl vf in
      let build params rem =
        let param = name_pattern "param" pat in
        Lfunction {kind = Curried; params = param::params;
                   attr = default_function_attribute;
                   loc = pat.pat_loc;
                   body = Matching.for_function
                            pat.pat_loc None (Lvar param) [pat, rem] partial}
      in
      (path,
       match obj_init with
         Lfunction {kind = Curried; params; body} -> build params body
       | rem                                      -> build [] rem)
  | Tcl_apply (cl, oexprs) ->
      let path, obj_init = transl_class_rebind obj_init cl vf in
      (path, transl_apply obj_init oexprs Location.none)
  | Tcl_let (rec_flag, defs, _vals, cl) ->
      let path, obj_init = transl_class_rebind obj_init cl vf in
      (path, Translcore.transl_let rec_flag defs obj_init)
  | Tcl_structure _ -> raise Exit
  | Tcl_constraint (cl', _, _, _, _) ->
      let path, obj_init = transl_class_rebind obj_init cl' vf in
      let rec check_constraint = function
          Cty_constr(path', _, _) when Path.same path path' -> ()
        | Cty_arrow (_, _, cty) -> check_constraint cty
        | _ -> raise Exit
      in
      check_constraint cl.cl_type;
      (path, obj_init)
  | Tcl_open (_, _, _, _, cl) ->
      transl_class_rebind obj_init cl vf

let rec transl_class_rebind_0 self obj_init cl vf =
  match cl.cl_desc with
    Tcl_let (rec_flag, defs, _vals, cl) ->
      let path, obj_init = transl_class_rebind_0 self obj_init cl vf in
      (path, Translcore.transl_let rec_flag defs obj_init)
  | _ ->
      let path, obj_init = transl_class_rebind obj_init cl vf in
      (path, lfunction [self] obj_init)

let transl_class_rebind cl vf =
  try
    let obj_init = Ident.create "obj_init"
    and self = Ident.create "self" in
    let obj_init0 =
      lapply {ap_should_be_tailcall=false;
              ap_loc=Location.none;
              ap_func=Lvar obj_init;
              ap_args=[Lvar self];
              ap_inlined=Default_inline;
              ap_specialised=Default_specialise}
    in
    let path, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in
    let id = (obj_init' = lfunction [self] obj_init0) in
    if id then transl_normal_path path else

    let cla = Ident.create "class"
    and new_init = Ident.create "new_init"
    and env_init = Ident.create "env_init"
    and table = Ident.create "table"
    and envs = Ident.create "envs" in
    Llet(
    Strict, Pgenval, new_init, lfunction [obj_init] obj_init',
    Llet(
    Alias, Pgenval, cla, transl_normal_path path,
    Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None),
          [mkappl(Lvar new_init, [lfield cla 0]);
           lfunction [table]
             (Llet(Strict, Pgenval, env_init,
                   mkappl(lfield cla 1, [Lvar table]),
                   lfunction [envs]
                     (mkappl(Lvar new_init,
                             [mkappl(Lvar env_init, [Lvar envs])]))));
           lfield cla 2;
           lfield cla 3],
          Location.none)))
  with Exit ->
    lambda_unit

(* Rewrite a closure using builtins. Improves native code size. *)

let rec module_path = function
    Lvar id ->
      let s = Ident.name id in s <> "" && s.[0] >= 'A' && s.[0] <= 'Z'
  | Lprim(Pfield _, [p], _)    -> module_path p
  | Lprim(Pgetglobal _, [], _) -> true
  | _                          -> false

let const_path local = function
    Lvar id -> not (List.mem id local)
  | Lconst _ -> true
  | Lfunction {kind = Curried; body} ->
      let fv = free_variables body in
      List.for_all (fun x -> not (IdentSet.mem x fv)) local
  | p -> module_path p

let rec builtin_meths self env env2 body =
  let const_path = const_path (env::self) in
  let conv = function
    (* Lvar s when List.mem s self ->  "_self", [] *)
    | p when const_path p -> "const", [p]
    | Lprim(Parrayrefu _, [Lvar s; Lvar n], _) when List.mem s self ->
        "var", [Lvar n]
    | Lprim(Pfield (n,_), [Lvar e], _) when Ident.same e env ->
        "env", [Lvar env2; Lconst(Const_pointer (n, Lambda.Pt_na))]
    | Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
        "meth", [met]
    | _ -> raise Not_found
  in
  match body with
  | Llet(_str, _k, s', Lvar s, body) when List.mem s self ->
      builtin_meths (s'::self) env env2 body
  | Lapply{ap_func = f; ap_args = [arg]} when const_path f ->
      let s, args = conv arg in ("app_"^s, f :: args)
  | Lapply{ap_func = f; ap_args = [arg; p]} when const_path f && const_path p ->
      let s, args = conv arg in
      ("app_"^s^"_const", f :: args @ [p])
  | Lapply{ap_func = f; ap_args = [p; arg]} when const_path f && const_path p ->
      let s, args = conv arg in
      ("app_const_"^s, f :: p :: args)
  | Lsend(Self, Lvar n, Lvar s, [arg], _) when List.mem s self ->
      let s, args = conv arg in
      ("meth_app_"^s, Lvar n :: args)
  | Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
      ("get_meth", [met])
  | Lsend(Public _, met, arg, [], _) ->
      let s, args = conv arg in
      ("send_"^s, met :: args)
  | Lsend(Cached, met, arg, [_;_], _) ->
      let s, args = conv arg in
      ("send_"^s, met :: args)
  | Lfunction {kind = Curried; params = [x]; body} ->
      let rec enter self = function
        | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'], _)
          when Ident.same x x' && List.mem s self ->
            ("set_var", [Lvar n])
        | Llet(_str, _k, s', Lvar s, body) when List.mem s self ->
            enter (s'::self) body
        | _ -> raise Not_found
      in enter self body
  | Lfunction _ -> raise Not_found
  | _ ->
      let s, args = conv body in ("get_"^s, args)

module M = struct
  open CamlinternalOO
  let builtin_meths self env env2 body =
    let builtin, args = builtin_meths self env env2 body in
    (* if not arr then [mkappl(oo_prim builtin, args)] else *)
    let tag = match builtin with
      "get_const" -> GetConst
    | "get_var"   -> GetVar
    | "get_env"   -> GetEnv
    | "get_meth"  -> GetMeth
    | "set_var"   -> SetVar
    | "app_const" -> AppConst
    | "app_var"   -> AppVar
    | "app_env"   -> AppEnv
    | "app_meth"  -> AppMeth
    | "app_const_const" -> AppConstConst
    | "app_const_var"   -> AppConstVar
    | "app_const_env"   -> AppConstEnv
    | "app_const_meth"  -> AppConstMeth
    | "app_var_const"   -> AppVarConst
    | "app_env_const"   -> AppEnvConst
    | "app_meth_const"  -> AppMethConst
    | "meth_app_const"  -> MethAppConst
    | "meth_app_var"    -> MethAppVar
    | "meth_app_env"    -> MethAppEnv
    | "meth_app_meth"   -> MethAppMeth
    | "send_const" -> SendConst
    | "send_var"   -> SendVar
    | "send_env"   -> SendEnv
    | "send_meth"  -> SendMeth
    | _ -> assert false
    in Lconst(Const_pointer(Obj.magic tag, Lambda.Pt_na)) :: args
end
open M


(*
   Class translation.
   Three subcases:
    * reapplication of a known class -> transl_class_rebind
    * class without local dependencies -> direct translation
    * with local dependencies -> generate a stubs tree,
      with a node for every local classes inherited
   A class is a 4-tuple:
    (obj_init, class_init, env_init, env)
    obj_init: creation function (unit -> obj)
    class_init: inheritance function (table -> env_init)
      (one by source code)
    env_init: parameterisation by the local environment
      (env -> params -> obj_init)
      (one for each combination of inherited class_init )
    env: local environment
   If ids=0 (immediate object), then only env_init is conserved.
*)

(*
let prerr_ids msg ids =
  let names = List.map Ident.unique_toplevel_name ids in
  prerr_endline (String.concat " " (msg :: names))
*)

let transl_class ids cl_id pub_meths cl vflag =
  (* First check if it is not only a rebind *)
  let rebind = transl_class_rebind cl vflag in
  if rebind <> lambda_unit then rebind else

  (* Prepare for heavy environment handling *)
  let tables = Ident.create (Ident.name cl_id ^ "_tables") in
  let (top_env, req) = oo_add_class tables in
  let top = not req in
  let cl_env, llets = build_class_lets cl in
  let new_ids = if top then [] else Env.diff top_env cl_env in
  let env2 = Ident.create "env" in
  let meth_ids = get_class_meths cl in
  let subst env lam i0 new_ids' =
    let fv = free_variables lam in
    (* prerr_ids "cl_id =" [cl_id]; prerr_ids "fv =" (IdentSet.elements fv); *)
    let fv = List.fold_right IdentSet.remove !new_ids' fv in
    (* We need to handle method ids specially, as they do not appear
       in the typing environment (PR#3576, PR#4560) *)
    (* very hacky: we add and remove free method ids on the fly,
       depending on the visit order... *)
    method_ids :=
      IdentSet.diff (IdentSet.union (free_methods lam) !method_ids) meth_ids;
    (* prerr_ids "meth_ids =" (IdentSet.elements meth_ids);
       prerr_ids "method_ids =" (IdentSet.elements !method_ids); *)
    let new_ids = List.fold_right IdentSet.add new_ids !method_ids in
    let fv = IdentSet.inter fv new_ids in
    new_ids' := !new_ids' @ IdentSet.elements fv;
    (* prerr_ids "new_ids' =" !new_ids'; *)
    let i = ref (i0-1) in
    List.fold_left
      (fun subst id ->
        incr i; Ident.add id (lfield env !i)  subst)
      Ident.empty !new_ids'
  in
  let new_ids_meths = ref [] in
  let msubst arr = function
      Lfunction {kind = Curried; params = self :: args; body} ->
        let env = Ident.create "env" in
        let body' =
          if new_ids = [] then body else
          subst_lambda (subst env body 0 new_ids_meths) body in
        begin try
          (* Doesn't seem to improve size for bytecode *)
          (* if not !Clflags.native_code then raise Not_found; *)
          if not arr || !Clflags.debug then raise Not_found;
          builtin_meths [self] env env2 (lfunction args body')
        with Not_found ->
          [lfunction (self :: args)
             (if not (IdentSet.mem env (free_variables body')) then body' else
              Llet(Alias, Pgenval, env,
                   Lprim(Pfield_computed,
                         [Lvar self; Lvar env2],
                         Location.none),
                   body'))]
        end
      | _ -> assert false
  in
  let new_ids_init = ref [] in
  let env1 = Ident.create "env" and env1' = Ident.create "env'" in
  let copy_env self =
    if top then lambda_unit else
    Lifused(env2, Lprim(Psetfield_computed (Pointer, Assignment),
                        [Lvar self; Lvar env2; Lvar env1'],
                        Location.none))
  and subst_env envs l lam =
    if top then lam else
    (* must be called only once! *)
    let lam = subst_lambda (subst env1 lam 1 new_ids_init) lam in
    Llet(Alias, Pgenval, env1, (if l = [] then Lvar envs else lfield envs 0),
    Llet(Alias, Pgenval, env1',
         (if !new_ids_init = [] then Lvar env1 else lfield env1 0),
         lam))
  in

  (* Now we start compiling the class *)
  let cla = Ident.create "class" in
  let (inh_init, obj_init) =
    build_object_init_0 cla [] cl copy_env subst_env top ids in
  let inh_init' = List.rev inh_init in
  let (inh_init', cl_init) =
    build_class_init cla true ([],[]) inh_init' obj_init msubst top cl
  in
  assert (inh_init' = []);
  let table = Ident.create "table"
  and class_init = Ident.create (Ident.name cl_id ^ "_init")
  and env_init = Ident.create "env_init"
  and obj_init = Ident.create "obj_init" in
  let pub_meths =
    List.sort
      (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s'))
      pub_meths in
  let tags = List.map Btype.hash_variant pub_meths in
  let rev_map = List.combine tags pub_meths in
  List.iter2
    (fun tag name ->
      let name' = List.assoc tag rev_map in
      if name' <> name then raise(Error(cl.cl_loc, Tags(name, name'))))
    tags pub_meths;
  let ltable table lam =
    Llet(Strict, Pgenval, table,
         mkappl (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
  and ldirect obj_init =
    Llet(Strict, Pgenval, obj_init, cl_init,
         Lsequence(mkappl (oo_prim "init_class", [Lvar cla]),
                   mkappl (Lvar obj_init, [lambda_unit])))
  in
  (* Simplest case: an object defined at toplevel (ids=[]) *)
  if top && ids = [] then llets (ltable cla (ldirect obj_init)) else

  let concrete = (vflag = Concrete)
  and lclass lam =
    let cl_init = llets (Lfunction{kind = Curried;
                                   attr = default_function_attribute;
                                   loc = Location.none;
                                   params = [cla]; body = cl_init}) in
    Llet(Strict, Pgenval, class_init, cl_init, lam (free_variables cl_init))
  and lbody fv =
    if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then
      mkappl (oo_prim "make_class",[transl_meth_list pub_meths;
                                    Lvar class_init])
    else
      ltable table (
      Llet(
      Strict, Pgenval, env_init, mkappl (Lvar class_init, [Lvar table]),
      Lsequence(
      mkappl (oo_prim "init_class", [Lvar table]),
      Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None),
            [mkappl (Lvar env_init, [lambda_unit]);
             Lvar class_init; Lvar env_init; lambda_unit],
            Location.none))))
  and lbody_virt lenvs =
    Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None),
          [lambda_unit; Lfunction{kind = Curried;
                                  attr = default_function_attribute;
                                  loc = Location.none;
                                  params = [cla]; body = cl_init};
           lambda_unit; lenvs],
         Location.none)
  in
  (* Still easy: a class defined at toplevel *)
  if top && concrete then lclass lbody else
  if top then llets (lbody_virt lambda_unit) else

  (* Now for the hard stuff: prepare for table caching *)
  let envs = Ident.create "envs"
  and cached = Ident.create "cached" in
  let lenvs =
    if !new_ids_meths = [] && !new_ids_init = [] && inh_init = []
    then lambda_unit
    else Lvar envs in
  let lenv =
    let menv =
      if !new_ids_meths = [] then lambda_unit else
      Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None),
            List.map (fun id -> Lvar id) !new_ids_meths,
            Location.none) in
    if !new_ids_init = [] then menv else
    Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None),
          menv :: List.map (fun id -> Lvar id) !new_ids_init,
          Location.none)
  and linh_envs =
    List.map
      (fun (_, p) -> Lprim(Pfield (3, Fld_na), [transl_normal_path p], Location.none))
      (List.rev inh_init)
  in
  let make_envs lam =
    Llet(StrictOpt, Pgenval, envs,
         (if linh_envs = [] then lenv else
         Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None),
               lenv :: linh_envs, Location.none)),
         lam)
  and def_ids cla lam =
    Llet(StrictOpt, Pgenval, env2,
         mkappl (oo_prim "new_variable", [Lvar cla; transl_label ""]),
         lam)
  in
  let inh_paths =
    List.filter
      (fun (_,path) -> List.mem (Path.head path) new_ids) inh_init
  in
  let inh_keys =
    List.map (fun (_,p) -> Lprim(Pfield (1, Fld_na), [transl_normal_path p],
                                 Location.none))
      inh_paths
  in
  let lclass lam =
    Llet(Strict, Pgenval, class_init,
         Lfunction{kind = Curried; params = [cla];
                   attr = default_function_attribute;
                   loc = Location.none;
                   body = def_ids cla cl_init}, lam)
  and lcache lam =
    if inh_keys = [] then Llet(Alias, Pgenval, cached, Lvar tables, lam) else
    Llet(Strict, Pgenval, cached,
         mkappl (oo_prim "lookup_tables",
                [Lvar tables; Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None),
                                    inh_keys, Location.none)]),
         lam)
  and lset cached i lam =
    Lprim(Psetfield(i, Pointer, Assignment, Fld_set_na),
          [Lvar cached; lam], Location.none)
  in
  let ldirect () =
    ltable cla
      (Llet(Strict, Pgenval, env_init, def_ids cla cl_init,
            Lsequence(mkappl (oo_prim "init_class", [Lvar cla]),
                      lset cached 0 (Lvar env_init))))
  and lclass_virt () =
    lset cached 0 (Lfunction{kind = Curried; attr = default_function_attribute;
                             loc = Location.none;
                             params = [cla]; body = def_ids cla cl_init})
  in
  let lupdate_cache =
    if ids = [] then ldirect () else
      if not concrete then lclass_virt () else
        lclass (
            mkappl (oo_prim "make_class_store",
                    [transl_meth_list pub_meths;
                     Lvar class_init; Lvar cached])) in
  let lcheck_cache =
    if !Clflags.native_code && !Clflags.afl_instrument then
      (* When afl-fuzz instrumentation is enabled, ignore the cache
         so that the program's behaviour does not change between runs *)
      lupdate_cache
    else
      Lifthenelse(lfield cached 0, lambda_unit, lupdate_cache) in
  llets (
  lcache (
  Lsequence(lcheck_cache,
  make_envs (
  if ids = [] then mkappl (lfield cached 0, [lenvs]) else
  Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None),
        (if concrete then
          [mkappl (lfield cached 0, [lenvs]);
           lfield cached 1;
           lfield cached 0;
           lenvs]
        else [lambda_unit; lfield cached 0; lambda_unit; lenvs]),
        Location.none
       )))))

(* Wrapper for class compilation *)
(*
    let cl_id = ci.ci_id_class in
(* TODO: cl_id is used somewhere else as typesharp ? *)
  let _arity = List.length ci.ci_params in
  let pub_meths = m in
  let cl = ci.ci_expr in
  let vflag = vf in
*)

let transl_class ids id pub_meths cl vf =
  oo_wrap cl.cl_env false (transl_class ids id pub_meths cl) vf

let () =
  transl_object := (fun id meths cl -> transl_class [] id meths cl Concrete)

(* Error report *)

open Format

let report_error ppf = function
  | Tags (lab1, lab2) ->
      fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s"
        lab1 lab2 "Change one of them."

let () =
  Location.register_error_of_exn
    (function
      | Error (loc, err) ->
        Some (Location.error_of_printer loc report_error err)
      | _ ->
        None
    )

end
module Translmod : sig 
#1 "translmod.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Translation from typed abstract syntax to lambda terms,
   for the module language *)

open Typedtree
open Lambda

val transl_implementation:
      string -> structure * module_coercion -> Lambda.program
val transl_store_phrases: string -> structure -> int * lambda
val transl_store_implementation:
      string -> structure * module_coercion -> Lambda.program

val transl_implementation_flambda:
  string -> structure * module_coercion -> Lambda.program

val transl_toplevel_definition: structure -> lambda
val transl_package:
      Ident.t option list -> Ident.t -> module_coercion -> lambda
val transl_store_package:
      Ident.t option list -> Ident.t -> module_coercion -> int * lambda

val transl_package_flambda:
      Ident.t option list -> module_coercion -> int * lambda

val toplevel_name: Ident.t -> string
val nat_toplevel_name: Ident.t -> Ident.t * int

val primitive_declarations: Primitive.description list ref

type error =
  Circular_dependency of Ident.t
| Conflicting_inline_attributes

exception Error of Location.t * error

val report_error: Format.formatter -> error -> unit

val reset: unit -> unit

(** make it an array for better performance*)
val get_export_identifiers : unit -> Ident.t list 

end = struct
#1 "translmod.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Translation from typed abstract syntax to lambda terms,
   for the module language *)

open Misc
open Asttypes
open Longident
open Path
open Types
open Typedtree
open Lambda
open Translobj
open Translcore
open Translclass

type error =
  Circular_dependency of Ident.t
| Conflicting_inline_attributes

exception Error of Location.t * error

(* Keep track of the root path (from the root of the namespace to the
   currently compiled module expression).  Useful for naming extensions. *)

let global_path glob = Some(Pident glob)
let is_top rootpath = 
  match rootpath with 
  | Some (Pident _ ) -> true
  | _ -> false 

let functor_path path param =
  match path with
    None -> None
  | Some p -> Some(Papply(p, Pident param))
let field_path path field =
  match path with
    None -> None
  | Some p -> Some(Pdot(p, Ident.name field, Path.nopos))

(* Compile type extensions *)

let transl_type_extension env rootpath tyext body =
  List.fold_right
    (fun ext body ->
      let lam =
        transl_extension_constructor env (field_path rootpath ext.ext_id) ext
      in
      Llet(Strict, Pgenval, ext.ext_id, lam, body))
    tyext.tyext_constructors
    body

(* Compile a coercion *)

let rec apply_coercion loc strict restr arg =
  match restr with
    Tcoerce_none ->
      arg
  | Tcoerce_structure(pos_cc_list, id_pos_list) ->
      name_lambda strict arg (fun id ->
        let get_field pos = Lprim(Pfield (pos, Fld_na),[Lvar id], loc) in
        let lam =
          Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None),
                List.map (apply_coercion_field loc get_field) pos_cc_list,
                loc)
        in
        wrap_id_pos_list loc id_pos_list get_field lam)
  | Tcoerce_functor(cc_arg, cc_res) ->
      let param = Ident.create "funarg" in
      let carg = apply_coercion loc Alias cc_arg (Lvar param) in
      apply_coercion_result loc strict arg [param] [carg] cc_res
  | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } ->
      transl_primitive pc_loc pc_desc pc_env pc_type None
  | Tcoerce_alias (path, cc) ->
      name_lambda strict arg
        (fun _ -> apply_coercion loc Alias cc (transl_normal_path path))

and apply_coercion_field loc get_field (pos, cc) =
  apply_coercion loc Alias cc (get_field pos)

and apply_coercion_result loc strict funct params args cc_res =
  match cc_res with
  | Tcoerce_functor(cc_arg, cc_res) ->
    let param = Ident.create "funarg" in
    let arg = apply_coercion loc Alias cc_arg (Lvar param) in
    apply_coercion_result loc strict funct
      (param :: params) (arg :: args) cc_res
  | _ ->
    name_lambda strict funct (fun id ->
      Lfunction{kind = Curried; params = List.rev params;
                attr = { default_function_attribute with
                         is_a_functor = true;
                         stub = true; };
                loc = loc;
                body = apply_coercion
                         loc Strict cc_res
                         (Lapply{ap_should_be_tailcall=false;
                                 ap_loc=loc;
                                 ap_func=Lvar id;
                                 ap_args=List.rev args;
                                 ap_inlined=Default_inline;
                                 ap_specialised=Default_specialise})})

and wrap_id_pos_list loc id_pos_list get_field lam =
  let fv = free_variables lam in
  (*Format.eprintf "%a@." Printlambda.lambda lam;
  IdentSet.iter (fun id -> Format.eprintf "%a " Ident.print id) fv;
  Format.eprintf "@.";*)
  let (lam,s) =
    List.fold_left (fun (lam,s) (id',pos,c) ->
      if IdentSet.mem id' fv then
        let id'' = Ident.create (Ident.name id') in
        (Llet(Alias, Pgenval, id'',
              apply_coercion loc Alias c (get_field pos),lam),
         Ident.add id' (Lvar id'') s)
      else (lam,s))
      (lam, Ident.empty) id_pos_list
  in
  if s == Ident.empty then lam else subst_lambda s lam


(* Compose two coercions
   apply_coercion c1 (apply_coercion c2 e) behaves like
   apply_coercion (compose_coercions c1 c2) e. *)

let rec compose_coercions c1 c2 =
  match (c1, c2) with
    (Tcoerce_none, c2) -> c2
  | (c1, Tcoerce_none) -> c1
  | (Tcoerce_structure (pc1, ids1), Tcoerce_structure (pc2, ids2)) ->
      let v2 = Array.of_list pc2 in
      let ids1 =
        List.map (fun (id,pos1,c1) ->
          let (pos2,c2) = v2.(pos1) in (id, pos2, compose_coercions c1 c2))
          ids1
      in
      Tcoerce_structure
        (List.map
          (function (_p1, Tcoerce_primitive _) as x ->
                      x (* (p1, Tcoerce_primitive p) *)
                  | (p1, c1) ->
                      let (p2, c2) = v2.(p1) in (p2, compose_coercions c1 c2))
             pc1,
         ids1 @ ids2)
  | (Tcoerce_functor(arg1, res1), Tcoerce_functor(arg2, res2)) ->
      Tcoerce_functor(compose_coercions arg2 arg1,
                      compose_coercions res1 res2)
  | (c1, Tcoerce_alias (path, c2)) ->
      Tcoerce_alias (path, compose_coercions c1 c2)
  | (_, _) ->
      fatal_error "Translmod.compose_coercions"

(*
let apply_coercion a b c =
  Format.eprintf "@[<2>apply_coercion@ %a@]@." Includemod.print_coercion b;
  apply_coercion a b c

let compose_coercions c1 c2 =
  let c3 = compose_coercions c1 c2 in
  let open Includemod in
  Format.eprintf "@[<2>compose_coercions@ (%a)@ (%a) =@ %a@]@."
    print_coercion c1 print_coercion c2 print_coercion c3;
  c3
*)

(* Record the primitive declarations occurring in the module compiled *)

let primitive_declarations = ref ([] : Primitive.description list)
let record_primitive = function
  | {val_kind=Val_prim p} ->
      primitive_declarations := p :: !primitive_declarations
  | _ -> ()

(* Utilities for compiling "module rec" definitions *)
let bs_init_mod args loc : Lambda.lambda =  
  Lprim(Pccall (Primitive.simple 
    ~name:"#init_mod"
    ~arity:2
    ~alloc:true), args, loc)
let bs_update_mod args loc : Lambda.lambda =
  Lprim(Pccall (Primitive.simple
    ~name:"#update_mod"
    ~arity:3
    ~alloc:true), args, loc)

let mod_prim name args loc =
  if !Clflags.bs_only then
    if name = "init_mod" then
      bs_init_mod args loc
    else if name = "update_mod" then
      bs_update_mod args loc
    else assert false
  else
  try
    Lapply
      {
      ap_func = transl_normal_path
        (fst (Env.lookup_value (Ldot (Lident "CamlinternalMod", name))
                Env.empty));
      ap_args =  args;
      ap_loc =  loc;
      ap_should_be_tailcall = false;
      ap_inlined = Default_inline;
      ap_specialised = Default_specialise;
      }
  with Not_found ->
    fatal_error ("Primitive " ^ name ^ " not found.")

let undefined_location loc =
  let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in
  
  let fname = Filename.basename fname in

  Lconst(Const_block(0, Lambda.default_tag_info,
                     [Const_base(Const_string (fname, None));
                      Const_base(Const_int line);
                      Const_base(Const_int char)]))

let init_shape modl =
  let rec init_shape_mod env mty =
    match Mtype.scrape env mty with
      Mty_ident _ ->
        raise Not_found
    | Mty_alias _ ->
        Const_block (1, Lambda.default_tag_info, [Const_pointer (0, Lambda.Pt_module_alias)])
    | Mty_signature sg ->
        Const_block(0, Lambda.default_tag_info, [Const_block(0, Lambda.default_tag_info, init_shape_struct env sg)])
    | Mty_functor _ ->
        raise Not_found (* can we do better? *)
  and init_shape_struct env sg =
    match sg with
      [] -> []
    | Sig_value(_id, {val_kind=Val_reg; val_type=ty}) :: rem ->
        let init_v =
          match Ctype.expand_head env ty with
            {desc = Tarrow(_,_,_,_)} ->
              Const_pointer (0, Lambda.default_pointer_info) (* camlinternalMod.Function *)
          | {desc = Tconstr(p, _, _)} when Path.same p Predef.path_lazy_t ->
              Const_pointer (1, Lambda.default_pointer_info) (* camlinternalMod.Lazy *)
          | _ -> raise Not_found in
        init_v :: init_shape_struct env rem
    | Sig_value(_, {val_kind=Val_prim _}) :: rem ->
        init_shape_struct env rem
    | Sig_value _ :: _rem ->
        assert false
    | Sig_type(id, tdecl, _) :: rem ->
        init_shape_struct (Env.add_type ~check:false id tdecl env) rem
    | Sig_typext _ :: _ ->
        raise Not_found
    | Sig_module(id, md, _) :: rem ->
        init_shape_mod env md.md_type ::
        init_shape_struct (Env.add_module_declaration ~check:false
                             id md env) rem
    | Sig_modtype(id, minfo) :: rem ->
        init_shape_struct (Env.add_modtype id minfo env) rem
    | Sig_class _ :: rem ->
        Const_pointer (2, Lambda.default_pointer_info) (* camlinternalMod.Class *)
        :: init_shape_struct env rem
    | Sig_class_type _ :: rem ->
        init_shape_struct env rem
  in
  try
    Some(undefined_location modl.mod_loc,
         Lconst(init_shape_mod modl.mod_env modl.mod_type))
  with Not_found ->
    None

(* Reorder bindings to honor dependencies.  *)

type binding_status = Undefined | Inprogress | Defined

let reorder_rec_bindings bindings =
  let id = Array.of_list (List.map (fun (id,_,_,_) -> id) bindings)
  and loc = Array.of_list (List.map (fun (_,loc,_,_) -> loc) bindings)
  and init = Array.of_list (List.map (fun (_,_,init,_) -> init) bindings)
  and rhs = Array.of_list (List.map (fun (_,_,_,rhs) -> rhs) bindings) in
  let fv = Array.map Lambda.free_variables rhs in
  let num_bindings = Array.length id in
  let status = Array.make num_bindings Undefined in
  let res = ref [] in
  let rec emit_binding i =
    match status.(i) with
      Defined -> ()
    | Inprogress -> raise(Error(loc.(i), Circular_dependency id.(i)))
    | Undefined ->
        if init.(i) = None then begin
          status.(i) <- Inprogress;
          for j = 0 to num_bindings - 1 do
            if IdentSet.mem id.(j) fv.(i) then emit_binding j
          done
        end;
        res := (id.(i), init.(i), rhs.(i)) :: !res;
        status.(i) <- Defined in
  for i = 0 to num_bindings - 1 do
    match status.(i) with
      Undefined -> emit_binding i
    | Inprogress -> assert false
    | Defined -> ()
  done;
  List.rev !res

(* Generate lambda-code for a reordered list of bindings *)

let eval_rec_bindings bindings cont =
  let rec bind_inits = function
    [] ->
      bind_strict bindings
  | (_id, None, _rhs) :: rem ->
      bind_inits rem
  | (id, Some(loc, shape), _rhs) :: rem ->
      Llet(Strict, Pgenval, id,
           mod_prim "init_mod" [loc; shape] Location.none,       
           bind_inits rem)
  and bind_strict = function
    [] ->
      patch_forwards bindings
  | (id, None, rhs) :: rem ->
      Llet(Strict, Pgenval, id, rhs, bind_strict rem)
  | (_id, Some _, _rhs) :: rem ->
      bind_strict rem
  and patch_forwards = function
    [] ->
      cont
  | (_id, None, _rhs) :: rem ->
      patch_forwards rem
  | (id, Some(_loc, shape), rhs) :: rem ->
      Lsequence(
            mod_prim "update_mod" [shape; Lvar id; rhs] Location.none,
            patch_forwards rem)
  in
    bind_inits bindings

let compile_recmodule compile_rhs bindings cont =
  eval_rec_bindings
    (reorder_rec_bindings
       (List.map
          (fun {mb_id=id; mb_expr=modl; mb_loc=loc; _} ->
            (id, modl.mod_loc, init_shape modl, compile_rhs id modl loc))
          bindings))
    cont

(* Extract the list of "value" identifiers bound by a signature.
   "Value" identifiers are identifiers for signature components that
   correspond to a run-time value: values, extensions, modules, classes.
   Note: manifest primitives do not correspond to a run-time value! *)

let rec bound_value_identifiers = function
    [] -> []
  | Sig_value(id, {val_kind = Val_reg}) :: rem ->
      id :: bound_value_identifiers rem
  | Sig_typext(id, _, _) :: rem -> id :: bound_value_identifiers rem
  | Sig_module(id, _, _) :: rem -> id :: bound_value_identifiers rem
  | Sig_class(id, _, _) :: rem -> id :: bound_value_identifiers rem
  | _ :: rem -> bound_value_identifiers rem


(* Code to translate class entries in a structure *)

let transl_class_bindings cl_list =
  let ids = List.map (fun (ci, _) -> ci.ci_id_class) cl_list in
  (ids,
   List.map
     (fun ({ci_id_class=id; ci_expr=cl; ci_virt=vf}, meths) ->
       (id, transl_class ids id meths cl vf))
     cl_list)

(* Compile one or more functors, merging curried functors to produce
   multi-argument functors.  Any [@inline] attribute on a functor that is
   merged must be consistent with any other [@inline] attribute(s) on the
   functor(s) being merged with.  Such an attribute will be placed on the
   resulting merged functor. *)

let merge_inline_attributes attr1 attr2 loc =
  match Lambda.merge_inline_attributes attr1 attr2 with
  | Some attr -> attr
  | None -> raise (Error (loc, Conflicting_inline_attributes))

let merge_functors mexp coercion root_path =
  let rec merge mexp coercion path acc inline_attribute =
    let finished = acc, mexp, path, coercion, inline_attribute in
    match mexp.mod_desc with
    | Tmod_functor (param, _, _, body) ->
      let inline_attribute' =
        Translattribute.get_inline_attribute mexp.mod_attributes
      in
      let arg_coercion, res_coercion =
        match coercion with
        | Tcoerce_none -> Tcoerce_none, Tcoerce_none
        | Tcoerce_functor (arg_coercion, res_coercion) ->
          arg_coercion, res_coercion
        | _ -> fatal_error "Translmod.merge_functors: bad coercion"
      in
      let loc = mexp.mod_loc in
      let path = functor_path path param in
      let inline_attribute =
        merge_inline_attributes inline_attribute inline_attribute' loc
      in
      merge body res_coercion path ((param, loc, arg_coercion) :: acc)
        inline_attribute
    | _ -> finished
  in
  merge mexp coercion root_path [] Default_inline

let export_identifiers  : Ident.t list ref = ref []
let get_export_identifiers () = 
  !export_identifiers

let rec compile_functor mexp coercion root_path loc =
  let functor_params_rev, body, body_path, res_coercion, inline_attribute =
    merge_functors mexp coercion root_path
  in
  assert (List.length functor_params_rev >= 1);  (* cf. [transl_module] *)
  let params, body =
    List.fold_left (fun (params, body) (param, loc, arg_coercion) ->
        let param' = Ident.rename param in
        let arg = apply_coercion loc Alias arg_coercion (Lvar param') in
        let params = param' :: params in
        let body = Llet (Alias, Pgenval, param, arg, body) in
        params, body)
      ([], transl_module res_coercion body_path body)
      functor_params_rev
  in
  Lfunction {
    kind = Curried;
    params;
    attr = {
      inline = inline_attribute;
      specialise = Default_specialise;
      is_a_functor = true;
      stub = false;
    };
    loc;
    body;
  }

(* Compile a module expression *)

and transl_module cc rootpath mexp =
  List.iter (Translattribute.check_attribute_on_module mexp)
    mexp.mod_attributes;
  let loc = mexp.mod_loc in
  match mexp.mod_type with
    Mty_alias (Mta_absent, _) -> apply_coercion loc Alias cc lambda_unit
  | _ ->
      match mexp.mod_desc with
        Tmod_ident (path,_) ->
          apply_coercion loc Strict cc
            (transl_module_path ~loc mexp.mod_env path)
      | Tmod_structure str ->
          fst (transl_struct loc [] cc rootpath str)
      | Tmod_functor _ ->
          oo_wrap mexp.mod_env true (fun () ->
            compile_functor mexp cc rootpath loc) ()
      | Tmod_apply(funct, arg, ccarg) ->
          let inlined_attribute, funct =
            Translattribute.get_and_remove_inlined_attribute_on_module funct
          in
          oo_wrap mexp.mod_env true
            (apply_coercion loc Strict cc)
            (Lapply{ap_should_be_tailcall=false;
                    ap_loc=loc;
                    ap_func=transl_module Tcoerce_none None funct;
                    ap_args=[transl_module ccarg None arg];
                    ap_inlined=inlined_attribute;
                    ap_specialised=Default_specialise})
      | Tmod_constraint(arg, _, _, ccarg) ->
          transl_module (compose_coercions cc ccarg) rootpath arg
      | Tmod_unpack(arg, _) ->
          apply_coercion loc Strict cc (Translcore.transl_exp arg)

and transl_struct loc fields cc rootpath str =
  transl_structure loc fields cc rootpath str.str_final_env str.str_items

and transl_structure loc fields cc rootpath final_env = function
    [] ->
      let body, size =
        match cc with
          Tcoerce_none ->
            let fields = List.rev fields in 
            let field_names = List.map (fun id -> id.Ident.name) fields in 
            Lprim(Pmakeblock(0, Lambda.Blk_module (Some field_names), Immutable, None),
                (List.fold_right (fun id acc -> begin
                      (if is_top rootpath then 
                         export_identifiers :=  id :: !export_identifiers);
                      (Lvar id :: acc) end) fields [])  , loc),
              List.length fields
        | Tcoerce_structure(pos_cc_list, id_pos_list) ->
                (* Do not ignore id_pos_list ! *)
            (*Format.eprintf "%a@.@[" Includemod.print_coercion cc;
            List.iter (fun l -> Format.eprintf "%a@ " Ident.print l)
              fields;
            Format.eprintf "@]@.";*)
            let v = Array.of_list (List.rev fields) in
            let get_field pos = Lvar v.(pos)
            and ids = List.fold_right IdentSet.add fields IdentSet.empty in
            let (result, names) = List.fold_right
              (fun  (pos, cc) (code, name) ->
                 begin match cc with
                 | Tcoerce_primitive p -> 
                     (if is_top rootpath then 
                        export_identifiers := p.pc_id:: !export_identifiers);
                     (transl_primitive p.pc_loc p.pc_desc p.pc_env p.pc_type None :: code, p.pc_desc.prim_name ::name)
                 | _ -> 
                     (if is_top rootpath then 
                        export_identifiers :=  v.(pos) :: !export_identifiers);
                     (apply_coercion loc Strict cc (get_field pos) :: code, v.(pos).Ident.name :: name)
                 end)
              pos_cc_list ([], [])in             
            let lam =
              Lprim(Pmakeblock(0, Blk_module (Some names), Immutable, None), 
                   result, loc)
            and id_pos_list =
              List.filter (fun (id,_,_) -> not (IdentSet.mem id ids))
                id_pos_list
            in
            wrap_id_pos_list loc id_pos_list get_field lam,
              List.length pos_cc_list
        | _ ->
            fatal_error "Translmod.transl_structure"
      in
      (* This debugging event provides information regarding the structure
         items. It is ignored by the OCaml debugger but is used by
         Js_of_ocaml to preserve variable names. *)
      (if !Clflags.debug && not !Clflags.bs_only then
         Levent(body,
                {lev_loc = loc;
                 lev_kind = Lev_pseudo;
                 lev_repr = None;
                 lev_env = Env.summary final_env})
       else
         body),
      size
  | item :: rem ->
      match item.str_desc with
      | Tstr_eval (expr, _) ->
          let body, size =
            transl_structure loc fields cc rootpath final_env rem
          in
          Lsequence(transl_exp expr, body), size
      | Tstr_value(rec_flag, pat_expr_list) ->
          let ext_fields = rev_let_bound_idents pat_expr_list @ fields in
          let body, size =
            transl_structure loc ext_fields cc rootpath final_env rem
          in
          transl_let rec_flag pat_expr_list body, size
      | Tstr_primitive descr ->
          record_primitive descr.val_val;
          transl_structure loc fields cc rootpath final_env rem
      | Tstr_type _ ->
          transl_structure loc fields cc rootpath final_env rem
      | Tstr_typext(tyext) ->
          let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in
          let body, size =
            transl_structure loc (List.rev_append ids fields)
              cc rootpath final_env rem
          in
          transl_type_extension item.str_env rootpath tyext body, size
      | Tstr_exception ext ->
          let id = ext.ext_id in
          let path = field_path rootpath id in
          let body, size =
            transl_structure loc (id :: fields) cc rootpath final_env rem
          in
          Llet(Strict, Pgenval, id,
               transl_extension_constructor item.str_env path ext, body),
          size
      | Tstr_module mb ->
          let id = mb.mb_id in
          let body, size =
            transl_structure loc (id :: fields) cc rootpath final_env rem
          in
          let module_body =
            transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr
          in
          let module_body =
            Translattribute.add_inline_attribute module_body mb.mb_loc
                                                 mb.mb_attributes
          in
          let module_body =
            
            if !Clflags.bs_only then module_body
            else
            
            Levent (module_body, {
              lev_loc = mb.mb_loc;
              lev_kind = Lev_module_definition id;
              lev_repr = None;
              lev_env = Env.summary Env.empty;
            })
          in
          Llet(pure_module mb.mb_expr, Pgenval, id,
               module_body,
               body), size
      | Tstr_recmodule bindings ->
          let ext_fields =
            List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields
          in
          let body, size =
            transl_structure loc ext_fields cc rootpath final_env rem
          in
          let lam =
            compile_recmodule
              (fun id modl loc ->
                 let module_body =
                   transl_module Tcoerce_none (field_path rootpath id) modl
                 in
            
                 if !Clflags.bs_only then module_body
                 else
                    
                 Levent (module_body, {
                   lev_loc = loc;
                   lev_kind = Lev_module_definition id;
                   lev_repr = None;
                   lev_env = Env.summary Env.empty;
                 }))
              bindings
              body
          in
          lam, size
      | Tstr_class cl_list ->
          let (ids, class_bindings) = transl_class_bindings cl_list in
          let body, size =
            transl_structure loc (List.rev_append ids fields)
              cc rootpath final_env rem
          in
          Lletrec(class_bindings, body), size
      | Tstr_include incl ->
          let ids = bound_value_identifiers incl.incl_type in
          let modl = incl.incl_mod in
          let mid = Ident.create "include" in
          let rec rebind_idents pos newfields = function
              [] ->
                transl_structure loc newfields cc rootpath final_env rem
            | id :: ids ->
                let body, size =
                  rebind_idents (pos + 1) (id :: newfields) ids
                in
                Llet(Alias, Pgenval, id,
                     Lprim(Pfield (pos, Fld_na), [Lvar mid], incl.incl_loc), body),
                size
          in
          let body, size = rebind_idents 0 fields ids in
          Llet(pure_module modl, Pgenval, mid,
               transl_module Tcoerce_none None modl, body),
          size

      | Tstr_modtype _
      | Tstr_open _
      | Tstr_class_type _
      | Tstr_attribute _ ->
          transl_structure loc fields cc rootpath final_env rem

and pure_module m =
  match m.mod_desc with
    Tmod_ident _ -> Alias
  | Tmod_constraint (m,_,_,_) -> pure_module m
  | _ -> Strict

(* Update forward declaration in Translcore *)
let _ =
  Translcore.transl_module := transl_module

(* Introduce dependencies on modules referenced only by "external". *)

let scan_used_globals lam =
  let globals = ref Ident.Set.empty in
  let rec scan lam =
    Lambda.iter scan lam;
    match lam with
      Lprim ((Pgetglobal id | Psetglobal id), _, _) ->
        globals := Ident.Set.add id !globals
    | _ -> ()
  in
  scan lam; !globals

let required_globals ~flambda body =
  let globals = scan_used_globals body in
  let add_global id req =
    if not flambda && Ident.Set.mem id globals then
      req
    else
      Ident.Set.add id req
  in
  let required =
    Hashtbl.fold
      (fun path _ -> add_global (Path.head path)) used_primitives
      (if flambda then globals else Ident.Set.empty)
  in
  let required =
    List.fold_right add_global (Env.get_required_globals ()) required
  in
  Env.reset_required_globals ();
  Hashtbl.clear used_primitives;
  required

(* Compile an implementation *)

let transl_implementation_flambda module_name (str, cc) =
  reset_labels ();
  primitive_declarations := [];
  Hashtbl.clear used_primitives;
  let module_id = Ident.create_persistent module_name in
  let body, size =
    Translobj.transl_label_init
      (fun () -> transl_struct Location.none [] cc
                   (global_path module_id) str)
  in
  { module_ident = module_id;
    main_module_block_size = size;
    required_globals = required_globals ~flambda:true body;
    code = body }

let transl_implementation module_name (str, cc) =
  let implementation =
    transl_implementation_flambda module_name (str, cc)
  in
  let code =
    Lprim (Psetglobal implementation.module_ident, [implementation.code],
           Location.none)
  in
  { implementation with code }

(* Build the list of value identifiers defined by a toplevel structure
   (excluding primitive declarations). *)

let rec defined_idents = function
    [] -> []
  | item :: rem ->
    match item.str_desc with
    | Tstr_eval _ -> defined_idents rem
    | Tstr_value(_rec_flag, pat_expr_list) ->
      let_bound_idents pat_expr_list @ defined_idents rem
    | Tstr_primitive _ -> defined_idents rem
    | Tstr_type _ -> defined_idents rem
    | Tstr_typext tyext ->
      List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
      @ defined_idents rem
    | Tstr_exception ext -> ext.ext_id :: defined_idents rem
    | Tstr_module mb -> mb.mb_id :: defined_idents rem
    | Tstr_recmodule decls ->
      List.map (fun mb -> mb.mb_id) decls @ defined_idents rem
    | Tstr_modtype _ -> defined_idents rem
    | Tstr_open _ -> defined_idents rem
    | Tstr_class cl_list ->
      List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ defined_idents rem
    | Tstr_class_type _ -> defined_idents rem
    | Tstr_include incl ->
      bound_value_identifiers incl.incl_type @ defined_idents rem
    | Tstr_attribute _ -> defined_idents rem

(* second level idents (module M = struct ... let id = ... end),
   and all sub-levels idents *)
let rec more_idents = function
    [] -> []
  | item :: rem ->
    match item.str_desc with
    | Tstr_eval _ -> more_idents rem
    | Tstr_value _ -> more_idents rem
    | Tstr_primitive _ -> more_idents rem
    | Tstr_type _ -> more_idents rem
    | Tstr_typext _ -> more_idents rem
    | Tstr_exception _ -> more_idents rem
    | Tstr_recmodule _ -> more_idents rem
    | Tstr_modtype _ -> more_idents rem
    | Tstr_open _ -> more_idents rem
    | Tstr_class _ -> more_idents rem
    | Tstr_class_type _ -> more_idents rem
    | Tstr_include{incl_mod={mod_desc =
                             Tmod_constraint ({mod_desc = Tmod_structure str},
                                              _, _, _)}} ->
        all_idents str.str_items @ more_idents rem
    | Tstr_include _ -> more_idents rem
    | Tstr_module {mb_expr={mod_desc = Tmod_structure str}}
    | Tstr_module{mb_expr={mod_desc =
                             Tmod_constraint ({mod_desc = Tmod_structure str},
                                              _, _, _)}} ->
        all_idents str.str_items @ more_idents rem
    | Tstr_module _ -> more_idents rem
    | Tstr_attribute _ -> more_idents rem

and all_idents = function
    [] -> []
  | item :: rem ->
    match item.str_desc with
    | Tstr_eval _ -> all_idents rem
    | Tstr_value(_rec_flag, pat_expr_list) ->
      let_bound_idents pat_expr_list @ all_idents rem
    | Tstr_primitive _ -> all_idents rem
    | Tstr_type _ -> all_idents rem
    | Tstr_typext tyext ->
      List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
      @ all_idents rem
    | Tstr_exception ext -> ext.ext_id :: all_idents rem
    | Tstr_recmodule decls ->
      List.map (fun mb -> mb.mb_id) decls @ all_idents rem
    | Tstr_modtype _ -> all_idents rem
    | Tstr_open _ -> all_idents rem
    | Tstr_class cl_list ->
      List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ all_idents rem
    | Tstr_class_type _ -> all_idents rem

    | Tstr_include{incl_type; incl_mod={mod_desc =
                             Tmod_constraint ({mod_desc = Tmod_structure str},
                                              _, _, _)}} ->
        bound_value_identifiers incl_type @ all_idents str.str_items @ all_idents rem
    | Tstr_include incl ->
      bound_value_identifiers incl.incl_type @ all_idents rem

    | Tstr_module {mb_id;mb_expr={mod_desc = Tmod_structure str}}
    | Tstr_module{mb_id;
                  mb_expr={mod_desc =
                             Tmod_constraint ({mod_desc = Tmod_structure str},
                                              _, _, _)}} ->
        mb_id :: all_idents str.str_items @ all_idents rem
    | Tstr_module mb -> mb.mb_id :: all_idents rem
    | Tstr_attribute _ -> all_idents rem


(* A variant of transl_structure used to compile toplevel structure definitions
   for the native-code compiler. Store the defined values in the fields
   of the global as soon as they are defined, in order to reduce register
   pressure.  Also rewrites the defining expressions so that they
   refer to earlier fields of the structure through the fields of
   the global, not by their names.
   "map" is a table from defined idents to (pos in global block, coercion).
   "prim" is a list of (pos in global block, primitive declaration). *)

let transl_store_subst = ref Ident.empty
  (** In the native toplevel, this reference is threaded through successive
      calls of transl_store_structure *)

let nat_toplevel_name id =
  try match Ident.find_same id !transl_store_subst with
    | Lprim(Pfield (pos,_), [Lprim(Pgetglobal glob, [], _)], _) -> (glob,pos)
    | _ -> raise Not_found
  with Not_found ->
    fatal_error("Translmod.nat_toplevel_name: " ^ Ident.unique_name id)

let field_of_str loc str =
  let ids = Array.of_list (defined_idents str.str_items) in
  fun (pos, cc) ->
    match cc with
    | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } ->
        transl_primitive pc_loc pc_desc pc_env pc_type None
    | _ -> apply_coercion loc Strict cc (Lvar ids.(pos))


let transl_store_structure glob map prims str =
  let rec transl_store rootpath subst = function
    [] ->
      transl_store_subst := subst;
        lambda_unit
    | item :: rem ->
        match item.str_desc with
        | Tstr_eval (expr, _attrs) ->
            Lsequence(subst_lambda subst (transl_exp expr),
                      transl_store rootpath subst rem)
        | Tstr_value(rec_flag, pat_expr_list) ->
            let ids = let_bound_idents pat_expr_list in
            let lam =
              transl_let rec_flag pat_expr_list (store_idents Location.none ids)
            in
            Lsequence(subst_lambda subst lam,
                      transl_store rootpath (add_idents false ids subst) rem)
        | Tstr_primitive descr ->
            record_primitive descr.val_val;
            transl_store rootpath subst rem
        | Tstr_type _ ->
            transl_store rootpath subst rem
        | Tstr_typext(tyext) ->
            let ids =
              List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
            in
            let lam =
              transl_type_extension item.str_env rootpath tyext
                                    (store_idents Location.none ids)
            in
            Lsequence(subst_lambda subst lam,
                      transl_store rootpath (add_idents false ids subst) rem)
        | Tstr_exception ext ->
            let id = ext.ext_id in
            let path = field_path rootpath id in
            let lam = transl_extension_constructor item.str_env path ext in
            Lsequence(Llet(Strict, Pgenval, id, subst_lambda subst lam,
                           store_ident ext.ext_loc id),
                      transl_store rootpath (add_ident false id subst) rem)
        | Tstr_module{mb_id=id;mb_loc=loc;
                      mb_expr={mod_desc = Tmod_structure str} as mexp;
                      mb_attributes} ->
            List.iter (Translattribute.check_attribute_on_module mexp)
              mb_attributes;
            let lam =
              transl_store (field_path rootpath id) subst str.str_items
            in
            (* Careful: see next case *)
            let subst = !transl_store_subst in
            Lsequence(lam,
                      Llet(Strict, Pgenval, id,
                           subst_lambda subst
                             (Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None),
                                    List.map (fun id -> Lvar id)
                                      (defined_idents str.str_items), loc)),
                           Lsequence(store_ident loc id,
                                     transl_store rootpath
                                                  (add_ident true id subst)
                                                  rem)))
        | Tstr_module{
            mb_id=id;mb_loc=loc;
            mb_expr= {
              mod_desc = Tmod_constraint (
                  {mod_desc = Tmod_structure str} as mexp, _, _,
                  (Tcoerce_structure (map, _) as _cc))};
            mb_attributes
          } ->
            (*    Format.printf "coerc id %s: %a@." (Ident.unique_name id)
                                Includemod.print_coercion cc; *)
            List.iter (Translattribute.check_attribute_on_module mexp)
              mb_attributes;
            let lam =
              transl_store (field_path rootpath id) subst str.str_items
            in
            (* Careful: see next case *)
            let subst = !transl_store_subst in
            let field = field_of_str loc str in
            Lsequence(lam,
                      Llet(Strict, Pgenval, id,
                           subst_lambda subst
                             (Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None),
                                    List.map field map, loc)),
                           Lsequence(store_ident loc id,
                                     transl_store rootpath
                                                  (add_ident true id subst)
                                                  rem)))
        | Tstr_module{mb_id=id; mb_expr=modl; mb_loc=loc; mb_attributes} ->
            let lam =
              Translattribute.add_inline_attribute
                (transl_module Tcoerce_none (field_path rootpath id) modl)
                loc mb_attributes
            in
            (* Careful: the module value stored in the global may be different
               from the local module value, in case a coercion is applied.
               If so, keep using the local module value (id) in the remainder of
               the compilation unit (add_ident true returns subst unchanged).
               If not, we can use the value from the global
               (add_ident true adds id -> Pgetglobal... to subst). *)
            Llet(Strict, Pgenval, id, subst_lambda subst lam,
                 Lsequence(store_ident loc id,
                           transl_store rootpath (add_ident true id subst) rem))
        | Tstr_recmodule bindings ->
            let ids = List.map (fun mb -> mb.mb_id) bindings in
            compile_recmodule
              (fun id modl _loc ->
                 subst_lambda subst
                   (transl_module Tcoerce_none
                      (field_path rootpath id) modl))
              bindings
              (Lsequence(store_idents Location.none ids,
                         transl_store rootpath (add_idents true ids subst) rem))
        | Tstr_class cl_list ->
            let (ids, class_bindings) = transl_class_bindings cl_list in
            let lam =
              Lletrec(class_bindings, store_idents Location.none ids)
            in
            Lsequence(subst_lambda subst lam,
                      transl_store rootpath (add_idents false ids subst) rem)

        | Tstr_include{
            incl_loc=loc;
            incl_mod= {
              mod_desc = Tmod_constraint (
                  ({mod_desc = Tmod_structure str} as mexp), _, _,
                  (Tcoerce_structure (map, _)))};
            incl_attributes;
            incl_type;
          } ->
            List.iter (Translattribute.check_attribute_on_module mexp)
              incl_attributes;
            (* Shouldn't we use mod_attributes instead of incl_attributes?
               Same question for the Tstr_module cases above, btw. *)
            let lam =
              transl_store None subst str.str_items
                (* It is tempting to pass rootpath instead of None
                   in order to give a more precise name to exceptions
                   in the included structured, but this would introduce
                   a difference of behavior compared to bytecode. *)
            in
            let subst = !transl_store_subst in
            let field = field_of_str loc str in
            let ids0 = bound_value_identifiers incl_type in
            let rec loop ids args =
              match ids, args with
              | [], [] ->
                  transl_store rootpath (add_idents true ids0 subst) rem
              | id :: ids, arg :: args ->
                  Llet(Alias, Pgenval, id, subst_lambda subst (field arg),
                       Lsequence(store_ident loc id,
                                 loop ids args))
              | _ -> assert false
            in
            Lsequence(lam, loop ids0 map)


        | Tstr_include incl ->
            let ids = bound_value_identifiers incl.incl_type in
            let modl = incl.incl_mod in
            let mid = Ident.create "include" in
            let loc = incl.incl_loc in
            let rec store_idents pos = function
                [] -> transl_store rootpath (add_idents true ids subst) rem
              | id :: idl ->
                  Llet(Alias, Pgenval, id, Lprim(Pfield (pos, Fld_na), [Lvar mid], loc),
                       Lsequence(store_ident loc id,
                                 store_idents (pos + 1) idl))
            in
            Llet(Strict, Pgenval, mid,
                 subst_lambda subst (transl_module Tcoerce_none None modl),
                 store_idents 0 ids)
        | Tstr_modtype _
        | Tstr_open _
        | Tstr_class_type _
        | Tstr_attribute _ ->
            transl_store rootpath subst rem

  and store_ident loc id =
    try
      let (pos, cc) = Ident.find_same id map in
      let init_val = apply_coercion loc Alias cc (Lvar id) in
      Lprim(Psetfield(pos, Pointer, Root_initialization, Fld_set_na),
            [Lprim(Pgetglobal glob, [], loc); init_val],
            loc)
    with Not_found ->
      fatal_error("Translmod.store_ident: " ^ Ident.unique_name id)

  and store_idents loc idlist =
    make_sequence (store_ident loc) idlist

  and add_ident may_coerce id subst =
    try
      let (pos, cc) = Ident.find_same id map in
      match cc with
        Tcoerce_none ->
          Ident.add id
            (Lprim(Pfield (pos, Fld_na),
                   [Lprim(Pgetglobal glob, [], Location.none)],
                   Location.none))
            subst
      | _ ->
          if may_coerce then subst else assert false
    with Not_found ->
      assert false

  and add_idents may_coerce idlist subst =
    List.fold_right (add_ident may_coerce) idlist subst

  and store_primitive (pos, prim) cont =
    Lsequence(Lprim(Psetfield(pos, Pointer, Root_initialization, Fld_set_na),
                    [Lprim(Pgetglobal glob, [], Location.none);
                     transl_primitive Location.none
                       prim.pc_desc prim.pc_env prim.pc_type None],
                    Location.none),
              cont)

  in List.fold_right store_primitive prims
                     (transl_store (global_path glob) !transl_store_subst str)

(* Transform a coercion and the list of value identifiers defined by
   a toplevel structure into a table [id -> (pos, coercion)],
   with [pos] being the position in the global block where the value of
   [id] must be stored, and [coercion] the coercion to be applied to it.
   A given identifier may appear several times
   in the coercion (if it occurs several times in the signature); remember
   to assign it the position of its last occurrence.
   Identifiers that are not exported are assigned positions at the
   end of the block (beyond the positions of all exported idents).
   Also compute the total size of the global block,
   and the list of all primitives exported as values. *)

let build_ident_map restr idlist more_ids =
  let rec natural_map pos map prims = function
      [] ->
        (map, prims, pos)
    | id :: rem ->
        natural_map (pos+1) (Ident.add id (pos, Tcoerce_none) map) prims rem in
  let (map, prims, pos) =
    match restr with
        Tcoerce_none ->
          natural_map 0 Ident.empty [] idlist
      | Tcoerce_structure (pos_cc_list, _id_pos_list) ->
              (* ignore _id_pos_list as the ids are already bound *)
        let idarray = Array.of_list idlist in
        let rec export_map pos map prims undef = function
        [] ->
          natural_map pos map prims undef
          | (_source_pos, Tcoerce_primitive p) :: rem ->
            export_map (pos + 1) map ((pos, p) :: prims) undef rem
          | (source_pos, cc) :: rem ->
            let id = idarray.(source_pos) in
            export_map (pos + 1) (Ident.add id (pos, cc) map)
              prims (list_remove id undef) rem
        in export_map 0 Ident.empty [] idlist pos_cc_list
      | _ ->
        fatal_error "Translmod.build_ident_map"
  in
  natural_map pos map prims more_ids

(* Compile an implementation using transl_store_structure
   (for the native-code compiler). *)

let transl_store_gen module_name ({ str_items = str }, restr) topl =
  reset_labels ();
  primitive_declarations := [];
  Hashtbl.clear used_primitives;
  let module_id = Ident.create_persistent module_name in
  let (map, prims, size) =
    build_ident_map restr (defined_idents str) (more_idents str) in
  let f = function
    | [ { str_desc = Tstr_eval (expr, _attrs) } ] when topl ->
        assert (size = 0);
        subst_lambda !transl_store_subst (transl_exp expr)
    | str -> transl_store_structure module_id map prims str in
  transl_store_label_init module_id size f str
  (*size, transl_label_init (transl_store_structure module_id map prims str)*)

let transl_store_phrases module_name str =
  transl_store_gen module_name (str,Tcoerce_none) true

let transl_store_implementation module_name (str, restr) =
  let s = !transl_store_subst in
  transl_store_subst := Ident.empty;
  let (i, code) = transl_store_gen module_name (str, restr) false in
  transl_store_subst := s;
  { Lambda.main_module_block_size = i;
    code;
    (* module_ident is not used by closure, but this allow to share
       the type with the flambda version *)
    module_ident = Ident.create_persistent module_name;
    required_globals = required_globals ~flambda:true code }

(* Compile a toplevel phrase *)

let toploop_ident = Ident.create_persistent "Toploop"
let toploop_getvalue_pos = 0 (* position of getvalue in module Toploop *)
let toploop_setvalue_pos = 1 (* position of setvalue in module Toploop *)

let aliased_idents = ref Ident.empty

let set_toplevel_unique_name id =
  aliased_idents :=
    Ident.add id (Ident.unique_toplevel_name id) !aliased_idents

let toplevel_name id =
  try Ident.find_same id !aliased_idents
  with Not_found -> Ident.name id

let toploop_getvalue id =
  Lapply{ap_should_be_tailcall=false;
         ap_loc=Location.none;
         ap_func=Lprim(Pfield (toploop_getvalue_pos, Fld_na),
                       [Lprim(Pgetglobal toploop_ident, [], Location.none)],
                       Location.none);
         ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None)))];
         ap_inlined=Default_inline;
         ap_specialised=Default_specialise}

let toploop_setvalue id lam =
  Lapply{ap_should_be_tailcall=false;
         ap_loc=Location.none;
         ap_func=Lprim(Pfield (toploop_setvalue_pos, Fld_na),
                       [Lprim(Pgetglobal toploop_ident, [], Location.none)],
                       Location.none);
         ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None)));
                  lam];
         ap_inlined=Default_inline;
         ap_specialised=Default_specialise}

let toploop_setvalue_id id = toploop_setvalue id (Lvar id)

let close_toplevel_term (lam, ()) =
  IdentSet.fold (fun id l -> Llet(Strict, Pgenval, id,
                                  toploop_getvalue id, l))
                (free_variables lam) lam

let transl_toplevel_item item =
  match item.str_desc with
    Tstr_eval (expr, _)
  | Tstr_value(Nonrecursive,
               [{vb_pat = {pat_desc=Tpat_any};vb_expr = expr}]) ->
      (* special compilation for toplevel "let _ = expr", so
         that Toploop can display the result of the expression.
         Otherwise, the normal compilation would result
         in a Lsequence returning unit. *)
      transl_exp expr
  | Tstr_value(rec_flag, pat_expr_list) ->
      let idents = let_bound_idents pat_expr_list in
      transl_let rec_flag pat_expr_list
        (make_sequence toploop_setvalue_id idents)
  | Tstr_typext(tyext) ->
      let idents =
        List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
      in
      (* we need to use unique name in case of multiple
         definitions of the same extension constructor in the toplevel *)
      List.iter set_toplevel_unique_name idents;
        transl_type_extension item.str_env None tyext
          (make_sequence toploop_setvalue_id idents)
  | Tstr_exception ext ->
      set_toplevel_unique_name ext.ext_id;
      toploop_setvalue ext.ext_id
        (transl_extension_constructor item.str_env None ext)
  | Tstr_module {mb_id=id; mb_expr=modl} ->
      (* we need to use the unique name for the module because of issues
         with "open" (PR#1672) *)
      set_toplevel_unique_name id;
      let lam = transl_module Tcoerce_none (Some(Pident id)) modl in
      toploop_setvalue id lam
  | Tstr_recmodule bindings ->
      let idents = List.map (fun mb -> mb.mb_id) bindings in
      compile_recmodule
        (fun id modl _loc -> transl_module Tcoerce_none (Some(Pident id)) modl)
        bindings
        (make_sequence toploop_setvalue_id idents)
  | Tstr_class cl_list ->
      (* we need to use unique names for the classes because there might
         be a value named identically *)
      let (ids, class_bindings) = transl_class_bindings cl_list in
      List.iter set_toplevel_unique_name ids;
      Lletrec(class_bindings, make_sequence toploop_setvalue_id ids)
  | Tstr_include incl ->
      let ids = bound_value_identifiers incl.incl_type in
      let modl = incl.incl_mod in
      let mid = Ident.create "include" in
      let rec set_idents pos = function
        [] ->
          lambda_unit
      | id :: ids ->
          Lsequence(toploop_setvalue id
                      (Lprim(Pfield (pos, Fld_na), [Lvar mid], Location.none)),
                    set_idents (pos + 1) ids) in
      Llet(Strict, Pgenval, mid,
           transl_module Tcoerce_none None modl, set_idents 0 ids)
  | Tstr_modtype _
  | Tstr_open _
  | Tstr_primitive _
  | Tstr_type _
  | Tstr_class_type _
  | Tstr_attribute _ ->
      lambda_unit

let transl_toplevel_item_and_close itm =
  close_toplevel_term
    (transl_label_init (fun () -> transl_toplevel_item itm, ()))

let transl_toplevel_definition str =
  reset_labels ();
  Hashtbl.clear used_primitives;
  make_sequence transl_toplevel_item_and_close str.str_items

(* Compile the initialization code for a packed library *)

let get_component = function
    None -> Lconst const_unit
  | Some id -> Lprim(Pgetglobal id, [], Location.none)

let transl_package_flambda component_names coercion =
  let size =
    match coercion with
    | Tcoerce_none -> List.length component_names
    | Tcoerce_structure (l, _) -> List.length l
    | Tcoerce_functor _
    | Tcoerce_primitive _
    | Tcoerce_alias _ -> assert false
  in
  size,
  apply_coercion Location.none Strict coercion
    (Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None), (*NOTE: not relevant in flambda *)
           List.map get_component component_names,
           Location.none))

let transl_package component_names target_name coercion =
  let components =
    Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None),
          List.map get_component component_names, Location.none) in
  Lprim(Psetglobal target_name,
        [apply_coercion Location.none Strict coercion components],
        Location.none)
  (*
  let components =
    match coercion with
      Tcoerce_none ->
        List.map get_component component_names
    | Tcoerce_structure (pos_cc_list, id_pos_list) ->
              (* ignore id_pos_list as the ids are already bound *)
        let g = Array.of_list component_names in
        List.map
          (fun (pos, cc) -> apply_coercion Strict cc (get_component g.(pos)))
          pos_cc_list
    | _ ->
        assert false in
  Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)])
   *)

let transl_store_package component_names target_name coercion =
  let rec make_sequence fn pos arg =
    match arg with
      [] -> lambda_unit
    | hd :: tl -> Lsequence(fn pos hd, make_sequence fn (pos + 1) tl) in
  match coercion with
    Tcoerce_none ->
      (List.length component_names,
       make_sequence
         (fun pos id ->
           Lprim(Psetfield(pos, Pointer, Root_initialization, Fld_set_na),
                 [Lprim(Pgetglobal target_name, [], Location.none);
                  get_component id],
                 Location.none))
         0 component_names)
  | Tcoerce_structure (pos_cc_list, _id_pos_list) ->
      let components =
        Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None),
              List.map get_component component_names,
              Location.none)
      in
      let blk = Ident.create "block" in
      (List.length pos_cc_list,
       Llet (Strict, Pgenval, blk,
             apply_coercion Location.none Strict coercion components,
             make_sequence
               (fun pos _id ->
                 Lprim(Psetfield(pos, Pointer, Root_initialization, Fld_set_na),
                       [Lprim(Pgetglobal target_name, [], Location.none);
                        Lprim(Pfield (pos, Fld_na), [Lvar blk], Location.none)],
                       Location.none))
               0 pos_cc_list))
  (*
              (* ignore id_pos_list as the ids are already bound *)
      let id = Array.of_list component_names in
      (List.length pos_cc_list,
       make_sequence
         (fun dst (src, cc) ->
           Lprim(Psetfield(dst, false),
                 [Lprim(Pgetglobal target_name, []);
                  apply_coercion Strict cc (get_component id.(src))]))
         0 pos_cc_list)
  *)
  | _ -> assert false

(* Error report *)

open Format

let report_error ppf = function
    Circular_dependency id ->
      fprintf ppf
        "@[Cannot safely evaluate the definition@ \
         of the recursively-defined module %a@]"
        Printtyp.ident id
  | Conflicting_inline_attributes ->
      fprintf ppf
        "@[Conflicting ``inline'' attributes@]"

let () =
  Location.register_error_of_exn
    (function
      | Error (loc, err) ->
        Some (Location.error_of_printer loc report_error err)
      | _ ->
        None
    )

let reset () =
  export_identifiers := [];
  primitive_declarations := [];
  transl_store_subst := Ident.empty;
  toploop_ident.Ident.flags <- 0;
  aliased_idents := Ident.empty;
  Env.reset_required_globals ();
  Hashtbl.clear used_primitives

end
module Lam_compile_env : sig 
#1 "lam_compile_env.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Helper for global Ocaml module index into meaningful names  *) 



type path = string 



type module_info = {
  signature :  Ocaml_types.t ;
  pure : bool 
}

type _ t = 
  | No_env :  (path * Js_cmj_format.t) t 
  | Has_env : Env.t  -> module_info t 


type ident_info = {
  name : string;
  signature : Ocaml_types.t;
  arity : Js_cmj_format.arity;
  closed_lambda : Lam.t option 
}  




val reset : unit -> unit 

(** 
  [add_js_module hint_name module_name]
  Given a js module name and hint name, assign an id to it
  we also bookkeep it as [External] dependency.

  Note the complexity lies in that we should consolidate all 
  same external dependencies into a single dependency.
  
  The strategy is that we first create a [Lam_module_ident.t] 
  and  query it if already exists in [cache_tbl], if it already
  exists, we discard the freshly made one, and use the cached one,
  otherwise, use the freshly made one instead

  Invariant: 
    any [id] as long as put in the [cached_tbl] should be always valid,
*)  
val add_js_module : 
    External_ffi_types.module_bind_name -> string  -> Ident.t 


(* The other dependencies are captured by querying 
   either when [access] or when expansion, 
   however such dependency can be removed after inlining etc.

   When we register such compile time dependency we classified 
   it as 
   Visit (ml), Builtin(built in js), External()

   For external, we never remove, we only consider 
   remove dependency for Runtime and Visit, so 
   when compile OCaml to Javascript, we only need 
   pay attention to for those modules are actually used or not
*)
(**
  [cached_find_ml_id_pos id pos env found]
  will raise if not found
*)
val cached_find_ml_id_pos : 
  Ident.t ->
  int -> 
  Env.t -> 
  ident_info

val query_and_add_if_not_exist : 
  Lam_module_ident.t ->
  'a t -> not_found:(unit -> 'b) ->
  found:('a -> 'b) -> 'b

val is_pure_module : Lam_module_ident.t -> bool


val get_package_path_from_cmj : 
  Lam_module_ident.t -> 
  (string * Js_packages_info.t * Js_cmj_format.cmj_case) option



(* The second argument is mostly from [runtime] modules 
    will change the input [hard_dependencies]
    [get_required_modules extra hard_dependencies]
    [extra] maybe removed if it is pure and not in [hard_dependencies]
*)
val get_required_modules : 
  Lam_module_ident.Hash_set.t  ->
  Lam_module_ident.Hash_set.t -> 
  Lam_module_ident.t list

end = struct
#1 "lam_compile_env.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








module E = Js_exp_make  
module S = Js_stmt_make

type path = string 

type ml_module_info = { 
  signature : Ocaml_types.t;
  cmj_table : Js_cmj_format.t ;
  cmj_path : path;
}

type env_value = 
  | Visit of ml_module_info
  | Runtime  of bool * path * Js_cmj_format.t
  (** 
     [Runtime (pure, path, cmj_format)]
     A built in module probably from our runtime primitives, 
      so it does not have any [signature]

  *)
  | External  
  (** Also a js file, but this belong to third party 
  *)




type ident_info = {
  (* id : Ident.t; *)
  name : string;
  signature : Ocaml_types.t;
  arity : Js_cmj_format.arity; 
  closed_lambda : Lam.t option 
}

(*
   refer: [Env.find_pers_struct]
   [ find_in_path_uncap !load_path (name ^ ".cmi")]
*)



let cached_tbl  = Lam_module_ident.Hash.create 31

(* For each compilation we need reset to make it re-entrant *)
let reset () = 
  Translmod.reset ();
  Lam_module_ident.Hash.clear cached_tbl 





(** We should not provide "#moduleid" as output
    since when we print it in the end, it will 
    be escaped quite ugly
*)
let add_js_module 
    (hint_name : External_ffi_types.module_bind_name)
    module_name : Ident.t 
  = 
  let id = 
    Ident.create @@ 
      (match hint_name with 
       | Phint_name hint_name -> 
        Ext_string.capitalize_ascii hint_name 
        (* make sure the module name is capitalized
           TODO: maybe a warning if the user hint is not good
        *)
       | Phint_nothing -> 
         Ext_modulename.js_id_name_of_hint_name module_name
      )
  in
  let lam_module_ident = 
    Lam_module_ident.of_external id module_name in  
  match Lam_module_ident.Hash.find_key_opt cached_tbl lam_module_ident with   
  | None ->
    Lam_module_ident.Hash.add 
      cached_tbl 
      lam_module_ident
      External;
    id
  | Some old_key ->
    old_key.id 




let (+>) = Lam_module_ident.Hash.add cached_tbl

let cached_find_ml_id_pos (module_id : Ident.t) (pos : int) env : ident_info =
  let oid  = Lam_module_ident.of_ml module_id in
  match Lam_module_ident.Hash.find_opt cached_tbl oid with 
  | None -> 
    let cmj_path, cmj_table = 
      Js_cmj_load.find_cmj (module_id.name ^ Literals.suffix_cmj) in
    begin match
        Ocaml_types.find_serializable_signatures_by_path module_id env with 
    | None -> 
      assert false (*TODO: more informative error message *)
    | Some signature -> 
      oid  +> Visit {signature;  cmj_table ; cmj_path  }  ;
      let name =  Ocaml_types.get_name signature pos  in
      let arity, closed_lambda =        
        Js_cmj_format.query_by_name cmj_table name         
      in
      {
       (* id;  *)
       name ;
       signature ;
       arity ;
       closed_lambda
      }
    end
  | Some (Visit {signature ; cmj_table } )
    -> 
    let name = Ocaml_types.get_name signature pos  in
    let arity , closed_lambda =  
      Js_cmj_format.query_by_name cmj_table name 
    in
    { 
      (* id; *)
      name; 
      signature;
      arity;
      closed_lambda
      (* TODO shall we cache the arity ?*) 
    } 
  | Some (Runtime _) -> assert false
  | Some External  -> assert false



type module_info = {
  signature :  Ocaml_types.t ;
  pure : bool 
}
(* TODO: it does not make sense to cache
   [Runtime] 
   and [externals]*)
type _ t = 
  | No_env :  (path * Js_cmj_format.t) t 
  | Has_env : Env.t  -> module_info t 


(* -FIXME: 
  Here [not_found] only means cmi not found, not cmj not found *)
let query_and_add_if_not_exist 
    (type u)
    (oid : Lam_module_ident.t) 
    (env : u t) ~not_found ~(found: u -> _) =
  match Lam_module_ident.Hash.find_opt cached_tbl oid with 
  | None -> 
    begin match oid.kind with
      | Runtime  -> 
        let (cmj_path, cmj_table) as cmj_info = 
          Js_cmj_load.find_cmj (Lam_module_ident.name oid ^ Literals.suffix_cmj) in           
        oid +> Runtime (true,cmj_path,cmj_table) ; 
         (match env with 
          | Has_env _ -> 
            found {signature = Ocaml_types.empty; pure = true}
          | No_env -> 
            found cmj_info)        
      | Ml 
        -> 
        let (cmj_path, cmj_table) as cmj_info = 
          Js_cmj_load.find_cmj (Lam_module_ident.name oid ^ Literals.suffix_cmj) in           
        ( match env with 
          | Has_env env -> 
            begin match 
                Ocaml_types.find_serializable_signatures_by_path  oid.id env with 
            | None -> not_found () (* actually when [not_found] in the call site, we throw... *)
            | Some signature -> 
              oid +> Visit {signature; cmj_table;cmj_path } ;
              found  { signature ; pure = Js_cmj_format.is_pure cmj_table} 
            end
          | No_env -> 
            found cmj_info)
        

      | External _  -> 
        oid +> External;
        (** This might be wrong, if we happen to expand  an js module
            we should assert false (but this in general should not happen)
        *)
        begin match env with 
          | Has_env _ 
            -> 
            found {signature = Ocaml_types.empty; pure = false}
          | No_env -> 
            found (Ext_string.empty, Js_cmj_format.no_pure_dummy)
            (* FIXME: #154, it come from External, should be okay *)
        end

    end
  | Some (Visit {signature  ; cmj_table; cmj_path}) -> 
    begin match env with 
      | Has_env _ -> 
        found   { signature; pure = Js_cmj_format.is_pure cmj_table} 
      | No_env  -> found (cmj_path,cmj_table)
    end

  | Some (Runtime (pure, cmj_path,cmj_table)) -> 
    begin match env with 
      | Has_env _ -> 
        found {signature = Ocaml_types.empty; pure }
      | No_env -> 
        found (cmj_path, cmj_table) 
    end
  | Some External -> 
    begin match env with 
      | Has_env _ -> 
        found {signature = Ocaml_types.empty; pure  = false}
      | No_env -> 
        found (Ext_string.empty, Js_cmj_format.no_pure_dummy) (* External is okay *)
    end




let get_package_path_from_cmj 
    ( id : Lam_module_ident.t) 
  : _ option = 
  query_and_add_if_not_exist id No_env
    ~not_found:(fun _ ->
        None
        (*
          So after querying, it should return 
           [Js_packages_info.Package_not_found]
        *)
      ) 
    ~found:(fun (cmj_path,x) -> 
        Some (cmj_path, 
              Js_cmj_format.get_npm_package_path x, 
              Js_cmj_format.get_cmj_case x )
      )


let add = Lam_module_ident.Hash_set.add




(* Conservative interface *)
let is_pure_module (id : Lam_module_ident.t)  = 
  id.kind = Runtime ||
  query_and_add_if_not_exist id No_env
    ~not_found:(fun _ -> false) 
    ~found:(fun (_,x) -> 
      Js_cmj_format.is_pure x)

let get_required_modules 
    extras 
    (hard_dependencies 
     : Lam_module_ident.Hash_set.t) : Lam_module_ident.t list =  
  Lam_module_ident.Hash.iter cached_tbl (fun id  _  ->
      if not @@ is_pure_module id 
      then add  hard_dependencies id);
  Lam_module_ident.Hash_set.iter extras (fun id  -> 
      (if not @@ is_pure_module  id 
       then add hard_dependencies id : unit)
    );
  Lam_module_ident.Hash_set.elements hard_dependencies

end
module Ext_pp : sig 
#1 "ext_pp.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** A simple pretty printer
    
    Advantage compared with [Format], 
    [P.newline] does not screw the layout, have better control when do a newline (sicne JS has ASI)
    Easy to tweak

    {ul 
    {- be a little smarter}
    {- buffer the last line, so that  we can do a smart newline, when it's really safe to do so}
    }
*)
type t

val indent_length : int 

val string : t -> string -> unit

val space :  t -> unit

val nspace : t -> int ->  unit

val group : t -> int -> (unit -> 'a) -> 'a
(** [group] will record current indentation 
    and indent futher
 *)

val vgroup : t -> int -> (unit -> 'a) -> 'a

val paren : t -> (unit -> 'a) -> 'a

val brace : t -> (unit -> 'a) -> 'a

val paren_group : t -> int -> (unit -> 'a) -> 'a

val cond_paren_group :
    t -> 
    bool -> 
    int -> 
    (unit -> 'a) -> 
    'a 

val paren_vgroup : t -> int -> (unit -> 'a) -> 'a

val brace_group : t -> int -> (unit -> 'a) -> 'a

val brace_vgroup : t -> int -> (unit -> 'a) -> 'a

val bracket_group : t -> int -> (unit -> 'a) -> 'a

val bracket_vgroup : t -> int -> (unit -> 'a) -> 'a

val newline : t -> unit

val force_newline : t -> unit
(** [force_newline] Always print a newline *)

val from_channel : out_channel -> t

val from_buffer : Buffer.t -> t

val flush : t -> unit -> unit

end = struct
#1 "ext_pp.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








module L = struct
  let space = " "
  let indent_str = "  "
end

let indent_length = String.length L.indent_str

type t = {
  output_string : string -> unit;
  output_char : char -> unit;
  flush : unit -> unit;
  mutable indent_level : int;
  mutable last_new_line : bool;
  (* only when we print newline, we print the indent *)
}

let from_channel chan = {
  output_string = (fun  s -> output_string chan s);
  output_char = (fun c -> output_char chan c);
  flush = (fun _ -> flush chan);
  indent_level = 0 ;
  last_new_line = false;
}


let from_buffer buf = {
  output_string = (fun s -> Buffer.add_string buf s);
  output_char = (fun  c -> Buffer.add_char buf c);
  flush = (fun _ -> ());
  indent_level = 0;
  last_new_line = false;
}

(* If we have [newline] in [s],
   all indentations will be broken
   in the future, we can detect this in [s]
*)
let string t s =
  t.output_string  s ;
  t.last_new_line <- false

let newline t =
  if not t.last_new_line then
    begin
      t.output_char  '\n';
      for i = 0 to t.indent_level - 1 do
        t.output_string  L.indent_str;
      done;
      t.last_new_line <- true
    end

let force_newline t =
  t.output_char  '\n';
  for i = 0 to t.indent_level - 1 do
    t.output_string  L.indent_str;
  done

let space t  =
  string t L.space

let nspace  t n  =
  string  t (String.make n ' ')

let group t i action =
  if i = 0 then action ()
  else
    let old = t.indent_level in
    t.indent_level <- t.indent_level + i;
    Ext_pervasives.finally ~clean:(fun _ -> t.indent_level <- old)
    ()  action

let vgroup = group

let paren t action =
  string t "(";
  let v = action () in
  string t ")";
  v

let brace fmt u =
  string fmt "{";
  (* break1 fmt ; *)
  let v = u () in
  string fmt "}";
  v

let bracket fmt u =
  string fmt "[";
  let v = u () in
  string fmt "]";
  v

let brace_vgroup st n action =
  string st "{";
  let v = vgroup st n (fun _ ->
      newline st;
      let v =  action () in
      v
    ) in
  force_newline st;
  string st "}";
  v

let bracket_vgroup st n action =
  string st "[";
  let v = vgroup st n (fun _ ->
      newline st;
      let v =  action () in
      v
    ) in
  force_newline st;
  string st "]";
  v

let bracket_group st n action =
  group st n (fun _ -> bracket st action)

let paren_vgroup st n action =
  string st "(";
  let v = group st n (fun _ ->
      newline st;
      let v = action () in
      v
    ) in
  newline st;
  string st ")";
  v

let paren_group st n action = 
    group st n (fun _ -> paren st action)

let cond_paren_group st b n action =    
  if b then 
    paren_group st n action 
  else 
    action ()


let brace_group st n action =
  group st n (fun _ -> brace st action )

let indent t n =
  t.indent_level <- t.indent_level + n

let flush t () = t.flush ()

end
module Ext_int : sig 
#1 "ext_int.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


type t = int
val compare : t -> t -> int 
val equal : t -> t -> bool 

end = struct
#1 "ext_int.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


type t = int

let compare (x : t) (y : t) = Pervasives.compare x y 

let equal (x : t) (y : t) = x = y

end
module Int_map : sig 
#1 "int_map.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








include Map_gen.S with type key = int

end = struct
#1 "int_map.ml"

# 2 "ext/map.cppo.ml"
(* we don't create [map_poly], since some operations require raise an exception which carries [key] *)


  
# 13 "ext/map.cppo.ml"
  type key = int
  let compare_key = Ext_int.compare

# 22 "ext/map.cppo.ml"
type 'a t = (key,'a) Map_gen.t
exception Duplicate_key of key 

let empty = Map_gen.empty 
let is_empty = Map_gen.is_empty
let iter = Map_gen.iter
let fold = Map_gen.fold
let for_all = Map_gen.for_all 
let exists = Map_gen.exists 
let singleton = Map_gen.singleton 
let cardinal = Map_gen.cardinal
let bindings = Map_gen.bindings
let to_sorted_array = Map_gen.to_sorted_array
let keys = Map_gen.keys
let choose = Map_gen.choose 
let partition = Map_gen.partition 
let filter = Map_gen.filter 
let map = Map_gen.map 
let mapi = Map_gen.mapi
let bal = Map_gen.bal 
let height = Map_gen.height 
let max_binding_exn = Map_gen.max_binding_exn
let min_binding_exn = Map_gen.min_binding_exn


let rec add (tree : _ Map_gen.t as 'a) x data  : 'a = match tree with 
  | Empty ->
    Node(Empty, x, data, Empty, 1)
  | Node(l, v, d, r, h) ->
    let c = compare_key x v in
    if c = 0 then
      Node(l, x, data, r, h)
    else if c < 0 then
      bal (add l x data ) v d r
    else
      bal l v d (add r x data )


let rec adjust (tree : _ Map_gen.t as 'a) x replace  : 'a = 
  match tree with 
  | Empty ->
    Node(Empty, x, replace None, Empty, 1)
  | Node(l, v, d, r, h) ->
    let c = compare_key x v in
    if c = 0 then
      Node(l, x, replace  (Some d) , r, h)
    else if c < 0 then
      bal (adjust l x  replace ) v d r
    else
      bal l v d (adjust r x  replace )


let rec find_exn (tree : _ Map_gen.t ) x = match tree with 
  | Empty ->
    raise Not_found
  | Node(l, v, d, r, _) ->
    let c = compare_key x v in
    if c = 0 then d
    else find_exn (if c < 0 then l else r) x

let rec find_opt (tree : _ Map_gen.t ) x = match tree with 
  | Empty -> None 
  | Node(l, v, d, r, _) ->
    let c = compare_key x v in
    if c = 0 then Some d
    else find_opt (if c < 0 then l else r) x

let rec find_default (tree : _ Map_gen.t ) x  default     = match tree with 
  | Empty -> default  
  | Node(l, v, d, r, _) ->
    let c = compare_key x v in
    if c = 0 then  d
    else find_default (if c < 0 then l else r) x default

let rec mem (tree : _ Map_gen.t )  x= match tree with 
  | Empty ->
    false
  | Node(l, v, d, r, _) ->
    let c = compare_key x v in
    c = 0 || mem (if c < 0 then l else r) x 

let rec remove (tree : _ Map_gen.t as 'a) x : 'a = match tree with 
  | Empty ->
    Empty
  | Node(l, v, d, r, h) ->
    let c = compare_key x v in
    if c = 0 then
      Map_gen.merge l r
    else if c < 0 then
      bal (remove l x) v d r
    else
      bal l v d (remove r x )


let rec split (tree : _ Map_gen.t as 'a) x : 'a * _ option * 'a  = match tree with 
  | Empty ->
    (Empty, None, Empty)
  | Node(l, v, d, r, _) ->
    let c = compare_key x v in
    if c = 0 then (l, Some d, r)
    else if c < 0 then
      let (ll, pres, rl) = split l x in (ll, pres, Map_gen.join rl v d r)
    else
      let (lr, pres, rr) = split r x in (Map_gen.join l v d lr, pres, rr)

let rec merge (s1 : _ Map_gen.t) (s2  : _ Map_gen.t) f  : _ Map_gen.t =
  match (s1, s2) with
  | (Empty, Empty) -> Empty
  | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 ->
    let (l2, d2, r2) = split s2 v1 in
    Map_gen.concat_or_join (merge l1 l2 f) v1 (f v1 (Some d1) d2) (merge r1 r2 f)
  | (_, Node (l2, v2, d2, r2, h2)) ->
    let (l1, d1, r1) = split s1 v2 in
    Map_gen.concat_or_join (merge l1 l2 f) v2 (f v2 d1 (Some d2)) (merge r1 r2 f)
  | _ ->
    assert false

let rec disjoint_merge  (s1 : _ Map_gen.t) (s2  : _ Map_gen.t) : _ Map_gen.t =
  match (s1, s2) with
  | (Empty, Empty) -> Empty
  | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 ->
    begin match split s2 v1 with 
    | l2, None, r2 -> 
      Map_gen.join (disjoint_merge  l1 l2) v1 d1 (disjoint_merge r1 r2)
    | _, Some _, _ ->
      raise (Duplicate_key  v1)
    end        
  | (_, Node (l2, v2, d2, r2, h2)) ->
    begin match  split s1 v2 with 
    | (l1, None, r1) -> 
      Map_gen.join (disjoint_merge  l1 l2) v2 d2 (disjoint_merge  r1 r2)
    | (_, Some _, _) -> 
      raise (Duplicate_key v2)
    end
  | _ ->
    assert false



let compare m1 m2 cmp = Map_gen.compare compare_key cmp m1 m2

let equal m1 m2 cmp = Map_gen.equal compare_key cmp m1 m2 

let add_list (xs : _ list ) init = 
  Ext_list.fold_left xs init (fun  acc (k,v) -> add acc k v )

let of_list xs = add_list xs empty

let of_array xs = 
  Ext_array.fold_left xs empty (fun acc (k,v) -> add acc k v ) 

end
module Ext_pp_scope : sig 
#1 "ext_pp_scope.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Scope type to improve identifier name printing
    Defines scope type [t], so that the pretty printer would 
    print more beautiful code:     
    print [identifer] instead of [identifier$1234] 
    when it can
 *)

type t 

val empty : t 

val print : Format.formatter -> t -> unit

val sub_scope : t -> Ident_set.t -> t

val merge : t -> Ident_set.t ->  t



val str_of_ident : t -> Ident.t -> string * t 

val ident : t -> Ext_pp.t -> Ident.t -> t 
end = struct
#1 "ext_pp_scope.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








type t =  
  int  Int_map.t String_map.t
(**
   -- "name" --> int map -- stamp --> index suffix
*)
let empty : t = 
  String_map.empty 

let rec print fmt v = 
  Format.fprintf fmt "@[<v>{"  ;
  String_map.iter v (fun k m -> 
      Format.fprintf fmt "%s: @[%a@],@ " k print_int_map m       
    )  ;
  Format.fprintf fmt "}@]"  
and print_int_map fmt m = 
  Int_map.iter m (fun k v -> 
      Format.fprintf fmt "%d - %d" k v       
    )    

let add_ident ~mangled:name (stamp : int) (cxt : t) : int * t = 
  match String_map.find_opt cxt name with 
  | None -> 
    (0, String_map.add cxt name (Int_map.add Int_map.empty stamp 0  )  )
  | Some imap -> (
      match Int_map.find_opt imap stamp with
      | None -> 
        let v = Int_map.cardinal imap in
        v, String_map.add  cxt name (Int_map.add imap stamp v )
      | Some i -> i, cxt
    )





(**
   same as {!Js_dump.ident} except it generates a string instead of doing the printing
   For fast/debug mode, we can generate the name as 
       [Printf.sprintf "%s$%d" name id.stamp] which is 
       not relevant to the context       

   Attention: 
   - $$Array.length, due to the fact that global module is 
       always printed in the begining(via imports), so you get a gurantee, 
       (global modules will not be printed as [List$1]) 

       However, this means we loose the ability of dynamic loading, is it a big 
       deal? we can fix this by a scanning first, since we already know which 
       modules are global

       check [test/test_global_print.ml] for regression
   - collision
      It is obvious that for the same identifier that they 
      print the same name.
      
      It also needs to be hold that for two different identifiers,  
      they print different names:
      - This happens when they escape to the same name and 
        share the  same stamp
      So the key has to be mangled name  + stamp
      otherwise, if two identifier happens to have same mangled name,
      if we use the original name as key, they can have same id (like 0).
      then it caused a collision
      
      Here we can guarantee that if mangled name and stamp are not all the same
      they can not have a collision

*)
let str_of_ident (cxt : t) (id : Ident.t)  : string * t  =
  if Ext_ident.is_js id then 
    (* reserved by compiler *)
    id.name , cxt
  else 
    let id_name = id.name in
    let name = Ext_ident.convert id_name in
    let i,new_cxt = add_ident  ~mangled:name id.stamp cxt in
    (if i == 0 then 
       name 
     else
       Printf.sprintf "%s$%d" name i), new_cxt 

let ident (cxt : t) f (id : Ident.t) : t  =
  let str, cxt = str_of_ident cxt id in
  Ext_pp.string f str; 
  cxt   


let merge (cxt : t) (set : Ident_set.t) = 
  Ident_set.fold set cxt (fun ident acc -> 
      snd (add_ident ~mangled:(Ext_ident.convert ident.name) ident.stamp acc)) 

(* Assume that all idents are already in [scope]
   so both [param/0] and [param/1] are in idents, we don't need 
   update twice,  once is enough
*)
let sub_scope (scope : t) (idents : Ident_set.t) : t =
  Ident_set.fold idents empty (fun {name } acc -> 
      let mangled = Ext_ident.convert name in 
      match String_map.find_exn scope mangled with 
      | exception Not_found -> assert false 
      | imap -> 
          if String_map.mem acc  mangled then acc 
          else String_map.add acc mangled imap 
    )


end
module Js_block_runtime : sig 
#1 "js_block_runtime.mli"
(* Copyright (C) 2019- Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

val tag_is_zero : 
  J.expression -> bool

val needChromeRuntime:
  J.expression -> 
  J.tag_info -> 
  bool 
  
val needBlockRuntime: 
  J.expression -> 
  J.tag_info -> 
  bool 

val check_additional_id :
  J.expression -> Ident.t option  
end = struct
#1 "js_block_runtime.ml"
(* Copyright (C) 2019- Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


let tag_is_zero (tag : J.expression) = 
  match tag.expression_desc with 
  | Number (Int {i = 0l; _}) -> true 
  | _ -> false;;

 let needChromeRuntime 
  (tag : J.expression)
  (tag_info : J.tag_info) = 
  match tag_info with 
  | Blk_variant _ 
  | Blk_module _    
  | Blk_record _   
  | Blk_constructor _   -> true

  | Blk_record_inlined _ -> true  
  

  | Blk_tuple 
  | Blk_array   

  | Blk_record_ext _ -> false
  
  | Blk_extension_slot -> false 
  | Blk_na  ->  not (tag_is_zero tag )

let needBlockRuntime (tag : J.expression) (tag_info : J.tag_info) = 
  match  tag_info with 
  | Blk_variant _ 
  | Blk_module _
  | Blk_record _  
  | Blk_tuple 
  | Blk_array -> false   

  | Blk_record_inlined (_,_,1)  
  
  | Blk_constructor (_, 1)      
  | Blk_na -> not (tag_is_zero tag)

  | Blk_record_inlined _ 
  
  | Blk_constructor _   -> true  

  | Blk_record_ext _ 
  
  | Blk_extension_slot -> false 
    (* converted to [Pcreate_extension] in the beginning*)

let option_id =   
  Ident.create_persistent Js_runtime_modules.option
let curry_id =   
  Ident.create_persistent Js_runtime_modules.curry
let block_id = 
  Ident.create_persistent Js_runtime_modules.block
let caml_chrome_id = 
  Ident.create_persistent Js_runtime_modules.caml_chrome_block

let check_additional_id (x : J.expression) =
  match x.expression_desc with
  | Optional_block(_,false) -> 
    Some option_id  
  | Call(_, _, {arity = NA}) ->  
    Some curry_id
  | Caml_block(_,_,tag,tag_info) 
    -> 
    if not !Js_config.debug then
      if needBlockRuntime tag tag_info then 
        Some block_id
      else None   
    else
    if needChromeRuntime tag tag_info then 
      (* This may depends on two modules, so in the runtime
        we let chrome depends on block
      *)
      Some caml_chrome_id
    else None
  | _ -> 
    None
end
module Js_dump_lit
= struct
#1 "js_dump_lit.ml"
(* Copyright (C) 2017 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

let function_ = "function"
let var = "var" (* should be able to switch to [let] easily*)
let return = "return"
let eq = "="
let require = "require"
let import = "import"
let from = "from"
let as_ = "as"
let export = "export"
let star = "*"
let lparen = "("
let rparen = ")"
let exports = "exports"
let dot = "."
let comma = ","
let colon = Ext_string.single_colon
let throw = "throw"
let default = "default"
let length = "length"
let char_code_at = "charCodeAt"
let new_ = "new"
let array = "Array"
let question = "?"      
let plusplus = "++"
let minusminus = "--"
let semi = ";"
let else_ = "else"
let if_ = "if"
let for_ = "for"
let try_ = "try"
let finally = "finally"

let this = "this"
let while_ = "while"
let empty_block = "empty_block"
let start_block = "start_block"
let end_block = "end_block"
let json = "JSON"
let stringify = "stringify"
let console = "console"
let define = "define"
let break = "break"
let continue = "continue"
let switch = "switch"
let strict_directive = "'use strict';"
let true_ = "true"
let false_ = "false"

let debugger = "debugger"
let tag = "tag"
let bind = "bind"
let math = "Math"
let apply = "apply"
let null = "null"
let undefined = "undefined"
let string_cap = "String"
let fromCharcode = "fromCharCode"
let eq = "="
let le = "<="
let ge = ">="
let plus_plus = "++" 
(*  FIXME: use (i = i + 1 | 0) instead  *)
let minus_minus = "--"

let caml_block_create = "__"

(** debug symbols *)
let block_record = "record"
let block_local_module = "localModule"
let block_poly_var = "polyVar"
let block_variant = "variant"
let block_simple_variant = "simpleVariant"
let case = "case" 
end
module Js_dump_string : sig 
#1 "js_dump_string.mli"
(* Copyright (C) 2017 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


 val pp_string : 
  Ext_pp.t -> 
  string -> 
  unit
end = struct
#1 "js_dump_string.ml"
(* Copyright (C) 2017 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

module P = Ext_pp

(** Avoid to allocate single char string too many times*)
let array_str1 =
  Array.init 256 (fun i -> String.make 1 (Char.chr i)) 

(** For conveting 

*)
let array_conv =
  [|"0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"; "a"; "b"; "c"; "d";
    "e"; "f"|]

 (* https://mathiasbynens.be/notes/javascript-escapes *)

 let pp_string f  (* ?(utf=false)*) s =
  let pp_raw_string f (* ?(utf=false)*) s = 
    let l = String.length s in
    for i = 0 to l - 1 do
      let c = String.unsafe_get s i in
      match c with
      | '\b' -> P.string f "\\b"
      | '\012' -> P.string f "\\f"
      | '\n' -> P.string f "\\n"
      | '\r' -> P.string f "\\r"
      | '\t' -> P.string f "\\t"
      (* This escape sequence is not supported by IE < 9
               | '\011' -> "\\v"
         IE < 9 treats '\v' as 'v' instead of a vertical tab ('\x0B'). 
         If cross-browser compatibility is a concern, use \x0B instead of \v.

         Another thing to note is that the \v and \0 escapes are not allowed in JSON strings.
      *)
      | '\000' when i = l - 1 || (let next = String.unsafe_get s (i + 1) in (next < '0' || next > '9'))
        -> P.string f "\\0"

      | '\\' (* when not utf*) -> P.string f "\\\\"


      | '\000' .. '\031'  | '\127'->
        let c = Char.code c in
        P.string f "\\x";
        P.string f (Array.unsafe_get array_conv (c lsr 4));
        P.string f (Array.unsafe_get array_conv (c land 0xf))
      | '\128' .. '\255' (* when not utf*) ->
        let c = Char.code c in
        P.string f "\\x";
        P.string f (Array.unsafe_get array_conv (c lsr 4));
        P.string f (Array.unsafe_get array_conv (c land 0xf))
      | '\"' -> P.string f "\\\"" (* quote*)
      | _ ->
        P.string f (Array.unsafe_get array_str1 (Char.code c))
    done
  in
  P.string f "\"";
  pp_raw_string f (*~utf*) s ;
  P.string f "\""
;;


(* let _best_string_quote s =
  let simple = ref 0 in
  let double = ref 0 in
  for i = 0 to String.length s - 1 do
    match s.[i] with
    | '\'' -> incr simple
    | '"' -> incr double
    | _ -> ()
  done;
  if !simple < !double
  then '\''
  else '"' *)

end
module Js_dump_property : sig 
#1 "js_dump_property.mli"
(* Copyright (C) 2017 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


val property_access : 
  Ext_pp.t ->
  string -> 
  unit 


val property_key : 
  Ext_pp.t -> 
  string -> 
  unit 
end = struct
#1 "js_dump_property.ml"
(* Copyright (C) 2017 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


module P = Ext_pp
module L = Js_dump_lit 

(**
   https://stackoverflow.com/questions/9367572/rules-for-unquoted-javascript-object-literal-keys
   https://mathiasbynens.be/notes/javascript-properties
   https://mathiasbynens.be/notes/javascript-identifiers

   Let's not do smart things
   {[
     { 003 : 1} 
   ]}
   becomes 
   {[
     { 3 : 1}
   ]}
*)

let obj_property_no_need_quot s = 
  let len = String.length s in 
  if len > 0 then 
    match String.unsafe_get s 0 with 
    | '$' | '_'
    | 'a'..'z'| 'A' .. 'Z' ->
      Ext_string.for_all_from  s
        1 
        (function 
          | 'a'..'z'|'A'..'Z'
          | '$' | '_' 
          | '0' .. '9' -> true
          | _ -> false)

    | _ -> false
  else 
    false 
(** used in printing keys 
    {[
      {"x" : x};;
      {x : x }
        {"50x" : 2 } GPR #1943
]}
    Note we can not treat it in the same way when printing
    [x.id] vs [{id : xx}]
    for example, id can be number in object literal
*)

(** used in property access 
    {[
      f.x ;;
      f["x"];;
    ]}
*)
let property_access f s = 
  if obj_property_no_need_quot s then 
    begin 
      P.string f L.dot;
      P.string f s; 
    end
  else
    begin 
      P.bracket_group f 1 @@ fun _ ->
      Js_dump_string.pp_string f s
    end

let property_key f s =     
  if obj_property_no_need_quot s then 
    P.string f s 
  else Js_dump_string.pp_string f s  
end
module Js_number : sig 
#1 "js_number.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)







type t  = float 


(* val to_string : t -> string *)


val caml_float_literal_to_js_string : string -> string

end = struct
#1 "js_number.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






type t = float 


(* http://www.ecma-international.org/ecma-262/5.1/#sec-7.8.3 
   http://caml.inria.fr/pub/docs/manual-ocaml/lex.html
   {[
     float-literal ::= [-](0...9){0...9|_}[.{0...9|_}][(e|E)][(e|E)[+|-](0...9){0...9|_}]     
   ]}   
   In ocaml, the interpretation of floating-point literals that
   fall outside the range of representable floating-point values is undefined.
   Also, (_) are accepted   

   see https://github.com/ocaml/ocaml/pull/268 that ocaml will have HEXADECIMAL notation 
   support in 4.3

   The Hex part is quite different   
 *)



let to_string (v : float) =
  if v = infinity
  then "Infinity"
  else if v = neg_infinity
  then "-Infinity"
  else if v <> v
  then "NaN"
  else
    let vint = (int_of_float v)
    (* TODO: check if 32-bits will loose some precision *)               
    in
    if float_of_int  vint = v
    then
      string_of_int vint
    else
      let s1 = Printf.sprintf "%.12g" v in
      if v = float_of_string s1
      then s1
      else
        let s2 = Printf.sprintf "%.15g" v in
        if v = float_of_string s2
        then s2
        else  Printf.sprintf "%.18g" v


let rec is_hex_format_aux (v : string) cur = 
    if v.[cur] = '-' || v.[cur]= '+' then 
      is_hex_format_ox v (cur + 1)
    else is_hex_format_ox v cur 
and is_hex_format_ox v cur = 
  v.[cur] = '0' && 
  (v.[cur + 1] = 'x' || v.[cur + 1] = 'X')

let is_hex_format (v : string) =   
  try is_hex_format_aux v 0 with _ -> false

(*
  call [to_string (float_of_string v)] 
  directly would loose some precision and lost some information
  like '3.0' -> '3'

*)
let rec aux (v : string) (buf : Buffer.t) i len = 
  if i >= len then ()
  else 
    let x = v.[i] in
    if x = '_' then
      aux v buf (i + 1) len
    else if   x  = '.' && i = len - 1  then
      ()
    else 
      begin
        Buffer.add_char buf x ;
        aux v buf ( i + 1) len
      end 

let transform v  len = 
  let buf = Buffer.create len  in
  let i = ref 0 in 
  while !i + 1 < len && v.[!i] = '0' && v.[!i + 1] <> '.' do 
    incr i
  done;
  aux v buf !i len;
  Buffer.contents buf



let caml_float_literal_to_js_string (float_str : string) : string = 
  let len = String.length float_str in

  if len >= 2 && is_hex_format float_str then  
    to_string (float_of_string float_str)
  else    

  transform float_str len

end
module Js_dump : sig 
#1 "js_dump.mli"
(* BuckleScript compiler
 * Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * http://www.ocsigen.org/js_of_ocaml/
 * Copyright (C) 2010 Jérôme Vouillon
 * Laboratoire PPS - CNRS Université Paris Diderot
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, with linking exception;
 * either version 2.1 of the License, or (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(* Authors: Jérôme Vouillon, Hongbo Zhang  *)



(** Print JS IR to vanilla Javascript code 
    Called by module {!Js_dump_program}
*)
val statement_list : 
  bool ->
  Ext_pp_scope.t -> 
  Ext_pp.t -> 
  J.block -> 
  Ext_pp_scope.t


(** 2 functions Only used for debugging *)
val string_of_block : J.block -> string

val string_of_expression : J.expression -> string

end = struct
#1 "js_dump.ml"
(* BuckleScript compiler
 * Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * http://www.ocsigen.org/js_of_ocaml/
 * Copyright (C) 2010 Jérôme Vouillon
 * Laboratoire PPS - CNRS Université Paris Diderot
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, with linking exception;
 * either version 2.1 of the License, or (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(* Authors: Jérôme Vouillon, Hongbo Zhang  *)

[@@@ocaml.warning "-57"] (* turn off such warning temporarily*)

(*
  http://stackoverflow.com/questions/2846283/what-are-the-rules-for-javascripts-automatic-semicolon-insertion-asi
  ASI catch up
   {[
     a=b
       ++c
       ---
       a=b ++c
     ====================
     a ++
     ---
     a
     ++
     ====================
     a --
     ---
     a
     --
     ====================
     (continue/break/return/throw) a
     ---
     (continue/break/return/throw)
       a
     ====================
   ]}

*)


module P = Ext_pp
module E = Js_exp_make
module S = Js_stmt_make

module L = Js_dump_lit

(* There modules are dynamically inserted in the last stage
  {Caml_curry}
  {Caml_block}
  {Caml_option}

  They can appear anywhere so even if you have a module 
  {
    let module Caml_block = ...

    (* Later would insert the use of Caml_block here which should 
      point tto the runtime module
    *)
  }
  There are no sane way to easy detect it ahead of time, we should be
  conservative here.
  (our call Js_fun_env.get_unbounded env) is not precise
*)


module Curry_gen = struct 
  let pp_curry_dot f =   
    P.string f Js_runtime_modules.curry;
    P.string f L.dot 
  let pp_optimize_curry (f : P.t) (len : int) = 
    pp_curry_dot f;
    P.string f "__";
    P.string f (Printf.sprintf "%d" len)

  let pp_app_any (f : P.t) =    
    pp_curry_dot f;
    P.string f "app"

  let pp_app (f : P.t) (len : int) =    
    pp_curry_dot f;
    P.string f "_"; 
    P.string f (Printf.sprintf "%d" len)
end 

let block_dot f = 
  P.string f Js_runtime_modules.block;
  P.string f L.dot 

let pp_block_create f =   
  block_dot f ;
  P.string f L.caml_block_create

let dbg_block_dot f =   
  P.string f Js_runtime_modules.caml_chrome_block;
  P.string f L.dot 

let dbg_block_create f =   
  dbg_block_dot f ;
  P.string f L.caml_block_create

let dbg_record f =   
  dbg_block_dot f ;
  P.string f L.block_record

let dbg_local_module f =   
  dbg_block_dot f;
  P.string f L.block_local_module

let dbg_poly_var f =   
  dbg_block_dot f;
  P.string f L.block_poly_var

let dbg_simple_variant f =   
  dbg_block_dot f ;
  P.string f L.block_simple_variant

let dbg_variant f =   
  dbg_block_dot f ; 
  P.string f L.block_variant



let return_indent = String.length L.return / Ext_pp.indent_length

let throw_indent = String.length L.throw / Ext_pp.indent_length

type cxt = Ext_pp_scope.t

let semi f = P.string f L.semi
let comma f = P.string f L.comma

let rec iter_lst cxt (f : P.t) ls element inter = 
  match ls with 
  | [] -> cxt 
  | [e] -> element cxt f e 
  | e::r -> 
    let acxt = element cxt f e  in 
    inter f; 
    iter_lst acxt f r element inter

let raw_snippet_exp_simple_enough (s : string) =
  Ext_string.for_all s (fun c -> 
  match c with 
  | 'a' .. 'z' | 'A' .. 'Z' | '_' -> true 
  | _ -> false
  )
(* Parentheses are required when the expression
   starts syntactically with "{" or "function"
   TODO:  be more conservative, since Google Closure will handle
   the precedence correctly, we also need people read the code..
   Here we force parens for some alien operators

   If we move assign into a statement, will be less?
   TODO: construct a test case that do need parenthesisze for expression
   IIE does not apply (will be inlined?)
*)

(* e = function(x){...}(x);  is good
*)        
let exp_need_paren  (e : J.expression) =
  match e.expression_desc with
  | Call ({expression_desc = Fun _ | Raw_js_function _; },_,_) -> true
  (* | Caml_uninitialized_obj _  *)
  | Raw_js_code (_, Exp)
  | Fun _ 
  | Raw_js_function _ 
  | Object _ -> true
  | Raw_js_code (_,Stmt)
  | Length _
  | Call _
  | Caml_block_tag _
  | Seq _
  | Static_index _
  | Cond _
  | Bin _
  | Is_null_or_undefined _
  | String_index _
  | Array_index _
  | String_append _
  | Char_of_int _
  | Char_to_int _
  | Var _
  | Undefined
  | Null
  | Str _
  | Unicode _
  | Array _
  | Optional_block _
  | Caml_block  _
  | FlatCall _
  | Typeof _
  | Number _
  | Js_not _
  | Bool _
  | New _
    -> false

let comma_strings f ls =     
  iter_lst 
  () f 
  ls 
  (fun _ f  a  -> P.string f a )
  comma


let comma_idents (cxt: cxt) f ls =     
  iter_lst cxt f ls   
  Ext_pp_scope.ident
  comma

let pp_paren_params 
  (inner_cxt : cxt) (f : Ext_pp.t) 
  (lexical : Ident.t list) : unit =   
  P.string f L.lparen;
  ignore @@ comma_idents inner_cxt f lexical;
  P.string f L.rparen

(** Print as underscore for unused vars, may not be 
    needed in the future *)  
let ipp_ident cxt f id (un_used : bool) =
  Ext_pp_scope.ident cxt f (
    if un_used then
      Ext_ident.make_unused () 
    else
      id)

let pp_var_assign cxt f id  =       
  P.string f L.var ; 
  P.space f ; 
  let acxt = Ext_pp_scope.ident cxt f id in 
  P.space f ; 
  P.string f L.eq ; 
  P.space f ;
  acxt 

let pp_js_function_params_body f s params =   
  P.paren_group f 1 (fun _ ->
      comma_strings f params
    );
  P.brace f (fun _ -> P.string f s)

let pp_var_assign_this cxt f id =   
  let cxt = pp_var_assign cxt f id in 
  P.string f L.this;
  P.space f ;
  semi f ;
  P.newline f ;
  cxt 

let pp_var_declare cxt f id = 
  P.string f L.var ; 
  P.space f ; 
  let acxt = Ext_pp_scope.ident cxt f id in 
  semi f ;
  acxt 

let pp_direction f (direction : J.for_direction) =   
  match direction with
  | Upto -> P.string f L.plus_plus
  | Downto -> P.string f L.minus_minus 

let return_sp f = 
    P.string f L.return ; P.space f   

let bool f b =     
  P.string f (if b then  L.true_ else L.false_)

let comma_sp f =   
  comma f ; P.space f 
let comma_nl f = 
  comma f ; P.newline f 

let drop_comment (x : J.expression) = 
  if x.comment = None then x 
  else {x with comment = None}  
let debugger_nl f =   
  P.newline f ; 
  P.string f L.debugger;
  semi f ;
  P.newline f 

let break_nl f =   
  P.string f L.break;
  P.space f ;
  semi f;
  P.newline f

let continue f s =   
  P.string f L.continue;
  P.space f ;
  P.string f s;
  semi f

let formal_parameter_list cxt f offset l env  = 
    iter_lst cxt f l Ext_pp_scope.ident comma_sp 
(* IdentMap *)
(*
f/122 -->
  f/122 is in the map
  if in, use the old mapping
  else
    check  f,
     if in last bumped id
     else
        use "f", register it

  check "f"
         if not , use "f", register stamp -> 0
         else
           check stamp
             if in  use it
             else check last bumped id, increase it and register
*)
type name =
  | No_name
  | Name_top  of Ident.t
  | Name_non_top of Ident.t


(**
   Turn [function f (x,y) { return a (x,y)} ] into [Curry.__2(a)],
   The idea is that [Curry.__2] will guess the arity of [a], if it does
   hit, then there is no cost when passed
*)

let is_var (b : J.expression)  a = 
  match b.expression_desc with 
  | Var (Id i) -> Ident.same i a 
  | _ -> false

(* TODO: refactoring
   Note that {!pp_function} could print both statement and expression when [No_name] is given
*)
let rec
  try_optimize_curry cxt f len function_id =
  Curry_gen.pp_optimize_curry f len ; 
  P.paren_group f 1 (fun _ -> expression 1 cxt f function_id  )


and  pp_function is_method
    cxt (f : P.t) ?(name=No_name)  (return : bool)
    (l : Ident.t list) (b : J.block) (env : Js_fun_env.t ) : cxt =
  match b, (name,  return)  with
  | [ {statement_desc =
         Return {return_value =
                   {expression_desc =
                      Call(({expression_desc = Var v ; _} as function_id),
                           ls ,
                           {arity = ( Full | NA as arity(* see #234*));
                            (* TODO: need a case to justify it*)
                            call_info =
                              (Call_builtin_runtime | Call_ml )})}}}],
    ((_, false) | (No_name, true))
    when
      (* match such case:
         {[ function(x,y){ return u(x,y) } ]}
         it can be optimized in to either [u] or [Curry.__n(u)]
      *)
      not is_method &&
      Ext_list.for_all2_no_exn ls l  is_var  ->
    let optimize  len p cxt f v =
      if p then try_optimize_curry cxt f len function_id
      else
        vident cxt f v in
    let len = List.length l in (* length *)
    (match name with
     | Name_top i | Name_non_top i  ->       
       let cxt = pp_var_assign cxt f i in 
       let cxt = optimize len (arity = NA && len <= 8) cxt f v in
       semi f ;
       cxt
     | No_name ->
       if return then 
         return_sp f ;
       optimize len (arity = NA && len <=8) cxt f v)

  | _, _  ->
    let set_env : Ident_set.t = (** identifiers will be printed following*)
      match name with
      | No_name ->
        Js_fun_env.get_unbounded env
      | Name_top id | Name_non_top id -> 
        Ident_set.add (Js_fun_env.get_unbounded env ) id in
    (* the context will be continued after this function *)
    let outer_cxt = Ext_pp_scope.merge cxt set_env in

    (* the context used to be printed inside this function

       when printing a function,
       only the enclosed variables and function name matters,
       if the function does not capture any variable, then the context is empty
    *)
    let inner_cxt = Ext_pp_scope.sub_scope outer_cxt set_env in


    (* (if not @@ Js_fun_env.is_empty env then *)
    (* pp_comment  f (Some (Js_fun_env.to_string env))) ; *)
    let param_body () =
      if is_method then
        match l with 
        | [] -> assert false 
        | this::arguments -> 
          let cxt = P.paren_group f 1 (fun _ ->
              formal_parameter_list inner_cxt  f 1 arguments env )
          in
          P.space f ;
          ignore @@ P.brace_vgroup f 1 (fun _ ->
              let cxt =
                if Js_fun_env.get_unused env 0 then cxt 
                else  pp_var_assign_this cxt f this in
              function_body cxt f b
            );
      else 
        let cxt = 
          P.paren_group f 1 (fun _ -> formal_parameter_list inner_cxt  f 0 l env ) in
        P.space f ;
        ignore @@ P.brace_vgroup f 1 (fun _ -> function_body cxt f b ) in
    let lexical : Ident_set.t = Js_fun_env.get_lexical_scope env in
    let enclose  lexical  return =
      let handle lexical =
        if  Ident_set.is_empty lexical
        then
          (if return then
             return_sp f ;
           match name with
           | No_name ->
             (* see # 1692, add a paren for annoymous function for safety  *)
             P.paren_group f 1  (fun _ ->
                 P.string f L.function_;
                 P.space f ;
                 param_body ())                
           | Name_non_top x  ->
             ignore @@ pp_var_assign inner_cxt f x ; 
             P.string f L.function_;
             P.space f ;
             param_body ();
             semi f 
           | Name_top x  ->
             P.string f L.function_;
             P.space f ;
             ignore (Ext_pp_scope.ident inner_cxt f x);
             param_body ())
        else
          (* print as
             {[(function(x,y){...} (x,y))]}
          *)
          let lexical = Ident_set.elements lexical in
          (if return then 
             return_sp f             
           else
             match name with
             | No_name -> ()
             | Name_non_top name | Name_top name->
               ignore @@ pp_var_assign inner_cxt f name              
          )
          ;
          P.string f L.lparen;
          P.string f L.function_;
          pp_paren_params inner_cxt f lexical; 
          P.brace_vgroup f 0  (fun _ ->
              return_sp f;
              P.string f L.function_;
              P.space f ;
              (match name with
               | No_name  -> ()
               | Name_non_top x | Name_top x -> ignore (Ext_pp_scope.ident inner_cxt f x));
              param_body ());
          pp_paren_params inner_cxt f lexical;     
          P.string f L.rparen;
          match name with
          | No_name -> () (* expression *)
          | _ -> semi f (* has binding, a statement *)  in
      handle 
        (match name with
         | Name_top name | Name_non_top name  when Ident_set.mem lexical name ->
           (*TODO: when calculating lexical we should not include itself *)
           Ident_set.remove lexical name
         | _ -> lexical) in
    enclose lexical return;
    outer_cxt


(* Assume the cond would not change the context,
    since it can be either [int] or [string]
*)
and pp_one_case_clause : 'a .
  _ -> P.t -> (P.t -> 'a -> unit) -> 'a J.case_clause -> _
  = fun cxt f  pp_cond
    ({switch_case; switch_body ; should_break } : _ J.case_clause) ->
    let cxt =
      P.group f 1  (fun _ ->
          P.group f 1 (fun _ ->
              P.string f L.case;
              P.space f ;
              pp_cond  f switch_case; (* could be integer or string *)
              P.space f ;
              P.string f L.colon  );
          P.space f;
          P.group f 1 (fun _ ->
              let cxt =
                match switch_body with
                | [] -> cxt
                | _ ->
                  P.newline f ;
                  statement_list false cxt  f switch_body
              in
              (if should_break then
                 begin
                   P.newline f ;
                   P.string f L.break;
                   semi f;
                 end) ;
              cxt))
    in
    P.newline f;
    cxt

and loop_case_clauses  :  'a . cxt ->
  P.t -> (P.t -> 'a -> unit) -> 'a J.case_clause list -> cxt
  = fun  cxt  f pp_cond cases ->
    Ext_list.fold_left cases cxt (fun acc x -> pp_one_case_clause acc f pp_cond x)              

and vident cxt f  (v : J.vident) =
  match v with
  | Id v | Qualified(v, _, None) ->
    Ext_pp_scope.ident cxt f v
  | Qualified (id, (Ml | Runtime),  Some name) ->
    let cxt = Ext_pp_scope.ident cxt f id in
    P.string f L.dot;
    P.string f (Ext_ident.convert  name);
    cxt
  | Qualified (id, External _, Some name) ->
    let cxt = Ext_pp_scope.ident cxt f id in
    Js_dump_property.property_access f name ;
    cxt


and expression l cxt  f (exp : J.expression) : cxt =
  pp_comment_option f exp.comment ;
  expression_desc cxt l f exp.expression_desc

and expression_desc cxt (level:int) f x : cxt  =
  match x with
  | Null ->
    P.string f L.null; cxt 
  | Undefined -> 
    P.string f L.undefined; cxt 
  | Var v ->
    vident cxt f v
  | Bool b ->
    bool f b ; cxt
  | Seq (e1, e2) ->
    P.cond_paren_group f (level > 0) 1 (fun () ->
      let cxt = expression 0 cxt f e1 in
      comma_sp f;
      expression 0 cxt f e2 )
  | Fun (method_, l, b, env) ->  (* TODO: dump for comments *)
    pp_function method_ cxt f false  l b env
  (* TODO:
     when [e] is [Js_raw_code] with arity
     print it in a more precise way
     It seems the optimizer already did work to make sure
     {[
       Call (Raw_js_code (s, Exp i), el, {Full})
       when Ext_list.length_equal el i
     ]}
  *)

  | Call (e, el, info) ->
    P.cond_paren_group f (level > 15) 1  (fun _ -> 
      P.group f 1 (fun _ ->
          match info, el  with
          | {arity  = Full }, _
          | _, [] ->
            let cxt = expression 15 cxt f e in
            P.paren_group f 1 (fun _ -> arguments cxt  f el )

          | _ , _ ->
            let len = List.length el in
            if 1 <= len && len <= 8 then
              begin
                Curry_gen.pp_app f len ; 
                P.paren_group f 1 (fun _ -> arguments cxt f (e::el))
              end
            else
              begin
                Curry_gen.pp_app_any f ;
                P.paren_group f 1
                  (fun _ -> arguments cxt f [ e ; E.array Mutable el])
              end))
  | FlatCall(e,el) ->
    P.group f 1 (fun _ ->
        let cxt = expression 15 cxt f e in
        P.string f L.dot;
        P.string f L.apply;
        P.paren_group f 1 (fun _ ->
            P.string f L.null;
            comma_sp f ;
            expression 1 cxt f el
          )
      )
  | Char_to_int e ->
    (match e.expression_desc with
     | String_index (a,b) ->
       P.group f 1 (fun _ ->
           let cxt = expression 15 cxt f a in
           P.string f L.dot;
           P.string f L.char_code_at;
           P.paren_group f 1 (fun _ -> expression 0 cxt f b);
         )
     | _ ->
       P.group f 1 (fun _ ->
           let cxt = expression 15 cxt f e in
           P.string f L.dot;
           P.string f L.char_code_at;
           P.string f "(0)";
           cxt))
  | Char_of_int e ->
    P.group f 1 (fun _ ->
        P.string f L.string_cap;
        P.string f L.dot;
        P.string f L.fromCharcode;
        P.paren_group f 1 (fun _ -> arguments cxt f [e])
      )  
  | Unicode s ->
    P.string f "\"";
    P.string f s ;
    P.string f "\"";
    cxt
  | Str (_, s) ->
    (*TODO --
       when utf8-> it will not escape '\\' which is definitely not we want
    *)
    Js_dump_string.pp_string f  s;
    cxt
  | Raw_js_function (s,params) ->   
    P.string f L.function_; 
    P.space f ; 
    pp_js_function_params_body f s params;
    cxt 
  | Raw_js_code (s,info) ->
    (match info with
     | Exp ->
       if raw_snippet_exp_simple_enough s then 
         P.string f s        
       else begin 
         P.string f L.lparen;
         P.string f s ;
         P.string f L.rparen;
       end;
       cxt
     | Stmt ->
       P.newline f  ;
       P.string f s ;
       P.newline f ;
       cxt)
  
  | Number v ->
    let s =
      match v with
      | Float {f} ->
        Js_number.caml_float_literal_to_js_string f
      (* attach string here for float constant folding?*)
      | Int { i; _}
        -> Int32.to_string i (* check , js convention with ocaml lexical convention *)
      | Uint i
        -> Format.asprintf "%lu" i
      | Nint i -> Nativeint.to_string i in
    let need_paren =
      if s.[0] = '-'
      then level > 13  (* Negative numbers may need to be parenthesized. *)
      else level = 15  (* Parenthesize as well when followed by a dot. *)
           && s.[0] <> 'I' (* Infinity *)
           && s.[0] <> 'N' (* NaN *) in
    let action = 
      fun _ -> P.string f s  in
    (
      if need_paren
      then P.paren f  action
      else action ()
    );
    cxt
  | Is_null_or_undefined e ->
    P.cond_paren_group f (level > 0) 1 (fun _ ->
        let cxt = expression 1 cxt f e in
        P.space f ;
        P.string f "==";
        P.space f ;
        P.string f L.null;
        cxt)  
  | Js_not e ->
    P.cond_paren_group f (level > 13) 1 (fun _ -> 
      P.string f "!" ;
      expression 13 cxt f e
    )
  | Typeof e
    ->
    P.string f "typeof";
    P.space f;
    expression 13 cxt f e
  | Bin (Eq, {expression_desc = Var i },
         {expression_desc =
            (
              Bin(
                (Plus as op), {expression_desc = Var j}, delta)
            | Bin(
                (Plus as op), delta, {expression_desc = Var j})
            | Bin(
                (Minus as op), {expression_desc = Var j}, delta)
            )
         })
    when Js_op_util.same_vident i j ->
    (* TODO: parenthesize when necessary *)
    begin match delta, op with
      | {expression_desc = Number (Int { i =  1l; _})}, Plus
      (* TODO: float 1. instead,
           since in JS, ++ is a float operation
      *)
      | {expression_desc = Number (Int { i =  -1l; _})}, Minus
        ->
        P.string f L.plusplus;
        P.space f ;
        vident cxt f i

      | {expression_desc = Number (Int { i =  -1l; _})}, Plus
      | {expression_desc = Number (Int { i =  1l; _})}, Minus
        ->
        P.string f L.minusminus;
        P.space f ;
        vident cxt f i;
      | _, _ ->
        let cxt = vident cxt f i in
        P.space f ;
        if op = Plus then P.string f "+="
        else P.string f "-=";
        P.space f ;
        expression 13 cxt  f delta
    end
  | Bin (Eq, {expression_desc = Array_index({expression_desc = Var i; _},
                                       {expression_desc = Number (Int {i = k0 })}
                                      ) },
         {expression_desc =
            (Bin((Plus as op),
                 {expression_desc = Array_index(
                      {expression_desc = Var j; _},
                      {expression_desc = Number (Int {i = k1; })}
                    ); _}, delta)
            | Bin((Plus as op), delta,
                  {expression_desc = Array_index(
                       {expression_desc = Var j; _},
                       {expression_desc = Number (Int {i = k1; })}
                     ); _})
            | Bin((Minus as op),
                  {expression_desc = Array_index(
                       {expression_desc = Var j; _},
                       {expression_desc = Number (Int {i = k1; })}
                     ); _}, delta)

            )})
    when  k0 = k1 && Js_op_util.same_vident i j
    (* Note that
       {[x = x + 1]}
       is exactly the same  (side effect, and return value)
       as {[ ++ x]}
       same to
       {[ x = x + a]}
       {[ x += a ]}
       they both return the modified value too
    *)
    (* TODO:
       handle parens..
    *)
    ->
    let aux cxt f vid i =
      let cxt = vident cxt f vid in
      P.string f "[";
      P.string f (Int32.to_string  i);
      P.string f"]";
      cxt in
    (** TODO: parenthesize when necessary *)
    (match delta, op with
     | {expression_desc = Number (Int { i =  1l; _})}, Plus
     | {expression_desc = Number (Int { i =  -1l; _})}, Minus
       ->
       P.string f L.plusplus;
       P.space f ;
       aux cxt f i k0
     | {expression_desc = Number (Int { i =  -1l; _})}, Plus
     | {expression_desc = Number (Int { i =  1l; _})}, Minus
       ->
       P.string f L.minusminus;
       P.space f ;
       aux cxt f  i k0
     | _, _ ->
       let cxt = aux cxt f i k0 in
       P.space f ;
       if op = Plus then P.string f "+="
       else P.string f "-=";
       P.space f ;
       expression 13 cxt  f delta)
  | Bin (Minus, {expression_desc = Number (Int {i=0l;_} | Float {f = "0."})}, e)
    (* TODO:
       Handle multiple cases like
       {[ 0. - x ]}
       {[ 0.00 - x ]}
       {[ 0.000 - x ]}
    *)
    ->
    P.cond_paren_group f (level > 13 ) 1 (fun _ -> 
      P.string f "-" ;
      expression 13 cxt f e
    )
  | Bin (op, e1, e2) ->
    let (out, lft, rght) = Js_op_util.op_prec op in
    let need_paren =
      level > out || (match op with Lsl | Lsr | Asr -> true | _ -> false) in
    (* We are more conservative here, to make the generated code more readable
          to the user *)
    P.cond_paren_group f need_paren 1  (fun _ -> 
      let cxt = expression lft cxt  f e1 in
      P.space f;
      P.string f (Js_op_util.op_str op);
      P.space f;
      expression rght cxt   f e2)
  | String_append (e1, e2) ->
    let op : Js_op.binop = Plus in
    let (out, lft, rght) = Js_op_util.op_prec op in
    let need_paren =
      level > out || (match op with Lsl | Lsr | Asr -> true | _ -> false) in
    P.cond_paren_group f need_paren 1 (fun _ -> 
      let cxt = expression  lft cxt f e1 in
      P.space f ;
      P.string f "+";
      P.space f;
      expression rght  cxt   f e2)
  | Array (el,_) ->
    (** TODO: simplify for singleton list *)
      (match el with
      | []| [ _ ] -> P.bracket_group f 1 @@ fun _ -> array_element_list  cxt f el
      | _ -> P.bracket_vgroup f 1 @@ fun _ -> array_element_list  cxt f el)
  | Optional_block (e,identity) -> 
    expression level cxt f  
      (if identity then e 
       else       
         E.runtime_call Js_runtime_modules.option "some" [e])
  | Caml_block( el, mutable_flag, tag, tag_info)
    ->
    (* Note that, if we ignore more than tag [0] we loose some information
       with regard tag  

       TODO: for numbers like 248, 255 we can reverse engineer to make it
         [Obj.xx_flag], but we can not do this in runtime libraries

       When it does not need block runtime, it means it will be compiled 
       as an array, note exception or open variant it is outer-most is 
       simply an array
    *)
    if not !Js_config.debug then begin 
      if not (Js_block_runtime.needBlockRuntime tag tag_info) then 
        expression_desc cxt level f  (Array (el, mutable_flag))
      else  
        begin
          pp_block_create f;
          P.paren_group f 1 (fun _ -> arguments cxt f [tag; E.array mutable_flag el])
        end  
    end 
      else
        if not (Js_block_runtime.needChromeRuntime tag tag_info) then 
          expression_desc cxt level f  (Array (el, mutable_flag))
        else 
      (  
        match tag_info with 
        | Blk_record labels ->
          dbg_record f ;
          P.paren_group f 1 (fun _ -> arguments cxt f 
                                [E.array Immutable
                                   (Ext_array.to_list_f labels E.str );
                                 E.array mutable_flag 
                                   (Ext_list.map el drop_comment) ]
                            )
        | Blk_module (Some labels) ->         
          dbg_local_module f;
          P.paren_group f 1 (fun _ -> arguments cxt f 
                                [E.array Immutable
                                   (Ext_list.map labels E.str);
                                 E.array mutable_flag
                                   (Ext_list.map el drop_comment)])
        | Blk_variant name ->  
          dbg_poly_var f;
          P.paren_group f 1 (fun _ -> arguments cxt f [ 
              E.str name;
              E.array mutable_flag el])        
        | Blk_constructor(name,number) 

          -> (* has to be debug mode *)          
          if number = 1 && Js_block_runtime.tag_is_zero tag then 
            begin
              dbg_simple_variant f; 
              P.paren_group f 1 (fun _ ->
                  arguments cxt f 
                    [E.str name; E.array mutable_flag el])             
            end
          else begin 
            dbg_variant f;
            P.paren_group f 1 (fun _ ->
                arguments cxt f 
                  [E.str name; tag; E.array mutable_flag el])
          end

          
                               
        | Blk_record_inlined _ (* TODO: No support for debug mode yet *)

        | Blk_tuple
        | Blk_array
     
        | Blk_record_ext _
      
        | Blk_extension_slot
        | Blk_na
        | Blk_module None ->           
          dbg_block_create f;
          P.paren_group f 1 (fun _ -> arguments cxt f [tag; E.array mutable_flag el])
    )

  | Caml_block_tag e ->
    P.group f 1 (fun _ ->
        let cxt = expression 15 cxt f  e in
        P.string f L.dot ;
        P.string f L.tag ;
        cxt)
  | Array_index (e, p)
  | String_index (e,p)
    ->
    P.cond_paren_group f (level > 15) 1 (fun _ -> 
        P.group f 1 @@ fun _ ->
        let cxt = expression 15 cxt f e in
        P.bracket_group f 1 @@ fun _ ->
        expression 0 cxt f p )
  | Static_index (e, s) ->
    P.cond_paren_group f (level > 15) 1 (fun _ -> 
        let cxt = expression 15 cxt f e in
        Js_dump_property.property_access f s ;
        (* See [ .obj_of_exports]
           maybe in the ast level we should have
           refer and export
        *)
        cxt) 

  | Length (e, _) ->
    (** Todo: check parens *)
    P.cond_paren_group f (level > 15) 1 (fun _ -> 
      let cxt = expression 15 cxt f e in
      P.string f L.dot;
      P.string f L.length;
      cxt)
  | New (e,  el) ->
    P.cond_paren_group f (level > 15) 1 (fun _ ->
      P.group f 1 @@ fun _ ->
      P.string f L.new_;
      P.space f;
      let cxt = expression 16 cxt f e in
      P.paren_group f 1 @@ fun _ ->
      match el with
      | Some el  -> arguments cxt f el
      | None -> cxt)
  | Cond (e, e1, e2) ->
    let action () =
      (* P.group f 1 @@ fun _ ->  *)
      let cxt =  expression 3 cxt f e in
      P.space f;
      P.string f L.question;
      P.space f;
      (*
            [level 1] is correct, however
            to make nice indentation , force nested conditional to be parenthesized
          *)
      let cxt = P.group f 1 (fun _ -> expression 3 cxt f e1) in
      (* let cxt = (P.group f 1 @@ fun _ -> expression 1 cxt f e1) in *)
      P.space f;
      P.string f L.colon;
      P.space f ;

      (* idem *)
      P.group f 1 @@ fun _ -> expression 3 cxt f e2
      (* P.group f 1 @@ fun _ -> expression 1 cxt f e2 *)
    in
    if level > 2 then P.paren_vgroup f 1 action else action ()

  | Object lst ->
    match lst with
    | [] -> P.string f "{ }" ; cxt
    | _ ->
      let action () =
        P.brace_vgroup f 1 @@ fun _ ->
        property_name_and_value_list cxt f lst in
      if level > 1 then
        (* #1946 object literal is easy to be
           interpreted as block statement
           here we avoid parens in such case
           {[
             var f = { x : 2 , y : 2}
           ]}
        *)
        P.paren_group f 1 action
      else action ()

and property_name_and_value_list cxt f l =     
  iter_lst cxt f l (fun cxt f (pn,e) -> 
    Js_dump_property.property_key f pn ;
    P.string f L.colon;
    P.space f;
    expression 1 cxt f e
  ) comma_nl      
and array_element_list cxt f el : cxt =
  iter_lst cxt f el (fun cxt f e  -> expression 1 cxt f e ) comma_nl
 
and arguments cxt f l : cxt =
  iter_lst cxt f l (fun cxt f e  -> expression 1 cxt f e) comma_sp
  
and variable_declaration top cxt f
    (variable : J.variable_declaration) : cxt =
  (* TODO: print [const/var] for different backends  *)
  match variable with
  | {ident = i; value =  None; ident_info ; _} ->
    if ident_info.used_stats = Dead_pure then cxt
    else pp_var_declare cxt f i 
  | { ident = name; value =  Some e; ident_info = {used_stats; _}} ->
    match used_stats with
    | Dead_pure ->
      cxt
    | Dead_non_pure ->
      (* Make sure parens are added correctly *)
      statement_desc top cxt f (J.Exp e)
    | _ ->
      match e.expression_desc, top  with
      | Fun (method_, params, b, env ), _ ->
        pp_function method_ cxt f
          ~name:(if top then Name_top name else Name_non_top name)
          false params b env      
      | Raw_js_function(s,params), true ->     
        P.string f L.function_;             
        P.space f ; 
        let acxt = Ext_pp_scope.ident cxt f name in 
        P.space f ; 
        pp_js_function_params_body f s params;
        semi f;
        acxt 
      | _, _ ->
        let cxt = pp_var_assign cxt f name in 
        let cxt = expression 1 cxt f e in
        semi f;
        cxt

    
and ipp_comment : 'a . P.t -> 'a  -> unit = fun   f comment ->
  ()


(** don't print a new line -- ASI
    FIXME: this still does not work in some cases...
    {[
      return /* ... */
      [... ]
    ]}
*)

and pp_comment f comment =
  if String.length comment > 0 then
    begin
      P.string f "/* "; P.string f comment ; P.string f " */"
    end

and pp_comment_option f comment  =
  match comment with
  | None -> ()
  | Some x -> pp_comment f x
and statement top cxt f
    ({statement_desc = s;  comment ; _} : J.statement)  : cxt =

  pp_comment_option f comment ;
  statement_desc top cxt f s

and statement_desc top cxt f (s : J.statement_desc) : cxt =
  match s with
  | Block [] ->
    ipp_comment f  L.empty_block; (* debugging*)
    cxt
  | Exp {expression_desc = Var _;}
    -> (* Does it make sense to optimize here? *)
    semi f; cxt
  | Exp e ->
    let cxt =
      (
        if exp_need_paren  e
        then P.paren_group f 1
        else P.group f 0
      ) (fun _ -> expression 0 cxt f e ) in
    semi f;
    cxt
  | Block b -> (* No braces needed here *)
    ipp_comment f L.start_block;
    let cxt = statement_list top cxt  f b in
    ipp_comment f  L.end_block;
    cxt
  | Variable l ->
    variable_declaration top cxt  f l

  | If (e, s1,  s2) -> (* TODO: always brace those statements *)
    P.string f L.if_;
    P.space f;
    let cxt = P.paren_group f 1 (fun _ -> expression 0 cxt f e) in
    P.space f;
    let cxt = block cxt f s1 in
    (match s2 with
     | None | (Some [])
     | Some [{statement_desc = (Block [] | Exp {expression_desc = Var _;} ); }]
       -> P.newline f; cxt
     | Some [{statement_desc = If _} as nest]
     | Some [{statement_desc = Block [ {statement_desc = If _ ; _} as nest] ; _}]
       ->
       P.space f;
       P.string f L.else_;
       P.space f;
       statement false cxt f nest
     | Some s2 ->
       P.space f;
       P.string f L.else_;
       P.space f ;
       block  cxt f s2)
  | While (label, e, s, _env) ->  (*  FIXME: print scope as well *)
    begin
      (match label with
       | Some i ->
         P.string f i ;
         P.string f L.colon;
         P.newline f ;
       | None -> ());
      let cxt =
        match e.expression_desc with
        | Number (Int {i = 1l}) ->
          P.string f L.while_;
          P.string f L.lparen;
          P.string f L.true_;
          P.string f L.rparen;
          P.space f ;
          cxt
        | _ ->
          P.string f L.while_;
          let cxt = P.paren_group f 1 (fun _ ->  expression 0 cxt f e) in
          P.space f ;
          cxt
      in
      let cxt = block cxt f s in
      semi f;
      cxt
    end
  | ForRange (for_ident_expression, finish, id, direction, s, env) ->
    let action cxt  =
      P.vgroup f 0 @@ fun _ ->
      let cxt = P.group f 0 @@ fun _ ->
        (* The only place that [semi] may have semantics here *)
        P.string f L.for_ ;
        P.paren_group f 1 @@ fun _ ->
        let cxt, new_id =
          match for_ident_expression, finish.expression_desc with
          | Some ident_expression , (Number _ | Var _ ) ->
            let cxt = pp_var_assign cxt f id in  
            expression 0 cxt f ident_expression, None
          | Some ident_expression, _ ->
            let cxt = pp_var_assign cxt f id in 
            let cxt = expression 1 cxt f ident_expression in
            P.space f ;
            comma f;  
            let id = Ext_ident.create (Ident.name id ^ "_finish") in
            let cxt = Ext_pp_scope.ident cxt f id in
            P.space f ;
            P.string f L.eq;
            P.space f;
            expression 1 cxt f finish, Some id
          | None, (Number _ | Var _) ->
            cxt, None
          | None , _ ->
            let id = Ext_ident.create (Ident.name id ^ "_finish") in
            let cxt = pp_var_assign cxt f id in 
            expression 15 cxt f finish, Some id in
        semi f ;
        P.space f;
        let cxt = Ext_pp_scope.ident cxt f id in
        P.space f;
        let right_prec  =
          match direction with
          | Upto ->
            let (_,_,right) = Js_op_util.op_prec Le  in
            P.string f L.le;
            right
          | Downto ->
            let (_,_,right) = Js_op_util.op_prec Ge in
            P.string f L.ge ;
            right
        in
        P.space f ;
        let cxt  =
          expression   right_prec cxt  f 
            (match new_id with
             | Some i -> E.var i
             | None -> finish) in
        semi f;
        P.space f;
        pp_direction f direction;
        Ext_pp_scope.ident cxt f id in
      block  cxt f s  in
    let lexical = Js_closure.get_lexical_scope env in
    if Ident_set.is_empty lexical
    then action cxt
    else
      (* unlike function,
         [print for loop] has side effect,
         we should take it out
      *)
      let inner_cxt = Ext_pp_scope.merge cxt lexical in
      let lexical = Ident_set.elements lexical in
      P.vgroup f 0
        (fun _ ->
           P.string f L.lparen;
           P.string f L.function_;               
           pp_paren_params inner_cxt f lexical; 
           let cxt = P.brace_vgroup f 0  (fun _ -> action inner_cxt) in               
           pp_paren_params inner_cxt f lexical; 
           P.string f L.rparen;
           semi f;
           cxt
        )
  | Continue s -> continue f s ; cxt
    (* P.newline f;  #2642 *)    
  | Debugger ->  debugger_nl f ; cxt
  | Break -> break_nl f; cxt

  | Return {return_value = e} ->
    begin match e.expression_desc with
      | Fun (method_,  l, b, env) ->
        let cxt =
          pp_function method_ cxt f true l b env in
        semi f ; cxt
      | Undefined ->  
        return_sp f;
        semi f;
        cxt 
      | _ ->
        return_sp f ;
        (* P.string f "return ";(\* ASI -- when there is a comment*\) *)
        P.group f return_indent (fun _ ->
            let cxt =  expression 0 cxt f e in
            semi f;
            cxt)
        (* There MUST be a space between the return and its
           argument. A line return will not work *)
    end
  | Int_switch (e, cc, def) ->
    P.string f L.switch;
    P.space f;
    let cxt = P.paren_group f 1 (fun _ ->  expression 0 cxt f e) in
    P.space f;
    P.brace_vgroup f 1 @@ fun _ ->
    let cxt = loop_case_clauses cxt f (fun f i -> P.string f (string_of_int i) ) cc in
    (match def with
     | None -> cxt
     | Some def ->
       P.group f 1 @@ fun _ ->
       P.string f L.default;
       P.string f L.colon;
       P.newline f;
       statement_list  false cxt  f def
    )

  | String_switch (e, cc, def) ->
    P.string f L.switch;
    P.space f;
    let cxt = P.paren_group f 1 @@ fun _ ->  expression 0 cxt f e in
    P.space f;
    P.brace_vgroup f 1 (fun _ ->
        let cxt = loop_case_clauses cxt f (fun f i -> Js_dump_string.pp_string f i ) cc in
        match def with
        | None -> cxt
        | Some def ->
          P.group f 1 (fun _ ->
          P.string f L.default;
          P.string f L.colon;
          P.newline f;
          statement_list  false cxt  f def ))
  | Throw e ->
    P.string f L.throw;
    P.space f ;
    P.group f throw_indent  (fun _ ->
        let cxt = expression 0 cxt f e in
        semi f ; cxt)

  (* There must be a space between the return and its
     argument. A line return would not work *)
  | Try (b, ctch, fin) ->
    P.vgroup f 0 @@ fun _->
    P.string f L.try_;
    P.space f ;
    let cxt = block cxt f b in
    let cxt =
      match ctch with
      | None ->
        cxt
      | Some (i, b) ->
        P.newline f;
        P.string f "catch (";
        let cxt = Ext_pp_scope.ident cxt f i in
        P.string f ")";
        block cxt f b in
    match fin with
    | None -> cxt
    | Some b ->
      P.group f 1 (fun _ ->
          P.string f L.finally;
          P.space f;
          block cxt f b)

and function_body cxt f b =
  match b with
  | []     -> cxt
  | [s]    ->
    begin match s.statement_desc with
    | If (bool,
          then_,
          Some [{
              statement_desc =
                Return {return_value = {expression_desc = Undefined}} }])
        ->
        statement false cxt f {s with statement_desc = If(bool,then_,None)}
    | _ ->        
      statement false  cxt f  s
    end
  | s :: r ->
    let cxt = statement false cxt f s in
    P.newline f;
    function_body cxt f  r

(* similar to [block] but no braces *)
and statement_list top cxt f  b =
  iter_lst cxt f b  (fun cxt f s -> statement top cxt f s )
    (if top then 
      (fun f -> P.newline f ; P.force_newline f )
      else P.newline
    )
    (* (fun f -> P.newline f ; if top then P.force_newline f ) *)

and block cxt f b =
  (* This one is for '{' *)
  P.brace_vgroup f 1 (fun _ -> statement_list false cxt   f b )




(* let program f cxt   ( x : J.program ) =
  let () = P.force_newline f in
  let cxt =  statement_list true cxt f x.block  in
  let () = P.force_newline f in
  Js_dump_import_export.exports cxt f x.exports *)

(* let dump_program (x : J.program) oc =
  ignore (program (P.from_channel oc)  Ext_pp_scope.empty  x ) *)

let string_of_block  block
  =
  let buffer  = Buffer.create 50 in
  let f = P.from_buffer buffer in
  let _scope =  statement_list true Ext_pp_scope.empty  f block in
  P.flush  f ();
  Buffer.contents buffer



let string_of_expression e =
  let buffer  = Buffer.create 50 in
  let f = P.from_buffer buffer in
  let _scope =  expression 0  Ext_pp_scope.empty  f e in
  P.flush  f ();
  Buffer.contents buffer


end
module Js_dump_import_export : sig 
#1 "js_dump_import_export.mli"
(* Copyright (C) 2017 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



val exports : 
  Ext_pp_scope.t -> Ext_pp.t -> Ident.t list -> Ext_pp_scope.t

val es6_export :   
  Ext_pp_scope.t -> Ext_pp.t -> Ident.t list -> Ext_pp_scope.t

val requires :  
  string -> Ext_pp_scope.t ->
  Ext_pp.t -> (Ident.t * string) list -> 
  Ext_pp_scope.t 

val imports : 
  Ext_pp_scope.t -> 
  Ext_pp.t -> 
  (Ident.t * string) list -> 
  Ext_pp_scope.t
end = struct
#1 "js_dump_import_export.ml"
(* Copyright (C) 2017 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

module P = Ext_pp
module L = Js_dump_lit
let default_export = "default"
let esModule  = "__esModule", "true"
(** Exports printer *)
(** Print exports in Google module format, CommonJS format *)
let exports cxt f (idents : Ident.t list) = 
  let outer_cxt, reversed_list = 
    Ext_list.fold_left idents (cxt, []) (fun (cxt, acc) id -> 
        let id_name = id.name in 
        let s = Ext_ident.convert id_name in        
        let str,cxt  = Ext_pp_scope.str_of_ident cxt id in         
        cxt, ( 
          if id_name = default_export then 
            (* TODO check how it will affect AMDJS*)
            esModule :: (default_export, str) :: (s,str)::acc 
          else (s,str) :: acc ))
  in    
  P.newline f ;
  Ext_list.rev_iter reversed_list (fun (s,export) -> 
      P.group f 0 @@ (fun _ ->  
          P.string f L.exports;
          P.string f L.dot;
          P.string f s; 
          P.space f ;
          P.string f L.eq;
          P.space f;
          P.string f export;          
          P.string f L.semi;);
      P.newline f;
    ) ;
  outer_cxt  


(** Print module in ES6 format, it is ES6, trailing comma is valid ES6 code *)
let es6_export cxt f (idents : Ident.t list) = 
  let outer_cxt, reversed_list = 
    Ext_list.fold_left idents (cxt, []) (fun (cxt, acc) id  -> 
        let id_name = id.name in 
        let s = Ext_ident.convert id_name in        
        let str,cxt  = Ext_pp_scope.str_of_ident cxt id in         
        cxt, ( 
          if id_name = default_export then 
            (default_export,str)::(s,str)::acc
          else 
            (s,str) :: acc ))
  in    
  P.newline f ;
  P.string f L.export ; 
  P.space f ; 
  P.brace_vgroup f 1 begin fun _ -> 
    Ext_list.rev_iter reversed_list (fun (s,export) -> 
        P.group f 0 @@ (fun _ ->  
            P.string f export;          
            P.space f ;
            if not @@ Ext_string.equal export s then begin 
              P.string f L.as_ ;
              P.space f;
              P.string f s
            end ;             
            P.string f L.comma ;);
        P.newline f;
      ) ;
  end;
  outer_cxt  
  

(** Node or Google module style imports *)
let requires require_lit cxt f (modules : (Ident.t * string) list ) =
  P.newline f ; 
  (* the context used to print the following program *)  
  let outer_cxt, reversed_list  =
    Ext_list.fold_left modules (cxt, []) 
      (fun (cxt, acc) (id,s)  ->
         let str, cxt = Ext_pp_scope.str_of_ident cxt id  in
         cxt, ((str,s) :: acc))
  in
  P.force_newline f ;    
  Ext_list.rev_iter reversed_list (fun (s,file) ->
      P.string f L.var;
      P.space f ;
      P.string f s ;
      P.space f ;
      P.string f L.eq;
      P.space f;
      P.string f require_lit;
      P.paren_group f 0 @@ (fun _ ->
          Js_dump_string.pp_string f file  );
      P.string f L.semi;
      P.newline f ;
    ) ;
  outer_cxt  

(** ES6 module style imports *)
let imports  cxt f (modules : (Ident.t * string) list ) =
  P.newline f ; 
  (* the context used to print the following program *)  
  let outer_cxt, reversed_list =
    Ext_list.fold_left modules (cxt, []) 
      (fun (cxt, acc) (id,s) ->
         let str, cxt = Ext_pp_scope.str_of_ident cxt id  in
         cxt, ((str,s) :: acc))
  in
  P.force_newline f ;    
  Ext_list.rev_iter reversed_list (fun (s,file) ->

      P.string f L.import;
      P.space f ;
      P.string f L.star ;
      P.space f ; (* import * as xx from 'xx*) 
      P.string f L.as_ ; 
      P.space f ; 
      P.string f s ; 
      P.space f ;
      P.string f L.from;
      P.space f;
      Js_dump_string.pp_string f file ;
      P.string f L.semi ;
      P.newline f ;
    ) ;
  outer_cxt

end
module Js_packages_state : sig 
#1 "js_packages_state.mli"
(* Copyright (C) 2017 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



val set_package_name : string -> unit 

val set_package_map : string -> unit 

val get_packages_info : 
  unit -> Js_packages_info.t 

val update_npm_package_path : 
  string -> unit   
end = struct
#1 "js_packages_state.ml"
(* Copyright (C) 2017 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


let packages_info  = ref Js_packages_info.empty



let set_package_name name =
  if Js_packages_info.is_empty !packages_info then 
      packages_info := Js_packages_info.from_name name
  else
    Ext_arg.bad_argf "duplicated flag for -bs-package-name"

let set_package_map module_name = 
    (* set_package_name name ; 
    let module_name = Ext_namespace.namespace_of_package_name name  in  *)
    Clflags.dont_record_crc_unit := Some module_name;
    Clflags.open_modules := 
      module_name::
      !Clflags.open_modules
      
let update_npm_package_path s  = 
  packages_info := 
    Js_packages_info.add_npm_package_path !packages_info s 

let get_packages_info () = !packages_info  
end
module Js_name_of_module_id : sig 
#1 "js_name_of_module_id.mli"
(* Copyright (C) 2017 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


(**
   generate the mdoule path so that it can be spliced here:
   {[
     var Xx = require("package/path/to/xx.js")
   ]}
   Note that it has to be consistent to how it is generated
*)  

val string_of_module_id : 
  Lam_module_ident.t ->
  output_dir:string ->
  Js_packages_info.module_system -> 
  string
end = struct
#1 "js_name_of_module_id.ml"
(* Copyright (C) 2017 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
(*
let (=)  (x : int) (y:float) = assert false 
*)

(* "xx/lib/ocaml/js.cmj" 
   Enhancement: This can be delegated to build system
*)
let runtime_package_path : string Lazy.t = 
  lazy (Filename.dirname (Filename.dirname 
    (Filename.dirname 
      (match Config_util.find_opt "js.cmj" with 
      | None -> assert false
      | Some x -> x))))

let (//) = Filename.concat 


let fix_path_for_windows : string -> string = 
  if Ext_sys.is_windows_or_cygwin then Ext_string.replace_backward_slash
  else fun s -> s 


let get_runtime_module_path 
    (dep_module_id : Lam_module_ident.t) 
    (current_package_info : Js_packages_info.t)
    module_system = 
  let current_info_query = 
    Js_packages_info.query_package_infos current_package_info
      module_system  in
  let js_file =  Ext_namespace.js_name_of_modulename dep_module_id.id.name Little_js in     
  match current_info_query with        
  | Package_not_found -> assert false
  | Package_script -> 
    Js_packages_info.runtime_package_path module_system js_file          
  | Package_found pkg -> 
    let  dep_path  = 
      "lib" // Js_packages_info.runtime_dir_of_module_system module_system in 
    if  Js_packages_info.is_runtime_package current_package_info then 
      Ext_path.node_rebase_file
        ~from:pkg.rel_path
        ~to_:dep_path 
        js_file
        (** TODO: we assume that both [x] and [path] could only be relative path
            which is guaranteed by [-bs-package-output]
        *)
    else  
      match module_system with 
      | NodeJS | Es6 -> 
        Js_packages_info.runtime_package_path module_system js_file              
      (** Note we did a post-processing when working on Windows *)
      | Es6_global 
        -> 
        (** lib/ocaml/xx.cmj --               
            HACKING: FIXME
            maybe we can caching relative package path calculation or employ package map *)
        (* assert false  *)
        Ext_path.rel_normalized_absolute_path              
          ~from:(
            Js_packages_info.get_output_dir 
              current_package_info
              ~package_dir:(Lazy.force Ext_path.package_dir)
              module_system )
          (Lazy.force runtime_package_path // dep_path // js_file)  



(* [output_dir] is decided by the command line argument *)
let string_of_module_id 
    (dep_module_id : Lam_module_ident.t) 
    ~(output_dir : string )
    (module_system : Js_packages_info.module_system)        
  : string =
  let current_package_info = Js_packages_state.get_packages_info ()  in 
  fix_path_for_windows (    
    match dep_module_id.kind  with 
    | External name -> name (* the literal string for external package *)
    (** This may not be enough, 
        1. For cross packages, we may need settle 
        down a single js package
        2. We may need es6 path for dead code elimination
         But frankly, very few JS packages have no dependency, 
         so having plugin may sound not that bad   
    *)
    | Runtime  -> 
      get_runtime_module_path dep_module_id current_package_info module_system
    | Ml  -> 
      let current_info_query = 
        Js_packages_info.query_package_infos 
          current_package_info
          module_system  
      in
      match Lam_compile_env.get_package_path_from_cmj dep_module_id with 
      | None -> 
        Bs_exception.error (Missing_ml_dependency dep_module_id.id.name)
      | Some (cmj_path, dep_package_info, little) -> 
        let js_file =  Ext_namespace.js_name_of_modulename dep_module_id.id.name little in 
        let dep_info_query =  
          Js_packages_info.query_package_infos dep_package_info module_system 
        in 
        match dep_info_query, current_info_query with
        | Package_not_found , _  -> 
          Bs_exception.error (Missing_ml_dependency dep_module_id.id.name)
        | Package_script , Package_found _  -> 
          Bs_exception.error (Dependency_script_module_dependent_not js_file)
        | (Package_script  | Package_found _ ), Package_not_found -> assert false

        | Package_found pkg, Package_script 
          ->    

          pkg.pkg_rel_path // js_file


        | Package_found dep_pkg,
          Package_found cur_pkg -> 
          if  Js_packages_info.same_package_by_name current_package_info  dep_package_info then 
            Ext_path.node_rebase_file
              ~from:cur_pkg.rel_path
              ~to_:dep_pkg.rel_path 
              js_file
              (** TODO: we assume that both [x] and [path] could only be relative path
                  which is guaranteed by [-bs-package-output]
              *)
          else  
            begin match module_system with 
              | NodeJS | Es6 -> 

                dep_pkg.pkg_rel_path // js_file

              (** Note we did a post-processing when working on Windows *)
              | Es6_global 
              -> 
                (** lib/ocaml/xx.cmj --               
                    HACKING: FIXME
                    maybe we can caching relative package path calculation or employ package map *)
                (* assert false  *)

                begin 
                  Ext_path.rel_normalized_absolute_path              
                    ~from:(
                      Js_packages_info.get_output_dir 
                        current_package_info
                        ~package_dir:(Lazy.force Ext_path.package_dir)
                        module_system 
                    )
                    ((Filename.dirname 
                        (Filename.dirname (Filename.dirname cmj_path))) // dep_pkg.rel_path // js_file)              
                end
            end
        | Package_script, Package_script 
          -> 
          match Config_util.find_opt js_file with 
          | Some file -> 
            let basename = Filename.basename file in 
            let dirname = Filename.dirname file in 
            Ext_path.node_rebase_file
              ~from:(
                Ext_path.absolute_cwd_path 
                output_dir)
              ~to_:(
                Ext_path.absolute_cwd_path 
                
                  dirname)
              basename  
          | None -> 
            Bs_exception.error (Js_not_found js_file))

  

(* Override it in browser *)


end
module Js_dump_program : sig 
#1 "js_dump_program.mli"
(* Copyright (C) 2017 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


(** only used for debugging purpose *)
val dump_program : J.program -> out_channel -> unit


val pp_deps_program :
  output_prefix:string ->
  Js_packages_info.module_system ->
  J.deps_program -> 
  Ext_pp.t -> 
  unit


val dump_deps_program :
  output_prefix:string ->
  Js_packages_info.module_system  -> 
  J.deps_program -> 
  out_channel -> 
  unit
  
end = struct
#1 "js_dump_program.ml"
(* Copyright (C) 2017 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

module P = Ext_pp
module L = Js_dump_lit 




let empty_explanation = 
  "/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */\n"

let program_is_empty (x : J.program) = 
  match x with 
  | {
    block = [];
    exports = [];
    export_set = _
  }  -> true 
  | _  -> false  

let deps_program_is_empty (x : J.deps_program) = 
  match x with 
  | { modules = [];
      program ;
      side_effect = None
    } -> program_is_empty program
  | _ -> false 

let program f cxt   ( x : J.program ) = 
  P.force_newline f;
  let cxt =  Js_dump.statement_list true cxt f x.block  in
  P.force_newline f;
  Js_dump_import_export.exports cxt f x.exports

let dump_program (x : J.program) oc = 
  ignore (program (P.from_channel oc)  Ext_pp_scope.empty  x )


let node_program ~output_dir f ( x : J.deps_program) = 
  P.string f L.strict_directive; 
  P.newline f ;
  let cxt = 
    Js_dump_import_export.requires 
      L.require
      Ext_pp_scope.empty
      f
      (Ext_list.map x.modules 
         (fun x -> 
            Lam_module_ident.id x,
            Js_name_of_module_id.string_of_module_id 
              x
              ~output_dir
              NodeJS 
         ))
  in
  program f cxt x.program  




let es6_program  ~output_dir fmt f (  x : J.deps_program) = 
  let cxt = 
    Js_dump_import_export.imports
      Ext_pp_scope.empty
      f
      (Ext_list.map x.modules
         (fun x -> 
            Lam_module_ident.id x,
            Js_name_of_module_id.string_of_module_id x ~output_dir
              fmt 
              ))
  in
  let () = P.force_newline f in 
  let cxt = Js_dump.statement_list true cxt f x.program.block in 
  let () = P.force_newline f in 
  Js_dump_import_export.es6_export cxt f x.program.exports



(** Make sure github linguist happy
    {[
      require('Linguist')
        Linguist::FileBlob.new('jscomp/test/test_u.js').generated?
    ]}
*)

let pp_deps_program
    ~output_prefix
    (kind : Js_packages_info.module_system )
    (program  : J.deps_program) (f : Ext_pp.t) = 
  if not !Js_config.no_version_header then 
    begin 
      P.string f Bs_version.header;
      P.newline f
    end ; 
  if deps_program_is_empty program then 
    P.string f empty_explanation 
    (* This is empty module, it won't be referred anywhere *)
  else 
    let output_dir = Filename.dirname output_prefix in   
    begin 
      ignore (match kind with 
          | Es6 | Es6_global -> 
            es6_program ~output_dir kind f program
          | NodeJS -> 
            node_program ~output_dir f program
        ) ;
      P.newline f ;
      P.string f (
        match program.side_effect with
        | None -> "/* No side effect */"
        | Some v -> Printf.sprintf "/* %s Not a pure module */" v );
      P.newline f;
      P.flush f ()
    end



let dump_deps_program
    ~output_prefix
    kind
    x 
    (oc : out_channel) = 
  pp_deps_program ~output_prefix  kind x (P.from_channel oc)

end
module Js_fold_basic : sig 
#1 "js_fold_basic.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)




(** A module to calculate hard dependency based on JS IR in module [J] *)

val depends_j : J.expression -> Ident_set.t -> Ident_set.t

(** TODO: {!Ordered_hash_set} for better ordering *)
val calculate_hard_dependencies : J.block -> Lam_module_ident.Hash_set.t

end = struct
#1 "js_fold_basic.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



class count_deps (add : Ident.t -> unit )  = 
  object(self)
    inherit  Js_fold.fold as super
    method! expression lam = 
      match lam.expression_desc with 
      | Fun (_, _, block, _) -> self#block block
      (** Call 
          actually depends on parameter, 
          since closure 
          {[
            n = n - 1
                    acc = () => n 
          ]}
          should be 

          {[
            acc = (function (n) {() => n} (n))
              n = n - 1
          ]}
      *)
      | _ -> super#expression lam
    method! ident x = add x ; self
  end

let add_lam_module_ident = Lam_module_ident.Hash_set.add
let create = Lam_module_ident.Hash_set.create
class count_hard_dependencies = 
  object(self : 'self_type)
    inherit  Js_fold.fold as super
    val hard_dependencies =  create 17
    method! vident vid = 
      match vid with 
      | Qualified (id,kind,_) ->
          add_lam_module_ident  hard_dependencies (Lam_module_ident.mk kind id); self
      | Id id -> self
    method! expression x : 'self_type  = 
      (* check {!Js_pass_scope} when making changes *)
      (match  Js_block_runtime.check_additional_id x with
       | Some id -> 
         add_lam_module_ident hard_dependencies
           (Lam_module_ident.of_runtime 
              id)
       | _ -> ());
      super#expression x
    method get_hard_dependencies = hard_dependencies
  end

let calculate_hard_dependencies block = 
  ((new count_hard_dependencies)#block block) # get_hard_dependencies

(*
   Given a set of [variables], count which variables  [lam] will depend on
   Invariant:
   [variables] are parameters which means immutable so that [Call] 
   will not depend [variables]

*)
let depends_j (lam : J.expression) (variables : Ident_set.t) = 
  let v = ref Ident_set.empty in
  let add id = 
    if Ident_set.mem variables id then 
      v := Ident_set.add !v id
  in
  ignore @@ (new count_deps add ) # expression lam ;
  !v


end
module Ident_map : sig 
#1 "ident_map.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

include Map_gen.S with type key = Ident.t
end = struct
#1 "ident_map.ml"

# 2 "ext/map.cppo.ml"
(* we don't create [map_poly], since some operations require raise an exception which carries [key] *)


  
# 16 "ext/map.cppo.ml"
  type key = Ident.t
  let compare_key = Ext_ident.compare

# 22 "ext/map.cppo.ml"
type 'a t = (key,'a) Map_gen.t
exception Duplicate_key of key 

let empty = Map_gen.empty 
let is_empty = Map_gen.is_empty
let iter = Map_gen.iter
let fold = Map_gen.fold
let for_all = Map_gen.for_all 
let exists = Map_gen.exists 
let singleton = Map_gen.singleton 
let cardinal = Map_gen.cardinal
let bindings = Map_gen.bindings
let to_sorted_array = Map_gen.to_sorted_array
let keys = Map_gen.keys
let choose = Map_gen.choose 
let partition = Map_gen.partition 
let filter = Map_gen.filter 
let map = Map_gen.map 
let mapi = Map_gen.mapi
let bal = Map_gen.bal 
let height = Map_gen.height 
let max_binding_exn = Map_gen.max_binding_exn
let min_binding_exn = Map_gen.min_binding_exn


let rec add (tree : _ Map_gen.t as 'a) x data  : 'a = match tree with 
  | Empty ->
    Node(Empty, x, data, Empty, 1)
  | Node(l, v, d, r, h) ->
    let c = compare_key x v in
    if c = 0 then
      Node(l, x, data, r, h)
    else if c < 0 then
      bal (add l x data ) v d r
    else
      bal l v d (add r x data )


let rec adjust (tree : _ Map_gen.t as 'a) x replace  : 'a = 
  match tree with 
  | Empty ->
    Node(Empty, x, replace None, Empty, 1)
  | Node(l, v, d, r, h) ->
    let c = compare_key x v in
    if c = 0 then
      Node(l, x, replace  (Some d) , r, h)
    else if c < 0 then
      bal (adjust l x  replace ) v d r
    else
      bal l v d (adjust r x  replace )


let rec find_exn (tree : _ Map_gen.t ) x = match tree with 
  | Empty ->
    raise Not_found
  | Node(l, v, d, r, _) ->
    let c = compare_key x v in
    if c = 0 then d
    else find_exn (if c < 0 then l else r) x

let rec find_opt (tree : _ Map_gen.t ) x = match tree with 
  | Empty -> None 
  | Node(l, v, d, r, _) ->
    let c = compare_key x v in
    if c = 0 then Some d
    else find_opt (if c < 0 then l else r) x

let rec find_default (tree : _ Map_gen.t ) x  default     = match tree with 
  | Empty -> default  
  | Node(l, v, d, r, _) ->
    let c = compare_key x v in
    if c = 0 then  d
    else find_default (if c < 0 then l else r) x default

let rec mem (tree : _ Map_gen.t )  x= match tree with 
  | Empty ->
    false
  | Node(l, v, d, r, _) ->
    let c = compare_key x v in
    c = 0 || mem (if c < 0 then l else r) x 

let rec remove (tree : _ Map_gen.t as 'a) x : 'a = match tree with 
  | Empty ->
    Empty
  | Node(l, v, d, r, h) ->
    let c = compare_key x v in
    if c = 0 then
      Map_gen.merge l r
    else if c < 0 then
      bal (remove l x) v d r
    else
      bal l v d (remove r x )


let rec split (tree : _ Map_gen.t as 'a) x : 'a * _ option * 'a  = match tree with 
  | Empty ->
    (Empty, None, Empty)
  | Node(l, v, d, r, _) ->
    let c = compare_key x v in
    if c = 0 then (l, Some d, r)
    else if c < 0 then
      let (ll, pres, rl) = split l x in (ll, pres, Map_gen.join rl v d r)
    else
      let (lr, pres, rr) = split r x in (Map_gen.join l v d lr, pres, rr)

let rec merge (s1 : _ Map_gen.t) (s2  : _ Map_gen.t) f  : _ Map_gen.t =
  match (s1, s2) with
  | (Empty, Empty) -> Empty
  | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 ->
    let (l2, d2, r2) = split s2 v1 in
    Map_gen.concat_or_join (merge l1 l2 f) v1 (f v1 (Some d1) d2) (merge r1 r2 f)
  | (_, Node (l2, v2, d2, r2, h2)) ->
    let (l1, d1, r1) = split s1 v2 in
    Map_gen.concat_or_join (merge l1 l2 f) v2 (f v2 d1 (Some d2)) (merge r1 r2 f)
  | _ ->
    assert false

let rec disjoint_merge  (s1 : _ Map_gen.t) (s2  : _ Map_gen.t) : _ Map_gen.t =
  match (s1, s2) with
  | (Empty, Empty) -> Empty
  | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 ->
    begin match split s2 v1 with 
    | l2, None, r2 -> 
      Map_gen.join (disjoint_merge  l1 l2) v1 d1 (disjoint_merge r1 r2)
    | _, Some _, _ ->
      raise (Duplicate_key  v1)
    end        
  | (_, Node (l2, v2, d2, r2, h2)) ->
    begin match  split s1 v2 with 
    | (l1, None, r1) -> 
      Map_gen.join (disjoint_merge  l1 l2) v2 d2 (disjoint_merge  r1 r2)
    | (_, Some _, _) -> 
      raise (Duplicate_key v2)
    end
  | _ ->
    assert false



let compare m1 m2 cmp = Map_gen.compare compare_key cmp m1 m2

let equal m1 m2 cmp = Map_gen.equal compare_key cmp m1 m2 

let add_list (xs : _ list ) init = 
  Ext_list.fold_left xs init (fun  acc (k,v) -> add acc k v )

let of_list xs = add_list xs empty

let of_array xs = 
  Ext_array.fold_left xs empty (fun acc (k,v) -> add acc k v ) 

end
module Ident_hashtbl : sig 
#1 "ident_hashtbl.mli"


include Hashtbl_gen.S with type key = Ident.t 



end = struct
#1 "ident_hashtbl.ml"
# 2 "ext/hashtbl.cppo.ml"
type key = Ident.t 
type 'a t = (key, 'a)  Hashtbl_gen.t 
let key_index (h : _ t ) (key : key) =
  (Bs_hash_stubs.hash_stamp_and_name  key.stamp key.name ) land (Array.length h.data - 1)
(* (Bs_hash_stubs.hash_string_int  key.name key.stamp ) land (Array.length h.data - 1) *)
let eq_key = Ext_ident.equal 

# 33 "ext/hashtbl.cppo.ml"
type ('a, 'b) bucketlist = ('a,'b) Hashtbl_gen.bucketlist
let create = Hashtbl_gen.create
let clear = Hashtbl_gen.clear
let reset = Hashtbl_gen.reset
let copy = Hashtbl_gen.copy
let iter = Hashtbl_gen.iter
let to_list = Hashtbl_gen.to_list
let fold = Hashtbl_gen.fold
let length = Hashtbl_gen.length
let stats = Hashtbl_gen.stats



let add (h : _ t) key info =
  let i = key_index h key in
  let h_data = h.data in   
  Array.unsafe_set h_data i (Cons(key, info, (Array.unsafe_get h_data i)));
  h.size <- h.size + 1;
  if h.size > Array.length h_data lsl 1 then Hashtbl_gen.resize key_index h

(* after upgrade to 4.04 we should provide an efficient [replace_or_init] *)
let modify_or_init (h : _ t) key modf default =
  let rec find_bucket (bucketlist : _ bucketlist)  =
    match bucketlist with
    | Cons(k,i,next) ->
      if eq_key k key then begin modf i; false end
      else find_bucket next 
    | Empty -> true in
  let i = key_index h key in 
  let h_data = h.data in 
  if find_bucket (Array.unsafe_get h_data i) then
    begin 
      Array.unsafe_set h_data i  (Cons(key,default (), Array.unsafe_get h_data i));
      h.size <- h.size + 1 ;
      if h.size > Array.length h_data lsl 1 then Hashtbl_gen.resize key_index h 
    end


let rec remove_bucket key (h : _ t) (bucketlist : _ bucketlist) : _ bucketlist = 
  match bucketlist with  
  | Empty ->
    Empty
  | Cons(k, i, next) ->
    if eq_key k key 
    then begin h.size <- h.size - 1; next end
    else Cons(k, i, remove_bucket key h next) 

let remove (h : _ t ) key =
  let i = key_index h key in
  let h_data = h.data in 
  let old_h_szie = h.size in 
  let new_bucket = remove_bucket key h (Array.unsafe_get h_data i) in  
  if old_h_szie <> h.size then 
    Array.unsafe_set h_data i  new_bucket

let rec find_rec key (bucketlist : _ bucketlist) = match bucketlist with  
  | Empty ->
    raise Not_found
  | Cons(k, d, rest) ->
    if eq_key key k then d else find_rec key rest

let find_exn (h : _ t) key =
  match Array.unsafe_get h.data (key_index h key) with
  | Empty -> raise Not_found
  | Cons(k1, d1, rest1) ->
    if eq_key key k1 then d1 else
      match rest1 with
      | Empty -> raise Not_found
      | Cons(k2, d2, rest2) ->
        if eq_key key k2 then d2 else
          match rest2 with
          | Empty -> raise Not_found
          | Cons(k3, d3, rest3) ->
            if eq_key key k3  then d3 else find_rec key rest3

let find_opt (h : _ t) key =
  Hashtbl_gen.small_bucket_opt eq_key key (Array.unsafe_get h.data (key_index h key))

let find_key_opt (h : _ t) key =
  Hashtbl_gen.small_bucket_key_opt eq_key key (Array.unsafe_get h.data (key_index h key))
  
let find_default (h : _ t) key default = 
  Hashtbl_gen.small_bucket_default eq_key key default (Array.unsafe_get h.data (key_index h key))
let find_all (h : _ t) key =
  let rec find_in_bucket (bucketlist : _ bucketlist) = match bucketlist with 
    | Empty ->
      []
    | Cons(k, d, rest) ->
      if eq_key k key 
      then d :: find_in_bucket rest
      else find_in_bucket rest in
  find_in_bucket (Array.unsafe_get h.data (key_index h key))

let replace h key info =
  let rec replace_bucket (bucketlist : _ bucketlist) : _ bucketlist = match bucketlist with 
    | Empty ->
      raise_notrace Not_found
    | Cons(k, i, next) ->
      if eq_key k key
      then Cons(key, info, next)
      else Cons(k, i, replace_bucket next) in
  let i = key_index h key in
  let h_data = h.data in 
  let l = Array.unsafe_get h_data i in
  try
    Array.unsafe_set h_data i  (replace_bucket l)
  with Not_found ->
    begin 
      Array.unsafe_set h_data i (Cons(key, info, l));
      h.size <- h.size + 1;
      if h.size > Array.length h_data lsl 1 then Hashtbl_gen.resize key_index h;
    end 

let mem (h : _ t) key =
  let rec mem_in_bucket (bucketlist : _ bucketlist) = match bucketlist with 
    | Empty ->
      false
    | Cons(k, d, rest) ->
      eq_key k key  || mem_in_bucket rest in
  mem_in_bucket (Array.unsafe_get h.data (key_index h key))


let of_list2 ks vs = 
  let len = List.length ks in 
  let map = create len in 
  List.iter2 (fun k v -> add map k v) ks vs ; 
  map


end
module Lam_id_kind : sig 
#1 "lam_id_kind.mli"
(* Copyright (C) Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


type rec_flag = 
  | Lam_rec 
  | Lam_non_rec

(* TODO: This may contain some closure environment,
     check how it will interact with dead code elimination
*)  
  | Lam_self_rec
  (* not inlining in this case *)
type function_id = {
  mutable arity : Lam_arity.t;
  lambda  : (Lam.t * rec_flag) option ;
}

type element = 
  | NA 
  | SimpleForm of Lam.t 

type boxed_nullable
  = 
  | Undefined 
  | Null 
  | Null_undefined


type t = 
  | Normal_optional of Lam.t
  | OptionalBlock of Lam.t * boxed_nullable
  | ImmutableBlock of element array
  | MutableBlock of element array
  | Constant of Lam_constant.t
  | Module of Ident.t
        (** TODO: static module vs first class module *)
  | FunctionId of function_id 
  | Exception 
  | Parameter
      (** For this case, it can help us determine whether it should be inlined or not *)

  | NA (** Not such information is associated with an identifier, it is immutable, 
           if you only associate a property to an identifier 
           we should consider [Lassign]
        *)
(** 
       {[ let v/2 =  Pnull_to_opt u]} 

       {[ let v/2 = Pnull_to_opt exp]}
       can be translated into 
       {[
         let v/1 = exp in 
         let v/2 =a Pnull_to_opt exp 
       ]}
       so that [Pfield v/2 0] will be replaced by [v/1], 
       [Lif(v/1)] will be translated into [Lif (v/2 === undefined )]
*)        



val print : Format.formatter -> t -> unit
end = struct
#1 "lam_id_kind.ml"
(* Copyright (C) Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

(** Keep track of which identifiers are aliased
  *)



type rec_flag = 
  | Lam_rec 
  | Lam_non_rec
  | Lam_self_rec 
    (* only a 
      single mutual 
      recursive function      
    *)


type function_id = {

  mutable arity : Lam_arity.t;
  (* TODO: This may contain some closure environment,
     check how it will interact with dead code elimination
  *)
  lambda  : (Lam.t * rec_flag) option ;
  
}

type element = 
  | NA 
  | SimpleForm of Lam.t 

type boxed_nullable
  = 
  | Undefined 
  | Null 
  | Null_undefined


type t = 
  | Normal_optional of Lam.t (* Some [x] *)
  | OptionalBlock of Lam.t * boxed_nullable
  | ImmutableBlock of element array 
  | MutableBlock of element array
  | Constant of Lam_constant.t
  | Module of Ident.t
        (** TODO: static module vs first class module *)
  | FunctionId of function_id 
  | Exception 
  | Parameter
      (** For this case, it can help us determine whether it should be inlined or not *)

  | NA (** Not such information is associated with an identifier, it is immutable, 
           if you only associate a property to an identifier 
           we should consider [Lassign]
        *)

let pp = Format.fprintf 

let print fmt (kind : t) = 
  match kind with 
  | ImmutableBlock (arr) -> 
    pp fmt "Imm(%d)" (Array.length arr)
  | Normal_optional _
    -> pp fmt "Some"
  | OptionalBlock(_, Null) 
    -> pp fmt "?Null"
  | OptionalBlock(_, Undefined)
    -> pp fmt "?Undefined"
  | OptionalBlock(_,Null_undefined)
    -> pp fmt "?Nullable"
  | MutableBlock (arr) ->     
    pp fmt "Mutable(%d)" (Array.length arr)
  | Constant _  ->
    pp fmt "Constant"
  | Module id -> 
    pp fmt "%s/%d" id.name id.stamp 
  | FunctionId _ -> 
    pp fmt "FunctionID"
  | Exception ->
    pp fmt "Exception" 
  | Parameter -> 
    pp fmt "Parameter"  
  | NA -> 
    pp fmt "NA"       
end
module Lam_stats : sig 
#1 "lam_stats.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Types defined for lambda analysis *)

type alias_tbl =  Ident.t Ident_hashtbl.t

(** Keep track of which identifiers are aliased
  *)



type ident_tbl = Lam_id_kind.t Ident_hashtbl.t 



type t = {
  env : Env.t;
  export_idents : Ident_set.t ;
  exports : Ident.t list ;
  alias_tbl : alias_tbl; 
  

  ident_tbl : ident_tbl;
  (** we don't need count arities for all identifiers, for identifiers
      for sure it's not a function, there is no need to count them
   *)


}


val print : Format.formatter -> t -> unit 
end = struct
#1 "lam_stats.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(* It can be useful for common sub expression elimination ? 
    if two lambdas are not equal, it should return false, other wise, 
    it might return true , this is only used as a way of optimizaton

    Use case :
    1. switch case -- common fall through
 *)

(* lambda pass for alpha conversion 
    and alias
    we need think about the order of the pass, might be the alias pass can be done 
    in the  beginning, when we do alpha conversion, we can instrument the table 
 *)



type alias_tbl =  Ident.t Ident_hashtbl.t



type ident_tbl = Lam_id_kind.t Ident_hashtbl.t 



type t = {
  env : Env.t;
  export_idents : Ident_set.t ;
  exports : Ident.t list ; (*It is kept since order matters? *)

  alias_tbl : alias_tbl; 
  ident_tbl : ident_tbl;
  (** we don't need count arities for all identifiers, for identifiers
      for sure it's not a function, there is no need to count them
  *)
  
}

let pp = Format.fprintf

let pp_alias_tbl fmt (tbl : alias_tbl) = 
  Ident_hashtbl.iter  tbl (fun k v -> pp fmt "@[%a -> %a@]@." Ident.print k Ident.print v)
  



let pp_ident_tbl fmt (ident_tbl : ident_tbl) = 
  Ident_hashtbl.iter ident_tbl (fun k v -> pp fmt "@[%a -> %a@]@." 
    Ident.print k Lam_id_kind.print v)
    

let print fmt (v : t) = 
    pp fmt "@[Alias table:@ @[%a@]@]" pp_alias_tbl v.alias_tbl ;    
    pp fmt "@[Ident table:@ @[%a@]@]" pp_ident_tbl v.ident_tbl ;
    pp fmt "@[exports:@ @[%a@]@]"
        (Format.pp_print_list 
            ~pp_sep:(fun fmt () -> pp fmt "@ ;")             
            Ident.print
        ) v.exports
end
module Lam_compile_context : sig 
#1 "lam_compile_context.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Type definition to keep track of compilation state 
  *)

(** Some types are defined in this module to help avoiding generating unnecessary symbols 
    (generating too many symbols will make the output code unreadable)
*)

type jbl_label = int 

type return_label = {
  id : Ident.t;
  label : J.label;
  params : Ident.t list;
  immutable_mask : bool array;
  mutable new_params : Ident.t Ident_map.t ;
  mutable triggered : bool
}



type value = {
    exit_id : Ident.t ; 
    bindings : Ident.t list ;
    order_id : int
  }

type let_kind = Lam_compat.let_kind

type return_type = 
  | ReturnFalse 
  | ReturnTrue of return_label option (* anonoymous function does not have identifier *)

(* delegate to the callee to generate expression 
      Invariant: [output] should return a trailing expression
  *)

type continuation = 
  | EffectCall of return_type
  | NeedValue of return_type
  | Declare of let_kind * J.ident (* bound value *)
  | Assign of J.ident 
  (** when use [Assign], var is not needed, since it's already declared 
      make sure all [Assign] are declared first, otherwise you are creating global variables
   *)



type jmp_table 

val continuation_is_return:
  continuation -> 
  bool 
type t = {
  continuation : continuation ;
  jmp_table : jmp_table;
  meta : Lam_stats.t ;
}

 val empty_handler_map : jmp_table  

type handler = {
  label : jbl_label ; 
  handler : Lam.t;
  bindings : Ident.t list; 
} 

val add_jmps :
    jmp_table -> 
    Ident.t ->
    handler list ->
    jmp_table * (jbl_label * Lam.t) list

val find_exn : jbl_label -> t -> value
end = struct
#1 "lam_compile_context.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)




type jbl_label = int 

module HandlerMap = Int_map
type value = {
  exit_id : Ident.t ;
  bindings : Ident.t list ;
  order_id : int
}

(* delegate to the callee to generate expression 
      Invariant: [output] should return a trailing expression
*)
type return_label = {
  id : Ident.t;
  label : J.label;
  params : Ident.t list;
  immutable_mask : bool array; 
  mutable new_params : Ident.t Ident_map.t;  
  mutable triggered : bool
}

type return_type = 
  | ReturnFalse 
  | ReturnTrue of return_label option 
  (* Note [return] does indicate it is a tail position in most cases
     however, in an exception handler, return may not be in tail position
     to fix #1701 we play a trick that (ReturnTrue None) 
     would never trigger tailcall, however, it preserves [return] 
     semantics
  *)
(* have a mutable field to notifiy it's actually triggered *)
(* anonoymous function does not have identifier *)

type let_kind = Lam_compat.let_kind

type continuation = 
  | EffectCall of return_type
  | NeedValue of return_type
  | Declare of let_kind * J.ident (* bound value *)
  | Assign of J.ident (* when use [Assign], var is not needed, since it's already declared  *)

type jmp_table =   value  HandlerMap.t

let continuation_is_return ( x : continuation) =  
  match x with 
  | EffectCall (ReturnTrue _) | NeedValue (ReturnTrue _) 
    -> true 
  | EffectCall ReturnFalse | NeedValue ReturnFalse 
  | Declare _ | Assign _
    -> false
    
type t = {
  continuation : continuation ;
  jmp_table : jmp_table;
  meta : Lam_stats.t ;
}

let empty_handler_map = HandlerMap.empty

type handler = {
  label : jbl_label ; 
  handler : Lam.t;
  bindings : Ident.t list; 
}

(* always keep key id positive, specifically no [0] generated *)
let add_jmps 
    (m  : jmp_table)
    exit_id code_table
    = 
  let map, handlers = 
    Ext_list.fold_left_with_offset 
      code_table (m,[]) 
      (HandlerMap.cardinal m + 1 ) 
      (fun { label; handler; bindings}
        (acc,handlers)        
        order_id 
        ->     
          HandlerMap.add acc label {exit_id; bindings; order_id } , 
          (order_id,handler)::handlers
      )   in 
  map, List.rev handlers


let find_exn i cxt = 
  Int_map.find_exn cxt.jmp_table i 
end
module Js_output : sig 
#1 "js_output.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** The intemediate output when compiling lambda into JS IR *)

(* Hongbo Should we rename this module js_of_lambda since it looks like it's
   containing that step
 *)


type finished =
  | True
  | False
  | Dummy (* Have no idea, so that when [++] is applied, always use the other *)

type t  =  {
  block : J.block ;
  value : J.expression option;
  output_finished : finished
}

(** When [finished] is true the block is already terminated,
    value does not make sense
    [finished]  default to false, which is conservative
*)

val make :
  ?value: J.expression ->
  ?output_finished:finished ->
  J.block ->
  t

val output_as_block :
  t ->
  J.block

val to_break_block :
  t ->
  J.block * bool
  (* the second argument is
    [true] means [break] needed

    When we know the output is gonna finished true
    we can reduce
    {[
      return xx ;
      break
    ]}
    into
    {[
      return ;
    ]}

  *)

val append_output: t -> t -> t


val dummy : t


val output_of_expression :
    Lam_compile_context.continuation ->
  
    J.expression -> (* compiled expression *)
    no_effects: bool Lazy.t -> 
    t

(** - needed for instrument [return] statement properly
*)
val output_of_block_and_expression :
    Lam_compile_context.continuation ->
    J.block ->
    J.expression ->
    t

val concat :
  t list ->
  t

val to_string :
  t ->
  string

end = struct
#1 "js_output.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



module E = Js_exp_make
module S = Js_stmt_make

type finished =
  | True
  | False
  | Dummy (* Have no idea, so that when [++] is applied, always use the other *)

type t  =  {
  block : J.block ;
  value : J.expression option;
  output_finished : finished ;

}

type continuation = Lam_compile_context.continuation

let make ?value ?(output_finished=False) block =
    { block ; value ; output_finished  }


let dummy =
    {value = None; block = []; output_finished = Dummy }

(** This can be merged with 
    {!output_of_block_and_expression} *)    
let output_of_expression
    (continuation : continuation)
    (exp : J.expression) ~(no_effects: bool Lazy.t)  =
  match continuation with
  | EffectCall  ReturnFalse ->
    if Lazy.force no_effects 
    then dummy
    else {block = []; value  = Some exp ; output_finished = False}
  | Declare (kind, n)->
    make [ S.define_variable ~kind n  exp]
  | Assign n  ->
    make [S.assign n exp ]
  | EffectCall (ReturnTrue _) ->
    make [S.return_stmt  exp] ~output_finished:True
  | NeedValue _ ->
    {block = []; value = Some exp; output_finished = False }


let output_of_block_and_expression
    (continuation : continuation)
    (block : J.block) exp : t =
  match continuation with
  | EffectCall ReturnFalse -> make block ~value:exp
  | EffectCall (ReturnTrue _) -> 
    make (Ext_list.append_one block (S.return_stmt exp)) ~output_finished:True
  | Declare (kind,n) ->
    make (Ext_list.append_one block (S.define_variable ~kind  n exp))
  | Assign n -> make (Ext_list.append_one block (S.assign n exp))
  | NeedValue _ ->
    make block ~value:exp



let block_with_opt_expr block (x : J.expression option) : J.block =
    match x with
    | None  -> block
    | Some x when Js_analyzer.no_side_effect_expression x -> block
    | Some x -> block @ [S.exp x ]

let opt_expr_with_block (x : J.expression option) block : J.block =
    match x with
    | None  -> block
    | Some x when Js_analyzer.no_side_effect_expression x -> block
    | Some x -> (S.exp x) :: block


let rec unnest_block (block : J.block) : J.block =
  match block with
  | [{statement_desc = Block block}] -> unnest_block block
  |  _ -> block

let output_as_block ( x : t)  : J.block =
  match x with
  | {block; value = opt; output_finished} ->
      let block = unnest_block block in
      if output_finished = True  then block
      else
        block_with_opt_expr block opt


let to_break_block (x : t) : J.block * bool =
    let block = unnest_block x.block in
    match x with
    | {output_finished = True;  _ } ->
        block, false
       (* value does not matter when [finished] is true
           TODO: check if it has side efects
        *)
    | { value =  None; output_finished } ->
        block,
        (match output_finished with | True -> false | (False | Dummy)  -> true  )

    | {value = Some _ as opt; _} ->
        block_with_opt_expr block opt, true


(** TODO: make everything expression make inlining hard, and code not readable?
           1. readability dpends on how we print the expression
           2. inlining needs generate symbols, which are statements, type mismatch
              we need capture [Exp e]

           can we call them all [statement]? statement has no value
        *)
(* | {block = [{statement_desc = Exp e }]; value = None ; _}, _ *)
(*   -> *)
(*     append { x with block = []; value = Some e} y *)
(* |  _ , {block = [{statement_desc = Exp e }]; value = None ; _} *)
(*   -> *)
(*     append x { y with block = []; value = Some e} *)

let rec append_output  (x : t ) (y : t ) : t =
    match x , y with (* ATTTENTION: should not optimize [opt_e2], it has to conform to [NeedValue]*)
    | { output_finished = True; _ }, _ -> x
    | _, {block = []; value= None; output_finished = Dummy } -> x
          (* finished = true --> value = E.undefined otherwise would throw*)
    | {block = []; value= None; _ }, y  -> y
    | {block = []; value= Some _; _}, {block = []; value= None; _ } -> x
    | {block = []; value =  Some e1; _}, ({block = []; value = Some e2; output_finished } as z) ->
        if Js_analyzer.no_side_effect_expression e1
        then z
            (* It would optimize cases like [module aliases]
                Bigarray, List
             *)
        else
          {block = []; value = Some (E.seq e1 e2); output_finished}
          (* {block = [S.exp e1]; value =  Some e2(\* (E.seq e1 e2) *\); finished} *)

    | {block = block1; value = opt_e1; _},  {block = block2; value = opt_e2; output_finished} ->
        let block1 = unnest_block block1 in
        make (block1 @ (opt_expr_with_block opt_e1  @@ unnest_block block2))
          ?value:opt_e2 ~output_finished:output_finished




(* Fold right is more efficient *)
let concat (xs : t list) : t =
  Ext_list.fold_right xs dummy (fun x acc -> append_output x  acc) 

let to_string x   =
  Js_dump.string_of_block (output_as_block x)

end
module Js_pass_debug : sig 
#1 "js_pass_debug.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






val dump : string  -> J.program -> J.program 

end = struct
#1 "js_pass_debug.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






let log_counter = ref 0 

let dump name (prog : J.program) =

    prog

 

end
module Js_map
= struct
#1 "js_map.ml"
(* BuckleScript compiler
 * Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, with linking exception;
 * either version 2.1 of the License, or (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 *)
(* Author: Hongbo Zhang  *)
(** GENERATED CODE, map visitor for JS IR  *)
open J
  
class virtual map =
  object ((o : 'self_type))
    method string : string -> string = o#unknown
    method option :
      'a 'a_out. ('self_type -> 'a -> 'a_out) -> 'a option -> 'a_out option =
      fun _f_a ->
        function | None -> None | Some _x -> let _x = _f_a o _x in Some _x
    method list :
      'a 'a_out. ('self_type -> 'a -> 'a_out) -> 'a list -> 'a_out list =
      fun _f_a ->
        function
        | [] -> []
        | _x :: _x_i1 ->
            let _x = _f_a o _x in
            let _x_i1 = o#list _f_a _x_i1 in _x :: _x_i1
    method int : int -> int = o#unknown
    method bool : bool -> bool = function | false -> false | true -> true
    method vident : vident -> vident =
      function
      | Id _x -> let _x = o#ident _x in Id _x
      | Qualified (_x, _x_i1, _x_i2) ->
          let _x = o#ident _x in
          let _x_i1 = o#kind _x_i1 in
          let _x_i2 = o#option (fun o -> o#string) _x_i2
          in Qualified (_x, _x_i1, _x_i2)
    method variable_declaration :
      variable_declaration -> variable_declaration =
      fun { ident = _x; value = _x_i1; property = _x_i2; ident_info = _x_i3 }
        ->
        let _x = o#ident _x in
        let _x_i1 = o#option (fun o -> o#expression) _x_i1 in
        let _x_i2 = o#property _x_i2 in
        let _x_i3 = o#ident_info _x_i3
        in
          { ident = _x; value = _x_i1; property = _x_i2; ident_info = _x_i3;
          }
    method tag_info : tag_info -> tag_info = o#unknown
    method statement_desc : statement_desc -> statement_desc =
      function
      | Block _x -> let _x = o#block _x in Block _x
      | Variable _x -> let _x = o#variable_declaration _x in Variable _x
      | Exp _x -> let _x = o#expression _x in Exp _x
      | If (_x, _x_i1, _x_i2) ->
          let _x = o#expression _x in
          let _x_i1 = o#block _x_i1 in
          let _x_i2 = o#option (fun o -> o#block) _x_i2
          in If (_x, _x_i1, _x_i2)
      | While (_x, _x_i1, _x_i2, _x_i3) ->
          let _x = o#option (fun o -> o#label) _x in
          let _x_i1 = o#expression _x_i1 in
          let _x_i2 = o#block _x_i2 in
          let _x_i3 = o#unknown _x_i3 in While (_x, _x_i1, _x_i2, _x_i3)
      | ForRange (_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5) ->
          let _x = o#option (fun o -> o#for_ident_expression) _x in
          let _x_i1 = o#finish_ident_expression _x_i1 in
          let _x_i2 = o#for_ident _x_i2 in
          let _x_i3 = o#for_direction _x_i3 in
          let _x_i4 = o#block _x_i4 in
          let _x_i5 = o#unknown _x_i5
          in ForRange (_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5)
      | Continue _x -> let _x = o#label _x in Continue _x
      | Break -> Break
      | Return _x -> let _x = o#return_expression _x in Return _x
      | Int_switch (_x, _x_i1, _x_i2) ->
          let _x = o#expression _x in
          let _x_i1 =
            o#list
              (fun o ->
                 (* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
                 (** Javascript IR
  
    It's a subset of Javascript AST specialized for OCaml lambda backend

    Note it's not exactly the same as Javascript, the AST itself follows lexical
    convention and [Block] is just a sequence of statements, which means it does 
    not introduce new scope
*)
                 (** object literal, if key is ident, in this case, it might be renamed by 
    Google Closure  optimizer,
    currently we always use quote
 *)
                 (* Since camldot is only available for toplevel module accessors,
       we don't need print  `A.length$2`
       just print `A.length` - it's guarateed to be unique
       
       when the third one is None, it means the whole module 

       TODO: 
       invariant, when [kind] is [Runtime], then we can ignore [ident], 
       since all [runtime] functions are unique, when do the 
       pattern match we can ignore the first one for simplicity
       for example       
       {[
         Qualified (_, Runtime, Some "caml_int_compare")         
       ]}       
     *)
                 (** where we use a trick [== null ] *) (* js true/false*)
                 (* https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Operators/Operator_Precedence 
     [typeof] is an operator     
  *)
                 (* !v *)
                 (* TODO: Add some primitives so that [js inliner] can do a better job *)
                 (* [int_op] will guarantee return [int32] bits 
     https://developer.mozilla.org/en/docs/Web/JavaScript/Reference/Operators/Bitwise_Operators  *)
                 (* | Int32_bin of int_op * expression * expression *)
                 (* f.apply(null,args) -- Fully applied guaranteed 
       TODO: once we know args's shape --
       if it's know at compile time, we can turn it into
       f(args[0], args[1], ... )
     *)
                 (* Analysze over J expression is hard since, 
        some primitive  call is translated 
        into a plain call, it's better to keep them
    *)
                 (* str.[i])*)
                 (* arr.(i)
       Invariant: 
       The second argument has to be type of [int],
       This can be constructed either in a static way [E.array_index_by_int] or a dynamic way 
       [E.array_index]
     *)
                 (* The third argument bool indicates whether we should 
       print it as 
       a["idd"] -- false
       or 
       a.idd  -- true
       There are several kinds of properties
       1. OCaml module dot (need to be escaped or not)
          All exported declarations have to be OCaml identifiers
       2. Javascript dot (need to be preserved/or using quote)
     *)
                 (* TODO: option remove *)
                 (* The first parameter by default is false, 
     it will be true when it's a method
  *)
                 (* A string is UTF-8 encoded, the string may contain
       escape sequences.
       The first argument is used to mark it is non-pure, please
       don't optimize it, since it does have side effec, 
       examples like "use asm;" and our compiler may generate "error;..." 
       which is better to leave it alone
       The last argument is passed from as `j` from `{j||j}`
     *)
                 (* It is escaped string, print delimited by '"'*)
                 (* literally raw JS code 
  *) (* [true] means [identity] *)
                 (* The third argument is [tag] , forth is [tag_info] *)
                 (* | Caml_uninitialized_obj of expression * expression *)
                 (* [tag] and [size] tailed  for [Obj.new_block] *)
                 (* For setter, it still return the value of expression, 
     we can not use 
     {[
       type 'a access = Get | Set of 'a
     ]}
     in another module, since it will break our code generator
     [Caml_block_tag] can return [undefined], 
     you have to use [E.tag] in a safe way     
  *)
                 (* | Caml_block_set_tag of expression * expression *)
                 (* | Caml_block_set_length of expression * expression *)
                 (* It will just fetch tag, to make it safe, when creating it, 
     we need apply "|0", we don't do it in the 
     last step since "|0" can potentially be optimized
  *)
                 (* pure*) (* pure *)
                 (* https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Statements/block
   block can be nested, specified in ES3 
 *)
                 (* Delay some units like [primitive] into JS layer ,
   benefit: better cross module inlining, and smaller IR size?
 *)
                 (* 
  [closure] captured loop mutable values in the outer loop

  check if it contains loop mutable values, happens in nested loop
  when closured, it's no longer loop mutable value. 
  which means the outer loop mutable value can not peek into the inner loop
  {[
  var i = f ();
  for(var finish = 32; i < finish; ++i){
  }
  ]}
  when [for_ident_expression] is [None], [var i] has to 
  be initialized outside, so 

  {[
  var i = f ()
  (function (xxx){
  for(var finish = 32; i < finish; ++i)
  }(..i))
  ]}
  This happens rare it's okay

  this is because [i] has to be initialized outside, if [j] 
  contains a block side effect
  TODO: create such example
*)
                 (* Since in OCaml, 
   
  [for i = 0 to k end do done ]
  k is only evaluated once , to encode this invariant in JS IR,
  make sure [ident] is defined in the first b

  TODO: currently we guarantee that [bound] was only 
  excecuted once, should encode this in AST level
*)
                 (* Can be simplified to keep the semantics of OCaml
   For (var i, e, ...){
     let  j = ... 
   }

   if [i] or [j] is captured inside closure

   for (var i , e, ...){
     (function (){
     })(i)
   }
*)
                 (* Single return is good for ininling..
   However, when you do tail-call optmization
   you loose the expression oriented semantics
   Block is useful for implementing goto
   {[
   xx:{
   break xx;
   }
   ]}
*)
                 (* Function declaration and Variable declaration  *)
                 (* check if it contains loop mutable values, happens in nested loop *)
                 (* only used when inline a fucntion *)
                 (* Here we need track back a bit ?, move Return to Function ...
                              Then we can only have one Return, which is not good *)
                 o#case_clause (fun o -> o#int))
              _x_i1 in
          let _x_i2 = o#option (fun o -> o#block) _x_i2
          in Int_switch (_x, _x_i1, _x_i2)
      | String_switch (_x, _x_i1, _x_i2) ->
          let _x = o#expression _x in
          let _x_i1 =
            o#list (fun o -> o#case_clause (fun o -> o#string)) _x_i1 in
          let _x_i2 = o#option (fun o -> o#block) _x_i2
          in String_switch (_x, _x_i1, _x_i2)
      | Throw _x -> let _x = o#expression _x in Throw _x
      | Try (_x, _x_i1, _x_i2) ->
          let _x = o#block _x in
          let _x_i1 =
            o#option
              (fun o (_x, _x_i1) ->
                 let _x = o#exception_ident _x in
                 let _x_i1 = o#block _x_i1 in (_x, _x_i1))
              _x_i1 in
          let _x_i2 = o#option (fun o -> o#block) _x_i2
          in Try (_x, _x_i1, _x_i2)
      | Debugger -> Debugger
    method statement : statement -> statement =
      fun { statement_desc = _x; comment = _x_i1 } ->
        let _x = o#statement_desc _x in
        let _x_i1 = o#option (fun o -> o#string) _x_i1
        in { statement_desc = _x; comment = _x_i1; }
    method return_expression : return_expression -> return_expression =
      fun { return_value = _x } ->
        let _x = o#expression _x in { return_value = _x; }
    method required_modules : required_modules -> required_modules =
      o#unknown
    method property_name : property_name -> property_name = o#unknown
    method property_map : property_map -> property_map =
      o#list
        (fun o (_x, _x_i1) ->
           let _x = o#property_name _x in
           let _x_i1 = o#expression _x_i1 in (_x, _x_i1))
    method property : property -> property = o#unknown
    method program : program -> program =
      fun { block = _x; exports = _x_i1; export_set = _x_i2 } ->
        let _x = o#block _x in
        let _x_i1 = o#exports _x_i1 in
        let _x_i2 = o#unknown _x_i2
        in { block = _x; exports = _x_i1; export_set = _x_i2; }
    method number : number -> number = o#unknown
    method mutable_flag : mutable_flag -> mutable_flag = o#unknown
    method length_object : length_object -> length_object = o#unknown
    method label : label -> label = o#string
    method kind : kind -> kind = o#unknown
    method jsint : jsint -> jsint = o#unknown
    method int_op : int_op -> int_op = o#unknown
    method ident_info : ident_info -> ident_info = o#unknown
    method ident : ident -> ident = o#unknown
    method for_ident_expression :
      for_ident_expression -> for_ident_expression = o#expression
    method for_ident : for_ident -> for_ident = o#ident
    method for_direction : for_direction -> for_direction = o#unknown
    method finish_ident_expression :
      finish_ident_expression -> finish_ident_expression = o#expression
    method expression_desc : expression_desc -> expression_desc =
      function
      | Length (_x, _x_i1) ->
          let _x = o#expression _x in
          let _x_i1 = o#length_object _x_i1 in Length (_x, _x_i1)
      | Char_of_int _x -> let _x = o#expression _x in Char_of_int _x
      | Char_to_int _x -> let _x = o#expression _x in Char_to_int _x
      | Is_null_or_undefined _x ->
          let _x = o#expression _x in Is_null_or_undefined _x
      | String_append (_x, _x_i1) ->
          let _x = o#expression _x in
          let _x_i1 = o#expression _x_i1 in String_append (_x, _x_i1)
      | Bool _x -> let _x = o#bool _x in Bool _x
      | Typeof _x -> let _x = o#expression _x in Typeof _x
      | Js_not _x -> let _x = o#expression _x in Js_not _x
      | Seq (_x, _x_i1) ->
          let _x = o#expression _x in
          let _x_i1 = o#expression _x_i1 in Seq (_x, _x_i1)
      | Cond (_x, _x_i1, _x_i2) ->
          let _x = o#expression _x in
          let _x_i1 = o#expression _x_i1 in
          let _x_i2 = o#expression _x_i2 in Cond (_x, _x_i1, _x_i2)
      | Bin (_x, _x_i1, _x_i2) ->
          let _x = o#binop _x in
          let _x_i1 = o#expression _x_i1 in
          let _x_i2 = o#expression _x_i2 in Bin (_x, _x_i1, _x_i2)
      | FlatCall (_x, _x_i1) ->
          let _x = o#expression _x in
          let _x_i1 = o#expression _x_i1 in FlatCall (_x, _x_i1)
      | Call (_x, _x_i1, _x_i2) ->
          let _x = o#expression _x in
          let _x_i1 = o#list (fun o -> o#expression) _x_i1 in
          let _x_i2 = o#unknown _x_i2 in Call (_x, _x_i1, _x_i2)
      | String_index (_x, _x_i1) ->
          let _x = o#expression _x in
          let _x_i1 = o#expression _x_i1 in String_index (_x, _x_i1)
      | Array_index (_x, _x_i1) ->
          let _x = o#expression _x in
          let _x_i1 = o#expression _x_i1 in Array_index (_x, _x_i1)
      | Static_index (_x, _x_i1) ->
          let _x = o#expression _x in
          let _x_i1 = o#string _x_i1 in Static_index (_x, _x_i1)
      | New (_x, _x_i1) ->
          let _x = o#expression _x in
          let _x_i1 =
            o#option (fun o -> o#list (fun o -> o#expression)) _x_i1
          in New (_x, _x_i1)
      | Var _x -> let _x = o#vident _x in Var _x
      | Fun (_x, _x_i1, _x_i2, _x_i3) ->
          let _x = o#bool _x in
          let _x_i1 = o#list (fun o -> o#ident) _x_i1 in
          let _x_i2 = o#block _x_i2 in
          let _x_i3 = o#unknown _x_i3 in Fun (_x, _x_i1, _x_i2, _x_i3)
      | Str (_x, _x_i1) ->
          let _x = o#bool _x in let _x_i1 = o#string _x_i1 in Str (_x, _x_i1)
      | Unicode _x -> let _x = o#string _x in Unicode _x
      | Raw_js_code (_x, _x_i1) ->
          let _x = o#string _x in
          let _x_i1 = o#code_info _x_i1 in Raw_js_code (_x, _x_i1)
      | Raw_js_function (_x, _x_i1) ->
          let _x = o#string _x in
          let _x_i1 = o#list (fun o -> o#string) _x_i1
          in Raw_js_function (_x, _x_i1)
      | Array (_x, _x_i1) ->
          let _x = o#list (fun o -> o#expression) _x in
          let _x_i1 = o#mutable_flag _x_i1 in Array (_x, _x_i1)
      | Optional_block (_x, _x_i1) ->
          let _x = o#expression _x in
          let _x_i1 = o#bool _x_i1 in Optional_block (_x, _x_i1)
      | Caml_block (_x, _x_i1, _x_i2, _x_i3) ->
          let _x = o#list (fun o -> o#expression) _x in
          let _x_i1 = o#mutable_flag _x_i1 in
          let _x_i2 = o#expression _x_i2 in
          let _x_i3 = o#tag_info _x_i3
          in Caml_block (_x, _x_i1, _x_i2, _x_i3)
      | Caml_block_tag _x -> let _x = o#expression _x in Caml_block_tag _x
      | Number _x -> let _x = o#number _x in Number _x
      | Object _x -> let _x = o#property_map _x in Object _x
      | Undefined -> Undefined
      | Null -> Null
    method expression : expression -> expression =
      fun { expression_desc = _x; comment = _x_i1 } ->
        let _x = o#expression_desc _x in
        let _x_i1 = o#option (fun o -> o#string) _x_i1
        in { expression_desc = _x; comment = _x_i1; }
    method exports : exports -> exports = o#unknown
    method exception_ident : exception_ident -> exception_ident = o#ident
    method deps_program : deps_program -> deps_program =
      fun { program = _x; modules = _x_i1; side_effect = _x_i2 } ->
        let _x = o#program _x in
        let _x_i1 = o#required_modules _x_i1 in
        let _x_i2 = o#option (fun o -> o#string) _x_i2
        in { program = _x; modules = _x_i1; side_effect = _x_i2; }
    method code_info : code_info -> code_info = o#unknown
    method case_clause :
      (* since in ocaml, it's expression oriented langauge, [return] in
    general has no jumps, it only happens when we do 
    tailcall conversion, in that case there is a jump.
    However, currently  a single [break] is good to cover
    our compilation strategy 

    Attention: we should not insert [break] arbitrarily, otherwise 
    it would break the semantics
    A more robust signature would be 
    {[ goto : label option ; ]}
  *)
        'a 'a_out.
        ('self_type -> 'a -> 'a_out) -> 'a case_clause -> 'a_out case_clause =
      fun _f_a { switch_case = _x; switch_body = _x_i1; should_break = _x_i2
        } ->
        let _x = _f_a o _x in
        let _x_i1 = o#block _x_i1 in
        let _x_i2 = o#bool _x_i2
        in { switch_case = _x; switch_body = _x_i1; should_break = _x_i2; }
    method block : block -> block = (* true means break *)
      (* TODO: For efficency: block should not be a list, it should be able to 
   be concatenated in both ways 
 *)
      o#list (fun o -> o#statement)
    method binop : binop -> binop = o#unknown
    method unknown : 'a. 'a -> 'a = fun x -> x
  end
  


end
module Js_pass_flatten : sig 
#1 "js_pass_flatten.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** A pass converting nested js statement into a flatten visual appearance 

    Note this module is used to convert some nested expressions to flat statements, 
    in general, it's more human readable, and since it generate flat statements, we can spot
    some inline opportunities for the produced statemetns, 
    (inline) expressions inside a nested expression would generate ugly code.

    Since we are aiming to flatten expressions, we should avoid some smart constructors in {!Js_helper}, 
    it  tries to spit out expression istead of statements if it can
*)

val program : J.program -> J.program

end = struct
#1 "js_pass_flatten.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






(* open recursion is hard
  Take cond for example:
  CHECK? Trick semantics difference 
  super#statement (S.if_ a ([ (\* self#statement *\) (S.exp b) ]) 
     ~else_:([self#statement (S.exp c)]) 
                 ) 
*)
module E = Js_exp_make
module S = Js_stmt_make 

let flatten_map = 
  object(self)
    inherit Js_map.map as super
    method! statement x = 
      match x.statement_desc with 
      |  Exp ({expression_desc = Seq _; _} as v) ->
          S.block ( List.rev_map self#statement (Js_analyzer.rev_flatten_seq v ))
      |  Exp ({expression_desc = Cond(a,b,c); comment} ) -> 
          { statement_desc = If (a, [ self#statement (S.exp b)],  
                                 Some [ self#statement (S.exp c)]); comment}

      |  Exp ({expression_desc = Bin(Eq, a, ({expression_desc = Seq _; _ } as v)); _} )
        ->
          let block = Js_analyzer.rev_flatten_seq v in
          begin match block with
          | {statement_desc = Exp last_one ; _} :: rest_rev
            ->  
              S.block (Ext_list.rev_map_append  rest_rev 
                [self#statement @@ S.exp (E.assign a  last_one)]
                self#statement
              )
                (* TODO: here we introduce a block, should avoid it *)
              (* super#statement *)
              (*   (S.block (List.rev_append rest_rev [S.exp (E.assign a  last_one)])) *)
          | _ ->
              assert false
          end
      | Return ( {return_value = {expression_desc = Cond (a,b,c);  comment}}) 
        -> 
          { statement_desc = If (a, [self#statement (S.return_stmt b)],  
                                 Some [ self#statement (S.return_stmt c)]); comment}

      | Return ({return_value = {expression_desc = Seq _; _} as v}) ->
          let block = Js_analyzer.rev_flatten_seq v  in
          begin match block with
          | {statement_desc = Exp last_one ; _} :: rest_rev
            ->  
              super#statement 
                (S.block (Ext_list.rev_map_append rest_rev [S.return_stmt last_one] (self#statement)))
          | _ -> assert false
          end
      | Block [x]
          -> 
            self#statement x 
      | _ -> super#statement x 

    method! block b =
      match b with
      | {statement_desc = Block bs } :: rest ->
          self#block ( bs @  rest)
      | x::rest  
        -> 
          self#statement x :: self#block rest
      | [] -> []
  end

let program ( x : J.program) = flatten_map # program x 

end
module Js_pass_flatten_and_mark_dead : sig 
#1 "js_pass_flatten_and_mark_dead.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** A pass to mark some declarations in JS IR as dead code *)

val program :  J.program -> J.program

end = struct
#1 "js_pass_flatten_and_mark_dead.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








module E = Js_exp_make
module S = Js_stmt_make

class count  var = object (self : 'self)
  val mutable appears = 0
  inherit Js_fold.fold as super
  method! ident  x =
    (if Ident.same x var then
      appears <- appears + 1); 
    self
  method get_appears = appears 
end

(* rewrite return for current block, but don't go into
   inner function, mostly for inlinning
 *)
class rewrite_return ?return_value ()=
  let mk_return  = 
    match return_value with 
    | None -> fun e -> S.exp e 
    | Some ident -> fun e -> 
      S.define_variable ~kind:Variable ident e in
  object (self : 'self)
    inherit Js_map.map as super
    method! statement x =
      match x.statement_desc with 
      | Return {return_value = e} -> 
          mk_return e 
      | _ -> super#statement x 
    method! expression x = x (* don't go inside *)
  end  

(* 
    HERE we are using an object , so make sure to clean it up, 
    remove stale cache
 *)
let mark_dead = object (self)
  inherit Js_fold.fold as super
  val mutable ident_use_stats : [`Info of J.ident_info | `Recursive] Ident_hashtbl.t
      = Ident_hashtbl.create 17
  
  val mutable export_set : Ident_set.t = Ident_set.empty    

  method mark_not_dead ident =
    match Ident_hashtbl.find_opt ident_use_stats ident with
    | None -> (* First time *)
        Ident_hashtbl.add ident_use_stats ident `Recursive 
        (* recursive identifiers *)
    | Some `Recursive
      -> ()
    | Some (`Info x) ->  Js_op_util.update_used_stats x Used 

  method scan b ident (ident_info : J.ident_info) = 
    let is_export = Ident_set.mem export_set ident in
    let () = 
      if is_export (* && false *) then 
        Js_op_util.update_used_stats ident_info Exported 
    in
    match Ident_hashtbl.find_opt ident_use_stats ident with
    | Some (`Recursive) -> 
        Js_op_util.update_used_stats ident_info Used; 
        Ident_hashtbl.replace ident_use_stats ident (`Info ident_info)
    | Some (`Info _) ->  
      (** check [camlinternlFormat,box_type] inlined twice 
          FIXME: seems we have redeclared identifiers
      *)
      ()
    (* assert false *)
    | None ->  (* First time *)
        Ident_hashtbl.add ident_use_stats ident (`Info ident_info);
        Js_op_util.update_used_stats ident_info 
          (if b then Scanning_pure else Scanning_non_pure)
  method promote_dead = 
    Ident_hashtbl.iter ident_use_stats (fun _id (info : [`Info of J.ident_info  | `Recursive]) ->
      match info  with 
      | `Info ({used_stats = Scanning_pure} as info) -> 
          Js_op_util.update_used_stats info Dead_pure
      | `Info ({used_stats = Scanning_non_pure} as info) -> 
          Js_op_util.update_used_stats info Dead_non_pure
      | _ -> ())
      ;
    Ident_hashtbl.clear ident_use_stats (* clear to make it re-entrant *)

  method! program x = 
    export_set <- x.export_set ; 
    super#program x 

  method! ident x = 
    self#mark_not_dead x ; self 

  method! variable_declaration vd =  
    match vd with 
    | { ident_info = {used_stats = Dead_pure } ; _}
      -> self
    | { ident_info = {used_stats = Dead_non_pure } ; value } -> 
      begin match value with
      | None -> self
      | Some x -> self#expression x 
      end
    | {ident; ident_info ; value ; _} -> 
      let pure = 
        match value with 
        | None  -> false 
        | Some x -> ignore (self#expression x); Js_analyzer.no_side_effect_expression x in
      self#scan pure ident ident_info; self
end

let mark_dead_code js = 
  let _ =  (mark_dead#program js) in 
  mark_dead#promote_dead;
  js
        
(*
   when we do optmizations, we might need track it will break invariant 
   of other optimizations, especially for [mutable] meta data, 
   for example, this pass will break [closure] information, 
   it should be done before closure pass (even it does not use closure information)

   Take away, it is really hard to change the code while collecting some information..
   we should always collect info in a single pass

   Note that, we should avoid reuse object, i.e,
   {[
     let v = 
       object 
       end      
   ]}   
   Since user may use `bsc.exe -c xx.ml xy.ml xz.ml` and we need clean up state
 *)

(** we can do here, however, we should 
    be careful that it can only be done 
    when it's accessed once and the array is not escaped,
    otherwise, we redo the computation,
    or even better, we re-order

    {[
      var match = [/* tuple */0,Pervasives.string_of_int(f(1,2,3)),f3(2),arr];

          var a = match[1];

            var b = match[2];

    ]}

    --->

    {[
      var match$1 = Pervasives.string_of_int(f(1,2,3));
          var match$2 = f3(2);
              var match = [/* tuple */0,match$1,match$2,arr];
                  var a = match$1;
                    var b = match$2;
                      var arr = arr; 
    ]}

    --> 
    since match$1 (after match is eliminated) is only called once 
    {[
      var a = Pervasives.string_of_int(f(1,2,3));
      var b = f3(2);
      var arr = arr; 
    ]}

*) 
let subst_map () = object (self)
  inherit Js_map.map as super

  val mutable substitution :  J.expression Ident_hashtbl.t= Ident_hashtbl.create 17 

  method get_substitution = substitution

  method add_substitue (ident : Ident.t) (e:J.expression) = 
    Ident_hashtbl.replace  substitution ident e

  method! statement v = 
    match v.statement_desc with 
    | Variable ({ident; ident_info = {used_stats = Dead_pure } ; _}) -> 
      {v with statement_desc = Block []}
    | Variable ({ident; ident_info = {used_stats = Dead_non_pure } ; value = None}) -> 
      {v with statement_desc = Block []}
    | Variable ({ident; ident_info = {used_stats = Dead_non_pure } ; value = Some x}) -> 
      {v with statement_desc =  (Exp x)}

    | Variable ({ ident ; 
                  property = (Strict | StrictOpt | Alias);
                  value = Some (
                      {expression_desc = (Caml_block ( _:: _ :: _ as ls, Immutable, tag, tag_info) 
                                         )} as block)
                } as variable) -> 
      (** If we do this, we should prevent incorrect inlning to inline it into an array :) 
          do it only when block size is larger than one
      *)
      let (_, e, bindings) = 
        Ext_list.fold_left ls (0, [], []) (fun (i,e, acc) x -> 
             match x.expression_desc with 
             | Var _ | Number _ | Str _ | J.Bool _ | Undefined
               ->  (* TODO: check the optimization *)
               (i + 1, x :: e, acc)
             | _ ->                
               (* tradeoff, 
                   when the block is small, it does not make 
                   sense too much -- 
                   bottomline, when the block size is one, no need to do 
                   this
               *)
               let v' = self#expression x in 
               let match_id =
                 Ext_ident.create
                   (Printf.sprintf "%s_%03d"
                      ident.name i) in
               (i + 1, E.var match_id :: e, (match_id, v') :: acc))  in
      let e = 
        {block with 
         expression_desc = 
           Caml_block(List.rev e, Immutable, tag, tag_info)
        } in
      let () = self#add_substitue ident e in
      (* let bindings =  !bindings in *)
      let original_statement = 
        { v with 
          statement_desc = Variable {variable with value =  Some   e }
        } in
      begin match bindings with 
        | [] -> 
          original_statement
        | _ ->  
          (* self#add_substitue ident e ; *)
          S.block @@
          (Ext_list.rev_map_append bindings [original_statement]
            (fun (id,v) -> 
               S.define_variable ~kind:Strict id v)  )
      end
    | _ -> super#statement v 

  method! expression x =
    match x.expression_desc with 
    | Array_index ({expression_desc = Var (Id (id))}, 
              {expression_desc = Number (Int {i; _})}) -> 
      (match Ident_hashtbl.find_opt self#get_substitution id with 
       | Some {expression_desc = Caml_block (ls, Immutable, _, _) } 
         -> 
         (* user program can be wrong, we should not 
            turn a runtime crash into compile time crash : )
         *)          
         (match Ext_list.nth_opt ls (Int32.to_int i) with 
          | Some ({expression_desc = J.Var _ | Number _ | Str _ | Undefined} as x)
            -> x 
          | None | Some _ -> 
            super#expression x )          
       | Some _ | None -> super#expression x )
      
    | _ -> super#expression x
end 

(* Top down or bottom up ?*)
(* A pass to support nullary argument in JS 
    Nullary information can be done in one pass, 
    there is no need to add another pass
 *)

let program  (js : J.program) = 
  js 
  |> (subst_map () )#program
  |> mark_dead_code
  (* |> mark_dead_code *)
  (* mark dead code twice does have effect in some cases, however, we disabled it 
    since the benefit is not obvious
   *)

end
module Js_pass_scope : sig 
#1 "js_pass_scope.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** A module to do scope analysis over JS IR *)

val program : J.program ->  Ident_set.t

end = struct
#1 "js_pass_scope.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








let _l idents = 
  Ext_log.err __LOC__ "hey .. %s@." 
    (String.concat "," @@ Ext_list.map idents (fun  i -> i.Ident.name ) ) 

(* 

    Base line 
    {[
     for i = 1 to n do (function (i){...}(i))
     done
       (* This is okay, since all ocaml follow the lexical scope, 
          for generrated code too (* TODO: check *)
        *)
    ]}

  For nested loops 
  {[
   for i = 0 to n do 
     for j = 0 to n do 
       arrr.(j)<- ()=>{ i}
     done
   done
 ]}
    Three kind of variables  (defined in the loop scope)
    1. loop mutable variables 
       As long as variables change per iteration, defined in a loop (in the same loop)
        and captured by a closure
       the loop, iff  be lexically scoped 
       Tailcall parameters are considered defined inside the loop
    - unless it's defined 
       outside all the loops - note that for nested loops, if it's defined 
       in the outerloop and captured by the inner loop, 
       it still has to be lexically scoped. 

       How do we detect whether it is loop invariant or not 
       - depend on loop variant 
       - depend on mutuable valuse
       - non pure (function call)

       so we need collect mutable variables 
       1. from lambda + loop (for/i) + tailcall params
       2. defined in the loop and can not determine it is invariant  
          in such cases we can determine it's immutable
          1. const 
          2. only depend on immutable values and no function call?

    ## The following would take advantage of nested loops 
    2. loop invariant observable varaibles 
        {[ 
         var x = (console.log(3), 32)
        ]}
    3. loop invariant non-observable variables 

    Invariant: 
    loop invariant (observable or not) variables can not depend on 
    loop mutable values so that once we detect loop Invariant variables 
    all its dependency are loop invariant as well, so we can do loop 
    Invariant code motion.
    
    TODO:
    loop invariant can be layered, it will be loop invariant 
    in the inner layer while loop variant in the outer layer.
    {[
    for i = 0 to 10 do 
      for j  = 10 do 
        let  k0 = param * 100 in (* loop invariant *)
        let  k1 = i * i in (* inner loop invariant, loop variant *)
        let  k2 = j * i in (* variant *)
        ..
      done 
    done 
    ]}
*)

let scope_pass  = 
  object(self)
    inherit Js_fold.fold as super

    val  defined_idents = Ident_set.empty 
        
    (** [used_idents] 
        does not contain locally defined idents *)
    val  used_idents = Ident_set.empty 
    (** we need collect mutable values and loop defined varaibles *)    
    val loop_mutable_values = Ident_set.empty 

    val mutable_values = Ident_set.empty      

    val closured_idents = Ident_set.empty 

    (** check if in loop or not *)    
    val in_loop = false 

    method get_in_loop = in_loop

    method get_defined_idents = defined_idents

    method get_used_idents = used_idents

    method get_loop_mutable_values = loop_mutable_values 

    method get_mutable_values = mutable_values 

    method get_closured_idents = closured_idents 

    method with_in_loop b = 
      if b = self#get_in_loop then self
      else {< in_loop = b >}
     (* Since it's loop mutable variable, for sure
         it is mutable variable
         *)       
    method with_loop_mutable_values b = 
      {< loop_mutable_values =  b >}

    method add_loop_mutable_variable id = 
      {< loop_mutable_values = Ident_set.add loop_mutable_values id;
         mutable_values = Ident_set.add mutable_values id 
         >}

    method add_mutable_variable id = 
      {< mutable_values = Ident_set.add mutable_values id >}

    method add_defined_ident ident = 
      {< defined_idents = Ident_set.add defined_idents ident >} 
    method add_used_ident ident = 
      {< used_idents = Ident_set.add used_idents ident >}
    method! expression x = 
      match x.expression_desc with 
      | Fun (_method_, params, block , env) -> 
        (* Function is the only place to introduce a new scope in 
            ES5
            TODO: check 
            {[ try .. catch(exn) {.. }]}
            what's the scope of exn
        *)
        (* Note that [used_idents] is not complete
            it ignores some locally defined idents *)
        let param_set = Ident_set.of_list params in
        let obj =  {<defined_idents = Ident_set.empty;
                     (** pass [empty]
                         so that we can check which parameter was actually used *)
                     used_idents = Ident_set.empty ;
                     in_loop = false;
                     loop_mutable_values = Ident_set.empty;
                     mutable_values = Ident_set.of_list (Js_fun_env.get_mutable_params params env) ; 
                     closured_idents = Ident_set.empty; (* think about nested function*)
                   >} # block block in
        let defined_idents', used_idents' = 
          obj#get_defined_idents, obj#get_used_idents  in
        (* mark which param is used *)
        params |> List.iteri 
          (fun i v -> 
             if not (Ident_set.mem used_idents' v) then 
               Js_fun_env.mark_unused env i) ;
        let closured_idents' =  (* pass param_set down *)
          Ident_set.(diff used_idents' (union defined_idents' param_set )) in

        (* Noe that we don't know which variables are exactly mutable yet ..
           due to the recursive thing
         *)
        Js_fun_env.set_unbounded env closured_idents'   ; 
        let lexical_scopes = Ident_set.(inter closured_idents' self#get_loop_mutable_values) in
        Js_fun_env.set_lexical_scope env lexical_scopes;
        (* tailcall , note that these varibles are used in another pass *)
        {< used_idents = 
             Ident_set.union used_idents closured_idents' ;
           (* There is a bug in ocaml -dsource*)           
           closured_idents = Ident_set.union closured_idents closured_idents'
        >}
      | _ -> 
        let obj = super#expression x in 
        match Js_block_runtime.check_additional_id x with
        | None -> obj
        | Some id -> 
          obj#add_used_ident id                
        (* TODO: most variables are immutable *)

    method! variable_declaration x = 
      match x with
      | { ident ; value; property  }  -> 
        let obj = 
          (match self#get_in_loop, property with 
           | true, Variable 
             -> 
             self#add_loop_mutable_variable ident 
           | true, (Strict | StrictOpt | Alias)
           (* Not real true immutable in javascript 
               since it's in the loop 

               TODO: we should also 
           *)
             -> 
             begin match value with 
               | None -> self#add_loop_mutable_variable ident
               (* TODO: Check why assertion failure *)
               (* self#add_loop_mutable_variable ident *) (* assert false *)
               | Some x
                 ->
                 (** 
                     when x is an immediate immutable value, 
                     (like integer .. )
                     not a reference, it should be Immutable
                     or string, 
                     type system might help here
                     TODO:
                 *)
                 match x.expression_desc with
                 | Fun _  | Number _ | Str _ 
                   -> self 
                 | _ -> 
                   (* if Ident_set.(is_empty @@ *)
                   (*   inter self#get_mutable_values  *)
                   (*     ( ({<  *)
                   (*         defined_idents = Ident_set.empty;  *)
                   (*         used_idents = Ident_set.empty; *)
                   (*         >} # expression x) # get_used_idents)) then *)
                   (*   (\* FIXME: still need to check expression is pure or not*\) *)
                   (*   self *)
                   (* else  *)
                   self#add_loop_mutable_variable ident
             end
           | false, Variable
             -> 
             self#add_mutable_variable ident      
           | false, (Strict | StrictOpt | Alias)
             -> self
          )#add_defined_ident ident
        in
        begin match value with 
          | None -> obj 
          | Some x -> obj # expression x  
        end 

        
    method! statement x = 
      match x.statement_desc with 
      | ForRange  (_,_, loop_id, _,_,a_env) as y -> (* TODO: simplify definition of For *)
          let obj = 
            {< in_loop = true ;
               loop_mutable_values = Ident_set.singleton loop_id ;
               used_idents = Ident_set.empty; (* TODO: if unused, can we generate better code? *)
               defined_idents = Ident_set.singleton loop_id ;
               closured_idents = Ident_set.empty (* Think about nested for blocks *)
                 (* Invariant: Finish id is never used *)
                 >}
              # statement_desc y in

          let defined_idents', used_idents', closured_idents' = 
            obj#get_defined_idents, obj#get_used_idents, obj#get_closured_idents in


          let lexical_scope =  Ident_set.(inter (diff closured_idents' defined_idents') self#get_loop_mutable_values) in
          let () = Js_closure.set_lexical_scope a_env lexical_scope in
          (* set scope *)
          {< used_idents = Ident_set.union used_idents used_idents';
             (* walk around ocaml -dsource bug 
                {[ 
                  Ident_set.(union used_idents used_idents)                  
                ]}                
             *)             
             defined_idents = Ident_set.union defined_idents defined_idents';
             (* TODO: if we our generated code also follow lexical scope,
                this is not necessary ;
                [varaibles] are mutable or not is known at definition
              *)
             closured_idents = Ident_set.union closured_idents lexical_scope
             >}

      | While (_label,pred,body, _env) ->  
          (((self#expression pred)#with_in_loop true) # block  body )
            #with_in_loop (self#get_in_loop)
      | _ -> 
          super#statement x 

    method! exception_ident x = 
      (* we can not simply skip it, since it can be used 
          TODO: check loop exception
          (loop {
          excption(i){
          () => {i}
          } 
          })
       *)
      {< used_idents = Ident_set.add used_idents x ;
         defined_idents = Ident_set.add defined_idents x
         >}
    method! for_ident x = {< loop_mutable_values = Ident_set.add loop_mutable_values x >}

    method! ident x = 
      if Ident_set.mem defined_idents x then 
        self
      else {< used_idents = Ident_set.add used_idents x >}
  end

let program js = 
  (scope_pass # program js ) # get_loop_mutable_values

end
module Js_pass_tailcall_inline : sig 
#1 "js_pass_tailcall_inline.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** This pass detect functions used once and if it is used in used
    in the tail position, it will get inlined, this will help 
    remove some common use cases like This
    {[
      let length x = 
        let rec aux n x = 
          match x with 
          | [] -> n 
          | _ :: rest -> aux (n + 1) rest in
        aux 0 x         
    ]} 
*)

val tailcall_inline : J.program -> J.program 

end = struct
#1 "js_pass_tailcall_inline.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






(* When we inline a function call, if we don't do a beta-reduction immediately, there is 
   a chance that it is ignored, (we can not assume that each pass is robust enough)

   After we do inlining, it makes sense to do another constant folding and propogation 
 *)

(* Check: shall we inline functions with while loop? if it is used only once, 
   it makes sense to inline it
*)

module S = Js_stmt_make
module E = Js_exp_make


(** Update ident info use cases, it is a non pure function, 
    it will annotate [program] with some meta data
    TODO: Ident Hashtbl could be improved, 
    since in this case it can not be global?  

*)
let count_collects () = 
  object (self)
    inherit Js_fold.fold as super
    (* collect used status*)
    val stats : int ref Ident_hashtbl.t = Ident_hashtbl.create 83
    (* collect all def sites *)
    val defined_idents : J.variable_declaration Ident_hashtbl.t = Ident_hashtbl.create 83

    val mutable my_export_set  : Ident_set.t = Ident_set.empty


    method add_use id = 
      match Ident_hashtbl.find_opt stats id with
      | None -> Ident_hashtbl.add stats id (ref 1)
      | Some v -> incr v 
    method! program x = 
      my_export_set <- x.export_set ; 

      super#program x
    method! variable_declaration 
        ({ident; value ; property  ; ident_info }  as v)
      =  
      Ident_hashtbl.add defined_idents ident v; 
      match value with 
      | None -> 
        self
      | Some x
        -> self#expression x 
    method! ident id = self#add_use id; self
    method get_stats = 
      Ident_hashtbl.iter defined_idents (fun ident v  -> 
          if Ident_set.mem my_export_set ident then 
            Js_op_util.update_used_stats v.ident_info Exported
          else 
            let pure = 
              match v.value  with 
              | None -> false  (* can not happen *)
              | Some x -> Js_analyzer.no_side_effect_expression x in
            match Ident_hashtbl.find_opt stats ident with 
            | None -> 
              Js_op_util.update_used_stats v.ident_info 
                (if pure then Dead_pure else Dead_non_pure)
            | Some num -> 
              if !num = 1 then 
                Js_op_util.update_used_stats v.ident_info 
                  (if pure then Once_pure else Used) 
        ) ; defined_idents
  end


let get_stats (program : J.program) : J.variable_declaration Ident_hashtbl.t
  =  ((count_collects ()) #program program) #get_stats


(* 1. recursive value ? let rec x = 1 :: x
    non-terminating
    2. duplicative identifiers ..
    remove it at the same time is a bit unsafe,
    since we have to guarantee that the one use
    case is substituted
    we already have this? in [defined_idents]
*)

(** There is a side effect when traversing dead code, since 
    we assume that substitue a node would mark a node as dead node,

    so if we traverse a dead node, this would get a wrong result.
    it does happen in such scenario
    {[
      let generic_basename is_dir_sep current_dir_name name =
        let rec find_end n =
          if n < 0 then String.sub name 0 1
          else if is_dir_sep name n then find_end (n - 1)
          else find_beg n (n + 1)
        and find_beg n p =
          if n < 0 then String.sub name 0 p
          else if is_dir_sep name n then String.sub name (n + 1) (p - n - 1)
          else find_beg (n - 1) p
        in
        if name = ""
        then current_dir_name
        else find_end (String.length name - 1)
    ]}
    [find_beg] can potentially be expanded in [find_end] and in [find_end]'s expansion, 
    if the order is not correct, or even worse, only the wrong one [find_beg] in [find_end] get expanded 
    (when we forget to recursive apply), then some code non-dead [find_beg] will be marked as dead, 
    while it is still called 
*)
let subst (export_set : Ident_set.t) stats  = 
  object (self)
    inherit Js_map.map as super
    method! statement st = 
      match st.statement_desc with 
      | Variable 
          {value = _ ;
           ident_info = {used_stats = Dead_pure}
          } 

        ->
        S.block []
      | Variable { ident_info = {used_stats = Dead_non_pure} ;
                   value = Some v  ; _ }        
        -> S.exp v
      | _ -> super#statement st 
    method! variable_declaration 
        ({ident; value = _ ; property = _ ; ident_info = _}  as v)
      =  
      (* TODO: replacement is a bit shaky, the problem is the lambda we stored is
         not consistent after we did some subsititution, and the dead code removal
         does rely on this (otherwise, when you do beta-reduction you have to regenerate names)
      *)
      let v = super # variable_declaration v in
      Ident_hashtbl.add stats ident v; (* see #278 before changes *)
      v
    method! block bs = 
      match bs with
      | ({statement_desc = 
            Variable ({value =
                         Some ({expression_desc = Fun _; _ } as v )
                      } as vd) ; comment = _} as st) :: rest  -> 
        let is_export = Ident_set.mem export_set vd.ident in
        if is_export then 
          self#statement st :: self#block rest 
        else 
          begin 
            match Ident_hashtbl.find_opt stats vd.ident with 
            (* TODO: could be improved as [mem] *)
            | None -> 
              if Js_analyzer.no_side_effect_expression v 
              then S.exp v  :: self#block rest 
              else self#block rest 

            | Some _ -> self#statement st  :: self#block rest 
          end

      | {statement_desc = 
           Return {return_value = 
                     {expression_desc = 
                        Call({expression_desc = Var (Id id)},args,_info)}} }
        as st 
        :: rest 
        -> 
        begin match Ident_hashtbl.find_opt stats id with 

          | Some ({ value = 
                      Some {expression_desc = Fun (false, params, block, _env) ; comment = _}; 
                    (*TODO: don't inline method tail call yet, 
                      [this] semantics are weird 
                    *)              
                    property = (Alias | StrictOpt | Strict);
                    ident_info = {used_stats = Once_pure };
                    ident = _
                  } as v)
            when Ext_list.same_length params args 
            -> 
            (* Ext_log.dwarn  __LOC__ "%s is dead \n %s " id.name  *)
            (*   (Js_dump.string_of_block [st]); *)
            Js_op_util.update_used_stats v.ident_info Dead_pure;
            let block  = 
              Ext_list.fold_right2 
                params args  ( self#block block) (* see #278 before changes*)
                (fun param arg acc ->  
                   S.define_variable ~kind:Variable param arg :: acc)                                                
            in
            (* Mark a function as dead means it will never be scanned, 
               here we inline the function
            *)
            Ext_list.append block (self#block rest)
          | (None | Some _) ->
            self#statement st :: self#block rest
        end
      | x :: xs 
        ->
        self#statement x :: self#block xs
      | [] 
        -> 
        []

  end


let tailcall_inline (program : J.program) = 
  let stats = get_stats program in
  let export_set = program.export_set in
  (subst export_set stats )#program program

    

end
module Js_shake : sig 
#1 "js_shake.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** A module to shake JS IR
   
    Tree shaking is not going to change the closure 
 *)

val shake_program : J.program -> J.program

end = struct
#1 "js_shake.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** we also need make it complete 
 *)
let get_initial_exports 
    count_non_variable_declaration_statement 
    (export_set : Ident_set.t) (block : J.block ) = 
  let result = Ext_list.fold_left block export_set 
    (fun acc st -> 
      match st.statement_desc with
      | Variable {ident ; value; _} ->
          if Ident_set.mem acc ident then 
            begin match value with
            | None -> acc  
            | Some x -> 
              (* If not a function, we have to calcuate again and again 
                  TODO: add hashtbl for a cache
               *)
                Ident_set.(
                union (Js_analyzer.free_variables_of_expression empty empty x) acc)
            end
          else 
            begin match value with
            | None -> acc 
            | Some x -> 
                if Js_analyzer.no_side_effect_expression x then acc 
                else 
                  Ident_set.(
                  union (Js_analyzer.free_variables_of_expression empty empty x) 
                    (add acc ident))
            end
      | _ -> 
          (* recalcuate again and again ... *)
          if Js_analyzer.no_side_effect_statement st || (not count_non_variable_declaration_statement)
          then acc
          else Ident_set.(union (Js_analyzer.free_variables_of_statement empty empty st) acc)
    ) in result, Ident_set.(diff result export_set)

let shake_program (program : J.program) = 
  let shake_block block export_set = 
    let block = List.rev @@ Js_analyzer.rev_toplevel_flatten block in 
    let  loop block export_set : Ident_set.t = 
      let rec aux acc block = 
        let result, diff = get_initial_exports false acc block   in
        (* let _d ()  =  *)
        (*   if Ext_string.ends_with program.name  debug_file then  *)
        (*     begin *)
        (*       Ext_log.err "@[%a@]@." Ident_set.print result  ; *)
        (*     end *)
        (* in *)
        if Ident_set.is_empty diff then 
          result
        else 
          aux result block in
      let first_iteration, delta  = get_initial_exports true export_set block  in
      (* let _d ()  =  *)
      (*   if Ext_string.ends_with program.name  debug_file then  *)
      (*   begin   *)
      (*     Ext_log.err "@[<v>%a@ %a@]@." *)
      (*       Ident_set.print first_iteration   *)
      (*       Ident_set.print delta (\* TODO: optimization, don't add persistent variables *\) *)
      (*       ; *)
      (*     Ext_log.err "init ---- @." *)
      (*   end *)
      (* in *)

      if not @@ Ident_set.is_empty delta then
        aux first_iteration block 
      else first_iteration in

    let really_set = loop block export_set in 
    Ext_list.fold_right block []
      (fun  (st : J.statement) acc -> 
        match st.statement_desc with
        | Variable {ident; value ; _} -> 
            if Ident_set.mem really_set ident then st:: acc 
            else 
              begin match value with 
              | None -> acc 
              | Some x -> 
                  if Js_analyzer.no_side_effect_expression x then acc
                  else st::acc
              end
        | _ -> if Js_analyzer.no_side_effect_statement st then acc else st::acc
      ) 
  in

  {program with block = shake_block program.block program.export_set}

end
module Lam_analysis : sig 
#1 "lam_analysis.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






(** A module which provides some basic analysis over lambda expression *)

(** No side effect, but it might depend on data store *)
val no_side_effects : Lam.t -> bool 

val size : Lam.t -> int

val ok_to_inline_fun_when_app : body:Lam.t -> Lam.ident list -> Lam.t list -> bool
  


val small_inline_size : int  
val exit_inline_size : int  


val safe_to_inline : Lam.t -> bool

end = struct
#1 "lam_analysis.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


(**used in effect analysis, it is sound but not-complete *)
let not_zero_constant ( x : Lam_constant.t) =  
  match x with 
  | Const_int i  -> i <> 0
  | Const_int32 i  -> i <> 0l
  | Const_int64 i  -> i <> 0L
  | Const_nativeint i -> i <> 0n
  | _ -> false 


let rec no_side_effects (lam : Lam.t) : bool = 
  match lam with 
  | Lvar _ 
  | Lconst _ 
  | Lfunction _ -> true
  | Lam.Lglobal_module _ -> true 
    (* we record side effect in the global level, 
      this expression itself is side effect free
    *)
  | Lprim {primitive;  args; _} -> 
    Ext_list.for_all args  no_side_effects && 
    (
      match primitive with 
      | Pccall {prim_name ; _} ->
        begin 
          match prim_name,args with 
          | ("caml_register_named_value"
            (* register to c runtime does not make sense  in ocaml *)
            | "caml_int64_float_of_bits"
             (* more safe to check if arguments are constant *)
            (* non-observable side effect *)    
            | "caml_sys_get_config"
            | "caml_sys_get_argv" (* should be fine *)

            | "caml_create_string" (* TODO: add more *)
            | "caml_make_vect"
            | "caml_create_bytes"
            | "caml_obj_dup"
            | "caml_array_dup"
            | "caml_obj_block"
            ), _  -> true 
          | "caml_ml_open_descriptor_in", [Lconst (  (Const_int 0))] -> true 
          | "caml_ml_open_descriptor_out", 
            [Lconst (  (Const_int (1|2))) ]
            -> true
          (* we can not mark it pure
             only when we guarantee this exception is caught...
           *)
          | _ , _-> false
        end 
      | Pmodint
      | Pdivint 
      | Pdivbint _
      | Pmodbint _ 
        -> begin match args with 
          | [_ ; Lconst cst ] -> not_zero_constant cst 
          | _ -> false 
        end
      
      | Pcreate_extension _
      (* | Pcreate_exception _ *)
      | Pjs_typeof
      | Pis_null
      | Pis_not_none
      | Psome
      | Psome_not_nest
      | Pis_undefined
      | Pis_null_undefined
      | Pnull_to_opt       
      | Pundefined_to_opt         
      | Pnull_undefined_to_opt 
      | Pjs_fn_make _         
      | Pjs_object_create _
        (** TODO: check *)      
      | Pbytes_to_string 
      | Pbytes_of_string 
      | Pglobal_exception _
      | Pmakeblock _  (* whether it's mutable or not *)
      | Pfield _
      | Pfield_computed
      | Pval_from_option
      | Pval_from_option_not_nest
      | Pfloatfield _ 
      | Pduprecord _ 
      (* Boolean operations *)
      | Psequand | Psequor | Pnot
      (* Integer operations *)
      | Pnegint | Paddint | Psubint | Pmulint 
     
      | Pandint | Porint | Pxorint
      | Plslint | Plsrint | Pasrint
      | Pintcomp _ 
      (* Float operations *)
      | Pintoffloat | Pfloatofint
      | Pnegfloat 
      (* | Pabsfloat *)
      | Paddfloat | Psubfloat | Pmulfloat 
      | Pdivfloat
      | Pfloatcomp _ 
      | Pjscomp _
      (* String operations *)
      | Pstringlength 
      | Pstringrefu 
      | Pstringrefs
      | Pbyteslength
      | Pbytesrefu
      | Pbytesrefs
      | Pmakearray _ 
      | Parraylength  
      | Parrayrefu 
      | Parrayrefs  
      (* Test if the argument is a block or an immediate integer *)
      | Pisint
      (* Test if the (integer) argument is outside an interval *)
      | Pisout
      | Pbintofint _
      | Pintofbint _
      | Pcvtbint _
      | Pnegbint _
      | Paddbint _
      | Psubbint _
      | Pmulbint _
      | Pandbint _
      | Porbint _
      | Pxorbint _
      | Plslbint _
      | Plsrbint _
      | Pasrbint _
      | Pbintcomp _
      (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *)
      | Pbigarrayref _ (* TODO it may raise an exception....*)
      (* Compile time constants *)
      | Pctconst _
      (* Integer to external pointer *)

      | Poffsetint _
      | Pstringadd 
      | Pjs_function_length
      | Pcaml_obj_length
      (* | Pjs_is_instance_array *)
      | Pwrap_exn
      | Praw_js_function _
        -> true
      | Pjs_apply
      | Pjs_runtime_apply
      | Pjs_call _ 
      | Pinit_mod
      | Pupdate_mod
      | Pjs_unsafe_downgrade _
      | Pdebugger 
      | Pjs_fn_run _ 
      | Pjs_fn_method _ | Pjs_fn_runmethod _
      (* TODO *)
      | Praw_js_code_exp _ 
      | Praw_js_code_stmt _
      | Pbytessetu 
      | Pbytessets
      (* Bitvect operations *)
      | Pbittest
      (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *)
      | Parraysets 
      | Pbigarrayset _
      (* size of the nth dimension of a big array *)
      | Pbigarraydim _
      (* load/set 16,32,64 bits from a string: (unsafe)*)
      | Pstring_load_16 _
      | Pstring_load_32 _
      | Pstring_load_64 _
      | Pstring_set_16 _
      | Pstring_set_32 _
      | Pstring_set_64 _
      (* load/set 16,32,64 bits from a
         (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *)
      | Pbigstring_load_16 _
      | Pbigstring_load_32 _
      | Pbigstring_load_64 _
      | Pbigstring_set_16 _
      | Pbigstring_set_32 _
      | Pbigstring_set_64 _
      (* byte swap *)
      | Pbswap16
      | Pbbswap _
      | Parraysetu  
      | Poffsetref _ 
      | Praise
      | Plazyforce 
      | Psetfield _ 
      | Psetfield_computed
      | Psetfloatfield _
      (* | Psetglobal _  *)
        -> false 
    )
  | Llet (_,_, arg,body) -> no_side_effects arg && no_side_effects body 
  | Lswitch (_,_) -> false 
  | Lstringswitch (_,_,_) -> false
  | Lstaticraise _ -> false
  | Lstaticcatch _ -> false 

  (* | "caml_sys_getenv" , [Lconst( (Const_string _))] *)
  (*         -> true *)
  (** not enough, we need know that 
      if it [Not_found], there are no other exceptions 
      can be thrown
  *)
  | Ltrywith (Lprim { primitive = Pccall{prim_name = "caml_sys_getenv"};
                    args = [Lconst _]; _},exn,
              Lifthenelse(Lprim{args =  
                                  [Lvar exn1; 
                                   Lprim {primitive = Pglobal_exception ({name="Not_found"}); args = []; _}]
                               ; _},
                          then_, _)) when Ident.same exn1 exn
    (** we might put this in an optimization pass 
        also make sure when we wrap this in [js] we 
        should follow the same patten, raise [Not_found] 
    *)
    -> no_side_effects then_
  (** It would be nice that we can also analysis some small functions 
      for example [String.contains], 
      [Format.make_queue_elem]
  *)
  | Ltrywith (body,exn,handler) 
    -> no_side_effects body && no_side_effects handler

  | Lifthenelse  (a,b,c) -> 
    no_side_effects a && no_side_effects b && no_side_effects c
  | Lsequence (a,b) -> no_side_effects a && no_side_effects b
  | Lletrec (bindings, body) ->
    Ext_list.for_all_snd bindings no_side_effects && no_side_effects body
  | Lwhile _ -> false (* conservative here, non-terminating loop does have side effect *)
  | Lfor _ -> false 
  | Lassign _ -> false (* actually it depends ... *)
  | Lsend _ -> false 
  | Lapply _ -> false (* we need purity analysis .. *)
  


(* 
    Estimate the size of lambda for better inlining 
    threshold is 1000 - so that we 
 *)
exception Too_big_to_inline

let really_big () = raise_notrace Too_big_to_inline

let big_lambda = 1000

let rec size (lam : Lam.t) = 
  try 
    match lam with 
    | Lvar _ ->  1
    | Lconst c -> size_constant c
    | Llet(_, _, l1, l2) -> 1 + size l1 + size l2 
    | Lletrec _ -> really_big ()
    | Lprim{primitive = Pfield _; 
            args =  [ Lglobal_module _]
           ;  _}
      -> 1
    | Lprim {primitive = Praise | Pis_not_none ; args =  [l ];  _} 
      -> size l
    | Lam.Lglobal_module _ -> 1       
    | Lprim {primitive = 
        Praw_js_code_stmt _ 
      | Praw_js_function _ 
      | Praw_js_code_exp _ } -> really_big ()
    | Lprim {args = ll; _} -> size_lams 1 ll

    (** complicated 
        1. inline this function
        2. ...
        exports.Make=
        function(funarg)
        {var $$let=Make(funarg);
        return [0, $$let[5],... $$let[16]]}
     *)      
    | Lapply{ fn;
             args; _} -> size_lams (size fn) args
    (* | Lfunction(_, params, l) -> really_big () *)
    | Lfunction {body} -> size body 
    | Lswitch(_, _) -> really_big ()
    | Lstringswitch(_,_,_) -> really_big ()
    | Lstaticraise (i,ls) -> 
        Ext_list.fold_left ls 1 (fun acc x -> size x + acc) 
    | Lstaticcatch(l1, (i,x), l2) -> really_big () 
    | Ltrywith(l1, v, l2) -> really_big ()
    | Lifthenelse(l1, l2, l3) -> 1 + size  l1 + size  l2 +  size  l3
    | Lsequence(l1, l2) -> size  l1  +  size  l2
    | Lwhile(l1, l2) -> really_big ()
    | Lfor(flag, l1, l2, dir, l3) -> really_big () 
    | Lassign (_,v) -> 1 + size v  (* This is side effectful,  be careful *)
    | Lsend _  ->  really_big ()

  with Too_big_to_inline ->  1000 
and size_constant x = 
  match x with 
  | Const_int _ | Const_char _ 

  | Const_float _  | Const_int32 _ | Const_int64 _ 
  | Const_nativeint _ 
  | Const_immstring _
  | Const_pointer _ 
  | Const_js_null | Const_js_undefined
  | Const_js_true | Const_js_false
    -> 1 
  | Const_unicode _  (* TODO: this seems to be not good heurisitives*)
  | Const_string _ ->  1
  | Const_some s -> size_constant s   
  | Const_block (_, _, str) 
    ->  Ext_list.fold_left str 0 (fun acc x -> acc + size_constant x ) 
  | Const_float_array xs  -> List.length xs

and size_lams acc (lams : Lam.t list) = 
  Ext_list.fold_left lams acc (fun acc l -> acc  + size l ) 
let args_all_const (args : Lam.t list) =
  Ext_list.for_all args (fun x -> match x with Lconst _ -> true | _ -> false) 
    
let exit_inline_size = 7 
let small_inline_size = 5

(** destruct pattern will work better 
    if it is closed lambda, otherwise
    you can not do full evaluation

    We still should avoid inline too big code, 

    ideally we should also evaluate its size after inlining, 
    since after partial evaluation, it might still be *very big*
*)
let destruct_pattern (body : Lam.t) params args =
  let rec aux v params args =
    match params, args with
    | x::xs, b::bs ->
      if Ident.same x v then Some b
      else aux v xs bs
    | [] , _ -> None
    | x::xs, [] -> assert false                  
  in   
  match body with
  | Lswitch (Lvar v , switch)
    ->
    begin match aux v params args with
      | Some (Lam.Lconst _ as lam) ->
        size (Lam.switch lam switch) < small_inline_size
      | Some _ | None -> false
    end        
  | Lifthenelse(Lvar v, then_, else_)
    -> (* -FIXME *)
    begin match aux v params args with
      | Some (Lconst _ as lam) ->
        size (Lam.if_ lam then_ else_) < small_inline_size
      | Some _ | None -> false          
    end      
  | _ -> false
    
(** Hints to inlining *)
let ok_to_inline_fun_when_app 
  ~(body : Lam.t) 
  (params : Ident.t list)
  (args : Lam.t list) =
  let s = size body in
  s < small_inline_size ||
  (destruct_pattern body params args) ||  
  (args_all_const args &&
   (s < 10 && no_side_effects body )) 







(* TODO:  We can relax this a bit later,
    but decide whether to inline it later in the call site
 *)
let safe_to_inline (lam : Lam.t) = 
  match lam with 
  | Lfunction _ ->  true
  | Lconst 
    (Const_pointer _  
    | Const_immstring _ 
    | Const_js_true 
    | Const_js_false
    | Const_js_undefined
    ) -> true
  | _ -> false

end
module Lam_arity_analysis : sig 
#1 "lam_arity_analysis.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Utilities for lambda analysis *)



val get_arity :
  Lam_stats.t -> 
  Lam.t ->
  Lam_arity.t






end = struct
#1 "lam_arity_analysis.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


let arity_of_var (meta : Lam_stats.t) (v : Ident.t)  =
  (** for functional parameter, if it is a high order function,
      if it's not from function parameter, we should warn
  *)
  match Ident_hashtbl.find_opt meta.ident_tbl v with 
  | Some (FunctionId {arity;_}) -> arity
  | Some _
  | None ->
    Lam_arity.na 


(* we need record all aliases -- since not all aliases are eliminated, 
   mostly are toplevel bindings
   We will keep iterating such environment
   If not found, we will return [NA]
*)
let rec get_arity (meta : Lam_stats.t) (lam : Lam.t) :  Lam_arity.t = 
  match lam with 
  | Lvar v -> arity_of_var meta v 
  | Lconst _ -> Lam_arity.non_function_arity_info
  | Llet(_,_,_, l ) -> get_arity meta l 
  | Lprim {primitive = Pfield (n,_); 
           args =  [ Lglobal_module id  ]; _} ->
    begin match (Lam_compile_env.cached_find_ml_id_pos id n meta.env).arity with 
      | Single x -> x 
      | Submodule _ -> Lam_arity.na
    end
  | Lprim {primitive = Pfield (m,_); 
           args =  [ Lprim{primitive = Pfield(n,_); 
                           args = [ Lglobal_module id]}  ]
          ; _} ->
    begin match (Lam_compile_env.cached_find_ml_id_pos id n meta.env).arity with 
      | Submodule subs -> subs.(m)
      | Single _ -> Lam_arity.na
    end
  (* TODO: all information except Pccall is complete, we could 
     get more arity information
  *)
  | Lprim {primitive = Praw_js_function(_, arg)} -> 
    Lam_arity.info [List.length arg] false
  | Lprim {primitive = Praise ;  _} -> Lam_arity.raise_arity_info
  | Lglobal_module _ (* TODO: fix me never going to happen *)
  | Lprim _  -> Lam_arity.na (* CHECK*)
  (* shall we handle primitive in a direct way, 
      since we know all the information
      Invariant: all primitive application is fully applied, 
      since this information  is already available

      -- Check external c functions ?
      -- it's not true for primitives 
      like caml_set_oo_id  or  Lprim (Pmakeblock , [])

      it seems true that primitive is always fully applied, however,
      it can return a function
  *)
  | Lletrec(_, body) ->  get_arity meta body

  | Lapply{fn = app;  args; _ } -> (* detect functor application *)
    let fn = get_arity meta app in 
    begin match fn with 
      | Arity_na -> Lam_arity.na
      | Arity_info ( xs, tail ) -> 
        let rec take (arities : _ list) arg_length = 
          match arities with 
          | x :: yys ->
            if arg_length = x then Lam_arity.info  yys tail
            else if arg_length > x then
              take yys (arg_length - x)
            else Lam_arity.info 
                ((x -  arg_length ) :: yys)
                tail
          | [] -> 
            if tail then Lam_arity.raise_arity_info
            else Lam_arity.na
            (* Actually, you can not have truly deministic arities
               for example [fun x -> x ]
            *)
        in
        take xs (List.length args) 
    end
  | Lfunction {arity;  body} -> 
    Lam_arity.merge arity  (get_arity meta body)
  | Lswitch(l, {sw_failaction; 
                sw_consts; 
                sw_blocks;
                sw_numblocks = _;
                sw_numconsts = _;
               }) -> 
    all_lambdas meta (
      let rest = 
        Ext_list.map_append sw_consts
          (Ext_list.map sw_blocks snd) snd  in
      match sw_failaction with None -> rest | Some x -> x::rest )
  | Lstringswitch(l, sw, d) -> 
    begin match d with 
      | None -> all_lambdas meta (Ext_list.map sw snd )
      | Some v -> all_lambdas meta (v:: Ext_list.map sw snd)
    end
  | Lstaticcatch(_, _, handler) -> get_arity meta handler
  | Ltrywith(l1, _, l2) -> 
    all_lambdas meta [l1;l2]
  | Lifthenelse(l1, l2, l3) ->
    all_lambdas meta [l2;l3]
  | Lsequence(_, l2) -> get_arity meta l2 
  | Lstaticraise _ (* since it will not be in tail position *)
  | Lsend _
     -> Lam_arity.na 
  | Lwhile _ 
  | Lfor _  
  | Lassign _ -> Lam_arity.non_function_arity_info

and all_lambdas meta (xs : Lam.t list) = 
  match xs with 
  | y :: ys -> 
    let arity =  get_arity meta y in 
    let rec aux (acc : Lam_arity.t) xs = 
      match acc, xs  with 
      | Arity_na, _ -> acc 
      | _, [] -> acc 
      | Arity_info(xxxs, tail), y::ys ->
        match get_arity meta y with 
        | Arity_na -> Lam_arity.na
        | Arity_info (yyys,tail2) -> 
          aux 
            (Lam_arity.merge_arities xxxs yyys tail tail2)
            ys
    in  aux arity ys     

  | [] -> Lam_arity.na




end
module Ident_hash_set : sig 
#1 "ident_hash_set.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


include Hash_set_gen.S with type key = Ident.t

end = struct
#1 "ident_hash_set.ml"
# 1 "ext/hash_set.cppo.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
# 37 "ext/hash_set.cppo.ml"
type key = Ident.t
let key_index (h :  _ Hash_set_gen.t ) (key : key) =
  (Bs_hash_stubs.hash_string_int  key.name key.stamp) land (Array.length h.data - 1)
let eq_key = Ext_ident.equal
type t = key Hash_set_gen.t


# 64 "ext/hash_set.cppo.ml"
let create = Hash_set_gen.create
let clear = Hash_set_gen.clear
let reset = Hash_set_gen.reset
let copy = Hash_set_gen.copy
let iter = Hash_set_gen.iter
let fold = Hash_set_gen.fold
let length = Hash_set_gen.length
let stats = Hash_set_gen.stats
let elements = Hash_set_gen.elements



let remove (h : _ Hash_set_gen.t) key =  
  let i = key_index h key in
  let h_data = h.data in
  let old_h_size = h.size in 
  let new_bucket = Hash_set_gen.remove_bucket eq_key key h (Array.unsafe_get h_data i) in
  if old_h_size <> h.size then  
    Array.unsafe_set h_data i new_bucket



let add (h : _ Hash_set_gen.t) key =
  let i = key_index h key  in 
  let h_data = h.data in 
  let old_bucket = (Array.unsafe_get h_data i) in
  if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then 
    begin 
      Array.unsafe_set h_data i (key :: old_bucket);
      h.size <- h.size + 1 ;
      if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h
    end

let of_array arr = 
  let len = Array.length arr in 
  let tbl = create len in 
  for i = 0 to len - 1  do
    add tbl (Array.unsafe_get arr i);
  done ;
  tbl 
  
    
let check_add (h : _ Hash_set_gen.t) key =
  let i = key_index h key  in 
  let h_data = h.data in  
  let old_bucket = (Array.unsafe_get h_data i) in
  if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then 
    begin 
      Array.unsafe_set h_data i  (key :: old_bucket);
      h.size <- h.size + 1 ;
      if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h;
      true 
    end
  else false 


let mem (h :  _ Hash_set_gen.t) key =
  Hash_set_gen.small_bucket_mem eq_key key (Array.unsafe_get h.data (key_index h key)) 

  

end
module Lam_free_variables : sig 
#1 "lam_free_variables.mli"
(* Copyright (C) 2018 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


 val pass_free_variables : Lam.t -> Ident_set.t
end = struct
#1 "lam_free_variables.ml"
(* Copyright (C) 2018 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


 let pass_free_variables (l : Lam.t) : Ident_set.t =
  let fv = ref Ident_set.empty in
  let rec 
  free_list xs = List.iter free xs 
  and free_list_snd : 'a. ('a * Lam.t) list -> unit = fun xs -> 
  Ext_list.iter_snd  xs free
  and free (l : Lam.t) =

    match l with
    | Lvar id -> fv := Ident_set.add !fv id
    | Lassign(id, e) ->
      free e;
      fv := Ident_set.add !fv id
    | Lstaticcatch(e1, (_,vars), e2) ->
      free e1; free e2;
      Ext_list.iter vars (fun id -> fv := Ident_set.remove !fv id) 
    | Ltrywith(e1, exn, e2) ->
      free e1; free e2;
      fv := Ident_set.remove !fv exn 
    | Lfunction{body;params} ->
      free body;
      Ext_list.iter params (fun param -> fv := Ident_set.remove !fv param) 
    | Llet(str, id, arg, body) ->
      free arg; free body;
      fv := Ident_set.remove !fv id
    | Lletrec(decl, body) ->
      free body;
      free_list_snd decl;
      Ext_list.iter decl (fun (id, exp) -> fv := Ident_set.remove !fv id) 
    | Lfor(v, e1, e2, dir, e3) ->
      free e1; free e2; free e3;
      fv := Ident_set.remove !fv v 
    | Lconst _ -> ()
    | Lapply{fn; args; _} ->
      free fn; free_list args
    | Lglobal_module _ -> ()
    (* according to the existing semantics:
       [primitive] is not counted
    *)
    | Lprim {args; _} ->
      free_list args
    | Lswitch(arg, sw) ->
      free arg;
      free_list_snd sw.sw_consts;
      free_list_snd sw.sw_blocks;
      Ext_option.iter sw.sw_failaction free;
    | Lstringswitch (arg,cases,default) ->
      free arg ;
      free_list_snd cases ;
      Ext_option.iter default free
    | Lstaticraise (_,args) ->
      free_list args
    | Lifthenelse(e1, e2, e3) ->
      free e1; free e2; free e3
    | Lsequence(e1, e2) ->
      free e1; free e2
    | Lwhile(e1, e2) ->
      free e1; free e2
    | Lsend (k, met, obj, args, _) ->
      free met; free obj;  free_list args
  in free l;
  !fv



(**
        [hit_any_variables fv l]
        check the lambda expression [l] if has some free
        variables captured by [fv].
        Note it does not do any checking like below
        [Llet(str,id,arg,body)]
        it only check [arg] or [body] is hit or not, there
        is a case that [id] is hit in [arg] but also exists
        in [fv], this is ignored.
*)
end
module Lam_group : sig 
#1 "lam_group.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






type t =
  | Single of Lam_compat.let_kind  * Ident.t * Lam.t
  | Recursive of (Ident.t * Lam.t) list
  | Nop of Lam.t





(** Tricky to be complete *)

val pp_group : Env.t -> Format.formatter -> t -> unit

val single :
  Lam_compat.let_kind ->
  Ident.t ->
  Lam.t ->
  t

val nop_cons :
  Lam.t ->
  t list ->
  t list

end = struct
#1 "lam_group.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)





(** This is not a recursive type definition *)
type t =
  | Single of Lam_compat.let_kind  * Ident.t * Lam.t
  | Recursive of (Ident.t * Lam.t) list
  | Nop of Lam.t

let single (kind : Lam_compat.let_kind) id (body : Lam.t) =
  match kind, body with
  | (Strict | StrictOpt),
    (Lvar _ | Lconst _) ->
    Single(Alias, id,body)
  | _ -> Single(kind,id,body)

let nop_cons (x : Lam.t) acc =
  match x with
  | Lvar _ | Lconst _ | Lfunction _
    ->  acc
  | _ -> Nop x :: acc

let pp = Format.fprintf

let str_of_kind (kind : Lam_compat.let_kind) =
  match kind with
  | Alias -> "a"
  | Strict -> ""
  | StrictOpt -> "o"
  | Variable -> "v"

let pp_group env fmt ( x : t) =
  match x with
  | Single (kind, id, lam) ->
    Format.fprintf fmt "@[let@ %a@ =%s@ @[<hv>%a@]@ @]" Ident.print id (str_of_kind kind)
      (Lam_print.env_lambda env) lam
  | Recursive lst ->
    List.iter (fun (id,lam) ->
        Format.fprintf fmt
          "@[let %a@ =r@ %a@ @]" Ident.print id (Lam_print.env_lambda env) lam
      ) lst
  | Nop lam -> Lam_print.env_lambda env fmt lam




end
module Lam_dce : sig 
#1 "lam_dce.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)









(** Dead code eliminatiion on the lambda layer 
*)

val remove : Ident.t list -> Lam_group.t list -> Lam_group.t list

end = struct
#1 "lam_dce.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)











let transitive_closure 
    (initial_idents : Ident.t list) 
    (ident_freevars : Ident_set.t Ident_hashtbl.t) 
  =
  let visited  = Ident_hash_set.create 31 in 
  let rec dfs (id : Ident.t) : unit =
    if not (Ident_hash_set.mem visited id || Ext_ident.is_js_or_global id ) then
      begin 
        Ident_hash_set.add visited id;
        match Ident_hashtbl.find_opt ident_freevars id with 
        | None -> 
          Ext_fmt.failwithf ~loc:__LOC__ "%s/%d not found"  (Ident.name id) (id.stamp)  
        | Some e -> Ident_set.iter e dfs
      end  in 
  Ext_list.iter initial_idents dfs;
  visited

let remove export_idents (rest : Lam_group.t list) : Lam_group.t list  = 
  let ident_free_vars :  _ Ident_hashtbl.t = Ident_hashtbl.create 17 in
  (* calculate initial required idents, 
     at the same time, populate dependency set [ident_free_vars]
  *)
  let initial_idents =
    Ext_list.fold_left rest export_idents (fun acc x -> 
        match x with
        | Single(kind, id,lam) ->                   
          begin
            Ident_hashtbl.add ident_free_vars id 
              (Lam_free_variables.pass_free_variables lam);
            match kind with
            | Alias | StrictOpt -> acc
            | Strict | Variable -> id :: acc 
          end
        | Recursive bindings -> 
          Ext_list.fold_left bindings acc (fun acc (id,lam) -> 
              Ident_hashtbl.add ident_free_vars id (Lam_free_variables.pass_free_variables lam);
              match lam with
              | Lfunction _ -> acc 
              | _ -> id :: acc
            ) 
        | Nop lam ->
          if Lam_analysis.no_side_effects lam then acc
          else 
            (** its free varaibles here will be defined above *)
            Ident_set.fold (Lam_free_variables.pass_free_variables lam) acc (fun x acc -> x :: acc) 
      )  in 
  let visited = transitive_closure initial_idents ident_free_vars in 
  Ext_list.fold_left rest [] (fun acc x->
      match x with 
      | Single(_,id,_) -> 
        if Ident_hash_set.mem visited id  then 
          x :: acc 
        else acc 
      | Nop _ -> x :: acc  
      | Recursive bindings ->
        let b = 
          Ext_list.fold_right bindings [] (fun ((id,_) as v) acc ->
              if Ident_hash_set.mem visited id then 
                v :: acc 
              else
                acc  
            )  in            
        match b with 
        | [] -> acc  
        | _ -> (Recursive b) :: acc
    )  |> List.rev   

  

end
module Lam_hit : sig 
#1 "lam_hit.mli"
(* Copyright (C) 2015 - Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



val hit_variables : Ident_set.t -> Lam.t -> bool

val hit_variable : Ident.t -> Lam.t -> bool 

end = struct
#1 "lam_hit.ml"
(* Copyright (C) 2015 - Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

 type t = Lam.t 


let hit_variables (fv : Ident_set.t) (l : t) : bool  =
  let rec 
  hit_opt (x : t option) = 
    match x with 
    | None -> false 
    | Some a -> hit a
  and hit_var (id : Ident.t) = Ident_set.mem fv id 
  and hit_list_snd : 'a. ('a * t ) list -> bool = fun x ->    
    Ext_list.exists_snd x hit
  and hit_list xs = Ext_list.exists xs hit
  and hit (l : t) =
    begin
      match (l : t) with
      | Lvar id -> hit_var id 
      | Lassign(id, e) ->
        hit_var id || hit e
      | Lstaticcatch(e1, (_,vars), e2) ->
        hit e1 || hit e2
      | Ltrywith(e1, exn, e2) ->
        hit e1 || hit e2
      | Lfunction{body;params} ->
        hit body;
      | Llet(str, id, arg, body) ->
        hit arg || hit body
      | Lletrec(decl, body) ->
        hit body ||
        hit_list_snd decl 
      | Lfor(v, e1, e2, dir, e3) ->
        hit e1 || hit e2 || hit e3
      | Lconst _ -> false
      | Lapply{fn; args; _} ->
        hit fn || hit_list args
      | Lglobal_module _  (* global persistent module, play safe *)
        -> false
      | Lprim {args; _} ->
        hit_list args
      | Lswitch(arg, sw) ->
        hit arg ||
        hit_list_snd sw.sw_consts ||
        hit_list_snd sw.sw_blocks ||
        hit_opt sw.sw_failaction 
      | Lstringswitch (arg,cases,default) ->
        hit arg ||
        hit_list_snd cases ||
        hit_opt default 
      | Lstaticraise (_,args) ->
        hit_list args
      | Lifthenelse(e1, e2, e3) ->
        hit e1 || hit e2 || hit e3
      | Lsequence(e1, e2) ->
        hit e1 || hit e2
      | Lwhile(e1, e2) ->
        hit e1 || hit e2
      | Lsend (k, met, obj, args, _) ->
        hit met || hit obj ||  hit_list args
    end
  in hit l


let hit_variable (fv : Ident.t) (l : t) : bool  =
  let rec 
  hit_opt (x : t option) = 
    match x with 
    | None -> false 
    | Some a -> hit a
  and hit_var (id : Ident.t) = Ident.same id fv   
  and hit_list_snd : 'a. ('a * t ) list -> bool = fun x ->    
    Ext_list.exists_snd x hit
  and hit_list xs = Ext_list.exists xs hit 
  and hit (l : t) =
    begin
      match (l : t) with
      | Lvar id -> hit_var id 
      | Lassign(id, e) ->
        hit_var id || hit e
      | Lstaticcatch(e1, (_,vars), e2) ->
        hit e1 || hit e2
      | Ltrywith(e1, exn, e2) ->
        hit e1 || hit e2
      | Lfunction{body;params} ->
        hit body;
      | Llet(str, id, arg, body) ->
        hit arg || hit body
      | Lletrec(decl, body) ->
        hit body ||
        hit_list_snd decl 
      | Lfor(v, e1, e2, dir, e3) ->
        hit e1 || hit e2 || hit e3
      | Lconst _ -> false
      | Lapply{fn; args; _} ->
        hit fn || hit_list args
      | Lglobal_module _  (* global persistent module, play safe *)
        -> false
      | Lprim {args; _} ->
        hit_list args
      | Lswitch(arg, sw) ->
        hit arg ||
        hit_list_snd sw.sw_consts ||
        hit_list_snd sw.sw_blocks ||
        hit_opt sw.sw_failaction 
      | Lstringswitch (arg,cases,default) ->
        hit arg ||
        hit_list_snd cases ||
        hit_opt default 
      | Lstaticraise (_,args) ->
        hit_list args
      | Lifthenelse(e1, e2, e3) ->
        hit e1 || hit e2 || hit e3
      | Lsequence(e1, e2) ->
        hit e1 || hit e2
      | Lwhile(e1, e2) ->
        hit e1 || hit e2
      | Lsend (k, met, obj, args, _) ->
        hit met || hit obj ||  hit_list args
    end
  in hit l

end
module Lam_util : sig 
#1 "lam_util.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








val kind_of_lambda_block : Lam.t list -> Lam_id_kind.t


(** [field_flattern_get cb v i tbl]
    try to remove the indirection of [v.(i)] by inlining when [v]
    is a known block, 
    if not, it will call [cb ()].
    
    Note due to different control flow, a constant block
    may result in out-of bound access, in that case, we should
    just ignore it. This does not mean our
    optimization is wrong, it means we hit an unreachable branch.
    for example
    {{
      let myShape = A 10 in 
      match myShape with 
      | A x -> x  (* only access field [0]*)
      | B (x,y) -> x + y (* Here it will try to access field [1] *)
    }}
*)
val field_flatten_get : 
  (unit -> Lam.t) -> Ident.t -> int -> Lam_stats.ident_tbl -> Lam.t





val alias_ident_or_global : Lam_stats.t ->
  Ident.t -> Ident.t -> Lam_id_kind.t -> Lam_compat.let_kind -> unit 


val refine_let : 
    kind:Lam_compat.let_kind  ->
      Ident.t -> Lam.t -> Lam.t -> Lam.t



val generate_label : ?name:string -> unit -> J.label 



(** [dump] when {!Js_config.is_same_file}*)
val dump : Env.t   -> string -> Lam.t -> unit


val not_function : Lam.t -> bool 
val is_function : Lam.t -> bool 









end = struct
#1 "lam_util.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)










(*
let add_required_modules ( x : Ident.t list) (meta : Lam_stats.t) = 
  let meta_require_modules = meta.required_modules in
  List.iter (fun x -> add meta_require_modules (Lam_module_ident.of_ml x)) x 
*)
  

(* 
    It's impossible to have a case like below:
   {[
     (let export_f = ... in export_f)
   ]}
    Even so, it's still correct
*)
let refine_let
    ~kind param
    (arg : Lam.t) (l : Lam.t)  : Lam.t =

  match (kind : Lam_compat.let_kind ), arg, l  with 
  | _, _, Lvar w when Ident.same w param 
    (* let k = xx in k
      there is no [rec] so [k] would not appear in [xx]
     *)
    -> arg (* TODO: optimize here -- it's safe to do substitution here *)
  | _, _, Lprim {primitive ; args =  [Lvar w]; loc ; _} when Ident.same w param 
                                                          &&  (function | Lam_primitive.Pmakeblock _ -> false | _ ->  true) primitive
    (* don't inline inside a block *)
    ->  Lam.prim ~primitive ~args:[arg]  loc 
  (* we can not do this substitution when capttured *)
  (* | _, Lvar _, _ -> (\** let u = h in xxx*\) *)
  (*     (\* assert false *\) *)
  (*     Ext_log.err "@[substitution >> @]@."; *)
  (*     let v= subst_lambda (Ident_map.singleton param arg ) l in *)
  (*     Ext_log.err "@[substitution << @]@."; *)
  (* v *)
  | _, _, Lapply {fn; args = [Lvar w]; loc; status} when
   Ident.same w param &&
    (not (Lam_hit.hit_variable param fn ))
   -> 
    (** does not work for multiple args since 
        evaluation order unspecified, does not apply 
        for [js] in general, since the scope of js ir is loosen

        here we remove the definition of [param]
        {[ let k = v in (body) k 
        ]}
        #1667 make sure body does not hit k 
    *)
    Lam.apply fn [arg] loc status
  | (Strict | StrictOpt ),
    ( Lvar _    | Lconst  _ | 
      Lprim {primitive = Pfield _ ;  
             args = [ Lglobal_module _ ]; _}) , _ ->
    (* (match arg with  *)
    (* | Lconst _ ->  *)
    (*     Ext_log.err "@[%a %s@]@."  *)
    (*       Ident.print param (string_of_lambda arg) *)
    (* | _ -> ()); *)
    (* No side effect and does not depend on store,
        since function evaluation is always delayed
    *)
    Lam.let_ Alias param arg l
  | ( (Strict | StrictOpt ) ), (Lfunction _ ), _ ->
    (*It can be promoted to [Alias], however, 
        we don't want to do this, since we don't want the 
        function to be inlined to a block, for example
      {[
        let f = fun _ -> 1 in
        [0, f]
      ]}
        TODO: punish inliner to inline functions 
        into a block 
    *)
    Lam.let_ StrictOpt  param arg l
  (* Not the case, the block itself can have side effects 
      we can apply [no_side_effects] pass 
      | Some Strict, Lprim(Pmakeblock (_,_,Immutable),_) ->  
        Llet(StrictOpt, param, arg, l) 
  *)      
  | Strict, _ ,_  when Lam_analysis.no_side_effects arg ->
    Lam.let_ StrictOpt param arg l
  | Variable, _, _ -> 
    Lam.let_ Variable  param arg l
  | kind, _, _ -> 
    Lam.let_ kind  param arg l
  (* | None , _, _ -> 
    Lam.let_ Strict param arg  l *)

let alias_ident_or_global (meta : Lam_stats.t) (k:Ident.t) (v:Ident.t) 
    (v_kind : Lam_id_kind.t) (let_kind : Lam_compat.let_kind) =
  (** treat rec as Strict, k is assigned to v 
      {[ let k = v ]}
  *)
  begin 
    match v_kind with 
    | NA ->
      begin 
        match Ident_hashtbl.find_opt meta.ident_tbl v  with 
        | None -> ()
        | Some ident_info -> Ident_hashtbl.add meta.ident_tbl k ident_info
      end
    | ident_info -> Ident_hashtbl.add meta.ident_tbl k ident_info
  end ;
  (* share -- it is safe to share most properties,
      for arity, we might be careful, only [Alias] can share,
      since two values have same type, can have different arities
      TODO: check with reference pass, it might break 
      since it will create new identifier, we can avoid such issue??

      actually arity is a dynamic property, for a reference, it can 
      be changed across 
      we should treat
      reference specially. or maybe we should track any 
      mutable reference
  *)
  begin match let_kind with 
    | Alias -> 
      if not @@ Ident_set.mem meta.export_idents k 
      then
        Ident_hashtbl.add meta.alias_tbl k v 
    (** For [export_idents], we don't want to do such simplification
        if we do substitution, then it will affect exports...
    *)
    | Strict | StrictOpt(*can discard but not be substitued *) | Variable  -> ()
  end




(* How we destruct the immutable block 
   depend on the block name itself, 
   good hints to do aggressive destructing
   1. the variable is not exported
      like [matched] -- these are blocks constructed temporary
   2. how the variable is used 
      if it is guarateed to be 
      - non export 
      - and non escaped (there is no place it is used as a whole)
      then we can always destruct it 
      if some fields are used in multiple places, we can create 
      a temporary field 

   3. It would be nice that when the block is mutable, its 
       mutable fields are explicit, since wen can not inline an mutable block access
*)

let element_of_lambda (lam : Lam.t) : Lam_id_kind.element = 
  match lam with 
  | Lvar _ 
  | Lconst _ 
  | Lprim {primitive = Pfield _ ; 
           args =  [ Lglobal_module _ ];
           _} -> SimpleForm lam
  (* | Lfunction _  *)
  | _ -> NA 

let kind_of_lambda_block (xs : Lam.t list) : Lam_id_kind.t = 
  ImmutableBlock( Ext_array.of_list_map xs (fun x -> 
    element_of_lambda x ))

let field_flatten_get
   lam v i (tbl : Lam_id_kind.t Ident_hashtbl.t) : Lam.t =
  match Ident_hashtbl.find_opt tbl v  with 
  | Some (Module g) -> 
    Lam.prim ~primitive:(Pfield (i, Lam_compat.Fld_na)) 
      ~args:[ Lam.global_module g ] Location.none
  | Some (ImmutableBlock (arr)) -> 
    begin match arr.(i) with 
      | NA -> lam ()
      | SimpleForm l -> l
      | exception _ -> lam ()
    end
  | Some (Constant (Const_block (_,_,ls))) -> 
    begin match Ext_list.nth_opt ls i with 
    | None -> lam  ()
    | Some x -> Lam.const x
    end
  | Some _
  | None -> lam ()


(* TODO: check that if label belongs to a different 
    namesape
*)
let count = ref 0 

let generate_label ?(name="") ()  = 
  incr count; 
  Printf.sprintf "%s_tailcall_%04d" name !count

let log_counter = ref 0


let dump env ext  lam = 

      ()
      
  




let is_function (lam : Lam.t) = 
  match lam with 
  | Lfunction _ -> true | _ -> false

let not_function (lam : Lam.t) = 
  match lam with 
  | Lfunction _ -> false | _ -> true 
(* 
let is_var (lam : Lam.t) id =   
  match lam with 
  | Lvar id0 -> Ident.same id0 id 
  | _ -> false *)

  
(* TODO: we need create 
   1. a smart [let] combinator, reusable beta-reduction 
   2. [lapply fn args info] 
   here [fn] should get the last tail
   for example 
   {[
     lapply (let a = 3 in let b = 4 in fun x y -> x + y) 2 3 
   ]}   
*)









end
module String_hash_set : sig 
#1 "string_hash_set.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


include Hash_set_gen.S with type key = string

end = struct
#1 "string_hash_set.ml"
# 1 "ext/hash_set.cppo.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
# 31 "ext/hash_set.cppo.ml"
type key = string 
let key_index (h :  _ Hash_set_gen.t ) (key : key) =
  (Bs_hash_stubs.hash_string  key) land (Array.length h.data - 1)
let eq_key = Ext_string.equal 
type  t = key  Hash_set_gen.t 


# 64 "ext/hash_set.cppo.ml"
let create = Hash_set_gen.create
let clear = Hash_set_gen.clear
let reset = Hash_set_gen.reset
let copy = Hash_set_gen.copy
let iter = Hash_set_gen.iter
let fold = Hash_set_gen.fold
let length = Hash_set_gen.length
let stats = Hash_set_gen.stats
let elements = Hash_set_gen.elements



let remove (h : _ Hash_set_gen.t) key =  
  let i = key_index h key in
  let h_data = h.data in
  let old_h_size = h.size in 
  let new_bucket = Hash_set_gen.remove_bucket eq_key key h (Array.unsafe_get h_data i) in
  if old_h_size <> h.size then  
    Array.unsafe_set h_data i new_bucket



let add (h : _ Hash_set_gen.t) key =
  let i = key_index h key  in 
  let h_data = h.data in 
  let old_bucket = (Array.unsafe_get h_data i) in
  if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then 
    begin 
      Array.unsafe_set h_data i (key :: old_bucket);
      h.size <- h.size + 1 ;
      if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h
    end

let of_array arr = 
  let len = Array.length arr in 
  let tbl = create len in 
  for i = 0 to len - 1  do
    add tbl (Array.unsafe_get arr i);
  done ;
  tbl 
  
    
let check_add (h : _ Hash_set_gen.t) key =
  let i = key_index h key  in 
  let h_data = h.data in  
  let old_bucket = (Array.unsafe_get h_data i) in
  if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then 
    begin 
      Array.unsafe_set h_data i  (key :: old_bucket);
      h.size <- h.size + 1 ;
      if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h;
      true 
    end
  else false 


let mem (h :  _ Hash_set_gen.t) key =
  Hash_set_gen.small_bucket_mem eq_key key (Array.unsafe_get h.data (key_index h key)) 

  

end
module Lam_coercion : sig 
#1 "lam_coercion.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


type t = {
  export_list : Ident.t list ;
  export_set : Ident_set.t;
  export_map : Lam.t Ident_map.t ; 
  groups : Lam_group.t list ; 
}   


val coerce_and_group_big_lambda : 
    Lam_stats.t ->
    Lam.t -> 
    t * Lam_stats.t
end = struct
#1 "lam_coercion.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)





(*
  Invariant: The last one is always [exports]
  Compile definitions
  Compile exports
  Assume Pmakeblock(_,_),
  lambda_exports are pure
  compile each binding with a return value

  Such invariant  might be wrong in toplevel (since it is all bindings)

  We should add this check as early as possible
*)

(*
- {[ Ident.same id eid]} is more  correct,
        however, it will introduce a coercion, which is not necessary,
        as long as its name is the same, we want to avoid
        another coercion
        In most common cases, it will be
   {[
     let export/100 =a fun ..
         export/100
   ]}
        This comes from we have lambda as below
   {[
     (* let export/100 =a export/99  *)
     (* above is probably the cause but does not have to be  *)
     (export/99)
   ]}
        [export/100] was not eliminated due to that it is export id,
        if we rename export/99 to be export id, then we don't need
        the  coercion any more, and export/100 will be dced later
   - avoid rebound
   check [map.ml] here coercion, we introduced
                    rebound which is not corrrect
   {[
     let Make/identifier = function (funarg){
         var $$let = Make/identifier(funarg);
                 return [0, ..... ]
       }
   ]}
                    Possible fix ?
                    change export identifier, we should do this in the very
                    beginning since lots of optimizations depend on this
                    however
*)

type t = {
  export_list : Ident.t list ;
  export_set : Ident_set.t;
  export_map : Lam.t Ident_map.t ;
  (** not used in code generation, mostly used
      for store some information in cmj files *)
  groups : Lam_group.t list ;
  (* all code to be compiled later = original code + rebound coercions *)
}


let handle_exports (meta : Lam_stats.t)
    (lambda_exports : Lam.t list)  (reverse_input : Lam_group.t list) =

  let (original_exports : Ident.t list) = meta.exports in
  let (original_export_set : Ident_set.t) = meta.export_idents in
  let len = List.length original_exports in
  let tbl = String_hash_set.create len in
  let ({export_list ; export_set  ;  groups = coercion_groups } as result)  =
    Ext_list.fold_right2 original_exports
      lambda_exports
      {export_list = []; export_set = original_export_set; export_map = Ident_map.empty; groups = []}
      (fun  (original_export_id : Ident.t) (lam : Lam.t) (acc : t)  ->
         let original_name = original_export_id.name in
         if not @@ String_hash_set.check_add tbl original_name then
           Bs_exception.error (Bs_duplicate_exports original_name);
         (match lam  with
          | Lvar id ->
            if
             Ident.name id = original_name then
            { acc with
              export_list = id :: acc.export_list ;
              export_set =
                if id.stamp = original_export_id.stamp then acc.export_set
                else (Ident_set.add (Ident_set.remove acc.export_set original_export_id) id )
            }
            else
             let newid = Ident.rename original_export_id in
             let kind : Lam_compat.let_kind = Alias in
             Lam_util.alias_ident_or_global meta newid id NA kind;
              { acc with
              export_list = newid :: acc.export_list;
              export_map = Ident_map.add acc.export_map newid lam ;
              groups = Single(kind, newid, lam) :: acc.groups
              }
          | _ ->
            (*
              Example:
              {[
              let N = [a0,a1,a2,a3]
              in [[ N[0], N[2]]]

              ]}
              After optimization
              {[
                [ [ a0, a2] ]
              ]}
              Here [N] is elminated while N is still exported identifier
              Invariant: [eid] can not be bound before
              FIX: this invariant is not guaranteed.
              Bug manifested: when querying arity info about N, it returns an array
              of size 4 instead of 2
              *)
             let newid = Ident.rename original_export_id in
             (
                let arity = Lam_arity_analysis.get_arity meta lam in  
                if not (Lam_arity.first_arity_na arity) then 
                Ident_hashtbl.add meta.ident_tbl newid
                (FunctionId{arity ; lambda = 
                match lam with 
                | Lfunction _ -> 
                  Some (lam,  Lam_non_rec)
                | _ -> None })
              );
            { acc with
              export_list = newid :: acc.export_list;
              export_map = Ident_map.add acc.export_map newid lam ;
              groups = Single(Strict, newid, lam) :: acc.groups
            })
      )
      

  in

  let (export_map, coerced_input) =
    Ext_list.fold_left reverse_input (result.export_map, result.groups)
      (fun (export_map, acc) x ->
         (match x with
          | Single (_,id,lam) when Ident_set.mem export_set id 
            -> Ident_map.add export_map id lam 
              (** relies on the Invariant that [eoid] can not be bound before
                  FIX: such invariant may not hold
              *)
          | _ -> export_map), x :: acc )  in
  { result with export_map ; groups = Lam_dce.remove export_list coerced_input }

(** TODO: more flattening,
    - also for function compilation, flattening should be done first
    - [compile_group] and [compile] become mutually recursive function
*)
;;
let rec flatten
    (acc :  Lam_group.t list )
    (lam : Lam.t) :  Lam.t *  Lam_group.t list =
  match lam with
  | Llet (str,id,arg,body) ->
    let (res,l) = flatten acc arg  in
    flatten (Single(str, id, res ) :: l) body
  | Lletrec (bind_args, body) ->
    flatten
      (
        Recursive bind_args :: acc
      )
      body
  | Lsequence (l,r) ->
    let (res, l)  = flatten acc l in
    flatten (Lam_group.nop_cons res  l)  r
  | x ->
    x, acc

(** Invarinat to hold:
    [export_map] is sound, for every rebinded export id, its key is indeed in
    [export_map] since we know its old bindings are no longer valid, i.e
    Lam_stats.t is not valid
*)
let coerce_and_group_big_lambda
    (meta : Lam_stats.t)
    lam : t * Lam_stats.t =
  match flatten [] lam with
  | Lprim {primitive = Pmakeblock _;  args = lambda_exports }, reverse_input
    ->
    let coerced_input =
      handle_exports
      meta lambda_exports reverse_input  in
    coerced_input,
      {meta with export_idents = coerced_input.export_set ;
        exports = coerced_input.export_list}
  | _ ->
    (* This could happen see #2474*)
    (* #3595 
    TODO: FIXME later
    *)
    assert false
    (* {
      export_list = meta.exports;
      export_set = meta.export_idents;
      export_map = Ident_map.empty ;
      (** not used in code generation, mostly used
          for store some information in cmj files *)
      groups = [Nop lam] ;
      (* all code to be compiled later = original code + rebound coercions *)
    }
    , meta *)


end
module Js_arr : sig 
#1 "js_arr.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)







val set_array : J.expression -> J.expression -> J.expression -> J.expression

val ref_array : J.expression -> J.expression -> J.expression

end = struct
#1 "js_arr.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






module E = Js_exp_make
 
let set_array  e e0 e1 = 
  E.assign (E.array_index e e0)  e1

let ref_array  e e0 = 
  E.array_index  e  e0

end
module Js_ast_util : sig 
#1 "js_ast_util.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






val named_expression : 
  J.expression -> (J.statement * Ident.t) option

end = struct
#1 "js_ast_util.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






module E = Js_exp_make 

module S = Js_stmt_make  


let rec named_expression (e : J.expression)
  :  (J.statement  * Ident.t) option = 
  if Js_analyzer.is_okay_to_duplicate e then 
    None 
  else 
    let obj = Ext_ident.create_tmp () in 
    let obj_code = 
      S.define_variable
        ~kind:Strict obj e in 
    Some (obj_code, obj)

end
module Js_of_lam_array : sig 
#1 "js_of_lam_array.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Utilities for creating Array of JS IR *)

val make_array : J.mutable_flag -> J.expression list -> J.expression
(** create an array *)

val set_array : J.expression -> J.expression -> J.expression -> J.expression
(** Here we don't care about [array_kind],  
    In the future, we might used TypedArray for FloatArray
 *)

val ref_array :  J.expression -> J.expression -> J.expression
end = struct
#1 "js_of_lam_array.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(*
   construct array,
   set array,
   ref array,

   Also make sure, don't call any primitive array method, i.e [E.array_index_by_int] 

   We also need check primitive [caml_make_vect], i.e, 
   [Caml_primitive['caml_make_vect']] see if it's correct 

   [caml_make_vect]
   [caml_array_sub]
   [caml_array_append]
   [caml_array_concat]
   [caml_make_float_vect]
   [caml_array_blit]

   research: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Typed_arrays


 *)

module E  = Js_exp_make


(* Parrayref(u|s) *)
let make_array mt  args = 
  E.array ~comment:"array" mt args 
 
let set_array  e e0 e1 = 
  E.assign (E.array_index e e0)  e1

let ref_array  e e0 = 
  E.array_index  e  e0
end
module Js_of_lam_record : sig 
#1 "js_of_lam_record.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






(** Utilities for compiling lambda record into JS IR *)

(* val make : J.mutable_flag -> (string * J.expression) list -> J.expression *)


val field : Lam_compat.field_dbg_info -> J.expression -> J.jsint ->J.expression


end = struct
#1 "js_of_lam_record.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








module E = Js_exp_make 




(* TODO: add label to the comment *)
(* let make  mutable_flag (args : (string * J.expression) list) = *)
(*   E.make_block ~comment:"record"  *)
(*     E.zero_int_literal empty_record_info (Ext_list.map snd args) mutable_flag *)



let field (field_info : Lam_compat.field_dbg_info) e i =
  match field_info with 
  | Fld_na -> 
    E.array_index_by_int e i 

  | Fld_record_inline s
  | Fld_record_extension s 

  | Fld_record s 
  | Fld_module s 
    -> E.array_index_by_int ~comment:s e i



end
module Lam_beta_reduce_util : sig 
#1 "lam_beta_reduce_util.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)







val simple_beta_reduce : 
  Ident.t list -> Lam.t -> Lam.t list -> Lam.t option

end = struct
#1 "lam_beta_reduce_util.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






(* 
   Principle: since in ocaml, the apply order is not specified 
   rules:
   1. each argument it is only used once, (avoid eval duplication)
   2. it's actually used, if not (Lsequence)
   3. no nested  compuation, 
      other wise the evaluation order is tricky (make sure eval order is correct)
*)

type value = 
  { mutable used : bool ; 
    lambda  : Lam.t
  }
let param_hash :  _ Ident_hashtbl.t = Ident_hashtbl.create 20
let simple_beta_reduce params body args = 
  let module E = struct exception Not_simple_apply end in
  let rec find_param v  opt = 
    match Ident_hashtbl.find_opt param_hash v with 
    | Some exp ->  
      if exp.used then raise E.Not_simple_apply
      else exp.used <- true; exp.lambda
    | None -> opt
  in  
  let rec aux acc (us : Lam.t list) = 
    match us with 
    | [] -> List.rev acc
    | (Lvar x as a ) :: rest 
      -> 
      aux  (find_param x a  :: acc) rest 
    | (Lconst  _  as u) :: rest 
      -> aux (u :: acc) rest 
    | _ :: _ -> raise E.Not_simple_apply 
  in 
  match (body : Lam.t) with 
  | Lprim { primitive ; args =  args' ; loc}  (* There is no lambda in primitive *)
    -> (* catch a special case of primitives *)
    (* Note in a very special case we can avoid any allocation
       {[
         when Ext_list.for_all2_no_exn
             (fun p a ->
                match (a : Lam.t) with
                | Lvar a -> Ident.same p a
                | _ -> false ) params args'
       ]}*)
    let () = 
      List.iter2 (fun p a -> Ident_hashtbl.add param_hash p {lambda = a; used = false }) params args  
    in 
    begin match aux [] args' with 
    | args -> 
      let result = 
        Ident_hashtbl.fold (fun _param {lambda; used} code -> 
            if not used then
              Lam.seq lambda code
            else code) param_hash (Lam.prim ~primitive ~args loc) in 
      Ident_hashtbl.clear param_hash;
      Some result 
    | exception _ -> 
      Ident_hashtbl.clear param_hash ;
      None
    end
  | Lapply { fn = Lvar fn_name as f ; args =  args';  loc; status}
    ->  
    let () = 
      List.iter2 (fun p a -> Ident_hashtbl.add param_hash p {lambda = a; used = false }) params args  
    in 
    (*since we adde each param only once, 
      iff it is removed once, no exception, 
      if it is removed twice there will be exception.
      if it is never removed, we have it as rest keys 
    *)
    begin match aux [] args' with 
      | us -> 
        let f = find_param fn_name  f in
        let result = 
          Ident_hashtbl.fold 
            (fun _param {lambda; used} code -> 
               if not used then 
                 Lam.seq lambda code
               else code )
            param_hash (Lam.apply  f us  loc status) in
        Ident_hashtbl.clear param_hash;
        Some result 
      | exception _ -> 
        Ident_hashtbl.clear param_hash; 
        None
    end
  | _ -> None

end
module Lam_bounded_vars : sig 
#1 "lam_bounded_vars.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


(** [rewrite tbl lam] 
    Given a [tbl] to rewrite all bounded variables in [lam] 
*)
val rewrite : Lam.t Ident_hashtbl.t -> Lam.t -> Lam.t

(** refresh lambda to replace all bounded vars for new ones *)
val refresh : 
  Lam.t -> 
  Lam.t 

end = struct
#1 "lam_bounded_vars.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



(*
   Given an [map], rewrite all let bound variables into new variables, 
   note that the [map] is changed
   example    
   {[
     let a/112 = 3 in a/112      
   ]}
   would be converted into 
   {[
     let a/113 = 3 in a/113     
   ]}   

   ATTENTION: [let] bound idents have to be renamed, 
   Note we rely on an invariant that parameter could not be rebound 
 *)

(* 
  Small function inline heuristics:
  Even if a function is small, it does not mean it is good for inlining,
  for example, in list.ml
   {[
     let rec length_aux len = function
         [] -> len
       | a::l -> length_aux (len + 1) l

     let length l = length_aux 0 l
   ]}   
   if we inline [length], it will expose [length_aux] to the user, first, it make 
   the code not very friendly, also since [length_aux] is used everywhere now, it 
   may affect that we will not do the inlining of [length_aux] in [length]

   Criteior for sure to inline   
   1. small size, does not introduce extra symbols, non-exported and non-recursive   
      non-recursive is required if we re-apply the strategy

   Other Factors:   
   2. number of invoked times
   3. arguments are const or not   
*)
let rewrite (map :   _ Ident_hashtbl.t) 
    (lam : Lam.t) : Lam.t = 

  let rebind i = 
    let i' = Ident.rename i in 
    Ident_hashtbl.add map i (Lam.var i');
    i' in
  (* order matters, especially for let bindings *)
  let rec 
    option_map op = 
    match op with 
    | None -> None 
    | Some x -> Some (aux x)
  and aux (lam : Lam.t) : Lam.t = 
    match lam with 
    | Lvar v ->
      Ident_hashtbl.find_default map v lam 
    | Llet(str, v, l1, l2) ->
      let v = rebind v in
      let l1 = aux l1 in      
      let l2 = aux l2 in
      Lam.let_ str v  l1  l2 
    | Lletrec(bindings, body) ->
      (*order matters see GPR #405*)
      let vars = Ext_list.map bindings (fun (k,_) -> rebind k) in 
      let bindings = Ext_list.map2 vars bindings (fun var (_,l) -> var, aux l) in 
      let body = aux body in       
      Lam.letrec bindings body
    | Lfunction{arity;  params; body} -> 
      let params =  Ext_list.map params rebind in
      let body = aux body in      
      Lam.function_ ~arity ~params ~body
    | Lstaticcatch(l1, (i,xs), l2) -> 
      let l1 = aux l1 in
      let xs = Ext_list.map xs rebind in
      let l2 = aux l2 in
      Lam.staticcatch l1 (i,xs) l2
    | Lfor(ident, l1, l2, dir, l3) ->
      let ident = rebind ident in 
      let l1 = aux l1 in
      let l2 = aux l2 in
      let l3 = aux l3 in
      Lam.for_ ident (aux  l1)  l2 dir  l3
    | Lconst _ -> lam
    | Lprim {primitive; args ; loc} ->
      (* here it makes sure that global vars are not rebound *)      
      Lam.prim ~primitive ~args:(Ext_list.map args aux) loc
    | Lglobal_module _ -> lam 
    | Lapply {fn;  args; loc;  status } ->
      let fn = aux fn in       
      let args = Ext_list.map args aux in 
      Lam.apply fn  args loc status
    | Lswitch(l, {sw_failaction; 
                  sw_consts; 
                  sw_blocks;
                  sw_numblocks;
                  sw_numconsts;
                 }) ->
      let l = aux l in
      Lam.switch l
              {sw_consts = 
                 Ext_list.map_snd  sw_consts aux;
               sw_blocks = Ext_list.map_snd  sw_blocks aux;
               sw_numconsts = sw_numconsts;
               sw_numblocks = sw_numblocks;
               sw_failaction =  option_map sw_failaction
              }
    | Lstringswitch(l, sw, d) ->
      let l = aux  l in
      Lam.stringswitch l 
                     (Ext_list.map_snd sw aux)
                     (option_map d)
    | Lstaticraise (i,ls) 
      -> Lam.staticraise i (Ext_list.map ls aux)
    | Ltrywith(l1, v, l2) -> 
      let l1 = aux l1 in
      let v = rebind v in
      let l2 = aux l2 in
      Lam.try_ l1 v l2
    | Lifthenelse(l1, l2, l3) -> 
      let l1 = aux l1 in
      let l2 = aux l2 in
      let l3 = aux l3 in
      Lam.if_ l1  l2   l3
    | Lsequence(l1, l2) -> 
      let l1 = aux l1 in
      let l2 = aux l2 in
      Lam.seq l1 l2
    | Lwhile(l1, l2) -> 
      let l1 = aux l1 in
      let l2 = aux l2 in
      Lam.while_  l1  l2
    | Lassign(v, l) 
      -> Lam.assign v (aux  l)
    | Lsend(u, m, o, ll, v) ->
      let m = aux m in 
      let o = aux o in 
      let ll = Ext_list.map ll aux in
      Lam.send u  m  o  ll v
  in 
  aux lam


let refresh lam = rewrite (Ident_hashtbl.create 17 : Lam.t Ident_hashtbl.t ) lam

end
module Js_of_lam_module : sig 
#1 "js_of_lam_module.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






val make :
  ?comment:string ->
  J.expression list -> J.expression


end = struct
#1 "js_of_lam_module.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






module E = Js_exp_make 

let make ?comment (args : J.expression list) =
  E.make_block
    ?comment E.zero_int_literal
    (Blk_module None) args Immutable


end
module Lam_compile_global : sig 
#1 "lam_compile_global.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Compile ocaml external module call , e.g [List.length] to  JS IR *)

val expand_global_module :  Ident.t -> Env.t   -> J.expression



val expand_global_module_as_lam : Ident.t -> Env.t -> Lam.t

end = struct
#1 "lam_compile_global.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








module E = Js_exp_make  
module S = Js_stmt_make

(* TODO: used in functor inlining, so that it can not be an exception
   Make(S), S can not be an exception
*)



let expand_global_module_as_lam id env = 
  Lam_compile_env.query_and_add_if_not_exist 
    (Lam_module_ident.of_ml id) 
    (Has_env env)
    ~not_found:(fun id -> assert false)
    ~found:(fun {signature ; _} 
             -> 
               Lam.prim
                 ~primitive:(Pmakeblock(0, Blk_module None, Immutable))  
                 ~args:(
                   let len = Ocaml_types.length signature in 
                   Ext_list.init len (fun i  -> 
                       Lam.prim
                         ~primitive:(Pfield (i, Lambda.Fld_na)) 
                         ~args:[ Lam.global_module id  ] Location.none)
                 )
                 Location.none (* FIXME*))


(* Given an module name,  find its expanded structure  *)  
let expand_global_module  id env  : J.expression = 
  Lam_compile_env.query_and_add_if_not_exist 
    (Lam_module_ident.of_ml id) 
    (Has_env env)
    ~not_found:(fun _ -> assert false)
    ~found:(fun   {signature; _} -> 
        Js_of_lam_module.make ~comment:id.name 
          (Ocaml_types.map (fun name -> E.ml_var_dot id name) signature )
      )




end
module Lam_var_stats : sig 
#1 "lam_var_stats.mli"
(* Copyright (C) 2018 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



type stats 
val fresh_stats: stats  
val top_and_used_zero_or_one : stats -> bool 

type position 
val sink : position 
val fresh_env: position 
val new_position_after_lam: Lam.t -> position -> position  

(** The variable used stats update depend 
    on the position of the variable*)
val update : position -> stats -> stats 
end = struct
#1 "lam_var_stats.ml"
(* Copyright (C) 2018 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


let loop_use = 100 (** Used in loop, huge punishment *)

type stats = 
  { 
    top : bool ; 
    (* all appearances are in the top,  substitution is fine 
       whether it is pure or not
       {[
         (fun x y          
           ->  x + y + (f x )) (32) (console.log('hi'), 33)
       ]}       
       since in ocaml, the application order is intentionally undefined, 
       note if [times] is not one, this field does not make sense       
    *)    
    times : int ; 
  }



let fresh_stats  : stats = { top = true; times = 0 }  
let sink_stats : stats = { top = false; times = loop_use}
let stats top times = {top; times}
let top_and_used_zero_or_one x = 
  match x with
  | {top = true; times = 0 | 1} -> true
  | _ -> false
type position = 
  | Begin (* top = true ; loop = false *)
  | Not_begin (* top = false; loop = false *)
  | Sink (* loop = true *)


let update (pos : position) (v : stats) : stats =  
  match pos with 
  | Begin -> { v with times = v.times + 1}
  | Not_begin -> { top = false;  times = v.times + 1}
  | Sink -> sink_stats


let sink : position = Sink
let fresh_env : position = Begin


(* no side effect, if argument has no side effect and used only once we can simply do the replacement *)
let new_position_after_lam lam (env : position) : position = 
  if not (env = Begin) || Lam_analysis.no_side_effects lam then env 
  else Not_begin


end
module Lam_beta_reduce : sig 
#1 "lam_beta_reduce.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Beta reduction of lambda IR *)


val beta_reduce : Ident.t list -> Lam.t -> Lam.t list -> Lam.t
(* Compile-time beta-reduction of functions immediately applied:
      Lapply(Lfunction(Curried, params, body), args, loc) ->
        let paramN = argN in ... let param1 = arg1 in body
      Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock(args))], loc) ->
        let paramN = argN in ... let param1 = arg1 in body
   Assumes |args| = |params|.
*)

(*
   Refresh all the identifiers, 
   otherwise the identifier property can not be preserved, 
   the obvious example is parameter
 *)

val propogate_beta_reduce : 
  Lam_stats.t -> 
  Ident.t list -> 
  Lam.t -> 
  Lam.t list -> 
  Lam.t



(** 
   {[ Lam_beta_reduce.propogate_beta_reduce_with_map 
       meta param_map
       params body args]}

   [param_map] collect the usage of parameters, it's readonly
   it can be  produced by 

   {[!Lam_analysis.free_variables meta.export_idents 
       (Lam_analysis.param_map_of_list params) body]}

   TODO:
   replace [propogate_beta_reduce] with such implementation 
   {[
     let propogate_beta_reduce meta params body args = 
       let (_, param_map) = 
         Lam_analysis.is_closed_with_map Ident_set.empty params body in 
       propogate_beta_reduce_with_map meta param_map params body args  
   ]}
*)
val propogate_beta_reduce_with_map : 
  Lam_stats.t ->
  Lam_var_stats.stats Ident_map.t ->
  Ident.t list ->
  Lam.t -> Lam.t list -> Lam.t

end = struct
#1 "lam_beta_reduce.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)










(* 
    A naive beta reduce would break the invariants of the optmization.


    The sane but slowest  way:
      when we do a beta reduction, we need rename all variables inlcuding 
      let-bound ones

    A conservative one:
      - for internal one 
        rename params and let bound variables
      - for external one (seriaized)
        if it's enclosed environment should be good enough
        so far, we only inline enclosed lambdas
    TODO: rename 

   Optimizations:   
   {[
     (fun x y -> ...     ) 100 3 
   ]}   
   we can bound [x] to [100] in a single step     
 *)
let propogate_beta_reduce 
    (meta : Lam_stats.t) params body args =
  match Lam_beta_reduce_util.simple_beta_reduce params body  args with 
  | Some x -> x 
  | None -> 
  let rest_bindings, rev_new_params  = 
    Ext_list.fold_left2 params args ([],[]) (fun old_param arg (rest_bindings, acc) -> 
         match arg with          
         | Lconst _
         | Lvar _  -> rest_bindings , arg :: acc 
         | _ -> 
           let p = Ident.rename old_param in 
           (p,arg) :: rest_bindings , (Lam.var p) :: acc 
      )  in
  let new_body = Lam_bounded_vars.rewrite (Ident_hashtbl.of_list2 (List.rev params) (rev_new_params)) body in
  Ext_list.fold_right rest_bindings new_body
    (fun (param, arg ) l -> 
       let arg = 
         match arg with 
         | Lvar v -> 
           begin 
             match Ident_hashtbl.find_opt meta.ident_tbl v with 
             | None -> ()
             | Some ident_info -> 
               Ident_hashtbl.add meta.ident_tbl param ident_info 
           end;
           arg 
         | Lglobal_module ident   
         -> 
           (* It's not completeness, its to make it sound.. 
              Pass global module as an argument
           *)
           Lam_compile_global.expand_global_module_as_lam ident meta.env 
         (* alias meta param ident (Module (Global ident)) Strict *)
         | Lprim {primitive = Pmakeblock (_, _, Immutable) ;args ; _} -> 

           Ident_hashtbl.replace meta.ident_tbl param 
             (Lam_util.kind_of_lambda_block args ); (** *)
           arg           
         | Lprim {primitive = Psome | Psome_not_nest; args = [v]; _} -> 
           Ident_hashtbl.replace meta.ident_tbl param 
            (Normal_optional(v));
           arg
         | _ -> arg in
       Lam_util.refine_let ~kind:Strict param arg l) 
     

let propogate_beta_reduce_with_map  
    (meta : Lam_stats.t) (map : Lam_var_stats.stats Ident_map.t ) params body args =
  match Lam_beta_reduce_util.simple_beta_reduce params body args with
  | Some x -> x
  | None ->
  let rest_bindings, rev_new_params  = 
    Ext_list.fold_left2 params args ([],[])  
      (fun old_param arg (rest_bindings, acc) -> 
         match arg with          
         | Lconst _
         | Lvar _  -> rest_bindings , arg :: acc 
         | Lglobal_module ident 
           (* We can pass Global, but you also need keep track of it*)
           ->
           let p = Ident.rename old_param in 
           (p,arg) :: rest_bindings , (Lam.var p) :: acc 

         | _ -> 
           if  Lam_analysis.no_side_effects arg then
             match Ident_map.find_exn map old_param with 
             | exception Not_found -> assert false 
             | stat -> 
               if Lam_var_stats.top_and_used_zero_or_one stat then 
                 rest_bindings, arg :: acc                
               else 
                 let p = Ident.rename old_param in 
                 (p,arg) :: rest_bindings , (Lam.var p) :: acc 
           else
             let p = Ident.rename old_param in 
             (p,arg) :: rest_bindings , (Lam.var p) :: acc ) in
  let new_body = Lam_bounded_vars.rewrite (Ident_hashtbl.of_list2 (List.rev params) (rev_new_params)) body in
  Ext_list.fold_right rest_bindings new_body
    (fun (param, (arg : Lam.t)) l -> 
       let arg = 
         match arg with 
         | Lvar v -> 
           begin 
             match Ident_hashtbl.find_opt meta.ident_tbl v with 
             | None -> ()
             | Some ident_info -> 
               Ident_hashtbl.add meta.ident_tbl param ident_info 
           end;
           arg 
          | Lglobal_module ident 
          -> 
           (* It's not completeness, its to make it sound.. *)
           Lam_compile_global.expand_global_module_as_lam ident meta.env 
         (* alias meta param ident (Module (Global ident)) Strict *)
         | Lprim {primitive = Pmakeblock (_, _, Immutable ) ; args} -> 
           Ident_hashtbl.replace meta.ident_tbl param 
             (Lam_util.kind_of_lambda_block args ); (** *)
           arg
         | Lprim {primitive = Psome | Psome_not_nest; args = [v]} -> 
           Ident_hashtbl.replace meta.ident_tbl param 
            (Normal_optional(v));
           arg 
         | _ -> arg in
       Lam_util.refine_let ~kind:Strict param arg l) 
     



let beta_reduce params body args =
  match Lam_beta_reduce_util.simple_beta_reduce params body args with 
  | Some x -> x 
  | None -> 
    Ext_list.fold_left2 params args body 
      (fun param arg l ->
         Lam_util.refine_let ~kind:Strict param arg l)
    

end
module Lam_closure : sig 
#1 "lam_closure.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

(** [is_closed_by map lam]
    return [true] if all unbound variables
    belongs to the given [map] *)
(* val is_closed_by : Ident_set.t -> Lam.t -> bool *)

val is_closed : Lam.t -> bool


(** The output is mostly used in betat reduction *)
val is_closed_with_map : 
  Ident_set.t ->
  Ident.t list -> 
  Lam.t -> 
  bool * Lam_var_stats.stats Ident_map.t

val free_variables : 
  Ident_set.t -> 
  Lam_var_stats.stats Ident_map.t -> 
  Lam.t -> 
  Lam_var_stats.stats Ident_map.t


end = struct
#1 "lam_closure.ml"
(* Copyright (C) 2017 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)





type position = Lam_var_stats.position
type stats = Lam_var_stats.stats

let adjust ( pos : position) (v : Ident.t) (fv : stats Ident_map.t) : stats Ident_map.t = 
  Ident_map.adjust fv v
    (fun v -> 
      let stat = match v with None -> Lam_var_stats.fresh_stats | Some v -> v in 
      Lam_var_stats.update pos stat)
    
    



let param_map_of_list lst : stats Ident_map.t = 
  Ext_list.fold_left lst Ident_map.empty 
    (fun acc l -> Ident_map.add acc l Lam_var_stats.fresh_stats ) 

let sink_pos = Lam_var_stats.sink    
(** Sanity check, remove all varaibles in [local_set] in the last pass *)  


(**
   [param_stats = free_variables exports param_stats lam] 
   This function tries to do more than detect free variable of [lam],  
   given [param_stats] it tries to return a new stats with updated usage of 
   recorded params and unbound parameters

   An enriched version of [free_varaibles] in {!Lam_free_variables}
*)
let free_variables 
    (export_idents : Ident_set.t ) 
    (params : stats Ident_map.t ) 
    (lam : Lam.t )
  : stats Ident_map.t = 
  let fv = ref params in
  let local_set = ref export_idents in
  let local_add k =
    local_set := Ident_set.add !local_set k in
  let local_add_list ks = 
    local_set :=  
      Ext_list.fold_left ks !local_set Ident_set.add in    
  (* base don the envrionmet, recoring the use cases of arguments 
     relies on [identifier] uniquely bound *)    
  let used (cur_pos : position) (v : Ident.t) = 

    if not (Ident_set.mem !local_set v) then 
      fv := adjust cur_pos v !fv in

  let rec iter (top : position) (lam : Lam.t) =
    match lam with 
    | Lvar v -> used top v 
    | Lconst _ -> ()
    | Lapply {fn; args; _} ->
      iter top  fn; 
      let top = Lam_var_stats.new_position_after_lam fn top in
      Ext_list.iter args (fun lam -> iter top lam ) 
    | Lprim {args ; _} -> 
      (* Check: can top be propoaged for all primitives *)
      Ext_list.iter args (iter top) 
    | Lglobal_module _ -> ()
    | Lfunction{ params; body} ->
      local_add_list params;
      iter sink_pos body (* Do we need continue *)
    | Llet(_, id, arg, body) ->
      iter top arg;
      local_add id ;  
      iter sink_pos body
    | Lletrec(decl, body) ->
      local_set := Ext_list.fold_left decl !local_set  (fun acc (id, _) -> 
          Ident_set.add acc id) ;        
      Ext_list.iter decl (fun (_, exp) -> iter sink_pos exp);
      iter sink_pos body
    | Lswitch(arg, 
              ({sw_consts; 
                sw_blocks; 
                sw_failaction;
                sw_numconsts;
                sw_numblocks
               })) ->
      iter top arg; 
      let top = Lam_var_stats.new_position_after_lam arg top  in       
      List.iter (fun (_, case) -> iter top case) sw_consts;
      List.iter (fun (_, case) -> iter top  case) sw_blocks;
      (match sw_failaction with 
       | None -> ()
       | Some x ->
         if  sw_numconsts || sw_numblocks
         then iter top x 
         else iter sink_pos x)      
    | Lstringswitch (arg,cases,default) ->
      iter top arg ;
      let top = Lam_var_stats.new_position_after_lam arg top  in       
      List.iter (fun (_,act) -> iter top  act) cases ;
      (match default with 
       | None -> ()
       | Some x -> iter top x )      
    | Lstaticraise (_,args) ->
      List.iter (iter sink_pos ) args
    | Lstaticcatch(e1, (_,vars), e2) ->
      iter sink_pos  e1; 
      local_add_list vars;       
      iter sink_pos e2
    | Ltrywith(e1, exn, e2) ->
      iter top  e1; iter sink_pos  e2
    | Lifthenelse(e1, e2, e3) ->
      iter top e1; 
      let top = Lam_var_stats.new_position_after_lam e1 top  in
      iter top e2; iter top e3
    | Lsequence(e1, e2) ->
      iter top e1; iter sink_pos e2
    | Lwhile(e1, e2) ->
      iter sink_pos e1; iter sink_pos e2 (* in the loop, no substitution any way *)
    | Lfor(v, e1, e2, dir, e3) ->
      local_add v ; 
      iter sink_pos e1; iter sink_pos e2; iter sink_pos e3
    | Lassign(id, e) ->
      used top  id ; 
      iter top e
    | Lsend (_k, met, obj, args, _) ->
      iter sink_pos met ; 
      iter sink_pos obj;
      List.iter (iter sink_pos) args in
  iter Lam_var_stats.fresh_env  lam ; 
  !fv 


let is_closed_by (set : Ident_set.t) (lam : Lam.t) : bool = 
  Ident_map.is_empty (free_variables set (Ident_map.empty ) lam   )


(** A bit consverative , it should be empty *)
let is_closed  lam = 
  Ident_map.for_all (free_variables Ident_set.empty Ident_map.empty lam)
    (fun k _ -> Ident.global k)
      


let is_closed_with_map 
  (exports : Ident_set.t) 
  (params : Ident.t list) 
  (body : Lam.t) : bool * stats Ident_map.t = 
  let param_map = free_variables exports (param_map_of_list params) body in
  let old_count = List.length params in
  let new_count = Ident_map.cardinal param_map in
  (old_count  = new_count, param_map)




end
module Js_long : sig 
#1 "js_long.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






type int64_call = J.expression list -> J.expression  

val make_const : lo:Int32.t -> hi:Int32.t -> J.expression

val of_const : int64 -> J.expression

val to_int32 : int64_call

val of_int32 : int64_call
val comp : Lam_compat.comparison -> int64_call
val neg : int64_call
val add : int64_call
val sub : int64_call
val mul : int64_call
val div : int64_call
val xor : int64_call
val mod_ : int64_call
val lsl_ : int64_call
val lsr_ : int64_call
val asr_ : int64_call
val and_ : int64_call
val or_ : int64_call
val swap : int64_call
val min : int64_call
val max : int64_call

val equal_null : int64_call
val equal_undefined : int64_call
val equal_nullable : int64_call

val to_float : int64_call
val of_float : int64_call
val compare : int64_call
val of_string : int64_call
val float_of_bits : int64_call
val bits_of_float : int64_call  
val get64 : int64_call

end = struct
#1 "js_long.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






module E = Js_exp_make
type int64_call = J.expression list -> J.expression  

let int64_call (fn : string) args  = 
  E.runtime_call Js_runtime_modules.int64 fn args 


(* TODO: make layout easier to change later *)
let record_info : Lam_tag_info.t = Blk_record [| "hi"; "lo"|]
let make_const ~lo ~hi = 
  E.make_block 
    ~comment:"int64" (E.zero_int_literal) 
    record_info
    [E.int hi; E.to_uint32 @@ E.int lo ; ]
    (* If we use unsigned int for lo field, 
       then we can not use [E.int] which is 
       assumed to to be signed int.
       Or we can use [Int64] to encode 
       in the ast node?
    *)
    Immutable
let make ~lo ~hi = 
  E.make_block 
    ~comment:"int64" (E.zero_int_literal) 
    record_info [   hi; E.to_uint32 lo ]
    Immutable
let get_lo x = E.array_index_by_int x 1l
let get_hi x = E.array_index_by_int x 0l


(* below should  not depend on layout *)


let of_const (v : Int64.t) = 
  make_const
    ~lo:(Int64.to_int32 v )
    ~hi:(Int64.to_int32 (Int64.shift_right v 32))

let to_int32 args = 
  E.to_int32 @@ get_lo (Ext_list.singleton_exn args)
  

let of_int32 (args : J.expression list) = 
  match args with 
  | [{expression_desc = Number (Int {i}) ; _}] 
    -> 
    if i < 0l then make_const ~lo:i ~hi:(-1l)
    else make_const ~lo:i ~hi:0l
  | _ -> int64_call  "of_int32" args

let comp (cmp : Lam_compat.comparison) args = 
  E.runtime_call  Js_runtime_modules.int64
    (match cmp with 
     | Ceq -> "eq"
     | Cneq -> "neq"
     | Clt -> "lt"
     | Cgt -> "gt"
     | Cle -> "le"
     | Cge -> "ge") args 

let neg args = 
  int64_call "neg" args

let add args = 
  int64_call "add" args 

let sub args = 
  int64_call "sub" args

let mul args =  
  int64_call "mul" args

let div args =
  int64_call "div" args


(** Note if operands are not pure, we need hold shared value, 
    which is  a statement [var x = ... ; x ], it does not fit 
    current pipe-line fall back to a function call
*)
let bit_op  op runtime_call args = 
  match args  with 
  | [l;r] -> 
    (* Int64 is a block in ocaml, a little more conservative in inlining *)
    if Js_analyzer.is_okay_to_duplicate l  &&
       Js_analyzer.is_okay_to_duplicate r then 
      make ~lo:(op (get_lo l) (get_lo r))
        ~hi:(op (get_hi l) (get_hi r))
    else int64_call runtime_call args 
  | _ -> assert false

let xor  = bit_op E.int32_bxor "xor"
let or_ = bit_op E.int32_bor "or_"
let and_ = bit_op E.int32_band "and_"


let lsl_ args = 
  int64_call "lsl_" args

let lsr_ args = 
  int64_call "lsr_" args

let asr_ args = 
  int64_call "asr_" args

let mod_ args = 
  int64_call "mod_" args


let swap args = 
  int64_call "swap" args

(* Safe constant propgation 
   {[
     Number.MAX_SAFE_INTEGER:
       Math.pow(2,53) - 1
   ]}
   {[
     Number.MIN_SAFE_INTEGER:
       - (Math.pow(2,53) -1)
   ]}
   Note that [Number._SAFE_INTEGER] is in ES6, 
   we can hard code this number without bringing browser issue.
*)
let of_float (args : J.expression list ) = 
  int64_call "of_float" args

let compare (args : J.expression list) = 
  int64_call "compare" args 

let of_string (args : J.expression list) = 
  int64_call "of_string" args 
let get64 = int64_call "get64"
let float_of_bits  =  int64_call "float_of_bits" 
let bits_of_float = int64_call "bits_of_float"
let min args = 
  int64_call "min" args 
let max args = 
  int64_call "max" args


let equal_null args =   
  int64_call "equal_null" args  
let equal_undefined args =   
  int64_call "equal_undefined" args
let equal_nullable args =   
  int64_call "equal_nullable" args

let to_float (args : J.expression list ) = 
  match args with
  (* | [ {expression_desc  *)
  (*      = Caml_block (  *)
  (*          [lo =  *)
  (*           {expression_desc = Number (Int {i = lo; _}) }; *)
  (*           hi =  *)
  (*           {expression_desc = Number (Int {i = hi; _}) }; *)
  (*          ], _, _, _); _ }]  *)
  (*   ->  *)

  | [ _ ] -> 
    int64_call "to_float" args
  | _ -> 
    assert false    

end
module Js_of_lam_block : sig 
#1 "js_of_lam_block.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Utilities for creating block of lambda expression in JS IR *)

val make_block : 
  Js_op.mutable_flag -> Lam_tag_info.t ->
  J.expression -> J.expression list -> J.expression

val field : 
  Lam_compat.field_dbg_info -> 
  J.expression -> 
  J.jsint -> 
  J.expression

val field_by_exp : 
  J.expression -> 
  J.expression -> 
  J.expression  

val set_field : 
  Lam_compat.set_field_dbg_info -> 
  J.expression -> J.jsint -> J.expression -> J.expression

val set_field_by_exp :
  J.expression -> 
  J.expression -> 
  J.expression -> 
  J.expression
end = struct
#1 "js_of_lam_block.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








module E = Js_exp_make

(* TODO: it would be even better, if the [tag_info] contains more information
   about immutablility
 *)
let make_block mutable_flag (tag_info : Lam_tag_info.t) tag args  = 

  match tag_info with
  | Blk_array -> Js_of_lam_array.make_array mutable_flag  args
  |  _ -> E.make_block tag tag_info args mutable_flag
  (* | _, (  Tuple | Variant _ ) -> (\** TODO: check with inline record *\) *)
  (*     E.arr Immutable *)
  (*       (E.small_int  ?comment:(Lam_compile_util.comment_of_tag_info tag_info) tag   *)
  (*        :: args) *)
  (* | _, _  ->  *)
  (*     E.arr mutable_flag *)
  (*       (E.int  ?comment:(Lam_compile_util.comment_of_tag_info tag_info) tag   *)
  (*        :: args) *)

let field (field_info : Lam_compat.field_dbg_info) e i =
  match field_info with 
  | Fld_na -> 
    E.array_index_by_int e i 
 
  | Fld_record_inline comment
  | Fld_record_extension comment

  | Fld_record comment
  | Fld_module comment
    -> E.array_index_by_int ~comment e i

let field_by_exp e i = 
  E.array_index e i 


let set_field (field_info : Lam_compat.set_field_dbg_info) e i e0 =
  let comment = 
    match field_info with 
    | Fld_set_na 
      -> None

    | Fld_record_inline_set s
    | Fld_record_extension_set s
    
    | Fld_record_set s -> Some (s)
  in (* see GPR#631*)
  E.assign_by_int ?comment e i e0 

let set_field_by_exp self index value = 
  E.assign_by_exp self index value





end
module Js_of_lam_string : sig 
#1 "js_of_lam_string.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Utilities to wrap [string] and [bytes] compilation, 

   this is isolated, so that we can swap different representation in the future.
   [string] is Immutable, so there is not [set_string] method
*)

val ref_string : J.expression -> J.expression -> J.expression

val ref_byte : J.expression -> J.expression -> J.expression

val set_byte : J.expression -> J.expression -> J.expression -> J.expression 

val caml_char_of_int : ?comment:string -> J.expression -> J.expression

val caml_char_to_int : ?comment:string -> J.expression -> J.expression

val const_char : char -> J.expression

val bytes_to_string : J.expression -> J.expression

val bytes_of_string : J.expression -> J.expression

end = struct
#1 "js_of_lam_string.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)









module E = Js_exp_make



(* We use module B for string compilation, once the upstream can make changes to the 
    patten match of range patterns, we can use module [A] which means [char] is [string] in js, 
    currently, it follows the same patten of ocaml, [char] is [int]
*)

let const_char (i : char) = 
  E.int  ~comment:("\"" ^ Ext_string.escaped (String.make 1 i) ^ "\"") 
    ~c:i (Int32.of_int @@ Char.code i)

let caml_char_of_int ?comment (v : J.expression)  =  v

let caml_char_to_int ?comment v =  v

(* string [s[i]] expects to return a [ocaml_char] *)
let ref_string e e1 = 
  E.char_to_int (E.string_index e e1)

(* [s[i]] excepts to return a [ocaml_char]
   We use normal array for [bytes]
   TODO: we can use [Buffer] in the future 
*)
let ref_byte e e0  = E.array_index  e  e0

(* {Bytes.set : bytes -> int -> char -> unit }*)
let set_byte  e e0 e1 = 
  E.assign (E.array_index e e0)  e1

(**
   Note that [String.fromCharCode] also works, but it only 
   work for small arrays, however, for {bytes_to_string} it is likely the bytes 
   will become big
   {[
     String.fromCharCode.apply(null,[87,97])
       "Wa"
       String.fromCharCode(87,97)
       "Wa" 
   ]}
   This does not work for large arrays
   {[
     String.fromCharCode.apply(null, prim = Array[1048576]) 
       Maxiume call stack size exceeded
   ]}
*)
let bytes_to_string e = 
  E.runtime_call Js_runtime_modules.bytes "bytes_to_string" [e]
  
let bytes_of_string s =
  E.runtime_call Js_runtime_modules.bytes "bytes_of_string" [s]




end
module Lam_compile_const : sig 
#1 "lam_compile_const.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Compile lambda constant to JS *)

val translate : Lam_constant.t -> J.expression


val translate_arg_cst : External_arg_spec.cst -> J.expression

end = struct
#1 "lam_compile_const.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








module E = Js_exp_make

(** return [val < 0] if not nested [Some (Some (Some None))]*)
let rec is_some_none_aux (x : Lam_constant.t) acc = 
  match x with 
  | Const_some v -> is_some_none_aux v (acc + 1)
  | Const_js_undefined -> acc 
  | _ -> -1

let rec nested_some_none   n none = 
  if n  = 0 then none
  else nested_some_none (n - 1) (E.optional_block none)


let rec 
translate_some (x : Lam_constant.t) : J.expression = 
  let depth = is_some_none_aux x 0 in 
  if depth < 0 then E.optional_not_nest_block (translate x )
  else nested_some_none depth (E.optional_block (translate Const_js_undefined))
and translate (x : Lam_constant.t ) : J.expression = 
  match x with 
  | Const_some s ->  translate_some s   
  | Const_js_true -> E.bool true 
  | Const_js_false -> E.bool false
  | Const_js_null -> E.nil
  | Const_js_undefined -> E.undefined
  | Const_int i -> E.int (Int32.of_int i)
  | Const_char i ->
    Js_of_lam_string.const_char i
  | Const_int32 i -> E.int i 
  (* E.float (Int32.to_string i) *)
  | Const_int64 i -> 
          (*
            TODO:
       {[
         Int64.to_string 0x7FFFFFFFFFFFFFFFL;;
         - : string = "9223372036854775807"
       ]}
       {[
         Int64.(to_float max_int);;
         - : float = 9.22337203685477581e+18
       ]}
       Note we should compile it to Int64 as JS's 
       speical representation -- 
       it is not representatble in JS number
    *)
    (* E.float (Int64.to_string i) *)
    Js_long.of_const i
  (* https://github.com/google/closure-library/blob/master/closure%2Fgoog%2Fmath%2Flong.js *)
  | Const_nativeint i -> E.nint i 
  | Const_float f -> E.float f (* TODO: preserve float *)
  | Const_string i (*TODO: here inline js*) -> 
    E.str  i 
  | Const_unicode i -> 
    E.unicode i 


  | Const_pointer (c,pointer_info) ->     
    E.int ?comment:(Lam_compile_util.comment_of_pointer_info pointer_info)
      (Int32.of_int c )

  | Const_block(tag, tag_info, xs ) -> 
    Js_of_lam_block.make_block NA tag_info 
      (E.small_int  tag) (Ext_list.map xs translate)

  | Const_float_array ars -> 
    (* according to the compiler 
        const_float_array is immutable 
       {[ Lprim(Pccall prim_obj_dup, [master]) ]},
        however, we can not translate 
       {[ prim_obj_dup(x) =>  x' ]}
        since x' is now mutable, prim_obj_dup does a copy,

        the compiler does this  is mainly to extract common data into data section, 
        we  deoptimized this in js backend? so it is actually mutable 
    *)
    (* TODO-- *)
    Js_of_lam_array.make_array Mutable
      (Ext_list.map ars E.float )
  (* E.arr Mutable ~comment:"float array" *)
  (*   (Ext_list.map (fun x ->  E.float  x ) ars) *)

  | Const_immstring s ->  (*TODO *)
    E.str s  (* TODO: check *)

(* and translate_optional s = 
  let  b = 
  match s with 
  | Const_js_undefined -> E.optional_block (translate s) *)

let translate_arg_cst (cst : External_arg_spec.cst) = 
  match cst with 
   | Arg_int_lit i -> 
     E.int (Int32.of_int i)
   | Arg_string_lit i -> 
     E.str i
   | Arg_js_null  -> E.nil
   | Arg_js_json s 
     -> E.raw_js_code Exp s

   | Arg_js_true  -> E.bool true
   | Arg_js_false -> E.bool false 

end
module Js_of_lam_polyvar : sig 
#1 "js_of_lam_polyvar.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)




val get_tag : 
  J.expression -> 
  J.expression 

val get_field :   
  J.expression -> 
  J.expression 

end = struct
#1 "js_of_lam_polyvar.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

module E = Js_exp_make


 let get_tag (arg : J.expression) = 
  E.array_index_by_int arg 0l

let get_field (arg : J.expression) =   
  E.array_index_by_int arg 1l
end
module Js_of_lam_option : sig 
#1 "js_of_lam_option.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






type option_unwrap_time =
  | Static_unwrapped
  | Runtime_maybe_unwrapped


(** Given [Some a ], return [a] *)  
val val_from_option:
  J.expression -> 
  J.expression 

(** Given [Some x] or [None], return [x]*)  
val get_default_undefined_from_optional:
  J.expression -> 
  J.expression  

(** Given [Some (`a x)] or [None], 
    return [x] *)  
val get_default_undefined : 
  J.expression ->
  J.expression


val destruct_optional : 
  for_sure_none:'a ->
  for_sure_some:(J.expression -> 'a) ->
  not_sure:(unit -> 'a) ->
  J.expression -> 
  'a

val some : 
  J.expression -> 
  J.expression

val is_not_none :  
  J.expression ->
  J.expression

val null_to_opt : 
  J.expression -> 
  J.expression

val undef_to_opt : 
  J.expression -> 
  J.expression   

val null_undef_to_opt : 
  J.expression -> 
  J.expression  
end = struct
#1 "js_of_lam_option.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






module E = Js_exp_make 

type option_unwrap_time =
  | Static_unwrapped
  | Runtime_maybe_unwrapped

(** Another way: 
    {[
      | Var _  ->
        can only bd detected at runtime thing
          (E.triple_equal (E.typeof arg)
             (E.str "number"))
    ]}
*)
let none : J.expression = 
  E.undefined


let is_none_static (arg : J.expression_desc ) = arg = Undefined

let is_not_none  (e : J.expression) : J.expression = 
  let desc = e.expression_desc in 
  if is_none_static desc then E.false_
  else match desc with 
  | Optional_block _ -> E.true_
  | _ -> 
    E.not (E.triple_equal e none)
  
let val_from_option (arg : J.expression) =   
  match arg.expression_desc with 
  | Optional_block (x,_) -> x 
  | _ -> 
    E.runtime_call Js_runtime_modules.option
      "valFromOption" [arg]
(**
  Invrariant: 
  - optional encoding
  -  None encoding

  when no argumet is supplied, [undefined] 
  if we detect that all rest arguments are [null], 
  we can remove them


  - avoid duplicate evlauation of [arg] when it
   is not a variable
  {!Js_ast_util.named_expression} does not help 
   since we need an expression here, it might be a statement
*)

let get_default_undefined_from_optional
    (arg : J.expression)
    : J.expression =
  let desc = arg.expression_desc in 
  if is_none_static desc then E.undefined else 
  match desc with  
  | Optional_block (x,_) 
    -> x (* invariant: option encoding *)
  | _ ->
    if Js_analyzer.is_okay_to_duplicate arg then
      (* FIXME: no need do such inlining*)
      E.econd (is_not_none arg )
        (val_from_option arg) E.undefined
    else
      (E.runtime_call Js_runtime_modules.option "option_get" [arg])

let get_default_undefined (arg : J.expression) : J.expression =
  let desc = arg.expression_desc in
  if is_none_static desc then E.undefined else
  match desc with
  | Optional_block (x,_) 
    -> 
    Js_of_lam_polyvar.get_field x 
    (* invariant: option encoding *)
  | _ ->
    (* FIXME: no need do such inlining*)
    if Js_analyzer.is_okay_to_duplicate arg then
      E.econd (is_not_none arg) 
        (Js_of_lam_polyvar.get_field (val_from_option arg)) E.undefined
    else
      E.runtime_call Js_runtime_modules.option "option_get_unwrap" [arg]

let destruct_optional
  ~for_sure_none
  ~for_sure_some
  ~not_sure 
  (arg : J.expression)
  =       
  let desc = arg.expression_desc in 
  if is_none_static desc then for_sure_none else
  match desc with 
  | Optional_block (x,_) 
    ->
    for_sure_some x 
  | _ -> not_sure ()




let some  = E.optional_block 
  
let null_to_opt e = 
  E.econd (E.is_null e) none (some e)           


let undef_to_opt e = 
  E.econd (E.is_undef e)
  none (some e)

let null_undef_to_opt e = 
  E.econd 
  (E.is_null_undefined e)
  none 
  (some e)    
end
module Js_of_lam_variant : sig 
#1 "js_of_lam_variant.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

(* module E = Js_exp_make *)

type arg_expression = 
  | Splice0
  | Splice1 of J.expression 
  | Splice2 of J.expression * J.expression
  
val eval :
   J.expression -> (int * string) list -> J.expression
val eval_as_event : 
  J.expression -> (int * string) list -> arg_expression
val eval_as_int : 
  J.expression -> (int * int) list -> J.expression
val eval_as_unwrap : J.expression -> J.expression

end = struct
#1 "js_of_lam_variant.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

module E = Js_exp_make
module S = Js_stmt_make

type arg_expression =
  | Splice0
  | Splice1 of E.t
  | Splice2 of E.t * E.t

(* we need destruct [undefined] when input is optional *)
let eval (arg : J.expression) (dispatches : (int * string) list ) : E.t =
  if arg == E.undefined then E.undefined else
  match arg.expression_desc with
  | Number (Int {i} | Uint i) ->
    E.str (Ext_list.assoc_by_int  dispatches (Int32.to_int i) None)
  | _ ->
    E.of_block
      [(S.int_switch arg
      (Ext_list.map dispatches (fun (i,r) ->
              {J.switch_case = i ;
               switch_body = [S.return_stmt (E.str r)];
               should_break = false (* FIXME: if true, still print break*)
              })))]

(** invariant: optional is not allowed in this case *)
(** arg is a polyvar *)
let eval_as_event (arg : J.expression) (dispatches : (int * string) list ) =
  match arg.expression_desc with
  | Array ([{expression_desc = Number (Int {i} | Uint i)}; cb], _)
  | Caml_block([{expression_desc = Number (Int {i} | Uint i)}; cb], _, _, _)
    -> (* FIXME - to polyvar*)
    let v = Ext_list.assoc_by_int dispatches (Int32.to_int i) None in
    Splice2(E.str v , cb )
  | _ ->
    Splice2
      (E.of_block
      [(S.int_switch (Js_of_lam_polyvar.get_tag arg)
      (Ext_list.map dispatches (fun (i,r) ->
              {J.switch_case = i ;
               switch_body = [S.return_stmt (E.str r)];
               should_break = false (* FIXME: if true, still print break*)
              }) ))]
      , (* TODO: improve, one dispatch later,
           the problem is that we can not create bindings
           due to the
        *)
     (Js_of_lam_polyvar.get_field  arg)
      )
      (** FIXME:
        1. duplicated evaluation of expressions arg
           Solution: calcuate the arg once in the beginning
        2. avoid block for branches <  3
          or always?
          a === 444? "a" : a==222? "b"
      *)

(* we need destruct [undefined] when input is optional *)
let eval_as_int (arg : J.expression) (dispatches : (int * int) list ) : E.t  =
  if arg == E.undefined then E.undefined else
  match arg.expression_desc with
  | Number (Int {i} | Uint i) ->
    E.int (Int32.of_int (Ext_list.assoc_by_int dispatches (Int32.to_int i) None))
  | _ ->
    E.of_block
      [(S.int_switch arg
      (Ext_list.map dispatches (fun (i,r) ->
              {J.switch_case = i ;
               switch_body = [S.return_stmt (E.int (Int32.of_int  r))];
               should_break = false (* FIXME: if true, still print break*)
              }) ))]

let eval_as_unwrap (arg : J.expression) : E.t =
  match arg.expression_desc with
  | Caml_block ([{expression_desc = Number _}; cb], _, _, _) ->
    cb
  | _ ->
    Js_of_lam_polyvar.get_field arg 




end
module Lam_compile_external_call : sig 
#1 "lam_compile_external_call.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Compile ocaml external function call to JS IR. *) 
val ocaml_to_js_eff : 
  External_arg_spec.t -> 
  J.expression -> 
  Js_of_lam_variant.arg_expression * J.expression list  

val translate_ffi :
  Location.t -> 
  Lam_compile_context.t -> 
  External_arg_spec.t list -> 
  External_ffi_types.external_spec -> 
  J.expression list -> 
  J.expression 
  
(** TODO: document supported attributes
    Attributes starting with `js` are reserved
    examples: "bs.splice"
 *)

end = struct
#1 "lam_compile_external_call.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



[@@@warning "+9"]

module E = Js_exp_make

let splice_fn_apply fn args = 
  E.runtime_call
    Js_runtime_modules.caml_splice_call
    "spliceApply"
    [fn; E.array Immutable args]
let splice_obj_fn_apply obj name args =
  E.runtime_call
    Js_runtime_modules.caml_splice_call
    "spliceObjApply"
    [obj; E.str name; E.array Immutable args]
    
(** 
   [bind_name] is a hint to the compiler to generate 
   better names for external module 
*)
let handle_external 
    ({bundle ; module_bind_name} : External_ffi_types.external_module_name)
  : Ident.t * string 
  =
  Lam_compile_env.add_js_module module_bind_name bundle , 
  bundle

let handle_external_opt 
    (module_name : External_ffi_types.external_module_name option) 
  : (Ident.t * string) option = 
  match module_name with 
  | Some module_name -> Some (handle_external module_name) 
  | None -> None 


type arg_expression = Js_of_lam_variant.arg_expression = 
  | Splice0
  | Splice1 of E.t 
  | Splice2 of E.t * E.t

let append_list  x xs = 
  match x with 
  | Splice0 -> xs 
  | Splice1 a -> a::xs 
  | Splice2 (a,b) -> a::b::xs
(** The first return value is value, the second argument is side effect expressions 
    Only the [unit] with no label will be ignored
    When  we are passing a boxed value to external(optional), we need
    unbox it in the first place.

    Note when optional value is not passed, the unboxed value would be 
    [undefined], with the combination of `[@bs.int]` it would be still be 
    [undefined], this by default is still correct..  
    {[
      (function () {
           switch (undefined) {
             case 97 : 
               return "a";
             case 98 : 
               return "b";

           }
         }()) === undefined
    ]} 

     This would not work with [NonNullString]
*)
let ocaml_to_js_eff 
    ({arg_label;  arg_type }:  External_arg_spec.t)
    (raw_arg : E.t)
  : arg_expression * E.t list  =
  let arg =
    match arg_label with
    | Optional label -> 
      Js_of_lam_option.get_default_undefined_from_optional raw_arg
    | Label (_, None) | Empty None -> raw_arg
    | Label (_, Some _) 
    | Empty ( Some _)
      -> assert false in 
  match arg_type with
  | Arg_cst _ -> assert false 
  | Fn_uncurry_arity _ -> assert false  
  (* has to be preprocessed by {!Lam} module first *)
  | Extern_unit ->  
    (if arg_label = External_arg_spec.empty_label then 
      Splice0 else Splice1 E.unit), 
    (if Js_analyzer.no_side_effect_expression arg then 
       []
     else 
       [arg]) (* leave up later to decide *)
  | Ignore -> 
    Splice0, 
    (if Js_analyzer.no_side_effect_expression arg then 
       []
     else 
       [arg])
  | NullString dispatches -> 
    Splice1 (Js_of_lam_variant.eval arg dispatches),[]
  | NonNullString dispatches -> 
    Js_of_lam_variant.eval_as_event arg dispatches,[]    
    (* FIXME: encode invariant below in the signature*)
    (* length of 2
      - the poly var tag 
      - the value
     *)
  | Int dispatches -> 
    Splice1 (Js_of_lam_variant.eval_as_int arg dispatches),[]
  | Unwrap ->
    let single_arg =
      match arg_label with
      | Optional label ->
        (**
           If this is an optional arg (like `?arg`), we have to potentially do
           2 levels of unwrapping:
           - if ocaml arg is `None`, let js arg be `undefined` (no unwrapping)
           - if ocaml arg is `Some x`, unwrap the arg to get the `x`, then
             unwrap the `x` itself
        *)
        Js_of_lam_option.get_default_undefined raw_arg
      | _ ->
        Js_of_lam_variant.eval_as_unwrap raw_arg
    in
    Splice1 single_arg,[]
  | Nothing  ->  Splice1 arg, []



let empty_pair = [],[]       

let add_eff eff e =
  match eff with
  | None -> e 
  | Some v -> E.seq v e 


type specs = External_arg_spec.t list

type exprs = E.t list 
(* TODO: fix splice, 
   we need a static guarantee that it is static array construct
   otherwise, we should provide a good error message here, 
   no compiler failure here 
   Invariant : Array encoding
   @return arguments and effect
*)
let assemble_args_no_splice call_loc ffi  
  (arg_types : specs) 
  (args : exprs) : exprs * E.t option = 
  let rec aux (labels : specs) (args : exprs) : exprs * exprs = 
    match labels, args with 
    | [], _  
      -> assert (args = []) ; empty_pair
    | { arg_label =  Empty (Some cst) ; _} :: labels, args 
    | { arg_label =  Label (_, Some cst); _} :: labels, args -> 
      let accs, eff = aux labels args in
      Lam_compile_const.translate_arg_cst cst :: accs, eff 
    | ({arg_label = Empty None | Label (_,None) | Optional _ ;_ } as arg_kind) ::labels,
       arg :: args
      ->  
        let accs, eff = aux labels args in 
        let acc, new_eff = ocaml_to_js_eff arg_kind arg in 
        append_list acc  accs, Ext_list.append new_eff  eff
    | { arg_label = Empty None | Label (_,None) | Optional _  ; _ } :: _ , [] 
      -> assert false 
  in 
  let args, eff = aux arg_types args  in 
  args,
  begin  match eff with
    | [] -> None 
    | x::xs ->  (** FIXME: the order of effects? *)
      Some (E.fuse_to_seq x xs) 
  end
let assemble_args_has_splice call_loc ffi (arg_types : specs) (args : exprs) 
  : exprs * E.t option * bool = 
  let dynamic = ref false in 
  let rec aux (labels : specs) (args : exprs) = 
    match labels, args with       
    | [] , _ -> assert (args = []); empty_pair
    | { arg_label =  Empty (Some cst) ; _} :: labels  , args 
    | { arg_label =  Label (_, Some cst); _} :: labels  , args -> 
      let accs, eff = aux labels args in
      Lam_compile_const.translate_arg_cst cst :: accs, eff 
    | ({arg_label = Empty None | Label (_,None) | Optional _ ;_ } as arg_kind) ::labels,
      arg :: args
      ->  
      let accs, eff = aux labels args in 
      begin match args, (arg : E.t) with 
        | [], {expression_desc = Array (ls,_mutable_flag) ;_ } -> 
          Ext_list.append ls accs, eff 
        | _ -> 
          if args = [] then dynamic := true ; 
          let acc, new_eff = ocaml_to_js_eff arg_kind arg in 
          append_list acc  accs, Ext_list.append new_eff  eff 
      end
    | { arg_label = Empty None | Label (_,None) | Optional _  ; _ } :: _ , [] 
      -> assert false 
  in 
  let args, eff = aux arg_types args  in 
  args,
  (match eff with
    | [] -> None 
    | x::xs ->  (** FIXME: the order of effects? *)
      Some (E.fuse_to_seq x xs)), !dynamic
  

let translate_scoped_module_val module_name fn  scopes = 
  match handle_external_opt module_name with 
  | Some (id,external_name) ->
    begin match scopes with 
      | [] -> 
        E.external_var_dot ~external_name ~dot:fn id 
        (* E.dot (E.var id) fn *)
      | x :: rest -> 
        (* let start = E.dot (E.var id )  x in  *)
        let start = E.external_var_dot ~external_name ~dot:x id in 
        Ext_list.fold_left (Ext_list.append rest  [fn]) start E.dot
    end
  | None ->  
    (*  no [@@bs.module], assume it's global *)
    begin match scopes with 
      | [] -> 
        (* E.external_var_dot ~external_name ~dot:fn id  *)
        E.js_global fn
      | x::rest -> 
        let start = E.js_global x  in 
        Ext_list.fold_left (Ext_list.append rest  [fn]) start E.dot
    end

let translate_scoped_access scopes obj =
  match scopes with 
  | [] ->  obj
  | x::xs -> 
    Ext_list.fold_left xs (E.dot obj x) E.dot
  
let translate_ffi 
    call_loc 
    (cxt  : Lam_compile_context.t)
    arg_types 
    (ffi : External_ffi_types.external_spec ) 
    (args : J.expression list) = 
  match ffi with
  | Js_call{ external_module_name = module_name; 
             name = fn; splice; 
             scopes
           } -> 
    let fn =  translate_scoped_module_val module_name fn scopes in 
    if splice then 
      let args, eff, dynamic  = 
          assemble_args_has_splice   call_loc ffi  arg_types args in 
      add_eff eff 
        (if dynamic then splice_fn_apply fn args
         else E.call ~info:{arity=Full; call_info = Call_na} fn args)
    else 
      let args, eff  = assemble_args_no_splice   call_loc ffi  arg_types args in 
      add_eff eff @@              
      E.call ~info:{arity=Full; call_info = Call_na} fn args

  | Js_module_as_fn {external_module_name = module_name; splice} ->
    let fn =
      let (id, name) = handle_external  module_name  in
      E.external_var_dot id ~external_name:name 
    in           
    if splice then 
      let args, eff, dynamic = 
          assemble_args_has_splice   call_loc ffi  arg_types args in 
      (* TODO: fix in rest calling convention *)          
      add_eff eff (
        if dynamic then
          splice_fn_apply fn args
        else 
          E.call ~info:{arity=Full; call_info = Call_na} fn args
      )              
    else 
      let args, eff = assemble_args_no_splice  call_loc ffi  arg_types args in 
      (* TODO: fix in rest calling convention *)          
      add_eff eff (E.call ~info:{arity=Full; call_info = Call_na} fn args)

  | Js_new { external_module_name = module_name; 
             name = fn;
             scopes
           } -> (* handle [@@bs.new]*)
    (* This has some side effect, it will 
       mark its identifier (If it has) as an object,
       ATTENTION: 
       order also matters here, since we mark its jsobject property, 
       it  will affect the code gen later
       TODO: we should propagate this property 
       as much as we can(in alias table)
    *)
    let args, eff = assemble_args_no_splice call_loc ffi  arg_types args in
    let fn =  translate_scoped_module_val module_name fn scopes in 
    add_eff eff 
      begin 
        (match cxt.continuation with 
         | Declare (_, id) | Assign id  ->
           (* Format.fprintf Format.err_formatter "%a@."Ident.print  id; *)
           Ext_ident.make_js_object id 
         | EffectCall _ | NeedValue _ -> ())
        ;
        E.new_ fn args
      end            

  | Js_send {splice ; name ; pipe ; js_send_scopes } -> 
    if pipe then 
      (* splice should not happen *)
      (* assert (js_splice = false) ;  *)
      if splice then 
        let args, self = Ext_list.split_at_last args in
        let arg_types, self_type = Ext_list.split_at_last arg_types in
        let args, eff, dynamic = assemble_args_has_splice call_loc ffi arg_types args in
        add_eff eff (          
          let self = translate_scoped_access js_send_scopes self in 
          if dynamic then
            splice_obj_fn_apply self name args 
          else 
            E.call ~info:{arity=Full; call_info = Call_na}  (E.dot self name) args)
      else 
        let args, self = Ext_list.split_at_last args in
        let arg_types, self_type = Ext_list.split_at_last arg_types in
        let args, eff = assemble_args_no_splice call_loc ffi  arg_types args in
        add_eff eff (
          let self = translate_scoped_access js_send_scopes self in 
          E.call ~info:{arity=Full; call_info = Call_na}  (E.dot self name) args)
    else    
      begin match args  with
        | self :: args -> 
          (* PR2162 [self_type] more checks in syntax:
             - should not be [bs.as] *)
          let [@warning"-8"] ( _self_type::arg_types )
            = arg_types in
          if splice then   
            let args, eff, dynamic = assemble_args_has_splice  call_loc ffi arg_types args in
            add_eff eff ( 
              let self = translate_scoped_access js_send_scopes self in 
              if dynamic then 
                splice_obj_fn_apply self name args 
              else               
                E.call ~info:{arity=Full; call_info = Call_na}  (E.dot self name) args)
          else 
            let args, eff = assemble_args_no_splice call_loc ffi  arg_types args in
            add_eff eff ( 
              let self = translate_scoped_access js_send_scopes self in 
              E.call ~info:{arity=Full; call_info = Call_na}  (E.dot self name) args)
        | _ -> 
          assert false 
      end

  | Js_module_as_var module_name -> 
    let (id, name) =  handle_external  module_name  in
    E.external_var_dot id ~external_name:name 

  | Js_var {name; external_module_name; scopes} -> 

    (* TODO #11
       1. check args -- error checking 
       2. support [@@bs.scope "window"]
       we need know whether we should call [add_js_module] or not 
    *)
      translate_scoped_module_val external_module_name name scopes


  | Js_module_as_class module_name ->
    let fn =
      let (id,name) = handle_external  module_name in
      E.external_var_dot id ~external_name:name  in           
    let args,eff = assemble_args_no_splice call_loc  ffi  arg_types args in 
    (* TODO: fix in rest calling convention *)   
    add_eff eff        
      begin 
        (match cxt.continuation with 
         | Declare (_, id) | Assign id  ->
           (* Format.fprintf Format.err_formatter "%a@."Ident.print  id; *)
           Ext_ident.make_js_object id 
         | EffectCall _ | NeedValue _ -> ())
        ;
        E.new_ fn args
      end            
  
  | Js_get {js_get_name = name; js_get_scopes = scopes } -> 
    let args,cur_eff = assemble_args_no_splice call_loc ffi  arg_types args in 
    add_eff cur_eff @@ 
    begin match args with 
      | [obj] ->
        let obj = translate_scoped_access scopes obj in 
        E.dot obj name        
      | _ -> assert false  (* Note these assertion happens in call site *)
    end  
  | Js_set {js_set_name = name; js_set_scopes = scopes  } -> 
    (* assert (js_splice = false) ;  *)
    let args,cur_eff = assemble_args_no_splice call_loc ffi  arg_types args in 
    add_eff cur_eff @@
    begin match args, arg_types with 
      | [obj; v], _ -> 
        let obj = translate_scoped_access scopes obj in
        E.assign (E.dot obj name) v         
      | _ -> 
        assert false 
    end
  | Js_get_index { js_get_index_scopes = scopes }
    -> 
    let args,cur_eff = assemble_args_no_splice call_loc ffi  arg_types args in 
    add_eff cur_eff @@ 
    begin match args with
      | [obj; v ] -> 
        Js_arr.ref_array (translate_scoped_access scopes obj) v 
      | _ -> assert false 
    end
  | Js_set_index { js_set_index_scopes = scopes }
    -> 
    let args,cur_eff = assemble_args_no_splice call_loc ffi arg_types args in 
    add_eff cur_eff @@ 
    begin match args with 
      | [obj; v ; value] -> 
          Js_arr.set_array (translate_scoped_access scopes obj) v value
      | _ -> assert false
    end


end
module Lam_compile_external_obj : sig 
#1 "lam_compile_external_obj.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Compile ocaml external function call to JS IR. *) 

(** 
    This module define how the FFI (via `external`) works with attributes. 
    Note it will route to {!Lam_compile_global} 
    for compiling normal functions without attributes.
 *)

val assemble_obj_args :
  External_arg_spec.t list -> 
  J.expression list -> 
  J.block * J.expression 
(* It returns a block in cases we need set the property dynamically: we need
  create a place holder assignment first and then set it accordingly
*)



end = struct
#1 "lam_compile_external_obj.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)




module E = Js_exp_make
module S = Js_stmt_make

(* Note: can potentially be inconsistent, sometimes 
   {[
     { x : 3 , y : undefined}
   ]}
   and 
   {[
     {x : 3 }
   ]}
   But the default to be undefined  seems reasonable 
*)

(* TODO: check stackoverflow *)
let assemble_obj_args (labels : External_arg_spec.t list)  (args : J.expression list) 
  : J.block * J.expression = 
   let rec aux (labels : External_arg_spec.t list) args 
    : (Js_op.property_name * E.t ) list  * J.expression list * _ = 
    match labels, args with 
    | [] , []  ->  [], [], []
    | {arg_label = Label (label, Some cst )} :: labels  , args -> 
      let accs, eff, assign = aux labels args in 
      (label, Lam_compile_const.translate_arg_cst cst )::accs, eff, assign 
    | {arg_label = Empty (Some _) } :: rest  , args -> assert false 
    | {arg_label = Empty None }::labels, arg::args 
      ->  (* unit type*)
      let (accs, eff, assign) as r  = aux labels args in 
      if Js_analyzer.no_side_effect_expression arg then r 
      else (accs, arg::eff, assign)
    | ({arg_label = Label (label,None)  } as arg_kind)::labels, arg::args 
      -> 
      let accs, eff, assign = aux labels args in 
      let acc, new_eff = Lam_compile_external_call.ocaml_to_js_eff arg_kind arg in 
      begin match acc with 
        | Splice2 _ 
        | Splice0 -> assert false
        | Splice1 x ->
          (label, x) :: accs , Ext_list.append new_eff  eff , assign          
      end (* evaluation order is undefined *)

    | ({arg_label = Optional label; arg_type } as arg_kind)::labels, arg::args 
      -> 
      let (accs, eff, assign) as r = aux labels args  in 
      Js_of_lam_option.destruct_optional arg 
        ~for_sure_none:r 
        ~for_sure_some:(fun x -> let acc, new_eff = Lam_compile_external_call.ocaml_to_js_eff 
            ({arg_label = External_arg_spec.label label None; arg_type}) x in 
          begin match acc with 
          | Splice2 _
          | Splice0 -> assert false 
          | Splice1 x ->
            (label, x) :: accs , Ext_list.append new_eff  eff , assign
          end )
        ~not_sure:(fun _ -> accs, eff , (arg_kind,arg)::assign )
    | {arg_label = Empty None | Label (_,None) | Optional _  } :: _ , [] -> assert false 
    | [],  _ :: _  -> assert false 
  in 
  let map, eff, assignment = aux labels args in 
  match assignment with 
  | [] -> 
    [],  begin  match eff with
      | [] -> 
        E.obj map 
      | x::xs -> E.seq (E.fuse_to_seq x xs) (E.obj map)
    end
  | _ ->     
    let v  = Ext_ident.create_tmp () in 
    let var_v = E.var v in 
    S.define_variable ~kind:Variable v 
    (begin match eff with
      | [] -> 
        E.obj map 
      | x::xs -> E.seq (E.fuse_to_seq x xs) (E.obj map)     
    end) :: 
      (Ext_list.flat_map assignment (fun 
        ((xlabel : External_arg_spec.t), (arg  : J.expression )) -> 
      match xlabel with 
      | {arg_label = Optional label } -> 
        (* Need make sure whether assignment is effectful or not
          to avoid code duplication
        *)
        begin match Js_ast_util.named_expression arg with 
        | None ->
          let acc,new_eff = 
            Lam_compile_external_call.ocaml_to_js_eff 
            {xlabel with arg_label =
             External_arg_spec.empty_label}
              (Js_of_lam_option.val_from_option arg) in 
          begin match acc with 
          | Splice1 v  ->                         
            [S.if_ (Js_of_lam_option.is_not_none arg )
              [S.exp (E.assign (E.dot var_v label) 
            (
              match new_eff with 
              | [] -> v 
              | x :: xs ->
                E.seq (E.fuse_to_seq  x xs ) v
             ) ) ] ] 
          | Splice0 | Splice2 _ -> assert false
          end
        | Some (st,id) -> (* FIXME: see #2503 *)
          let arg = E.var id in         
          let acc,new_eff = 
            Lam_compile_external_call.ocaml_to_js_eff 
            {xlabel with arg_label =
             External_arg_spec.empty_label}
              (Js_of_lam_option.val_from_option arg) in 
          begin match acc with 
          | Splice1 v  ->        
            st ::  
            [S.if_ 
              (Js_of_lam_option.is_not_none arg) 
              [S.exp (E.assign (E.dot var_v label) 
              (match new_eff with 
              | [] -> v 
              | x :: xs ->
                E.seq (E.fuse_to_seq x xs) v 
              )) ]]
          | Splice0 | Splice2 _ -> assert false
          end 
        end 
      |  _ -> assert false    
      )
      )
    , var_v                    

end
module Bs_warnings : sig 
#1 "bs_warnings.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


type t =
  | Unsafe_poly_variant_type

val prerr_bs_ffi_warning : Location.t -> t -> unit


val warn_missing_primitive : Location.t -> string -> unit 

val warn_literal_overflow : Location.t -> unit 

val error_unescaped_delimiter : 
  Location.t -> string  -> unit 

end = struct
#1 "bs_warnings.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



type t =
  | Unsafe_poly_variant_type
  (* for users write code like this:
     {[ external f : [`a of int ] -> string = ""]}
     Here users forget about `[@bs.string]` or `[@bs.int]`
  *)    



let to_string t =
  match t with
  | Unsafe_poly_variant_type 
    -> 
    "Here a OCaml polymorphic variant type passed into JS, probably you forgot annotations like `[@bs.int]` or `[@bs.string]`  "

let warning_formatter = Format.err_formatter

let print_string_warning (loc : Location.t) x =   
  if loc.loc_ghost then 
    Format.fprintf warning_formatter "File %s@."  !Location.input_name      
  else 
    Location.print warning_formatter loc ; 
  Format.fprintf warning_formatter "@{<error>Warning@}: %s@." x 

let prerr_bs_ffi_warning loc x =  
    Location.prerr_warning loc (Warnings.Bs_ffi_warning (to_string x))

let unimplemented_primitive = "Unimplemented primitive used:" 
type error = 
  | Uninterpreted_delimiters of string
  | Unimplemented_primitive of string 
exception  Error of Location.t * error

let pp_error fmt x =
  match x with 
  | Unimplemented_primitive str -> 
    Format.pp_print_string fmt unimplemented_primitive;
    Format.pp_print_string fmt str
  
  | Uninterpreted_delimiters str -> 
    Format.pp_print_string fmt "Uninterpreted delimiters" ;
    Format.pp_print_string fmt str



let () = 
  Location.register_error_of_exn (function 
      | Error (loc,err) -> 
        Some (Location.error_of_printer loc pp_error err)
      | _ -> None
    )




let warn_missing_primitive loc txt =      
  if not !Js_config.no_warn_unimplemented_external && not !Clflags.bs_quiet then
    begin 
      print_string_warning loc ( unimplemented_primitive ^ txt ^ " \n" );
      Format.pp_print_flush warning_formatter ()
    end

let warn_literal_overflow loc = 
  if not !Clflags.bs_quiet then
  begin 
    print_string_warning loc 
      "Integer literal exceeds the range of representable integers of type int";
    Format.pp_print_flush warning_formatter ()  
  end 



let error_unescaped_delimiter loc txt = 
  raise (Error(loc, Uninterpreted_delimiters txt))






(**
   Note the standard way of reporting error in compiler:

   val Location.register_error_of_exn : (exn -> Location.error option) -> unit 
   val Location.error_of_printer : Location.t ->
   (Format.formatter -> error -> unit) -> error -> Location.error

   Define an error type

   type error 
   exception Error of Location.t * error 

   Provide a printer to error

   {[
     let () = 
       Location.register_error_of_exn
         (function 
           | Error(loc,err) -> 
             Some (Location.error_of_printer loc pp_error err)
           | _ -> None
         )
   ]}
*)

end
module Js_of_lam_exception : sig 
#1 "js_of_lam_exception.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






  
val get_builtin_by_name : string -> J.expression


val caml_set_oo_id : 
  J.expression list -> J.expression

val caml_fresh_oo_id :
  J.expression list -> J.expression

val make : J.expression  -> J.expression
(* val make_extension : J.expression  -> J.expression *)

end = struct
#1 "js_of_lam_exception.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






(** An pattern match on {!caml_set_oo_id args}
    Note that in the trunk, it is immutable by default now 
 *)
module E = Js_exp_make 


(* Sync up with [caml_set_oo_id] 
   Note if we inline {!Caml_exceptions.create}, 
   it seems can be useful for optimizations in theory, 
   in practice, it never happen, since the pattern match 
   never dig into it internally, so maybe {!Obj.set_tag} 
   is not necessary at all
*)
let make exception_str  : J.expression = 
  E.runtime_call Js_runtime_modules.exceptions Literals.create [exception_str]

(* let make_extension exception_str  : J.expression =  *)
(*   E.runtime_call Js_config.exceptions "makeExtension" [exception_str] *)


let get_builtin_by_name name = 
  E.runtime_ref Js_runtime_modules.builtin_exceptions (Ext_string.lowercase_ascii name)


(* let match_exception_def (args : J.expression list) =  *)
(*   match args with    *)
(*   | [{ expression_desc  =  *)
(*                Caml_block ( *)
(*                  [ exception_str;  *)
(*                    {expression_desc = J.Number (Int { i = 0l; _}); _} *)
(*                  ], *)
(*                  mutable_flag,  *)
(*                  {expression_desc = J.Number (Int {i = object_tag; _}); _}, _ ); *)
(*               _} ] ->  *)
(*     if object_tag = 248l (\* Obj.object_tag *\) then *)
(*       Some ( exception_str, mutable_flag)     *)
(*     else *)
(*       None *)
(*   | _ -> None *)

let caml_set_oo_id args = 
      (**
         If we can guarantee this code path is never hit, we can do 
         a better job for encoding of exception and extension?
      *)
      E.runtime_call Js_runtime_modules.exceptions "caml_set_oo_id" args 
    (* begin match match_exception_def args with  *)
    (* | Some ( exception_str, mutable_flag) *)
    (*   ->  *)
    (*   make_exception exception_str  *)
    (* | _ -> *)
    (* end *)
    
let caml_fresh_oo_id args = 
  E.runtime_call Js_runtime_modules.exceptions "caml_fresh_oo_id" args 
end
module Js_of_lam_float_record : sig 
#1 "js_of_lam_float_record.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






(** Compile a special representation in OCaml when all fields are of type [float] 
    check the invariant in {!Js_of_lam_array.make_array}
*)

val set_double_field : 
  Lam_compat.set_field_dbg_info -> 
  J.expression -> J.jsint -> 
  J.expression -> J.expression

val get_double_feild : 
  Lam_compat.field_dbg_info -> 
  J.expression -> J.jsint -> J.expression

end = struct
#1 "js_of_lam_float_record.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






module E = Js_exp_make 

let get_double_feild (field_info : Lam_compat.field_dbg_info) e i = 
  match field_info with 
  | Fld_na -> 
    E.array_index_by_int e i 
 
  | Fld_record_inline s
  | Fld_record_extension s

  | Fld_record s 
  | Fld_module s 
    -> E.array_index_by_int ~comment:s e i

let set_double_field (field_info : Lam_compat.set_field_dbg_info) e  i e0 = 
  let v = 
    match field_info with 
    | Fld_set_na 
      -> 
      E.array_index_by_int e i 
 
    | Fld_record_inline_set s
    | Fld_record_extension_set s 
      
    | Fld_record_set s -> 
      E.array_index_by_int ~comment:s e i 
  in 
  E.assign v  e0


end
module Js_of_lam_tuple : sig 
#1 "js_of_lam_tuple.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Utilities for compiling lambda tuple into JS IR *)

val make : J.expression list -> J.expression

end = struct
#1 "js_of_lam_tuple.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








module E = Js_exp_make

let make (args : J.expression list) =
  E.make_block E.zero_int_literal Blk_tuple args Immutable


end
module Lam_dispatch_primitive : sig 
#1 "lam_dispatch_primitive.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)









(** Compile lambda primitives (note this is different external c calls) *)


(** 
    @return None when the primitives are not handled in  pre-processing
*)
val translate : 
  Location.t ->
  string ->
  J.expression list -> J.expression 

end = struct
#1 "lam_dispatch_primitive.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)









module E = Js_exp_make  
module S = Js_stmt_make

(** not exhaustive *)
let args_const_unbox_approx_int_zero (args : J.expression list) = 
  match args with 
  | [ {expression_desc = Number (Int { i = 0l ; }) }] -> true 
  | _ -> false
let args_const_unbox_approx_int_one (args : J.expression list) = 
  match args with 
  | [ {expression_desc = Number (Int { i = 1l ; }) }] -> true 
  | _ -> false
let args_const_unbox_approx_int_two (args : J.expression list) = 
  match args with 
  | [ {expression_desc = Number (Int { i = 2l ; }) }] -> true 
  | _ -> false

(** 
   There are two things we need consider:
   1.  For some primitives we can replace caml-primitive with js primitives directly
   2.  For some standard library functions, we prefer to replace with javascript primitives
    For example [Pervasives["^"] -> ^]
    We can collect all mli files in OCaml and replace it with an efficient javascript runtime

   TODO: return type to be expression is ugly, 
   we should allow return block    
*)
let translate loc (prim_name : string) 
    (args : J.expression list) : J.expression  =
  let call m = 
    E.runtime_call m prim_name args in 
  begin match prim_name with 
    (* | "caml_gc_stat" 
    | "caml_gc_quick_stat"  
    | "caml_gc_get" *)
    | "caml_gc_counters"
    | "caml_gc_set"
    | "caml_gc_minor"
    | "caml_gc_major_slice"
    | "caml_gc_major"
    | "caml_gc_full_major"
    | "caml_gc_compaction"
    | "caml_final_register"
    | "caml_final_release"
      ->  call Js_runtime_modules.gc
    (* | "caml_abs_float" -> 
      E.math "abs" args  *)
    (* | "caml_acos_float" -> 
      E.math "acos" args  *)
    |  "caml_add_float" -> 
      begin match args with 
        | [e0;e1] -> E.float_add e0 e1 (** TODO float plus*)
        | _ -> assert false
      end
    |"caml_div_float" -> 
      begin match args with 
        | [e0;e1] -> E.float_div e0 e1
        | _ -> assert false 
      end
    |"caml_sub_float" -> 
      begin match args with 
        | [e0;e1] -> E.float_minus e0 e1 
        | _ -> assert false 
      end
    | "caml_eq_float" -> 
      begin match args with 
        | [e0;e1] -> E.float_equal e0 e1 
        | _ -> assert false 
      end
    | "caml_ge_float"  ->
      begin match args with 
        | [e0;e1] -> E.float_comp Cge e0 e1
        | _ -> assert false 
      end
    |"caml_gt_float"  ->
      begin match args with 
        | [e0;e1] -> E.float_comp Cgt  e0 e1
        | _ -> assert false 
      end
    (* | "caml_tan_float"  ->
      E.math "tan" args 
    | "caml_tanh_float"  ->
      E.math "tanh" args 
    | "caml_asin_float"  -> 
      E.math "asin" args 
    | "caml_atan2_float" -> 
      E.math "atan2" args
    | "caml_atan_float" -> 
      E.math "atan" args 
    | "caml_ceil_float" -> 
      E.math "ceil" args 
    | "caml_cos_float" -> 
      E.math "cos" args 
    | "caml_cosh_float" -> 
      E.math "cosh" args
    | "caml_exp_float" -> 
      E.math "exp" args
    | "caml_sin_float" -> 
      E.math "sin" args
    | "caml_sinh_float"-> 
      E.math "sinh" args
    | "caml_sqrt_float" -> 
      E.math "sqrt" args

 *)
    | "caml_float_of_int" -> 
      begin match args with 
        | [e] -> e 
        | _ -> assert false 
      end
    (* | "caml_floor_float" ->
      E.math "floor" args 
    | "caml_log_float" -> 
      E.math "log" args 
    | "caml_log10_float" -> 
      E.math "log10" args 
    | "caml_log1p_float" -> 
      E.math "log1p" args 
    | "caml_power_float"  -> 
      E.math "pow" args *)

    | "caml_array_get" -> 
      call Js_runtime_modules.array
    | "caml_array_get_addr"
    | "caml_array_get_float"
    | "caml_array_unsafe_get"
    | "caml_array_unsafe_get_float" -> 
      begin match args with 
        | [e0;e1] -> Js_of_lam_array.ref_array e0 e1
        | _ -> assert false
      end
    | "caml_array_set" ->
      call Js_runtime_modules.array
    | "caml_array_set_addr"
    | "caml_array_set_float"
    | "caml_array_unsafe_set"
    | "caml_array_unsafe_set_addr"
    | "caml_array_unsafe_set_float" -> 
      begin match args with 
        | [e0;e1;e2] -> 
          Js_of_lam_array.set_array e0 e1 e2
        | _ -> assert false
      end

    | "caml_int32_add"
      -> 
      begin match args with 
        | [e0;e1] -> E.int32_add e0 e1 
        | _ -> assert false 
      end

    | "caml_nativeint_add" 
      -> 
      begin match args with 
        | [e0;e1] -> E.unchecked_int32_add e0 e1 
        | _ -> assert false 
      end
    | "caml_int32_div" 
      -> 
      begin match args with 
        | [e0;e1] -> 
          E.int32_div  ~checked:(!Js_config.check_div_by_zero) e0 e1
        | _ -> assert false 
      end

    | "caml_nativeint_div" 
      -> (* nativeint behaves exactly the same as js numbers except division *)
      begin match args with 
        | [e0;e1] -> E.int32_div  ~checked:false e0 e1
        | _ -> assert false 
      end

    | "caml_int32_mul"
      -> 
      begin match args with 
        | [e0;e1] -> E.int32_mul e0 e1 
        | _ -> assert false 
      end
    | "caml_nativeint_mul"  -> 
      begin match args with 
        | [e0;e1] -> E.unchecked_int32_mul e0 e1 
        | _ -> assert false 
      end
    | "caml_int32_of_int"
    | "caml_nativeint_of_int" 
    | "caml_nativeint_of_int32" -> 
      begin match args with 
        | [e] -> e 
        | _ -> assert false 
      end
    | "caml_int32_of_float"
    | "caml_int_of_float"
    | "caml_nativeint_of_float" -> 
      begin match args with 
        | [e] -> E.to_int32 e 
        | _ -> assert false 
      end
    | "caml_int32_to_float"
    | "caml_int32_to_int"
    | "caml_nativeint_to_int" 
    | "caml_nativeint_to_float"
    | "caml_nativeint_to_int32" -> 
      begin match args with 
        | [e] -> e (* TODO: do more checking when [to_int32]*)
        | _ -> assert false 
      end
    | "caml_int32_sub" -> 
      begin match args with 
        | [e0;e1] -> E.int32_minus e0 e1 
        | _ -> assert false 
      end

    | "caml_nativeint_sub" ->
      begin match args with 
        | [e0;e1] -> E.unchecked_int32_minus e0 e1 
        | _ -> assert false 
      end
    | "caml_int32_xor" 
    | "caml_nativeint_xor" -> 
      begin match args with 
        | [e0; e1] -> E.int32_bxor e0 e1 
        | _ -> assert false 
      end

    | "caml_int32_and"
    | "caml_nativeint_and" -> 
      begin match args with 
        | [e0;e1] -> E.int32_band e0 e1 
        | _ -> assert false 
      end
    | "caml_int32_or"
    | "caml_nativeint_or" ->
      begin match args with
        | [e0;e1] -> E.int32_bor e0 e1 
        | _ -> assert false  
      end
    | "caml_le_float" ->
      begin match args with 
        | [e0;e1] -> E.float_comp Cle e0 e1 
        | _ -> assert false 
      end
    | "caml_lt_float" ->
      begin match args with 
        | [e0;e1] -> E.float_comp Clt e0 e1 
        | _ -> assert false 
      end
    |  "caml_neg_float" -> 
      begin match args with 
        | [e] -> 
          (** TODO: use float.. *)
          E.int32_minus E.zero_int_literal e 
        | _ -> assert false
      end
    | "caml_neq_float" -> 
      begin match args with 
        | [e0;e1] -> E.float_notequal e0 e1
        | _ -> assert false 
      end
    | "caml_mul_float" -> 
      begin match args with 
        | [e0; e1] -> E.float_mul e0 e1 
        | _ -> assert false  
      end

    | "caml_bytes_equal" ->   
      call Js_runtime_modules.caml_primitive
      
    | "caml_int64_equal_null"
      -> Js_long.equal_null args 
    | "caml_int64_equal_undefined"
      -> Js_long.equal_undefined args 
    | "caml_int64_equal_nullable" 
      -> Js_long.equal_nullable args 
      
    | "caml_int64_to_float"
      -> Js_long.to_float args
    | "caml_int64_of_float"
      -> Js_long.of_float args
    | "caml_int64_compare"
      -> Js_long.compare args     
    | "caml_int64_bits_of_float"
      -> Js_long.bits_of_float args     
    | "caml_int64_float_of_bits"
      -> Js_long.float_of_bits args 
    | "caml_int64_bswap"
      -> Js_long.swap args    
    | "caml_int64_min"       
      ->  Js_long.min args 
    | "caml_int64_max" 
      ->  Js_long.max args      
    | "caml_int32_float_of_bits"
    | "caml_int32_bits_of_float"

    | "caml_modf_float"
    | "caml_ldexp_float"
    | "caml_frexp_float"

    | "caml_copysign_float"
    | "caml_expm1_float"
    | "caml_hypot_float"

      ->
      call Js_runtime_modules.float
    | "caml_fmod_float" 
      (* float module like js number module *)      
      ->      
      begin match args with 
        | [e0;e1] -> E.float_mod e0 e1
        | _ -> assert false 
      end
   
    | "caml_string_equal" 
      -> 
      begin match args with 
        | [e0; e1] -> E.string_equal e0 e1 
        | _ -> assert false 
      end
    | "caml_string_notequal"
      -> 
      begin match args with 
        | [e0; e1] -> E.string_comp NotEqEq e0 e1
        (** TODO: convert to ocaml ones*)
        | _ -> assert false 
      end
    | "caml_string_lessequal"
      -> 
      begin match args with 
        | [e0; e1] 
          -> 
          E.string_comp Le e0 e1
        | _ -> assert false 
      end
    | "caml_string_lessthan"
      -> 
      begin match args with 
        | [e0; e1] 
          -> 
          E.string_comp Lt e0 e1
        | _ -> assert false 
      end
    | "caml_string_greaterequal"
      -> 
      begin match args with 
        | [e0; e1] 
          -> 
          E.string_comp Ge  e0 e1
        | _ -> assert false 
      end
    | "caml_string_greaterthan"
      -> 
      begin match args with 
        | [e0; e1] 
          -> 
          E.string_comp Gt  e0 e1
        | _ -> assert false 
      end  
    | "caml_bool_notequal"
      -> 
      begin match args with 
        | [e0; e1] -> E.bool_comp Cneq e0 e1
        (** TODO: specialized in OCaml ones*)
        | _ -> assert false 
      end
    | "caml_bool_lessequal"
      -> 
      begin 
        match args with 
        | [e0; e1] 
          -> 
          E.bool_comp Cle e0 e1
        | _ -> assert false 
      end
    | "caml_bool_lessthan"
      -> 
      begin match args with 
        | [e0; e1] 
          -> 
          E.bool_comp Clt e0 e1
        | _ -> assert false 
      end
    | "caml_bool_greaterequal"
      -> 
      begin match args with 
        | [e0; e1] 
          -> 
          E.bool_comp Cge  e0 e1
        | _ -> assert false 
      end
    | "caml_bool_greaterthan"    
      ->
       begin match args with 
       | [e0;e1] -> 
          E.bool_comp Cgt e0 e1
       | _ -> assert false
       end
    | "caml_bool_equal"  
    | "caml_bool_equal_null"
    | "caml_bool_equal_nullable"
    | "caml_bool_equal_undefined"
      -> 
        begin match args with 
        | [e0; e1] -> E.bool_comp Ceq e0 e1 
        | _ -> assert false 
        end 
    | "caml_int_equal_null"
    | "caml_int_equal_nullable"
    | "caml_int_equal_undefined"
    
    | "caml_int32_equal_null"
    | "caml_int32_equal_nullable"
    | "caml_int32_equal_undefined"
    

    | "caml_nativeint_equal_null"
    | "caml_nativeint_equal_nullable"
    | "caml_nativeint_equal_undefined"
      ->   
      begin match args with 
      | [e0;e1]
       -> E.int_comp Ceq e0 e1
      | _ -> assert false 
      end 
    
    | "caml_float_equal_null"
    | "caml_float_equal_nullable"
    | "caml_float_equal_undefined"
      ->   
      begin match args with 
      | [e0;e1]
       -> E.float_comp Ceq e0 e1
      | _ -> assert false 
      end 
    
    | "caml_string_equal_null"
    | "caml_string_equal_nullable"
    | "caml_string_equal_undefined"
      ->   
      begin match args with 
      | [e0;e1]
       -> E.string_comp EqEqEq e0 e1
      | _ -> assert false 
      end 



    | "caml_create_bytes"  

    | "caml_create_string" -> 
      (* Bytes.create *)
      (* Note that for invalid range, JS raise an Exception RangeError, 
         here in OCaml it's [Invalid_argument], we have to preserve this semantics.
          Also, it's creating a [bytes] which is a js array actually.
      *)
      begin match args with
        | [{expression_desc = Number (Int {i; _}); _}] 
          when i < 8l
          ->
          (*Invariants: assuming bytes are [int array]*)
          E.array NA 
            (if i = 0l then []
            else 
            Ext_list.init 
              (Int32.to_int i)
              (fun i -> E.zero_int_literal)
            )
        | _ -> 
          E.runtime_call Js_runtime_modules.bytes
            "caml_create_bytes" args
      end
    | "caml_bool_compare" ->   
      begin match args with 
      | [{expression_desc = Bool a} ; {expression_desc = Bool b} ] 
        ->  
          let c = compare a b in 
          E.int (if c = 0 then 0l else if c > 0 then 1l else -1l)
      | _ -> 
        call Js_runtime_modules.caml_primitive
      end
    | "caml_int_compare"
    | "caml_int32_compare"
    | "caml_nativeint_compare"
    | "caml_float_compare"
    | "caml_bytes_compare"
    | "caml_string_compare" 
    -> 
      call Js_runtime_modules.caml_primitive

    | "caml_bool_min"  
    | "caml_int_min"
    | "caml_float_min"
    | "caml_string_min"
    | "caml_nativeint_min"
    | "caml_int32_min"
    
      -> 
      begin match args with 
        | [a;b] ->
          if Js_analyzer.is_okay_to_duplicate a && Js_analyzer.is_okay_to_duplicate b then 
            E.econd (E.js_comp Clt a b) a b 
          else 
            call Js_runtime_modules.caml_primitive
        | _ -> assert false  
      end
    | "caml_bool_max"
    | "caml_int_max"
    | "caml_float_max"
    | "caml_string_max"
    | "caml_nativeint_max"
    | "caml_int32_max"    
    -> 
      begin match args with 
        | [a;b] -> 
          if Js_analyzer.is_okay_to_duplicate a && Js_analyzer.is_okay_to_duplicate b then 
            E.econd (E.js_comp Cgt a b) a b 
          else 
            call Js_runtime_modules.caml_primitive
        | _ -> assert false 
      end
    | "caml_fill_string"
    | "caml_fill_bytes"
      -> 
        E.runtime_call 
          Js_runtime_modules.bytes "caml_fill_bytes" args
    | "caml_is_printable" 
      -> 
      call Js_runtime_modules.char
    | "caml_string_get"    
      -> 
        call Js_runtime_modules.string
    | "bytes_to_string"
    | "bytes_of_string"
    | "caml_blit_string" 
    | "caml_blit_bytes"
      -> 
      call Js_runtime_modules.bytes

    | "caml_register_named_value" -> 
      (**
         callback.ml
         {[ external register_named_value : string -> Obj.t -> unit
           = "caml_register_named_value" ]}

         See the manual chap19, Interfacing C with OCaml

         {[
           let f x = print_string "f is applied to "; print_int x; print_newline()
           let _ = Callback.register "test function" f
         ]}

         On the C side 
         {[
           let f x = print_string "f is applied to "; print_int x; print_newline()
           let _ = Callback.register "test function" f
         ]}

         [caml_named_value] is a c primitive but not belong to OCaml/runtimedef.ml,
         so we don't needs
         handle it 
      *)
      E.unit

    | "caml_backtrace_status"


    | "caml_get_exception_backtrace"
    | "caml_get_exception_raw_backtrace"
    | "caml_record_backtrace"
    | "caml_convert_raw_backtrace" 
    | "caml_get_current_callstack"
      -> E.unit
    (* unit -> unit 
       _ -> unit  
       major_slice : int -> int 
    *)
    (** Note we captured [exception/extension] creation in the early pass, this primitive is 
        like normal one to set the identifier *)


    | "caml_fresh_oo_id" 
      ->
      Js_of_lam_exception.caml_fresh_oo_id args   

    | "caml_is_extension" ->
      call Js_runtime_modules.exceptions
    | "caml_as_js_exn" ->
      call Js_runtime_modules.caml_js_exceptions  
    | "caml_set_oo_id" (* needed in {!camlinternalOO.set_id} *)
      ->
      Js_of_lam_exception.caml_set_oo_id args 
    | "caml_sys_const_big_endian" -> 
      (** return false *)
      E.bool Sys.big_endian
    | "caml_sys_const_word_size" -> 
      E.small_int  Sys.word_size
    (** TODO: How it will affect program behavior *)
    | "caml_sys_const_ostype_cygwin" -> E.false_
    | "caml_sys_const_ostype_win32" -> E.false_
    | "caml_sys_const_ostype_unix" -> E.true_
    | "caml_sys_get_config" ->
      (** No cross compilation *)
      Js_of_lam_tuple.make [E.str Sys.os_type; E.small_int  Sys.word_size; 
                            E.bool Sys.big_endian ]
    | "caml_sys_get_argv" 
    (** TODO: refine
        Inlined here is helpful for DCE
        {[ external get_argv: unit -> string * string array = "caml_sys_get_argv" ]}
    *)
    (* Js_of_lam_tuple.make [E.str "cmd";  *)
    (*                       Js_of_lam_array.make_array NA Pgenarray [] *)
    (*                      ] *)
    | "caml_sys_time"
    | "caml_sys_random_seed"
    | "caml_sys_getenv"
    | "caml_sys_system_command" 
    | "caml_sys_getcwd" (* check browser or nodejs *)
    | "caml_sys_is_directory"
    | "caml_sys_exit"
      (* | "caml_sys_file_exists" *)
      -> 
      call Js_runtime_modules.sys
    | "caml_lex_engine"
    | "caml_new_lex_engine"
      -> 
      call Js_runtime_modules.lexer 
    | "caml_parse_engine"
    | "caml_set_parser_trace" 
      -> 
      call Js_runtime_modules.parser 
    | "caml_make_float_vect"
    
    | "caml_floatarray_create"
    
      ->
      E.runtime_call Js_runtime_modules.array 
        "caml_make_float_vect" args 
    | "caml_array_sub"
    | "caml_array_concat"
    (*external concat: 'a array list -> 'a array 
       Not good for inline *)
    | "caml_array_blit"    
    | "caml_make_vect" -> 
      call Js_runtime_modules.array
    | "caml_ml_flush"
    | "caml_ml_out_channels_list"
    | "caml_ml_output_char"
    | "caml_ml_output" 
      -> 
      call Js_runtime_modules.io

    | "caml_array_dup" -> 
      begin match args with 
        | [a]
          -> 
          begin match a.expression_desc with 
            | Array _ 
            | Caml_block _ -> a 
            (* here we created a temporary block
               and copied it
               and discarded it immediately
               This could be canceled              
            *)
            | _ -> call Js_runtime_modules.array
          end
        | _ -> assert false 
      end
    | "caml_obj_block" -> 
      (** TODO: Optimize  for [CamlinternalOO] input 
          external new_block : tag:int -> size:int  -> t = "caml_obj_block"
          Note that we don't need initialize its content anyway
          TODO: more optimizations later
          ATTENTION: This optmization is coupled with memory layout
      *)
      begin match args with 
        | [ tag; 
            {expression_desc = Number (Int { i ;_}); _} ] ->
          E.make_block tag Blk_na 
            (Ext_list.init (Int32.to_int i) 
               (fun _ -> E.zero_int_literal)) NA

        | [ _; _] -> 
          call Js_runtime_modules.obj_runtime
          (* E.uninitialized_object tag size *)
        | _ -> assert false


      end
    | "caml_format_float"

    | "caml_hexstring_of_float"  
    
    | "caml_nativeint_format"
    | "caml_int32_format"
    | "caml_float_of_string"
    | "caml_int_of_string" (* what is the semantics?*)
    | "caml_int32_of_string"
    | "caml_nativeint_of_string" 
    | "caml_int64_format"
    | "caml_int64_of_string"
    | "caml_format_int" 
      -> 
      call Js_runtime_modules.format 
    (*   "caml_alloc_dummy"; *)
    (* TODO:   "caml_alloc_dummy_float"; *)
    | "caml_obj_dup" 
    | "caml_update_dummy"
    | "caml_obj_truncate"
    | "caml_lazy_make_forward"  
      -> 
      call Js_runtime_modules.obj_runtime

    | "caml_notequal" ->
      begin match args with 
      | [a1;b1]  when 
        E.for_sure_js_null_undefined a1 
        || E.for_sure_js_null_undefined b1 
        -> 
        E.neq_null_undefined_boolean a1 b1 
      (* FIXME address_equal *)
      | _ -> 
        Location.prerr_warning loc Warnings.Bs_polymorphic_comparison ; 
        call Js_runtime_modules.obj_runtime
      end
    | "caml_equal"  ->     
      begin match args with 
      | [a1;b1]  when 
        E.for_sure_js_null_undefined a1 || E.for_sure_js_null_undefined b1 
        -> 
        E.eq_null_undefined_boolean a1 b1 
        (* FIXME address_equal *)
      | _ -> 
        Location.prerr_warning loc Warnings.Bs_polymorphic_comparison ; 
        call Js_runtime_modules.obj_runtime
      end
  
    | "caml_min"
    | "caml_max"
    | "caml_compare"    
    | "caml_greaterequal"
    | "caml_greaterthan"
    | "caml_lessequal"
    | "caml_lessthan"

    | "caml_equal_null"
    | "caml_equal_undefined"
    | "caml_equal_nullable"
      -> 

      Location.prerr_warning loc Warnings.Bs_polymorphic_comparison ; 
      call Js_runtime_modules.obj_runtime
    | "caml_obj_set_tag" 
      -> 
      call Js_runtime_modules.obj_runtime
    | "caml_obj_tag" -> 
      (* Note that in ocaml, [int] has tag [1000] and [string] has tag [252]
         also now we need do nullary check 
      *)      
      begin match args with 
        | [e] -> E.tag e 
        | _ -> assert false end

    (* End of Unix support *)
    (* bigarrary support *)
    | "caml_ba_init"
      -> 
      begin match args with 
        | [e] -> E.seq e E.unit 
        | _ -> assert false
      end
    (* call  Js_config.bigarray *)
    (* End of bigarray support *)
    | "caml_bswap16"
    | "caml_int32_bswap"
    | "caml_nativeint_bswap" 
      -> call Js_runtime_modules.int32
    | "caml_get_public_method"
      ->
      call Js_runtime_modules.oo
    (** TODO: Primitives not implemented yet ...*)
    | "caml_install_signal_handler"
      -> 
      begin match args with
        | [num; behavior] 
          -> E.seq num behavior (*TODO:*)
        | _ -> assert false
      end
    | "caml_md5_string"
      -> call Js_runtime_modules.md5
    | "caml_hash_mix_string"
    | "caml_hash_mix_int"
    | "caml_hash_final_mix"
      -> call Js_runtime_modules.hash_primitive
    | "caml_hash"
      -> call Js_runtime_modules.hash 
    | "caml_weak_set"
    | "caml_weak_create"
    | "caml_weak_get"
    | "caml_weak_check"
    | "caml_weak_blit"
    | "caml_weak_get_copy"
      -> call Js_runtime_modules.weak

    | "caml_ml_open_descriptor_in" when   
      args_const_unbox_approx_int_zero args -> 
      E.runtime_ref Js_runtime_modules.io "stdin"
    | "caml_ml_open_descriptor_out" when 
      args_const_unbox_approx_int_one args -> 
      E.runtime_ref Js_runtime_modules.io "stdout"
    | "caml_ml_open_descriptor_out" when 
      args_const_unbox_approx_int_two args -> 
      E.runtime_ref Js_runtime_modules.io "stderr"

    | "caml_ba_create"
    | "caml_ba_get_generic"
    | "caml_ba_set_generic"
    | "caml_ba_num_dims"
    | "caml_ba_dim"
    | "caml_ba_kind"
    | "caml_ba_layout"
    | "caml_ba_sub"
    | "caml_ba_slice"
    | "caml_ba_blit"
    | "caml_ba_fill"
    | "caml_ba_reshape"
    | "caml_ba_map_file_bytecode"

    (* caml_ba_get_1,  (\* %caml_ba_ref_1 *\) *)
    (* caml_ba_get_2, *)
    (* caml_ba_get_3, *)

    (* caml_ba_set_1,  // %caml_ba_set_1 *)
    (* caml_ba_set_2, *)
    (* caml_ba_set_3, *)

    (* caml_ba_dim_1, // %caml_ba_dim_1 *)
    (* caml_ba_dim_2,  *)
    (* caml_ba_dim_3,  *)
    | "caml_output_value_to_buffer"
    | "caml_marshal_data_size"
    | "caml_input_value_from_string"
    | "caml_output_value"
    | "caml_input_value"
    | "caml_output_value_to_string"
    | "caml_md5_chan"
    | "caml_hash_univ_param"
    | "caml_sys_close"
    | "caml_sys_open"
    | "caml_ml_input"
    | "caml_ml_input_scan_line"
    | "caml_ml_input_int"
    | "caml_ml_close_channel"
    | "caml_ml_output_int"

    | "caml_ml_channel_size_64"
    | "caml_ml_channel_size"
    | "caml_ml_pos_in_64"
    | "caml_ml_pos_in"
    | "caml_ml_seek_in"
    | "caml_ml_seek_in_64"
    | "caml_ml_pos_out"
    | "caml_ml_pos_out_64"
    | "caml_ml_seek_out"
    | "caml_ml_seek_out_64"
    | "caml_ml_set_binary_mode"    
    | _ -> 
      Bs_warnings.warn_missing_primitive loc prim_name  ;
      E.resolve_and_apply prim_name args
      (*we dont use [throw] here, since [throw] is an statement 
        so we wrap in IIFE
        TODO: we might provoide a hook for user to provide polyfill.
        For example `Bs_global.xxx`
      *)        

  end 



;;

end
module Lam_compile_primitive : sig 
#1 "lam_compile_primitive.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Primitive compilation  *) 

(* The entry point of compile primitives
   Note it will call {!Lam_compile_external_call.translate} for c stubs compilation
*)

val translate : 
  Location.t -> 
  Lam_compile_context.t  ->
  Lam_primitive.t ->
  J.expression list -> J.expression

end = struct
#1 "lam_compile_primitive.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








module E = Js_exp_make 

(* If it is the return value, since it is a side-effect call,
   we return unit, otherwise just return it
*)
let ensure_value_unit (st : Lam_compile_context.continuation) e : E.t = 
  match st with 
  | EffectCall (ReturnTrue _ ) | NeedValue (ReturnTrue _)
  | Assign _ | Declare _ | NeedValue _  -> E.seq e E.unit
  | EffectCall ReturnFalse -> e 
(* NeedValue should return a meaningful expression*)

let translate  loc
    (cxt : Lam_compile_context.t) 
    (prim : Lam_primitive.t)
    (args : J.expression list) : J.expression = 
  match prim with
  | Pis_not_none -> 
      Js_of_lam_option.is_not_none (Ext_list.singleton_exn args)      
  | Pcreate_extension s 
    -> 
    Js_of_lam_exception.make (E.str s)
  | Pwrap_exn -> 
    E.runtime_call Js_runtime_modules.caml_js_exceptions "internalToOCamlException" args 
  | Praw_js_function(arg,block) -> 
    E.raw_js_function arg block
  | Praw_js_code_exp s -> 
    E.raw_js_code Exp s  
  | Praw_js_code_stmt s -> 
    E.raw_js_code Stmt s 
  | Pjs_runtime_apply -> 
    (match args with 
     | [f ;  args] -> 
       E.flat_call f args
     | _ -> assert false)
  | Pjs_apply -> 
    (match args with 
     | fn :: rest -> 
       E.call ~info:{arity=Full; call_info =  Call_na} fn rest 
     | _ -> assert false)
  | Pnull_to_opt -> 
    (match args with 
     | [e] -> 
       (match e.expression_desc with 
        | Var _ | Undefined | Null -> 
          Js_of_lam_option.null_to_opt e 
        | _ ->
          E.runtime_call Js_runtime_modules.option
            "null_to_opt" args)         
     | _ -> assert false )
    
  | Pundefined_to_opt ->
    (match args with 
     | [e] -> 
       (match e.expression_desc with 
        | Var _ | Undefined | Null -> 
          Js_of_lam_option.undef_to_opt e 
        | _ -> 
          E.runtime_call Js_runtime_modules.option  
            "undefined_to_opt" args )
     | _ -> assert false )
    
  | Pnull_undefined_to_opt -> 
    begin match args with 
      | [e] -> 
        begin match e.expression_desc with 
          | Var _ | Undefined | Null   -> 
            Js_of_lam_option.null_undef_to_opt e             
          | _ ->
            E.runtime_call 
              Js_runtime_modules.option        
              "nullable_to_opt" args 
        end
      | _ -> assert false  
    end   
  | Pjs_function_length -> 
    E.function_length (Ext_list.singleton_exn args)    
  | Pcaml_obj_length -> 
    E.obj_length (Ext_list.singleton_exn args)
  | Pis_null -> 
    E.is_null (Ext_list.singleton_exn args)    
  | Pis_undefined -> 
    E.is_undef (Ext_list.singleton_exn args) 
  | Pis_null_undefined ->     
    E.is_null_undefined (Ext_list.singleton_exn args)
  | Pjs_typeof -> 
    E.typeof (Ext_list.singleton_exn args)
    
  | Pjs_unsafe_downgrade _
  | Pdebugger 
  | Pjs_fn_run _ 
  | Pjs_fn_make _

  | Pjs_fn_runmethod _ 
    -> assert false (* already handled by {!Lam_compile} *)
  | Pjs_fn_method _ -> assert false
  | Pglobal_exception id ->
    Js_of_lam_exception.get_builtin_by_name id.name    
  | Pstringadd ->
    begin match args with      
      | [a;b] ->
        E.string_append a b
      | _ -> assert false          
    end          
  | Pinit_mod -> 
    E.runtime_call Js_runtime_modules.module_ "init_mod" args
  | Pupdate_mod ->
    E.runtime_call Js_runtime_modules.module_ "update_mod" args
  | Psome ->     
    let arg = Ext_list.singleton_exn args in 
    (match arg.expression_desc with 
     | Null 
     | Object _ 
     | Number _
     | Caml_block _      
     | Array _
     | Str _
       -> 
       (* This makes sense when type info 
          is not available at the definition
          site, and inline recovered it
       *)
       E.optional_not_nest_block arg 
     | _ -> E.optional_block arg)
  | Psome_not_nest ->   
    E.optional_not_nest_block (Ext_list.singleton_exn args)
  | Pmakeblock(tag, tag_info, mutable_flag ) ->  (* RUNTIME *)
    Js_of_lam_block.make_block 
      (Js_op_util.of_lam_mutable_flag mutable_flag) 
      tag_info (E.small_int tag) args 
  | Pval_from_option -> 
    Js_of_lam_option.val_from_option (Ext_list.singleton_exn args)
  | Pval_from_option_not_nest -> 
    Ext_list.singleton_exn args 
  | Pfield (i, fld_info) -> 
    Js_of_lam_block.field fld_info (Ext_list.singleton_exn args) (Int32.of_int i)
    (* Invariant depends on runtime *)
   | Pfield_computed ->  
    (match args with 
    | [self; index] -> 
      Js_of_lam_block.field_by_exp self  index 
    | _ -> assert false
    )
  (** Negate boxed int *)
  | Pnegbint Pint32
    ->
      E.int32_minus (E.zero_int_literal)  (Ext_list.singleton_exn args) 
      
  | Pnegint
    -> 
      (* #977 *)
      E.int32_minus (E.zero_int_literal)  (Ext_list.singleton_exn args)
  | Pnegbint Pnativeint
    -> 
      E.unchecked_int32_minus (E.zero_int_literal)  (Ext_list.singleton_exn args) 
  | Pnegbint Pint64
    -> 
    Js_long.neg args 


  | Pnegfloat 
    -> 
      E.float_minus (E.zero_float_lit) (Ext_list.singleton_exn args) 
  (** Negate boxed int end*)
  (* Int addition and subtraction *)
  | Paddint 
  | Paddbint  Pint32
    ->
    begin match args with
      | [e1;e2] ->
        E.int32_add  e1  e2
      | _ -> assert false
    end
  | Paddbint Pnativeint 
    -> 
    begin match args with
      | [e1;e2] ->
        E.unchecked_int32_add  e1  e2
      | _ -> assert false
    end

  | Paddbint Pint64
    ->  
    Js_long.add args 


  | Paddfloat
    -> 
    begin match args with
      | [e1;e2] ->
        E.float_add  e1  e2
      | _ -> assert false
    end
  | Psubint 
    -> 
    begin match args with 
      | [e1; e2] ->     
        E.int32_minus e1 e2 
      | _ -> assert false
    end
  | Psubbint Pint32
    -> 
    begin match args with
      | [e1;e2] ->
        E.int32_minus   e1  e2
      | _ -> assert false 
    end
  | Psubbint Pnativeint
    -> 
    begin match args with
      | [e1;e2] ->
        E.unchecked_int32_minus   e1  e2
      | _ -> assert false 
    end
  | Psubbint Pint64
    -> 
    Js_long.sub args 
  | Psubfloat
    ->
    begin match args with
      | [e1;e2] ->
        E.float_minus   e1  e2
      | _ -> assert false 
    end
  | Pmulbint Lambda.Pnativeint
    -> 
    begin match args with
      | [e1; e2]  ->
        E.unchecked_int32_mul  e1  e2
      | _ -> assert false 
    end

  | Pmulint 
  | Pmulbint Pint32
    ->
    begin match args with
      | [e1; e2]  ->
        E.int32_mul  e1  e2
      | _ -> assert false 
    end
  | Pmulbint Pint64 
    -> 
    Js_long.mul args 
  | Pmulfloat 
    -> 
    begin match args with
      | [e1; e2]  ->
        E.float_mul  e1  e2
      | _ -> assert false 
    end
  | Pdivfloat -> 
    begin match args with  
      | [e1;e2] -> E.float_div  e1  e2
      | _ -> assert false 
    end
  | Pdivbint Pnativeint
    -> 
    begin match args with 
      | [e1;e2] ->
        E.int32_div ~checked:false e1 e2
      | _ -> assert false
    end
  | Pdivint 
  | Pdivbint Pint32
    -> 
    begin match args with 
      | [e1;e2] ->
        E.int32_div ~checked:(!Js_config.check_div_by_zero) e1 e2
      | _ -> assert false
    end

  | Pdivbint Pint64 
    -> Js_long.div args 
  | Pmodint 
  | Pmodbint Pnativeint
  | Pmodbint Pint32
    ->
    begin match args with
      | [e1; e2] ->
        E.int32_mod   ~checked:(!Js_config.check_div_by_zero) e1  e2
      | _ -> assert false 
    end
  | Pmodbint Pint64 
    -> Js_long.mod_ args  
  | Plslint 
  | Plslbint Pnativeint
  | Plslbint Pint32
    ->
    begin match args with
      | [e1;e2] ->
        E.int32_lsl e1  e2
      | _ -> assert false 
    end
  | Plslbint Pint64 
    -> Js_long.lsl_ args
  | Plsrbint Pnativeint
    -> 
    begin match args with
      | [e1; e2] ->
        E.int32_lsr   e1  e2
      | _ -> assert false
    end
  | Plsrint 
  | Plsrbint Pint32
    ->
    begin match args with
      | [e1; {J.expression_desc = Number (Int {i=0l; _}|Uint 0l | Nint 0n); _}]
        -> 
        e1
      | [e1; e2] ->
        E.to_int32 @@ E.int32_lsr   e1  e2
      | _ -> assert false
    end
  | Plsrbint Pint64
    -> Js_long.lsr_ args
  | Pasrint 
  | Pasrbint Pnativeint
  | Pasrbint Pint32
    ->
    begin match args with
      | [e1;e2] ->
        E.int32_asr  e1  e2
      | _ -> assert false
    end
  | Pasrbint Pint64 
    -> Js_long.asr_ args      
  | Pandint 
  | Pandbint Pnativeint
  | Pandbint Pint32
    ->
    begin match args with
      | [e1;e2] ->
        E.int32_band  e1  e2
      | _ -> assert false
    end
  | Pandbint Pint64
    -> Js_long.and_ args
  | Porint 
  | Porbint Pnativeint
  | Porbint Pint32
    ->
    begin match args with
      | [e1;e2] ->
        E.int32_bor  e1  e2
      | _ -> assert false
    end
  | Porbint Pint64 
    -> Js_long.or_ args
  | Pxorint 
  | Pxorbint Pnativeint
  | Pxorbint Pint32 
    -> 
    begin match args with
      | [e1;e2] ->
        E.int32_bxor  e1  e2
      | _ -> assert false
    end
  | Pxorbint Lambda.Pint64 
    ->
    Js_long.xor args    
  | Pjscomp cmp ->
    begin match args with
      | [l;r] -> E.js_comp cmp l r 
      | _ -> assert false 
    end
  | Pbintcomp (Pnativeint ,cmp)
  | Pfloatcomp cmp
  | Pintcomp cmp
  | Pbintcomp (Pint32 ,cmp) ->
    (* Global Builtin Exception is an int, like 
       [Not_found] or [Invalid_argument] ?
    *)
    (match args with 
     | [e1;e2] -> E.int_comp cmp e1 e2
     | _ -> assert false )
  (* List --> stamp = 0 
     Assert_false --> stamp = 26 
  *)
  | Pbintcomp (Pint64 ,cmp)
    -> Js_long.comp cmp args

  | Pcvtbint ((Pint32 | Pnativeint ), Pint64) 
    -> Js_long.of_int32 args
  | Pcvtbint (Pint64, Pint64)
  | Pcvtbint ((Pnativeint|Pint32), (Pnativeint|Pint32))
    ->   
    begin match args with 
      | [e0] -> e0 
      | _ -> assert false
    end
  | Pcvtbint (Pint64, (Pnativeint|Pint32)) 
    ->  
    Js_long.to_int32 args 
  | Pintoffloat -> 
    begin
      match args with 
      | [e] -> E.to_int32 e 
      | _ -> assert false 
    end
  | Pbintofint Pint64
    -> Js_long.of_int32 args 
  | Pbintofint (Pnativeint 
               | Pint32 )
  | Pintofbint Pnativeint
  | Pintofbint Pint32
  | Pfloatofint 
    -> Ext_list.singleton_exn args     
  | Pintofbint Pint64
    -> Js_long.to_int32 args
  (* | Pabsfloat -> 
    begin match args with 
      | [e] ->
        E.math "abs" [e]
      (* GCC treat built-ins like Math in a dirfferent way*)
      | _ -> assert false
    end *)
  | Pnot ->
    E.not  (Ext_list.singleton_exn args)       
  | Poffsetint n ->
    E.int32_add (Ext_list.singleton_exn args) (E.small_int  n)      
  | Poffsetref n ->
    let v = (Js_of_lam_block.field Fld_na (Ext_list.singleton_exn args) 0l) in
    E.seq (E.assign  v (E.int32_add v (E.small_int  n))) E.unit
  | Psequand -> (* TODO: rhs is possibly a tail call *)
    begin match args with
      | [e1;e2] ->
        E.and_   e1  e2
      | _ -> assert false
    end
  | Psequor -> (* TODO: rhs is possibly a tail call *)
    begin match args with
      | [e1;e2] ->
        E.or_  e1  e2
      | _ -> assert false
    end
  | Pisout -> 
    begin match args with 
      (* predicate: [x > range  or x < 0 ]
         can be simplified if x is positive , x > range
         if x is negative, fine, its uint is for sure larger than range,
         the output is not readable, we might change it back.

         Note that if range is small like [1], then the negative of 
         it can be more precise (given integer)
         a normal case of the compiler is  that it will do a shift 
         in the first step [ (x - 1) > 1 or ( x - 1 ) < 0 ]
      *)
      | [range; e] -> E.is_out e range
      | _ -> assert false
    end
  | Pbytes_of_string -> 
      (* TODO: write a js primitive  - or is it necessary ?
         if we have byte_get/string_get
         still necessary, since you can set it now.
      *)
    Js_of_lam_string.bytes_of_string (Ext_list.singleton_exn args)      
  | Pbytes_to_string  -> 
    Js_of_lam_string.bytes_to_string (Ext_list.singleton_exn args)      
  | Pstringlength ->
    E.string_length (Ext_list.singleton_exn args)      
  | Pbyteslength  -> 
    E.bytes_length (Ext_list.singleton_exn args)      
  (* This should only be Pbyteset(u|s), which in js, is an int array 
     Bytes is an int array in javascript
  *)
  | Pbytessetu
  | Pbytessets -> 
    (match args with
     | [e;e0;e1] -> ensure_value_unit cxt.continuation 
                      (Js_of_lam_string.set_byte e e0 e1)
     | _ -> assert false)
  | Pbytesrefu ->
    (match args with
     | [e;e1] -> Js_of_lam_string.ref_byte e e1
     | _ -> assert false)


  | Pbytesrefs ->
    begin match args with
      | [e ; e1] ->
        if !Clflags.fast then
          Js_of_lam_string.ref_byte e e1
        else E.runtime_call Js_runtime_modules.bytes "get" args            
      | _ -> assert false         
    end
  (* For bytes and string, they both return [int] in ocaml 
      we need tell Pbyteref from Pstringref
      1. Pbyteref -> a[i]
      2. Pstringref -> a.charCodeAt (a[i] is wrong)
  *)
  | Pstringrefu  ->
    begin match args with
      | [e;e1] -> Js_of_lam_string.ref_string e e1 
      | _ -> assert false
    end

  | Pstringrefs ->
    begin match args with
      | [e;e1] ->
        if !Clflags.fast then
          Js_of_lam_string.ref_string e e1             
        else       
          E.runtime_call Js_runtime_modules.string "get" args          
      | _ -> assert false
    end
  (** only when Lapply -> expand = true*)
  | Praise  -> assert false (* handled before here *)

  (* Runtime encoding relevant *)
  | Parraylength -> 
    E.array_length (Ext_list.singleton_exn args)      
  | Psetfield (i, field_info) -> 
    (match args with 
     | [e0;e1] ->  (** RUNTIME *)
       ensure_value_unit cxt.continuation 
         (Js_of_lam_block.set_field field_info e0 (Int32.of_int i) e1)
     (*TODO: get rid of [E.unit ()]*)
     | _ -> assert false)    
  | Psetfield_computed ->      
    (match args with 
    | [self; index; value] ->
      ensure_value_unit cxt.continuation
        (Js_of_lam_block.set_field_by_exp self index value)
    | _ -> assert false
    )
  | Psetfloatfield (i,field_info)
    -> (** RUNTIME --  RETURN VALUE SHOULD BE UNIT *)
    (match args with 
     | [e;e0] -> 
       ensure_value_unit cxt.continuation 
         (Js_of_lam_float_record.set_double_field field_info e (Int32.of_int i) e0 ) 
     | _ -> assert false)
  | Pfloatfield (i, field_info) -> (** RUNTIME *)    
      Js_of_lam_float_record.get_double_feild field_info (Ext_list.singleton_exn args)
         (Int32.of_int i) 
  | Parrayrefu ->  
    (match args with
     | [e;e1] -> Js_of_lam_array.ref_array e e1 (* Todo: Constant Folding *)
     | _ -> assert false)    
  | Parrayrefs ->
    Lam_dispatch_primitive.translate loc "caml_array_get" args
  | Pmakearray _kind -> 
    Js_of_lam_array.make_array Mutable  args 
  | Parraysetu  -> 
      (match args with (* wrong*)
      | [e;e0;e1] -> ensure_value_unit cxt.continuation (Js_of_lam_array.set_array  e e0 e1)
      | _ -> assert false)    
  | Parraysets  -> 
    Lam_dispatch_primitive.translate loc "caml_array_set" args
  | Pccall prim -> 
    Lam_dispatch_primitive.translate loc prim.prim_name  args
  (* Lam_compile_external_call.translate loc cxt prim args *)
  (* Test if the argument is a block or an immediate integer *)
  | Pjs_object_create labels
    -> 
    assert false 

  | Pjs_call (_, arg_types, ffi) -> 
    Lam_compile_external_call.translate_ffi 
      loc cxt arg_types ffi args 
  (** FIXME, this can be removed later *)
  | Pisint -> 
    E.is_type_number (Ext_list.singleton_exn args)
  | Pctconst ct -> 
    (match ct with 
     | Big_endian -> E.bool Sys.big_endian
     | Word_size -> 
       E.small_int  Sys.word_size
     | Ostype_unix -> E.bool Sys.unix
     | Ostype_win32 -> E.bool Sys.win32      
     | Ostype_cygwin -> E.bool Sys.cygwin

     | Int_size -> E.int 32l
     | Max_wosize ->
      (* max_array_length*)
       E.int 2147483647l (* 2 ^ 31 - 1 *) 
        (* 4_294_967_295l  not representable*)
        (* 2 ^ 32 - 1*)
     | Backend_type  -> 
      E.make_block
        E.zero_int_literal 
        (Blk_constructor ("Other",1))
        [E.str "BS"] Immutable

     )
    
  | Pduprecord ((Record_regular 
                | Record_float 
   
                | Record_inlined {tag = 0; num_nonconsts = 1}
                | Record_extension
                
                ),_) -> 
    (* _size is the length of all_lables*)
    (* TODO: In debug mode, need switch to  *)
    Lam_dispatch_primitive.translate loc "caml_array_dup" args

  | Pduprecord (Record_unboxed _inlined,_) 
    -> assert false
  | Pduprecord (Record_inlined _, _)
    -> 
    Lam_dispatch_primitive.translate loc "caml_obj_dup" args
    (* check dubug mode *)
  

  | Pbigarrayref (unsafe, dimension, kind, layout)
    -> 
    (* can be refined to 
       [caml_bigarray_float32_c_get_1]
       note that kind can be [generic]
       and layout can be [unknown],
       dimension is always available
    *)
    begin match dimension, kind, layout, unsafe with 
      | 1,  ( Pbigarray_float32 | Pbigarray_float64
            | Pbigarray_sint8 | Pbigarray_uint8
            | Pbigarray_sint16 | Pbigarray_uint16
            | Pbigarray_int32 | Pbigarray_int64
            | Pbigarray_caml_int | Pbigarray_native_int
            | Pbigarray_complex32 | Pbigarray_complex64), Pbigarray_c_layout, _
        -> 
        begin match args with
          | [x;indx] -> Js_of_lam_array.ref_array x indx
          | _ -> assert false
        end
      | _, _, _ ,_ -> 
        E.resolve_and_apply
          ("caml_ba_get_" ^ string_of_int dimension ) args
        (* E.runtime_call Js_config.bigarray  *)
        (*   ("caml_ba_get_" ^ string_of_int dimension ) args  *)
    end
  | Pbigarrayset (unsafe, dimension, kind, layout)
    -> 
    begin match dimension, kind, layout, unsafe with 
      | 1,  ( Pbigarray_float32 | Pbigarray_float64
            | Pbigarray_sint8 | Pbigarray_uint8
            | Pbigarray_sint16 | Pbigarray_uint16
            | Pbigarray_int32 | Pbigarray_int64
            | Pbigarray_caml_int | Pbigarray_native_int
            | Pbigarray_complex32 | Pbigarray_complex64), Pbigarray_c_layout, _
        -> 
        begin match args with 
          | [x; index; value] -> 
            Js_of_lam_array.set_array x index value          
          | _ -> assert false
        end

      | _ , _, _,_ 
        -> 
        E.resolve_and_apply
          ("caml_ba_set_" ^ string_of_int dimension) args
          (* E.runtime_call Js_config.bigarray  *)
          (*   ("caml_ba_set_" ^ string_of_int dimension ) args  *)
    end

  | Pbigarraydim i
    -> 
    E.resolve_and_apply 
      ("caml_ba_dim_" ^ string_of_int i) args
  (* E.runtime_call Js_config.bigarray *)
  (*   ("caml_ba_dim_" ^ string_of_int i) args        *)
  | Pbswap16 
    -> 
    E.runtime_call Js_runtime_modules.int32 "caml_bswap16" args
  | Pbbswap Lambda.Pnativeint
  | Pbbswap Lambda.Pint32
    -> 
    E.runtime_call Js_runtime_modules.int32 "caml_int32_bswap" args
  | Pbbswap Lambda.Pint64
    -> Js_long.swap args 
  | Pstring_load_16 unsafe
    -> E.runtime_call Js_runtime_modules.string "caml_string_get16" args
  | Pstring_load_32 unsafe
    -> E.runtime_call Js_runtime_modules.string "caml_string_get32" args
  | Pstring_load_64 unsafe
    -> Js_long.get64 args

  | Plazyforce  
  (*   let parm = Ident.create "prim" in 
       Lfunction(Curried, [parm], 
                 Matching.inline_lazy_force (Lvar parm) Location.none) 
   It is inlined, this should not appear here *)    
  | Pbittest 

  | Pstring_set_16 _
  | Pstring_set_32 _
  | Pstring_set_64 _
  | Pbigstring_load_16 _
  | Pbigstring_load_32 _
  | Pbigstring_load_64 _
  | Pbigstring_set_16 _
  | Pbigstring_set_32 _
  | Pbigstring_set_64 _
    -> 
    (*we dont use [throw] here, since [throw] is an statement  *)        
    let s = Lam_print.primitive_to_string prim in    
    Bs_warnings.warn_missing_primitive loc  s;
    E.resolve_and_apply s args



end
module Lam_eta_conversion : sig 
#1 "lam_eta_conversion.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


(** 
  [transform n loc status fn args]
  n is the number of missing arguments required for [fn].
  Return a function of airty [n]
*) 

val transform_under_supply : 
  int ->
  Location.t -> Lam.apply_status -> Lam.t -> Lam.t list -> Lam.t


val unsafe_adjust_to_arity :
  Location.t -> 
  to_:int -> 
  ?from:int -> 
  Lam.t -> 
  Lam.t 
end = struct
#1 "lam_eta_conversion.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


(*
  let f x y =  x + y 
  Invariant: there is no currying 
  here since f's arity is 2, no side effect 
  f 3 --> function(y) -> f 3 y 
*)

(** 
   [transform n loc status fn args]
   n is the number of missing arguments required for [fn].
   Return a function of airty [n]
*) 
let transform_under_supply n loc status fn args = 
  let extra_args = Ext_list.init n
      (fun _ ->   (Ident.create Literals.param)) in
  let extra_lambdas = Ext_list.map  extra_args Lam.var in
  begin match Ext_list.fold_right (fn::args) ([],[])  (fun (lam : Lam.t) (acc, bind) ->
      match lam with
      | Lvar _
      | Lconst (Const_int _  
        | Const_char _ | Const_string _ 
        | Const_float _ | Const_int32 _ 
        | Const_int64 _ | Const_nativeint _ 
        | Const_pointer _ | Const_immstring _ | Const_js_true | Const_js_false | Const_js_undefined) 
      | Lprim {primitive = Pfield _;
               args =  [ Lglobal_module _ ]; _ }
      | Lfunction _ 
        ->
        (lam :: acc, bind)
      | _ ->
        let v = Ident.create Literals.partial_arg in
        (Lam.var v :: acc),  ((v, lam) :: bind)
    )   with 
  | fn :: args, [] -> 
    (* More than no side effect in the [args], 
       we try to avoid computation, so even if 
       [x + y] is side effect free, we need eval it only once 
    *)
    (* TODO: Note we could adjust [fn] if [fn] is already a function
       But it is dangerous to change the arity 
       of an existing function which may cause inconsistency
    *)
    Lam.function_ ~arity:n  ~params:extra_args
      ~body:(Lam.apply fn (Ext_list.append args  extra_lambdas) 
               loc 
               status
            ) 
  | fn::args , bindings ->

    let rest : Lam.t = 
      Lam.function_ ~arity:n  ~params:extra_args
        ~body:(Lam.apply fn (Ext_list.append args  extra_lambdas) 
                 loc 
                 status
              ) in
    Ext_list.fold_left bindings rest (fun lam (id,x) ->
        Lam.let_ Strict id x lam
      ) 
  | _, _ -> assert false
  end



(* Invariant: mk0 : (unit -> 'a0) -> 'a0 t 
                TODO: this case should be optimized, 
                we need check where we handle [arity=0] 
                as a special case -- 
                if we do an optimization before compiling
                into lambda

   {[Fn.mk0]} is not intended for use by normal users

   so we assume [Fn.mk0] is only used in such cases
   {[
     Fn.mk0 (fun _ -> .. )
   ]}
   when it is passed as a function directly
*)
(*TODO: can be optimized ?
  {[\ x y -> (\u -> body x) x y]}
  {[\u x -> body x]}        
    rewrite rules 
  {[
    \x -> body 
          --
          \y (\x -> body ) y 
  ]}
  {[\ x y -> (\a b c -> g a b c) x y]}
  {[ \a b -> \c -> g a b c ]}
*)
(** if arity = 0 then 
            begin match fn with 
              | Lfunction {params =  [_]; body}
                ->
                compile_lambda cxt 
                  (Lam.function_ 
                     ~arity:0 
                     ~kind:Curried
                     ~params:[]
                     ~body)
              | _ -> 
                let wrapper, new_fn = 
                  match fn with 
                  | Lvar _ 
                  | Lprim {primitive = Pfield _ ; args = [Lglobal_module _]; _} -> 
                    None, fn 
                  | _ ->  
                    let partial_arg = Ext_ident.create Literals.partial_arg in 
                    Some partial_arg, Lam.var partial_arg
                in 
                let cont =   
                  (Lam.function_ ~arity:0 
                     ~kind:Curried ~params:[] 
                     ~body:(
                       Lam.apply new_fn
                         [Lam.unit]
                         Location.none App_na
                     )) in 
                begin match wrapper with 
                  | None ->      
                    compile_lambda cxt  cont
                  | Some partial_arg
                    -> 
                    compile_lambda cxt (Lam.let_ Strict partial_arg fn cont )  
                end
            end
          else 
            begin match fn with
              | Lam.Lfunction{arity = len; kind; params = args; body}
                ->
                if len = arity then
                  compile_lambda cxt fn 
                else if len > arity then 
                  let params, rest  = Ext_list.split_at arity args  in 
                  compile_lambda cxt 
                    (Lam.function_ 
                       ~arity
                       ~kind ~params
                       ~body:(Lam.function_ ~arity:(len - arity)
                                ~kind ~params:rest ~body)
                    )
                else (* len < arity *)
                  compile_lambda cxt 
                    (Lam_eta_conversion.transform_under_supply arity 
                       Location.none App_na
                       fn  [] )
              (* let extra_args = Ext_list.init (arity - len) (fun _ ->   (Ident.create Literals.param)) in *)
              (* let extra_lambdas = Ext_list.map (fun x -> Lam.var x) extra_args in *)
              (* Lam.Lfunction (kind, Ext_list.append extra_args  args , body ) *)

                                | _ -> 
                                compile_lambda cxt 
                                (Lam_eta_conversion.transform_under_supply arity
                                Location.none App_na  fn  [] )
                                end *)


(** Unsafe function, we are changing arity here, it should be applied 
    cautiously, since 
    [let u = f] and we are chaning the arity of [f] it will affect 
    the collection of [u]
    A typical use case is to pass an OCaml function to JS side as a callback (i.e, [@bs.uncurry])
*)
let unsafe_adjust_to_arity loc ~(to_:int) ?(from : int option) (fn : Lam.t) : Lam.t = 
  begin match from, fn  with 
    | Some from, _ 
    | None, Lfunction{arity=from} ->
      if from = to_ then 
        fn 
      else if to_ = 0 then  
        match fn with 
        | Lfunction{params = [param]; body} -> 
          Lam.function_ ~arity:0 
            ~params:[]
            ~body:(
              Lam.let_ Alias param Lam.unit body  
            ) (* could be only introduced by 
                 {[ Pjs_fn_make 0 ]} <- 
                 {[ fun [@bs] () -> .. ]}
              *)
        | _ -> 
          let wrapper, new_fn  = 
            match fn with 
            | Lvar _ 
            | Lprim{primitive = Pfield _ ; args = [Lglobal_module _]; _ }
              -> 
              None, fn 
            | _ -> 
              let partial_arg = Ext_ident.create Literals.partial_arg in 
              Some partial_arg, Lam.var partial_arg in 

          let cont = Lam.function_ 
              ~arity:0
              ~params:[]
              ~body:(
                Lam.apply new_fn [Lam.unit ] loc App_na
              ) in 

          match wrapper with 
          | None -> cont 
          | Some partial_arg 
            -> Lam.let_ Strict partial_arg fn cont 

      else if to_ > from then 
        match fn with 
        | Lfunction{params;body} -> 
          (* {[fun x -> f]} -> 
             {[ fun x y -> f y ]}
          *)
          let extra_args = Ext_list.init (to_ - from) (fun _ -> Ident.create Literals.param) in 
          Lam.function_
            ~arity:to_ 
            ~params:(Ext_list.append params  extra_args )
            ~body:(Lam.apply body (Ext_list.map extra_args Lam.var) loc App_na)
        | _ -> 
          let arity = to_ in 
          let extra_args = Ext_list.init to_  (fun _ -> Ident.create Literals.param ) in 
          let wrapper, new_fn = 
            match fn with 
            | Lvar _ 
            | Lprim {primitive = Pfield _ ; args = [ Lglobal_module _] ; _}  -> 
              None, fn
            | _ -> 
              let partial_arg = Ext_ident.create Literals.partial_arg in 
              Some partial_arg, Lam.var partial_arg
          in   
          let cont = 
            Lam.function_ 
              ~arity

              ~params:extra_args 
              ~body:(
                let first_args, rest_args = Ext_list.split_at extra_args from in 
                Lam.apply (Lam.apply new_fn (Ext_list.map first_args  Lam.var) loc App_ml_full) (Ext_list.map rest_args Lam.var) loc App_na ) in 
          begin match wrapper with 
            | None -> cont 
            | Some partial_arg -> 
              Lam.let_ Strict partial_arg fn cont 
          end    
      else 
        (* add3  --adjust to arity 1 ->
           fun x -> (fun y z -> add3 x y z )

           [fun x y z -> f x y z ]
           [fun x -> [fun y z -> f x y z ]]
           This is okay if the function is not held by other..
        *)
        begin match fn with 

          | Lfunction 
              {params; body; } (* TODO check arity = List.length params in debug mode *)
            -> 
            let arity = to_ in 
            let extra_outer_args, extra_inner_args = Ext_list.split_at params arity in 
            Lam.function_ 
              ~arity 

              ~params:extra_outer_args 
              ~body:(
                Lam.function_ ~arity:(from - to_)
                  ~params:extra_inner_args ~body:body)
          | _
            -> 
            let extra_outer_args = 
              Ext_list.init to_
                (fun _ ->   Ident.create Literals.param) in
            let wrapper, new_fn = 
              match fn with 
              | Lvar _ 
              | Lprim {primitive = Pfield _ ; args = [ Lglobal_module _] ; _}  -> 
                None, fn
              | _ -> 
                let partial_arg = Ext_ident.create Literals.partial_arg in 
                Some partial_arg, Lam.var partial_arg
            in   
            let cont = 
              Lam.function_ ~arity:to_ ~params:extra_outer_args 
                ~body:(
                  let arity = from - to_ in 
                  let extra_inner_args =
                    Ext_list.init arity (fun _ -> Ident.create Literals.param ) in 
                  Lam.function_ ~arity ~params:extra_inner_args 
                    ~body:(Lam.apply new_fn 
                             (Ext_list.map_append extra_outer_args 
                                (Ext_list.map extra_inner_args Lam.var) 
                                Lam.var 
                             )      
                             loc App_ml_full)
                )  in 
            begin match wrapper with 
              | None -> cont 
              | Some partial_arg -> Lam.let_ Strict partial_arg fn  cont    
            end
        end 
    | None, _ ->      
      (** In this case [fn] is not [Lfunction], otherwise we would get [arity] *)
      if to_ = 0 then 
        let wrapper, new_fn  = 
          match fn with 
          | Lvar _ 
          | Lprim{primitive = Pfield _ ; args = [Lglobal_module _]; _ }
            -> 
            None, fn 
          | _ -> 
            let partial_arg = Ext_ident.create Literals.partial_arg in 
            Some partial_arg, Lam.var partial_arg in 

        let cont = Lam.function_ 
            ~arity:0
            ~params:[]
            ~body:(
              Lam.apply new_fn [Lam.unit] loc App_na
            ) in 

        match wrapper with 
        | None -> cont 
        | Some partial_arg 
          -> Lam.let_ Strict partial_arg fn cont 
      else   
        transform_under_supply to_ loc App_na fn []
  end 


(* | _ -> 
   let partial_arg = Ext_ident.create Literals.partial_arg in 
   Lam.let_ Strict partial_arg fn 
    (let arity = to_ in 
     let extra_args = Ext_list.init arity (fun _ -> Ident.create Literals.param) in 
     Lam.function_ ~arity ~kind:Curried ~params:extra_args 
       ~body:(Lam.apply fn (Ext_list.map Lam.var extra_args ) loc Lam.App_na )
    ) *)

end
module Lam_iter : sig 
#1 "lam_iter.mli"
(* Copyright (C) 2018 - Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)




val inner_iter :  Lam.t -> (Lam.t -> unit) -> unit 

val inner_exists : Lam.t -> (Lam.t -> bool) -> bool
end = struct
#1 "lam_iter.ml"
(* Copyright (C) 2018 - Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type t = Lam.t 
type ident = Ident.t 


let inner_iter (l : t) (f : t -> unit ) : unit =
  match l  with
  | Lvar (_ : ident)
  | Lconst (_ : Lam_constant.t) -> ()
  | Lapply ({fn; args; loc; status} )  ->
    f fn;
    List.iter f args
  | Lfunction({body; arity;  params } ) ->
    f body
  | Llet(str, id, arg, body) ->
    f arg ;
    f body;
  | Lletrec(decl, body) ->
    f body;
    Ext_list.iter_snd  decl f 
  | Lswitch(arg, {sw_consts; sw_numconsts; sw_blocks; sw_numblocks; sw_failaction}) ->
    f arg;
    Ext_list.iter_snd sw_consts f;
    Ext_list.iter_snd sw_blocks f;
    Ext_option.iter sw_failaction f      
  | Lstringswitch (arg,cases,default) ->
    f arg;
    Ext_list.iter_snd cases f;
    Ext_option.iter default f     
  | Lglobal_module (_ )
    ->  ()
  | Lprim {args; primitive ; loc}  ->
    List.iter f args;
  
  | Lstaticraise (id,args) ->
    List.iter f args;
  | Lstaticcatch(e1, vars , e2) ->
    f e1;
    f e2
  | Ltrywith(e1, exn, e2) ->
    f e1;
    f e2
  | Lifthenelse(e1, e2, e3) ->
    f e1;  f e2 ;  f e3
  | Lsequence(e1, e2) ->
    f e1 ;  f e2
  | Lwhile(e1, e2) ->
    f e1 ;  f e2
  | Lfor(v, e1, e2, dir, e3) ->
    f e1 ;  f e2;  f e3
  | Lassign(id, e) ->
    f e
  | Lsend (k, met, obj, args, loc) ->
    f met; f obj; List.iter f args   


let inner_exists (l : t) (f : t -> bool) : bool =
  match l  with
  | Lvar (_ : ident)
  | Lglobal_module (_ )
  | Lconst (_ : Lam_constant.t) -> false
  | Lapply ({fn; args; loc; status} )  ->
    f fn ||
    Ext_list.exists args f 
  | Lfunction({body; arity;  params } ) ->
    f body
  | Llet(str, id, arg, body) ->
    f arg ||
    f body
  | Lletrec(decl, body) ->
    f body ||
    Ext_list.exists_snd  decl f 
  | Lswitch(arg, {sw_consts; sw_numconsts; sw_blocks; sw_numblocks; sw_failaction}) ->
    f arg ||
    Ext_list.exists_snd sw_consts f ||
    Ext_list.exists_snd sw_blocks f ||
    Ext_option.exists sw_failaction f      
  | Lstringswitch (arg,cases,default) ->
    f arg ||
    Ext_list.exists_snd cases f ||
    Ext_option.exists default f     
  
  | Lprim {args; primitive ; loc}  ->
    Ext_list.exists args f;
  
  | Lstaticraise (id,args) ->
    Ext_list.exists args f;
  | Lstaticcatch(e1, vars , e2) ->
    f e1 ||
    f e2
  | Ltrywith(e1, exn, e2) ->
    f e1 ||
    f e2
  | Lifthenelse(e1, e2, e3) ->
    f e1 ||  f e2 ||  f e3
  | Lsequence(e1, e2) ->
    f e1 ||  f e2
  | Lwhile(e1, e2) ->
    f e1 ||  f e2
  | Lfor(v, e1, e2, dir, e3) ->
    f e1 ||  f e2 ||  f e3
  | Lassign(id, e) ->
    f e
  | Lsend (k, met, obj, args, loc) ->
    f met || f obj || Ext_list.exists args f 

end
module Lam_exit_code : sig 
#1 "lam_exit_code.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


val has_exit_code :  Lam.t -> (int -> bool ) -> bool


val has_exit : Lam.t -> bool

end = struct
#1 "lam_exit_code.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


let has_exit_code lam  exits = 
  let rec aux (lam : Lam.t) = 
    match lam with 
    | Lfunction _ -> false 
      (* static exit can not cross function boundary *)
    | Lstaticraise(p,_) 
      when exits p -> true 

    | _ -> 
      Lam_iter.inner_exists lam aux
  in aux lam  
let rec has_exit (lam : Lam.t) =   
  match lam with 
  | Lfunction _ -> false 
  | Lstaticraise(_,_) -> true 
  | _ -> Lam_iter.inner_exists lam has_exit
end
module Lam_methname : sig 
#1 "lam_methname.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



val translate : ?loc:Location.t -> string -> string

end = struct
#1 "lam_methname.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


(**
  {[
    _open -> open 
    _in -> in 
    _MAX_LENGTH -> MAX_LENGTH
    _Capital -> Capital 
    
    _open__ ->  _open
    open__ -> open 
    
    _'x -> 'x 

    _Capital__ -> _Capital 
    _MAX__ -> _MAX
    __ -> __ 
    __x -> __x 
    ___ -> _     
    ____ -> __
    _ -> _  (* error *)   
    

  ]}
  First we scan '__' from end to start, 
  If found, discard it.
  Otherwise, check if it is [_ + keyword] or followed by capital letter,
  If so, discard [_].

  Limitations: user can not have [_Capital__, _Capital__other] to 
  make it all compile to [Capital].
  Keyword is fine [open__, open__other].
  So we loose polymorphism over capital letter. 
  It is okay, otherwise, if [_Captial__] is interpreted as [Capital], then
  there is no way to express [_Capital]
*)

(* Copied from [ocaml/parsing/lexer.mll] *)
let key_words = String_hash_set.of_array [|
    "and";
    "as";
    "assert";
    "begin";
    "class";
    "constraint";
    "do";
    "done";
    "downto";
    "else";
    "end";
    "exception";
    "external";
    "false";
    "for";
    "fun";
    "function";
    "functor";
    "if";
    "in";
    "include";
    "inherit";
    "initializer";
    "lazy";
    "let";
    "match";
    "method";
    "module";
    "mutable";
    "new";
    "nonrec";
    "object";
    "of";
    "open";
    "or";
(*  "parser", PARSER; *)
    "private";
    "rec";
    "sig";
    "struct";
    "then";
    "to";
    "true";
    "try";
    "type";
    "val";
    "virtual";
    "when";
    "while";
    "with";

    "mod";
    "land";
    "lor";
    "lxor";
    "lsl";
    "lsr";
    "asr";
|]
let double_underscore = "__"

(*https://caml.inria.fr/pub/docs/manual-ocaml/lex.html
{[

  label-name	::=	 lowercase-ident 
]}
*)
let valid_start_char x =
  match x with 
  | '_' | 'a' .. 'z' -> true 
  | _ -> false 
let translate ?loc name = 
  assert (not @@ Ext_string.is_empty name);
  let i = Ext_string.rfind ~sub:double_underscore name in 
  if i < 0 then 
    let name_len = String.length name in 
    if name.[0] = '_' then  begin 
      let try_key_word = (String.sub name 1 (name_len - 1)) in 
      if name_len > 1 && 
        (not (valid_start_char try_key_word.[0])
        || String_hash_set.mem key_words try_key_word)  then 
        try_key_word
      else 
        name 
    end
    else name 
  else if i = 0 then name 
  else  String.sub name 0 i 


end
module Vec_gen
= struct
#1 "vec_gen.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


module type ResizeType = 
sig 
  type t 
  val null : t (* used to populate new allocated array checkout {!Obj.new_block} for more performance *)
end

module type S = 
sig 
  type elt 
  type t
  val length : t -> int 
  val compact : t -> unit
  val singleton : elt -> t 
  val empty : unit -> t 
  val make : int -> t 
  val init : int -> (int -> elt) -> t
  val is_empty : t -> bool
  val of_array : elt array -> t
  val of_sub_array : elt array -> int -> int -> t

  (** Exposed for some APIs which only take array as input, 
      when exposed   
  *)
  val unsafe_internal_array : t -> elt array
  val reserve : t -> int -> unit
  val push :  t -> elt -> unit
  val delete : t -> int -> unit 
  val pop : t -> unit
  val get_last_and_pop : t -> elt
  val delete_range : t -> int -> int -> unit 
  val get_and_delete_range : t -> int -> int -> t
  val clear : t -> unit 
  val reset : t -> unit 
  val to_list : t -> elt list 
  val of_list : elt list -> t
  val to_array : t -> elt array 
  val of_array : elt array -> t
  val copy : t -> t 
  val reverse_in_place : t -> unit
  val iter : t -> (elt -> unit) -> unit 
  val iteri : t -> (int -> elt -> unit ) -> unit 
  val iter_range : t -> from:int -> to_:int -> (elt -> unit) -> unit 
  val iteri_range : t -> from:int -> to_:int -> (int -> elt -> unit) -> unit
  val map : (elt -> elt) -> t ->  t
  val mapi : (int -> elt -> elt) -> t -> t
  val map_into_array : (elt -> 'f) -> t -> 'f array
  val map_into_list : (elt -> 'f) -> t -> 'f list 
  val fold_left : ('f -> elt -> 'f) -> 'f -> t -> 'f
  val fold_right : (elt -> 'g -> 'g) -> t -> 'g -> 'g
  val filter : (elt -> bool) -> t -> t
  val inplace_filter : (elt -> bool) -> t -> unit
  val inplace_filter_with : (elt -> bool) -> cb_no:(elt -> 'a -> 'a) -> 'a -> t -> 'a 
  val inplace_filter_from : int -> (elt -> bool) -> t -> unit 
  val equal : (elt -> elt -> bool) -> t -> t -> bool 
  val get : t -> int -> elt
  val unsafe_get : t -> int -> elt
  val last : t -> elt
  val capacity : t -> int
  val exists : (elt -> bool) -> t -> bool
  val sub : t -> int -> int  -> t 
end


end
module Int_vec : sig 
#1 "int_vec.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

include Vec_gen.S with type elt = int

end = struct
#1 "int_vec.ml"
# 1 "ext/vec.cppo.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

# 34 "ext/vec.cppo.ml"
type elt = int 
let null = 0 (* can be optimized *)
let unsafe_blit = Bs_hash_stubs.int_unsafe_blit

# 41 "ext/vec.cppo.ml"
external unsafe_sub : 'a array -> int -> int -> 'a array = "caml_array_sub"

type  t = {
  mutable arr : elt array ;
  mutable len : int ;  
}

let length d = d.len

let compact d =
  let d_arr = d.arr in 
  if d.len <> Array.length d_arr then 
    begin
      let newarr = unsafe_sub d_arr 0 d.len in 
      d.arr <- newarr
    end
let singleton v = 
  {
    len = 1 ; 
    arr = [|v|]
  }

let empty () =
  {
    len = 0;
    arr = [||];
  }

let is_empty d =
  d.len = 0

let reset d = 
  d.len <- 0; 
  d.arr <- [||]


(* For [to_*] operations, we should be careful to call {!Array.*} function 
   in case we operate on the whole array
*)
let to_list d =
  let rec loop (d_arr : elt array) idx accum =
    if idx < 0 then accum else loop d_arr (idx - 1) (Array.unsafe_get d_arr idx :: accum)
  in
  loop d.arr (d.len - 1) []


let of_list lst =
  let arr = Array.of_list lst in 
  { arr ; len = Array.length arr}


let to_array d = 
  unsafe_sub d.arr 0 d.len

let of_array src =
  {
    len = Array.length src;
    arr = Array.copy src;
    (* okay to call {!Array.copy}*)
  }
let of_sub_array arr off len = 
  { 
    len = len ; 
    arr = Array.sub arr off len  
  }  
let unsafe_internal_array v = v.arr  
(* we can not call {!Array.copy} *)
let copy src =
  let len = src.len in
  {
    len ;
    arr = unsafe_sub src.arr 0 len ;
  }

(* FIXME *)
let reverse_in_place src = 
  Ext_array.reverse_range src.arr 0 src.len 




(* {!Array.sub} is not enough for error checking, it 
   may contain some garbage
 *)
let sub (src : t) start len =
  let src_len = src.len in 
  if len < 0 || start > src_len - len then invalid_arg "Vec.sub"
  else 
  { len ; 
    arr = unsafe_sub src.arr start len }

let iter d  f = 
  let arr = d.arr in 
  for i = 0 to d.len - 1 do
    f (Array.unsafe_get arr i)
  done

let iteri d f =
  let arr = d.arr in
  for i = 0 to d.len - 1 do
    f i (Array.unsafe_get arr i)
  done

let iter_range d ~from ~to_ f =
  if from < 0 || to_ >= d.len then invalid_arg "Resize_array.iter_range"
  else 
    let d_arr = d.arr in 
    for i = from to to_ do 
      f  (Array.unsafe_get d_arr i)
    done

let iteri_range d ~from ~to_ f =
  if from < 0 || to_ >= d.len then invalid_arg "Resize_array.iteri_range"
  else 
    let d_arr = d.arr in 
    for i = from to to_ do 
      f i (Array.unsafe_get d_arr i)
    done

let map_into_array f src =
  let src_len = src.len in 
  let src_arr = src.arr in 
  if src_len = 0 then [||]
  else 
    let first_one = f (Array.unsafe_get src_arr 0) in 
    let arr = Array.make  src_len  first_one in
    for i = 1 to src_len - 1 do
      Array.unsafe_set arr i (f (Array.unsafe_get src_arr i))
    done;
    arr 
let map_into_list f src = 
  let src_len = src.len in 
  let src_arr = src.arr in 
  if src_len = 0 then []
  else 
    let acc = ref [] in         
    for i =  src_len - 1 downto 0 do
      acc := f (Array.unsafe_get src_arr i) :: !acc
    done;
    !acc

let mapi f src =
  let len = src.len in 
  if len = 0 then { len ; arr = [| |] }
  else 
    let src_arr = src.arr in 
    let arr = Array.make len (Array.unsafe_get src_arr 0) in
    for i = 1 to len - 1 do
      Array.unsafe_set arr i (f i (Array.unsafe_get src_arr i))
    done;
    {
      len ;
      arr ;
    }

let fold_left f x a =
  let rec loop a_len (a_arr : elt array) idx x =
    if idx >= a_len then x else 
      loop a_len a_arr (idx + 1) (f x (Array.unsafe_get a_arr idx))
  in
  loop a.len a.arr 0 x

let fold_right f a x =
  let rec loop (a_arr : elt array) idx x =
    if idx < 0 then x
    else loop a_arr (idx - 1) (f (Array.unsafe_get a_arr idx) x)
  in
  loop a.arr (a.len - 1) x

(**  
   [filter] and [inplace_filter]
*)
let filter f d =
  let new_d = copy d in 
  let new_d_arr = new_d.arr in 
  let d_arr = d.arr in
  let p = ref 0 in
  for i = 0 to d.len  - 1 do
    let x = Array.unsafe_get d_arr i in
    (* TODO: can be optimized for segments blit *)
    if f x  then
      begin
        Array.unsafe_set new_d_arr !p x;
        incr p;
      end;
  done;
  new_d.len <- !p;
  new_d 

let equal eq x y : bool = 
  if x.len <> y.len then false 
  else 
    let rec aux x_arr y_arr i =
      if i < 0 then true else  
      if eq (Array.unsafe_get x_arr i) (Array.unsafe_get y_arr i) then 
        aux x_arr y_arr (i - 1)
      else false in 
    aux x.arr y.arr (x.len - 1)

let get d i = 
  if i < 0 || i >= d.len then invalid_arg "Resize_array.get"
  else Array.unsafe_get d.arr i
let unsafe_get d i = Array.unsafe_get d.arr i 
let last d = 
  if d.len <= 0 then invalid_arg   "Resize_array.last"
  else Array.unsafe_get d.arr (d.len - 1)

let capacity d = Array.length d.arr

(* Attention can not use {!Array.exists} since the bound is not the same *)  
let exists p d = 
  let a = d.arr in 
  let n = d.len in   
  let rec loop i =
    if i = n then false
    else if p (Array.unsafe_get a i) then true
    else loop (succ i) in
  loop 0

let map f src =
  let src_len = src.len in 
  if src_len = 0 then { len = 0 ; arr = [||]}
  (* TODO: we may share the empty array 
     but sharing mutable state is very challenging, 
     the tricky part is to avoid mutating the immutable array,
     here it looks fine -- 
     invariant: whenever [.arr] mutated, make sure  it is not an empty array
     Actually no: since starting from an empty array 
     {[
       push v (* the address of v should not be changed *)
     ]}
  *)
  else 
    let src_arr = src.arr in 
    let first = f (Array.unsafe_get src_arr 0 ) in 
    let arr = Array.make  src_len first in
    for i = 1 to src_len - 1 do
      Array.unsafe_set arr i (f (Array.unsafe_get src_arr i))
    done;
    {
      len = src_len;
      arr = arr;
    }

let init len f =
  if len < 0 then invalid_arg  "Resize_array.init"
  else if len = 0 then { len = 0 ; arr = [||] }
  else 
    let first = f 0 in 
    let arr = Array.make len first in
    for i = 1 to len - 1 do
      Array.unsafe_set arr i (f i)
    done;
    {

      len ;
      arr 
    }



  let make initsize : t =
    if initsize < 0 then invalid_arg  "Resize_array.make" ;
    {

      len = 0;
      arr = Array.make  initsize null ;
    }



  let reserve (d : t ) s = 
    let d_len = d.len in 
    let d_arr = d.arr in 
    if s < d_len || s < Array.length d_arr then ()
    else 
      let new_capacity = min Sys.max_array_length s in 
      let new_d_arr = Array.make new_capacity null in 
       unsafe_blit d_arr 0 new_d_arr 0 d_len;
      d.arr <- new_d_arr 

  let push (d : t) v  =
    let d_len = d.len in
    let d_arr = d.arr in 
    let d_arr_len = Array.length d_arr in
    if d_arr_len = 0 then
      begin 
        d.len <- 1 ;
        d.arr <- [| v |]
      end
    else  
      begin 
        if d_len = d_arr_len then 
          begin
            if d_len >= Sys.max_array_length then 
              failwith "exceeds max_array_length";
            let new_capacity = min Sys.max_array_length d_len * 2 
            (* [d_len] can not be zero, so [*2] will enlarge   *)
            in
            let new_d_arr = Array.make new_capacity null in 
            d.arr <- new_d_arr;
             unsafe_blit d_arr 0 new_d_arr 0 d_len ;
          end;
        d.len <- d_len + 1;
        Array.unsafe_set d.arr d_len v
      end

(** delete element at offset [idx], will raise exception when have invalid input *)
  let delete (d : t) idx =
    let d_len = d.len in 
    if idx < 0 || idx >= d_len then invalid_arg "Resize_array.delete" ;
    let arr = d.arr in 
     unsafe_blit arr (idx + 1) arr idx  (d_len - idx - 1);
    let idx = d_len - 1 in 
    d.len <- idx
    
# 362 "ext/vec.cppo.ml"
(** pop the last element, a specialized version of [delete] *)
  let pop (d : t) = 
    let idx  = d.len - 1  in
    if idx < 0 then invalid_arg "Resize_array.pop";
    d.len <- idx
  
# 373 "ext/vec.cppo.ml"
(** pop and return the last element *)  
  let get_last_and_pop (d : t) = 
    let idx  = d.len - 1  in
    if idx < 0 then invalid_arg "Resize_array.get_last_and_pop";
    let last = Array.unsafe_get d.arr idx in 
    d.len <- idx 
    
# 384 "ext/vec.cppo.ml"
    ;
    last 

(** delete elements start from [idx] with length [len] *)
  let delete_range (d : t) idx len =
    let d_len = d.len in 
    if len < 0 || idx < 0 || idx + len > d_len then invalid_arg  "Resize_array.delete_range"  ;
    let arr = d.arr in 
     unsafe_blit arr (idx + len) arr idx (d_len  - idx - len);
    d.len <- d_len - len

# 402 "ext/vec.cppo.ml"
(** delete elements from [idx] with length [len] return the deleted elements as a new vec*)
  let get_and_delete_range (d : t) idx len : t = 
    let d_len = d.len in 
    if len < 0 || idx < 0 || idx + len > d_len then invalid_arg  "Resize_array.get_and_delete_range"  ;
    let arr = d.arr in 
    let value =  unsafe_sub arr idx len in
     unsafe_blit arr (idx + len) arr idx (d_len  - idx - len);
    d.len <- d_len - len; 
    
# 416 "ext/vec.cppo.ml"
    {len = len ; arr = value}


  (** Below are simple wrapper around normal Array operations *)  

  let clear (d : t ) =
    
# 428 "ext/vec.cppo.ml"
    d.len <- 0



  let inplace_filter f (d : t) : unit = 
    let d_arr = d.arr in     
    let d_len = d.len in
    let p = ref 0 in
    for i = 0 to d_len - 1 do 
      let x = Array.unsafe_get d_arr i in 
      if f x then 
        begin 
          let curr_p = !p in 
          (if curr_p <> i then 
             Array.unsafe_set d_arr curr_p x) ;
          incr p
        end
    done ;
    let last = !p  in 
    
# 448 "ext/vec.cppo.ml"
    d.len <-  last 
    (* INT , there is not need to reset it, since it will cause GC behavior *)

  
# 454 "ext/vec.cppo.ml"
  let inplace_filter_from start f (d : t) : unit = 
    if start < 0 then invalid_arg "Vec.inplace_filter_from"; 
    let d_arr = d.arr in     
    let d_len = d.len in
    let p = ref start in    
    for i = start to d_len - 1 do 
      let x = Array.unsafe_get d_arr i in 
      if f x then 
        begin 
          let curr_p = !p in 
          (if curr_p <> i then 
             Array.unsafe_set d_arr curr_p x) ;
          incr p
        end
    done ;
    let last = !p  in 
    
# 471 "ext/vec.cppo.ml"
    d.len <-  last 


# 477 "ext/vec.cppo.ml"
(** inplace filter the elements and accumulate the non-filtered elements *)
  let inplace_filter_with  f ~cb_no acc (d : t)  = 
    let d_arr = d.arr in     
    let p = ref 0 in
    let d_len = d.len in
    let acc = ref acc in 
    for i = 0 to d_len - 1 do 
      let x = Array.unsafe_get d_arr i in 
      if f x then 
        begin 
          let curr_p = !p in 
          (if curr_p <> i then 
             Array.unsafe_set d_arr curr_p x) ;
          incr p
        end
      else 
        acc := cb_no  x  !acc
    done ;
    let last = !p  in 
    
# 497 "ext/vec.cppo.ml"
    d.len <-  last 
    (* INT , there is not need to reset it, since it will cause GC behavior *)
    
# 502 "ext/vec.cppo.ml"
    ; !acc 




end
module Resize_array : sig 
#1 "resize_array.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

module Make ( Resize : Vec_gen.ResizeType) : Vec_gen.S with type elt = Resize.t 



end = struct
#1 "resize_array.ml"
# 1 "ext/vec.cppo.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
# 25 "ext/vec.cppo.ml"
external unsafe_blit : 
    'a array -> int -> 'a array -> int -> int -> unit = "caml_array_blit"
module Make ( Resize :  Vec_gen.ResizeType) = struct
  type elt = Resize.t 

  let null = Resize.null 
  

# 41 "ext/vec.cppo.ml"
external unsafe_sub : 'a array -> int -> int -> 'a array = "caml_array_sub"

type  t = {
  mutable arr : elt array ;
  mutable len : int ;  
}

let length d = d.len

let compact d =
  let d_arr = d.arr in 
  if d.len <> Array.length d_arr then 
    begin
      let newarr = unsafe_sub d_arr 0 d.len in 
      d.arr <- newarr
    end
let singleton v = 
  {
    len = 1 ; 
    arr = [|v|]
  }

let empty () =
  {
    len = 0;
    arr = [||];
  }

let is_empty d =
  d.len = 0

let reset d = 
  d.len <- 0; 
  d.arr <- [||]


(* For [to_*] operations, we should be careful to call {!Array.*} function 
   in case we operate on the whole array
*)
let to_list d =
  let rec loop (d_arr : elt array) idx accum =
    if idx < 0 then accum else loop d_arr (idx - 1) (Array.unsafe_get d_arr idx :: accum)
  in
  loop d.arr (d.len - 1) []


let of_list lst =
  let arr = Array.of_list lst in 
  { arr ; len = Array.length arr}


let to_array d = 
  unsafe_sub d.arr 0 d.len

let of_array src =
  {
    len = Array.length src;
    arr = Array.copy src;
    (* okay to call {!Array.copy}*)
  }
let of_sub_array arr off len = 
  { 
    len = len ; 
    arr = Array.sub arr off len  
  }  
let unsafe_internal_array v = v.arr  
(* we can not call {!Array.copy} *)
let copy src =
  let len = src.len in
  {
    len ;
    arr = unsafe_sub src.arr 0 len ;
  }

(* FIXME *)
let reverse_in_place src = 
  Ext_array.reverse_range src.arr 0 src.len 




(* {!Array.sub} is not enough for error checking, it 
   may contain some garbage
 *)
let sub (src : t) start len =
  let src_len = src.len in 
  if len < 0 || start > src_len - len then invalid_arg "Vec.sub"
  else 
  { len ; 
    arr = unsafe_sub src.arr start len }

let iter d  f = 
  let arr = d.arr in 
  for i = 0 to d.len - 1 do
    f (Array.unsafe_get arr i)
  done

let iteri d f =
  let arr = d.arr in
  for i = 0 to d.len - 1 do
    f i (Array.unsafe_get arr i)
  done

let iter_range d ~from ~to_ f =
  if from < 0 || to_ >= d.len then invalid_arg "Resize_array.iter_range"
  else 
    let d_arr = d.arr in 
    for i = from to to_ do 
      f  (Array.unsafe_get d_arr i)
    done

let iteri_range d ~from ~to_ f =
  if from < 0 || to_ >= d.len then invalid_arg "Resize_array.iteri_range"
  else 
    let d_arr = d.arr in 
    for i = from to to_ do 
      f i (Array.unsafe_get d_arr i)
    done

let map_into_array f src =
  let src_len = src.len in 
  let src_arr = src.arr in 
  if src_len = 0 then [||]
  else 
    let first_one = f (Array.unsafe_get src_arr 0) in 
    let arr = Array.make  src_len  first_one in
    for i = 1 to src_len - 1 do
      Array.unsafe_set arr i (f (Array.unsafe_get src_arr i))
    done;
    arr 
let map_into_list f src = 
  let src_len = src.len in 
  let src_arr = src.arr in 
  if src_len = 0 then []
  else 
    let acc = ref [] in         
    for i =  src_len - 1 downto 0 do
      acc := f (Array.unsafe_get src_arr i) :: !acc
    done;
    !acc

let mapi f src =
  let len = src.len in 
  if len = 0 then { len ; arr = [| |] }
  else 
    let src_arr = src.arr in 
    let arr = Array.make len (Array.unsafe_get src_arr 0) in
    for i = 1 to len - 1 do
      Array.unsafe_set arr i (f i (Array.unsafe_get src_arr i))
    done;
    {
      len ;
      arr ;
    }

let fold_left f x a =
  let rec loop a_len (a_arr : elt array) idx x =
    if idx >= a_len then x else 
      loop a_len a_arr (idx + 1) (f x (Array.unsafe_get a_arr idx))
  in
  loop a.len a.arr 0 x

let fold_right f a x =
  let rec loop (a_arr : elt array) idx x =
    if idx < 0 then x
    else loop a_arr (idx - 1) (f (Array.unsafe_get a_arr idx) x)
  in
  loop a.arr (a.len - 1) x

(**  
   [filter] and [inplace_filter]
*)
let filter f d =
  let new_d = copy d in 
  let new_d_arr = new_d.arr in 
  let d_arr = d.arr in
  let p = ref 0 in
  for i = 0 to d.len  - 1 do
    let x = Array.unsafe_get d_arr i in
    (* TODO: can be optimized for segments blit *)
    if f x  then
      begin
        Array.unsafe_set new_d_arr !p x;
        incr p;
      end;
  done;
  new_d.len <- !p;
  new_d 

let equal eq x y : bool = 
  if x.len <> y.len then false 
  else 
    let rec aux x_arr y_arr i =
      if i < 0 then true else  
      if eq (Array.unsafe_get x_arr i) (Array.unsafe_get y_arr i) then 
        aux x_arr y_arr (i - 1)
      else false in 
    aux x.arr y.arr (x.len - 1)

let get d i = 
  if i < 0 || i >= d.len then invalid_arg "Resize_array.get"
  else Array.unsafe_get d.arr i
let unsafe_get d i = Array.unsafe_get d.arr i 
let last d = 
  if d.len <= 0 then invalid_arg   "Resize_array.last"
  else Array.unsafe_get d.arr (d.len - 1)

let capacity d = Array.length d.arr

(* Attention can not use {!Array.exists} since the bound is not the same *)  
let exists p d = 
  let a = d.arr in 
  let n = d.len in   
  let rec loop i =
    if i = n then false
    else if p (Array.unsafe_get a i) then true
    else loop (succ i) in
  loop 0

let map f src =
  let src_len = src.len in 
  if src_len = 0 then { len = 0 ; arr = [||]}
  (* TODO: we may share the empty array 
     but sharing mutable state is very challenging, 
     the tricky part is to avoid mutating the immutable array,
     here it looks fine -- 
     invariant: whenever [.arr] mutated, make sure  it is not an empty array
     Actually no: since starting from an empty array 
     {[
       push v (* the address of v should not be changed *)
     ]}
  *)
  else 
    let src_arr = src.arr in 
    let first = f (Array.unsafe_get src_arr 0 ) in 
    let arr = Array.make  src_len first in
    for i = 1 to src_len - 1 do
      Array.unsafe_set arr i (f (Array.unsafe_get src_arr i))
    done;
    {
      len = src_len;
      arr = arr;
    }

let init len f =
  if len < 0 then invalid_arg  "Resize_array.init"
  else if len = 0 then { len = 0 ; arr = [||] }
  else 
    let first = f 0 in 
    let arr = Array.make len first in
    for i = 1 to len - 1 do
      Array.unsafe_set arr i (f i)
    done;
    {

      len ;
      arr 
    }



  let make initsize : t =
    if initsize < 0 then invalid_arg  "Resize_array.make" ;
    {

      len = 0;
      arr = Array.make  initsize null ;
    }



  let reserve (d : t ) s = 
    let d_len = d.len in 
    let d_arr = d.arr in 
    if s < d_len || s < Array.length d_arr then ()
    else 
      let new_capacity = min Sys.max_array_length s in 
      let new_d_arr = Array.make new_capacity null in 
       unsafe_blit d_arr 0 new_d_arr 0 d_len;
      d.arr <- new_d_arr 

  let push (d : t) v  =
    let d_len = d.len in
    let d_arr = d.arr in 
    let d_arr_len = Array.length d_arr in
    if d_arr_len = 0 then
      begin 
        d.len <- 1 ;
        d.arr <- [| v |]
      end
    else  
      begin 
        if d_len = d_arr_len then 
          begin
            if d_len >= Sys.max_array_length then 
              failwith "exceeds max_array_length";
            let new_capacity = min Sys.max_array_length d_len * 2 
            (* [d_len] can not be zero, so [*2] will enlarge   *)
            in
            let new_d_arr = Array.make new_capacity null in 
            d.arr <- new_d_arr;
             unsafe_blit d_arr 0 new_d_arr 0 d_len ;
          end;
        d.len <- d_len + 1;
        Array.unsafe_set d.arr d_len v
      end

(** delete element at offset [idx], will raise exception when have invalid input *)
  let delete (d : t) idx =
    let d_len = d.len in 
    if idx < 0 || idx >= d_len then invalid_arg "Resize_array.delete" ;
    let arr = d.arr in 
     unsafe_blit arr (idx + 1) arr idx  (d_len - idx - 1);
    let idx = d_len - 1 in 
    d.len <- idx
    
# 358 "ext/vec.cppo.ml"
    ;
    Array.unsafe_set arr idx  null
    
# 362 "ext/vec.cppo.ml"
(** pop the last element, a specialized version of [delete] *)
  let pop (d : t) = 
    let idx  = d.len - 1  in
    if idx < 0 then invalid_arg "Resize_array.pop";
    d.len <- idx
    
# 369 "ext/vec.cppo.ml"
    ;    
    Array.unsafe_set d.arr idx null
  
# 373 "ext/vec.cppo.ml"
(** pop and return the last element *)  
  let get_last_and_pop (d : t) = 
    let idx  = d.len - 1  in
    if idx < 0 then invalid_arg "Resize_array.get_last_and_pop";
    let last = Array.unsafe_get d.arr idx in 
    d.len <- idx 
    
# 381 "ext/vec.cppo.ml"
    ;
    Array.unsafe_set d.arr idx null
    
# 384 "ext/vec.cppo.ml"
    ;
    last 

(** delete elements start from [idx] with length [len] *)
  let delete_range (d : t) idx len =
    let d_len = d.len in 
    if len < 0 || idx < 0 || idx + len > d_len then invalid_arg  "Resize_array.delete_range"  ;
    let arr = d.arr in 
     unsafe_blit arr (idx + len) arr idx (d_len  - idx - len);
    d.len <- d_len - len
    
# 396 "ext/vec.cppo.ml"
    ;
    for i = d_len - len to d_len - 1 do
      Array.unsafe_set arr i null
    done

# 402 "ext/vec.cppo.ml"
(** delete elements from [idx] with length [len] return the deleted elements as a new vec*)
  let get_and_delete_range (d : t) idx len : t = 
    let d_len = d.len in 
    if len < 0 || idx < 0 || idx + len > d_len then invalid_arg  "Resize_array.get_and_delete_range"  ;
    let arr = d.arr in 
    let value =  unsafe_sub arr idx len in
     unsafe_blit arr (idx + len) arr idx (d_len  - idx - len);
    d.len <- d_len - len; 
    
# 412 "ext/vec.cppo.ml"
    for i = d_len - len to d_len - 1 do
      Array.unsafe_set arr i null
    done;
    
# 416 "ext/vec.cppo.ml"
    {len = len ; arr = value}


  (** Below are simple wrapper around normal Array operations *)  

  let clear (d : t ) =
    
# 424 "ext/vec.cppo.ml"
    for i = 0 to d.len - 1 do 
      Array.unsafe_set d.arr i null
    done;
    
# 428 "ext/vec.cppo.ml"
    d.len <- 0



  let inplace_filter f (d : t) : unit = 
    let d_arr = d.arr in     
    let d_len = d.len in
    let p = ref 0 in
    for i = 0 to d_len - 1 do 
      let x = Array.unsafe_get d_arr i in 
      if f x then 
        begin 
          let curr_p = !p in 
          (if curr_p <> i then 
             Array.unsafe_set d_arr curr_p x) ;
          incr p
        end
    done ;
    let last = !p  in 
    
# 451 "ext/vec.cppo.ml"
    delete_range d last  (d_len - last)

  
# 454 "ext/vec.cppo.ml"
  let inplace_filter_from start f (d : t) : unit = 
    if start < 0 then invalid_arg "Vec.inplace_filter_from"; 
    let d_arr = d.arr in     
    let d_len = d.len in
    let p = ref start in    
    for i = start to d_len - 1 do 
      let x = Array.unsafe_get d_arr i in 
      if f x then 
        begin 
          let curr_p = !p in 
          (if curr_p <> i then 
             Array.unsafe_set d_arr curr_p x) ;
          incr p
        end
    done ;
    let last = !p  in 
    
# 473 "ext/vec.cppo.ml"
    delete_range d last  (d_len - last)


# 477 "ext/vec.cppo.ml"
(** inplace filter the elements and accumulate the non-filtered elements *)
  let inplace_filter_with  f ~cb_no acc (d : t)  = 
    let d_arr = d.arr in     
    let p = ref 0 in
    let d_len = d.len in
    let acc = ref acc in 
    for i = 0 to d_len - 1 do 
      let x = Array.unsafe_get d_arr i in 
      if f x then 
        begin 
          let curr_p = !p in 
          (if curr_p <> i then 
             Array.unsafe_set d_arr curr_p x) ;
          incr p
        end
      else 
        acc := cb_no  x  !acc
    done ;
    let last = !p  in 
    
# 500 "ext/vec.cppo.ml"
    delete_range d last  (d_len - last)
    
# 502 "ext/vec.cppo.ml"
    ; !acc 



# 507 "ext/vec.cppo.ml"
end

end
module Int_vec_vec : sig 
#1 "int_vec_vec.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

include Vec_gen.S with type elt = Int_vec.t

end = struct
#1 "int_vec_vec.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


include Resize_array.Make(struct type t = Int_vec.t let null = Int_vec.empty () end)

end
module Ext_scc : sig 
#1 "ext_scc.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 



type node = Int_vec.t
(** Assume input is int array with offset from 0 
    Typical input 
    {[
      [|
        [ 1 ; 2 ]; // 0 -> 1,  0 -> 2 
        [ 1 ];   // 0 -> 1 
        [ 2 ]  // 0 -> 2 
      |]
    ]}
    Note that we can tell how many nodes by calculating 
    [Array.length] of the input 
*)
val graph : Int_vec.t array -> Int_vec_vec.t


(** Used for unit test *)
val graph_check : node array -> int * int list 

end = struct
#1 "ext_scc.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
type node = Int_vec.t 
(** 
   [int] as data for this algorithm
   Pros:
   1. Easy to eoncode algorithm (especially given that the capacity of node is known)
   2. Algorithms itself are much more efficient
   3. Node comparison semantics is clear
   4. Easy to print output
   Cons:
   1. post processing input data  
 *)
let min_int (x : int) y = if x < y then x else y  


let graph  e =
  let index = ref 0 in 
  let s = Int_vec.empty () in

  let output = Int_vec_vec.empty () in (* collect output *)
  let node_numes = Array.length e in
  
  let on_stack_array = Array.make node_numes false in
  let index_array = Array.make node_numes (-1) in 
  let lowlink_array = Array.make node_numes (-1) in
  
  let rec scc v_data  =
    let new_index = !index + 1 in 
    index := new_index ;
    Int_vec.push s v_data; 

    index_array.(v_data) <- new_index ;  
    lowlink_array.(v_data) <- new_index ; 
    on_stack_array.(v_data) <- true ;    
    let v = e.(v_data) in     
    Int_vec.iter v (fun w_data  ->
        if Array.unsafe_get index_array w_data < 0 then (* not processed *)
          begin  
            scc w_data;
            Array.unsafe_set lowlink_array v_data  
              (min_int (Array.unsafe_get lowlink_array v_data) (Array.unsafe_get lowlink_array w_data))
          end  
        else if Array.unsafe_get on_stack_array w_data then 
          (* successor is in stack and hence in current scc *)
          begin 
            Array.unsafe_set lowlink_array v_data  
              (min_int (Array.unsafe_get lowlink_array v_data) (Array.unsafe_get lowlink_array w_data))
          end
      ) ; 

    if Array.unsafe_get lowlink_array v_data = Array.unsafe_get index_array v_data then
      (* start a new scc *)
      begin
        let s_len = Int_vec.length s in
        let last_index = ref (s_len - 1) in 
        let u = ref (Int_vec.unsafe_get s !last_index) in
        while  !u <> v_data do 
          Array.unsafe_set on_stack_array (!u)  false ; 
          last_index := !last_index - 1;
          u := Int_vec.unsafe_get s !last_index
        done ;
        on_stack_array.(v_data) <- false; (* necessary *)
        Int_vec_vec.push output (Int_vec.get_and_delete_range s !last_index (s_len  - !last_index));
      end   
  in
  for i = 0 to node_numes - 1 do 
    if Array.unsafe_get index_array i < 0 then scc i
  done ;
  output 

let graph_check v = 
  let v = graph v in 
  Int_vec_vec.length v, 
  Int_vec_vec.fold_left (fun acc x -> Int_vec.length x :: acc ) [] v  

end
module Hash_set_ident_mask : sig 
#1 "hash_set_ident_mask.mli"


(** Based on [hash_set] specialized for mask operations  *)
type ident = Ident.t  


type t
val create: int ->  t


(* add one ident *)
val add_unmask :  t -> ident -> unit


(** [check_mask h key] if [key] exists mask it otherwise nothing
    return true if all keys are masked otherwise false
*)
val mask_check_all_hit : ident ->  t -> bool

(** [iter_and_unmask f h] iterating the collection and mask all idents,
    dont consul the collection in function [f]
    TODO: what happens if an exception raised in the callback,
    would the hashtbl still be in consistent state?
*)
val iter_and_unmask: (ident -> bool ->  unit) ->  t -> unit



  

end = struct
#1 "hash_set_ident_mask.ml"

(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



type ident = Ident.t

type key = {ident : ident ; mutable mask : bool }

type t = {
  mutable size : int ; 
  mutable data : key list array;
  initial_size : int ; 
  mutable mask_size : int (* mark how many idents are marked *)
}



let key_index_by_ident (h : t) (key : Ident.t) =    
  (Bs_hash_stubs.hash_string_int  key.name key.stamp) land (Array.length h.data - 1)

let key_index (h :  t ) ({ident = key} : key) =
  key_index_by_ident h key 


let create  initial_size =
  let s = Ext_util.power_2_above 8 initial_size in
  { initial_size = s; size = 0; data = Array.make s [] ; mask_size = 0}

let iter_and_unmask f h =
  let rec do_bucket buckets = 
    match buckets with 
    | [ ] ->
      ()
    | k ::  rest ->    
      f k.ident k.mask ;
      if k.mask then 
        begin 
          k.mask <- false ;
          (* we can set [h.mask_size] to zero,
             however, it would result inconsistent state
             once [f] throw
          *)
          h.mask_size <- h.mask_size - 1
        end; 
      do_bucket rest 
  in
  let d = h.data in
  for i = 0 to Array.length d - 1 do
    do_bucket (Array.unsafe_get d i)
  done
  

let rec small_bucket_mem key lst =
  match lst with 
  | [] -> false 
  | {ident = key1 }::rest -> 
    Ext_ident.equal key   key1 ||
    match rest with 
    | [] -> false 
    | {ident = key2} :: rest -> 
      Ext_ident.equal key   key2 ||
      match rest with 
      | [] -> false 
      | {ident = key3; _} :: rest -> 
        Ext_ident.equal key   key3 ||
        small_bucket_mem key rest 

let resize indexfun h =
  let odata = h.data in
  let osize = Array.length odata in
  let nsize = osize * 2 in
  if nsize < Sys.max_array_length then begin
    let ndata = Array.make nsize [ ] in
    h.data <- ndata;          (* so that indexfun sees the new bucket count *)
    let rec insert_bucket = function
        [ ] -> ()
      | key :: rest ->
        let nidx = indexfun h key in
        ndata.(nidx) <- key :: ndata.(nidx);
        insert_bucket rest
    in
    for i = 0 to osize - 1 do
      insert_bucket (Array.unsafe_get odata i)
    done
  end

let add_unmask (h : t) (key : Ident.t) =
  let i = key_index_by_ident h key  in 
  let h_data = h.data in 
  let old_bucket = Array.unsafe_get h_data i in
  if not (small_bucket_mem key old_bucket) then 
    begin 
      Array.unsafe_set h_data i ({ident = key; mask = false} :: old_bucket);
      h.size <- h.size + 1 ;
      if h.size > Array.length h_data lsl 1 then resize key_index h
    end




let rec small_bucket_mask  key lst =
  match lst with 
  | [] -> false 
  | key1::rest -> 
    if Ext_ident.equal key   key1.ident  then 
      if key1.mask then false else (key1.mask <- true ; true) 
    else 
      match rest with 
      | [] -> false
      | key2 :: rest -> 
        if Ext_ident.equal key key2.ident  then 
          if key2.mask then false else (key2.mask <- true ; true)
        else 
          match rest with 
          | [] -> false
          | key3 :: rest -> 
            if Ext_ident.equal key key3.ident then 
              if key3.mask then false else (key3.mask <- true ; true)
            else 
              small_bucket_mask  key rest 

let mask_check_all_hit (key : Ident.t) (h : t)  =     
  if 
    small_bucket_mask key 
      (Array.unsafe_get h.data (key_index_by_ident h key )) then 
    begin 
      h.mask_size <- h.mask_size + 1 
    end;
  h.size = h.mask_size 




end
module Int_vec_util : sig 
#1 "int_vec_util.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


val mem : int -> Int_vec.t -> bool
end = struct
#1 "int_vec_util.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


let rec unsafe_mem_aux arr  i (key : int) bound = 
    if i <= bound then 
        if Array.unsafe_get arr i = (key : int) then 
            true 
         else unsafe_mem_aux arr (i + 1) key bound    
    else false 
    


let mem key (x : Int_vec.t) =
    let internal_array = Int_vec.unsafe_internal_array x in 
    let len = Int_vec.length x in 
    unsafe_mem_aux internal_array 0 key (len - 1)
    
end
module Ordered_hash_map_gen
= struct
#1 "ordered_hash_map_gen.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


(* does not support [remove], 
    so that the adding order is strict and continous  
 *)

module type S =
sig
  type key
  type 'value t
  val create: int ->  'value t
  val clear : 'vaulue t -> unit
  val reset : 'value t -> unit
  val copy: 'value t -> 'value t
  val add : 'value t -> key -> 'value -> unit
  val mem : 'value t -> key -> bool
  val rank : 'value t -> key -> int (* -1 if not found*)
  val find_value : 'value t -> key -> 'value (* raise if not found*)
  val iter: (key -> 'value -> int -> unit) ->  'value t -> unit
  val fold: (key -> 'value -> int -> 'b -> 'b) ->  'value t -> 'b -> 'b
  val length:  'value t -> int
  val stats: 'value t -> Hashtbl.statistics
  val elements : 'value t -> key list 
  val choose : 'value t -> key 
  val to_sorted_array: 'value t -> key array
end

(* We do dynamic hashing, and resize the table and rehash the elements
   when buckets become too long. *)
type ('a,'b) bucket = 
  | Empty 
  | Cons of 'a * int * 'b  * ('a,'b) bucket

type ('a,'b) t =
  { mutable size: int;                        (* number of entries *)
    mutable data: ('a,'b) bucket array;  (* the buckets *)
    initial_size: int;                        (* initial array size *)
  }




let create  initial_size =
  let s = Ext_util.power_2_above 16 initial_size in
  { initial_size = s; size = 0; data = Array.make s Empty }

let clear h =
  h.size <- 0;
  let len = Array.length h.data in
  for i = 0 to len - 1 do
    Array.unsafe_set h.data i  Empty
  done

let reset h =
  h.size <- 0;
  h.data <- Array.make h.initial_size Empty


let copy h = { h with data = Array.copy h.data }

let length h = h.size

let resize indexfun h =
  let odata = h.data in
  let osize = Array.length odata in
  let nsize = osize * 2 in
  if nsize < Sys.max_array_length then begin
    let ndata = Array.make nsize Empty in
    h.data <- ndata;          (* so that indexfun sees the new bucket count *)
    let rec insert_bucket = function
        Empty -> ()
      | Cons(key,info,data,rest) ->
        let nidx = indexfun h key in
        ndata.(nidx) <- Cons(key,info,data, ndata.(nidx));
        insert_bucket rest
    in
    for i = 0 to osize - 1 do
      insert_bucket (Array.unsafe_get odata i)
    done
  end

let iter f h =
  let rec do_bucket = function
    | Empty ->
      ()
    | Cons(k ,i, value, rest) ->
      f k value i; do_bucket rest in
  let d = h.data in
  for i = 0 to Array.length d - 1 do
    do_bucket (Array.unsafe_get d i)
  done

let choose h = 
  let rec aux arr offset len = 
    if offset >= len then raise Not_found
    else 
      match Array.unsafe_get arr offset with 
      | Empty -> aux arr (offset + 1) len 
      | Cons (k,_,_,rest) -> k 
  in
  aux h.data 0 (Array.length h.data)

let to_sorted_array h = 
  if h.size = 0 then [||]
  else 
    let v = choose h in 
    let arr = Array.make h.size v in
    iter (fun k _ i -> Array.unsafe_set arr i k) h;
    arr 

let fold f h init =
  let rec do_bucket b accu =
    match b with
      Empty ->
      accu
    | Cons( k , i,  value, rest) ->
      do_bucket rest (f k  value i  accu) in
  let d = h.data in
  let accu = ref init in
  for i = 0 to Array.length d - 1 do
    accu := do_bucket (Array.unsafe_get d i) !accu
  done;
  !accu

let elements set = 
  fold  (fun k  _  _ acc  ->  k :: acc) set []


let rec bucket_length acc (x : _ bucket) = 
  match x with 
  | Empty -> 0
  | Cons(_,_,_,rest) -> bucket_length (acc + 1) rest  

let stats h =
  let mbl =
    Ext_array.fold_left h.data 0 (fun m b -> max m (bucket_length 0 b))  in
  let histo = Array.make (mbl + 1) 0 in
  Ext_array.iter h.data
    (fun b ->
       let l = bucket_length 0 b in
       histo.(l) <- histo.(l) + 1)
    ;
  { Hashtbl.num_bindings = h.size;
    num_buckets = Array.length h.data;
    max_bucket_length = mbl;
    bucket_histogram = histo }



end
module Ordered_hash_map_local_ident : sig 
#1 "ordered_hash_map_local_ident.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



(** Hash algorithm only hash 
    stamp, this makes sense when  all identifiers are local (no global)
*)
include Ordered_hash_map_gen.S with type key = Ident.t

end = struct
#1 "ordered_hash_map_local_ident.ml"
  
# 10 "ext/ordered_hash_map.cppo.ml"
  type key = Ident.t
  type   'value t = (key,'value) Ordered_hash_map_gen.t
  let key_index (h : _ t) (key : key) =
    (Bs_hash_stubs.hash_int  key.stamp) land (Array.length h.data - 1)
  let equal_key = Ext_ident.equal


# 20 "ext/ordered_hash_map.cppo.ml"
open Ordered_hash_map_gen

let create = create
let clear = clear
let reset = reset
let copy = copy
let iter = iter
let fold = fold
let length = length
let stats = stats
let elements = elements
let choose = choose
let to_sorted_array = to_sorted_array



let rec small_bucket_mem key lst =
  match lst with 
  | Empty -> false 
  | Cons(key1,_, _, rest) -> 
    equal_key key key1 ||
    match rest with 
    | Empty -> false 
    | Cons(key2 , _,_, rest) -> 
      equal_key key  key2 ||
      match rest with 
      | Empty -> false 
      | Cons(key3,_, _, rest) -> 
        equal_key key  key3 ||
        small_bucket_mem key rest 

let rec small_bucket_rank key lst =
  match lst with 
  | Empty -> -1
  | Cons(key1,i,_, rest) -> 
    if equal_key key key1 then i 
    else match rest with 
      | Empty -> -1 
      | Cons(key2,i2, _, rest) -> 
        if equal_key key  key2 then i2 else
          match rest with 
          | Empty -> -1 
          | Cons(key3,i3, _, rest) -> 
            if equal_key key  key3 then i3 else
              small_bucket_rank key rest 
let rec small_bucket_find_value  key (lst : (_,_) bucket)   =
  match lst with 
  | Empty -> raise Not_found
  | Cons(key1,_,value, rest) -> 
    if equal_key key  key1 then value 
    else match rest with 
      | Empty -> raise Not_found 
      | Cons(key2,_,value, rest) -> 
        if equal_key key  key2 then value else
          match rest with 
          | Empty -> raise Not_found 
          | Cons(key3, _ , value, rest) -> 
            if equal_key key  key3 then value else
              small_bucket_find_value key rest 

let add h key value =
  let i = key_index h key  in 
  if not (small_bucket_mem key  h.data.(i)) then 
    begin 
      h.data.(i) <- Cons(key,h.size, value, h.data.(i));
      h.size <- h.size + 1 ;
      if h.size > Array.length h.data lsl 1 then resize key_index h
    end

let mem h key =
  small_bucket_mem key (Array.unsafe_get h.data (key_index h key)) 
let rank h key = 
  small_bucket_rank key(Array.unsafe_get h.data (key_index h key))  

let find_value h key =
  small_bucket_find_value key (Array.unsafe_get h.data (key_index h key))













end
module Lam_scc : sig 
#1 "lam_scc.mli"
(* Copyright (C) 2018 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



type bindings = (Ident.t * Lam.t) list

val scc_bindings : bindings -> bindings list 
val scc : bindings -> Lam.t -> Lam.t  -> Lam.t 
end = struct
#1 "lam_scc.ml"
(* Copyright (C) 2018 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



(**
    [hit_mask mask lambda] iters through the lambda
    set the bit of corresponding [id] if [id] is hit.
    As an optimization step if [mask_check_all_hit],
    there is no need to iter such lambda any more
*)
let hit_mask ( mask : Hash_set_ident_mask.t) (l : Lam.t) : bool =
  let rec 
    hit_opt (x : Lam.t option) = 
    match x with 
    | None -> false 
    | Some a -> hit a
    and hit_var (id : Ident.t) = Hash_set_ident_mask.mask_check_all_hit id mask
    and hit_list_snd : 'a. ('a * Lam.t ) list -> bool = fun x ->    
      Ext_list.exists_snd x hit
    and hit_list xs = Ext_list.exists  xs hit
    and hit (l : Lam.t) =
    match l  with
    | Lvar id -> hit_var id
    | Lassign(id, e) ->
      hit_var id || hit e
    | Lstaticcatch(e1, (_,vars), e2) ->
      hit e1 || hit e2
    | Ltrywith(e1, exn, e2) ->
      hit e1 || hit e2
    | Lfunction{body;params} ->
      hit body
    | Llet(str, id, arg, body) ->
      hit arg || hit body
    | Lletrec(decl, body) ->
      hit body ||
      hit_list_snd decl
    | Lfor(v, e1, e2, dir, e3) ->
      hit e1 || hit e2 || hit e3
    | Lconst _ -> false
    | Lapply{fn; args; _} ->
      hit fn || hit_list args
    | Lglobal_module id (* playsafe *)
      -> false
    | Lprim {args; _} ->
      hit_list args
    | Lswitch(arg, sw) ->
      hit arg ||
      hit_list_snd sw.sw_consts ||
      hit_list_snd sw.sw_blocks ||
      hit_opt sw.sw_failaction
    | Lstringswitch (arg,cases,default) ->
      hit arg ||
      hit_list_snd cases ||
      hit_opt default
    | Lstaticraise (_,args) ->
      hit_list args
    | Lifthenelse(e1, e2, e3) ->
      hit e1 || hit e2 || hit e3
    | Lsequence(e1, e2) ->
      hit e1 || hit e2
    | Lwhile(e1, e2) ->
      hit e1 || hit e2
    | Lsend (k, met, obj, args, _) ->
      hit met || hit obj || hit_list args  
  in hit l



 type bindings = (Ident.t * Lam.t) list


let preprocess_deps (groups : bindings) : _ * Ident.t array * Int_vec.t array   =
  let len = List.length groups in
  let domain : _ Ordered_hash_map_local_ident.t =
    Ordered_hash_map_local_ident.create len in
  let mask = Hash_set_ident_mask.create len in
  List.iter (fun (x,lam) ->
      Ordered_hash_map_local_ident.add domain x lam;
      Hash_set_ident_mask.add_unmask mask x;
    ) groups ;
  let int_mapping = Ordered_hash_map_local_ident.to_sorted_array domain in
  let node_vec = Array.make (Array.length int_mapping) (Int_vec.empty ()) in
  domain
  |> Ordered_hash_map_local_ident.iter ( fun id lam key_index ->
      let base_key =  node_vec.(key_index) in
      ignore (hit_mask mask lam) ;
      mask |> Hash_set_ident_mask.iter_and_unmask (fun ident hit  ->
          if hit then
            begin
              let key = Ordered_hash_map_local_ident.rank domain ident in
              Int_vec.push base_key key;
            end
        );

    ) ;
  domain, int_mapping , node_vec


let is_function_bind (_, (x : Lam.t)) =
  match x with
  | Lfunction _ -> true
  | _ -> false

let sort_single_binding_group (group : bindings) =
  if Ext_list.for_all group  is_function_bind then group
  else
    List.sort (fun (_,lama) (_,lamb) ->
        match (lama : Lam.t), (lamb : Lam.t) with
        | Lfunction _, Lfunction _ ->  0
        | Lfunction _ , _ -> -1
        | _, Lfunction _ -> 1
        | _,_ -> 0
      ) group

(** TODO: even for a singleton recursive function, tell whehter it is recursive or not ? *)
let scc_bindings (groups : bindings) : bindings list =
  match groups with
  | [ _ ] -> [ sort_single_binding_group groups ]
  | _ ->
    let domain, int_mapping, node_vec = preprocess_deps groups in
    let clusters : Int_vec_vec.t = Ext_scc.graph node_vec in
    if Int_vec_vec.length clusters <= 1 then [ sort_single_binding_group groups]
    else
      Int_vec_vec.fold_right (fun  (v : Int_vec.t) acc ->
          let bindings =
            Int_vec.map_into_list (fun i ->
                let id = int_mapping.(i) in
                let lam  = Ordered_hash_map_local_ident.find_value domain  id in
                (id,lam)
              ) v  in
          sort_single_binding_group bindings :: acc
        )  clusters []
(* single binding, it does not make sense to do scc,
   we can eliminate {[ let rec f x = x + x  ]}, but it happens rarely in real world
*)
let scc  (groups :  bindings)  ( lam : Lam.t) ( body : Lam.t)
  =
  begin match groups with
    | [ (id,bind) ] ->
      if Lam_hit.hit_variable id bind
      then
        lam
      else Lam.let_ Strict id bind body
    | _ ->
      let (domain, int_mapping, node_vec)  = preprocess_deps groups in
      let clusters = Ext_scc.graph node_vec in
      if Int_vec_vec.length clusters <= 1 then lam
      else
        Int_vec_vec.fold_right (fun  (v : Int_vec.t) acc ->
            let bindings =
              Int_vec.map_into_list (fun i ->
                  let id = int_mapping.(i) in
                  let lam  = Ordered_hash_map_local_ident.find_value domain  id in
                  (id,lam)
                ) v  in
            match bindings with
            | [ id,lam ] ->
              let base_key = Ordered_hash_map_local_ident.rank domain id in
              if Int_vec_util.mem base_key node_vec.(base_key) then
                Lam.letrec bindings acc
              else  Lam.let_ Strict id lam acc
            | _ ->
              Lam.letrec bindings  acc
          )  clusters body
  end



end
module Lam_compile : sig 
#1 "lam_compile.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Compile single lambda IR to JS IR  *)

val compile_recursive_lets :
  Lam_compile_context.t ->
  (Ident.t * Lam.t) list -> 
  Js_output.t

val compile_lambda :
  Lam_compile_context.t -> 
  Lam.t ->
  Js_output.t

end = struct
#1 "lam_compile.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

module E = Js_exp_make

module S = Js_stmt_make

let method_cache_id = ref 1 (*TODO: move to js runtime for re-entrant *)


(* assume outer is [Lstaticcatch] *)
let rec flat_catches (acc : Lam_compile_context.handler list) (x : Lam.t)
  : Lam_compile_context.handler list * Lam.t =
  match x with
  | Lstaticcatch(l, (code, bindings), handler)
    when
      acc = [] ||
      (not @@ Lam_exit_code.has_exit_code handler
         (fun exit -> Ext_list.exists acc (fun { label } -> label = exit) ) )
    -> (* #1698 should not crush exit code here without checking *)
    flat_catches ( {label = code; handler; bindings} ::acc) l
  | _ -> acc, x

let flatten_nested_caches  (x : Lam.t) 
  : Lam_compile_context.handler list * Lam.t =
  flat_catches [] x

let morph_declare_to_assign (cxt : Lam_compile_context.t) k =
    match cxt.continuation with
    | Declare (kind, did) ->
        k {cxt with continuation = Assign did} (Some (kind,did))
    | _ -> k cxt None

let group_apply cases callback =     
   Ext_list.flat_map
    (
    Ext_list.stable_group cases
    (fun (_,lam) (_,lam1) -> 
      Lam.eq_approx lam lam1))
    (fun group -> Ext_list.map_last group callback ) 
(* TODO:
    for expression generation,
    name, should_return  is not needed,
    only jmp_table and env needed
*)


type default_case =
  | Default of Lam.t
  | Complete
  | NonComplete

let no_effects_const  = lazy true
let has_effects_const = lazy false

(** We drop the ability of cross-compiling
        the compiler has to be the same running
*)
(* since it's only for alias, there is no arguments,
   we should not inline function definition here, even though
   it is very small
   TODO: add comment here, we should try to add comment for
   cross module inlining

   if we do too agressive inlining here:

   if we inline {!List.length} which will call {!A_list.length},
   then we if we try inline {!A_list.length}, this means if {!A_list}
   is rebuilt, this module should also be rebuilt,

   But if the build system is content-based, suppose {!A_list}
   is changed, cmj files in {!List} is unchnaged, however,
   {!List.length} call {!A_list.length} which is changed, since
   [ocamldep] only detect that we depend on {!List}, it will not
   get re-built, then we are screwed.

   This is okay for stamp based build system.

   Another solution is that we add dependencies in the compiler

   -: we should not do functor application inlining in a
      non-toplevel, it will explode code very quickly
*)
let rec
  compile_external_field (* Like [List.empty]*)
    (lamba_cxt : Lam_compile_context.t)
    (id : Ident.t)
    (pos : int)
    (env : Env.t)
  : Js_output.t =  
  match Lam_compile_env.cached_find_ml_id_pos id pos env  with      
  | { closed_lambda = Some lam}
      when Lam_util.not_function lam
      ->
      compile_lambda lamba_cxt lam     
  | { name} ->
      Js_output.output_of_expression lamba_cxt.continuation  
      ~no_effects:no_effects_const
      (if id.name = "Sys" && name = "os_type" then E.str Sys.os_type
         else E.ml_var_dot id name )

(* TODO: how nested module call would behave,
   In the future, we should keep in track  of if
   it is fully applied from [Lapply]
   Seems that the module dependency is tricky..
   should we depend on [Pervasives] or not?

   we can not do this correctly for the return value,
   however we can inline the definition in Pervasives
   TODO:
   [Pervasives.print_endline]
   [Pervasives.prerr_endline]
   @param id external module id
   @param number the index of the external function
   @param env typing environment
   @param args arguments
*)
(** This can not happen since this id should be already consulted by type checker
          Worst case
    {[
      E.array_index_by_int m pos
    ]}
*)
(* when module is passed as an argument - unpack to an array
    for the function, generative module or functor can be a function,
    however it can not be global -- global can only module
*)

and compile_external_field_apply    
    (args_lambda : Lam.t list)
    (id : Ident.t)
    (pos : int)
    (env : Env.t) (lambda_cxt : Lam_compile_context.t): Js_output.t =

  let ident_info =  
    Lam_compile_env.cached_find_ml_id_pos id pos env in 
  let args_code, args =
      let dummy = [], [] in 
      if args_lambda = [] then dummy
      else 
        let arg_cxt = {lambda_cxt with continuation = NeedValue ReturnFalse} in 
        Ext_list.fold_right args_lambda dummy (fun arg_lambda  (args_code, args)  ->
           match compile_lambda arg_cxt arg_lambda with
           | {block; value = Some b} ->
             (Ext_list.append block args_code), (b :: args )
           | _ -> assert false
        )  in
  match ident_info.closed_lambda with
  | Some (Lfunction{ params; body; _})
      when Ext_list.same_length params args_lambda ->
      (* TODO: serialize it when exporting to save compile time *)
      let (_, param_map)  =
        Lam_closure.is_closed_with_map Ident_set.empty params body in
      compile_lambda lambda_cxt
        (Lam_beta_reduce.propogate_beta_reduce_with_map lambda_cxt.meta param_map
           params body args_lambda)
  | _ ->
      let rec aux (acc : J.expression)
          arity args (len : int)  : E.t =
          if len = 0 then         
          acc (** All arguments consumed so far *)
          else match arity with 
          |  x :: rest   ->
          let x =
            if x = 0
            then 1
            else x in (* Relax when x = 0 *)
          if  len >= x
          then
            let first_part, continue =  Ext_list.split_at args x in
            aux
              (E.call ~info:{arity=Full; call_info = Call_ml} acc first_part)
              rest
              continue (len - x)
          else (* GPR #1423 *)
          if Ext_list.for_all  args Js_analyzer.is_okay_to_duplicate then
            let params = Ext_list.init (x - len) (fun _ -> Ext_ident.create "param") in
            E.ocaml_fun params
              [S.return_stmt (E.call ~info:{arity=Full; call_info=Call_ml}
                                acc (Ext_list.append args @@ Ext_list.map params E.var))]
          else E.call ~info:Js_call_info.dummy acc args
        (* alpha conversion now? --
           Since we did an alpha conversion before so it is not here
        *)
        | [] ->
          (* can not happen, unless it's an exception ? *)
          E.call ~info:Js_call_info.dummy acc args
      in
      let fn = E.ml_var_dot id ident_info.name in 
      let initial_args_len = List.length args in 
      let expression = 
        match ident_info.arity with 
        | Submodule _ -> E.call ~info:Js_call_info.dummy fn args 
        | Single x -> 
          aux fn (Lam_arity.extract_arity x) args initial_args_len
      in   
      Js_output.output_of_block_and_expression
        lambda_cxt.continuation
        args_code expression


(**
    The second return values are values which need to be wrapped using
   [caml_update_dummy]

   Invariant:  jmp_table can not across function boundary,
       here we share env

*)
and compile_recursive_let ~all_bindings
    (cxt : Lam_compile_context.t)
    (id : Ident.t)
    (arg : Lam.t)   : Js_output.t * Ident.t list =
  match arg with
  |  Lfunction { params; body; _}  ->

    let continue_label = Lam_util.generate_label ~name:id.name () in
    (* TODO: Think about recursive value
       {[
         let rec v = ref (fun _ ...
                         )
       ]}
        [Alias] may not be exact
    *)
    let ret : Lam_compile_context.return_label =
      { id;
        label = continue_label;
        params;
        immutable_mask = Array.make (List.length params) true;
        new_params = Ident_map.empty;
        triggered = false } in
    let output =
      compile_lambda
        { cxt with
          continuation = EffectCall (ReturnTrue (Some ret ));
          jmp_table = Lam_compile_context.empty_handler_map}  body in
    let result =
      if ret.triggered then
        let body_block = Js_output.output_as_block output in
        E.ocaml_fun
          (* TODO:  save computation of length several times
             Here we always create [ocaml_fun],
             it will be renamed into [method]
             when it is detected by a primitive
          *)
          ~immutable_mask:ret.immutable_mask
          (Ext_list.map params (fun x ->
               Ident_map.find_default ret.new_params x  x )
              )
          [
            S.while_ (* ~label:continue_label *)
              E.true_
              (
                Ident_map.fold ret.new_params body_block
                  (fun old new_param  acc ->
                     S.define_variable ~kind:Alias old (E.var new_param) :: acc)
                  
              )
          ]

      else            (* TODO:  save computation of length several times *)
        E.ocaml_fun params (Js_output.output_as_block output )
    in
    Js_output.output_of_expression 
      (Declare (Alias, id))
       result ~no_effects:(lazy (Lam_analysis.no_side_effects arg)), []
  | Lprim {primitive = Pmakeblock (0, _, _) ; args =  ls}
    when Ext_list.for_all ls (fun x ->
        match x with
        | Lvar pid ->
          Ident.same pid id  ||
          (not @@ Ext_list.exists all_bindings (fun (other,_) -> Ident.same other pid ) )
        | _ -> false) 
    ->
    (* capture cases like for {!Queue}
       {[let rec cell = { content = x; next = cell} ]}
       #1716: be careful not to optimize such cases:
       {[ let rec a = { b} and b = { a} ]} they are indeed captured
       and need to be declared first
    *)
    Js_output.make (
      S.define_variable ~kind:Variable id (E.array Mutable []) ::
      (Ext_list.mapi ls (fun i x ->
           match x with
           | Lvar lid
             -> S.exp
                  (Js_arr.set_array (E.var id) (E.int (Int32.of_int i)) (E.var lid))
           | _ -> assert false))
    ), []

  | Lprim{primitive = Pmakeblock _ ; _}   ->
    (* FIXME: also should fill tag *)
    (* Lconst should not appear here if we do [scc]
       optimization, since it's faked recursive value,
       however it would affect scope issues, we have to declare it first
    *)
    (* Ext_log.err "@[recursive value %s/%d@]@." id.name id.stamp; *)
    begin
      match compile_lambda {cxt with continuation = NeedValue ReturnFalse } arg with
      | { block = b; value = Some v} ->
        (* TODO: check recursive value ..
            could be improved for simple cases
        *)
        Js_output.make
          (Ext_list.append
             b
             [S.exp
                (E.runtime_call Js_runtime_modules.obj_runtime "caml_update_dummy"
                   [ E.var id;  v])]),
        [id]
      (* S.define ~kind:Variable id (E.arr Mutable [])::  *)
      | _ -> assert false
    end
  | Lvar _   ->
    compile_lambda
      {cxt with continuation = Declare (Alias ,id) } arg, []
  | _ ->
    (* pathological case:
        fail to capture taill call?
       {[ let rec a =
            if  g > 30 then .. fun () -> a ()
       ]}

        Neither  below is not allowed in ocaml:
       {[
         let rec v =
           if sum 0 10 > 20 then
             1::v
           else 2:: v
       ]}
       {[
         let rec v =
           if sum 0 10 > 20 then
             fun _ -> print_endline "hi"; v ()
           else
             fun _-> print_endline "hey"; v ()
       ]}
    *)
    compile_lambda
      {cxt with continuation = Declare (Alias ,id)} arg, []

and compile_recursive_lets_aux cxt id_args : Js_output.t =
  (* #1716 *)
  let output_code, ids  =
    Ext_list.fold_right id_args (Js_output.dummy, [])
      (fun (ident,arg) (acc, ids) ->
         let code, declare_ids  =
           compile_recursive_let ~all_bindings:id_args cxt ident arg in
         (Js_output.append_output code  acc, Ext_list.append declare_ids  ids )
      ) 
  in
  match ids with
  | [] -> output_code
  | _ ->
    Js_output.append_output
      (Js_output.make
         (Ext_list.map ids
            (fun id -> S.define_variable ~kind:Variable id (E.dummy_obj ()))))
      output_code
and compile_recursive_lets cxt id_args : Js_output.t  =
  match id_args with
  | [ ] -> Js_output.dummy
  | _ ->
    let id_args_group = Lam_scc.scc_bindings id_args in
    match id_args_group with
    | [ ] -> assert false
    | first::rest  ->
      let acc = compile_recursive_lets_aux cxt first in
      Ext_list.fold_left rest acc 
        (fun acc x ->
           Js_output.append_output
             acc  (compile_recursive_lets_aux cxt x )) 

and compile_general_cases
 :
  'a .
  ('a -> J.expression) ->
  (J.expression -> J.expression -> J.expression) ->
  Lam_compile_context.t ->
  (?default:J.block ->
   ?declaration:Lam_compat.let_kind * Ident.t  ->
   _ -> 'a J.case_clause list ->  J.statement) ->
  _ ->
  ('a * Lam.t) list -> default_case -> J.block
  = fun
  (make_exp : _ -> J.expression)
  (eq_exp : J.expression -> J.expression -> J.expression)
  (cxt : Lam_compile_context.t)
  (switch :
  ?default:J.block ->
   ?declaration:Lam_compat.let_kind * Ident.t  ->
   _ -> _ J.case_clause list ->  J.statement
   )
   (switch_exp : J.expression)
   (cases : (_ * Lam.t) list)
   (default : default_case) ->
    match cases, default with
    | [], Default lam ->
      Js_output.output_as_block (compile_lambda cxt lam)
    | [], (Complete | NonComplete) ->  []
    | [(id,lam)],Complete ->
      (* To take advantage of such optimizations,
          when we generate code using switch,
          we should always have a default,
          otherwise the compiler engine would think that
          it's also complete
      *)
      Js_output.output_as_block (compile_lambda cxt lam)
    | [(id,lam)], NonComplete
      ->
      morph_declare_to_assign cxt (fun cxt define  ->
          [S.if_ ?declaration:define (eq_exp switch_exp (make_exp id) )
             (Js_output.output_as_block (compile_lambda cxt lam) )
          ])

    | ([(id,lam)], Default x) | ([(id,lam); (_,x)], Complete)
      ->
      morph_declare_to_assign cxt (fun cxt define ->
          let else_block = Js_output.output_as_block (compile_lambda cxt x) in
          let then_block = Js_output.output_as_block (compile_lambda cxt lam)  in
          [ S.if_ ?declaration:define (eq_exp switch_exp (make_exp id) )
              then_block
              ~else_:else_block
          ])
    | _ , _ ->
      (* TODO: this is not relevant to switch case
          however, in a subset of switch-case if we can analysis
          its branch are the same, we can propogate which
          might encourage better inlining strategey
          ---
          TODO: grouping can be delayed untile JS IR

          see #2413
          In general, we know it is last call,
          there is no need to print [break];
          But we need make sure the last call lambda does not
          have `(exit ..)` due to we pass should_return from Lstaticcath downwards
          Since this is a rough approximation, some `(exit ..)` does not destroy
          last call property, we use exiting should_break to improve preciseness
          (and it indeed help catch 
          - tailcall or not does not matter, if it is the tailcall
            break still should not be printed (it will be continuned)                               
        TOOD: disabled temporarily since it's not perfect yet *)
      morph_declare_to_assign cxt ( fun cxt declaration  ->
          let default =
            match default with
            | Complete -> None
            | NonComplete -> None
            | Default lam -> Some (Js_output.output_as_block  (compile_lambda cxt lam))
          in
          let body =            
              group_apply cases (fun last (switch_case,lam) ->
                      if last then
                        (* merge and shared *)
                        let switch_body, should_break  =
                            Js_output.to_break_block (compile_lambda cxt lam) in
                        let should_break =
                            if not @@ Lam_compile_context.continuation_is_return cxt.continuation then
                              should_break
                            else
                              should_break && Lam_exit_code.has_exit lam in
                        {J.switch_case ;
                            switch_body;
                            should_break
                        }
                      else
                        { switch_case; switch_body = []; should_break = false }
                    )                   
              
              (* TODO: we should also group default *)
              (* The last clause does not need [break]
                  common break through, *)
          in
          [switch ?default ?declaration switch_exp body]
        )

and compile_cases cxt switch_exp table default =
  compile_general_cases
    E.small_int
    E.int_equal
    cxt
    (fun  ?default ?declaration e clauses    ->
       S.int_switch ?default  ?declaration e clauses)
    switch_exp
    table
    default
and compile_switch switch_arg sw (lambda_cxt : Lam_compile_context.t) = 
  (* TODO: if default is None, we can do some optimizations
      Use switch vs if/then/else

      TODO: switch based optimiztion - hash, group, or using array,
            also if last statement is throw -- should we drop remaining
            statement?
  *)
  let ({sw_numconsts;
        sw_consts;
        sw_numblocks;
        sw_blocks;
        sw_failaction } : Lam.switch) = sw in 
  let  sw_num_default  =
    match sw_failaction with
    | None -> Complete
    | Some x ->
      if sw_numconsts
      then Complete
      else Default x in
  let sw_blocks_default =
    match sw_failaction  with
    | None -> Complete
    | Some x ->
      if sw_numblocks
      then Complete
      else Default x in
  let compile_whole  (cxt  : Lam_compile_context.t ) =
    match compile_lambda 
            {cxt with  continuation = NeedValue ReturnFalse}
            switch_arg
    with
    | {value =  None; _}  -> assert false
    | { block; value = Some e } ->
      block @
      (if sw_numconsts && sw_consts = [] then
         compile_cases cxt (E.tag e)  sw_blocks sw_blocks_default
       else if sw_numblocks && sw_blocks = [] then
         compile_cases cxt e  sw_consts sw_num_default
       else
         (* [e] will be used twice  *)
         let dispatch e =
           S.if_
             (E.is_type_number e )
             (compile_cases cxt e sw_consts sw_num_default
             )
             (* default still needed, could simplified*)
             ~else_:
               (compile_cases  cxt (E.tag e ) sw_blocks
                  sw_blocks_default) in
           match e.expression_desc with
           | J.Var _  -> [ dispatch e]
           | _ ->
             let v = Ext_ident.create_tmp () in
             (* Necessary avoid duplicated computation*)
             [ S.define_variable ~kind:Variable v e ;  dispatch (E.var v)]) in
  match lambda_cxt.continuation  with  (* Needs declare first *)
  | NeedValue _ ->
    (* Necessary since switch is a statement, we need they return
       the same value for different branches -- can be optmized
       when branches are minimial (less than 2)
    *)
    let v = Ext_ident.create_tmp () in
    Js_output.make
      (S.declare_variable ~kind:Variable v   ::
       compile_whole {lambda_cxt with continuation = Assign v})
      ~value:(E.var  v)

  | Declare (kind,id) ->
    Js_output.make (S.declare_variable ~kind id
                    :: compile_whole {lambda_cxt with continuation = Assign id} )
  | EffectCall _ | Assign _  -> Js_output.make (compile_whole lambda_cxt)

and compile_string_cases cxt switch_exp table default =
  compile_general_cases
    E.str
    E.string_equal
    cxt
    (fun  ?default ?declaration e clauses    ->
       S.string_switch ?default  ?declaration e clauses)
    switch_exp
    table
    default
(* TODO: optional arguments are not good
    for high order currying *)    

and compile_stringswitch l cases default (lambda_cxt : Lam_compile_context.t) = 
  (* TODO might better optimization according to the number of cases
      Be careful: we should avoid multiple evaluation of l,
      The [gen] can be elimiated when number of [cases] is less than 3
  *)
  match 
    compile_lambda 
      {lambda_cxt with continuation = NeedValue ReturnFalse } l
  with
  | {value = None } -> assert false
  | {block ; value =  Some e}  ->
    (* when should_return is true -- it's passed down
       otherwise it's ok *)
    let default =
      match default with
      | Some x -> Default x
      | None -> Complete in
    match lambda_cxt.continuation with
    (* TODO: can be avoided when cases are less than 3 *)
    | NeedValue _ ->
      let v = Ext_ident.create_tmp () in
      Js_output.make 
        (Ext_list.append block (
            compile_string_cases
              {lambda_cxt with continuation = Declare (Variable, v)}
              e cases default)) ~value:(E.var v)
    | _ ->
      Js_output.make
        (Ext_list.append block 
           (compile_string_cases  lambda_cxt e cases default))
   (*
         This should be optimized in lambda layer
         (let (match/1038 = (apply g/1027 x/1028))
         (catch
         (stringswitch match/1038
         case "aabb": 0
         case "bbc": 1
         default: (exit 1))
         with (1) 2))
      *)
and compile_staticraise i (largs : Lam.t list) lambda_cxt  =    
 (* [i] is the jump table, [largs] is the arguments passed to [Lstaticcatch]*)
    match Lam_compile_context.find_exn i lambda_cxt  with
    | {exit_id; bindings ; order_id} ->
          Ext_list.fold_right2 largs bindings
           (Js_output.make [S.assign exit_id (E.small_int  order_id)]
              ~value:E.undefined)
           (fun larg bind acc ->
            let new_output =
                match larg with
                | Lvar id ->
                    Js_output.make [S.assign bind (E.var id)]

                | _ -> (* TODO: should be Assign -- Assign is an optimization *)
                  compile_lambda 
                    {lambda_cxt with continuation = Assign bind } larg
            in Js_output.append_output new_output acc
           )

    (* Invariant: exit_code can not be reused
        (catch l with (32)
        (handler))
        32 should not be used in another catch
        Invariant:
        This is true in current ocaml compiler
        currently exit only appears in should_return position relative to staticcatch
        if not we should use ``javascript break`` or ``continue``
       if exit_code_id == code
         handler -- ids are not useful, since
         when compiling `largs` we will do the binding there
         - when exit_code is undefined internally,
           it should PRESERVE  ``tail`` property
         - if it uses `staticraise` only once
           or handler is minimal, we can inline
         - always inline also seems to be ok, but it might bloat the code
         - another common scenario is that we have nested catch
           (catch (catch (catch ..))
        checkout example {!Digest.file}, you can not inline handler there,
        we can spot such patten and use finally there?
         {[
           let file filename =
             let ic = open_in_bin filename in
             match channel ic (-1) with
             | d -> close_in ic; d
             | exception e -> close_in ic; raise e

         ]}
      *)
and compile_staticcatch (cur_lam : Lam.t) (lambda_cxt  : Lam_compile_context.t)=  
    let code_table, body = flatten_nested_caches cur_lam in
    let exit_id = Ext_ident.create_tmp ~name:"exit" () in
    let exit_expr = E.var exit_id in
    let jmp_table, handlers =
      Lam_compile_context.add_jmps lambda_cxt.jmp_table exit_id code_table  in

    (* Declaration First, body and handler have the same value *)
    let declares =
      S.define_variable ~kind:Variable exit_id
        E.zero_int_literal ::
      (* we should always make it zero here, since [zero] is reserved in our mapping*)
      Ext_list.flat_map code_table 
        (fun {bindings} -> Ext_list.map bindings 
            (fun x -> S.declare_variable ~kind:Variable x))  in
    match  lambda_cxt.continuation with
    (* could be optimized when cases are less than 3 *)
    | NeedValue _ ->
      let v = Ext_ident.create_tmp  () in
      let new_cxt = {lambda_cxt with jmp_table = jmp_table; continuation = Assign v } in 
      let lbody = compile_lambda new_cxt body in
      Js_output.append_output
        (Js_output.make  (S.declare_variable ~kind:Variable v  :: declares) )
        (Js_output.append_output lbody (Js_output.make (
             compile_cases new_cxt exit_expr handlers  NonComplete)  ~value:(E.var v )))
    | Declare (kind, id)
      (* declare first this we will do branching*) ->
      let declares = S.declare_variable ~kind id  :: declares in
      let new_cxt = {lambda_cxt with jmp_table = jmp_table; continuation = Assign id } in 
      let lbody = compile_lambda new_cxt body in
      Js_output.append_output (Js_output.make  declares)
        (Js_output.append_output lbody
           (Js_output.make (compile_cases new_cxt exit_expr handlers NonComplete)))
                              (* place holder -- tell the compiler that
                                 we don't know if it's complete
                              *)                           
    | EffectCall _ | Assign _  ->
      let new_cxt = {lambda_cxt with jmp_table = jmp_table } in 
      let lbody = compile_lambda new_cxt body in
      Js_output.append_output (Js_output.make declares)
        (Js_output.append_output lbody
           (Js_output.make (compile_cases new_cxt exit_expr handlers NonComplete)))

and compile_sequand 
      (l : Lam.t) (r : Lam.t) (lambda_cxt : Lam_compile_context.t) =     
    if Lam_compile_context.continuation_is_return lambda_cxt.continuation then
      compile_lambda lambda_cxt (Lam.sequand  l r )
    else
      let new_cxt = {lambda_cxt with continuation = NeedValue ReturnFalse} in
      match compile_lambda new_cxt l with
      | { value = None } -> assert false
      | {block = l_block; value = Some l_expr} ->
        match compile_lambda new_cxt r with
        | { value = None } -> assert false
        | {block = []; value = Some r_expr}
          ->
          Js_output.output_of_block_and_expression
            lambda_cxt.continuation 
            l_block (E.and_ l_expr r_expr)
        | { block = r_block; value = Some r_expr} ->
          match lambda_cxt.continuation with
          | Assign v ->
            (* Refernece Js_output.output_of_block_and_expression *)
            Js_output.make
              (
                l_block @
                [S.if_ l_expr (r_block @ [ S.assign v r_expr])
                   ~else_:[S.assign v E.false_]
                ]
              )
          | Declare (_kind,v) ->
            (* Refernece Js_output.output_of_block_and_expression *)
            Js_output.make
              (
                l_block @
                [ S.define_variable ~kind:Variable v E.false_ ;
                  S.if_ l_expr
                    (r_block @ [S.assign v r_expr])])
          | EffectCall _
          | NeedValue _ ->
            let v = Ext_ident.create_tmp () in
            Js_output.make
              (S.define_variable ~kind:Variable v E.false_ ::
               l_block @
               [S.if_ l_expr
                  (r_block @ [
                      S.assign v r_expr
                    ])])
              ~value:(E.var v)

and compile_sequor 
    (l : Lam.t)      
    (r : Lam.t)
    (lambda_cxt : Lam_compile_context.t) = 
    if Lam_compile_context.continuation_is_return lambda_cxt.continuation then  
      compile_lambda lambda_cxt (Lam.sequor l r)
    else
      let new_cxt = {lambda_cxt with continuation = NeedValue ReturnFalse} in
      match compile_lambda new_cxt l with
      | {value = None } -> assert false
      | {block = l_block; value = Some l_expr} ->
        match compile_lambda new_cxt r with
        | {value = None} -> assert false
        | {block = []; value = Some r_expr} ->
          let exp =  E.or_ l_expr r_expr  in
          Js_output.output_of_block_and_expression
            lambda_cxt.continuation l_block exp
        | {block = r_block; value = Some r_expr} ->
          begin match lambda_cxt.continuation with
            | Assign v ->
              (* Reference Js_output.output_of_block_and_expression *)
              Js_output.make
                (l_block @
                 [ S.if_ (E.not l_expr)
                     (r_block @ [
                         S.assign v r_expr
                       ])
                     ~else_:[S.assign v E.true_] ])
            | Declare(_kind,v) ->
              Js_output.make
                (
                  l_block @
                  [ S.define_variable ~kind:Variable v E.true_;
                    S.if_ (E.not l_expr)
                      (r_block @ [S.assign v r_expr])
                  ]
                )
            | EffectCall _
            | NeedValue _ ->
              let v = Ext_ident.create_tmp () in
              Js_output.make
                ( l_block @
                  [S.define_variable ~kind:Variable v E.true_;
                   S.if_ (E.not l_expr)
                     (r_block @ [
                         S.assign v r_expr
                       ])
                  ]
                )
                ~value:(E.var v)
          end
(* Note that ``J.While(expression * statement )``
            idealy if ocaml expression does not need fresh variables, we can generate
            while expression, here we generate for statement, leave optimization later.
            (Sine OCaml expression can be really complex..)
*)
and compile_while (predicate : Lam.t) (body : Lam.t) (lambda_cxt : Lam_compile_context.t) =              
    match compile_lambda {lambda_cxt with continuation = NeedValue ReturnFalse } predicate
    with
    | { value = None} -> assert false
    | { block; value =  Some e} ->
      (* st = NeedValue -- this should be optimized and never happen *)
      let e =
        match block with
        | [] -> e
        | _ -> E.of_block block ~e  in
      let block =
        [
          S.while_
            e
            (Js_output.output_as_block @@
             compile_lambda
               {lambda_cxt with continuation = EffectCall ReturnFalse}
               body)
        ] in
      Js_output.output_of_block_and_expression lambda_cxt.continuation block E.unit

(** all non-tail 
   TODO: check semantics should start, finish be executed each time in both
     ocaml and js?, also check evaluation order..
     in ocaml id is not in the scope of finish, so it should be safe here

     for i  = 0 to (print_int 3; 10) do print_int i done;;
     3012345678910- : unit = ()

   for(var i =  0 ; i < (console.log(i),10); ++i){console.log('hi')}
   print i each time, so they are different semantics...
*)

and compile_for 
    id start finish direction body (lambda_cxt : Lam_compile_context.t) = 
    let new_cxt = {lambda_cxt with continuation = NeedValue ReturnFalse} in 
    let block =
      match compile_lambda new_cxt start,
            compile_lambda new_cxt finish with
      | {value = None}, _ | _, {value = None} -> assert false    
      | {block = b1; value =  Some e1}, {block = b2; value =  Some e2} ->

        (* order b1 -- (e1 -- b2 -- e2)
            in most cases we can shift it into such scenarios
            b1, b2, [e1, e2]
            - b2 is Empty
            - e1 is pure
            we can guarantee e1 is pure, if it literally contains a side effect call,
            put it in the beginning


        *)
        let block_body = 
          Js_output.output_as_block 
            (compile_lambda {lambda_cxt with  continuation = EffectCall ReturnFalse}
               body) in 
        match b1,b2 with
        | _,[] ->
          Ext_list.append_one b1 (S.for_ (Some e1) e2  id direction block_body)
        | _, _ when Js_analyzer.no_side_effect_expression e1
                (*
                     e1 > b2 > e2
                     re-order
                     b2 > e1 > e2
                   *)
          ->
          Ext_list.append b1
            (Ext_list.append_one b2  (S.for_ (Some e1) e2  id direction block_body))
        | _ , _
          ->
          Ext_list.append b1 
            (S.define_variable ~kind:Variable id e1 :: 
             (Ext_list.append_one b2  (S.for_ None e2 id direction block_body))) in 
    Js_output.output_of_block_and_expression 
      lambda_cxt.continuation block         
      E.unit

and compile_assign id (lambda : Lam.t) (lambda_cxt : Lam_compile_context.t) = 
    let block =
      match lambda with
      | Lprim {primitive = Poffsetint  v; args =  [Lvar bid]}
        when Ident.same id bid ->
        [ S.exp (E.assign (E.var id)
                   (E.int32_add (E.var id) (E.small_int  v)))
        ]
      | _ ->        
        match compile_lambda 
                {lambda_cxt with continuation = NeedValue ReturnFalse} 
                lambda 
        with
        | {value = None} -> assert false
        | {block ; value =  Some v}  ->
          (Ext_list.append_one block  (S.assign id v)) in
    Js_output.output_of_block_and_expression lambda_cxt.continuation block E.unit  
(*
         tail --> should be renamed to `shouldReturn`
          in most cases ``shouldReturn`` == ``tail``, however, here is not,
          should return, but it is not a tail call in js
          (* could be optimized using javascript style exceptions *)
   {[
     {try
        {var $js=g(x);}
          catch(exn){if(exn=Not_found){var $js=0;}else{throw exn;}}
     return h($js);
   }
   ]}
*)    
and compile_trywith lam id catch (lambda_cxt : Lam_compile_context.t) =          
    let aux 
        (with_context : Lam_compile_context.t) 
        (body_context : Lam_compile_context.t) =
      (* should_return is passed down 
         #1701, try should prevent tailcall *)
      [ S.try_ (Js_output.output_as_block (compile_lambda body_context lam))
          ~with_:(id,
                  Js_output.output_as_block (compile_lambda with_context catch ))

      ] in
    match lambda_cxt.continuation with
    | Declare (kind,  id) ->
      let context = { lambda_cxt with continuation = Assign id} in  
      Js_output.make (S.declare_variable ~kind
                        id :: aux context context )
    | Assign _  -> 
      Js_output.make (aux lambda_cxt lambda_cxt)
    | NeedValue _ ->
      let v = Ext_ident.create_tmp () in
      let context = {lambda_cxt with continuation = Assign v} in 
      Js_output.make (S.declare_variable ~kind:Variable v :: 
                      aux context context)  ~value:(E.var v )
    | EffectCall (ReturnTrue (Some _)) -> 
      Js_output.make (aux lambda_cxt {lambda_cxt with continuation = EffectCall (ReturnTrue None)} )
    | EffectCall _ -> 
      Js_output.make (aux lambda_cxt lambda_cxt)

(* Note that in [Texp_apply] for [%sendcache] the cache might not be used
   see {!CamlinternalOO.send_meth} and {!Translcore.transl_exp0} the branch
   [Texp_apply] when [public_send ], args are simply dropped

   reference
   [js_of_ocaml]
   1. GETPUBMET
   2. GETDYNMET
   3. GETMETHOD
   [ocaml]
   Lsend (bytegen.ml)
   For the object layout refer to [camlinternalOO/create_object]
   {[
     let create_object table =
       (* XXX Appel de [obj_block] *)
       let obj = mark_ocaml_object @@ Obj.new_block Obj.object_tag table.size in
       (* XXX Appel de [caml_modify] *)
       Obj.set_field obj 0 (Obj.repr table.methods);
       Obj.obj (set_id obj)

     let create_object_opt obj_0 table =
       if (Obj.magic obj_0 : bool) then obj_0 else begin
         (* XXX Appel de [obj_block] *)
         let obj = mark_ocaml_object @@ Obj.new_block Obj.object_tag table.size in
         (* XXX Appel de [caml_modify] *)
         Obj.set_field obj 0 (Obj.repr table.methods);
         Obj.obj (set_id obj)
       end
   ]}
   it's a block with tag [248], the first field is [table.methods] which is an array
   {[
     type table =
       { mutable size: int;
         mutable methods: closure array;
         mutable methods_by_name: meths;
         mutable methods_by_label: labs;
         mutable previous_states:
           (meths * labs * (label * item) list * vars *
            label list * string list) list;
         mutable hidden_meths: (label * item) list;
         mutable vars: vars;
         mutable initializers: (obj -> unit) list }
   ]}
*)
and compile_send  (meth_kind : Lam_compat.meth_kind)
    (met : Lam.t) 
    (obj : Lam.t) (args : Lam.t list) loc 
    (lambda_cxt : Lam_compile_context.t) =       
    let new_cxt = {lambda_cxt with continuation = NeedValue ReturnFalse} in 
    match Ext_list.split_map (met :: obj :: args) (fun x  ->
          match x with
          | Lprim {primitive = Pccall {prim_name ; _}; args =  []}
            (* nullary external call*)
            ->
            [], E.var (Ext_ident.create_js prim_name)
          | _ ->
              match compile_lambda new_cxt x with
              | {value = None} -> assert false        
              | {block; value = Some b} -> block, b
        ) with
    | _, ([] | [_]) -> assert false
    | (args_code, label::nobj::args)
      ->
      let cont3 nobj k =
        match Js_ast_util.named_expression nobj with
        | None ->
          let cont =
            Js_output.output_of_block_and_expression
              lambda_cxt.continuation (List.concat args_code)
          in
          cont (k nobj)
        | Some (obj_code, v) ->
          let cont2 obj_code v =
            Js_output.output_of_block_and_expression
              lambda_cxt.continuation 
              ( Ext_list.concat_append args_code  [obj_code]) v in
          let cobj = E.var v in
          cont2 obj_code (k cobj) in
      match meth_kind with
      | Self ->
        (* TODO: horrible hack -- fixed later *)
        cont3 nobj (fun aobj -> E.call ~info:Js_call_info.dummy
                       (Js_of_lam_array.ref_array
                          (Js_of_lam_record.field Fld_na aobj 0l) label )
                       (aobj :: args))
      (* [E.small_int 1] is because we use array,
          when we change the runtime represenation, it needs to be adapted
      *)

      | Cached | Public None
        (* TODO: check -- 1. js object propagate 2. js object create  *)
        ->
        let get = E.runtime_ref  Js_runtime_modules.oo "caml_get_public_method" in
        let cache = !method_cache_id in
        let () = incr method_cache_id  in
        cont3 nobj (fun obj' ->
            E.call ~info:Js_call_info.dummy
              (E.call ~info:Js_call_info.dummy get
                 [obj'; label; E.small_int cache]) (obj'::args)
          ) (* avoid duplicated compuattion *)


      | Public (Some name) ->
        let cache = !method_cache_id in
        incr method_cache_id ;
        cont3 nobj
          (fun aobj -> E.public_method_call name aobj label
              (Int32.of_int cache) args )


and compile_ifthenelse 
      (predicate : Lam.t)
      (t_branch : Lam.t)
      (f_branch : Lam.t)
      (lambda_cxt : Lam_compile_context.t) = 
    match compile_lambda {lambda_cxt with continuation = NeedValue ReturnFalse } predicate with
    | {value = None } -> assert false    
    | {block = b; value =  Some e} ->
      match lambda_cxt.continuation with
      | NeedValue _ ->
        (match
           compile_lambda lambda_cxt  t_branch,
           compile_lambda lambda_cxt  f_branch with
        | {block = []; value =  Some out1},
          {block = []; value =  Some out2} -> (* speical optimization *)
          Js_output.make b ~value:(E.econd e out1 out2)
        | _, _ ->
          (* we can not reuse -- here we need they have the same name,
                 TODO: could be optimized by inspecting assigment statement *)
          let id = Ext_ident.create_tmp () in
          let assign_cxt = {lambda_cxt with continuation = Assign id} in 
          match compile_lambda assign_cxt  t_branch, compile_lambda assign_cxt f_branch
          with
          | out1 , out2 ->
            Js_output.make
              (Ext_list.append
                 (S.declare_variable ~kind:Variable id :: b)  [
                 S.if_ e
                   (Js_output.output_as_block out1)
                   ~else_:(Js_output.output_as_block out2 )
               ])
              ~value:(E.var id)
        )
      | Declare (kind,id) ->
        let declare_cxt = {lambda_cxt with continuation = NeedValue ReturnFalse} in 
        (match 
           compile_lambda declare_cxt t_branch,
           compile_lambda declare_cxt f_branch with
        | {block = []; value =  Some out1},
          {block = []; value =  Some out2} ->
          (* Invariant: should_return is false*)
          Js_output.make (Ext_list.append_one b (S.define_variable ~kind id (E.econd e out1 out2)))
        | _, _ ->
          Js_output.make
            ( Ext_list.append_one b (
                  S.if_ ~declaration:(kind,id) e
                    (Js_output.output_as_block @@
                     compile_lambda {lambda_cxt with continuation = Assign id}  t_branch)
                    ~else_:(Js_output.output_as_block @@
                            (compile_lambda {lambda_cxt with continuation = Assign id} f_branch)))))
      | Assign id ->
        let then_output =
          Js_output.output_as_block (compile_lambda lambda_cxt  t_branch) in
        let else_output =
          Js_output.output_as_block (compile_lambda lambda_cxt f_branch) in
        Js_output.make (Ext_list.append_one b  (
            S.if_ e
              then_output
              ~else_:else_output))
      | EffectCall should_return ->
        let context1 = {lambda_cxt with continuation = NeedValue should_return} in 
        (match should_return,
               compile_lambda context1  t_branch,
               compile_lambda context1  f_branch with

        (* see PR#83 *)
        |  ReturnFalse , {block = []; value =  Some out1},
           {block = []; value =  Some out2} ->            
          (match Js_exp_make.remove_pure_sub_exp out1 ,
                 Js_exp_make.remove_pure_sub_exp out2 with
          | None, None -> Js_output.make (Ext_list.append_one b  (S.exp e))
          (* FIX #1762 *)
          | Some out1, Some out2 ->
            Js_output.make b  ~value:(E.econd e  out1 out2)
          | Some out1, None ->
            Js_output.make (Ext_list.append_one b  (S.if_ e  [S.exp out1]))
          | None, Some out2 ->
            Js_output.make (Ext_list.append_one b  (S.if_ (E.not e) [S.exp out2])))
        |  ReturnFalse , {block = []; value = Some out1}, _ ->
          (* assert branch
              TODO: here we re-compile two branches since
              its context is different -- could be improved
          *)
          if Js_analyzer.no_side_effect_expression out1 then
            Js_output.make
              (Ext_list.append b [ S.if_ (E.not e)
                                     (Js_output.output_as_block @@
                                      (compile_lambda lambda_cxt f_branch))])
          else
            Js_output.make
              (Ext_list.append b [S.if_ e
                                    (Js_output.output_as_block
                                     @@ compile_lambda lambda_cxt t_branch)
                                    ~else_:(Js_output.output_as_block @@
                                            (compile_lambda lambda_cxt f_branch))]
              )

        | ReturnFalse , _, {block = []; value = Some out2} ->
          let else_ =
            if  Js_analyzer.no_side_effect_expression out2 then
              None
            else
              Some (
                Js_output.output_as_block (compile_lambda lambda_cxt f_branch)) in
          Js_output.make
            (Ext_list.append_one b 
               (S.if_ e
                  (Js_output.output_as_block (
                      compile_lambda lambda_cxt t_branch))
                  ?else_))
        | ReturnTrue _, {block = []; value =  Some out1},
          {block = []; value =  Some out2} ->
          Js_output.make
            (Ext_list.append_one b  (S.return_stmt  (E.econd e  out1 out2)))
            ~output_finished:True
        |   _, _, _  ->
          let then_output =
            Js_output.output_as_block (compile_lambda lambda_cxt  t_branch) in
          let else_output =
            Js_output.output_as_block (compile_lambda lambda_cxt f_branch) in
          Js_output.make (Ext_list.append_one b  (
              S.if_ e
                then_output
                ~else_:else_output)))
and compile_apply 
  (appinfo : Lam.apply_info) 
  (lambda_cxt : Lam_compile_context.t) = 
    match appinfo with 
    | {
      fn = Lapply{ fn; args =  fn_args; status = App_na ; };
      args;
      status = App_na; loc }
      ->
      (* After inlining we can generate such code,
         see {!Ari_regress_test}
      *)
      compile_lambda  lambda_cxt (Lam.apply fn (Ext_list.append fn_args  args)  loc  App_na )
    (* External function calll *)
    | { fn =
          Lprim{primitive = Pfield (n,_);
                args = [  Lglobal_module id];_};
        args ;
        status = App_na | App_ml_full} ->
      (* Note we skip [App_js_full] since [get_exp_with_args] dont carry
         this information, we should fix [get_exp_with_args]
      *)
      compile_external_field_apply  args id n  lambda_cxt.meta.env  lambda_cxt


    | { fn; args = args_lambda;   status} ->
      (* TODO: ---
         1. check arity, can be simplified for pure expression
         2. no need create names
      *)
      let new_cxt = {lambda_cxt with continuation = NeedValue ReturnFalse} in 
      let [@warning "-8" (* non-exhaustive pattern*)] (args_code, fn_code:: args) =
        Ext_list.fold_right (fn::args_lambda) ([],[]) (fun x  (args_code, fn_code )->
            match compile_lambda new_cxt x with
            | {block ; value =  Some b} -> Ext_list.append block  args_code , b:: fn_code
            | {value = None} -> assert false
          )  in
      match fn, lambda_cxt.continuation with
      | (Lvar fn_id,
         (EffectCall (ReturnTrue (Some ret)) | NeedValue (ReturnTrue (Some   ret))))
        when Ident.same ret.id fn_id ->
        ret.triggered <- true;
        (* Here we mark [finished] true, since the continuation
            does not make sense any more (due to that we have [continue])
            TODO: [finished] is not a meaningful name, we should use [truncate]
            to mean the following statement should be truncated
        *)
            (*
                actually, there is no easy way to determin
                if the argument depends on an expresion, since
                it can be a function, then it may depend on anything
                http://caml.inria.fr/pub/ml-archives/caml-list/2005/02/5727b4ecaaef6a7a350c9d98f5f68432.en.html
                http://caml.inria.fr/pub/ml-archives/caml-list/2005/02/fe9bc4e23e6dc8c932c8ab34240ff195.en.html

            *)
        (* TODO: use [fold]*)
        let (_,assigned_params,new_params) =
          Ext_list.fold_left2 ret.params args  (0, [], Ident_map.empty) (fun param arg (i,assigns,new_params) ->
              match arg with
              | {expression_desc = Var (Id x); _} when Ident.same x param ->
                (i + 1, assigns, new_params)
              | _ ->
                let new_param, m  =
                  match Ident_map.find_opt ret.new_params param  with
                  | None ->
                    ret.immutable_mask.(i)<- false;
                    let v = Ext_ident.create ("_"^param.Ident.name) in
                    v, (Ident_map.add new_params param v)
                  | Some v -> v, new_params  in
                (i+1, (new_param, arg) :: assigns, m)
            ) in
        ret.new_params <- Ident_map.disjoint_merge new_params ret.new_params;
        let block = Ext_list.map_append assigned_params [S.continue_ ] (fun (param, arg) -> S.assign param arg) in 
        (* Note true and continue needed to be handled together*)
        Js_output.make  ~output_finished:True (Ext_list.append args_code block)
      | _ ->
        Js_output.output_of_block_and_expression lambda_cxt.continuation args_code
          (E.call ~info:(match fn, status with
               | _,  App_ml_full ->
                 {arity = Full ; call_info = Call_ml}
               | _,  App_js_full ->
                 {arity = Full ; call_info = Call_na}
               | _,   App_na ->
                 {arity = NA; call_info = Call_ml }
             ) fn_code args)
and compile_prim (prim_info : Lam.prim_info) (lambda_cxt : Lam_compile_context.t) =     
    match prim_info with 
    | {primitive = Pfield (n,_); args = [ Lglobal_module id ]; _}
      -> (* should be before Lglobal_global *)
      compile_external_field lambda_cxt id n lambda_cxt.meta.env
    | {primitive = Praise ; args =  [ e ]; _} ->      
      (match compile_lambda {lambda_cxt with  continuation = NeedValue ReturnFalse} e with
       | {block ; value =  Some v} ->
         Js_output.make
           (Ext_list.append_one block  (S.throw_stmt v))
           ~value:E.undefined ~output_finished:True
       (* FIXME -- breaks invariant when NeedValue, reason is that js [throw] is statement
          while ocaml it's an expression, we should remove such things in lambda optimizations
       *)
       | {value =  None} -> assert false)

    | {primitive = Psequand ; args =  [l;r] ; _} ->
      compile_sequand l r lambda_cxt
    |  {primitive = Psequor; args =  [l;r]} ->
      compile_sequor l r lambda_cxt 
    |  {primitive = Pdebugger ; _} ->
      (* [%bs.debugger] guarantees that the expression does not matter
         TODO: make it even safer      *)
      Js_output.output_of_block_and_expression lambda_cxt.continuation
        S.debugger_block E.unit
    (* TODO:
       check the arity of fn before wrapping it
       we need mark something that such eta-conversion can not be simplified in some cases
    *)

    |  {primitive = Pjs_unsafe_downgrade (name,loc); args = [obj]}
      when not (Ext_string.ends_with name Literals.setter_suffix)
      ->
      (**
         either a getter {[ x #. height ]} or {[ x ## method_call ]}
      *)
      let property =  Lam_methname.translate ~loc name  in      
      (match compile_lambda {lambda_cxt with continuation = NeedValue ReturnFalse} obj
       with
       | {value = None} -> assert false
       | {block; value = Some b } ->
         let blocks, ret  =
           if block = [] then [],  E.dot b property
           else
             match Js_ast_util.named_expression b  with
             | None -> block,  E.dot b property
             | Some (x, b) ->
               Ext_list.append_one block  x,  E.dot (E.var b) property in
         Js_output.output_of_block_and_expression lambda_cxt.continuation blocks ret)
    | {primitive = Pjs_fn_run arity;  args = args_lambda}
      ->
      (* 1. prevent eta-conversion
         by using [App_js_full]
         2. invariant: `external` declaration will guarantee
         the function application is saturated
         3. we need a location for Pccall in the call site
      *)

      (match args_lambda with
       | [Lprim{
           primitive =
             Pjs_unsafe_downgrade(method_name,loc);
           args = [obj]} as fn;
          arg]
         ->
         let need_value_no_return_cxt = {lambda_cxt with continuation = NeedValue ReturnFalse} in
         let obj_output = compile_lambda  need_value_no_return_cxt obj in
         let arg_output = compile_lambda need_value_no_return_cxt arg in
         let cont obj_block arg_block obj_code =
           Js_output.output_of_block_and_expression lambda_cxt.continuation  
             (
               match obj_code with
               | None -> Ext_list.append obj_block  arg_block
               | Some obj_code -> Ext_list.append obj_block (obj_code :: arg_block)
             )
         in
         (match obj_output, arg_output with
          | {value = None}, _ | _, {value = None} -> assert false
          | {block = obj_block; value = Some obj },
            {block = arg_block; value = Some value}
            ->
            if  Ext_string.ends_with method_name Literals.setter_suffix then
              let property =
                Lam_methname.translate ~loc
                  (String.sub method_name 0
                     (String.length method_name - Literals.setter_suffix_len)) in
              match Js_ast_util.named_expression  obj with
              | None ->
                cont obj_block arg_block None
                  (E.seq (E.assign (E.dot obj property) value) E.unit)
              | Some (obj_code, obj)
                ->
                cont obj_block arg_block (Some obj_code)
                  (E.seq (E.assign (E.dot (E.var obj) property) value) E.unit)
            else
              compile_lambda lambda_cxt
                (Lam.apply fn [arg]
                   Location.none (* TODO *) App_js_full))
       | fn :: rest ->
         compile_lambda lambda_cxt
           (Lam.apply fn rest
              Location.none (*TODO*)
              App_js_full)
       | [] -> assert false)
      
    | {primitive = Pjs_fn_runmethod arity ; args }
      ->
      (match args with
       | (Lprim{primitive = Pjs_unsafe_downgrade (name,loc);
                args = [ _ ]} as fn)
         :: _obj
         :: rest ->
         (* assert (Ident.same id2 id) ;  *)
         (* we ignore the computation of [_obj],
            since our ast writer
            {[ obj#.f (x,y)
            ]}
            -->
            {[ runmethod2 f obj#.f x y]}
         *)
         compile_lambda lambda_cxt (Lam.apply fn rest loc App_js_full)
       | _ -> assert false)

    | {primitive = Pjs_fn_method arity;  args = args_lambda} ->
      (match args_lambda with
       | [Lfunction{arity = len; params; body} ]
         when len = arity ->
         Js_output.output_of_block_and_expression
           lambda_cxt.continuation
           []
           (E.method_
              params
              (* Invariant:  jmp_table can not across function boundary,
                 here we share env
              *)
              (Js_output.output_as_block
                 ( compile_lambda
                     { lambda_cxt with continuation = EffectCall ( ReturnTrue None);                                 
                                       jmp_table = Lam_compile_context.empty_handler_map}
                     body)))
       | _ -> assert false)      
    |  {primitive = Pjs_fn_make arity;  args = [fn]; loc } ->
      compile_lambda lambda_cxt (Lam_eta_conversion.unsafe_adjust_to_arity loc ~to_:arity ?from:None fn)

    |  {primitive = Pjs_fn_make arity; args = [] | _::_::_ } ->
      assert false

    | { primitive = Pjs_object_create labels ; args ; loc}
      ->
      let args_block, args_expr =
        if args = [] then [], []
        else 
          let new_cxt = {lambda_cxt with continuation = NeedValue ReturnFalse} in 
          Ext_list.split_map args (fun x ->
              match compile_lambda new_cxt  x with
              | {block ; value = Some b} -> block,b
              | {value = None} -> assert false ) in
      let block, exp  =
        Lam_compile_external_obj.assemble_obj_args labels args_expr in
      Js_output.output_of_block_and_expression lambda_cxt.continuation
        (Ext_list.concat_append args_block block) exp

    | {primitive; args; loc} ->
      let args_block, args_expr =
        if args = [] then [], []
        else let new_cxt = {lambda_cxt with continuation = NeedValue ReturnFalse} in 
        Ext_list.split_map args (fun x ->
            match compile_lambda new_cxt x with
            | {block ; value = Some b} -> block,b
            | {value = None} -> assert false ) in
      let args_code  : J.block = List.concat args_block in
      let exp  =  (* TODO: all can be done in [compile_primitive] *)
        Lam_compile_primitive.translate loc lambda_cxt  primitive args_expr in
      Js_output.output_of_block_and_expression lambda_cxt.continuation  args_code exp

and compile_lambda
    (lambda_cxt : Lam_compile_context.t)
    (cur_lam : Lam.t)  : Js_output.t  =

    match cur_lam with
    | Lfunction{ params; body} ->
      Js_output.output_of_expression lambda_cxt.continuation  ~no_effects:no_effects_const
        (E.ocaml_fun
           params
           (* Invariant:  jmp_table can not across function boundary,
              here we share env
           *)
           (Js_output.output_as_block
              ( compile_lambda
                  { lambda_cxt with 
                    continuation = EffectCall (ReturnTrue None); (* Refine*)
                    jmp_table = Lam_compile_context.empty_handler_map}
                  body)))
    | Lapply appinfo -> 
      compile_apply appinfo lambda_cxt
    | Llet (let_kind,id,arg, body) ->
      (* Order matters..  see comment below in [Lletrec] *)
      let args_code =   
        compile_lambda {lambda_cxt with continuation = Declare(let_kind,id)} arg in 
      Js_output.append_output
      args_code (compile_lambda  lambda_cxt  body)

    | Lletrec (id_args, body) ->
      (* There is a bug in our current design,
         it requires compile args first (register that some objects are jsidentifiers)
         and compile body wiht such effect.
         So here we should compile [id_args] first, then [body] later.
         Note it has some side effect over cache number as well, mostly the value of
         [Caml_primitive["caml_get_public_method"](x,hash_tab, number)]

         To fix this,
         1. scan the lambda layer first, register js identifier before proceeding
         2. delay the method call into javascript ast
      *)
      let v =  compile_recursive_lets lambda_cxt  id_args in
      Js_output.append_output v  (compile_lambda lambda_cxt  body)

    | Lvar id -> 
      Js_output.output_of_expression lambda_cxt.continuation ~no_effects:no_effects_const (E.var id )
    | Lconst c ->
      Js_output.output_of_expression lambda_cxt.continuation ~no_effects:no_effects_const (Lam_compile_const.translate c)
    | Lglobal_module i ->
      (* introduced by
         1. {[ include Array --> let include  = Array  ]}
         2. inline functor application
      *)
      let exp = Lam_compile_global.expand_global_module i lambda_cxt.meta.env  in
      Js_output.output_of_block_and_expression lambda_cxt.continuation [] exp

    | Lprim prim_info -> 
        compile_prim prim_info lambda_cxt
    | Lsequence (l1,l2) ->
      let output_l1 =
        compile_lambda {lambda_cxt with continuation = EffectCall ReturnFalse} l1 in
      let output_l2 =
        compile_lambda lambda_cxt l2  in
      Js_output.append_output output_l1  output_l2
    | Lifthenelse(predicate,t_branch,f_branch) ->
      compile_ifthenelse predicate t_branch f_branch lambda_cxt  
    | Lstringswitch(l, cases, default) ->
      compile_stringswitch l cases default lambda_cxt
    | Lswitch(switch_arg, sw) ->
      compile_switch switch_arg sw lambda_cxt 
    | Lstaticraise(i, largs) ->  
      compile_staticraise i largs lambda_cxt 
    | Lstaticcatch _  ->
      compile_staticcatch cur_lam lambda_cxt      
    | Lwhile(p,body) ->
      compile_while p body lambda_cxt
    | Lfor (id,start,finish,direction,body) ->
      compile_for id start finish direction body lambda_cxt
    | Lassign(id,lambda) ->
      compile_assign id lambda lambda_cxt
    | Ltrywith(lam,id, catch) ->  (* generate documentation *)
      compile_trywith lam id catch lambda_cxt
    | Lsend(meth_kind,met, obj, args,loc) ->
      compile_send meth_kind met obj args loc lambda_cxt

end
module Ast_literal : sig 
#1 "ast_literal.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


type 'a  lit = ?loc: Location.t -> unit -> 'a

val predef_option : Longident.t 
val predef_some : Longident.t 
val predef_none : Longident.t 

module Lid : sig
  type t = Longident.t 
  val val_unit : t 
  val type_unit : t 
  val type_int : t 
  val js_fn : t 
  val js_meth : t 
  val js_meth_callback : t 
  val js_obj : t 

  val ignore_id : t 
  val js_null : t 
  val js_undefined : t
  val js_null_undefined : t 
  val js_re_id : t 
  val js_internal : t 
end

type expression_lit = Parsetree.expression lit 
type core_type_lit = Parsetree.core_type lit 
type pattern_lit = Parsetree.pattern lit 

val val_unit : expression_lit

val type_unit : core_type_lit
val type_exn : core_type_lit
val type_string : core_type_lit
val type_bool : core_type_lit
val type_int : core_type_lit 
val type_any : core_type_lit

val pat_unit : pattern_lit

end = struct
#1 "ast_literal.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

open Ast_helper


let predef_prefix_ident : Longident.t = Lident "*predef*"

let predef_option : Longident.t =
  Ldot (predef_prefix_ident, "option")

let predef_some : Longident.t =
  Ldot (predef_prefix_ident, "Some")

let predef_none : Longident.t =
  Ldot (predef_prefix_ident, "None")


module Lid = struct
  type t = Longident.t
  let val_unit : t = Lident "()"
  let type_unit : t = Lident "unit"
  let type_string : t = Lident "string"
  let type_int : t = Lident "int" (* use *predef* *)
  let type_exn : t = Lident "exn" (* use *predef* *)
  let type_bool : t = Lident "bool" (* use *predef* *)
  (* TODO should be renamed in to {!Js.fn} *)
  (* TODO should be moved into {!Js.t} Later *)
  let js_internal : t = Ldot (Lident "Js", "Internal")
  let js_fn : t =
      Ldot (js_internal,  "fn")
  let js_meth : t =
      Ldot (js_internal , "meth")
  let js_meth_callback : t =
      Ldot (js_internal, "meth_callback")
  let js_obj : t = Ldot (Lident "Js", "t")
  let ignore_id : t = Ldot (Lident "Pervasives", "ignore")
  let js_null  : t = Ldot (Lident "Js", "null")
  let js_undefined : t = Ldot (Lident "Js", "undefined")
  let js_null_undefined : t = Ldot (Lident "Js", "null_undefined")
  let js_re_id : t = Ldot (Ldot (Lident "Js", "Re"), "t")
end

module No_loc = struct
  let loc = Location.none
  let val_unit =
    Ast_helper.Exp.construct {txt = Lid.val_unit; loc }  None

  let type_unit =
    Ast_helper.Typ.mk  (Ptyp_constr ({ txt = Lid.type_unit; loc}, []))
  let type_exn =
    Ast_helper.Typ.mk  (Ptyp_constr ({ txt = Lid.type_unit; loc}, []))

  let type_int =
    Ast_helper.Typ.mk (Ptyp_constr ({txt = Lid.type_int; loc}, []))
  let type_string =
    Ast_helper.Typ.mk  (Ptyp_constr ({ txt = Lid.type_string; loc}, []))
  let type_bool =
    Ast_helper.Typ.mk  (Ptyp_constr ({ txt = Lid.type_bool; loc}, []))
  let type_any = Ast_helper.Typ.any ()
  let pat_unit = Pat.construct {txt = Lid.val_unit; loc} None
end

type 'a  lit = ?loc: Location.t -> unit -> 'a
type expression_lit = Parsetree.expression lit
type core_type_lit = Parsetree.core_type lit
type pattern_lit = Parsetree.pattern lit

let val_unit ?loc () =
  match loc with
  | None -> No_loc.val_unit
  | Some loc -> Ast_helper.Exp.construct {txt = Lid.val_unit; loc}  None


let type_unit ?loc () =
  match loc with
  | None ->
    No_loc.type_unit
  | Some loc ->
    Ast_helper.Typ.mk ~loc  (Ptyp_constr ({ txt = Lid.type_unit; loc}, []))

let type_exn ?loc () =
  match loc with
  | None ->
    No_loc.type_exn
  | Some loc ->
    Ast_helper.Typ.mk ~loc  (Ptyp_constr ({ txt = Lid.type_exn; loc}, []))


let type_string ?loc () =
  match loc with
  | None -> No_loc.type_string
  | Some loc ->
    Ast_helper.Typ.mk ~loc  (Ptyp_constr ({ txt = Lid.type_string; loc}, []))

let type_bool ?loc () =
  match loc with
  | None -> No_loc.type_bool
  | Some loc ->
    Ast_helper.Typ.mk ~loc  (Ptyp_constr ({ txt = Lid.type_bool; loc}, []))

let type_int ?loc () =
  match loc with
  | None -> No_loc.type_int
  | Some loc ->
    Ast_helper.Typ.mk ~loc  (Ptyp_constr ({ txt = Lid.type_int; loc}, []))

let type_any ?loc () =
  match loc with
  | None -> No_loc.type_any
  | Some loc -> Ast_helper.Typ.any ~loc ()

let pat_unit ?loc () =
  match loc with
  | None -> No_loc.pat_unit
  | Some loc ->
    Pat.construct ~loc {txt = Lid.val_unit; loc} None

end
module Ast_comb : sig 
#1 "ast_comb.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)




(* note we first declare its type is [unit], 
   then [ignore] it, [ignore] is necessary since 
   the js value  maybe not be of type [unit] and 
   we can use [unit] value (though very little chance) 
   sometimes
*)
val discard_exp_as_unit : 
  Location.t -> Parsetree.expression -> Parsetree.expression


val tuple_type_pair : 
  ?loc:Ast_helper.loc ->
  [< `Make | `Run ] ->
  int -> Parsetree.core_type * Parsetree.core_type list * Parsetree.core_type

val to_js_type :
  Location.t -> Parsetree.core_type -> Parsetree.core_type



val to_undefined_type :
  Location.t -> Parsetree.core_type -> Parsetree.core_type  

val to_js_re_type : Location.t -> Parsetree.core_type

val single_non_rec_value : 
  Ast_helper.str -> 
  Parsetree.expression -> 
  Parsetree.structure_item

val single_non_rec_val :   
  Ast_helper.str -> 
  Parsetree.core_type -> 
  Parsetree.signature_item
end = struct
#1 "ast_comb.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


open Ast_helper 



(* let fun_no_label ?loc ?attrs  pat body = 
  Ast_compatible.fun_ ?loc ?attrs  pat body *)


let discard_exp_as_unit loc e = 
  Ast_compatible.apply_simple ~loc     
    (Exp.ident ~loc {txt = Ast_literal.Lid.ignore_id; loc})
    [Exp.constraint_ ~loc e 
       (Ast_literal.type_unit ~loc ())]


let tuple_type_pair ?loc kind arity = 
  let prefix  = "a" in
  if arity = 0 then 
    let ty = Typ.var ?loc ( prefix ^ "0") in 
    match kind with 
    | `Run -> ty,  [], ty 
    | `Make -> 
      (Ast_compatible.arrow ?loc
         (Ast_literal.type_unit ?loc ())
         ty ,
       [], ty)
  else
    let number = arity + 1 in
    let tys = Ext_list.init number (fun i -> 
        Typ.var ?loc (prefix ^ string_of_int (number - i - 1))
      )  in
    match tys with 
    | result :: rest -> 
      Ext_list.reduce_from_left tys (fun r arg -> Ast_compatible.arrow ?loc arg r) , 
      List.rev rest , result
    | [] -> assert false
    
    

let js_obj_type_id  = 
  Ast_literal.Lid.js_obj 

let re_id  = 
  Ast_literal.Lid.js_re_id 

let to_js_type loc  x  = 
  Typ.constr ~loc {txt = js_obj_type_id; loc} [x]

let to_js_re_type loc  =
  Typ.constr ~loc { txt = re_id ; loc} []
    
let to_undefined_type loc x =
  Typ.constr ~loc
    {txt = Ast_literal.Lid.js_undefined ; loc}
    [x]  

let single_non_rec_value  name exp = 
  Str.value Nonrecursive 
    [Vb.mk (Pat.var name) exp]

let single_non_rec_val name ty = 
  Sig.value 
    (Val.mk name ty)
end
module Bs_syntaxerr : sig 
#1 "bs_syntaxerr.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type error 
  = Unsupported_predicates
  | Conflict_bs_bs_this_bs_meth  
  | Duplicated_bs_deriving
  | Conflict_attributes

  | Duplicated_bs_as 
  | Expect_int_literal
  | Expect_string_literal
  | Expect_int_or_string_or_json_literal
  | Unhandled_poly_type
  | Unregistered of string 
  | Invalid_underscore_type_in_external
  | Invalid_bs_string_type 
  | Invalid_bs_int_type 
  | Invalid_bs_unwrap_type
  | Conflict_ffi_attribute of string
  | Not_supported_in_bs_deriving
  | Canot_infer_arity_by_syntax
  | Illegal_attribute
  | Inconsistent_arity of int * int 
  (* we still rqeuire users to have explicit annotation to avoid
     {[ (((int -> int) -> int) -> int )]}
  *)
  | Not_supported_directive_in_bs_return
  | Expect_opt_in_bs_return_to_opt
  | Label_in_uncurried_bs_attribute

  | Bs_this_simple_pattern


val err : Location.t -> error -> 'a

end = struct
#1 "bs_syntaxerr.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



type error
  = Unsupported_predicates
  | Conflict_bs_bs_this_bs_meth
  | Duplicated_bs_deriving
  | Conflict_attributes

  | Duplicated_bs_as
  | Expect_int_literal
  | Expect_string_literal
  | Expect_int_or_string_or_json_literal
  | Unhandled_poly_type
  | Unregistered of string
  | Invalid_underscore_type_in_external
  | Invalid_bs_string_type
  | Invalid_bs_int_type
  | Invalid_bs_unwrap_type
  | Conflict_ffi_attribute of string
  | Not_supported_in_bs_deriving
  | Canot_infer_arity_by_syntax
  | Illegal_attribute
  | Inconsistent_arity of int * int
  (* we still rqeuire users to have explicit annotation to avoid
     {[ (((int -> int) -> int) -> int )]}
  *)
  | Not_supported_directive_in_bs_return
  | Expect_opt_in_bs_return_to_opt
  | Label_in_uncurried_bs_attribute

  | Bs_this_simple_pattern

let pp_error fmt err =
  Format.pp_print_string fmt @@ match err with
  | Label_in_uncurried_bs_attribute
    -> "BuckleScript uncurried function doesn't support labeled arguments yet"
  | Expect_opt_in_bs_return_to_opt
      ->
        "bs.return directive *_to_opt expect return type to be \n\
         syntax wise `_ option` for safety"

  | Not_supported_directive_in_bs_return
    ->
    "Not supported return directive"
  | Illegal_attribute ->
    "Illegal attributes"
  | Canot_infer_arity_by_syntax
    ->   "Cannot infer the arity through the syntax, either [@bs.uncurry n] or \n\
              write it in arrow syntax "
  | Inconsistent_arity (arity,n)
      -> Printf.sprintf "Inconsistent arity %d vs %d" arity n
  | Not_supported_in_bs_deriving
    ->
    "not supported in deriving"
  | Unsupported_predicates
    ->
     "unsupported predicates"
  | Conflict_bs_bs_this_bs_meth ->
     "[@bs.this], [@bs], [@bs.meth] can not be applied at the same time"
  | Duplicated_bs_deriving
    -> "duplicate bs.deriving attribute"
  | Conflict_attributes
    -> "conflicting attributes "
  | Expect_string_literal
    -> "expect string literal "
  | Duplicated_bs_as
    ->
    "duplicate bs.as "
  | Expect_int_literal
    ->
    "expect int literal "
  | Expect_int_or_string_or_json_literal
    ->
    "expect int, string literal or json literal {json|text here|json} "
  | Unhandled_poly_type
    ->
    "Unhandled poly type"
  | Unregistered str
    -> "Unregistered " ^ str
  | Invalid_underscore_type_in_external
    ->
    "_ is not allowed in combination with external optional type"
  | Invalid_bs_string_type
    ->
    "Not a valid type for [@bs.string]"
  | Invalid_bs_int_type
    ->
    "Not a valid type for [@bs.int]"
  | Invalid_bs_unwrap_type
    ->
    "Not a valid type for [@bs.unwrap]. Type must be an inline variant (closed), and\n\
     each constructor must have an argument."
  | Conflict_ffi_attribute str
    ->
    "Conflicting FFI attributes found: " ^ str
  | Bs_this_simple_pattern
    ->
    "[@bs.this] expect its pattern variable to be simple form"

type exn +=  Error of Location.t * error


let () =
  Location.register_error_of_exn (function
    | Error(loc,err) ->
      Some (Location.error_of_printer loc pp_error err)
    | _ -> None
    )

let err loc error = raise (Error(loc, error))

end
module Ast_core_type : sig 
#1 "ast_core_type.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type t = Parsetree.core_type




val lift_option_type : t -> t
val is_any : t -> bool
val replace_result : t -> t -> t

(* val opt_arrow: Location.t -> string -> t -> t -> t *)

val is_unit : t -> bool
val is_array : t -> bool


(** return a function type
    [from_labels ~loc tyvars labels]
    example output:
    {[x:'a0 -> y:'a1 -> < x :'a0 ;y :'a1  > Js.t]}
*)
val from_labels :
  loc:Location.t -> int ->  string Asttypes.loc list -> t

val make_obj :
  loc:Location.t ->
  (string * Parsetree.attributes * t) list ->
  t

val is_user_option : t -> bool

val is_user_bool : t -> bool

val is_user_int : t -> bool



(**
  returns 0 when it can not tell arity from the syntax
*)
val get_uncurry_arity : t -> [`Arity of int | `Not_function ]



(** fails when Ptyp_poly *)
val list_of_arrow :
  t ->
  t *  
  Ast_compatible.param_type list

val is_arity_one : t -> bool

end = struct
#1 "ast_core_type.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type t = Parsetree.core_type









let lift_option_type ({ptyp_loc} as ty:t) : t =
  {ptyp_desc =
     Ptyp_constr(
       {txt = Ast_literal.predef_option;
        loc = ptyp_loc}
        , [ty]);
        ptyp_loc = ptyp_loc;
      ptyp_attributes = []
    }

let is_any (ty : t) =
  ty.ptyp_desc = Ptyp_any

open Ast_helper

let replace_result (ty : t) (result : t) : t =
  let rec aux (ty : Parsetree.core_type) =
    match ty with
    | { ptyp_desc =
          Ptyp_arrow (label,t1,t2)
      } -> { ty with ptyp_desc = Ptyp_arrow(label,t1, aux t2)}
    | {ptyp_desc = Ptyp_poly(fs,ty)}
      ->  {ty with ptyp_desc = Ptyp_poly(fs, aux ty)}
    | _ -> result in
  aux ty

let is_unit (ty : t ) =
  match ty.ptyp_desc with
  | Ptyp_constr({txt =Lident "unit"}, []) -> true
  | _ -> false

let is_array (ty : t) =
  match ty.ptyp_desc with
  | Ptyp_constr({txt =Lident "array"}, [_]) -> true
  | _ -> false

let is_user_option (ty : t) =
  match ty.ptyp_desc with
  | Ptyp_constr(
    {txt = Lident "option" |
     (Ldot (Lident "*predef*", "option")) },
    [_]) -> true
  | _ -> false

let is_user_bool (ty : t) =
  match ty.ptyp_desc with
  | Ptyp_constr({txt = Lident "bool"},[]) -> true
  | _ -> false

let is_user_int (ty : t) =
  match ty.ptyp_desc with
  | Ptyp_constr({txt = Lident "int"},[]) -> true
  | _ -> false





(* Note that OCaml type checker will not allow arbitrary
   name as type variables, for example:
   {[
     '_x'_
   ]}
   will be recognized as a invalid program
*)
let from_labels ~loc arity labels
  : t =
  let tyvars =
    ((Ext_list.init arity (fun i ->
         Typ.var ~loc ("a" ^ string_of_int i)))) in
  let result_type =
    Ast_comb.to_js_type loc
      (Ast_compatible.object_ ~loc
         (Ext_list.map2 labels tyvars (fun x y -> x.Asttypes.txt ,[], y)) Closed)
  in
  Ext_list.fold_right2 labels tyvars  result_type
    (fun label (* {loc ; txt = label }*)
      tyvar acc -> 
      Ast_compatible.label_arrow ~loc:label.loc label.txt tyvar acc) 


let make_obj ~loc xs =
  Ast_comb.to_js_type loc
    (Ast_compatible.object_  ~loc xs Closed)



(**

{[ 'a . 'a -> 'b ]}
OCaml does not support such syntax yet
{[ 'a -> ('a. 'a -> 'b) ]}

*)
let rec get_uncurry_arity_aux  (ty : t) acc =
    match ty.ptyp_desc with
    | Ptyp_arrow(_, _ , new_ty) ->
      get_uncurry_arity_aux new_ty (succ acc)
    | Ptyp_poly (_,ty) ->
      get_uncurry_arity_aux ty acc
    | _ -> acc

(**
   {[ unit -> 'b ]} return arity 0
   {[ unit -> 'a1 -> a2']} arity 2
   {[ 'a1 -> 'a2 -> ... 'aN -> 'b ]} return arity N
*)
let get_uncurry_arity (ty : t ) =
  match ty.ptyp_desc  with
  | Ptyp_arrow(arg_label, {ptyp_desc = (Ptyp_constr ({txt = Lident "unit"}, []))},
     rest  ) when Ast_compatible.is_arg_label_simple arg_label -> 
     begin match rest with 
     | {ptyp_desc = Ptyp_arrow _ } ->  
      `Arity (get_uncurry_arity_aux rest 1 )
    | _ -> `Arity 0 
    end
  | Ptyp_arrow(_,_,rest ) ->
    `Arity(get_uncurry_arity_aux rest 1)
  | _ -> `Not_function

let get_curry_arity  ty =
  get_uncurry_arity_aux ty 0

let is_arity_one ty = get_curry_arity ty =  1


let list_of_arrow 
    (ty : t) : 
  t * Ast_compatible.param_type list
  =
  let rec aux (ty : t) acc =
    match ty.ptyp_desc with
    | Ptyp_arrow(label,t1,t2) ->
      aux t2 
        (({label; 
          ty = t1; 
          attr = ty.ptyp_attributes;
          loc = ty.ptyp_loc} : Ast_compatible.param_type) :: acc
        )
    | Ptyp_poly(_, ty) -> (* should not happen? *)
      Bs_syntaxerr.err ty.ptyp_loc Unhandled_poly_type
    | return_type -> ty, List.rev acc
  in aux ty []


(* type arg_label =
  | Nolabel (* it will be ignored , side effect will be recorded *)
  | Labelled of string
  | Optional of string
  

let label_name l : arg_label =
  if l = "" then Nolabel else
  if is_optional_label l
  then Optional (String.sub l 1 (String.length l - 1))
  else Labelled l   *)
end
module Ext_js_regex : sig 
#1 "ext_js_regex.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

(* This is a module that checks if js regex is valid or not *)

val js_regex_checker : string -> bool
end = struct
#1 "ext_js_regex.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


let check_from_end al =
  let rec aux l seen =
    match l with
    | [] -> false
    | (e::r) ->
      if e < 0 || e > 255 then false
      else (let c = Char.chr e in
            if c = '/' then true
            else (if Ext_list.exists seen (fun x -> x = c)  then false (* flag should not be repeated *)
                  else (if c = 'i' || c = 'g' || c = 'm' || c = 'y' || c ='u' then aux r (c::seen) 
                        else false)))
  in aux al []

let js_regex_checker s =
  match Ext_utf8.decode_utf8_string s with 
  | [] -> false 
  | 47 (* [Char.code '/' = 47 ]*)::tail -> 
    check_from_end (List.rev tail)       
  | _ :: _ -> false 
  | exception Ext_utf8.Invalid_utf8 _ -> false 

end
module Ast_payload : sig 
#1 "ast_payload.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



(** A utility module used when destructuring parsetree attributes, used for 
    compiling FFI attributes and built-in ppx  *)

type t = Parsetree.payload
type lid = string Asttypes.loc
type label_expr = lid  * Parsetree.expression
type action = 
   lid * Parsetree.expression option

val is_single_string : t -> (string * string option) option
val is_single_string_as_ast : 
  t -> 
  Parsetree.expression option 

val is_single_int : t -> int option 

type rtn = Not_String_Lteral | JS_Regex_Check_Failed | Correct of Parsetree.expression
val as_string_exp : check_js_regex: bool -> t -> rtn
val as_core_type : Location.t -> t -> Parsetree.core_type    
(* val as_empty_structure :  t -> bool  *)
val as_ident : t -> Longident.t Asttypes.loc option
val raw_string_payload : Location.t -> string -> t 
val assert_strings :
  Location.t -> t -> string list  

(** as a record or empty 
    it will accept 

    {[ [@@@bs.config ]]}
    or 
    {[ [@@@bs.config no_export ] ]}
    or 
    {[ [@@@bs.config { property  .. } ]]}    
    Note that we only 
    {[
      { flat_property}
    ]}
    below  is not allowed 
    {[
      {M.flat_property}
    ]}
*)

val ident_or_record_as_config : 
  Location.t ->
  t -> action list 

val assert_bool_lit : Parsetree.expression -> bool

val empty : t 

val table_dispatch : 
  (Parsetree.expression option  -> 'a) String_map.t -> action -> 'a

end = struct
#1 "ast_payload.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type t = Parsetree.payload

let is_single_string (x : t ) = 
  match x with  (** TODO also need detect empty phrase case *)
  | PStr [ {
      pstr_desc =  
        Pstr_eval (
          {pexp_desc = 
             Pexp_constant 

                (Pconst_string(name,dec))
               
              ;
           _},_);
      _}] -> Some (name,dec)
  | _  -> None

let is_single_string_as_ast (x : t ) 
  : Parsetree.expression option = 
  match x with  (** TODO also need detect empty phrase case *)
  | PStr [ {
      pstr_desc =  
        Pstr_eval (
          {pexp_desc = 
             Pexp_constant 

                (Pconst_string(name,dec))
               
              ;
           _} as e ,_);
      _}] -> Some e
  | _  -> None

  
(** TODO also need detect empty phrase case *)  

let is_single_int (x : t ) : int option = 
  match x with  
  | PStr [ {
      pstr_desc =  
        Pstr_eval (
          {pexp_desc = 
             Pexp_constant 
               (Pconst_integer (name,_));
           _},_);
      _}] -> Some (int_of_string name)
  | _  -> None

type rtn = Not_String_Lteral | JS_Regex_Check_Failed | Correct of Parsetree.expression

let as_string_exp ~check_js_regex (x : t ) = 
  match x with  (** TODO also need detect empty phrase case *)
  | PStr [ {
      pstr_desc =  
        Pstr_eval (
          {pexp_desc = 
             Pexp_constant 
 
               (Pconst_string (str,_))
               
               ;
           _} as e ,_);
      _}] -> if check_js_regex then (if Ext_js_regex.js_regex_checker str then Correct e else JS_Regex_Check_Failed) else Correct e
  | _  -> Not_String_Lteral

let as_core_type loc x =
  match  x with
  | Parsetree.PTyp x -> x
  | _ -> Location.raise_errorf ~loc "except a core type"

let as_ident (x : t ) =
  match x with
  | PStr [
      {pstr_desc =
         Pstr_eval (
           {
             pexp_desc =
               Pexp_ident ident 

           } , _)
      }
    ] -> Some ident
  | _ -> None
open Ast_helper

let raw_string_payload loc (s : string) : t =
  PStr [ Str.eval ~loc (Ast_compatible.const_exp_string ~loc s) ]


type lid = string Asttypes.loc
type label_expr = lid  * Parsetree.expression

type action = 
  lid * Parsetree.expression option 
(** None means punning is hit 
    {[ { x } ]}
    otherwise it comes with a payload 
    {[ { x = exp }]}
*)



let ident_or_record_as_config     
    loc
    (x : Parsetree.payload) 
  : ( string Location.loc * Parsetree.expression option) list 
  = 
  match  x with 
  | PStr 
      [ {pstr_desc = Pstr_eval
             ({pexp_desc = Pexp_record (label_exprs, with_obj) ; pexp_loc = loc}, _); 
         _
        }]
    -> 
    begin match with_obj with
      | None ->
        Ext_list.map label_exprs
          (fun ((x,y) : (Longident.t Asttypes.loc * _) ) -> 
             match (x,y) with 
             | ({txt = Lident name; loc} ) , 
               ({Parsetree.pexp_desc = Pexp_ident{txt = Lident name2}} )
               when name2 = name -> 
               ({Asttypes.txt = name ; loc}, None)
             | ({txt = Lident name; loc} ), y 
               -> 
               ({Asttypes.txt = name ; loc}, Some y)
             | _ -> 
               Location.raise_errorf ~loc "Qualified label is not allood"
          )

      | Some _ -> 
        Location.raise_errorf ~loc "with is not supported"
    end
  | PStr [
      {pstr_desc =
         Pstr_eval (
           {
             pexp_desc =
               Pexp_ident ({loc = lloc; txt = Lident txt});

           } , _)
      }
    ] -> [ {Asttypes.txt ; loc = lloc}, None] 
  | PStr [] -> []
  | _ -> 
    Location.raise_errorf ~loc "this is not a valid record config"



let assert_strings loc (x : t) : string list
  = 
  let module M = struct exception Not_str end  in 
  match x with 
  | PStr [ {pstr_desc =  
              Pstr_eval (
                {pexp_desc = 
                   Pexp_tuple strs;
                 _},_);
            pstr_loc = loc ;            
            _}] ->
    (try 
        Ext_list.map strs (fun e ->
           match (e : Parsetree.expression) with
           | {pexp_desc = Pexp_constant (
 
              Pconst_string
              
               (name,_)); _} -> 
             name
           | _ -> raise M.Not_str)
     with M.Not_str ->
       Location.raise_errorf ~loc "expect string tuple list"
    )
  | PStr [ {
      pstr_desc =  
        Pstr_eval (
          {pexp_desc = 
             Pexp_constant 
 
               (Pconst_string(name,_)); 
               
           _},_);
      _}] ->  [name] 
  | PStr [] ->  []
 
  | PSig _ 

  | PStr _                
  | PTyp _ | PPat _ ->
    Location.raise_errorf ~loc "expect string tuple list"
let assert_bool_lit  (e : Parsetree.expression) = 
  match e.pexp_desc with
  | Pexp_construct ({txt = Lident "true" }, None)
    -> true
  | Pexp_construct ({txt = Lident "false" }, None)
    -> false 
  | _ ->
    Location.raise_errorf ~loc:e.pexp_loc "expect `true` or `false` in this field"


let empty : t = Parsetree.PStr []



let table_dispatch table (action : action)
  = 
  match action with 
  | {txt =  name; loc  }, y -> 
    begin match String_map.find_exn table name with 
      | fn -> fn y
      | exception _ -> Location.raise_errorf ~loc "%s is not supported" name
    end

end
module Ast_signature : sig 
#1 "ast_signature.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type item = Parsetree.signature_item
type t = item list 


val fuseAll : ?loc:Ast_helper.loc ->  t -> item
end = struct
#1 "ast_signature.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type item = Parsetree.signature_item
type t = item list 

open Ast_helper

let fuseAll ?(loc=Location.none)  (t : t) : item = 
  Sig.include_ ~loc (Incl.mk ~loc (Mty.signature ~loc t))
  
end
module Ast_structure : sig 
#1 "ast_structure.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


type item = Parsetree.structure_item

type t = item list 


val fuseAll: ?loc:Ast_helper.loc ->  t -> item

(* val fuse_with_constraint:
  ?loc:Ast_helper.loc ->
  Parsetree.type_declaration list ->
  t   ->
  Ast_signature.t -> 
  item *)

val constraint_ : ?loc:Ast_helper.loc -> t -> Ast_signature.t -> item

val dummy_item : Location.t -> item 
end = struct
#1 "ast_structure.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type item = Parsetree.structure_item

type t = item list 

open Ast_helper


let fuseAll ?(loc=Location.none)  (t : t) : item = 
  Str.include_ ~loc 
    (Incl.mk ~loc (Mod.structure ~loc t ))
    
(* let fuse_with_constraint
    ?(loc=Location.none) 
    (item : Parsetree.type_declaration list ) (t : t) (coercion) = 
  Str.include_ ~loc 
    (Incl.mk ~loc 
       (Mod.constraint_
         (Mod.structure ~loc 
         ({pstr_loc = loc; pstr_desc = Pstr_type item} :: t) )
         (
           Mty.signature ~loc 
           ({psig_loc = loc; psig_desc = Psig_type item} :: coercion)
         )
         )
    )      *)
let constraint_ ?(loc=Location.none) (stru : t) (sign : Ast_signature.t) = 
  Str.include_ ~loc
    (Incl.mk ~loc 
       (Mod.constraint_ ~loc (Mod.structure ~loc stru) (Mty.signature ~loc sign)))

let dummy_item  loc : item =        
  Str.eval ~loc (Ast_literal.val_unit ~loc ())
end
module Ast_derive : sig 
#1 "ast_derive.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type tdcls = Parsetree.type_declaration list 

type gen = {
  structure_gen : tdcls -> bool -> Ast_structure.t ;
  signature_gen : tdcls -> bool -> Ast_signature.t ; 
  expression_gen : (Parsetree.core_type -> Parsetree.expression) option ; 
}

(**
   [register name cb]
   example: [register "accessors" cb]
*)
val register : 
  string -> 
  (Parsetree.expression option -> gen) -> 
  unit

(* val gen_structure: 
  tdcls  ->
  Ast_payload.action list ->
  bool -> 
  Ast_structure.t *)

val gen_signature: 
  tdcls ->
  Ast_payload.action list -> 
  bool -> 
  Ast_signature.t


val gen_expression : 
  string Asttypes.loc -> 
  Parsetree.core_type -> 
  Parsetree.expression



val gen_structure_signature :  
  Location.t -> 
  Parsetree.type_declaration list ->
  Ast_payload.action -> 
  bool -> 
  Parsetree.structure_item
end = struct
#1 "ast_derive.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type tdcls = Parsetree.type_declaration list

type gen = {
  structure_gen : tdcls -> bool -> Ast_structure.t ;
  signature_gen : tdcls -> bool -> Ast_signature.t ; 
  expression_gen : (Parsetree.core_type -> Parsetree.expression) option ; 
}

(* the first argument is [config] payload
   {[
     { x = {uu} }
   ]}
*)
type derive_table  = 
  (Parsetree.expression option -> gen) String_map.t

let derive_table : derive_table ref = ref String_map.empty

let register key value = 
  derive_table := String_map.add !derive_table key value 



(* let gen_structure 
    (tdcls : tdcls)
    (actions :  Ast_payload.action list ) 
    (explict_nonrec : bool )
  : Ast_structure.t = 
  Ext_list.flat_map
    (fun action -> 
       (Ast_payload.table_dispatch !derive_table action).structure_gen 
         tdcls explict_nonrec) actions *)

let gen_signature
    tdcls
    (actions :  Ast_payload.action list ) 
    (explict_nonrec : bool )
  : Ast_signature.t = 
  Ext_list.flat_map actions
    (fun action -> 
       (Ast_payload.table_dispatch !derive_table action).signature_gen
         tdcls explict_nonrec) 

(** used for cases like [%sexp] *)         
let gen_expression ({Asttypes.txt ; loc}) typ =
  let txt = Ext_string.tail_from txt (String.length Literals.bs_deriving_dot) in 
  match (Ast_payload.table_dispatch !derive_table 
           ({txt ; loc}, None)).expression_gen with 
  | None ->
    Bs_syntaxerr.err loc (Unregistered txt)

  | Some f -> f typ

open Ast_helper  
let gen_structure_signature 
    loc
    (tdcls : tdcls)   
    (action : Ast_payload.action)
    (explicit_nonrec : bool) = 
  let derive_table = !derive_table in  
  let u = 
    Ast_payload.table_dispatch derive_table action in  

  let a = u.structure_gen tdcls explicit_nonrec in
  let b = u.signature_gen tdcls explicit_nonrec in
  Str.include_ ~loc  
    (Incl.mk ~loc 
       (Mod.constraint_ ~loc
          (Mod.structure ~loc a)
          (Mty.signature ~loc b )
       )
    )
end
module Hash_set_poly : sig 
#1 "hash_set_poly.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


type   'a t 

val create : int -> 'a t

val clear : 'a t -> unit

val reset : 'a t -> unit

val copy : 'a t -> 'a t

val add : 'a t -> 'a  -> unit
val remove : 'a t -> 'a -> unit

val mem : 'a t -> 'a -> bool

val iter : 'a t -> ('a -> unit) -> unit

val elements : 'a t -> 'a list

val length : 'a t -> int 

val stats:  'a t -> Hashtbl.statistics

end = struct
#1 "hash_set_poly.ml"
# 1 "ext/hash_set.cppo.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
# 51 "ext/hash_set.cppo.ml"
[@@@ocaml.warning "-3"]
(* we used cppo the mixture does not work*)
external seeded_hash_param :
  int -> int -> int -> 'a -> int = "caml_hash" "noalloc"
let key_index (h :  _ Hash_set_gen.t ) (key : 'a) =
  seeded_hash_param 10 100 0 key land (Array.length h.data - 1)
let eq_key = (=)
type  'a t = 'a Hash_set_gen.t 


# 64 "ext/hash_set.cppo.ml"
let create = Hash_set_gen.create
let clear = Hash_set_gen.clear
let reset = Hash_set_gen.reset
let copy = Hash_set_gen.copy
let iter = Hash_set_gen.iter
let fold = Hash_set_gen.fold
let length = Hash_set_gen.length
let stats = Hash_set_gen.stats
let elements = Hash_set_gen.elements



let remove (h : _ Hash_set_gen.t) key =  
  let i = key_index h key in
  let h_data = h.data in
  let old_h_size = h.size in 
  let new_bucket = Hash_set_gen.remove_bucket eq_key key h (Array.unsafe_get h_data i) in
  if old_h_size <> h.size then  
    Array.unsafe_set h_data i new_bucket



let add (h : _ Hash_set_gen.t) key =
  let i = key_index h key  in 
  let h_data = h.data in 
  let old_bucket = (Array.unsafe_get h_data i) in
  if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then 
    begin 
      Array.unsafe_set h_data i (key :: old_bucket);
      h.size <- h.size + 1 ;
      if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h
    end

let of_array arr = 
  let len = Array.length arr in 
  let tbl = create len in 
  for i = 0 to len - 1  do
    add tbl (Array.unsafe_get arr i);
  done ;
  tbl 
  
    
let check_add (h : _ Hash_set_gen.t) key =
  let i = key_index h key  in 
  let h_data = h.data in  
  let old_bucket = (Array.unsafe_get h_data i) in
  if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then 
    begin 
      Array.unsafe_set h_data i  (key :: old_bucket);
      h.size <- h.size + 1 ;
      if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h;
      true 
    end
  else false 


let mem (h :  _ Hash_set_gen.t) key =
  Hash_set_gen.small_bucket_mem eq_key key (Array.unsafe_get h.data (key_index h key)) 

  

end
module Bs_ast_invariant : sig 
#1 "bs_ast_invariant.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

 
type iterator = Ast_iterator.iterator

val mark_used_bs_attribute : 
  Parsetree.attribute -> unit 

(** [warn_discarded_unused_attributes discarded]
  warn if [discarded] has unused bs attribute
*)  
val warn_discarded_unused_attributes :   
  Parsetree.attributes -> unit 
(** Ast invariant checking for detecting errors *)

val emit_external_warnings_on_structure:
  Parsetree.structure -> unit 

val emit_external_warnings_on_signature:  
  Parsetree.signature -> unit
end = struct
#1 "bs_ast_invariant.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


let is_bs_attribute txt = 
  let len = String.length txt  in
  len >= 2 &&
  (*TODO: check the stringing padding rule, this preciate may not be needed *)
  String.unsafe_get txt 0 = 'b'&& 
  String.unsafe_get txt 1 = 's' &&
  (len = 2 ||
   String.unsafe_get txt 2 = '.'
  )

let used_attributes : string Asttypes.loc Hash_set_poly.t = 
    Hash_set_poly.create 16 




(* only mark non-ghost used bs attribute *)
let mark_used_bs_attribute ((x,_) : Parsetree.attribute) = 
  if not x.loc.loc_ghost then
    Hash_set_poly.add used_attributes x

let dummy_unused_attribute : Warnings.t = (Bs_unused_attribute "")



let warn_unused_attribute 
  (({txt; loc} as sloc, _) : Parsetree.attribute) = 
  if is_bs_attribute txt && 
     not loc.loc_ghost &&
     not (Hash_set_poly.mem used_attributes sloc) then 
    begin    

      Location.prerr_warning loc (Bs_unused_attribute txt)
    end

let warn_discarded_unused_attributes (attrs : Parsetree.attributes) = 
  if attrs <> [] then 
    Ext_list.iter attrs warn_unused_attribute
    
 
type iterator = Ast_iterator.iterator
let default_iterator = Ast_iterator.default_iterator

(* Note we only used Bs_ast_iterator here, we can reuse compiler-libs instead of 
   rolling our own*)
let emit_external_warnings : iterator=
  {
    default_iterator with
    attribute = (fun _ attr -> warn_unused_attribute attr);
    expr = (fun self a -> 
        match a.pexp_desc with 
        | Pexp_constant (

          Pconst_string

          (_, Some s)) 
          when Ast_utf8_string_interp.is_unescaped s -> 
          Bs_warnings.error_unescaped_delimiter a.pexp_loc s 

        | Pexp_constant(Pconst_integer(s,None)) -> 
          (* range check using int32 
            It is better to give a warning instead of error to avoid make people unhappy.
            It also has restrictions in which platform bsc is running on since it will 
            affect int ranges
          *)
          (
            try 
              ignore (
                if String.length s = 0 || s.[0] = '-' then 
                  Int32.of_string s 
                else Int32.of_string ("-" ^ s))
            with _ ->              
              Bs_warnings.warn_literal_overflow a.pexp_loc
          )

        | _ -> default_iterator.expr self a 
      );
    value_description =
      (fun self v -> 
         match v with 
         | ( {
             pval_loc;
             pval_prim =
               "%identity"::_;
             pval_type
           } : Parsetree.value_description)
           when not
               (Ast_core_type.is_arity_one pval_type)
           -> 
           Location.raise_errorf
             ~loc:pval_loc
             "%%identity expect its type to be of form 'a -> 'b (arity 1)"
         | _ ->
           default_iterator.value_description self v 
      );
      pat = begin fun self (pat : Parsetree.pattern) -> 
                  match pat.ppat_desc with
                  |  Ppat_constant(

            Pconst_string
                    
         (_, Some "j")) ->
        Location.raise_errorf ~loc:pat.ppat_loc  "Unicode string is not allowed in pattern match" 
      | _ -> default_iterator.pat self pat
      end 
  }

let emit_external_warnings_on_structure  (stru : Parsetree.structure) = 
  if Warnings.is_active dummy_unused_attribute then 
    emit_external_warnings.structure emit_external_warnings stru

let emit_external_warnings_on_signature  (sigi : Parsetree.signature) = 
  if Warnings.is_active dummy_unused_attribute then 
    emit_external_warnings.signature emit_external_warnings sigi
end
module Ast_attributes : sig 
#1 "ast_attributes.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
type attr =  Parsetree.attribute
type t =  attr list

type ('a,'b) st =
  { get : 'a option ;
    set : 'b option }

val process_method_attributes_rev :
  t ->
  (bool * bool , [`Get | `No_get ]) st * t

type attr_kind = 
  | Nothing 
  | Meth_callback of attr 
  | Uncurry of attr  
  | Method of attr

val process_attributes_rev :
  t -> attr_kind * t

val process_pexp_fun_attributes_rev :
  t -> bool * t

val process_bs :
  t -> bool * t

val external_needs_to_be_encoded :
  t -> bool

val has_inline_in_stru : 
  t -> 
  bool

val has_inline_payload_in_sig :
  t ->
  attr option 

type derive_attr = {
  explict_nonrec : bool;
  bs_deriving : Ast_payload.action list option
}


val iter_process_bs_string_int_unwrap_uncurry :
  t -> 
  [`Nothing | `String | `Int | `Ignore | `Unwrap | `Uncurry of int option ]


val iter_process_bs_string_as :
  t -> string option

val iter_process_bs_string_as_ast :   
  t -> 
  Parsetree.expression option
  
val has_bs_optional :
  t -> bool 

val iter_process_bs_int_as :
  t -> int option


val iter_process_bs_string_or_int_as :
    t ->
    [ `Int of int
    | `Str of string
    | `Json_str of string  ] option


val process_derive_type :
  t -> derive_attr * t

val iter_process_derive_type :
  t -> derive_attr


val bs : attr
val is_bs : attr -> bool
val is_optional : attr -> bool
val is_bs_as : attr -> bool



val bs_get : attr
val bs_get_arity : attr 
val bs_set : attr
val bs_return_undefined : attr

val deprecated : string -> attr

end = struct
#1 "ast_attributes.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type attr =  Parsetree.attribute
type t =  attr list

type ('a,'b) st =
  { get : 'a option ;
    set : 'b option }


let process_method_attributes_rev (attrs : t) =
  Ext_list.fold_left attrs ({get = None ; set = None}, []) (fun (st,acc) (({txt ; loc}, payload) as attr ) ->
      match txt  with
      | "bs.get" (* [@@bs.get{null; undefined}]*)
        ->
        let result =
          Ext_list.fold_left (Ast_payload.ident_or_record_as_config loc payload) (false, false)
            (fun (null, undefined) ({txt ; loc}, opt_expr) ->
              match txt with
              | "null" ->
                (match opt_expr with
                 | None -> true
                 | Some e ->
                   Ast_payload.assert_bool_lit e), undefined

              |  "undefined" ->
                null,
                (match opt_expr with
                 | None ->  true
                 | Some e ->
                   Ast_payload.assert_bool_lit e)
              | "nullable" ->
                begin match opt_expr with
                  | None -> true, true
                  | Some e ->
                    let v = Ast_payload.assert_bool_lit e in
                    v,v
                end
              | _ -> Bs_syntaxerr.err loc Unsupported_predicates
            ) in

        ({st with get = Some result}, acc  )

      | "bs.set"
        ->
        let result =
          Ext_list.fold_left (Ast_payload.ident_or_record_as_config loc payload) `Get 
            (fun st ({txt ; loc}, opt_expr)  ->
               if txt =  "no_get" then
                 match opt_expr with
                 | None -> `No_get
                 | Some e ->
                   if Ast_payload.assert_bool_lit e then
                     `No_get
                   else `Get
               else Bs_syntaxerr.err loc Unsupported_predicates
            )  in
        (* properties -- void
              [@@bs.set{only}]
        *)
        {st with set = Some result }, acc
      | _ ->
        (st, attr::acc  )
    ) 

type attr_kind = 
  | Nothing 
  | Meth_callback of attr 
  | Uncurry of attr 
  | Method of attr

let process_attributes_rev (attrs : t) : attr_kind * t =
  Ext_list.fold_left attrs ( Nothing, []) (fun (st, acc) (({txt; loc}, _) as attr) ->
      match txt, st  with
      | "bs", (Nothing | Uncurry _)
        ->
        Uncurry attr, acc (* TODO: warn unused/duplicated attribute *)
      | "bs.this", (Nothing | Meth_callback _)
        ->  Meth_callback attr, acc
      | "bs.meth",  (Nothing | Method _)
        -> Method attr, acc
      | "bs", _
      | "bs.this", _
        -> Bs_syntaxerr.err loc Conflict_bs_bs_this_bs_meth
      | _ , _ ->
        st, attr::acc
    ) 

let process_pexp_fun_attributes_rev (attrs : t) =
  Ext_list.fold_left attrs (false, []) (fun (st, acc) (({txt; loc}, _) as attr ) ->
      match txt  with
      | "bs.open"
        ->
        true, acc
      | _  ->
        st, attr::acc
    ) 


let process_bs (attrs : t) =
  Ext_list.fold_left attrs (false, []) (fun (st, acc) (({txt; loc}, _) as attr ) ->
      match txt, st  with
      | "bs", _
        ->
        true, acc
      | _ , _ ->
        st, attr::acc
    ) 

let external_needs_to_be_encoded (attrs : t)=
  Ext_list.exists_fst attrs 
    (fun {txt} ->
       Ext_string.starts_with txt "bs." || txt = Literals.gentype_import) 

let has_inline_in_stru (attrs : t) : bool =
  Ext_list.exists attrs (fun 
    (({txt;},_) as attr) -> 
    if txt = "bs.inline" then
      (Bs_ast_invariant.mark_used_bs_attribute attr;
      true)
    else false)       

let has_inline_payload_in_sig (attrs : t)  = 
  Ext_list.find_first attrs 
    (fun (({txt},_) as attr) ->
       if txt = "bs.inline" then
       begin
        Bs_ast_invariant.mark_used_bs_attribute attr;
        true
       end 
       else false
    ) 

type derive_attr = {
  explict_nonrec : bool;
  bs_deriving : Ast_payload.action list option
}

let process_derive_type (attrs : t) : derive_attr * t =
  Ext_list.fold_left attrs ({explict_nonrec = false; bs_deriving = None }, []) 
    (fun (st, acc) ({txt ; loc}, payload  as attr)  ->
      match  st, txt  with
      |  {bs_deriving = None}, "bs.deriving"
        ->
        {st with
         bs_deriving = Some
             (Ast_payload.ident_or_record_as_config loc payload)}, acc
      | {bs_deriving = Some _}, "bs.deriving"
        ->
        Bs_syntaxerr.err loc Duplicated_bs_deriving

      | _ , _ ->
        let st =
          if txt = "nonrec" then
            { st with explict_nonrec = true }
          else st in
        st, attr::acc
    ) 

let iter_process_derive_type (attrs : t) =
  let st = ref {explict_nonrec = false; bs_deriving = None } in
  Ext_list.iter attrs
    (fun ({txt ; loc}, payload  as attr)  ->
      match  txt  with
      |  "bs.deriving"
        ->
        let ost = !st in
        (match ost with
         | {bs_deriving = None } ->
           Bs_ast_invariant.mark_used_bs_attribute attr ;
           st :=
             {ost with
              bs_deriving = Some
                  (Ast_payload.ident_or_record_as_config loc payload)}
         | {bs_deriving = Some _} ->
           Bs_syntaxerr.err loc Duplicated_bs_deriving)

      | "nonrec" ->
        st :=
          { !st with explict_nonrec = true }
      (* non bs attribute, no need to mark its use *)
      | _ -> ()
    ) ;
  !st


(* duplicated [bs.uncurry] [bs.string] not allowed,
  it is worse in bs.uncurry since it will introduce
  inconsistency in arity
 *)  
let iter_process_bs_string_int_unwrap_uncurry (attrs : t) =
  let st = ref `Nothing in 
  let assign v (({loc;_}, _ ) as attr : attr) = 
    if !st = `Nothing then 
    begin 
      Bs_ast_invariant.mark_used_bs_attribute attr;
      st := v ;
    end  
    else Bs_syntaxerr.err loc Conflict_attributes  in 
  Ext_list.iter attrs (fun (({txt ; loc}, (payload : _ ) ) as attr)  ->
      match  txt with
      | "bs.string"
        -> assign `String attr
      | "bs.int"
        -> assign `Int attr
      | "bs.ignore"
        -> assign `Ignore attr
      | "bs.unwrap"
        -> assign `Unwrap attr
      | "bs.uncurry"
        ->
        assign (`Uncurry (Ast_payload.is_single_int payload)) attr
      | _ -> ()
    ) ;
  !st 


let iter_process_bs_string_as  (attrs : t) : string option =
  let st = ref None in
  Ext_list.iter attrs
    (fun
      (({txt ; loc}, payload ) as attr )  ->
      match  txt with
      | "bs.as"
        ->
        if !st = None then
          match Ast_payload.is_single_string payload with
          | None ->
            Bs_syntaxerr.err loc Expect_string_literal
          | Some  (v,_dec) ->            
            Bs_ast_invariant.mark_used_bs_attribute attr ;
            st:= Some v
        else
          Bs_syntaxerr.err loc Duplicated_bs_as
      | _  -> ()
    ) ;
  !st

let iter_process_bs_string_as_ast  (attrs : t) : Parsetree.expression option =
  let st = ref None in
  Ext_list.iter attrs
    (fun
      (({txt ; loc}, payload ) as attr )  ->
      match  txt with
      | "bs.as"
        ->
        if !st = None then
          match Ast_payload.is_single_string_as_ast payload with
          | None ->
            Bs_syntaxerr.err loc Expect_string_literal
          | Some _ as v ->            
            Bs_ast_invariant.mark_used_bs_attribute attr ;
            st:=  v
        else
          Bs_syntaxerr.err loc Duplicated_bs_as
      | _  -> ()
    ) ;
  !st  

let has_bs_optional  (attrs : t) : bool =
  Ext_list.exists attrs (fun
      (({txt ; }, _ ) as attr)  ->
      match  txt with
      | "bs.optional"
        ->
        Bs_ast_invariant.mark_used_bs_attribute attr ;
        true
      | _  -> false
    ) 



let iter_process_bs_int_as  (attrs : t) =
  let st = ref None in
  Ext_list.iter attrs
    (fun
      (({txt ; loc}, payload ) as attr)  ->
      match  txt with
      | "bs.as"
        ->
        if !st =  None then
          match Ast_payload.is_single_int payload with
          | None ->
            Bs_syntaxerr.err loc Expect_int_literal
          | Some  _ as v->
            Bs_ast_invariant.mark_used_bs_attribute attr ;
            st := v
        else
          Bs_syntaxerr.err loc Duplicated_bs_as
      | _  -> ()
    ) ; !st


let iter_process_bs_string_or_int_as (attrs : Parsetree.attributes) =
  let st = ref None in
  Ext_list.iter attrs
    (fun
      (({txt ; loc}, payload ) as attr)  ->
      match  txt with
      | "bs.as"
        ->
        if !st = None then
          (Bs_ast_invariant.mark_used_bs_attribute attr ;
           match Ast_payload.is_single_int payload with
           | None ->
             begin match Ast_payload.is_single_string payload with
               | Some (s,None) ->
                 st := Some (`Str (s))
               | Some (s, Some "json") ->
                 st := Some (`Json_str s )
               | None | Some (_, Some _) ->
                 Bs_syntaxerr.err loc Expect_int_or_string_or_json_literal

             end
           | Some   v->
             st := (Some (`Int v))
          )
        else
          Bs_syntaxerr.err loc Duplicated_bs_as
      | _ -> ()

    ) ;
  !st

let locg = Location.none
let bs : attr
  =  {txt = "bs" ; loc = locg}, Ast_payload.empty

let is_bs (attr : attr) =
  match attr with
  | {Location.txt = "bs"; _}, _ -> true
  | _ -> false

let is_optional (attr : attr) =
  match attr with
  | {Location.txt = "bs.optional"; _}, _ -> true
  | _ -> false

let is_bs_as (attr : attr) =
  match attr with
  | {Location.txt = "bs.as"; _}, _ -> true
  | _ -> false

let bs_get : attr
  =  {txt = "bs.get"; loc = locg}, Ast_payload.empty

let bs_get_arity : attr
  =  {txt = "internal.arity"; loc = locg}, 
    PStr 
    [{pstr_desc =
         Pstr_eval (
          Ast_compatible.const_exp_int ~loc:locg 1
           ,
           [])
      ; pstr_loc = locg}]
  

let bs_set : attr
  =  {txt = "bs.set"; loc = locg}, Ast_payload.empty

let bs_return_undefined : attr
  =
  {txt = "bs.return"; loc = locg },
  PStr
    [
      {pstr_desc =
         Pstr_eval (
           {pexp_desc =
              Pexp_ident
                { txt = Lident "undefined_to_opt";
                  loc = locg};
            pexp_loc = locg;
            pexp_attributes = []
           },[])
      ; pstr_loc = locg}]

let deprecated s : attr =       
  {txt = "ocaml.deprecated"; loc = locg },
  PStr
    [
      {pstr_desc =
         Pstr_eval (
           Ast_compatible.const_exp_string ~loc:locg s, 
           [])
      ; pstr_loc = locg}]

end
module Ast_exp : sig 
#1 "ast_exp.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type t = Parsetree.expression 

end = struct
#1 "ast_exp.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type t = Parsetree.expression 

end
module Ast_external_mk : sig 
#1 "ast_external_mk.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

(**
  [local_module loc ~pval_prim ~pval_type args]
  generate such code 
  {[
    let module J = struct 
       external unsafe_expr : pval_type = pval_prim 
    end in 
    J.unssafe_expr args
  ]}
*)
val local_external_apply :
   Location.t ->
  ?pval_attributes:Parsetree.attributes ->
  pval_prim:string list ->
  pval_type:Parsetree.core_type ->
  ?local_module_name:string ->
  ?local_fun_name:string ->
  Parsetree.expression list -> 
  Parsetree.expression_desc


val local_external_obj :
   Location.t ->
  ?pval_attributes:Parsetree.attributes ->
  pval_prim:string list ->
  pval_type:Parsetree.core_type ->
  ?local_module_name:string ->
  ?local_fun_name:string ->
  (string * Parsetree.expression) list ->  (* [ (label, exp )]*)  
  Parsetree.expression_desc



val local_extern_cont : 
  Location.t ->
  ?pval_attributes:Parsetree.attributes ->
  pval_prim:string list ->
  pval_type:Parsetree.core_type ->
  ?local_module_name:string ->
  ?local_fun_name:string ->
  (Parsetree.expression -> Parsetree.expression) -> Parsetree.expression_desc

end = struct
#1 "ast_external_mk.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

let local_external_apply loc 
     ?(pval_attributes=[])
     ~pval_prim
     ~pval_type 
     ?(local_module_name = "J")
     ?(local_fun_name = "unsafe_expr")
     args
  : Parsetree.expression_desc = 
  Pexp_letmodule
    ({txt = local_module_name; loc},
     {pmod_desc =
        Pmod_structure
          [{pstr_desc =
              Pstr_primitive
                {pval_name = {txt = local_fun_name; loc};
                 pval_type ;
                 pval_loc = loc;
                 pval_prim ;
                 pval_attributes };
            pstr_loc = loc;
           }];
      pmod_loc = loc;
      pmod_attributes = []},
      Ast_compatible.apply_simple 
      ({pexp_desc = Pexp_ident {txt = Ldot (Lident local_module_name, local_fun_name); 
                                      loc};
              pexp_attributes = [] ;
              pexp_loc = loc} : Parsetree.expression) args ~loc
    )

let local_external_obj loc 
     ?(pval_attributes=[])
     ~pval_prim
     ~pval_type 
     ?(local_module_name = "J")
     ?(local_fun_name = "unsafe_expr")
     args
  : Parsetree.expression_desc = 
  Pexp_letmodule
    ({txt = local_module_name; loc},
     {pmod_desc =
        Pmod_structure
          [{pstr_desc =
              Pstr_primitive
                {pval_name = {txt = local_fun_name; loc};
                 pval_type ;
                 pval_loc = loc;
                 pval_prim ;
                 pval_attributes };
            pstr_loc = loc;
           }];
      pmod_loc = loc;
      pmod_attributes = []},
      Ast_compatible.apply_labels
      ({pexp_desc = Pexp_ident {txt = Ldot (Lident local_module_name, local_fun_name); 
                                      loc};
              pexp_attributes = [] ;
              pexp_loc = loc} : Parsetree.expression) args ~loc
    )    

let local_extern_cont loc 
     ?(pval_attributes=[])
     ~pval_prim
     ~pval_type 
     ?(local_module_name = "J")
     ?(local_fun_name = "unsafe_expr")
     (cb : Parsetree.expression -> 'a) 
  : Parsetree.expression_desc = 
  Pexp_letmodule
    ({txt = local_module_name; loc},
     {pmod_desc =
        Pmod_structure
          [{pstr_desc =
              Pstr_primitive
                {pval_name = {txt = local_fun_name; loc};
                 pval_type ;
                 pval_loc = loc;
                 pval_prim ;
                 pval_attributes };
            pstr_loc = loc;
           }];
      pmod_loc = loc;
      pmod_attributes = []},
     cb {pexp_desc = Pexp_ident {txt = Ldot (Lident local_module_name, local_fun_name); 
                                 loc};
         pexp_attributes = [] ;
         pexp_loc = loc}
)

end
module Ast_polyvar : sig 
#1 "ast_polyvar.mli"
(* Copyright (C) 2017 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

(** side effect: it will mark used attributes `bs.as`  *)
val map_row_fields_into_ints:
  Location.t -> 
  Parsetree.row_field list -> 
  (int * int ) list 

val map_constructor_declarations_into_ints:
  Parsetree.constructor_declaration list ->
  [ `Offset of int | `New  of int list ]

val map_row_fields_into_strings:
  Location.t -> 
  Parsetree.row_field list -> 
  External_arg_spec.attr


val is_enum :   
  Parsetree.row_field list -> 
  bool

val is_enum_polyvar :   
  Parsetree.type_declaration ->
  Parsetree.row_field list option 

val is_enum_constructors :   
  Parsetree.constructor_declaration list ->
  bool 
end = struct
#1 "ast_polyvar.ml"
(* Copyright (C) 2017 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


let map_row_fields_into_ints ptyp_loc
    (row_fields : Parsetree.row_field list) 
  = 
  let _, acc = 
    Ext_list.fold_left row_fields (0, []) 
       (fun (i,acc) rtag -> 
          match rtag with 
          | Rtag (label, attrs, true,  [])
            -> 
            begin match Ast_attributes.iter_process_bs_int_as attrs with 
              | Some i -> 
                i + 1, 
                ((Ast_compatible.hash_label label , i):: acc ) 
              | None -> 
                i + 1 , 
                ((Ast_compatible.hash_label label , i):: acc )
            end
          | _ -> 
            Bs_syntaxerr.err ptyp_loc Invalid_bs_int_type
       )  in 
  List.rev acc

(** Note this is okay with enums, for variants,
    the underlying representation may change due to       
    unbox
*)
let map_constructor_declarations_into_ints 
    (row_fields : Parsetree.constructor_declaration list)
  = 
  let mark = ref `nothing in 
  let _, acc
    = 
    Ext_list.fold_left row_fields (0, []) 
       (fun (i,acc) rtag -> 
          let attrs = rtag.pcd_attributes in 
           match Ast_attributes.iter_process_bs_int_as attrs with 
            | Some j -> 
              if j <> i then 
                (
                  if i = 0 then mark := `offset j
                  else mark := `complex
                )
              ;
              (j + 1, 
               (j:: acc ) )
            | None -> 
              i + 1 , 
              ( i:: acc )
       ) in 
  match !mark with 
  | `nothing -> `Offset 0
  | `offset j -> `Offset j 
  | `complex -> `New (List.rev acc)



(** It also check in-consistency of cases like 
    {[ [`a  | `c of int ] ]}       
*)  
let map_row_fields_into_strings ptyp_loc 
    (row_fields : Parsetree.row_field list) : External_arg_spec.attr = 
  let case, result = 
    Ext_list.fold_right row_fields (`Nothing, []) (fun tag (nullary, acc) -> 
        match nullary, tag with 
        | (`Nothing | `Null), 
          Rtag (label, attrs, true,  [])
          -> 
          begin match Ast_attributes.iter_process_bs_string_as attrs with 
            | Some name -> 
              `Null, ((Ast_compatible.hash_label label, name) :: acc )

            | None -> 
              `Null, ((Ast_compatible.hash_label label, Ast_compatible.label_of_name label) :: acc )
          end
        | (`Nothing | `NonNull), Rtag(label, attrs, false, ([ _ ])) 
          -> 
          begin match Ast_attributes.iter_process_bs_string_as attrs with 
            | Some name -> 
              `NonNull, ((Ast_compatible.hash_label label, name) :: acc)
            | None -> 
              `NonNull, ((Ast_compatible.hash_label label, Ast_compatible.label_of_name label) :: acc)
          end
        | _ -> Bs_syntaxerr.err ptyp_loc Invalid_bs_string_type

      )  in 
  match case with 
  | `Nothing -> Bs_syntaxerr.err ptyp_loc Invalid_bs_string_type
  | `Null -> External_arg_spec.NullString result 
  | `NonNull -> NonNullString result


let is_enum row_fields = 
  List.for_all (fun (x : Parsetree.row_field) -> 
      match x with 
      | Rtag(_label,_attrs,true, []) -> true 
      | _ -> false
    ) row_fields


let is_enum_polyvar (ty : Parsetree.type_declaration) =      
  match ty.ptype_manifest with 
  | Some {ptyp_desc = Ptyp_variant(row_fields,Closed,None)}
    when is_enum row_fields ->
    Some row_fields 
  | _ -> None 

let is_enum_constructors 
    (constructors : Parsetree.constructor_declaration list) =   
  List.for_all 
    (fun (x : Parsetree.constructor_declaration) ->
       match x with 
       | {pcd_args = 
 
  Pcstr_tuple [] (* Note the enum is encoded using [Pcstr_tuple []]*)
        
        } -> true 
       | _ -> false 
    )
    constructors
end
module Ast_external_process : sig 
#1 "ast_external_process.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



 type response = {
  pval_type : Parsetree.core_type ; 
  pval_prim : string list ; 
  pval_attributes : Parsetree.attributes;
  no_inline_cross_module : bool 
}

(**
  [handle_attributes_as_string
  loc pval_name.txt pval_type pval_attributes pval_prim]
  [pval_name.txt] is the name of identifier
  [pval_prim] is the name of string literal

  return value is of [pval_type, pval_prims, new_attrs]
*)
val handle_attributes_as_string :
  Bs_loc.t ->
  Ast_core_type.t ->
  Ast_attributes.t ->
  string  ->  
  string  ->
  response




(** [pval_prim_of_labels labels]
    return [pval_prims] for FFI, it is specialized for
    external object which is used in
    {[ [%obj { x = 2; y = 1} ] ]}
*)
val pval_prim_of_labels : string Asttypes.loc list -> string list


val pval_prim_of_option_labels :
  (bool * string Asttypes.loc) list ->
  bool ->
  string list

end = struct
#1 "ast_external_process.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


[@@@ocaml.warning "+9"]
(* record pattern match complete checker*)

type field = 
  | No_fields
  | Valid_fields
  | Invalid_field

let variant_can_bs_unwrap_fields (row_fields : Parsetree.row_field list) : bool =
  let validity =
    Ext_list.fold_left row_fields No_fields      
      begin fun st row ->
        match st, row with
        | (* we've seen no fields or only valid fields so far *)
          (No_fields | Valid_fields),
          (* and this field has one constructor arg that we can unwrap to *)
          Rtag (label, attrs, false, ([ _ ]))
          ->
          Valid_fields
        | (* otherwise, this field or a previous field was invalid *)
          _ ->
          Invalid_field
      end
  in
  validity = Valid_fields 

(*
  TODO: [nolabel] is only used once turn Nothing into Unit, refactor later
*)
let spec_of_ptyp 
    (nolabel : bool) (ptyp : Parsetree.core_type) : External_arg_spec.attr = 
  let ptyp_desc = ptyp.ptyp_desc in
  match Ast_attributes.iter_process_bs_string_int_unwrap_uncurry ptyp.ptyp_attributes with
  | `String ->
    begin match ptyp_desc with
      | Ptyp_variant ( row_fields, Closed, None)
        ->
        Ast_polyvar.map_row_fields_into_strings ptyp.ptyp_loc row_fields
      | _ ->
        Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_string_type
    end
  | `Ignore ->
    Ignore
  | `Int ->
    begin match ptyp_desc with
      | Ptyp_variant ( row_fields, Closed, None) ->
        let int_lists =
          Ast_polyvar.map_row_fields_into_ints ptyp.ptyp_loc row_fields in
        Int int_lists
      | _ -> Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_int_type
    end
  | `Unwrap ->
    begin match ptyp_desc with
      | Ptyp_variant (row_fields, Closed, _)
        when variant_can_bs_unwrap_fields row_fields ->
        Unwrap
      | _ ->
        Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_unwrap_type
    end
  | `Uncurry opt_arity ->
    let real_arity =  Ast_core_type.get_uncurry_arity ptyp in
    (begin match opt_arity, real_arity with
       | Some arity, `Not_function ->
         Fn_uncurry_arity arity
       | None, `Not_function  ->
         Bs_syntaxerr.err ptyp.ptyp_loc Canot_infer_arity_by_syntax
       | None, `Arity arity  ->
         Fn_uncurry_arity arity
       | Some arity, `Arity n ->
         if n <> arity then
           Bs_syntaxerr.err ptyp.ptyp_loc (Inconsistent_arity (arity,n))
         else Fn_uncurry_arity arity
     end)
  | `Nothing ->
    begin match ptyp_desc with
      | Ptyp_constr ({txt = Lident "unit"; _}, [])
        -> if nolabel then Extern_unit else  Nothing
      | Ptyp_variant _ ->
        Bs_warnings.prerr_bs_ffi_warning ptyp.ptyp_loc Unsafe_poly_variant_type;
        Nothing
      | _ ->
        Nothing
    end
(* is_optional = false 
*)
let refine_arg_type ~(nolabel:bool) (ptyp : Ast_core_type.t) 
  : Ast_core_type.t * External_arg_spec.attr = 
  if Ast_core_type.is_any ptyp then (* (_[@bs.as ])*)
    let ptyp_attrs = ptyp.ptyp_attributes in
    let result = Ast_attributes.iter_process_bs_string_or_int_as ptyp_attrs in
    (* when ppx start dropping attributes
       we should warn, there is a trade off whether
       we should warn dropped non bs attribute or not
    *)
    Bs_ast_invariant.warn_discarded_unused_attributes ptyp_attrs;
    match result with
    |  None ->
      Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external
    | Some (`Int i) ->
      Ast_literal.type_int ~loc:ptyp.ptyp_loc (), Arg_cst(External_arg_spec.cst_int i)
    | Some (`Str i)->
      Ast_literal.type_string ~loc:ptyp.ptyp_loc (), Arg_cst (External_arg_spec.cst_string i)
    | Some (`Json_str s) ->
      Ast_literal.type_string ~loc:ptyp.ptyp_loc (), Arg_cst (External_arg_spec.cst_json ptyp.ptyp_loc s)
  else (* ([`a|`b] [@bs.string]) *)
    ptyp, spec_of_ptyp nolabel ptyp   

let get_basic_type_from_option_label (ptyp_arg : Ast_core_type.t) =     
    
      ptyp_arg 
      
  
(** Given the type of argument, process its [bs.] attribute and new type,
    The new type is currently used to reconstruct the external type
    and result type in [@@bs.obj]
    They are not the same though, for example
    {[
      external f : hi:([ `hi | `lo ] [@bs.string]) -> unit -> _ = "" [@@bs.obj]
    ]}
    The result type would be [ hi:string ]
*)
let get_opt_arg_type
    ~(nolabel : bool)
    (ptyp_arg : Ast_core_type.t) :
  External_arg_spec.attr  =
  let ptyp = get_basic_type_from_option_label ptyp_arg in 
  if Ast_core_type.is_any ptyp then (* (_[@bs.as ])*)
    (* extenral f : ?x:_ -> y:int -> _ = "" [@@bs.obj] is not allowed *)
    Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external;
  (* ([`a|`b] [@bs.string]) *)    
  spec_of_ptyp nolabel ptyp



(**
   [@@bs.module "react"]
   [@@bs.module "react"]
   ---
   [@@bs.module "@" "react"]
   [@@bs.module "@" "react"]

   They should have the same module name

   TODO: we should emit an warning if we bind
   two external files to the same module name
*)
type bundle_source =
  [`Nm_payload of string (* from payload [@@bs.val "xx" ]*)
  |`Nm_external of string (* from "" in external *)
  | `Nm_val of string lazy_t   (* from function name *)
  ]

let string_of_bundle_source (x : bundle_source) =
  match x with
  | `Nm_payload x
  | `Nm_external x
  | `Nm_val lazy x -> x


type name_source =
  [ bundle_source
  | `Nm_na

  ]




type external_desc =
  { val_name : name_source;
    external_module_name : External_ffi_types.external_module_name option;
    module_as_val : External_ffi_types.external_module_name option;
    val_send : name_source ;
    val_send_pipe : Ast_core_type.t option;
    splice : bool ; (* mutable *)
    scopes : string list ;
    set_index : bool; (* mutable *)
    get_index : bool;
    new_name : name_source ;
    call_name : name_source ;
    set_name : name_source ;
    get_name : name_source ;

    mk_obj : bool ;
    return_wrapper : External_ffi_types.return_wrapper ;

  }

let init_st =
  {
    val_name = `Nm_na;
    external_module_name = None ;
    module_as_val = None;
    val_send = `Nm_na;
    val_send_pipe = None;
    splice = false;
    scopes = [];
    set_index = false;
    get_index = false;
    new_name = `Nm_na;
    call_name = `Nm_na;
    set_name = `Nm_na ;
    get_name = `Nm_na ;
    mk_obj = false ;
    return_wrapper = Return_unset;

  }


let return_wrapper loc (txt : string) : External_ffi_types.return_wrapper =
  match txt with
  | "undefined_to_opt" -> Return_undefined_to_opt
  | "null_to_opt" -> Return_null_to_opt
  | "nullable"
  | "null_undefined_to_opt" -> Return_null_undefined_to_opt
  | "identity" -> Return_identity
  | _ ->
    Bs_syntaxerr.err loc Not_supported_directive_in_bs_return


(* The processed attributes will be dropped *)
let parse_external_attributes
    (no_arguments : bool)   
    (prim_name_check : string)
    (prim_name_or_pval_prim: bundle_source )
    (prim_attributes : Ast_attributes.t) : Ast_attributes.t * external_desc =

  (* shared by `[@@bs.val]`, `[@@bs.send]`,
     `[@@bs.set]`, `[@@bs.get]` , `[@@bs.new]`
     `[@@bs.send.pipe]` does not use it
  *)
  let name_from_payload_or_prim ~loc (payload : Parsetree.payload) : name_source =
    match payload with
    | PStr [] ->
      (prim_name_or_pval_prim :> name_source)
    (* It is okay to have [@@bs.val] without payload *)
    | _ ->
      begin match Ast_payload.is_single_string payload with
        | Some  (val_name, _) ->  `Nm_payload val_name
        | None ->
          Location.raise_errorf ~loc "Invalid payload"
      end

  in
  Ext_list.fold_left prim_attributes ([], init_st) 
    (fun (attrs, st) (({txt ; loc}, payload) as attr )
      ->
        if txt = Literals.gentype_import then 
          let bundle = 
              "./" ^ Ext_filename.new_extension
                (Filename.basename !Location.input_name)  ".gen"
            in 
            attr::attrs, 
            {st with external_module_name = Some { bundle; module_bind_name = Phint_nothing}}          
        else if Ext_string.starts_with txt "bs." then
           attrs, begin match txt with
            | "bs.val" ->
              if no_arguments then
                {st with val_name = name_from_payload_or_prim ~loc payload}
              else
                {st with call_name = name_from_payload_or_prim ~loc payload}

            | "bs.module" ->
              begin match Ast_payload.assert_strings loc payload with
                | [bundle] ->
                  {st with external_module_name =
                             Some {bundle; module_bind_name = Phint_nothing}}
                | [bundle;bind_name] ->
                  {st with external_module_name =
                             Some {bundle; module_bind_name = Phint_name bind_name}}
                | [] ->
                  { st with
                    module_as_val =
                      Some
                        { bundle =
                            string_of_bundle_source
                              (prim_name_or_pval_prim :> bundle_source) ;
                          module_bind_name = Phint_nothing}
                  }
                | _  ->
                  Bs_syntaxerr.err loc Illegal_attribute
              end
            | "bs.scope" ->
              begin match Ast_payload.assert_strings loc payload with
                | [] ->
                  Bs_syntaxerr.err loc Illegal_attribute
                (* We need err on empty scope, so we can tell the difference
                   between unset/set
                *)
                | scopes ->  { st with scopes = scopes }
              end
            | "bs.splice" | "bs.variadic" -> {st with splice = true}
            | "bs.send" ->
              { st with val_send = name_from_payload_or_prim ~loc payload}
            | "bs.send.pipe"
              ->
              { st with val_send_pipe = Some (Ast_payload.as_core_type loc payload)}
            | "bs.set" ->
              {st with set_name = name_from_payload_or_prim ~loc  payload}
            | "bs.get" -> {st with get_name = name_from_payload_or_prim ~loc payload}

            | "bs.new" -> {st with new_name = name_from_payload_or_prim ~loc payload}
            | "bs.set_index" -> 
              if String.length prim_name_check <> 0 then 
                Location.raise_errorf ~loc "[@@bs.set_index] expect external names to be empty string";
              {st with set_index = true}
            | "bs.get_index"->               
              if String.length prim_name_check <> 0 then
                Location.raise_errorf ~loc "[@@bs.get_index] expect external names to be empty string";
              {st with get_index = true}
            | "bs.obj" -> {st with mk_obj = true}
            | "bs.return" ->
              let actions =
                Ast_payload.ident_or_record_as_config loc payload in
              begin match actions with
                | [ ({txt; _ },None) ] ->
                  { st with return_wrapper = return_wrapper loc txt}
                | _ ->
                  Bs_syntaxerr.err loc Not_supported_directive_in_bs_return
              end
            | _ -> (Location.prerr_warning loc (Bs_unused_attribute txt); st)
          end
        else attr :: attrs, st
    )
    


let rec has_bs_uncurry (attrs : Ast_attributes.t) = 
  Ext_list.exists_fst attrs (fun x -> x.txt = "bs.uncurry")


let check_return_wrapper
    loc (wrapper : External_ffi_types.return_wrapper)
    result_type =
  match wrapper with
  | Return_identity -> wrapper
  | Return_unset  ->
    if Ast_core_type.is_unit result_type then
      Return_replaced_with_unit
    else
      wrapper
  | Return_undefined_to_opt
  | Return_null_to_opt
  | Return_null_undefined_to_opt
    ->
    if Ast_core_type.is_user_option result_type then
      wrapper
    else
      Bs_syntaxerr.err loc Expect_opt_in_bs_return_to_opt
  | Return_replaced_with_unit ->
    assert false (* Not going to happen from user input*)



type response = {
  pval_type : Parsetree.core_type ; 
  pval_prim : string list ; 
  pval_attributes : Parsetree.attributes;
  no_inline_cross_module : bool 
}



let process_obj 
    (loc : Location.t)
    (st : external_desc) 
    (prim_name : string)   
    (arg_types_ty : Ast_compatible.param_type list)
    (result_type : Ast_core_type.t)
  : Parsetree.core_type *  External_ffi_types.t 
  = 
  match st with
  | {
    val_name = `Nm_na;
    external_module_name = None ;
    module_as_val = None;
    val_send = `Nm_na;
    val_send_pipe = None;
    splice = false;
    new_name = `Nm_na;
    call_name = `Nm_na;
    set_name = `Nm_na ;
    get_name = `Nm_na ;
    get_index = false ;
    return_wrapper = Return_unset ;
    set_index = false ;
    mk_obj = _;
    scopes = [];
    (* wrapper does not work with [bs.obj]
       TODO: better error message *)
  } ->
    if String.length prim_name <> 0 then
      Location.raise_errorf ~loc "[@@bs.obj] expect external names to be empty string";
    let arg_kinds, new_arg_types_ty, result_types =
      Ext_list.fold_right arg_types_ty ( [], [], [])
        (fun param_type ( arg_labels, (arg_types : Ast_compatible.param_type list), result_types) ->
           let arg_label = Ast_compatible.convert param_type.label in
           let ty  = param_type.ty in 
           let new_arg_label, new_arg_types,  output_tys =
             match arg_label with
             | Nolabel ->
               let new_ty, arg_type = refine_arg_type ~nolabel:true  ty in
               if arg_type = Extern_unit then
                 External_arg_spec.empty_kind arg_type, 
                 {param_type with ty = new_ty}::arg_types, result_types
               else
                 Location.raise_errorf ~loc "expect label, optional, or unit here"
             | Labelled name ->
               let new_ty, arg_type = refine_arg_type ~nolabel:false  ty in
               begin match arg_type with
                 | Ignore ->
                   External_arg_spec.empty_kind arg_type,
                   {param_type with ty = new_ty}::arg_types, result_types
                 | Arg_cst  i  ->
                   let s = Lam_methname.translate ~loc name in
                   {arg_label = External_arg_spec.label s (Some i);
                    arg_type },
                   arg_types, (* ignored in [arg_types], reserved in [result_types] *)
                   ((name , [], new_ty) :: result_types)
                 | Nothing  ->
                   let s = (Lam_methname.translate ~loc name) in
                   {arg_label = External_arg_spec.label s None ; arg_type },
                   {param_type with ty = new_ty}::arg_types,
                   ((name , [], new_ty) :: result_types)
                 | Int _  ->
                   let s = Lam_methname.translate ~loc name in
                   {arg_label = External_arg_spec.label s None; arg_type},
                   {param_type with ty = new_ty}::arg_types,
                   ((name, [], Ast_literal.type_int ~loc ()) :: result_types)
                 | NullString _ ->
                   let s = Lam_methname.translate ~loc name in
                   {arg_label = External_arg_spec.label s None; arg_type},
                   {param_type with ty = new_ty }::arg_types,
                   ((name, [], Ast_literal.type_string ~loc ()) :: result_types)
                 | Fn_uncurry_arity _ ->
                   Location.raise_errorf ~loc
                     "The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
                 | Extern_unit -> assert false
                 | NonNullString _
                   ->
                   Location.raise_errorf ~loc
                     "bs.obj label %s does not support such arg type" name
                 | Unwrap ->
                   Location.raise_errorf ~loc
                     "bs.obj label %s does not support [@bs.unwrap] arguments" name
               end
             | Optional name ->
               let arg_type = get_opt_arg_type ~nolabel:false  ty in
               begin match arg_type with
                 | Ignore ->
                   External_arg_spec.empty_kind arg_type,
                   param_type::arg_types, result_types
                 | Nothing ->
                   let s = (Lam_methname.translate ~loc name) in
                   {arg_label = External_arg_spec.optional s; arg_type},
                   param_type :: arg_types,
                   ( (name, [], Ast_comb.to_undefined_type loc (get_basic_type_from_option_label ty)) ::  result_types)
                 | Int _  ->
                   let s = Lam_methname.translate ~loc name in
                   {arg_label = External_arg_spec.optional s ; arg_type },
                   param_type :: arg_types,
                   ((name, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_int ~loc ()) :: result_types)
                 | NullString _  ->
                   let s = Lam_methname.translate ~loc name in
                   {arg_label = External_arg_spec.optional s ; arg_type },
                   param_type::arg_types,
                   ((name, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_string ~loc ()) :: result_types)
                 | Arg_cst _
                   ->
                   Location.raise_errorf ~loc "bs.as is not supported with optional yet"
                 | Fn_uncurry_arity _ ->
                   Location.raise_errorf ~loc
                     "The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
                 | Extern_unit   -> assert false
                 | NonNullString _
                   ->
                   Location.raise_errorf ~loc
                     "bs.obj label %s does not support such arg type" name
                 | Unwrap ->
                   Location.raise_errorf ~loc
                     "bs.obj label %s does not support [@bs.unwrap] arguments" name
               end
           in
           new_arg_label::arg_labels,
           new_arg_types,
           output_tys) in

    let result =
      if Ast_core_type.is_any  result_type then
        Ast_core_type.make_obj ~loc result_types
      else
        fst (refine_arg_type ~nolabel:true result_type) 
        (* result type can not be labeled *)
    in
    Ast_compatible.mk_fn_type new_arg_types_ty result,
    External_ffi_types.Ffi_obj_create arg_kinds
  | _ -> Location.raise_errorf ~loc "Attribute found that conflicts with [@@bs.obj]"


let external_desc_of_non_obj 
    (loc : Location.t) 
    (st : external_desc) 
    (prim_name_or_pval_prim : bundle_source)
    (arg_type_specs_length : int) 
    arg_types_ty 
    (arg_type_specs : External_arg_spec.t list) : External_ffi_types.external_spec =
  match st with
  | {set_index = true;
     val_name = `Nm_na;
     external_module_name = None ;
     module_as_val = None;
     val_send = `Nm_na;
     val_send_pipe = None;
     splice = false;
     scopes ;
     get_index = false;
     new_name = `Nm_na;
     call_name = `Nm_na;
     set_name = `Nm_na ;
     get_name = `Nm_na ;

     return_wrapper = _;
     mk_obj = _ ;

    }
    ->
    if arg_type_specs_length = 3 then
      Js_set_index {js_set_index_scopes = scopes}
    else
      Location.raise_errorf ~loc "Ill defined attribute [@@bs.set_index](arity of 3)"
  | {set_index = true; _} ->
    Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.set_index]")
  | {get_index = true;
     val_name = `Nm_na;
     external_module_name = None ;
     module_as_val = None;
     val_send = `Nm_na;
     val_send_pipe = None;

     splice = false;
     scopes ;
     new_name = `Nm_na;
     call_name = `Nm_na;
     set_name = `Nm_na ;
     get_name = `Nm_na ;
     set_index = false;
     mk_obj;
     return_wrapper ;
    } ->
    if arg_type_specs_length = 2 then
      Js_get_index {js_get_index_scopes = scopes}
    else Location.raise_errorf ~loc
        "Ill defined attribute [@@bs.get_index] (arity expected 2 : while %d)" arg_type_specs_length

  | {get_index = true; _} ->
    Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.get_index]")
  | {module_as_val = Some external_module_name ;

     get_index = false;
     val_name ;
     new_name ;

     external_module_name = None ;
     val_send = `Nm_na;
     val_send_pipe = None;
     scopes = []; (* module as var does not need scopes *)
     splice;
     call_name = `Nm_na;
     set_name = `Nm_na ;
     get_name = `Nm_na ;
     set_index = false;
     return_wrapper = _;
     mk_obj = _ ;
    } ->
    begin match arg_types_ty, new_name, val_name  with
      | [], `Nm_na,  _ -> Js_module_as_var external_module_name
      | _, `Nm_na, _ -> Js_module_as_fn {splice; external_module_name }
      | _, #bundle_source, #bundle_source ->
        Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.module].")

      | _, (`Nm_val _ | `Nm_external _) , `Nm_na
        -> Js_module_as_class external_module_name
      | _, `Nm_payload _ , `Nm_na
        ->
        Location.raise_errorf ~loc
          "Incorrect FFI attribute found: (bs.new should not carry a payload here)"
    end
  | {module_as_val = Some x; _} ->
    Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.module].")
  | {call_name = (`Nm_val lazy name | `Nm_external name | `Nm_payload name) ;
     splice;
     scopes ;
     external_module_name;

     val_name = `Nm_na ;
     module_as_val = None;
     val_send = `Nm_na ;
     val_send_pipe = None;

     set_index = false;
     get_index = false;
     new_name = `Nm_na;
     set_name = `Nm_na ;
     get_name = `Nm_na ;
     mk_obj = _ ;
     return_wrapper = _ ;
    } ->
    Js_call {splice; name; external_module_name; scopes }
  | {call_name = #bundle_source ; _ }
    ->
    Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.val]")
  | {val_name = (`Nm_val lazy name | `Nm_external name | `Nm_payload name);
     external_module_name;

     call_name = `Nm_na ;
     module_as_val = None;
     val_send = `Nm_na ;
     val_send_pipe = None;
     set_index = false;
     get_index = false;
     new_name = `Nm_na;
     set_name = `Nm_na ;
     get_name = `Nm_na;
     mk_obj = _;
     return_wrapper = _;
     splice = false ;
     scopes ;
    }
    -> (* 
    if no_arguments -->
          {[
            external ff : int = "" [@@bs.val]
          ]}
       *)
    Js_var { name; external_module_name; scopes}
  | {val_name = #bundle_source ; _ }
    ->
    Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.val]")

  | {splice ;
     scopes ;
     external_module_name = (Some _ as external_module_name);
     val_name = `Nm_na ;
     call_name = `Nm_na ;
     module_as_val = None;
     val_send = `Nm_na ;
     val_send_pipe = None;
     set_index = false;
     get_index = false;
     new_name = `Nm_na;
     set_name = `Nm_na ;
     get_name = `Nm_na ;
     mk_obj = _ ;
     return_wrapper= _ ;
    }
    ->
    let name = string_of_bundle_source prim_name_or_pval_prim in
    if arg_type_specs_length  = 0 then
      (*
         {[
           external ff : int = "" [@@bs.module "xx"]
         ]}
      *)
      Js_var { name; external_module_name; scopes}
    else  Js_call {splice; name; external_module_name; scopes}
  | {val_send = (`Nm_val lazy name | `Nm_external name | `Nm_payload name);
     splice;
     scopes;
     val_send_pipe = None;
     val_name = `Nm_na  ;
     call_name = `Nm_na ;
     module_as_val = None;
     set_index = false;
     get_index = false;
     new_name = `Nm_na;
     set_name = `Nm_na ;
     get_name = `Nm_na ;
     external_module_name = None ;
     mk_obj = _ ;
     return_wrapper = _ ;
    } ->
    (* PR #2162 - since when we assemble arguments the first argument in
       [@@bs.send] is ignored
    *)
    begin match arg_type_specs with
      | [] ->
        Location.raise_errorf
          ~loc "Ill defined attribute [@@bs.send] (the external needs to be a regular function call with at least one argument)"
      |  {arg_type = Arg_cst _ ; arg_label = _} :: _
        ->
        Location.raise_errorf
          ~loc "Ill defined attribute [@@bs.send] (first argument can't be const)"
      | _ :: _  ->
        Js_send {splice ; name; js_send_scopes = scopes ;  pipe = false}
    end
  | {val_send = #bundle_source; _ }
    -> Location.raise_errorf ~loc "You used a FFI attribute that can't be used with [@@bs.send]"
  | {val_send_pipe = Some typ;
     (* splice = (false as splice); *)
     val_send = `Nm_na;
     val_name = `Nm_na  ;
     call_name = `Nm_na ;
     module_as_val = None;
     set_index = false;
     get_index = false;
     new_name = `Nm_na;
     set_name = `Nm_na ;
     get_name = `Nm_na ;
     external_module_name = None ;
     mk_obj = _;
     return_wrapper = _;
     scopes;
     splice ;
    } ->
    (** can be one argument *)
    Js_send {splice  ;
             name = string_of_bundle_source prim_name_or_pval_prim;
             js_send_scopes = scopes;
             pipe = true}

  | {val_send_pipe = Some _ ; _}
    -> Location.raise_errorf ~loc "conflict attributes found with [@@bs.send.pipe]"

  | {new_name = (`Nm_val lazy name | `Nm_external name | `Nm_payload name);
     external_module_name;

     val_name = `Nm_na  ;
     call_name = `Nm_na ;
     module_as_val = None;
     set_index = false;
     get_index = false;
     val_send = `Nm_na ;
     val_send_pipe = None;
     set_name = `Nm_na ;
     get_name = `Nm_na ;
     splice = false;
     scopes;
     mk_obj = _ ;
     return_wrapper = _ ;
    }
    -> Js_new {name; external_module_name;  scopes}
  | {new_name = #bundle_source ; _ } ->
    Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.new]")
  | {set_name = (`Nm_val lazy name | `Nm_external name | `Nm_payload name);
     val_name = `Nm_na  ;
     call_name = `Nm_na ;
     module_as_val = None;
     set_index = false;
     get_index = false;
     val_send = `Nm_na ;
     val_send_pipe = None;
     new_name = `Nm_na ;
     get_name = `Nm_na ;
     external_module_name = None;
     splice = false;
     mk_obj = _ ;
     return_wrapper = _;
     scopes ;
    }
    ->
    if arg_type_specs_length = 2 then
      Js_set { js_set_scopes = scopes ; js_set_name = name}
    else  Location.raise_errorf ~loc "Ill defined attribute [@@bs.set] (two args required)"
  | {set_name = #bundle_source; _}
    -> Location.raise_errorf ~loc "conflict attributes found with [@@bs.set]"
  | {get_name = (`Nm_val lazy name | `Nm_external name | `Nm_payload name);

     val_name = `Nm_na  ;
     call_name = `Nm_na ;
     module_as_val = None;
     set_index = false;
     get_index = false;
     val_send = `Nm_na ;
     val_send_pipe = None;
     new_name = `Nm_na ;
     set_name = `Nm_na ;
     external_module_name = None;
     splice = false ;
     mk_obj = _;
     return_wrapper = _;
     scopes
    }
    ->
    if arg_type_specs_length = 1 then
      Js_get { js_get_name = name; js_get_scopes = scopes }
    else
      Location.raise_errorf ~loc "Ill defined attribute [@@bs.get] (only one argument)"
  | {get_name = #bundle_source; _}
    -> Location.raise_errorf ~loc "Attribute found that conflicts with [@@bs.get]"

  | {get_name = `Nm_na;
     val_name = `Nm_na  ;
     call_name = `Nm_na ;
     module_as_val = None;
     set_index = false;
     get_index = false;
     val_send = `Nm_na ;
     val_send_pipe = None;
     new_name = `Nm_na ;
     set_name = `Nm_na ;
     external_module_name = None;
     splice = _ ;
     scopes = _;
     mk_obj = _;
     return_wrapper = _;

    }
    ->  Location.raise_errorf ~loc "Could not infer which FFI category it belongs to, maybe you forgot [%@%@bs.val]? "  

(** Note that the passed [type_annotation] is already processed by visitor pattern before*)
let handle_attributes
    (loc : Bs_loc.t)
    (type_annotation : Parsetree.core_type)
    (prim_attributes : Ast_attributes.t) 
    (pval_name : string )
    (prim_name : string)
  : Parsetree.core_type *  External_ffi_types.t * Parsetree.attributes * bool
  =
  (** sanity check here
      {[ int -> int -> (int -> int -> int [@bs.uncurry])]}
      It does not make sense
  *)
  if has_bs_uncurry type_annotation.ptyp_attributes then
    Location.raise_errorf
      ~loc "[@@bs.uncurry] can not be applied to the whole definition";
  let prim_name_or_pval_name =
    if String.length prim_name = 0 then  
      `Nm_val (lazy (Location.prerr_warning loc (Bs_fragile_external pval_name); pval_name))
    else  `Nm_external prim_name  (* need check name *) in
  let result_type, arg_types_ty =
    (* Note this assumes external type is syntatic (no abstraction)*)
    Ast_core_type.list_of_arrow type_annotation in
  if has_bs_uncurry result_type.ptyp_attributes then
    Location.raise_errorf
      ~loc:result_type.ptyp_loc
      "[@@bs.uncurry] can not be applied to tailed position";
  let no_arguments = arg_types_ty = [] in  
  let unused_attrs, external_desc =
    parse_external_attributes no_arguments  
      prim_name prim_name_or_pval_name  prim_attributes in
  if external_desc.mk_obj then
    (* warn unused attributes here ? *)
    let new_type, spec = process_obj loc external_desc prim_name arg_types_ty result_type in 
    new_type, spec, unused_attrs, false
  else
    let splice = external_desc.splice in
    let arg_type_specs, new_arg_types_ty, arg_type_specs_length   =
      let init : External_arg_spec.t list * Ast_compatible.param_type list * int  = 
        match external_desc.val_send_pipe with
        | Some obj ->
          let new_ty, arg_type = refine_arg_type ~nolabel:true obj in
          begin match arg_type with
            | Arg_cst _ ->
              Location.raise_errorf ~loc:obj.ptyp_loc "[@bs.as] is not supported in bs.send type "
            | _ ->
              (* more error checking *)
              [External_arg_spec.empty_kind arg_type],
              [{label = Ast_compatible.no_label;
                ty = new_ty;
                attr =  [];
                loc = obj.ptyp_loc} ],
              0           
          end
        | None -> [],[], 0 in 
      Ext_list.fold_right arg_types_ty init
        (fun  param_type (arg_type_specs, arg_types, i) ->
           let arg_label = Ast_compatible.convert param_type.label in
           let ty = param_type.ty in 
           if i = 0 && splice  then
             begin match arg_label with 
               | Optional _ -> 
                 Location.raise_errorf ~loc "[@@@@bs.splice] expect the last type to be a non optional"
               | Labelled _ | Nolabel 
                -> 
                if Ast_core_type.is_any ty then 
                  Location.raise_errorf ~loc "[@@@@bs.splice] expect the last type to be an array";                  
                if spec_of_ptyp true ty <> Nothing then 
                  Location.raise_errorf ~loc "[@@@@bs.splice] expect the last type to be an array";
                match ty.ptyp_desc with 
                | Ptyp_constr({txt = Lident "array"; _}, [_])
                  -> ()
                | _ -> Location.raise_errorf ~loc "[@@@@bs.splice] expect the last type to be an array";
             end ; 
           let arg_label, arg_type, new_arg_types =
             match arg_label with
             | Optional s  ->
               let arg_type = get_opt_arg_type ~nolabel:false ty in
               begin match arg_type with
                 | NonNullString _ ->
                   (* ?x:([`x of int ] [@bs.string]) does not make sense *)
                   Location.raise_errorf
                     ~loc
                     "[@@bs.string] does not work with optional when it has arities in label %s" s
                 | _ ->
                   External_arg_spec.optional s, arg_type,
                   param_type :: arg_types end
             | Labelled s  ->
               begin match refine_arg_type ~nolabel:false ty with
                 | new_ty, (Arg_cst i as arg_type)  ->
                   External_arg_spec.label s (Some i), arg_type, arg_types
                 | new_ty, arg_type ->
                   External_arg_spec.label s None, arg_type, 
                   {param_type with ty = new_ty} :: arg_types
               end
             | Nolabel ->
               begin match refine_arg_type ~nolabel:true ty with
                 | new_ty , (Arg_cst i as arg_type) ->
                   External_arg_spec.empty_lit i , arg_type,  arg_types
                 | new_ty , arg_type ->
                   External_arg_spec.empty_label, arg_type, {param_type with ty = new_ty} :: arg_types
               end
           in
           ({ arg_label  ;
              arg_type
            } :: arg_type_specs,
            new_arg_types,
            if arg_type = Ignore then i
            else i + 1
           )
        )  in
    let ffi : External_ffi_types.external_spec  = 
      external_desc_of_non_obj 
        loc external_desc prim_name_or_pval_name arg_type_specs_length 
        arg_types_ty arg_type_specs in 
    let relative = External_ffi_types.check_ffi ~loc ffi in 
    (* result type can not be labeled *)
    (* currently we don't process attributes of
       return type, in the future we may  *)
    let return_wrapper = check_return_wrapper loc external_desc.return_wrapper result_type in
    Ast_compatible.mk_fn_type new_arg_types_ty result_type,  
    Ffi_bs (arg_type_specs, return_wrapper, ffi),
    unused_attrs,
    relative 



let handle_attributes_as_string
    (pval_loc : Location.t)
    (typ : Ast_core_type.t) 
    (attrs : Ast_attributes.t) 
    (pval_name : string)
    (prim_name : string) 
  : response =
  let pval_type, ffi, pval_attributes, no_inline_cross_module  =
    handle_attributes pval_loc typ attrs pval_name prim_name  in
  { pval_type;
    pval_prim = [prim_name; External_ffi_types.to_string ffi];
    pval_attributes;
    no_inline_cross_module 
  }



let pval_prim_of_labels (labels : string Asttypes.loc list) =
  let arg_kinds =
    Ext_list.fold_right labels ([] : External_arg_spec.t list ) 
      (fun {loc ; txt } arg_kinds
        ->
          let arg_label =
            External_arg_spec.label
              (Lam_methname.translate ~loc txt) None in
          {arg_type = Nothing ;
           arg_label  } :: arg_kinds
      ) in
  let encoding =
    External_ffi_types.to_string (Ffi_obj_create arg_kinds) in
  [""; encoding]

let pval_prim_of_option_labels
    (labels : (bool * string Asttypes.loc) list)
    (ends_with_unit : bool)
  =
  let arg_kinds =
    Ext_list.fold_right labels
      (if ends_with_unit then
         [External_arg_spec.empty_kind Extern_unit]
       else [])
      (fun (is_option,{loc ; txt }) arg_kinds
        ->
          let label_name = Lam_methname.translate ~loc txt in
          let arg_label =
            if is_option then
              External_arg_spec.optional label_name
            else External_arg_spec.label label_name None
          in
          {arg_type = Nothing ;
           arg_label  } :: arg_kinds) in
  let encoding =
    External_ffi_types.to_string (Ffi_obj_create arg_kinds) in
  [""; encoding]


end
module Ast_pat : sig 
#1 "ast_pat.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type t = Parsetree.pattern

val is_unit_cont : yes:'a -> no:'a -> t -> 'a

(** [arity_of_fun pat e] tells the arity of 
    expression [fun pat -> e]*)
val arity_of_fun : t -> Parsetree.expression -> int


val is_single_variable_pattern_conservative : t -> bool

end = struct
#1 "ast_pat.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


type t = Parsetree.pattern


let is_unit_cont ~yes ~no (p : t)  =
  match p  with
  | {ppat_desc = Ppat_construct({txt = Lident "()"}, None)}
    -> yes 
  | _ -> no


(** [arity_of_fun pat e] tells the arity of 
    expression [fun pat -> e]
*)
let arity_of_fun
    (pat : Parsetree.pattern)
    (e : Parsetree.expression) =
  let rec aux (e : Parsetree.expression)  =
    match e.pexp_desc with
    | Pexp_fun (arg_label, _, pat, e) 
      when Ast_compatible.is_arg_label_simple arg_label ->
      1 + aux e       
    | Pexp_fun _
      -> Location.raise_errorf
           ~loc:e.pexp_loc "Label is not allowed in JS object"
    | _ -> 0 in
  is_unit_cont ~yes:0 ~no:1 pat + aux e 


let rec is_single_variable_pattern_conservative  (p : t ) =
  match p.ppat_desc with 
  | Parsetree.Ppat_any 
  | Parsetree.Ppat_var _ -> true 
  | Parsetree.Ppat_alias (p,_) 
  | Parsetree.Ppat_constraint (p, _) -> 
    is_single_variable_pattern_conservative p 
  
  | _ -> false

end
module Bs_ast_mapper : sig 
#1 "bs_ast_mapper.mli"



(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                         Alain Frisch, LexiFi                           *)
(*                                                                        *)
(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** The interface of a -ppx rewriter

  A -ppx rewriter is a program that accepts a serialized abstract syntax
  tree and outputs another, possibly modified, abstract syntax tree.
  This module encapsulates the interface between the compiler and
  the -ppx rewriters, handling such details as the serialization format,
  forwarding of command-line flags, and storing state.

  {!mapper} allows to implement AST rewriting using open recursion.
  A typical mapper would be based on {!default_mapper}, a deep
  identity mapper, and will fall back on it for handling the syntax it
  does not modify. For example:

  {[
open Asttypes
open Parsetree
open Ast_mapper

let test_mapper argv =
  { default_mapper with
    expr = fun mapper expr ->
      match expr with
      | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} ->
        Ast_helper.Exp.constant (Const_int 42)
      | other -> default_mapper.expr mapper other; }

let () =
  register "ppx_test" test_mapper]}

  This -ppx rewriter, which replaces [[%test]] in expressions with
  the constant [42], can be compiled using
  [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml].

  *)

  open Parsetree

  (** {1 A generic Parsetree mapper} *)
  
  type mapper = {
    attribute: mapper -> attribute -> attribute;
    attributes: mapper -> attribute list -> attribute list;
    case: mapper -> case -> case;
    cases: mapper -> case list -> case list;
    class_declaration: mapper -> class_declaration -> class_declaration;
    class_description: mapper -> class_description -> class_description;
    class_expr: mapper -> class_expr -> class_expr;
    class_field: mapper -> class_field -> class_field;
    class_signature: mapper -> class_signature -> class_signature;
    class_structure: mapper -> class_structure -> class_structure;
    class_type: mapper -> class_type -> class_type;
    class_type_declaration: mapper -> class_type_declaration
                            -> class_type_declaration;
    class_type_field: mapper -> class_type_field -> class_type_field;
    constructor_declaration: mapper -> constructor_declaration
                             -> constructor_declaration;
    expr: mapper -> expression -> expression;
    extension: mapper -> extension -> extension;
    extension_constructor: mapper -> extension_constructor
                           -> extension_constructor;
    include_declaration: mapper -> include_declaration -> include_declaration;
    include_description: mapper -> include_description -> include_description;
    label_declaration: mapper -> label_declaration -> label_declaration;
    location: mapper -> Location.t -> Location.t;
    module_binding: mapper -> module_binding -> module_binding;
    module_declaration: mapper -> module_declaration -> module_declaration;
    module_expr: mapper -> module_expr -> module_expr;
    module_type: mapper -> module_type -> module_type;
    module_type_declaration: mapper -> module_type_declaration
                             -> module_type_declaration;
    open_description: mapper -> open_description -> open_description;
    pat: mapper -> pattern -> pattern;
    payload: mapper -> payload -> payload;
    signature: mapper -> signature -> signature;
    signature_item: mapper -> signature_item -> signature_item;
    structure: mapper -> structure -> structure;
    structure_item: mapper -> structure_item -> structure_item;
    typ: mapper -> core_type -> core_type;
    type_declaration: mapper -> type_declaration -> type_declaration;
(* #if true then    *)
    type_declaration_list: mapper -> type_declaration list -> type_declaration list;
(* #end *)
    type_extension: mapper -> type_extension -> type_extension;
    type_kind: mapper -> type_kind -> type_kind;
    value_binding: mapper -> value_binding -> value_binding;
(* #if true then    *)
    value_bindings_rec: mapper -> value_binding list -> value_binding list;  
    value_bindings: mapper -> value_binding list -> value_binding list;
(* #end *)
    value_description: mapper -> value_description -> value_description;
    with_constraint: mapper -> with_constraint -> with_constraint;
  }
  (** A mapper record implements one "method" per syntactic category,
      using an open recursion style: each method takes as its first
      argument the mapper to be applied to children in the syntax
      tree. *)
  
  val default_mapper: mapper
  (** A default mapper, which implements a "deep identity" mapping. *)
  
end = struct
#1 "bs_ast_mapper.ml"


(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                         Alain Frisch, LexiFi                           *)
(*                                                                        *)
(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* A generic Parsetree mapping class *)

(*
[@@@ocaml.warning "+9"]
  (* Ensure that record patterns don't miss any field. *)
*)


open Parsetree
open Ast_helper
open Location

type mapper = {
  attribute: mapper -> attribute -> attribute;
  attributes: mapper -> attribute list -> attribute list;
  case: mapper -> case -> case;
  cases: mapper -> case list -> case list;
  class_declaration: mapper -> class_declaration -> class_declaration;
  class_description: mapper -> class_description -> class_description;
  class_expr: mapper -> class_expr -> class_expr;
  class_field: mapper -> class_field -> class_field;
  class_signature: mapper -> class_signature -> class_signature;
  class_structure: mapper -> class_structure -> class_structure;
  class_type: mapper -> class_type -> class_type;
  class_type_declaration: mapper -> class_type_declaration
                          -> class_type_declaration;
  class_type_field: mapper -> class_type_field -> class_type_field;
  constructor_declaration: mapper -> constructor_declaration
                           -> constructor_declaration;
  expr: mapper -> expression -> expression;
  extension: mapper -> extension -> extension;
  extension_constructor: mapper -> extension_constructor
                         -> extension_constructor;
  include_declaration: mapper -> include_declaration -> include_declaration;
  include_description: mapper -> include_description -> include_description;
  label_declaration: mapper -> label_declaration -> label_declaration;
  location: mapper -> Location.t -> Location.t;
  module_binding: mapper -> module_binding -> module_binding;
  module_declaration: mapper -> module_declaration -> module_declaration;
  module_expr: mapper -> module_expr -> module_expr;
  module_type: mapper -> module_type -> module_type;
  module_type_declaration: mapper -> module_type_declaration
                           -> module_type_declaration;
  open_description: mapper -> open_description -> open_description;
  pat: mapper -> pattern -> pattern;
  payload: mapper -> payload -> payload;
  signature: mapper -> signature -> signature;
  signature_item: mapper -> signature_item -> signature_item;
  structure: mapper -> structure -> structure;
  structure_item: mapper -> structure_item -> structure_item;
  typ: mapper -> core_type -> core_type;
  type_declaration: mapper -> type_declaration -> type_declaration;
(* #if true then    *)
  type_declaration_list: mapper -> type_declaration list -> type_declaration list;
(* #end *)
  type_extension: mapper -> type_extension -> type_extension;
  type_kind: mapper -> type_kind -> type_kind;
  value_binding: mapper -> value_binding -> value_binding;
(* #if true then    *)
  value_bindings_rec: mapper -> value_binding list -> value_binding list; 
  value_bindings: mapper -> value_binding list -> value_binding list;
(* #end *)
  value_description: mapper -> value_description -> value_description;
  with_constraint: mapper -> with_constraint -> with_constraint;
}

let map_fst f (x, y) = (f x, y)
let map_snd f (x, y) = (x, f y)
let map_tuple f1 f2 (x, y) = (f1 x, f2 y)
let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
let map_opt f = function None -> None | Some x -> Some (f x)

let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}

module T = struct
  (* Type expressions for the core language *)

  let row_field sub = function
    | Rtag (l, attrs, b, tl) ->
        Rtag (map_loc sub l, sub.attributes sub attrs,
              b, List.map (sub.typ sub) tl)
    | Rinherit t -> Rinherit (sub.typ sub t)

  let object_field sub = function
    | Otag (l, attrs, t) ->
        Otag (map_loc sub l, sub.attributes sub attrs, sub.typ sub t)
    | Oinherit t -> Oinherit (sub.typ sub t)

  let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
    let open Typ in
    let loc = sub.location sub loc in
    let attrs = sub.attributes sub attrs in
    match desc with
    | Ptyp_any -> any ~loc ~attrs ()
    | Ptyp_var s -> var ~loc ~attrs s
    | Ptyp_arrow (lab, t1, t2) ->
        arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
    | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
    | Ptyp_constr (lid, tl) ->
        constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
    | Ptyp_object (l, o) ->
        object_ ~loc ~attrs (List.map (object_field sub) l) o
    | Ptyp_class (lid, tl) ->
        class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
    | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s
    | Ptyp_variant (rl, b, ll) ->
        variant ~loc ~attrs (List.map (row_field sub) rl) b ll
    | Ptyp_poly (sl, t) -> poly ~loc ~attrs
                             (List.map (map_loc sub) sl) (sub.typ sub t)
    | Ptyp_package (lid, l) ->
        package ~loc ~attrs (map_loc sub lid)
          (List.map (map_tuple (map_loc sub) (sub.typ sub)) l)
    | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x)

  let map_type_declaration sub
      {ptype_name; ptype_params; ptype_cstrs;
       ptype_kind;
       ptype_private;
       ptype_manifest;
       ptype_attributes;
       ptype_loc} =
    Type.mk (map_loc sub ptype_name)
      ~params:(List.map (map_fst (sub.typ sub)) ptype_params)
      ~priv:ptype_private
      ~cstrs:(List.map
                (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub))
                ptype_cstrs)
      ~kind:(sub.type_kind sub ptype_kind)
      ?manifest:(map_opt (sub.typ sub) ptype_manifest)
      ~loc:(sub.location sub ptype_loc)
      ~attrs:(sub.attributes sub ptype_attributes)

(* #if true then *)
  let map_type_declaration_list sub l = List.map (sub.type_declaration sub) l 
(* #end *)
  let map_type_kind sub = function
    | Ptype_abstract -> Ptype_abstract
    | Ptype_variant l ->
        Ptype_variant (List.map (sub.constructor_declaration sub) l)
    | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l)
    | Ptype_open -> Ptype_open

  let map_constructor_arguments sub = function
    | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l)
    | Pcstr_record l ->
        Pcstr_record (List.map (sub.label_declaration sub) l)

  let map_type_extension sub
      {ptyext_path; ptyext_params;
       ptyext_constructors;
       ptyext_private;
       ptyext_attributes} =
    Te.mk
      (map_loc sub ptyext_path)
      (List.map (sub.extension_constructor sub) ptyext_constructors)
      ~params:(List.map (map_fst (sub.typ sub)) ptyext_params)
      ~priv:ptyext_private
      ~attrs:(sub.attributes sub ptyext_attributes)

  let map_extension_constructor_kind sub = function
      Pext_decl(ctl, cto) ->
        Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto)
    | Pext_rebind li ->
        Pext_rebind (map_loc sub li)

  let map_extension_constructor sub
      {pext_name;
       pext_kind;
       pext_loc;
       pext_attributes} =
    Te.constructor
      (map_loc sub pext_name)
      (map_extension_constructor_kind sub pext_kind)
      ~loc:(sub.location sub pext_loc)
      ~attrs:(sub.attributes sub pext_attributes)

end

module CT = struct
  (* Type expressions for the class language *)

  let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} =
    let open Cty in
    let loc = sub.location sub loc in
    let attrs = sub.attributes sub attrs in
    match desc with
    | Pcty_constr (lid, tys) ->
        constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
    | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x)
    | Pcty_arrow (lab, t, ct) ->
        arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct)
    | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x)
    | Pcty_open (ovf, lid, ct) ->
        open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_type sub ct)

  let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
    =
    let open Ctf in
    let loc = sub.location sub loc in
    let attrs = sub.attributes sub attrs in
    match desc with
    | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct)
    | Pctf_val (s, m, v, t) ->
        val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t)
    | Pctf_method (s, p, v, t) ->
        method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t)
    | Pctf_constraint (t1, t2) ->
        constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
    | Pctf_attribute x -> attribute ~loc (sub.attribute sub x)
    | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x)

  let map_signature sub {pcsig_self; pcsig_fields} =
    Csig.mk
      (sub.typ sub pcsig_self)
      (List.map (sub.class_type_field sub) pcsig_fields)
end

module MT = struct
  (* Type expressions for the module language *)

  let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} =
    let open Mty in
    let loc = sub.location sub loc in
    let attrs = sub.attributes sub attrs in
    match desc with
    | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
    | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s)
    | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg)
    | Pmty_functor (s, mt1, mt2) ->
        functor_ ~loc ~attrs (map_loc sub s)
          (Misc.may_map (sub.module_type sub) mt1)
          (sub.module_type sub mt2)
    | Pmty_with (mt, l) ->
        with_ ~loc ~attrs (sub.module_type sub mt)
          (List.map (sub.with_constraint sub) l)
    | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me)
    | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x)

  let map_with_constraint sub = function
    | Pwith_type (lid, d) ->
        Pwith_type (map_loc sub lid, sub.type_declaration sub d)
    | Pwith_module (lid, lid2) ->
        Pwith_module (map_loc sub lid, map_loc sub lid2)
    | Pwith_typesubst (lid, d) ->
        Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d)
    | Pwith_modsubst (s, lid) ->
        Pwith_modsubst (map_loc sub s, map_loc sub lid)

  let map_signature_item sub {psig_desc = desc; psig_loc = loc} =
    let open Sig in
    let loc = sub.location sub loc in
    match desc with
    | Psig_value vd -> value ~loc (sub.value_description sub vd)
    | Psig_type (rf, l) -> 
(* #if false then     
      type_ ~loc rf (List.map (sub.type_declaration sub) l)
#else        *)
      type_ ~loc rf (sub.type_declaration_list sub l)
(* #end *)
    | Psig_typext te -> type_extension ~loc (sub.type_extension sub te)
    | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed)
    | Psig_module x -> module_ ~loc (sub.module_declaration sub x)
    | Psig_recmodule l ->
        rec_module ~loc (List.map (sub.module_declaration sub) l)
    | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
    | Psig_open x -> open_ ~loc (sub.open_description sub x)
    | Psig_include x -> include_ ~loc (sub.include_description sub x)
    | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l)
    | Psig_class_type l ->
        class_type ~loc (List.map (sub.class_type_declaration sub) l)
    | Psig_extension (x, attrs) ->
        extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs)
    | Psig_attribute x -> attribute ~loc (sub.attribute sub x)
end


module M = struct
  (* Value expressions for the module language *)

  let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
    let open Mod in
    let loc = sub.location sub loc in
    let attrs = sub.attributes sub attrs in
    match desc with
    | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x)
    | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str)
    | Pmod_functor (arg, arg_ty, body) ->
        functor_ ~loc ~attrs (map_loc sub arg)
          (Misc.may_map (sub.module_type sub) arg_ty)
          (sub.module_expr sub body)
    | Pmod_apply (m1, m2) ->
        apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2)
    | Pmod_constraint (m, mty) ->
        constraint_ ~loc ~attrs (sub.module_expr sub m)
                    (sub.module_type sub mty)
    | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e)
    | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x)

  let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
    let open Str in
    let loc = sub.location sub loc in
    match desc with
    | Pstr_eval (x, attrs) ->
        eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x)
    | Pstr_value (r, vbs) -> 
(* #if false then     
    value ~loc r (List.map (sub.value_binding sub) vbs)
#else      *)
    value ~loc r 
      ((if r = Recursive then sub.value_bindings_rec else sub.value_bindings) sub vbs)
(* #end *)
    | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd)
    | Pstr_type (rf, l) -> 
(* #if false then    
    type_ ~loc rf (List.map (sub.type_declaration sub) l)
#else     *)
    type_ ~loc rf (sub.type_declaration_list sub l)
(* #end *)
    | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te)
    | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed)
    | Pstr_module x -> module_ ~loc (sub.module_binding sub x)
    | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l)
    | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
    | Pstr_open x -> open_ ~loc (sub.open_description sub x)
    | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l)
    | Pstr_class_type l ->
        class_type ~loc (List.map (sub.class_type_declaration sub) l)
    | Pstr_include x -> include_ ~loc (sub.include_declaration sub x)
    | Pstr_extension (x, attrs) ->
        extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs)
    | Pstr_attribute x -> attribute ~loc (sub.attribute sub x)
end

module E = struct
  (* Value expressions for the core language *)

  let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
    let open Exp in
    let loc = sub.location sub loc in
    let attrs = sub.attributes sub attrs in
    match desc with
    | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
    | Pexp_constant x -> constant ~loc ~attrs x
    | Pexp_let (r, vbs, e) ->
(* #if false then     
        let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
          (sub.expr sub e)
#else           *)
        let_ ~loc ~attrs r 
        ( (if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
          sub vbs
        )
          (sub.expr sub e)
(* #end *)
    | Pexp_fun (lab, def, p, e) ->
        fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p)
          (sub.expr sub e)
    | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel)
    | Pexp_apply (e, l) ->
        apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l)
    | Pexp_match (e, pel) ->
        match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
    | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
    | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el)
    | Pexp_construct (lid, arg) ->
        construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg)
    | Pexp_variant (lab, eo) ->
        variant ~loc ~attrs lab (map_opt (sub.expr sub) eo)
    | Pexp_record (l, eo) ->
        record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l)
          (map_opt (sub.expr sub) eo)
    | Pexp_field (e, lid) ->
        field ~loc ~attrs (sub.expr sub e) (map_loc sub lid)
    | Pexp_setfield (e1, lid, e2) ->
        setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid)
          (sub.expr sub e2)
    | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el)
    | Pexp_ifthenelse (e1, e2, e3) ->
        ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
          (map_opt (sub.expr sub) e3)
    | Pexp_sequence (e1, e2) ->
        sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
    | Pexp_while (e1, e2) ->
        while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
    | Pexp_for (p, e1, e2, d, e3) ->
        for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d
          (sub.expr sub e3)
    | Pexp_coerce (e, t1, t2) ->
        coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1)
          (sub.typ sub t2)
    | Pexp_constraint (e, t) ->
        constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t)
    | Pexp_send (e, s) ->
        send ~loc ~attrs (sub.expr sub e) (map_loc sub s)
    | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid)
    | Pexp_setinstvar (s, e) ->
        setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e)
    | Pexp_override sel ->
        override ~loc ~attrs
          (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel)
    | Pexp_letmodule (s, me, e) ->
        letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me)
          (sub.expr sub e)
    | Pexp_letexception (cd, e) ->
        letexception ~loc ~attrs
          (sub.extension_constructor sub cd)
          (sub.expr sub e)
    | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e)
    | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e)
    | Pexp_poly (e, t) ->
        poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t)
    | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls)
    | Pexp_newtype (s, e) ->
        newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e)
    | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me)
    | Pexp_open (ovf, lid, e) ->
        open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e)
    | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x)
    | Pexp_unreachable -> unreachable ~loc ~attrs ()
end

module P = struct
  (* Patterns *)

  let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} =
    let open Pat in
    let loc = sub.location sub loc in
    let attrs = sub.attributes sub attrs in
    match desc with
    | Ppat_any -> any ~loc ~attrs ()
    | Ppat_var s -> var ~loc ~attrs (map_loc sub s)
    | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s)
    | Ppat_constant c -> constant ~loc ~attrs c
    | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2
    | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl)
    | Ppat_construct (l, p) ->
        construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p)
    | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p)
    | Ppat_record (lpl, cf) ->
        record ~loc ~attrs
               (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf
    | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl)
    | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2)
    | Ppat_constraint (p, t) ->
        constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t)
    | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s)
    | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p)
    | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s)
    | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p)
    | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p)
    | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x)
end

module CE = struct
  (* Value expressions for the class language *)

  let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} =
    let open Cl in
    let loc = sub.location sub loc in
    let attrs = sub.attributes sub attrs in
    match desc with
    | Pcl_constr (lid, tys) ->
        constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
    | Pcl_structure s ->
        structure ~loc ~attrs (sub.class_structure sub s)
    | Pcl_fun (lab, e, p, ce) ->
        fun_ ~loc ~attrs lab
          (map_opt (sub.expr sub) e)
          (sub.pat sub p)
          (sub.class_expr sub ce)
    | Pcl_apply (ce, l) ->
        apply ~loc ~attrs (sub.class_expr sub ce)
          (List.map (map_snd (sub.expr sub)) l)
    | Pcl_let (r, vbs, ce) ->
(* #if false then 
        let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
          (sub.class_expr sub ce)
#else *)
        let_ ~loc ~attrs r           
        ((if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
          sub vbs
        )
          (sub.class_expr sub ce)
(* #end           *)
    | Pcl_constraint (ce, ct) ->
        constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct)
    | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x)
    | Pcl_open (ovf, lid, ce) ->
        open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_expr sub ce)

  let map_kind sub = function
    | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e)
    | Cfk_virtual t -> Cfk_virtual (sub.typ sub t)

  let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
    let open Cf in
    let loc = sub.location sub loc in
    let attrs = sub.attributes sub attrs in
    match desc with
    | Pcf_inherit (o, ce, s) ->
        inherit_ ~loc ~attrs o (sub.class_expr sub ce)
          (map_opt (map_loc sub) s)
    | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k)
    | Pcf_method (s, p, k) ->
        method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k)
    | Pcf_constraint (t1, t2) ->
        constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
    | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e)
    | Pcf_attribute x -> attribute ~loc (sub.attribute sub x)
    | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x)

  let map_structure sub {pcstr_self; pcstr_fields} =
    {
      pcstr_self = sub.pat sub pcstr_self;
      pcstr_fields = List.map (sub.class_field sub) pcstr_fields;
    }

  let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr;
                         pci_loc; pci_attributes} =
    Ci.mk
     ~virt:pci_virt
     ~params:(List.map (map_fst (sub.typ sub)) pl)
      (map_loc sub pci_name)
      (f pci_expr)
      ~loc:(sub.location sub pci_loc)
      ~attrs:(sub.attributes sub pci_attributes)
end

(* Now, a generic AST mapper, to be extended to cover all kinds and
   cases of the OCaml grammar.  The default behavior of the mapper is
   the identity. *)

let default_mapper =
  {
    structure = (fun this l -> List.map (this.structure_item this) l);
    structure_item = M.map_structure_item;
    module_expr = M.map;
    signature = (fun this l -> List.map (this.signature_item this) l);
    signature_item = MT.map_signature_item;
    module_type = MT.map;
    with_constraint = MT.map_with_constraint;
    class_declaration =
      (fun this -> CE.class_infos this (this.class_expr this));
    class_expr = CE.map;
    class_field = CE.map_field;
    class_structure = CE.map_structure;
    class_type = CT.map;
    class_type_field = CT.map_field;
    class_signature = CT.map_signature;
    class_type_declaration =
      (fun this -> CE.class_infos this (this.class_type this));
    class_description =
      (fun this -> CE.class_infos this (this.class_type this));
    type_declaration = T.map_type_declaration;
(* #if true then      *)
    type_declaration_list = T.map_type_declaration_list;
(* #end *)
    type_kind = T.map_type_kind;
    typ = T.map;
    type_extension = T.map_type_extension;
    extension_constructor = T.map_extension_constructor;
    value_description =
      (fun this {pval_name; pval_type; pval_prim; pval_loc;
                 pval_attributes} ->
        Val.mk
          (map_loc this pval_name)
          (this.typ this pval_type)
          ~attrs:(this.attributes this pval_attributes)
          ~loc:(this.location this pval_loc)
          ~prim:pval_prim
      );

    pat = P.map;
    expr = E.map;

    module_declaration =
      (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} ->
         Md.mk
           (map_loc this pmd_name)
           (this.module_type this pmd_type)
           ~attrs:(this.attributes this pmd_attributes)
           ~loc:(this.location this pmd_loc)
      );

    module_type_declaration =
      (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} ->
         Mtd.mk
           (map_loc this pmtd_name)
           ?typ:(map_opt (this.module_type this) pmtd_type)
           ~attrs:(this.attributes this pmtd_attributes)
           ~loc:(this.location this pmtd_loc)
      );

    module_binding =
      (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} ->
         Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr)
           ~attrs:(this.attributes this pmb_attributes)
           ~loc:(this.location this pmb_loc)
      );


    open_description =
      (fun this {popen_lid; popen_override; popen_attributes; popen_loc} ->
         Opn.mk (map_loc this popen_lid)
           ~override:popen_override
           ~loc:(this.location this popen_loc)
           ~attrs:(this.attributes this popen_attributes)
      );


    include_description =
      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
         Incl.mk (this.module_type this pincl_mod)
           ~loc:(this.location this pincl_loc)
           ~attrs:(this.attributes this pincl_attributes)
      );

    include_declaration =
      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
         Incl.mk (this.module_expr this pincl_mod)
           ~loc:(this.location this pincl_loc)
           ~attrs:(this.attributes this pincl_attributes)
      );


    value_binding =
      (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} ->
         Vb.mk
           (this.pat this pvb_pat)
           (this.expr this pvb_expr)
           ~loc:(this.location this pvb_loc)
           ~attrs:(this.attributes this pvb_attributes)
      );

(* #if true then  *)
    value_bindings = (fun this vbs -> 
      match vbs with 
      | [vb] -> [this.value_binding this vb]
      | _ -> List.map (this.value_binding this) vbs
    );

    value_bindings_rec = (fun this vbs -> 
      match vbs with 
      | [vb] -> [this.value_binding this vb]
      | _ -> List.map (this.value_binding this) vbs
    );
(* #end *)
    constructor_declaration =
      (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} ->
        Type.constructor
          (map_loc this pcd_name)
          ~args:(T.map_constructor_arguments this pcd_args)
          ?res:(map_opt (this.typ this) pcd_res)
          ~loc:(this.location this pcd_loc)
          ~attrs:(this.attributes this pcd_attributes)
      );

    label_declaration =
      (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} ->
         Type.field
           (map_loc this pld_name)
           (this.typ this pld_type)
           ~mut:pld_mutable
           ~loc:(this.location this pld_loc)
           ~attrs:(this.attributes this pld_attributes)
      );

    cases = (fun this l -> List.map (this.case this) l);
    case =
      (fun this {pc_lhs; pc_guard; pc_rhs} ->
         {
           pc_lhs = this.pat this pc_lhs;
           pc_guard = map_opt (this.expr this) pc_guard;
           pc_rhs = this.expr this pc_rhs;
         }
      );



    location = (fun _this l -> l);

    extension = (fun this (s, e) -> (map_loc this s, this.payload this e));
    attribute = (fun this (s, e) -> (map_loc this s, this.payload this e));
    attributes = (fun this l -> List.map (this.attribute this) l);
    payload =
      (fun this -> function
         | PStr x -> PStr (this.structure this x)
         | PSig x -> PSig (this.signature this x)
         | PTyp x -> PTyp (this.typ this x)
         | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)
      );
  }

end
module Ast_util : sig 
#1 "ast_util.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



type loc = Location.t 
type label_exprs = (Longident.t Asttypes.loc * Parsetree.expression) list
type 'a cxt = loc -> Bs_ast_mapper.mapper -> 'a

(** In general three kinds of ast generation.
    - convert a curried to type to uncurried 
    - convert a curried fun to uncurried fun
    - convert a uncuried application to normal 
*)
type uncurry_expression_gen = 
  (Parsetree.pattern ->
   Parsetree.expression ->
   Parsetree.expression_desc) cxt
type uncurry_type_gen = 
  (Ast_compatible.arg_label -> (* label for error checking *)
   Parsetree.core_type ->
   Parsetree.core_type  ->
   Parsetree.core_type) cxt

(** TODO: the interface is not reusable, it depends on too much context *)
(** syntax: {[f arg0 arg1 [@bs]]}*)
val uncurry_fn_apply : 
  (Parsetree.expression ->
   Parsetree.expression list ->
   Parsetree.expression_desc ) cxt 

(** syntax : {[f## arg0 arg1 ]}*)
val method_apply : 
  (Parsetree.expression ->
  string ->
  Parsetree.expression list ->
  Parsetree.expression_desc) cxt 

(** syntax {[f#@ arg0 arg1 ]}*)
val property_apply : 
  (Parsetree.expression ->
   string ->
   Parsetree.expression list ->
   Parsetree.expression_desc) cxt 


(** 
    [function] can only take one argument, that is the reason we did not adopt it
    syntax:
    {[ fun [@bs] pat pat1-> body ]}
    [to_uncurry_fn (fun pat -> (fun pat1 -> ...  body))]

*)
val to_uncurry_fn : uncurry_expression_gen


(** syntax: 
    {[fun [@bs.this] obj pat pat1 -> body]}    
*)
val to_method_callback : uncurry_expression_gen


(** syntax : 
    {[ int -> int -> int [@bs]]}
*)
val to_uncurry_type : uncurry_type_gen
  

(** syntax
    {[ method : int -> itn -> int ]}
*)
val to_method_type : uncurry_type_gen

(** syntax:
    {[ 'obj -> int -> int [@bs.this] ]}
*)
val to_method_callback_type : uncurry_type_gen





val record_as_js_object : 
  (label_exprs ->
   Parsetree.expression_desc) cxt 

val js_property : 
  loc ->
  Parsetree.expression -> string -> Parsetree.expression_desc

val handle_debugger : 
  loc -> Ast_payload.t -> Parsetree.expression_desc

val handle_raw : 
  check_js_regex: bool -> loc -> Ast_payload.t -> Parsetree.expression

val handle_external :
  loc -> string -> Parsetree.expression 
  
val handle_raw_structure : 
  loc -> Ast_payload.t -> Parsetree.structure_item

val ocaml_obj_as_js_object :
  (Parsetree.pattern ->
   Parsetree.class_field list ->
   Parsetree.expression_desc) cxt   

end = struct
#1 "ast_util.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

open Ast_helper 
type 'a cxt = Ast_helper.loc -> Bs_ast_mapper.mapper -> 'a
type loc = Location.t 

type label_exprs = (Longident.t Asttypes.loc * Parsetree.expression) list
type uncurry_expression_gen = 
  (Parsetree.pattern ->
   Parsetree.expression ->
   Parsetree.expression_desc) cxt
type uncurry_type_gen = 
  (Ast_compatible.arg_label ->
   Parsetree.core_type ->
   Parsetree.core_type  ->
   Parsetree.core_type) cxt

let uncurry_type_id = 
  Ast_literal.Lid.js_fn
 
let method_id  = 
  Ast_literal.Lid.js_meth

let method_call_back_id  = 
  Ast_literal.Lid.js_meth_callback

let arity_lit = "Arity_"

let mk_args loc (n : int) (tys : Parsetree.core_type list) : Parsetree.core_type = 
  Typ.variant ~loc 
    [ Rtag (

      {loc; txt = arity_lit ^ string_of_int n}
      
      ,
       [], (n = 0),  tys)] Closed None

let generic_lift txt loc args result  = 
  let xs =
    match args with 
    | [ ] -> [mk_args loc 0   [] ; result ]
    | [ x ] -> [ mk_args loc 1 [x] ; result ] 
    | _ -> 
      [mk_args loc (List.length args ) [Typ.tuple ~loc args] ; result ]
  in 
  Typ.constr ~loc {txt ; loc} xs

let lift_curry_type  loc   = 
  generic_lift   uncurry_type_id loc

let lift_method_type loc  = 
  generic_lift  method_id loc

let lift_js_method_callback loc
  = 
  generic_lift method_call_back_id loc 
(** Note that currently there is no way to consume [Js.meth_callback]
    so it is fine to encode it with a freedom, 
    but we need make it better for error message.
    - all are encoded as 
    {[ 
      type fn =  (`Args_n of _ , 'result ) Js.fn
      type method = (`Args_n of _, 'result) Js.method
      type method_callback = (`Args_n of _, 'result) Js.method_callback
    ]}
    For [method_callback], the arity is never zero, so both [method] 
    and  [fn] requires (unit -> 'a) to encode arity zero
*)



let arrow = Ast_compatible.arrow


let js_property loc obj (name : string) =
  Parsetree.Pexp_send
    ((Ast_compatible.app1 ~loc
        (Exp.ident ~loc
           {loc;
            txt = Ldot (Ast_literal.Lid.js_internal, Literals.unsafe_downgrade)})
        obj), 

        {loc; txt = name}

        )

(* TODO: 
   have a final checking for property arities 
     [#=], 
*)

(*         
  if not (Ast_compatible.is_arg_label_simple label) then
    Bs_syntaxerr.err loc Label_in_uncurried_bs_attribute;
*)
let generic_apply  kind loc 
    (self : Bs_ast_mapper.mapper) 
    (obj : Parsetree.expression) 
    (args : Parsetree.expression list) cb   =
  let obj = self.expr self obj in
  let args =
    Ext_list.map args (fun e -> self.expr self e) in
  let len = List.length args in 
  let arity, fn, args  = 
    match args with 
    | [ {pexp_desc =
           Pexp_construct ({txt = Lident "()"}, None)}]
      -> 
      0, cb loc obj, []
    | _ -> 
      len,  cb loc obj, args in
  if arity < 10 then 
    let txt = 
      match kind with 
      | `Fn | `PropertyFn ->  
        Longident.Ldot (Ast_literal.Lid.js_internal, 
                        Literals.fn_run ^ string_of_int arity)
      | `Method -> 
        Longident.Ldot(Ast_literal.Lid.js_internal,
                       Literals.method_run ^ string_of_int arity
                      ) in 
    Parsetree.Pexp_apply (Exp.ident {txt ; loc}, (Ast_compatible.no_label,fn) :: Ext_list.map args (fun x -> Ast_compatible.no_label,x))
  else 
    let fn_type, args_type, result_type = Ast_comb.tuple_type_pair ~loc `Run arity  in 
    let string_arity = string_of_int arity in
    let pval_prim, pval_type = 
      match kind with 
      | `Fn | `PropertyFn -> 
        ["#fn_run"; string_arity], 
        arrow ~loc  (lift_curry_type loc args_type result_type ) fn_type
      | `Method -> 
        ["#method_run" ; string_arity], 
        arrow ~loc  (lift_method_type loc args_type result_type) fn_type
    in
    Ast_external_mk.local_external_apply loc ~pval_prim ~pval_type 
      (  fn :: args )


let uncurry_fn_apply loc self fn args = 
  generic_apply `Fn loc self fn args (fun _ obj -> obj )

let property_apply loc self obj name args  
  =  generic_apply `PropertyFn loc self obj args 
    (fun loc obj -> Exp.mk ~loc (js_property loc obj name))

let method_apply loc self obj name args = 
  generic_apply `Method loc self obj args 
    (fun loc obj -> Exp.mk ~loc (js_property loc obj name))

let generic_to_uncurry_type  kind loc (mapper : Bs_ast_mapper.mapper) label
    (first_arg : Parsetree.core_type) 
    (typ : Parsetree.core_type)  =
  if not (Ast_compatible.is_arg_label_simple label) then
    Bs_syntaxerr.err loc Label_in_uncurried_bs_attribute;

  let rec aux acc (typ : Parsetree.core_type) = 
    (* in general, 
       we should collect [typ] in [int -> typ] before transformation, 
       however: when attributes [bs] and [bs.this] found in typ, 
       we should stop 
    *)
    match Ast_attributes.process_attributes_rev typ.ptyp_attributes with 
    | Nothing, _   -> 
      begin match typ.ptyp_desc with 
        | Ptyp_arrow (label, arg, body)
          -> 
          if not (Ast_compatible.is_arg_label_simple label) then
            Bs_syntaxerr.err typ.ptyp_loc Label_in_uncurried_bs_attribute;
          aux (mapper.typ mapper arg :: acc) body 
        | _ -> mapper.typ mapper typ, acc 
      end
    | _, _ -> mapper.typ mapper typ, acc  
  in 
  let first_arg = mapper.typ mapper first_arg in
  let result, rev_extra_args = aux  [first_arg] typ in 
  let args  = List.rev rev_extra_args in 
  let filter_args args  =  
    match args with 
    | [{Parsetree.ptyp_desc = 
          (Ptyp_constr ({txt = Lident "unit"}, []) 
          )}]
      -> []
    | _ -> args in
  match kind with 
  | `Fn ->
    let args = filter_args args in
    lift_curry_type loc args result 
  | `Method -> 
    let args = filter_args args in
    lift_method_type loc args result 

  | `Method_callback
    -> lift_js_method_callback loc args result 


let to_uncurry_type  = 
  generic_to_uncurry_type `Fn
let to_method_type  =
  generic_to_uncurry_type  `Method
let to_method_callback_type  = 
  generic_to_uncurry_type `Method_callback 

let generic_to_uncurry_exp kind loc (self : Bs_ast_mapper.mapper)  pat body 
  = 
  let rec aux acc (body : Parsetree.expression) = 
    match Ast_attributes.process_attributes_rev body.pexp_attributes with 
    | Nothing, _ -> 
      begin match body.pexp_desc with 
        | Pexp_fun (arg_label,_, arg, body)
          -> 
          if not (Ast_compatible.is_arg_label_simple arg_label)  then
            Bs_syntaxerr.err loc Label_in_uncurried_bs_attribute;
          aux (self.pat self arg :: acc) body 
        | _ -> self.expr self body, acc 
      end 
    | _, _ -> self.expr self body, acc  
  in 
  let first_arg = self.pat self pat in  
  let () = 
    match kind with 
    | `Method_callback -> 
      if not @@ Ast_pat.is_single_variable_pattern_conservative first_arg then
        Bs_syntaxerr.err first_arg.ppat_loc  Bs_this_simple_pattern
    | _ -> ()
  in 

  let result, rev_extra_args = aux [first_arg] body in 
  let body = 
    Ext_list.fold_left rev_extra_args result (fun e p -> Ast_compatible.fun_ ~loc p e )
    in
  let len = List.length rev_extra_args in 
  let arity = 
    match kind with 
    | `Fn  ->
      begin match rev_extra_args with 
        | [ p]
          ->
          Ast_pat.is_unit_cont ~yes:0 ~no:len p           

        | _ -> len 
      end
    | `Method_callback -> len  in 
  if arity < 10  then 
    let txt = 
      match kind with 
      | `Fn -> 
        Longident.Ldot ( Ast_literal.Lid.js_internal, Literals.fn_mk ^ string_of_int arity)
      | `Method_callback -> 
        Longident.Ldot (Ast_literal.Lid.js_internal,  Literals.fn_method ^ string_of_int arity) in
    Parsetree.Pexp_apply (Exp.ident {txt;loc} , [ Ast_compatible.no_label, body])

  else 
    let pval_prim =
      [ (match kind with 
            | `Fn -> "#fn_mk"
            | `Method_callback -> "#fn_method"); 
        string_of_int arity]  in
    let fn_type , args_type, result_type  = Ast_comb.tuple_type_pair ~loc `Make arity  in 
    let pval_type = arrow ~loc  fn_type (
        match kind with 
        | `Fn -> 
          lift_curry_type loc args_type result_type
        | `Method_callback -> 
          lift_js_method_callback loc args_type result_type
      ) in
    Ast_external_mk.local_extern_cont loc ~pval_prim ~pval_type 
      (fun prim -> Ast_compatible.app1 ~loc prim body) 

let to_uncurry_fn   = 
  generic_to_uncurry_exp `Fn
let to_method_callback  = 
  generic_to_uncurry_exp `Method_callback 


let handle_debugger loc (payload : Ast_payload.t) = 
  match payload with 
  | PStr [] -> 
    Parsetree.Pexp_apply
      (Exp.ident {txt = Ldot(Ast_literal.Lid.js_internal, Literals.debugger ); loc}, 
       [ Ast_compatible.no_label, Ast_literal.val_unit ~loc ()])
  | _ ->  
    Location.raise_errorf ~loc "bs.debugger does not accept payload"


let handle_raw ~check_js_regex loc payload =
  begin match Ast_payload.as_string_exp ~check_js_regex payload with
    | Not_String_Lteral ->
      Location.raise_errorf ~loc
        "bs.raw can only be applied to a string"
    | Ast_payload.JS_Regex_Check_Failed ->
      Location.raise_errorf ~loc "this is an invalid js regex"
    | Correct exp ->
      let pexp_desc = 
        Parsetree.Pexp_apply (
          Exp.ident {loc; 
                     txt = 
                       Ldot (Ast_literal.Lid.js_internal, 
                             Literals.raw_expr)},
          [Ast_compatible.no_label,exp]
        )
      in
      { exp with pexp_desc }
  end

let handle_external loc x = 
  let raw_exp : Ast_exp.t = 
    Ast_compatible.app1
    (Exp.ident ~loc 
         {loc; txt = Ldot (Ast_literal.Lid.js_internal, 
                           Literals.raw_expr)})
      ~loc 
      (Ast_compatible.const_exp_string ~loc x  ~delimiter:Ext_string.empty) in 
  let empty = (* FIXME: the empty delimiter does not make sense*)
    Exp.ident ~loc 
    {txt = Ldot (Ldot(Lident"Js", "Undefined"), "empty");loc}    
  in 
  let undefined_typeof = 
    Exp.ident {loc ; txt = Ldot(Lident "Js","undefinedToOption")} in 
  let typeof = 
    Exp.ident {loc ; txt = Ldot(Lident "Js","typeof")} in 

  Ast_compatible.app1 ~loc undefined_typeof (
    Exp.ifthenelse ~loc
    (Ast_compatible.app2 ~loc 
      (Exp.ident ~loc {loc ; txt = Ldot (Lident "Pervasives", "=")} )            
        (Ast_compatible.app1 ~loc typeof raw_exp)      
        (Ast_compatible.const_exp_string ~loc "undefined")
        )      
      empty
      (Some raw_exp)
  )


let handle_raw_structure loc payload = 
  begin match Ast_payload.as_string_exp ~check_js_regex:false payload with 
    | Correct exp 
      -> 
      let pexp_desc = 
        Parsetree.Pexp_apply(
          Exp.ident {txt = Ldot (Ast_literal.Lid.js_internal,  Literals.raw_stmt); loc},
          [ Ast_compatible.no_label,exp]) in 
      Ast_helper.Str.eval 
        { exp with pexp_desc }

    | Not_String_Lteral
      -> 
      Location.raise_errorf ~loc "bs.raw can only be applied to a string"
    | JS_Regex_Check_Failed 
      ->
      Location.raise_errorf ~loc "this is an invalid js regex"
  end


let ocaml_obj_as_js_object
    loc (mapper : Bs_ast_mapper.mapper)
    (self_pat : Parsetree.pattern)
    (clfs : Parsetree.class_field list) =
  let self_type_lit = "self_type"   in 

  (** Attention: we should avoid type variable conflict for each method  
      Since the method name is unique, there would be no conflict 
      OCaml does not allow duplicate instance variable and duplicate methods, 
      but it does allow duplicates between instance variable and method name, 
      we should enforce such rules 
      {[
        object 
          val x = 3
          method x = 3 
        end [@bs]
      ]} should not compile with a meaningful error message
  *)

  let generate_val_method_pair 
      loc (mapper : Bs_ast_mapper.mapper)
      val_name  is_mutable = 

    let result = Typ.var ~loc val_name in 
    result , 
    ((val_name , [], result ) ::
     (if is_mutable then 
        [val_name ^ Literals.setter_suffix,[],
         to_method_type loc mapper Ast_compatible.no_label result (Ast_literal.type_unit ~loc ()) ]
      else 
        []) )
  in 
  (* Note mapper is only for API compatible 
   * TODO: we should check label name to avoid conflict 
  *)  
  let self_type loc = Typ.var ~loc self_type_lit in 

  let generate_arg_type loc (mapper  : Bs_ast_mapper.mapper)
      method_name arity : Ast_core_type.t = 
    let result = Typ.var ~loc method_name in   
    if arity = 0 then
      to_method_type loc mapper Ast_compatible.no_label (Ast_literal.type_unit ~loc ()) result 

    else
      let tyvars =
        Ext_list.init arity (fun i -> Typ.var ~loc (method_name ^ string_of_int i))
      in
      begin match tyvars with
        | x :: rest ->
          let method_rest =
            Ext_list.fold_right rest result (fun v acc -> Ast_compatible.arrow ~loc  v acc)
          in         
          to_method_type loc mapper Ast_compatible.no_label x method_rest
        | _ -> assert false
      end in          

  let generate_method_type
      loc
      (mapper : Bs_ast_mapper.mapper)
      ?alias_type method_name arity =
    let result = Typ.var ~loc method_name in   

    let self_type =
      let v = self_type loc  in
      match alias_type with 
      | None -> v 
      | Some ty -> Typ.alias ~loc ty self_type_lit
    in  
    if arity = 0 then
      to_method_callback_type loc mapper  Ast_compatible.no_label self_type result      
    else
      let tyvars =
        Ext_list.init arity (fun i -> Typ.var ~loc (method_name ^ string_of_int i))
      in
      begin match tyvars with
        | x :: rest ->
          let method_rest =
            Ext_list.fold_right rest result (fun v acc -> Ast_compatible.arrow ~loc  v acc)
          in         
          (to_method_callback_type loc mapper  Ast_compatible.no_label self_type
             (Ast_compatible.arrow ~loc  x method_rest))
        | _ -> assert false
      end in          


  (** we need calculate the real object type 
      and exposed object type, in some cases there are equivalent

      for public object type its [@bs.meth] it does not depend on itself
      while for label argument it is [@bs.this] which depends internal object
  *)
  let internal_label_attr_types, public_label_attr_types  = 
    Ext_list.fold_right clfs ([], []) 
      (fun ({pcf_loc  = loc} as x  : Parsetree.class_field) 
        (label_attr_types, public_label_attr_types) ->
        match x.pcf_desc with
        | Pcf_method (
            label,
            public_flag,
            Cfk_concrete
              (Fresh, e))
          ->
          begin match e.pexp_desc with
            | Pexp_poly
                (({pexp_desc = Pexp_fun (arg_label, _, pat, e)} ),
                 None) 
              when Ast_compatible.is_arg_label_simple arg_label
              ->  
              let arity = Ast_pat.arity_of_fun pat e in
              let method_type =
                generate_arg_type x.pcf_loc mapper label.txt arity in 
              ((label.Asttypes.txt, [], method_type) :: label_attr_types),
              (if public_flag = Public then
                 (label.Asttypes.txt, [], method_type) :: public_label_attr_types
               else 
                 public_label_attr_types)

            | Pexp_poly( _, Some _)
              ->
              Location.raise_errorf ~loc "polymorphic type annotation not supported yet"
            | Pexp_poly (_, None) ->
              Location.raise_errorf ~loc
                "Unsupported syntax, expect syntax like `method x () = x ` "
            | _ ->
              Location.raise_errorf ~loc "Unsupported syntax in js object"               
          end
        | Pcf_val (label, mutable_flag, Cfk_concrete(Fresh, val_exp)) ->
          let  label_type, label_attr  = 
            generate_val_method_pair x.pcf_loc mapper label.txt  
              (mutable_flag = Mutable )
          in
          (Ext_list.append label_attr  label_attr_types, public_label_attr_types)
        | Pcf_val (label, mutable_flag, Cfk_concrete(Override, val_exp)) -> 
          Location.raise_errorf ~loc "override flag not support currently"
        | Pcf_val (label, mutable_flag, Cfk_virtual _) -> 
          Location.raise_errorf ~loc "virtual flag not support currently"

        | Pcf_method (_, _, Cfk_concrete(Override, _) ) -> 
          Location.raise_errorf ~loc "override flag not supported"

        | Pcf_method (_, _, Cfk_virtual _ )
          ->
          Location.raise_errorf ~loc "virtural method not supported"

        | Pcf_inherit _ 
        | Pcf_initializer _
        | Pcf_attribute _
        | Pcf_extension _
        | Pcf_constraint _ ->
          Location.raise_errorf ~loc "Only method support currently"
      ) in
  let internal_obj_type = Ast_core_type.make_obj ~loc internal_label_attr_types in
  let public_obj_type = Ast_core_type.make_obj ~loc public_label_attr_types in
  let (labels,  label_types, exprs, _) =
    Ext_list.fold_right clfs  ([], [], [], false)
      (fun (x  : Parsetree.class_field)
        (labels,
         label_types,
         exprs, aliased ) ->
        match x.pcf_desc with
        | Pcf_method (
            label,
            _public_flag,
            Cfk_concrete
              (Fresh, e))
          ->
          begin match e.pexp_desc with
            | Pexp_poly
                (({pexp_desc = Pexp_fun (arg_label, None, pat, e)} as f),
                 None)
              when Ast_compatible.is_arg_label_simple arg_label   
              ->  
              let arity = Ast_pat.arity_of_fun pat e in
              let alias_type = 
                if aliased then None 
                else Some internal_obj_type in
              let  label_type =
                generate_method_type ?alias_type
                  x.pcf_loc mapper label.txt arity in 
              (label::labels,
               label_type::label_types,
               {f with
                pexp_desc =
                  let f = Ast_pat.is_unit_cont pat ~yes:e ~no:f in                       
                  to_method_callback loc mapper self_pat f
               } :: exprs, 
               true
              )
            | Pexp_poly( _, Some _)
              ->
              Location.raise_errorf ~loc
                "polymorphic type annotation not supported yet"

            | Pexp_poly (_, None) ->
              Location.raise_errorf
                ~loc "Unsupported syntax, expect syntax like `method x () = x ` "
            | _ ->
              Location.raise_errorf ~loc "Unsupported syntax in js object"               
          end
        | Pcf_val (label, mutable_flag, Cfk_concrete(Fresh, val_exp)) ->
          let  label_type, label_attr  = 
            generate_val_method_pair x.pcf_loc mapper label.txt  
              (mutable_flag = Mutable )
          in
          (label::labels,
           label_type :: label_types, 
           (mapper.expr mapper val_exp :: exprs), 
           aliased 
          )

        | Pcf_val (label, mutable_flag, Cfk_concrete(Override, val_exp)) -> 
          Location.raise_errorf ~loc "override flag not support currently"
        | Pcf_val (label, mutable_flag, Cfk_virtual _) -> 
          Location.raise_errorf ~loc "virtual flag not support currently"

        | Pcf_method (_, _, Cfk_concrete(Override, _) ) -> 
          Location.raise_errorf ~loc "override flag not supported"

        | Pcf_method (_, _, Cfk_virtual _ )
          ->
          Location.raise_errorf ~loc "virtural method not supported"


        | Pcf_inherit _ 
        | Pcf_initializer _
        | Pcf_attribute _
        | Pcf_extension _
        | Pcf_constraint _ ->
          Location.raise_errorf ~loc "Only method support currently"
      )  in
  let pval_type =
    Ext_list.fold_right2  labels label_types public_obj_type
      (fun label label_type acc ->
         Ast_compatible.label_arrow
           ~loc:label.Asttypes.loc
           label.Asttypes.txt
           label_type acc           
      ) in
  Ast_external_mk.local_extern_cont
    loc
    ~pval_prim:(Ast_external_process.pval_prim_of_labels labels)
    (fun e ->
       Ast_compatible.apply_labels ~loc e
         (Ext_list.map2 labels exprs (fun l expr -> l.txt, expr) ) )
    ~pval_type


let record_as_js_object 
    loc 
    (self : Bs_ast_mapper.mapper)
    (label_exprs : label_exprs)
  : Parsetree.expression_desc = 

  let labels,args, arity =
    Ext_list.fold_right label_exprs ([],[],0) (fun ({txt ; loc}, e) (labels,args,i) -> 
        match txt with
        | Lident x ->
          ({Asttypes.loc = loc ; txt = x} :: labels, (x, self.expr self e) :: args, i + 1)
        | Ldot _ | Lapply _ ->  
          Location.raise_errorf ~loc "invalid js label ")  in
  Ast_external_mk.local_external_obj loc 
    ~pval_prim:(Ast_external_process.pval_prim_of_labels labels)
    ~pval_type:(Ast_core_type.from_labels ~loc arity labels) 
    args 


end
module Ast_exp_extension : sig 
#1 "ast_exp_extension.mli"
(* Copyright (C) 2018 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


val handle_extension :
  bool ref ->
  Parsetree.expression ->
  Bs_ast_mapper.mapper ->
  Parsetree.extension ->
  Parsetree.expression


type t = { args : string list ; block :  string }

val fromString : string -> t 
  
end = struct
#1 "ast_exp_extension.ml"
(* Copyright (C) 2018 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
open Ast_helper


let rec unroll_function_aux 
  (acc : string list)
  (body : Parsetree.expression) : string list * string =
  match body.pexp_desc with
  | Pexp_constant(
 
    Pconst_string
    
    (block,_)) -> acc, block
  | Pexp_fun(arg_label,_,pat,cont)
    when Ast_compatible.is_arg_label_simple arg_label -> 
    (match pat.ppat_desc with 
    | Ppat_var s -> 
      unroll_function_aux (s.txt::acc) cont
    | Ppat_any -> 
      unroll_function_aux ("_"::acc) cont
    | Ppat_constraint _ -> 
      Location.raise_errorf ~loc:body.pexp_loc  
      "type annotation around bs.raw arguments is invalid, please put in this form: let f : t1 -> t2 = fun%%raw param1 param2 -> .."
    | _ -> 
      Location.raise_errorf ~loc:body.pexp_loc  
      "bs.raw can only be applied to a string or a special function form "
    )
  | _ -> 
    Location.raise_errorf ~loc:body.pexp_loc  
    "bs.raw can only be applied to a string or a special function form "

type t = { args : string list ; block :  string }

let toString (x : t) = 
  Bs_version.version ^ Marshal.to_string x []

(* exception handling*)
let fromString (x : string) : t = 
  if Ext_string.starts_with x Bs_version.version then 
    Marshal.from_string x (String.length Bs_version.version)
  else 
     Ext_fmt.failwithf
        ~loc:__LOC__
        "Compiler version mismatch. The project might have been built with one version of BuckleScript, and then with another. Please wipe the artifacts and do a clean build."

let handle_extension record_as_js_object e (self : Bs_ast_mapper.mapper)
    (({txt ; loc} as lid , payload) : Parsetree.extension) = 
  begin match txt with
    | "bs.raw" | "raw" -> 
      begin match payload with 
      | PStr [
        {pstr_desc = Pstr_eval({pexp_desc = Pexp_fun(arg_label,_,pat,body)},_)}]
        when Ast_compatible.is_arg_label_simple arg_label
         -> 
         begin match pat.ppat_desc, body.pexp_desc with 
         | Ppat_construct ({txt = Lident "()"}, None), Pexp_constant(

          Pconst_string
           
           (block,_))
           -> 
            Ast_compatible.app1 ~loc 
            (Exp.ident ~loc {txt = Ldot (Ast_literal.Lid.js_internal, Literals.raw_function);loc})            
            (Ast_compatible.const_exp_string ~loc ( toString {args = [] ; block } ) )
         | ppat_desc, _ -> 
            let txt = 
              match ppat_desc with 
              | Ppat_var {txt} -> txt 
              | Ppat_any -> "_"
              | _ -> 
                Location.raise_errorf ~loc "bs.raw can only be applied to a string or a special function form "
            in 
            let acc, block = unroll_function_aux [txt] body in 
            Ast_compatible.app1 ~loc 
              (Exp.ident ~loc {txt = Ldot (Ast_literal.Lid.js_internal, Literals.raw_function);loc})
              (Ast_compatible.const_exp_string ~loc (toString {args = List.rev acc ; block }))
         end 
      | _ ->   Ast_util.handle_raw ~check_js_regex:false loc payload
      end
    | "bs.re" | "re" ->
      Exp.constraint_ ~loc
        (Ast_util.handle_raw ~check_js_regex:true loc payload)
        (Ast_comb.to_js_re_type loc)
    | "bs.external" | "external" ->
      begin match Ast_payload.as_ident payload with 
        | Some {txt = Lident x}
          -> Ast_util.handle_external loc x
        (* do we need support [%external gg.xx ] 

           {[ Js.Undefined.to_opt (if Js.typeof x == "undefined" then x else Js.Undefined.empty ) ]}
        *)

        | None | Some _ -> 
          Location.raise_errorf ~loc 
            "external expects a single identifier"
      end
    | "bs.time"| "time" ->
      (
        match payload with 
        | PStr [{pstr_desc = Pstr_eval (e,_)}] -> 
          let locString = 
            if loc.loc_ghost then 
              "GHOST LOC"
            else 
              let loc_start = loc.loc_start in 
              let (file, lnum, __) = Location.get_pos_info loc_start in                  
              Printf.sprintf "%s %d"
                file lnum in   
          let e = self.expr self e in 
          Exp.sequence ~loc
            (Ast_compatible.app1 ~loc     
               (Exp.ident ~loc {loc; 
                                txt = 
                                  Ldot (Ldot (Lident "Js", "Console"), "timeStart")   
                               })
               (Ast_compatible.const_exp_string ~loc locString)
            )     
            ( Exp.let_ ~loc Nonrecursive
                [Vb.mk ~loc (Pat.var ~loc {loc; txt = "timed"}) e ;
                ]
                (Exp.sequence ~loc
                   (Ast_compatible.app1 ~loc     
                      (Exp.ident ~loc {loc; 
                                       txt = 
                                         Ldot (Ldot (Lident "Js", "Console"), "timeEnd")   
                                      })
                      (Ast_compatible.const_exp_string ~loc locString)
                   )    
                   (Exp.ident ~loc {loc; txt = Lident "timed"})
                )
            )
        | _ -> 
          Location.raise_errorf 
            ~loc "expect a boolean expression in the payload"
      )
    | "bs.assert" | "assert" ->
      (
        match payload with 
        | PStr [ {pstr_desc = Pstr_eval( e,_)}] -> 

          let locString = 
            if loc.loc_ghost then 
              "ASSERT FAILURE"
            else 
              let loc_start = loc.loc_start in 
              let (file, lnum, cnum) = Location.get_pos_info loc_start in
              let file = Filename.basename file in 
              let enum = 
                loc.Location.loc_end.Lexing.pos_cnum -
                loc_start.Lexing.pos_cnum + cnum in
              Printf.sprintf "File %S, line %d, characters %d-%d"
                file lnum cnum enum in   
          let raiseWithString  locString =      
              Ast_compatible.app1 ~loc 
               (Exp.ident ~loc {loc; txt = 
                                       Ldot(Ldot (Lident "Js","Exn"),"raiseError")})               
                (Ast_compatible.const_exp_string locString)               
          in 
          (match e.pexp_desc with
           | Pexp_construct({txt = Lident "false"},None) -> 
             (* The backend will convert [assert false] into a nop later *)
             if !Clflags.no_assert_false  then 
               Exp.assert_ ~loc 
                 (Exp.construct ~loc {txt = Lident "false";loc} None)
             else 
               (raiseWithString locString)
           | Pexp_constant (
 
    Pconst_string
              
              (r, _)) -> 
             if !Clflags.noassert then 
               Exp.assert_ ~loc (Exp.construct ~loc {txt = Lident "true"; loc} None)
               (* Need special handling to make it type check*)
             else   
               raiseWithString r
           | _ ->    
             let e = self.expr self  e in 
             if !Clflags.noassert then 
               (* pass down so that it still type check, but the backend will
                  make it a nop
               *)
               Exp.assert_ ~loc e
             else 
               Exp.ifthenelse ~loc
                 (Ast_compatible.app1 ~loc
                    (Exp.ident {loc ; txt = Ldot(Lident "Pervasives","not")})
                    e
                 )
                 (raiseWithString locString)
                 None
          )
        | _ -> 
          Location.raise_errorf 
            ~loc "expect a boolean expression in the payload"
      )
    | "bs.node" | "node" ->
      let strip s =
        match s with 
        | "_module" -> "module" 
        | x -> x  in 
      begin match Ast_payload.as_ident payload with
        | Some {txt = Lident
                    ( "__filename"
                    | "__dirname"
                    | "_module"
                    | "require" as name); loc}
          ->
          let exp =
            Ast_util.handle_external loc (strip name)  in
          let typ =
            Ast_core_type.lift_option_type  
            @@                 
            if name = "_module" then
              Typ.constr ~loc
                { txt = Ldot (Lident "Node", "node_module") ;
                  loc} []   
            else if name = "require" then
              (Typ.constr ~loc
                 { txt = Ldot (Lident "Node", "node_require") ;
                   loc} [] )  
            else
              Ast_literal.type_string ~loc () in                  
          Exp.constraint_ ~loc exp typ                
        | Some _ | None ->
          begin match payload with 
            | PTyp _ -> 
              Location.raise_errorf 
                ~loc "Illegal payload, expect an expression payload instead of type payload"              
            | PPat _ ->
              Location.raise_errorf 
                ~loc "Illegal payload, expect an expression payload instead of pattern  payload"        
            | _ -> 
              Location.raise_errorf 
                ~loc "Illegal payload"
          end

      end             
    | "bs.debugger"|"debugger" ->
      {e with pexp_desc = Ast_util.handle_debugger loc payload}
    | "bs.obj" | "obj" ->
      begin match payload with 
        | PStr [{pstr_desc = Pstr_eval (e,_)}]
          -> 
          Ext_ref.non_exn_protect record_as_js_object true
            (fun () -> self.expr self e ) 
        | _ -> Location.raise_errorf ~loc "Expect an expression here"
      end
    | _ ->
      match payload with
      | PTyp typ when Ext_string.starts_with txt Literals.bs_deriving_dot ->
        self.expr self (Ast_derive.gen_expression lid typ)
      | _ ->  
        e (* For an unknown extension, we don't really need to process further*)
        (* Exp.extension ~loc ~attrs:e.pexp_attributes (
            self.extension self extension) *)
        (* Bs_ast_mapper.default_mapper.expr self e   *)
  end 

end
module Int_hashtbl : sig 
#1 "int_hashtbl.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



include Hashtbl_gen.S with type key = int




end = struct
#1 "int_hashtbl.ml"
# 15 "ext/hashtbl.cppo.ml"
type key = int 
type 'a t = (key, 'a)  Hashtbl_gen.t 
let key_index (h : _ t ) (key : key) =
  (Bs_hash_stubs.hash_int  key ) land (Array.length h.data - 1)
let eq_key = Ext_int.equal   


# 33 "ext/hashtbl.cppo.ml"
type ('a, 'b) bucketlist = ('a,'b) Hashtbl_gen.bucketlist
let create = Hashtbl_gen.create
let clear = Hashtbl_gen.clear
let reset = Hashtbl_gen.reset
let copy = Hashtbl_gen.copy
let iter = Hashtbl_gen.iter
let to_list = Hashtbl_gen.to_list
let fold = Hashtbl_gen.fold
let length = Hashtbl_gen.length
let stats = Hashtbl_gen.stats



let add (h : _ t) key info =
  let i = key_index h key in
  let h_data = h.data in   
  Array.unsafe_set h_data i (Cons(key, info, (Array.unsafe_get h_data i)));
  h.size <- h.size + 1;
  if h.size > Array.length h_data lsl 1 then Hashtbl_gen.resize key_index h

(* after upgrade to 4.04 we should provide an efficient [replace_or_init] *)
let modify_or_init (h : _ t) key modf default =
  let rec find_bucket (bucketlist : _ bucketlist)  =
    match bucketlist with
    | Cons(k,i,next) ->
      if eq_key k key then begin modf i; false end
      else find_bucket next 
    | Empty -> true in
  let i = key_index h key in 
  let h_data = h.data in 
  if find_bucket (Array.unsafe_get h_data i) then
    begin 
      Array.unsafe_set h_data i  (Cons(key,default (), Array.unsafe_get h_data i));
      h.size <- h.size + 1 ;
      if h.size > Array.length h_data lsl 1 then Hashtbl_gen.resize key_index h 
    end


let rec remove_bucket key (h : _ t) (bucketlist : _ bucketlist) : _ bucketlist = 
  match bucketlist with  
  | Empty ->
    Empty
  | Cons(k, i, next) ->
    if eq_key k key 
    then begin h.size <- h.size - 1; next end
    else Cons(k, i, remove_bucket key h next) 

let remove (h : _ t ) key =
  let i = key_index h key in
  let h_data = h.data in 
  let old_h_szie = h.size in 
  let new_bucket = remove_bucket key h (Array.unsafe_get h_data i) in  
  if old_h_szie <> h.size then 
    Array.unsafe_set h_data i  new_bucket

let rec find_rec key (bucketlist : _ bucketlist) = match bucketlist with  
  | Empty ->
    raise Not_found
  | Cons(k, d, rest) ->
    if eq_key key k then d else find_rec key rest

let find_exn (h : _ t) key =
  match Array.unsafe_get h.data (key_index h key) with
  | Empty -> raise Not_found
  | Cons(k1, d1, rest1) ->
    if eq_key key k1 then d1 else
      match rest1 with
      | Empty -> raise Not_found
      | Cons(k2, d2, rest2) ->
        if eq_key key k2 then d2 else
          match rest2 with
          | Empty -> raise Not_found
          | Cons(k3, d3, rest3) ->
            if eq_key key k3  then d3 else find_rec key rest3

let find_opt (h : _ t) key =
  Hashtbl_gen.small_bucket_opt eq_key key (Array.unsafe_get h.data (key_index h key))

let find_key_opt (h : _ t) key =
  Hashtbl_gen.small_bucket_key_opt eq_key key (Array.unsafe_get h.data (key_index h key))
  
let find_default (h : _ t) key default = 
  Hashtbl_gen.small_bucket_default eq_key key default (Array.unsafe_get h.data (key_index h key))
let find_all (h : _ t) key =
  let rec find_in_bucket (bucketlist : _ bucketlist) = match bucketlist with 
    | Empty ->
      []
    | Cons(k, d, rest) ->
      if eq_key k key 
      then d :: find_in_bucket rest
      else find_in_bucket rest in
  find_in_bucket (Array.unsafe_get h.data (key_index h key))

let replace h key info =
  let rec replace_bucket (bucketlist : _ bucketlist) : _ bucketlist = match bucketlist with 
    | Empty ->
      raise_notrace Not_found
    | Cons(k, i, next) ->
      if eq_key k key
      then Cons(key, info, next)
      else Cons(k, i, replace_bucket next) in
  let i = key_index h key in
  let h_data = h.data in 
  let l = Array.unsafe_get h_data i in
  try
    Array.unsafe_set h_data i  (replace_bucket l)
  with Not_found ->
    begin 
      Array.unsafe_set h_data i (Cons(key, info, l));
      h.size <- h.size + 1;
      if h.size > Array.length h_data lsl 1 then Hashtbl_gen.resize key_index h;
    end 

let mem (h : _ t) key =
  let rec mem_in_bucket (bucketlist : _ bucketlist) = match bucketlist with 
    | Empty ->
      false
    | Cons(k, d, rest) ->
      eq_key k key  || mem_in_bucket rest in
  mem_in_bucket (Array.unsafe_get h.data (key_index h key))


let of_list2 ks vs = 
  let len = List.length ks in 
  let map = create len in 
  List.iter2 (fun k v -> add map k v) ks vs ; 
  map


end
module Lam_constant_convert : sig 
#1 "lam_constant_convert.mli"
(* Copyright (C) 2018- Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

 
 val convert_constant:
  Lambda.structured_constant -> 
  Lam_constant.t
end = struct
#1 "lam_constant_convert.ml"
(* Copyright (C) 2018- Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

let rec convert_constant ( const : Lambda.structured_constant) : Lam_constant.t =
  match const with
  | Const_base (Const_int i) -> (Const_int i)
  | Const_base (Const_char i) -> (Const_char i)
  | Const_base (Const_string(i,opt)) ->
      (match opt with
      | Some opt when
          Ast_utf8_string_interp.is_unicode_string opt  ->
        Const_unicode i
      | _ ->
        Const_string i)
    
  | Const_base (Const_float i) -> (Const_float i)
  | Const_base (Const_int32 i) -> (Const_int32 i)
  | Const_base (Const_int64 i) -> (Const_int64 i)
  | Const_base (Const_nativeint i) -> (Const_nativeint i)
  | Const_pointer(i,p) ->
    begin match p with 
    | Pt_constructor p -> Const_pointer(i, Pt_constructor p)
    | Pt_variant p -> Const_pointer(i,Pt_variant p)
    | Pt_module_alias -> Const_pointer(i, Pt_module_alias)
    | Pt_builtin_boolean -> if i = 0 then Const_js_false else Const_js_true
    | Pt_shape_none ->
       Lam_constant.lam_none
    | Pt_na ->  Const_pointer(i, Pt_na)      
     end 
  | Const_float_array (s) -> Const_float_array(s)
  | Const_immstring s -> Const_immstring s
  | Const_block (i,t,xs) ->
    begin match t with 
    | Blk_some_not_nested -> 
      Const_some (convert_constant (Ext_list.singleton_exn xs))
    | Blk_some -> 
      Const_some (convert_constant (Ext_list.singleton_exn xs))        
    | Blk_constructor(a,b) ->   
      let t : Lam_tag_info.t = Blk_constructor(a,b) in 
      Const_block (i,t, Ext_list.map xs convert_constant )
    | Blk_tuple ->   
      let t : Lam_tag_info.t = Blk_tuple in 
      Const_block (i,t, Ext_list.map xs convert_constant )
    | Blk_array -> 
      let t : Lam_tag_info.t = Blk_array in 
      Const_block (i,t, Ext_list.map xs convert_constant )
    | Blk_variant s -> 
      let t : Lam_tag_info.t = Blk_variant s in 
      Const_block (i,t, Ext_list.map xs convert_constant )      
    | Blk_record s -> 
      let t : Lam_tag_info.t = Blk_record s in 
      Const_block (i,t, Ext_list.map xs convert_constant )
    | Blk_module s -> 
      let t : Lam_tag_info.t = Blk_module s in 
      Const_block (i,t, Ext_list.map xs convert_constant )    
    | Blk_extension_slot -> 
      let t : Lam_tag_info.t = Blk_extension_slot in 
      Const_block (i,t, Ext_list.map xs convert_constant )      
    | Blk_na -> 
      let t : Lam_tag_info.t = Blk_na in 
      Const_block (i,t, Ext_list.map xs convert_constant )      

    | Blk_record_inlined (s,ctor,ix)  -> 
      let t : Lam_tag_info.t = Blk_record_inlined (s, ctor,ix) in 
      Const_block (i,t, Ext_list.map xs convert_constant )      
    | Blk_record_ext s -> 
      let t : Lam_tag_info.t = Blk_record_ext s in 
      Const_block(i,t, Ext_list.map xs convert_constant)
        
    end
    

    


end
module Lam_convert : sig 
#1 "lam_convert.mli"
(* Copyright (C) 2018 - Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


val happens_to_be_diff:  
  (int * Lambda.lambda) list -> int option 


(** 
  [convert exports lam]
  it also collect [exit_map] and a collection of potential depended modules [may_depends]
  In this pass we also synchronized aliases so that 
    {[
      let a1 = a0 in 
      let a2 = a1 in 
      let a3 = a2 in 
      let a4 = a3 in 
    ]}
    converted to 
    {[
      let a1 = a0 in 
      let a2 = a0 in 
      let a3 = a0 in 
      let a4 = a0 in 
    ]}
    we dont eliminate unused let bindings to leave it for {!Lam_pass_lets_dce}
    we should remove all those let aliases, otherwise, it will be
    pushed into alias table again
 *)
val convert :  Ident_set.t -> Lambda.lambda -> Lam.t * Lam_module_ident.Hash_set.t

end = struct
#1 "lam_convert.ml"
(* Copyright (C) 2018 - Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


(** A conservative approach to avoid packing exceptions
    for lambda expression like {[
      try { ... }catch(id){body}
    ]}
    we approximate that if [id] is destructed or not.
    If it is destructed, we need pack it in case it is JS exception.
    The packing is called Js.Exn.internalTOOCamlException, which is a nop for OCaml exception, 
    but will wrap as (Error e) when it is an JS exception. 

    {[
      try .. with 
      | A (x,y) -> 
      | Js.Error ..
    ]}

    Without such wrapping, the code above would raise

    Note it is not guaranteed that exception raised(or re-raised) is a structured
    ocaml exception but it is guaranteed that if such exception is processed it would
    still be an ocaml exception.
    for example {[
      match x with
      | exception e -> raise e
    ]}
    it will re-raise an exception as it is (we are not packing it anywhere)

    It is hard to judge an exception is destructed or escaped, any potential
    alias(or if it is passed as an argument) would cause it to be leaked
*)
let exception_id_destructed (l : Lam.t) (fv : Ident.t): bool  =
  let rec 
    hit_opt (x : _ option) = 
  match x with 
  | None -> false
  | Some a -> hit a   
  and hit_list_snd : 'a. ('a * _ ) list -> bool = fun x ->    
    Ext_list.exists_snd  x  hit
  and hit_list xs = Ext_list.exists xs hit 
  and hit (l : Lam.t) =
    match l  with
    | Lprim {primitive = Pintcomp _ ;
             args = ([x;y ])  } ->
      begin match x,y with
        | Lvar _, Lvar _ -> false
        | Lvar _, _ -> hit y
        | _, Lvar _ -> hit x
        | _, _  -> hit x || hit y
      end
    | Lprim {primitive = Praise ; args = [Lvar _]} -> false
    | Lprim {primitive ; args; _} ->
      hit_list args
    | Lvar id ->    
      Ident.same id fv
    | Lassign(id, e) ->
      Ident.same id fv || hit e
    | Lstaticcatch(e1, (_,vars), e2) ->
      hit e1 || hit e2
    | Ltrywith(e1, exn, e2) ->
      hit e1 || hit e2
    | Lfunction{body;params} ->
      hit body;
    | Llet(str, id, arg, body) ->
      hit arg || hit body
    | Lletrec(decl, body) ->
      hit body ||
      hit_list_snd decl
    | Lfor(v, e1, e2, dir, e3) ->
      hit e1 || hit e2 || hit e3
    | Lconst _ -> false
    | Lapply{fn; args; _} ->
      hit fn || hit_list args
    | Lglobal_module _  (* global persistent module, play safe *)
      -> false
    | Lswitch(arg, sw) ->
      hit arg ||
      hit_list_snd sw.sw_consts ||
      hit_list_snd sw.sw_blocks ||
      hit_opt sw.sw_failaction 
    | Lstringswitch (arg,cases,default) ->
      hit arg ||
      hit_list_snd cases ||
      hit_opt default 
    | Lstaticraise (_,args) ->
      hit_list args
    | Lifthenelse(e1, e2, e3) ->
      hit e1 || hit e2 || hit e3
    | Lsequence(e1, e2) ->
      hit e1 || hit e2
    | Lwhile(e1, e2) ->
      hit e1 || hit e2
    | Lsend (k, met, obj, args, _) ->
      hit met || hit obj || hit_list args
  in hit l


let abs_int x = if x < 0 then - x else x
let no_over_flow x  = abs_int x < 0x1fff_ffff 

let lam_is_var (x : Lam.t) (y : Ident.t) = 
  match x with 
  | Lvar y2 -> Ident.same y2 y 
  | _ -> false

(** Make sure no int range overflow happens
    also we only check [int]
*)
let happens_to_be_diff
    (sw_consts :
       (int * Lambda.lambda) list) : int option =
  match sw_consts with
  | (a, Lconst (Const_pointer (a0,_)| Const_base (Const_int a0)))::
    (b, Lconst (Const_pointer (b0,_)| Const_base (Const_int b0)))::
    rest when
     no_over_flow a  &&
     no_over_flow a0 &&
     no_over_flow b &&
     no_over_flow b0 ->
    let diff = a0 - a in
    if b0 - b = diff then
      if Ext_list.for_all rest (fun (x, lam) ->
          match lam with
          | Lconst (Const_pointer(x0,_) | Const_base(Const_int x0))
            when no_over_flow x0 && no_over_flow x ->
            x0 - x = diff
          | _ -> false
        ) then
        Some diff
      else
        None
    else None
  | _ -> None 


let prim = Lam.prim 

type required_modules = Lam_module_ident.Hash_set.t


(** drop Lseq (List! ) etc *)
let rec drop_global_marker (lam : Lam.t) =
  match lam with
  | Lsequence (Lglobal_module id, rest) ->
    drop_global_marker rest
  | _ -> lam

let seq = Lam.seq 
let unit = Lam.unit 

let lam_prim ~primitive:( p : Lambda.primitive) ~args loc : Lam.t =
  match p with
  | Pint_as_pointer
  | Pidentity -> Ext_list.singleton_exn args 
  | Pccall _ -> assert false
  | Prevapply -> assert false
  | Pdirapply -> assert false
  | Ploc loc -> assert false (* already compiled away here*)

  | Pbytes_to_string (* handled very early *)
    -> prim ~primitive:Pbytes_to_string ~args loc
  | Pbytes_of_string -> prim ~primitive:Pbytes_of_string ~args loc
  | Pignore -> (* Pignore means return unit, it is not an nop *)
    seq (Ext_list.singleton_exn args) unit 
  | Pgetglobal id ->
    assert false
  | Psetglobal id ->
    (* we discard [Psetglobal] in the beginning*)
    drop_global_marker (Ext_list.singleton_exn args)
  (* prim ~primitive:(Psetglobal id) ~args loc *)
  | Pmakeblock (tag,info, mutable_flag
 
    , _block_shape

  )
    -> 
    begin match info with 
    | Blk_some_not_nested 
      -> 
      prim ~primitive:Psome_not_nest ~args loc 
    | Blk_some 
      ->    
      prim ~primitive:Psome ~args loc 
    | Blk_constructor(xs,i) ->  
      let info : Lam_tag_info.t = Blk_constructor(xs,i) in
      prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc
    | Blk_tuple  -> 
      let info : Lam_tag_info.t = Blk_tuple in
      prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc
    | Blk_array -> 
      let info : Lam_tag_info.t = Blk_array in
      prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc
    | Blk_variant s -> 
      let info : Lam_tag_info.t = Blk_variant s in
      prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc
    | Blk_record s -> 
      let info : Lam_tag_info.t = Blk_record s in
      prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc

    | Blk_record_inlined (s,ctor,i) ->
      let info : Lam_tag_info.t = Blk_record_inlined (s, ctor,i) in
      prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc
    | Blk_record_ext s ->
      let info : Lam_tag_info.t = Blk_record_ext s in
      prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc
            
    | Blk_module s -> 
      let info : Lam_tag_info.t = Blk_module s in
      prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc
    | Blk_extension_slot -> 
      let info : Lam_tag_info.t = Blk_extension_slot in
      ( 

      match args with 
      | [ Lconst (Const_string name);
          Lprim {primitive = Pccall {prim_name = "caml_fresh_oo_id"} ; }
        ] -> 
        prim ~primitive:(Pcreate_extension name) ~args:[] loc
      | _ ->
       
      prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc
      )

    | Blk_na -> 
      let info : Lam_tag_info.t = Blk_na in
      prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc
    end  
  | Pfield (id,info)
    -> prim ~primitive:(Pfield (id,info)) ~args loc

  | Psetfield (id,b,
 
    _initialization_or_assignment,

      info)
    -> prim ~primitive:(Psetfield (id,info)) ~args loc

  | Pfloatfield (id,info)
    -> prim ~primitive:(Pfloatfield (id,info)) ~args loc
  | Psetfloatfield (id,
 
    _initialization_or_assignment,
  
      info)
    -> prim ~primitive:(Psetfloatfield (id,info)) ~args loc
  | Pduprecord (repr,i)
    -> prim ~primitive:(Pduprecord(repr,i)) ~args loc
  | Plazyforce -> prim ~primitive:Plazyforce ~args loc


  | Praise _ ->
    prim ~primitive:Praise ~args loc
  | Psequand -> prim ~primitive:Psequand ~args loc
  | Psequor -> prim ~primitive:Psequor ~args loc
  | Pnot -> prim ~primitive:Pnot ~args loc
  | Pnegint -> prim ~primitive:Pnegint ~args  loc
  | Paddint -> prim ~primitive:Paddint ~args loc
  | Psubint -> prim ~primitive:Psubint ~args loc
  | Pmulint -> prim ~primitive:Pmulint ~args loc
  | Pdivint 

    _is_safe (*FIXME*)
    
    -> prim ~primitive:Pdivint ~args loc
  | Pmodint 

    _is_safe (*FIXME*)
  
    -> prim ~primitive:Pmodint ~args loc
  | Pandint -> prim ~primitive:Pandint ~args loc
  | Porint -> prim ~primitive:Porint ~args loc
  | Pxorint -> prim ~primitive:Pxorint ~args loc
  | Plslint -> prim ~primitive:Plslint ~args loc
  | Plsrint -> prim ~primitive:Plsrint ~args loc
  | Pasrint -> prim ~primitive:Pasrint ~args loc
  | Pstringlength -> prim ~primitive:Pstringlength ~args loc
  | Pstringrefu -> prim ~primitive:Pstringrefu ~args loc


  | Pabsfloat -> assert false
  | Pstringrefs -> prim ~primitive:Pstringrefs ~args loc
  | Pbyteslength -> prim ~primitive:Pbyteslength ~args loc
  | Pbytesrefu -> prim ~primitive:Pbytesrefu ~args loc
  | Pbytessetu -> prim ~primitive:Pbytessetu ~args  loc
  | Pbytesrefs -> prim ~primitive:Pbytesrefs ~args loc
  | Pbytessets -> prim ~primitive:Pbytessets ~args loc
  | Pisint -> prim ~primitive:Pisint ~args loc
  | Pisout -> prim ~primitive:Pisout ~args loc
  | Pbittest -> prim ~primitive:Pbittest ~args loc
  | Pintoffloat -> prim ~primitive:Pintoffloat ~args loc
  | Pfloatofint -> prim ~primitive:Pfloatofint ~args loc
  | Pnegfloat -> prim ~primitive:Pnegfloat ~args loc
  
  | Paddfloat -> prim ~primitive:Paddfloat ~args loc
  | Psubfloat -> prim ~primitive:Psubfloat ~args loc
  | Pmulfloat -> prim ~primitive:Pmulfloat ~args loc
  | Pdivfloat -> prim ~primitive:Pdivfloat ~args loc

  | Pbswap16 -> prim ~primitive:Pbswap16 ~args loc
  | Pintcomp x -> prim ~primitive:(Pintcomp x)  ~args loc
  | Poffsetint x -> prim ~primitive:(Poffsetint x) ~args loc
  | Poffsetref x -> prim ~primitive:(Poffsetref x) ~args  loc
  | Pfloatcomp x -> prim ~primitive:(Pfloatcomp x) ~args loc
  | Pmakearray 

    (x, _mutable_flag) (*FIXME*)
    
    -> prim ~primitive:(Pmakearray x) ~args  loc
  | Parraylength _ -> prim ~primitive:Parraylength ~args loc
  | Parrayrefu _ -> prim ~primitive:(Parrayrefu ) ~args loc
  | Parraysetu _ -> prim ~primitive:(Parraysetu ) ~args loc
  | Parrayrefs _ -> prim ~primitive:(Parrayrefs ) ~args loc
  | Parraysets _ -> prim ~primitive:(Parraysets ) ~args loc
  | Pbintofint x -> prim ~primitive:(Pbintofint x) ~args loc
  | Pintofbint x -> prim ~primitive:(Pintofbint x) ~args loc
  | Pnegbint x -> prim ~primitive:(Pnegbint x) ~args loc
  | Paddbint x -> prim ~primitive:(Paddbint x) ~args loc
  | Psubbint x -> prim ~primitive:(Psubbint x) ~args loc
  | Pmulbint x -> prim ~primitive:(Pmulbint x) ~args loc
  | Pdivbint 

    {size = x; is_safe } (*FIXME*)
    
    ->
     prim ~primitive:(Pdivbint x) ~args loc
  | Pmodbint 

    {size = x; is_safe } (*FIXME*)
  
    -> prim ~primitive:(Pmodbint x) ~args loc
  | Pandbint x -> prim ~primitive:(Pandbint x) ~args loc
  | Porbint x -> prim ~primitive:(Porbint x) ~args loc
  | Pxorbint x -> prim ~primitive:(Pxorbint x) ~args loc
  | Plslbint x -> prim ~primitive:(Plslbint x) ~args loc
  | Plsrbint x -> prim ~primitive:(Plsrbint x) ~args loc
  | Pasrbint x -> prim ~primitive:(Pasrbint x) ~args loc
  | Pbigarraydim x -> prim ~primitive:(Pbigarraydim x) ~args loc
  | Pstring_load_16 x -> prim ~primitive:(Pstring_load_16 x) ~args loc
  | Pstring_load_32 x -> prim ~primitive:(Pstring_load_32 x) ~args loc
  | Pstring_load_64 x -> prim ~primitive:(Pstring_load_64 x) ~args loc
  | Pstring_set_16 x -> prim ~primitive:(Pstring_set_16 x) ~args loc
  | Pstring_set_32 x -> prim ~primitive:(Pstring_set_32 x) ~args loc
  | Pstring_set_64 x -> prim ~primitive:(Pstring_set_64 x) ~args loc
  | Pbigstring_load_16 x -> prim ~primitive:(Pbigstring_load_16 x) ~args loc
  | Pbigstring_load_32 x -> prim ~primitive:(Pbigstring_load_32 x) ~args loc
  | Pbigstring_load_64 x -> prim ~primitive:(Pbigstring_load_64 x) ~args loc
  | Pbigstring_set_16 x -> prim ~primitive:(Pbigstring_set_16 x) ~args loc
  | Pbigstring_set_32 x -> prim ~primitive:(Pbigstring_set_32 x) ~args loc
  | Pbigstring_set_64 x -> prim ~primitive:(Pbigstring_set_64 x) ~args loc
  | Pctconst x ->
    begin match x with
      | Word_size ->
        Lam.const (Const_int 32) 
      | _ -> prim ~primitive:(Pctconst x) ~args loc
    end

  | Pbbswap x -> prim ~primitive:(Pbbswap x) ~args loc
  | Pcvtbint (a,b) -> prim ~primitive:(Pcvtbint (a,b)) ~args loc
  | Pbintcomp (a,b) -> prim ~primitive:(Pbintcomp (a,b)) ~args loc
  | Pbigarrayref (a,b,c,d) -> prim ~primitive:(Pbigarrayref (a,b,c,d)) ~args loc
  | Pbigarrayset (a,b,c,d) -> prim ~primitive:(Pbigarrayset (a,b,c,d)) ~args loc
 
  | Pfield_computed -> 
    prim ~primitive:Pfield_computed ~args loc 
  | Popaque -> Ext_list.singleton_exn args      
  | Psetfield_computed _ ->  
    prim ~primitive:Psetfield_computed ~args loc 
  | Pduparray _ ->  assert false 
    (* Does not exist since we compile array in js backend unlike native backend *)





let may_depend = Lam_module_ident.Hash_set.add


let convert (exports : Ident_set.t) (lam : Lambda.lambda) : Lam.t * Lam_module_ident.Hash_set.t  =
  let alias_tbl = Ident_hashtbl.create 64 in
  let exit_map = Int_hashtbl.create 0 in
  let may_depends = Lam_module_ident.Hash_set.create 0 in

  let rec
    convert_ccall (a_prim : Primitive_compat.t)  (args : Lambda.lambda list) loc : Lam.t =
    let prim_name = a_prim.prim_name in
    let prim_name_len  = String.length prim_name in
    match External_ffi_types.from_string a_prim.prim_native_name with
    | Ffi_normal ->
      if prim_name_len > 0 && String.unsafe_get prim_name 0 = '#' then
        convert_js_primitive a_prim args loc
      else
        (* COMPILER CHECK *)
        (* Here the invariant we should keep is that all exception
           created should be captured
        *)
          (

          
            let args = Ext_list.map args convert_aux in
            prim ~primitive:(Pccall a_prim) ~args loc
          )
    | Ffi_obj_create labels ->
      let args = Ext_list.map args  convert_aux in
      prim ~primitive:(Pjs_object_create labels) ~args loc
    | Ffi_bs(arg_types, result_type, ffi) ->
      let args = Ext_list.map args convert_aux in
      Lam.handle_bs_non_obj_ffi arg_types result_type ffi args loc prim_name
    | Ffi_inline_const i -> Lam.const i

  and convert_js_primitive (p: Primitive_compat.t) (args : Lambda.lambda list) loc =
    let s = p.prim_name in
    match () with
    | _ when s = "#is_none" -> 
      prim ~primitive:Pis_not_none ~args:(Ext_list.map args convert_aux ) loc 
    | _ when s = "#val_from_unnest_option" 
      -> 
      prim ~primitive:Pval_from_option_not_nest
        ~args:[convert_aux (Ext_list.singleton_exn args)] loc
    | _ when s = "#val_from_option" 
      -> 
      prim ~primitive:Pval_from_option
        ~args:(Ext_list.map args convert_aux ) loc
    | _ when s = "#raw_expr" ->
      (match args with
       | [Lconst( Const_base (Const_string(s,_)))] ->
         prim ~primitive:(Praw_js_code_exp s)
           ~args:[] loc
       | _ -> assert false)
      
    | _ when s = "#raw_function" ->   
      (match args with
       | [Lconst( Const_base (Const_string(s,_)))] ->
         let v = Ast_exp_extension.fromString s in 
         prim ~primitive:(Praw_js_function (v.block, v.args))
           ~args:[] loc
       | _ -> assert false)
      
    | _ when s = "#raw_stmt" ->
      begin match args with
        | [Lconst( Const_base (Const_string(s,_)))] ->
          prim ~primitive:(Praw_js_code_stmt s)
            ~args:[] loc
        | _ -> assert false
      end
    | _ when s =  "#debugger"  ->
      (* ATT: Currently, the arity is one due to PPX *)
      prim ~primitive:Pdebugger ~args:[] loc
    | _ when s = "#null" ->
      Lam.const (Const_js_null)
    | _ when s = "#undefined" ->
      Lam.const (Const_js_undefined)
    | _ when s = "#init_mod" ->
      let args = Ext_list.map args  convert_aux in
      begin match args with
      | [_loc; Lconst(Const_block(0,_,[Const_block(0,_,[])]))]
        ->
        Lam.unit
      | _ -> prim ~primitive:Pinit_mod ~args loc
      end
    | _ when s = "#update_mod" ->
      let args = Ext_list.map args convert_aux in
      begin match args with
      | [Lconst(Const_block(0,_,[Const_block(0,_,[])]));_;_]
        -> Lam.unit
      | _ -> prim ~primitive:Pupdate_mod ~args loc
      end
    | _ ->
      let primitive : Lam_primitive.t =
        match s with
        | "#apply" -> Pjs_runtime_apply
        | "#apply1"
        | "#apply2"
        | "#apply3"
        | "#apply4"
        | "#apply5"
        | "#apply6"
        | "#apply7"
        | "#apply8" -> Pjs_apply
        | "#makemutablelist" ->
          Pmakeblock(0, Blk_constructor("::",1),Mutable)
        | "#setfield1" ->
          Psetfield(1,  Fld_set_na)
        | "#undefined_to_opt" -> Pundefined_to_opt
        | "#nullable_to_opt" -> Pnull_undefined_to_opt
        | "#null_to_opt" -> Pnull_to_opt
        | "#is_nullable" -> Pis_null_undefined
        | "#string_append" -> Pstringadd
        | "#obj_length" -> Pcaml_obj_length
        | "#function_length" -> Pjs_function_length

        | "#unsafe_lt" -> Pjscomp Clt
        | "#unsafe_gt" -> Pjscomp Cgt
        | "#unsafe_le" -> Pjscomp Cle
        | "#unsafe_ge" -> Pjscomp Cge
        | "#unsafe_eq" -> Pjscomp Ceq
        | "#unsafe_neq" -> Pjscomp Cneq

        | "#typeof" -> Pjs_typeof
        | "#fn_run" | "#method_run" -> Pjs_fn_run(Ext_pervasives.nat_of_string_exn p.prim_native_name)
        | "#fn_mk" -> Pjs_fn_make (Ext_pervasives.nat_of_string_exn p.prim_native_name)
        | "#fn_method" -> Pjs_fn_method (Ext_pervasives.nat_of_string_exn p.prim_native_name)
        | "#unsafe_downgrade" -> Pjs_unsafe_downgrade (Ext_string.empty,loc)
        | _ -> Location.raise_errorf ~loc
                 "@{<error>Error:@} internal error, using unrecorgnized primitive %s" s
      in
      let args = Ext_list.map args convert_aux in
      prim ~primitive ~args loc
  and convert_aux (lam : Lambda.lambda) : Lam.t =
    match lam with
    | Lvar x ->
      let var = Ident_hashtbl.find_default alias_tbl x x in
      if Ident.persistent var then
        Lam.global_module var
      else
        Lam.var var
    | Lconst x ->
      Lam.const (Lam_constant_convert.convert_constant x )
    | Lapply 

        {ap_func = fn; ap_args = args; ap_loc = loc; }
    
      ->
          (** we need do this eargly in case [aux fn] add some wrapper *)
          Lam.apply (convert_aux fn) (Ext_list.map args convert_aux ) loc App_na  
    | Lfunction 
 
    {kind; params; body }
    
      ->  
      assert (kind = Curried);
      Lam.function_
            ~arity:(List.length params)  ~params
            ~body:(convert_aux body)
    | Llet 

      (kind,_value_kind, id,e,body) (*FIXME*)
      
      -> convert_let kind id e body

    | Lletrec (bindings,body)
      ->
      let bindings = Ext_list.map_snd  bindings convert_aux in
      let body = convert_aux body in
      let lam = Lam.letrec bindings body in
      Lam_scc.scc bindings lam body
    (* inlining will affect how mututal recursive behave *)
    | Lprim(Prevapply, [x ; f ],  outer_loc)
    | Lprim(Pdirapply, [f ; x],  outer_loc) ->
      convert_pipe f x outer_loc
    | Lprim (Prevapply, _, _ ) -> assert false
    | Lprim(Pdirapply, _, _) -> assert false
    | Lprim(Pccall a, args, loc)  ->
      convert_ccall (Primitive_compat.of_primitive_description a) args loc
    | Lprim (Pgetglobal id, args, loc) ->
      let args = Ext_list.map args convert_aux in
      if Ident.is_predef_exn id then
        Lam.prim ~primitive:(Pglobal_exception id) ~args loc 
      else
        begin
          may_depend may_depends (Lam_module_ident.of_ml id);
          assert (args = []);
          Lam.global_module id
        end
    | Lprim (primitive,args, loc)
      ->
      let args = Ext_list.map args convert_aux in
      lam_prim ~primitive ~args loc
    | Lswitch 

      (e,s, _loc)
      
      -> convert_switch e s 
    | Lstringswitch (e, cases, default, _ ) ->
      Lam.stringswitch 
      (convert_aux e) 
      (Ext_list.map_snd cases convert_aux)
      (Ext_option.map default convert_aux)
    | Lstaticraise (id,[]) ->
        (match Int_hashtbl.find_opt exit_map id  with
        | None -> Lam.staticraise id []
        | Some new_id -> Lam.staticraise new_id [])      
    | Lstaticraise (id, args) ->
      Lam.staticraise id (Ext_list.map args convert_aux )
    | Lstaticcatch (b, (i,[]), Lstaticraise (j,[]) )
      -> (* peep-hole [i] aliased to [j] *)
      let new_i = Int_hashtbl.find_default exit_map j j in
      Int_hashtbl.add exit_map i new_i ;
      convert_aux b
    | Lstaticcatch (b, (i, ids), handler) ->
      Lam.staticcatch (convert_aux b) (i,ids) (convert_aux handler)
    | Ltrywith (b, id, handler) ->
      let body = convert_aux b in
      let handler = convert_aux handler in
      if exception_id_destructed handler id then
        let newId = Ident.create ("raw_" ^ id.name) in
        Lam.try_ body newId
                  (Lam.let_ StrictOpt id
                    (prim ~primitive:Pwrap_exn ~args:[Lam.var newId] Location.none)
                    handler
                 )
      else
        Lam.try_  body id handler
    | Lifthenelse (b,then_,else_) ->
      Lam.if_ (convert_aux b) (convert_aux then_) (convert_aux else_)
    | Lsequence (a,b)
      -> Lam.seq (convert_aux a) (convert_aux b)
    | Lwhile (b,body) ->
      Lam.while_ (convert_aux b) (convert_aux body)
    | Lfor (id, from_, to_, dir, loop) ->
      Lam.for_ id (convert_aux from_) (convert_aux to_) dir (convert_aux loop)
    | Lassign (id, body) ->
      Lam.assign id (convert_aux body)
    | Lsend (kind, a,b,ls, loc) ->
      (* Format.fprintf Format.err_formatter "%a@." Printlambda.lambda b ; *)
        (match convert_aux b with
        | Lprim {primitive =  Pjs_unsafe_downgrade(_,loc);  args}
          ->
          begin match kind, ls with
            | Public (Some name), [] ->
              prim ~primitive:(Pjs_unsafe_downgrade (name,loc))
                ~args loc
            | _ -> assert false
          end
        | b ->
          Lam.send kind (convert_aux a)  b (Ext_list.map ls convert_aux) loc)
      
    | Levent (e, event) ->
      (* disabled by upstream*)
      assert false
    | Lifused (id, e) -> convert_aux e (* TODO: remove it ASAP *)

  and convert_let (kind : Lam_compat.let_kind) id (e : Lambda.lambda) body : Lam.t = 
    match kind, e with
    | Alias , Lvar u  ->
      let new_u = Ident_hashtbl.find_default alias_tbl u u in
      Ident_hashtbl.add alias_tbl id new_u ;
      if Ident_set.mem exports id then
        Lam.let_ kind id (Lam.var new_u) (convert_aux body)
      else convert_aux body
    | Alias ,  Lprim (Pgetglobal u,[], _) when not (Ident.is_predef_exn u)
      ->
      Ident_hashtbl.add alias_tbl id u;
      may_depend may_depends (Lam_module_ident.of_ml u);
      if Ident_set.mem exports id then
        Lam.let_ kind id (Lam.var u) (convert_aux body)
      else convert_aux body

    | _, _ -> 
      let new_e = convert_aux e in 
      let new_body = convert_aux body in 
          (*
            reverse engineering cases as {[           
           (let (switcher/1013 =a (-1+ match/1012))
               (if (isout 2 switcher/1013) (exit 1)
                   (switch* switcher/1013
                      case int 0: 'a'
                        case int 1: 'b'
                        case int 2: 'c')))            
         ]}
         To elemininate the id [switcher], we need ensure it appears only 
         in two places.

         To advance this case, when [sw_failaction] is None
      *)
      match kind, new_e, new_body with 
      | Alias, Lprim {primitive = Poffsetint offset; args =  [Lvar _ as matcher ]},
        Lswitch (Lvar switcher3 ,
                 ({
                   sw_numconsts = false ; 
                   sw_consts ;
                   sw_blocks = []; sw_numblocks = true;
                   sw_failaction = Some ifso
                 } as px)
                ) 
        when Ident.same switcher3 id    &&
             not (Lam_hit.hit_variable id ifso ) && 
             not (Ext_list.exists_snd sw_consts (Lam_hit.hit_variable id))
        -> 
        Lam.switch matcher 
          {px with 
           sw_consts = 
             Ext_list.map sw_consts 
               (fun (i,act) -> i - offset, act)
          }
      | _ -> 
        Lam.let_ kind id new_e new_body
  and convert_pipe (f : Lambda.lambda) (x : Lambda.lambda) outer_loc =        
      let x  = convert_aux x in
      let f =  convert_aux f in
      match  f with
      | Lfunction {params = [param]; body = Lprim{primitive; args = [Lvar inner_arg]; loc }}
        when Ident.same param inner_arg -> 
        Lam.prim ~primitive ~args:[x] outer_loc
      | Lapply {fn = Lfunction{params; body = Lprim{primitive; args = inner_args}}; args}
        when Ext_list.for_all2_no_exn inner_args params lam_is_var &&
             Ext_list.length_larger_than_n inner_args args 1 
        ->
        Lam.prim ~primitive ~args:(Ext_list.append_one args x) outer_loc
      | Lapply{fn;args} ->
        Lam.apply fn (Ext_list.append_one args x) outer_loc App_na
      | _ ->
        Lam.apply f [x] outer_loc App_na
    and convert_switch (e : Lambda.lambda) (s : Lambda.lambda_switch) = 
        let  e = convert_aux e in
        match s with
        | {
          sw_failaction = None ;
          sw_blocks = [];
          sw_numblocks = 0;
          sw_consts ;
          sw_numconsts ;
        } ->
          begin match happens_to_be_diff sw_consts with
            | Some 0 -> e
            | Some i ->
              prim
                ~primitive:Paddint
                ~args:[e; Lam.const(Const_int i)]
                Location.none
            | None ->
              Lam.switch e
                {sw_failaction = None;
                 sw_blocks = [];
                 sw_numblocks = true;
                 sw_consts =
                   Ext_list.map_snd  sw_consts convert_aux;
                 sw_numconsts = 
                   Ext_list.length_ge sw_consts sw_numconsts
                }
          end
        | _ -> 
          Lam.switch  e   
            { sw_numconsts =  Ext_list.length_ge s.sw_consts s.sw_numconsts ;
              sw_consts = Ext_list.map_snd  s.sw_consts convert_aux;
              sw_numblocks = Ext_list.length_ge s.sw_blocks s.sw_numblocks;
              sw_blocks = Ext_list.map_snd s.sw_blocks convert_aux;
              sw_failaction =Ext_option.map s.sw_failaction convert_aux } in
  convert_aux lam , may_depends


(** FIXME: more precise analysis of [id], if it is not 
    used, we can remove it
        only two places emit [Lifused],
        {[
          lsequence (Lifused(id, set_inst_var obj id expr)) rem
          Lifused (env2, Lprim(Parrayset Paddrarray, [Lvar self; Lvar env2; Lvar env1']))
        ]}

        Note the variable, [id], or [env2] is already defined, it can be removed if it is not
        used. This optimization seems useful, but doesnt really matter since it only hit translclass

        more details, see [translclass] and [if_used_test]
        seems to be an optimization trick for [translclass]
        
        | Lifused(v, l) ->
          if count_var v > 0 then simplif l else lambda_unit
      *)  


      (*
        | Lfunction(kind,params,Lprim(prim,inner_args,inner_loc))
          when List.for_all2_no_exn (fun x y ->
          match y with
          | Lambda.Lvar y when Ident.same x y -> true
          | _ -> false
           ) params inner_args
          ->
          let rec aux outer_args params =
            match outer_args, params with
            | x::xs , _::ys ->
              x :: aux xs ys
            | [], [] -> []
            | x::xs, [] ->
            | [], y::ys
          if Ext_list.same_length inner_args args then
            aux (Lprim(prim,args,inner_loc))
          else

           {[
             (fun x y -> f x y) (computation;e) -->
             (fun y -> f (computation;e) y)
           ]}
              is wrong

              or
           {[
             (fun x y -> f x y ) ([|1;2;3|]) -->
             (fun y -> f [|1;2;3|] y)
           ]}
              is also wrong.

              It seems, we need handle [@bs.splice] earlier

              or
           {[
             (fun x y -> f x y) ([|1;2;3|]) -->
             let x0, x1, x2 =1,2,3 in
             (fun y -> f [|x0;x1;x2|] y)
           ]}
              But this still need us to know [@bs.splice] in advance


           we should not remove it immediately, since we have to be careful
                  where it is used, it can be [exported], [Lvar] or [Lassign] etc
                  The other common mistake is that
           {[
             let x = y (* elimiated x/y*)
             let u = x  (* eliminated u/x *)
           ]}

            however, [x] is already eliminated
           To improve the algorithm
           {[
             let x = y (* x/y *)
             let u = x (* u/y *)
           ]}
                  This looks more correct, but lets be conservative here

                  global module inclusion {[ include List ]}
                  will cause code like {[ let include =a Lglobal_module (list)]}

                  when [u] is global, it can not be bound again,
                  it should always be the leaf
        *)      
end
module Lam_pass_alpha_conversion : sig 
#1 "lam_pass_alpha_conversion.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** alpha conversion based on arity *)

val alpha_conversion : Lam_stats.t -> Lam.t  -> Lam.t

end = struct
#1 "lam_pass_alpha_conversion.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = 
  let rec 
    populateApplyInfo (args_arity : int list) (len : int) (fn : Lam.t) (args : Lam.t list) loc status : Lam.t = 
    match args_arity with 
    | 0 :: _ 
    | [] -> Lam.apply (simpl fn) (Ext_list.map args simpl)  loc status
    | x :: xs -> 
      if x = len 
      then 
        Lam.apply (simpl fn) (Ext_list.map args simpl) loc App_ml_full
      else if x > len  
      then 
        let fn = simpl fn in
        let args = Ext_list.map args simpl in
        Lam_eta_conversion.transform_under_supply (x - len) loc App_ml_full
          fn args 
      else 
        let first,rest = Ext_list.split_at args x in 
        Lam.apply (
          Lam.apply (simpl fn) 
            (Ext_list.map first simpl ) 
            loc App_ml_full
        )
          (Ext_list.map rest simpl ) loc status (* TODO refien *)
    
  and simpl  (lam : Lam.t) = 
    match lam with 
    | Lconst _ -> lam
    | Lvar _ -> lam 
    | Lapply {fn = l1; args =  ll;  loc ; status} 
      -> (* detect functor application *)
      let args_arity =  Lam_arity.extract_arity (Lam_arity_analysis.get_arity meta l1) in
      let len = List.length ll in         
      populateApplyInfo args_arity len l1 ll loc status
    | Llet (str, v, l1, l2) ->
      Lam.let_ str v (simpl l1) (simpl l2 )
    | Lletrec (bindings, body) ->
      let bindings = Ext_list.map_snd  bindings simpl in 
      Lam.letrec bindings (simpl body) 
    | Lglobal_module _ -> lam 
    | Lprim {primitive = (Pjs_fn_make len) as primitive ; args = [arg] 
      ; loc } -> 
      
      begin match 
      Lam_arity.get_first_arity 
      (Lam_arity_analysis.get_arity meta arg) with       
      | Some x 
        -> 
        let arg = simpl arg in
          Lam_eta_conversion.unsafe_adjust_to_arity loc 
            ~to_:len 
            ~from:x
            arg 
      | None ->  Lam.prim ~primitive ~args:[simpl arg] loc
      end
    | Lprim {primitive; args ; loc} -> 
      Lam.prim ~primitive ~args:(Ext_list.map args simpl) loc
    | Lfunction {arity; params; body = l} ->
      (* Lam_mk.lfunction kind params (simpl l) *)
      Lam.function_ ~arity  ~params  ~body:(simpl  l)
    | Lswitch (l, {sw_failaction; 
                  sw_consts; 
                  sw_blocks;
                  sw_numblocks;
                  sw_numconsts;
                 }) ->
      Lam.switch (simpl  l)
              {sw_consts = 
                 Ext_list.map_snd  sw_consts simpl;
               sw_blocks = Ext_list.map_snd  sw_blocks simpl;
               sw_numconsts;
               sw_numblocks;
               sw_failaction = Ext_option.map sw_failaction simpl;
              }
    | Lstringswitch (l, sw, d) ->
      Lam.stringswitch (simpl  l)
                    (Ext_list.map_snd sw simpl)
                    (Ext_option.map d simpl)
    | Lstaticraise (i,ls) ->
      Lam.staticraise i (Ext_list.map ls simpl)
    | Lstaticcatch (l1, ids, l2) 
      -> 
      Lam.staticcatch (simpl  l1) ids (simpl  l2)
    | Ltrywith (l1, v, l2) 
      -> 
      Lam.try_ (simpl  l1) v (simpl  l2)
    | Lifthenelse (l1, l2, l3) -> 
      Lam.if_ (simpl  l1) (simpl  l2) (simpl  l3)
    | Lsequence (l1, l2) 
      -> Lam.seq (simpl  l1) (simpl  l2)
    | Lwhile (l1, l2)
      -> Lam.while_ (simpl  l1) (simpl l2)
    | Lfor (flag, l1, l2, dir, l3)
      -> Lam.for_ flag (simpl  l1) (simpl  l2) dir (simpl  l3)
    | Lassign (v, l) ->
      (* Lalias-bound variables are never assigned, so don't increase
         v's refsimpl *)
      Lam.assign v (simpl  l)
    | Lsend (u, m, o, ll, v) -> 
      Lam.send u (simpl m) (simpl o) (Ext_list.map ll simpl) v

  in 

  simpl lam

end
module Lam_pass_collect : sig 
#1 "lam_pass_collect.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)









(** This pass is used to collect meta data information.

    It includes:
    alias table, arity for identifiers and might more information,
    
    ATTENTION:
    For later pass to keep its information complete and up to date,
    we  need update its table accordingly

    - Alias inference is not for substitution, it is for analyze which module is 
      actually a global module or an exception, so it can be relaxed a bit
      (without relying on strict analysis)

    - Js object (local) analysis 

    Design choice:

    Side effectful operations:
       - Lassign 
       - Psetfield

    1. What information should be collected:

    2. What's the key
       If it's identifier, 
       
    Information that is always sound, not subject to change 

    - shall we collect that if an identifier is passed as a parameter, (useful for escape analysis), 
    however, since it's going to change after inlning (for local function)

    - function arity, subject to change when you make it a mutable ref and change it later
    
    - Immutable blocks of identifiers
     
      if identifier itself is function/non block then the access can be inlined 
      if identifier itself is immutable block can be inlined
      if identifier is mutable block can be inlined (without Lassign) since

    - When collect some information, shall we propogate this information to 
      all alias table immeidately

      - annotation identifiers (at first time)
      -
 *)

(** Modify existing [meta] *)
val collect_helper : Lam_stats.t -> Lam.t -> unit

(** return a new [meta] *)
val count_alias_globals : 
  Env.t -> 
  Ident.t list -> 
  Ident_set.t -> 
  Lam.t -> 
  Lam_stats.t 



end = struct
#1 "lam_pass_collect.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Check, it is shared across ident_tbl, 
    Only [Lassign] will break such invariant,
    how about guarantee that [Lassign] only check the local ref 
    and we track which ids are [Lassign]ed
*)
(**
   might not be the same due to refinement
   assert (old.arity = v) 
*)
let annotate (meta : Lam_stats.t)  rec_flag  (k:Ident.t) (arity : Lam_arity.t) lambda = 
  Ident_hashtbl.add meta.ident_tbl k 
      (FunctionId {arity; lambda = Some (lambda, rec_flag) })
  (* see #3609 
    we have to update since bounded function lambda
    may contain staled unbounded varaibles
  *)
  (* match Ident_hashtbl.find_opt  meta.ident_tbl k  with 
  | None -> (** FIXME: need do a sanity check of arity is NA or Determin(_,[],_) *)
    
  |  Some (FunctionId old)  ->  
    Ident_hashtbl.add meta.ident_tbl k 
      (FunctionId {arity; lambda = Some (lambda, rec_flag) })
    (* old.arity <- arity   *)
    (* due to we keep refining arity analysis after each round*)      
  | _ -> assert false  *)
  (* TODO -- avoid exception *)


(** it only make senses recording arities for 
    function definition,
    alias propgation - and toplevel identifiers, this needs to be exported
*)
let collect_helper  (meta : Lam_stats.t) (lam : Lam.t)  = 
  let rec collect_bind rec_flag
      (kind : Lam_compat.let_kind) 
      (ident : Ident.t)
      (lam : Lam.t) = 
    match lam with 
    | Lconst v 
      -> 
      Ident_hashtbl.replace meta.ident_tbl ident (Constant v); (** *)
    | Lprim {primitive = Pmakeblock (_, _, Immutable ) ; args=  ls}
      -> 
      Ident_hashtbl.replace meta.ident_tbl ident 
        (Lam_util.kind_of_lambda_block ls);
      List.iter collect ls     
    | Lprim {primitive = Psome | Psome_not_nest; args = [v]} -> 
      Ident_hashtbl.replace meta.ident_tbl ident (Normal_optional(v));
      collect v   
    | Lprim{primitive = Praw_js_function(_,raw_args); args = _ }           
      ->
      Ident_hashtbl.replace meta.ident_tbl ident 
        (FunctionId {arity = Lam_arity.info [List.length raw_args] false; lambda = None} )
    | Lprim {primitive = Pnull_to_opt; 
             args = ([ Lvar _ as l ]  ) ; _}
      ->
      Ident_hashtbl.replace meta.ident_tbl ident 
        (OptionalBlock(l, Null ))    
    | Lprim {primitive = Pundefined_to_opt; 
             args = ([ Lvar _ as l] ); _}
      ->
      Ident_hashtbl.replace meta.ident_tbl ident 
        (OptionalBlock(l, Undefined) )
    | Lprim {primitive = Pnull_undefined_to_opt;
             args = ([ Lvar _ as l] );}
      ->
      Ident_hashtbl.replace meta.ident_tbl ident 
        (OptionalBlock(l, Null_undefined))
    | Lglobal_module v  
      -> 
      Lam_util.alias_ident_or_global meta  ident v (Module  v) kind; 
    | Lvar v 
      -> 
      (
        (* if Ident.global v then  *)
        Lam_util.alias_ident_or_global meta  ident v NA kind
        (* enven for not subsitution, it still propogate some properties *)
        (* else () *)
      )
    | Lfunction{ params; body}
      (** TODO record parameters ident ?, but it will be broken after inlining *)  
      -> 
      (** TODO could be optimized in one pass? 
          -- since collect would iter everywhere,
          so -- it would still iterate internally
      *)

      Ext_list.iter params (fun p -> Ident_hashtbl.add meta.ident_tbl p Parameter ) ;
      let arity = Lam_arity_analysis.get_arity meta lam in       
      annotate meta rec_flag ident  arity lam; 
      collect body
    | x -> 
      collect x ;
      if Ident_set.mem meta.export_idents ident then 
        annotate meta rec_flag ident (Lam_arity_analysis.get_arity meta x ) lam


  and collect  (lam : Lam.t)  =
    match lam with 

    (** TODO: 
        how about module aliases..
        record dependency
        --- tricky -- if we inlining, 
        is it safe to remove it? probably not...
    *)
    | Lconst _ -> ()
    | Lvar _ -> ()
    | Lapply{fn = l1; args =  ll; _} ->
      collect  l1; List.iter collect  ll
    | Lfunction { params; body =  l} -> (* functor ? *)
      List.iter (fun p -> Ident_hashtbl.add meta.ident_tbl p Parameter ) params;
      collect  l
    | Llet (kind,ident,arg,body) -> 
      collect_bind Lam_non_rec kind ident arg ; collect body
    | Lletrec (bindings, body) -> 
      (match bindings with 
       | [ident, arg] -> collect_bind Lam_self_rec Strict ident arg
       | _ -> 
         Ext_list.iter bindings
           (fun (ident,arg) -> collect_bind Lam_rec  Strict ident arg )) ;
      collect body
    | Lglobal_module _ -> ()
    | Lprim {args; _} -> List.iter collect  args
    | Lswitch(l, {sw_failaction; sw_consts; sw_blocks}) ->
      collect  l;
      Ext_list.iter_snd sw_consts collect;
      Ext_list.iter_snd sw_blocks collect;
      Ext_option.iter sw_failaction collect 
    | Lstringswitch(l, sw, d) ->
      collect  l ;
      Ext_list.iter_snd sw  collect;
      Ext_option.iter d collect
    | Lstaticraise (code,ls) -> 
      List.iter collect  ls
    | Lstaticcatch(l1, (_,_), l2) -> collect  l1; collect  l2
    | Ltrywith(l1, _, l2) -> collect  l1; collect  l2
    | Lifthenelse(l1, l2, l3) -> collect  l1; collect  l2; collect  l3
    | Lsequence(l1, l2) -> collect  l1; collect  l2
    | Lwhile(l1, l2) -> collect  l1; collect l2
    | Lfor(_, l1, l2, dir, l3) -> collect  l1; collect  l2; collect  l3
    | Lassign(v, l) ->
      (* Lalias-bound variables are never assigned, so don't increase
         v's refcollect *)
      collect  l
    | Lsend(_, m, o, ll, _) -> collect m ; collect o; List.iter collect ll
  in collect lam 



let count_alias_globals 
    env 
    (export_idents : Ident.t list)
    (export_sets  : Ident_set.t)
    (lam : Lam.t) : Lam_stats.t =
  let meta : Lam_stats.t = 
    {alias_tbl = Ident_hashtbl.create 31 ; 
     ident_tbl = Ident_hashtbl.create 31;

     exports =  export_idents;
     env;
     export_idents = export_sets;
    } in 
  collect_helper  meta lam ; 
  meta

end
module Lam_pass_deep_flatten : sig 
#1 "lam_pass_deep_flatten.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


val deep_flatten : Lam.t -> Lam.t

end = struct
#1 "lam_pass_deep_flatten.ml"
(* Copyright (C) 2015- Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

 (* type eliminate =
    |  Not_eliminatable
    |  *)

let rec eliminate_tuple (id : Ident.t) (lam : Lam.t) acc =
  match lam with
  | Llet (Alias,v, Lprim {primitive = Pfield (i,_); args = [Lvar tuple]}, e2)
    when Ident.same tuple id
    ->
    eliminate_tuple id e2 (Int_map.add acc i v )
    (* it is okay to have duplicates*)
  | _ ->
    if Lam_hit.hit_variable id lam then
      None
    else  Some (acc,lam)
(* [groups] are in reverse order *)

      (** be careful to flatten letrec
          like below :
          {[
            let rec even =
              let odd n =  if n ==1 then true else even (n - 1) in
              fun n -> if n ==0  then true else odd (n - 1)
          ]}
          odd and even are recursive values, since all definitions inside
          e.g, [odd] can see [even] now, however, it should be fine
          in our case? since ocaml's recursive value does not allow immediate
          access its value direclty?, seems no
          {[
            let rec even2 =
              let odd = even2 in
              fun n -> if n ==0  then true else odd (n - 1)
          ]}
      *)
      (* FIXME:
          here we try to move inner definitions of [recurisve value] upwards
          for example:
         {[
           let rec x =
             let y = 32 in
             y :: x
           and z = ..
             ---
             le ty = 32 in
           let rec x = y::x
           and z = ..
         ]}
          however, the inner definitions can see [z] and [x], so we
          can not blindly move it in the beginning, however, for
          recursive value, ocaml does not allow immediate access to
          recursive value, so what's the best strategy?
          ---
          the motivation is to capture real tail call
      *)
      (*            | Single ((Alias | Strict | StrictOpt), id, ( Lfunction _ )) ->
              (** FIXME:
                   It should be alias and alias will be optimized away
                   in later optmizations, however,
                   this means if we don't optimize
                  {[ let u/a = v in ..]}
                   the output would be wrong, we should *optimize
                   this away right now* instead of delaying it to the
                   later passes
              *)
              (acc, set, g :: wrap, stop)
      *)
       (* could also be from nested [let rec]
                 like
                 {[
                   let rec x =
                     let rec y = 1 :: y in
                     2:: List.hd y:: x
                 ]}
                 TODO: seems like we should update depenency graph,

              *)
      (** TODO: more flattening,
          - also for function compilation, flattening should be done first
          - [compile_group] and [compile] become mutually recursive function
      *)
      (* Printlambda.lambda Format.err_formatter lam ; assert false  *)
let lambda_of_groups ~(rev_bindings : Lam_group.t list) (result : Lam.t)  : Lam.t =
  Ext_list.fold_left rev_bindings result (fun acc x ->
      match x with
      | Nop l -> Lam.seq l acc
      | Single(kind,ident,lam) -> Lam_util.refine_let ~kind ident lam acc
      | Recursive bindings -> Lam.letrec bindings acc)
    


(* TODO:
    refine effectful [ket_kind] to be pure or not
    Be careful of how [Lifused(v,l)] work
    since its semantics depend on whether v is used or not
    return value are in reverse order, but handled by [lambda_of_groups]
*)
let deep_flatten
    (lam : Lam.t) :  Lam.t  =
  let rec
    flatten
      (acc :  Lam_group.t list )
      (lam : Lam.t) :  Lam.t *  Lam_group.t list =
    match lam with
    | Llet (str, id,
            (Lprim {primitive = (
                          Pnull_to_opt
                         | Pundefined_to_opt
                         | Pnull_undefined_to_opt)
                   ; args  =  [Lvar _]} as arg), body)
      ->
      flatten (Single(str, id, aux arg ) :: acc) body
    | Llet (str, id,
            Lprim {primitive = (
                          Pnull_to_opt | Pundefined_to_opt | Pnull_undefined_to_opt as primitive );
                   args = [arg]}, body)
      ->
      let newId = Ident.rename id in
      flatten acc
        (Lam.let_ str newId arg
               (Lam.let_ Alias id
                  (Lam.prim
                     ~primitive
                     ~args: [Lam.var newId] Location.none (* FIXME*))
                  body)
              )
    | Llet (str,id,arg,body) ->
      (*
        {[ let match = (a,b,c)
           let d = (match/1)
           let e = (match/2)
           ..
        ]}
      *)
      let (res,accux) = flatten acc arg  in
      begin match id.name, str, res with
        | ("match" | "include"| "param"),
          (Alias | Strict | StrictOpt),
          Lprim {primitive = Pmakeblock(_,_, Immutable); args} ->
          begin match eliminate_tuple id body Int_map.empty with
            | Some (tuple_mapping, body) ->
              flatten (
                Ext_list.fold_left_with_offset args accux  0
                  (fun arg  acc i ->
                     match Int_map.find_opt tuple_mapping i with
                     | None ->
                        Lam_group.nop_cons arg acc
                     | Some key ->
                       Lam_group.single str key arg :: acc
                  )
                  
                  
              ) body
            | None ->
              flatten (Single(str, id, res ) :: accux) body
          end
        | _ -> flatten (Single(str, id, res ) :: accux) body
      end
    | Lletrec (bind_args, body) ->

      flatten
        (
          Recursive
            (Ext_list.map_snd bind_args aux)
          :: acc
        )
        body
    | Lsequence (l,r) ->
      let (res, l)  = flatten acc l in
      flatten (Lam_group.nop_cons res l)  r
    | x ->
      aux x, acc

  and aux  (lam : Lam.t) : Lam.t=
    match lam with
    | Llet _ ->
      let res, groups = flatten [] lam
      in lambda_of_groups res ~rev_bindings:groups
    | Lletrec (bind_args, body) ->
      (* Attention: don't mess up with internal {let rec} *)
      let rec iter bind_args groups set  =
        match bind_args with
        | [] ->   (List.rev groups, set)
        | (id,arg) :: rest ->
          iter rest ((id, aux arg) :: groups) (Ident_set.add set id)
      in
      let groups, collections = iter bind_args [] Ident_set.empty in
      (* Try to extract some value definitions from recursive values as [wrap],
         it will stop whenever it find it could not move forward
        {[
           let rec x =
              let y = 1 in
              let z = 2 in
              ...
        ]}
      *)
      let (rev_bindings, rev_wrap, _) =
        Ext_list.fold_left groups ([],  [], false ) (fun (inner_recursive_bindings,  wrap,stop) (id,lam) ->
          if stop || Lam_hit.hit_variables collections lam  then
              (id, lam) :: inner_recursive_bindings, wrap, true
          else
              (inner_recursive_bindings,  (Lam_group.Single (Strict, id, lam)) :: wrap, false)
          ) in
      lambda_of_groups
      ~rev_bindings:rev_wrap (* These bindings are extracted from [letrec] *)
        (Lam.letrec  (List.rev rev_bindings)  (aux body))
    | Lsequence (l,r) -> Lam.seq (aux l) (aux r)
    | Lconst _ -> lam
    | Lvar _ -> lam
    (* | Lapply(Lfunction(Curried, params, body), args, _) *)
    (*   when  List.length params = List.length args -> *)
    (*     aux (beta_reduce  params body args) *)
    (* | Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock _, args)], _) *)
    (*     (\** TODO: keep track of this parameter in ocaml trunk, *)
    (*           can we switch to the tupled backend? *\) *)
    (*   when  List.length params = List.length args -> *)
    (*       aux (beta_reduce params body args) *)

    | Lapply{fn = l1; args  = ll; loc; status} ->
      Lam.apply (aux l1) (Ext_list.map ll aux) loc status

    (* This kind of simple optimizations should be done each time
       and as early as possible *)

    (* | Lprim {primitive = Pccall{prim_name = "caml_int64_float_of_bits"; _};
            args = [ Lconst (  (Const_int64 i))]; _}
      ->
      Lam.const
        (  (Const_float (Js_number.to_string (Int64.float_of_bits i) ))) *)
    (* | Lprim {primitive = Pccall{prim_name = "caml_int64_to_float"; _};
             args = [ Lconst (  (Const_int64 i))]; _}
      ->
      (* TODO: note when int is too big, [caml_int64_to_float] is unsafe *)
      Lam.const
        (  (Const_float (Js_number.to_string (Int64.to_float i) ))) *)
    | Lglobal_module _ -> lam
    | Lprim {primitive ; args; loc }
      ->
      let args = Ext_list.map args aux in
      Lam.prim ~primitive ~args loc

    | Lfunction{arity;  params;  body = l} ->
      Lam.function_ ~arity  ~params  ~body:(aux  l)
    | Lswitch(l, {sw_failaction;
                  sw_consts;
                  sw_blocks;
                  sw_numblocks;
                  sw_numconsts;
                 }) ->
      Lam.switch (aux  l)
              {sw_consts =
                 Ext_list.map_snd  sw_consts aux;
               sw_blocks = Ext_list.map_snd  sw_blocks aux;
               sw_numconsts;
               sw_numblocks;
               sw_failaction = Ext_option.map sw_failaction aux
              }
    | Lstringswitch(l, sw, d) ->
      Lam.stringswitch (aux  l)
                    (Ext_list.map_snd  sw aux)
                    (Ext_option.map d aux)
    | Lstaticraise (i,ls)
      -> Lam.staticraise i (Ext_list.map ls aux)
    | Lstaticcatch(l1, ids, l2) ->
      Lam.staticcatch (aux  l1) ids (aux  l2)
    | Ltrywith(l1, v, l2) ->
      Lam.try_ (aux  l1) v (aux  l2)
    | Lifthenelse(l1, l2, l3)
      ->
      Lam.if_ (aux  l1) (aux l2) (aux l3)
    | Lwhile(l1, l2)
      ->
      Lam.while_ (aux  l1) (aux l2)
    | Lfor(flag, l1, l2, dir, l3)
      ->
      Lam.for_ flag (aux  l1) (aux  l2) dir (aux  l3)
    | Lassign(v, l) ->
      (* Lalias-bound variables are never assigned, so don't increase
         v's refaux *)
      Lam.assign v (aux  l)
    | Lsend(u, m, o, ll, v) ->
      Lam.send u (aux m) (aux o) (Ext_list.map ll aux) v
  in aux lam

end
module Lam_exit_count : sig 
#1 "lam_exit_count.mli"
(* Copyright (C) 2018 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


 type collection 

 
 val count_helper : Lam.t -> collection

 val count_exit : collection -> int -> int 



end = struct
#1 "lam_exit_count.ml"
(* Copyright (C) 2018 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


type collection = int ref Int_hashtbl.t
(** Don't modify it .. *)
let default_zero = ref 0

(* Count occurrences of (exit n ...) statements *)
let count_exit (exits : collection) i =
  !(Int_hashtbl.find_default exits i default_zero)

let incr_exit (exits : collection) i =
  Int_hashtbl.modify_or_init exits i incr (fun _ -> ref 1)


(** 
  This funcition counts how each [exit] is used, it will affect how the following optimizations performed.
  
  Some smart cases (this requires the following optimizations follow it): 
  
  {[
    Lstaticcatch(l1, (i,_), l2) 
  ]}
  If [l1] does not contain [(exit i)],
  [l2] will be removed, so don't count it.
  
  About Switch default branch handling, it maybe backend-specific
  See https://github.com/ocaml/ocaml/commit/fcf3571123e2c914768e34f1bd17e4cbaaa7d212#diff-704f66c0fa0fc9339230b39ce7d90919 
  For Lstringswitch ^
  
  For Lswitch, if it is not exhuastive pattern match, default will be counted twice.
  Since for pattern match,  we will  test whether it is  an integer or block, both have default cases predicate: [sw_numconsts] vs nconsts
*)
let count_helper  (lam : Lam.t) : collection = 
  let exits : collection = Int_hashtbl.create 17 in
  let rec count (lam : Lam.t) = 
    match lam with 
    | Lstaticraise (i,ls) -> incr_exit exits i ; Ext_list.iter ls count
    | Lstaticcatch(l1, (i,_), l2) ->
      count l1;
      if count_exit exits i > 0 then count l2
    | Lstringswitch(l, sw, d) ->
      count l;
      Ext_list.iter_snd sw count;
      Ext_option.iter d count
    | Lglobal_module _
    | Lvar _| Lconst _ -> ()
    | Lapply{fn ; args; _} -> count fn; Ext_list.iter args count
    | Lfunction {body} -> count body
    | Llet(_, _, l1, l2) ->
      count l2; count l1
    | Lletrec(bindings, body) ->
      Ext_list.iter_snd bindings count;
      count body    
    | Lprim {args;  _} -> List.iter count args
    | Lswitch(l, sw) ->
      count_default sw ;
      count l;
      Ext_list.iter_snd sw.sw_consts count;
      Ext_list.iter_snd sw.sw_blocks count
    | Ltrywith(l1, v, l2) -> count l1; count l2
    | Lifthenelse(l1, l2, l3) -> count l1; count l2; count l3
    | Lsequence(l1, l2) -> count l1; count l2
    | Lwhile(l1, l2) -> count l1; count l2
    | Lfor(_, l1, l2, dir, l3) -> count l1; count l2; count l3
    | Lassign(_, l) -> count l
    | Lsend(_, m, o, ll, _) -> count m; count o; List.iter count ll
  and count_default sw =
    match sw.sw_failaction with
    | None -> ()
    | Some al ->
      if not sw.sw_numconsts && not sw.sw_numblocks
      then 
          (count al ; count al)    
      else 
          count al in 
  count lam ; 
  exits
;;

end
module Lam_subst : sig 
#1 "lam_subst.mli"
(* Copyright (C) 2017 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)




(* Apply a substitution to a lambda-term.
   Assumes that the bound variables of the lambda-term do not
   belong to the domain of the substitution.
   Assumes that the image of the substitution is out of reach
   of the bound variables of the lambda-term (no capture). *)

val subst : Lam.t Ident_map.t -> Lam.t -> Lam.t

end = struct
#1 "lam_subst.ml"
(* Copyright (C) 2017 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)




(* Apply a substitution to a lambda-term.
   Assumes that the bound variables of the lambda-term do not
   belong to the domain of the substitution.
   Assumes that the image of the substitution is out of reach
   of the bound variables of the lambda-term (no capture). *)

 let subst (s : Lam.t Ident_map.t) lam =
  let rec subst_aux (x : Lam.t) : Lam.t =
    match x with 
    | Lvar id as l ->
      Ident_map.find_default s id  l
    | Lconst sc as l -> l
    | Lapply{fn; args; loc; status} -> 
      Lam.apply (subst_aux fn) (Ext_list.map args subst_aux ) loc status
    | Lfunction {arity; params; body} -> 
      Lam.function_ ~arity  ~params ~body:(subst_aux body)
    | Llet(str, id, arg, body) -> 
      Lam.let_ str id (subst_aux arg) (subst_aux body)
    | Lletrec(decl, body) -> 
      Lam.letrec (Ext_list.map decl subst_decl ) (subst_aux body)
    | Lprim { primitive ; args; loc} -> 
      Lam.prim ~primitive ~args:(Ext_list.map args subst_aux ) loc
    | Lam.Lglobal_module _ -> x  
    | Lswitch(arg, sw) ->
      Lam.switch (subst_aux arg)
        {sw with sw_consts = Ext_list.map sw.sw_consts subst_case ;
                 sw_blocks = Ext_list.map sw.sw_blocks subst_case ;
                 sw_failaction = subst_opt  sw.sw_failaction; }
    | Lstringswitch (arg,cases,default) ->
      Lam.stringswitch
        (subst_aux arg) (Ext_list.map cases subst_strcase ) (subst_opt default)
    | Lstaticraise (i,args)
      ->  Lam.staticraise i (Ext_list.map args subst_aux)
    | Lstaticcatch(e1, io, e2)
      -> Lam.staticcatch (subst_aux e1) io (subst_aux e2)
    | Ltrywith(e1, exn, e2)
      -> Lam.try_ (subst_aux e1) exn (subst_aux e2)
    | Lifthenelse(e1, e2, e3)
      -> Lam.if_ (subst_aux e1) (subst_aux e2) (subst_aux e3)
    | Lsequence(e1, e2)
      -> Lam.seq (subst_aux e1) (subst_aux e2)
    | Lwhile(e1, e2) 
      -> Lam.while_ (subst_aux e1) (subst_aux e2)
    | Lfor(v, e1, e2, dir, e3) 
      -> Lam.for_ v (subst_aux e1) (subst_aux e2) dir (subst_aux e3)
    | Lassign(id, e) -> 
      Lam.assign id (subst_aux e)
    | Lsend (k, met, obj, args, loc) ->
      Lam.send k (subst_aux met) (subst_aux obj) (Ext_list.map args subst_aux) loc
  and subst_decl (id, exp) = (id, subst_aux exp)
  and subst_case (key, case) = (key, subst_aux case)
  and subst_strcase (key, case) = (key, subst_aux case)
  and subst_opt = function
    | None -> None
    | Some e -> Some (subst_aux e)
  in subst_aux lam 

end
module Lam_pass_exits : sig 
#1 "lam_pass_exits.mli"
(***********************************************************************)
(*                                                                     *)
(*                                OCaml                                *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)
(* Adapted for Javascript backend: Hongbo Zhang,                       *)


(** A pass used to optimize the exit code compilation, adaped from the compiler's
    [simplif] module
 *)



val simplify_exits : Lam.t -> Lam.t

end = struct
#1 "lam_pass_exits.ml"
(***********************************************************************)
(*                                                                     *)
(*                                OCaml                                *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)
(* Adapted for Javascript backend: Hongbo Zhang                        *)


(**
        [no_bounded_varaibles lambda]
        checks if [lambda] contains bounded variable, for
        example [Llet (str,id,arg,body) ] will fail such check.
        This is used to indicate such lambda expression if it is okay
        to inline directly since if it contains bounded variables it
        must be rebounded before inlining
*)
let rec 
  no_list args = Ext_list.for_all args no_bounded_variables 
  and no_list_snd : 'a. ('a * Lam.t ) list -> bool  = fun args ->
    Ext_list.for_all_snd  args no_bounded_variables
  and no_opt x =   
    match x with 
    | None -> true 
    | Some a -> no_bounded_variables a 
  and no_bounded_variables (l : Lam.t) =
  match l with
  | Lvar _ -> true
  | Lconst _ -> true
  | Lassign(_id, e) ->
    no_bounded_variables e
  | Lapply{fn; args; _} ->
    no_bounded_variables fn && no_list args
  | Lglobal_module _ -> true
  | Lprim {args; primitive = _ ; } ->
    no_list args
  | Lswitch(arg, sw) ->
    no_bounded_variables arg &&
    no_list_snd sw.sw_consts &&
    no_list_snd sw.sw_blocks &&
    no_opt sw.sw_failaction
  | Lstringswitch (arg,cases,default) ->
    no_bounded_variables arg &&
    no_list_snd cases && no_opt default
  | Lstaticraise (_,args) ->
    no_list args
  | Lifthenelse(e1, e2, e3) ->
    no_bounded_variables e1 && no_bounded_variables e2 && no_bounded_variables e3
  | Lsequence(e1, e2) ->
    no_bounded_variables e1 && no_bounded_variables e2
  | Lwhile(e1, e2) ->
    no_bounded_variables e1 && no_bounded_variables e2
  | Lsend (k, met, obj, args, _) ->
    no_bounded_variables met  &&
    no_bounded_variables obj &&
    no_list args
  | Lstaticcatch(e1, (_,vars), e2) ->
    vars = [] && no_bounded_variables e1 &&  no_bounded_variables e2
  | Lfunction{body;params} ->
    params = [] && no_bounded_variables body;
  | Lfor _  -> false
  | Ltrywith _ -> false
  | Llet _ ->false
  | Lletrec(decl, body) -> decl = [] && no_bounded_variables body


(*
   TODO: 
   we should have a pass called, always inlinable
   as long as its length is smaller than [exit=exit_id], for example

   {[
     switch(box_name)
       {case "":exit=178;break;
        case "b":exit=178;break;
        case "h":box_type=/* Pp_hbox */0;break;
        case "hov":box_type=/* Pp_hovbox */3;break;
        case "hv":box_type=/* Pp_hvbox */2;break;
        case "v":box_type=/* Pp_vbox */1;break;
        default:box_type=invalid_box(/* () */0);}

       switch(exit){case 178:box_type=/* Pp_box */4;break}
   ]}
*)

(** The third argument is its occurrence,
  when do the substitution, if its occurence is > 1,
  we should refresh
 *)
type lam_subst = 
  | Id of Lam.t 
  | Refresh of Lam.t

type subst_tbl = (Ident.t list * lam_subst ) Int_hashtbl.t

let to_lam x = 
  match x with 
  | Id x -> x 
  | Refresh x -> Lam_bounded_vars.refresh x 

(**
   Simplify  ``catch body with (i ...) handler''
      - if (exit i ...) does not occur in body, suppress catch
      - if (exit i ...) occurs exactly once in body,
        substitute it with handler
      - If handler is a single variable, replace (exit i ..) with it


  Note:
    In ``catch body with (i x1 .. xn) handler''
     Substituted expression is
      let y1 = x1 and ... yn = xn in
      handler[x1 <- y1 ; ... ; xn <- yn]
     For the sake of preserving the uniqueness  of bound variables.
   ASKS: This documentation seems outdated
     (No alpha conversion of ``handler'' is presently needed, since
     substitution of several ``(exit i ...)''
     occurs only when ``handler'' is a variable.)
  Note that 
           for [query] result = 2, 
           the non-inline cost is 
           {[
             var exit ;

             exit = 11;
             exit = 11;

             switch(exit){
               case exit = 11 : body ; break
             }

           ]}
           the inline cost is 

           {[
             body;
             body;
           ]}

           when [i] is negative, we can not inline in general, 
           since the outer is a traditional [try .. catch] body, 
           if it is guaranteed to be non throw, then we can inline
        *)

(** TODO: better heuristics, also if we can group same exit code [j] 
       in a very early stage -- maybe we can define our enhanced [Lambda] 
       representation and counter can be more precise, for example [apply] 
       does not need patch from the compiler

       FIXME:   when inlining, need refresh local bound identifiers
       #1438 when the action containes bounded variable 
         to keep the invariant, everytime, we do an inlining,
         we need refresh, just refreshing once is not enough
    We need to decide whether inline or not based on post-simplification
       code, since when we do the substitution 
       we use the post-simplified expression, it is more consistent
       TODO: when we do the case merging on the js side, 
       the j is not very indicative                
*)             

let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lam.t) : Lam.t = 
  let rec simplif (lam : Lam.t) = 
    match lam with 
    | Lstaticcatch (l1,(i,xs),l2) ->      
        let i_occur = query i in 
        (match i_occur , l2 with
        | 0,_ -> simplif l1
        | ( _ , Lvar _
          | _, Lconst _) (* when i >= 0  # 2316 *) ->  
          Int_hashtbl.add subst i (xs, Id (simplif l2)) ;
          simplif l1 (** l1 will inline *)
        | 1,_ when i >= 0 -> (** Ask: Note that we have predicate i >=0 *)
          Int_hashtbl.add subst i (xs, Id (simplif l2)) ;
          simplif l1 (** l1 will inline *)
        |  _ ->
          let l2 = simplif l2 in 
          (* we only inline when [l2] does not contain bound variables
             no need to refresh
          *)
          let ok_to_inline = 
            i >=0 && 
            (no_bounded_variables l2) &&
            (let lam_size = Lam_analysis.size l2 in
             (i_occur <= 2 && lam_size < Lam_analysis.exit_inline_size   )
             || (lam_size < 5 ))
          in 
          if ok_to_inline 
          then 
            begin            
              Int_hashtbl.add subst i (xs,  Id l2) ;
              simplif l1 
            end
          else Lam.staticcatch (simplif l1) (i,xs) l2)
    | Lstaticraise (i,[])  ->
      (match Int_hashtbl.find_opt subst i with
       | Some (_,handler) -> to_lam handler
       | None -> lam)      
    | Lstaticraise (i,ls) ->
      let ls = Ext_list.map  ls simplif in
      (match Int_hashtbl.find_opt subst i with
       | Some (xs, handler) -> 
         let handler = to_lam handler in 
         let ys = Ext_list.map xs Ident.rename in
         let env =
           Ext_list.fold_right2 xs ys Ident_map.empty 
             (fun x y t -> Ident_map.add t x (Lam.var y) ) in
         Ext_list.fold_right2 ys ls 
           (Lam_subst.subst  env  handler)
           (fun y l r -> Lam.let_ Strict y l r)
       | None -> Lam.staticraise i ls
      )
    | Lvar _|Lconst _  -> lam
    | Lapply {fn; args;  loc; status } -> 
      Lam.apply (simplif fn) (Ext_list.map args simplif) loc status
    | Lfunction {arity; params; body} -> 
      Lam.function_ ~arity  ~params ~body:(simplif body)
    | Llet (kind, v, l1, l2) -> 
      Lam.let_ kind v (simplif l1) (simplif l2)
    | Lletrec (bindings, body) ->
      Lam.letrec
        (Ext_list.map_snd  bindings simplif) 
        (simplif body)
    | Lglobal_module _ -> lam 
    | Lprim {primitive; args; loc} -> 
      let args = Ext_list.map args simplif in
      Lam.prim ~primitive ~args loc
    | Lswitch(l, sw) ->
      let new_l = simplif l in 
      let new_consts =  Ext_list.map_snd  sw.sw_consts simplif in 
      let new_blocks =  Ext_list.map_snd  sw.sw_blocks simplif in 
      let new_fail = Ext_option.map sw.sw_failaction simplif in       
      Lam.switch
        new_l
        { 
          sw with 
          sw_consts = new_consts ;
          sw_blocks = new_blocks; 
          sw_failaction = new_fail}
    | Lstringswitch(l,sw,d) ->
      Lam.stringswitch
        (simplif l) (Ext_list.map_snd  sw simplif)
        (Ext_option.map d simplif)
    | Ltrywith (l1, v, l2) -> 
      Lam.try_ (simplif l1) v (simplif l2)
    | Lifthenelse (l1, l2, l3) -> 
      Lam.if_ (simplif l1) (simplif l2) (simplif l3)
    | Lsequence (l1, l2) -> Lam.seq (simplif l1) (simplif l2)
    | Lwhile (l1, l2) -> Lam.while_ (simplif l1) (simplif l2)
    | Lfor (v, l1, l2, dir, l3) ->
      Lam.for_ v (simplif l1) (simplif l2) dir (simplif l3)
    | Lassign (v, l) -> 
      Lam.assign v (simplif l)
    | Lsend (k, m, o, ll, loc) ->
      Lam.send k (simplif m) (simplif o) (Ext_list.map ll simplif ) loc
  in 
  simplif lam 

let simplify_exits (lam : Lam.t) =
  let exits = Lam_exit_count.count_helper lam in
  subst_helper (Int_hashtbl.create 17 ) (Lam_exit_count.count_exit exits) lam

(* Compile-time beta-reduction of functions immediately applied:
      Lapply(Lfunction(Curried, params, body), args, loc) ->
        let paramN = argN in ... let param1 = arg1 in body
      Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock(args))], loc) ->
        let paramN = argN in ... let param1 = arg1 in body
   Assumes |args| = |params|.
*)

end
module Lam_pass_count : sig 
#1 "lam_pass_count.mli"
(***********************************************************************)
(*                                                                     *)
(*                                OCaml                                *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)
(* Adapted for Javascript backend : Hongbo Zhang,  *)

type used_info = { 
  mutable times : int ; 
  mutable captured : bool;
    (* captured in functon or loop, 
       inline in such cases should be careful
       1. can not inline mutable values
       2. avoid re-computation 
    *)
}

type occ_tbl  = used_info Ident_hashtbl.t

val dummy_info : unit -> used_info
val collect_occurs : Lam.t -> occ_tbl

val pp_occ_tbl : Format.formatter -> occ_tbl -> unit   

end = struct
#1 "lam_pass_count.ml"
(***********************************************************************)
(*                                                                     *)
(*                                OCaml                                *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)
(* Adapted for Javascript backend : Hongbo Zhang,  *)

(*A naive dead code elimination *)
type used_info = { 
  mutable times : int ; 
  mutable captured : bool;
  (* captured in functon or loop, 
     inline in such cases should be careful
     1. can not inline mutable values
     2. avoid re-computation 
  *)
}

type occ_tbl  = used_info Ident_hashtbl.t
(* First pass: count the occurrences of all let-bound identifiers *)

type local_tbl = used_info  Ident_map.t

let dummy_info () = {times =  0 ; captured = false }
(* y is untouched *)

let absorb_info (x : used_info) (y : used_info) = 
  match x, y with
  | {times = x0} , {times = y0; captured } -> 
    x.times <- x0 + y0;
    if captured then x.captured <- true

let pp_info fmt (x : used_info) = 
  Format.fprintf fmt "(<captured:%b>:%d)"  x.captured x.times

let pp_occ_tbl fmt tbl = 
  Ident_hashtbl.iter tbl (fun k v -> 
      Format.fprintf fmt "@[%a@ %a@]@." Ident.print k pp_info v 
    ) 
(* The global table [occ] associates to each let-bound identifier
   the number of its uses (as a reference):
   - 0 if never used
   - 1 if used exactly once in and not under a lambda or within a loop
       - when under a lambda, 
       - it's probably a closure
       - within a loop
       - update reference,
       niether is good for inlining
   - > 1 if used several times or under a lambda or within a loop.
   The local table [bv] associates to each locally-let-bound variable
   its reference count, as above.  [bv] is enriched at let bindings
   but emptied when crossing lambdas and loops. *)
let collect_occurs  lam : occ_tbl =
  let occ : occ_tbl = Ident_hashtbl.create 83 in

  (* Current use count of a variable. *)
  let used v = 
    match Ident_hashtbl.find_opt occ v with 
    | None -> false 
    | Some {times ; _} -> times > 0  in

  (* Entering a [let].  Returns updated [bv]. *)
  let bind_var bv ident =
    let r = dummy_info () in
    Ident_hashtbl.add occ ident r;
    Ident_map.add bv ident r  in

  (* Record a use of a variable *)
  let add_one_use bv ident  =
    match Ident_map.find_opt bv ident with 
    | Some r  -> r.times <- r.times + 1 
    | None ->
      (* ident is not locally bound, therefore this is a use under a lambda
         or within a loop.  Increase use count by 2 -- enough so
         that single-use optimizations will not apply. *)
      match Ident_hashtbl.find_opt occ ident with 
      | Some r -> absorb_info r {times = 1; captured =  true}
      | None ->
        (* Not a let-bound variable, ignore *)
        () in

  let inherit_use bv ident bid =
    let n =
      match Ident_hashtbl.find_opt occ bid with
      | None -> dummy_info ()
      | Some v -> v in
    match Ident_map.find_opt bv ident with 
    | Some r  -> absorb_info r n
    | None ->
      (* ident is not locally bound, therefore this is a use under a lambda
         or within a loop.  Increase use count by 2 -- enough so
         that single-use optimizations will not apply. *)
      match Ident_hashtbl.find_opt occ ident with 
      | Some r -> absorb_info r {n with captured = true} 
      | None ->
        (* Not a let-bound variable, ignore *)
        () in

  let rec count (bv : local_tbl) (lam : Lam.t) = 
    match lam with 
    | Lfunction{body = l} ->
      count Ident_map.empty l
    (** when entering a function local [bv] 
        is cleaned up, so that all closure variables will not be
        carried over, since the parameters are never rebound, 
        so it is fine to kep it empty
    *)
    | Lfor(_, l1, l2, dir, l3) -> 
      count bv l1;
      count bv l2; 
      count Ident_map.empty l3
    | Lwhile(l1, l2) -> count Ident_map.empty l1; count Ident_map.empty l2
    | Lvar v ->
      add_one_use bv v 
    | Llet(_, v, Lvar w, l2)  ->
      (* v will be replaced by w in l2, so each occurrence of v in l2
         increases w's refcount *)
      count (bind_var bv v) l2;
      inherit_use bv w v 
    | Llet(kind, v, l1, l2) ->
      count (bind_var bv v) l2;
      (* count [l2] first,
         If v is unused, l1 will be removed, so don't count its variables *)
      if kind = Strict || used v then count bv l1
    | Lassign(_, l) ->
      (* Lalias-bound variables are never assigned, so don't increase
         this ident's refcount *)
      count bv l
    | Lglobal_module _ -> ()
    | Lprim {args; _} -> List.iter (count bv ) args
    | Lletrec(bindings, body) ->
      List.iter (fun (v, l) -> count bv l) bindings;
      count bv body
        (** Note there is a difference here when do beta reduction for *)
    | Lapply{fn = Lfunction{params; body};  args; _}
      when  Ext_list.same_length params args ->
      count bv (Lam_beta_reduce.beta_reduce  params body args)
    (* | Lapply{fn = Lfunction{function_kind = Tupled; params; body}; *)
    (*          args = [Lprim {primitive = Pmakeblock _;  args; _}]; _} *)
    (*   when  Ext_list.same_length params  args -> *)
    (*   count bv (Lam_beta_reduce.beta_reduce   params body args) *)
    | Lapply{fn = l1; args= ll; _} ->
      count bv l1; List.iter (count bv) ll 
    | Lconst cst -> ()
    | Lswitch(l, sw) ->
      count_default bv sw ;
      count bv l;
      List.iter (fun (_, l) -> count bv l) sw.sw_consts;
      List.iter (fun (_, l) -> count bv l) sw.sw_blocks
    | Lstringswitch(l, sw, d) ->
      count bv l ;
      List.iter (fun (_, l) -> count bv l) sw ;
      begin match d with
        | Some d -> count bv d 
        | None -> ()
      end        
    (* x2 for native backend *)
    (* begin match sw with *)
    (* | []|[_] -> count bv d *)
    (* | _ -> count bv d ; count bv d *)
    (* end *)      
    | Lstaticraise (i,ls) -> List.iter (count bv) ls
    | Lstaticcatch(l1, (i,_), l2) -> count bv l1; count bv l2
    | Ltrywith(l1, v, l2) -> count bv l1; count bv l2
    | Lifthenelse(l1, l2, l3) -> count bv l1; count bv l2; count bv l3
    | Lsequence(l1, l2) -> count bv l1; count bv l2 
    | Lsend(_, m, o, ll, _) -> 
      count bv m ;
      count bv o;
      List.iter (count bv) ll
  and count_default bv sw = 
    match sw.sw_failaction with
    | None -> ()
    | Some al ->
      if not sw.sw_numconsts && not sw.sw_numblocks
      then 
        begin (* default action will occur twice in native code *)
          count bv al ; count bv al
        end 
      else 
        begin (* default action will occur once *)
          assert (not sw.sw_numconsts || not sw.sw_numblocks) ;
          count bv al
        end
  in
  count Ident_map.empty  lam;
  occ


end
module Lam_pass_eliminate_ref : sig 
#1 "lam_pass_eliminate_ref.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


exception Real_reference 

val eliminate_ref : 
    Ident.t -> 
    Lam.t -> 
    Lam.t








end = struct
#1 "lam_pass_eliminate_ref.ml"
(***********************************************************************)
(*                                                                     *)
(*                                OCaml                                *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)
(* Adapted for Javascript backend : Hongbo Zhang,  *)




exception Real_reference

let rec eliminate_ref id (lam : Lam.t) = 
  match lam with  (** we can do better escape analysis in Javascript backend *)
  | Lvar v ->
    if Ident.same v id then raise_notrace Real_reference else lam
  | Lprim {primitive = Pfield (0,_); args =  [Lvar v]} when Ident.same v id ->
    Lam.var id
  | Lfunction{params; body} as lam ->
    if Ident_set.mem (Lam_free_variables.pass_free_variables  lam) id (*TODO: optmization: no need construct*)
    then raise_notrace Real_reference
    else lam
  (* In Javascript backend, its okay, we can reify it later
     a failed case 
     {[
       for i = .. 
           let v = ref 0 
               for j = .. 
                   incr v 
                     a[j] = ()=>{!v}

     ]}
     here v is captured by a block, and it's a loop mutable value,
     we have to generate 
     {[
       for i = .. 
           let v = ref 0 
               (function (v){for j = .. 
                                   a[j] = ()=>{!v}}(v)

     ]}
     now, v is a real reference 
     TODO: we can refine analysis in later
  *)
  (* Lfunction(kind, params, eliminate_ref id body) *)
  | Lprim {primitive = Psetfield(0,_); 
           args =  [Lvar v; e]} when Ident.same v id ->
    Lam.assign id (eliminate_ref id e)
  | Lprim {primitive = Poffsetref delta ; 
           args =  [Lvar v]; loc } when Ident.same v id ->
    Lam.assign id (Lam.prim ~primitive:(Poffsetint delta) ~args:[Lam.var id] loc)
  | Lconst _  -> lam
  | Lapply{fn = e1; args =  el;  loc; status} ->
    Lam.apply 
      (eliminate_ref id e1)
      (Ext_list.map  el (eliminate_ref id))
      loc status
  | Llet(str, v, e1, e2) ->
    Lam.let_ str v (eliminate_ref id e1) (eliminate_ref id e2)
  | Lletrec(idel, e2) ->
    Lam.letrec
      (Ext_list.map idel (fun (v, e) -> (v, eliminate_ref id e)))
      (eliminate_ref id e2)
  | Lam.Lglobal_module _ -> lam     
  | Lprim {primitive ; args ; loc} ->
    Lam.prim  ~primitive ~args:(Ext_list.map args (eliminate_ref id)) loc
  | Lswitch(e, sw) ->
    Lam.switch(eliminate_ref id e)
      {sw_numconsts = sw.sw_numconsts;
       sw_consts =
         Ext_list.map sw.sw_consts (fun (n, e) -> (n, eliminate_ref id e)) ;
       sw_numblocks = sw.sw_numblocks;
       sw_blocks =
         Ext_list.map sw.sw_blocks (fun (n, e) -> (n, eliminate_ref id e)) ;
       sw_failaction =
         match sw.sw_failaction with 
         | None -> None 
         | Some x -> Some (eliminate_ref id x)
          }
  | Lstringswitch(e, sw, default) ->
    Lam.stringswitch
      (eliminate_ref id e)
      (Ext_list.map  sw (fun (s, e) -> (s, eliminate_ref id e)))
      (match default with 
      | None -> None 
      | Some x ->  Some (eliminate_ref id x))
  | Lstaticraise (i,args) ->
    Lam.staticraise i (Ext_list.map args (eliminate_ref id) )
  | Lstaticcatch(e1, i, e2) ->
    Lam.staticcatch (eliminate_ref id e1) i (eliminate_ref id e2)
  | Ltrywith(e1, v, e2) ->
    Lam.try_ (eliminate_ref id e1) v (eliminate_ref id e2)
  | Lifthenelse(e1, e2, e3) ->
    Lam.if_ (eliminate_ref id e1) (eliminate_ref id e2) (eliminate_ref id e3)
  | Lsequence(e1, e2) ->
    Lam.seq (eliminate_ref id e1) (eliminate_ref id e2)
  | Lwhile(e1, e2) ->
    Lam.while_ (eliminate_ref id e1) (eliminate_ref id e2)
  | Lfor(v, e1, e2, dir, e3) ->
    Lam.for_ v
      (eliminate_ref id e1) 
      (eliminate_ref id e2)
      dir
      (eliminate_ref id e3)
  | Lassign(v, e) ->
    Lam.assign v (eliminate_ref id e)
  | Lsend(k, m, o, el, loc) ->
    Lam.send k 
      (eliminate_ref id m) (eliminate_ref id o)
      (Ext_list.map el (eliminate_ref id)) loc
  



end
module Lam_pass_lets_dce : sig 
#1 "lam_pass_lets_dce.mli"
(***********************************************************************)
(*                                                                     *)
(*                                OCaml                                *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)
(* Adapted for Javascript backend: Hongbo Zhang                        *)

(**
   This pass would do beta reduction, and dead code elimination (adapted from compiler's built-in [Simplif] module )

   1. beta reduction -> Llet (Strict )
  
   2. The global table [occ] associates to each let-bound identifier
   the number of its uses (as a reference):
     - 0 if never used
     - 1 if used exactly once in and *not under a lambda or within a loop
     - > 1 if used several times or under a lambda or within a loop.

   The local table [bv] associates to each locally-let-bound variable
   its reference count, as above.  [bv] is enriched at let bindings
   but emptied when crossing lambdas and loops. 

   For this pass, when it' used under a lambda or within a loop, we don't do anything,
   in theory, we can still do something if it's pure but we are conservative here.

   [bv] is used to help caculate [occ] it is not useful outside

 *)
val simplify_lets :  Lam.t -> Lam.t

end = struct
#1 "lam_pass_lets_dce.ml"
(***********************************************************************)
(*                                                                     *)
(*                                OCaml                                *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)
(* Adapted for Javascript backend : Hongbo Zhang,  *)


let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam = 
  let subst : Lam.t Ident_hashtbl.t = Ident_hashtbl.create 32 in
  let string_table : string Ident_hashtbl.t = Ident_hashtbl.create 32 in  
  let used v = (count_var v ).times > 0 in
  let rec simplif (lam : Lam.t) = 
    match lam with 
    | Lvar v  -> Ident_hashtbl.find_default subst v lam 
    | Llet( (Strict | Alias | StrictOpt) , v, Lvar w, l2) 
      ->
      Ident_hashtbl.add subst v (simplif (Lam.var w));
      simplif l2
    | Llet(Strict as kind,
           v, (Lprim {primitive = (Pmakeblock(0, tag_info, Mutable) 
                                   as primitive); 
                      args = [linit] ; loc}), lbody)
      ->
      let slinit = simplif linit in
      let slbody = simplif lbody in
      begin 
        try (** TODO: record all references variables *)
          Lam_util.refine_let
            ~kind:Variable v slinit
             (Lam_pass_eliminate_ref.eliminate_ref v slbody)
        with Lam_pass_eliminate_ref.Real_reference ->
          Lam_util.refine_let 
            ~kind v (Lam.prim ~primitive ~args:[slinit] loc)
            slbody
      end
    | Llet(Alias, v, l1, l2) ->
      (** For alias, [l1] is pure, we can always inline,
          when captured, we should avoid recomputation
      *)
      begin 
        match count_var v, l1  with
        | {times = 0; _}, _  -> simplif l2 
        | {times = 1; captured = false }, _ 
        | {times = 1; captured = true }, (Lconst _ | Lvar _)
        |  _, (Lconst 
                 ((
                     Const_int _ | Const_char _ | Const_float _ | Const_int32 _ 
                     | Const_nativeint _ )
                 | Const_pointer _ |Const_js_true | Const_js_false | Const_js_undefined) (* could be poly-variant [`A] -> [65a]*)
              | Lprim {primitive = Pfield (_);
                       args = [ 
                         Lglobal_module _
                       ]}
              ) 
          (* Const_int64 is no longer primitive
             Note for some constant which is not 
             inlined, we can still record it and
             do constant folding independently              
          *)
          ->
          Ident_hashtbl.add subst v (simplif l1); simplif l2
        | _, Lconst (Const_string s ) -> 
          (** only "" added for later inlining *)
          Ident_hashtbl.add string_table v s;
          Lam.let_ Alias v l1 (simplif l2)
          (* we need move [simplif l2] later, since adding Hashtbl does have side effect *)
        | _ -> Lam.let_ Alias v (simplif l1) (simplif l2)
        (* for Alias, in most cases [l1] is already simplified *)
      end
    | Llet(StrictOpt as kind, v, l1, lbody) ->
      (** can not be inlined since [l1] depend on the store
          {[
            let v = [|1;2;3|]
          ]}
          get [StrictOpt] here,  we can not inline v, 
          since the value of [v] can be changed
          
          GPR #1476 
          Note to pass the sanitizer, we do need remove dead code (not just best effort)
          This logic is tied to {!Lam_pass_count.count}
          {[
            if kind = Strict || used v then count bv l1
          ]}
          If the code which should be removed is not removed, it will hold references 
          to other variables which is already removed.
      *)
      if not @@ used v 
      then simplif lbody (* GPR #1476 *)
      else
        begin match l1 with 
        | (Lprim {primitive = (Pmakeblock(0, tag_info, Mutable) 
                                    as primitive); 
                       args = [linit] ; loc})
          -> 
          let slinit = simplif linit in
          let slbody = simplif lbody in
          begin 
            try (** TODO: record all references variables *)
              Lam_util.refine_let
                ~kind:Variable v slinit
                (Lam_pass_eliminate_ref.eliminate_ref v slbody)
            with Lam_pass_eliminate_ref.Real_reference ->
              Lam_util.refine_let 
                ~kind v (Lam.prim ~primitive ~args:[slinit] loc)
                slbody
          end

        | _ -> 
          let l1 = simplif l1 in         
          begin match l1 with 
            | Lconst(Const_string s) -> 
              Ident_hashtbl.add string_table v s; 
              (* we need move [simplif lbody] later, since adding Hashtbl does have side effect *)
              Lam.let_ Alias v l1 (simplif lbody)
            | _ -> 
              Lam_util.refine_let ~kind v l1 (simplif lbody)
          end  
        end
    (* TODO: check if it is correct rollback to [StrictOpt]? *)

    | Llet((Strict | Variable as kind), v, l1, l2) -> 
      if not @@ used v 
      then
        let l1 = simplif l1 in
        let l2 = simplif l2 in
        if Lam_analysis.no_side_effects l1 
        then l2 
        else Lam.seq l1 l2
      else 
        let l1 = (simplif l1) in 
        
         begin match kind, l1 with 
         | Strict, Lconst((Const_string s))
           -> 
            Ident_hashtbl.add string_table v s;
            Lam.let_ Alias v l1 (simplif l2)
         | _ -> 
           Lam_util.refine_let ~kind v l1 (simplif l2)
        end
    | Lsequence(l1, l2) -> Lam.seq (simplif l1) (simplif l2)

    | Lapply{fn = Lfunction{params; body};  args; _}
      when  Ext_list.same_length params args ->
      simplif (Lam_beta_reduce.beta_reduce  params body args)
    (* | Lapply{ fn = Lfunction{function_kind = Tupled; params; body}; *)
    (*           args = [Lprim {primitive = Pmakeblock _;  args; _}]; _} *)
    (*   (\** TODO: keep track of this parameter in ocaml trunk, *)
    (*       can we switch to the tupled backend? *)
    (*   *\) *)
    (*   when  Ext_list.same_length params  args -> *)
    (*   simplif (Lam_beta_reduce.beta_reduce params body args) *)

    | Lapply{fn = l1;args =  ll; loc; status} -> 
      Lam.apply (simplif l1) (Ext_list.map  ll simplif) loc status
    | Lfunction{arity; params; body = l} ->
      Lam.function_ ~arity ~params ~body:(simplif l)
    | Lconst _ -> lam
    | Lletrec(bindings, body) ->
      Lam.letrec 
        (Ext_list.map_snd  bindings simplif) 
        (simplif body)
    | Lprim {primitive=Pstringadd; args = [l;r]; loc } -> 
      begin
        let l' = simplif l in 
        let r' = simplif r in
        let opt_l = 
          match l' with 
          | Lconst((Const_string ls)) -> Some ls 
          | Lvar i -> Ident_hashtbl.find_opt string_table i 
          | _ -> None in 
        match opt_l with   
        | None -> Lam.prim ~primitive:Pstringadd ~args:[l';r'] loc 
        | Some l_s -> 
          let opt_r = 
            match r' with 
            | Lconst ( (Const_string rs)) -> Some rs 
            | Lvar i -> Ident_hashtbl.find_opt string_table i 
            | _ -> None in 
            begin match opt_r with 
            | None -> Lam.prim ~primitive:Pstringadd ~args:[l';r'] loc 
            | Some r_s -> 
              Lam.const (Const_string(l_s^r_s))
            end
      end

    | Lprim {primitive = (Pstringrefu|Pstringrefs) as primitive ; 
      args = [l;r] ; loc 
      } ->  (* TODO: introudce new constant *)
      let l' = simplif l in 
      let r' = simplif r in 
      let opt_l =
         match l' with 
         | Lconst (Const_string ls) -> 
            Some ls 
         | Lvar i -> Ident_hashtbl.find_opt string_table i 
         | _ -> None in 
      begin match opt_l with 
      | None -> Lam.prim ~primitive ~args:[l';r'] loc 
      | Some l_s -> 
        match r with 
        |Lconst((Const_int i)) -> 
          if i < String.length l_s && i >=0  then
            Lam.const ((Const_char l_s.[i]))
          else 
            Lam.prim ~primitive ~args:[l';r'] loc 
        | _ -> 
          Lam.prim ~primitive ~args:[l';r'] loc 
      end    
    | Lglobal_module _ -> lam    
    | Lprim {primitive; args; loc} 
      -> Lam.prim ~primitive ~args:(Ext_list.map args simplif) loc
    | Lswitch(l, sw) ->
      let new_l = simplif l
      and new_consts =  Ext_list.map_snd sw.sw_consts simplif
      and new_blocks =  Ext_list.map_snd sw.sw_blocks simplif
      and new_fail = Ext_option.map sw.sw_failaction simplif
      in
      Lam.switch
        new_l
        {sw with sw_consts = new_consts ; sw_blocks = new_blocks;
                 sw_failaction = new_fail}
    | Lstringswitch (l,sw,d) ->
      Lam.stringswitch
        (simplif l) (Ext_list.map_snd  sw simplif)
        (Ext_option.map d simplif)
    | Lstaticraise (i,ls) ->
      Lam.staticraise i (Ext_list.map ls simplif)
    | Lstaticcatch(l1, (i,args), l2) ->
      Lam.staticcatch (simplif l1) (i,args) (simplif l2)
    | Ltrywith(l1, v, l2) -> Lam.try_ (simplif l1) v (simplif l2)
    | Lifthenelse(l1, l2, l3) -> 
      Lam.if_ (simplif l1) (simplif l2) (simplif l3)
    | Lwhile(l1, l2) 
      -> 
      Lam.while_ (simplif l1) (simplif l2)
    | Lfor(v, l1, l2, dir, l3) ->
      Lam.for_ v (simplif l1) (simplif l2) dir (simplif l3)
    | Lassign(v, l) -> Lam.assign v (simplif l)
    | Lsend(k, m, o, ll, loc) ->
      Lam.send k (simplif m) (simplif o) (Ext_list.map ll simplif) loc
  in simplif lam ;;


(* To transform let-bound references into variables *)
let apply_lets  occ lambda = 
  let count_var v =
    match
      Ident_hashtbl.find_opt occ v 
    with
    | None -> Lam_pass_count.dummy_info ()
    | Some  v -> v in
  lets_helper count_var lambda      

let simplify_lets  (lam : Lam.t) = 
  let occ =  Lam_pass_count.collect_occurs  lam in 

  apply_lets  occ   lam

end
module Lam_inline_util : sig 
#1 "lam_inline_util.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Utilities for lambda inlining *)

val maybe_functor : string -> bool

val should_be_functor : string -> Lam.t -> bool 

end = struct
#1 "lam_inline_util.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)







(* TODO: add a context, like 
    [args]
    [Lfunction(params,body)]
 *)


let maybe_functor (name : string) = 
  name.[0] >= 'A' && name.[0] <= 'Z'


let should_be_functor (name : string) (lam : Lam.t) = 
  maybe_functor name  &&
  (match lam with Lfunction _ -> true | _ -> false)



end
module Lam_pass_remove_alias : sig 
#1 "lam_pass_remove_alias.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** Keep track of the global module Aliases *) 

(**
    One way:  guarantee that all global aliases *would be removed* ,
    it will not be aliased 
    
    So the only remaining place for globals is either 
    just  Pgetglobal in functor application or 
    `Lprim (Pfield( i ), [Pgetglobal])`

    This pass does not change meta  data
*)

val simplify_alias : 
  Lam_stats.t -> 
  Lam.t ->
  Lam.t



end = struct
#1 "lam_pass_remove_alias.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)





let id_is_for_sure_true_in_boolean (tbl : Lam_stats.ident_tbl) id = 
  match Ident_hashtbl.find_opt tbl id with 
  | Some (ImmutableBlock(_))
  | Some (Normal_optional _ )
  | Some (MutableBlock _) -> true
  | Some 
      (Constant _  | Module _ | FunctionId _ | Exception | Parameter | NA
      | OptionalBlock(_, (Undefined | Null | Null_undefined))
      )

  | None -> false

let simplify_alias 
    (meta : Lam_stats.t)
    (lam : Lam.t) 
  :  Lam.t  = 

  let rec simpl  (lam : Lam.t) : Lam.t = 
    match lam with 
    | Lvar v ->
      begin match (Ident_hashtbl.find_opt meta.alias_tbl v) with
        | None -> lam
        | Some v ->
          if Ident.persistent v then 
            Lam.global_module v 
          else 
            Lam.var v 
            (* This is wrong
                currently alias table has info 
                include -> Array

                however, (field id Array/xx) 
                does not result in a reduction, so we 
                still pick the old one (field id include)
                which makes dead code elimination wrong
            *)
      end
    (* GLOBAL module needs to be propogated *)
    | Llet (kind, k, (Lglobal_module i as g), l )
      -> 
      (* This is detection of global MODULE inclusion
          we need track all global module aliases, when it's
          passed as a parameter(escaped), we need do the expansion
          since global module access is not the same as local module
          TODO: 
          since we aliased k, so it's safe to remove it?
          no, we should not shake away code just by [Ident_set.mem k meta.export_idents ]
          in that case, we should provide strong guarantee that all [k] will be substitued
      *)
      let v = simpl l in
      Lam.let_ kind k g v
    (* in this case it is preserved, but will still be simplified 
        for the inner expression
    *)

    | Lprim {primitive = (Pfield (i,_) as primitive); args =  [arg]; loc} -> 
      (* ATTENTION: 
         Main use case, we should detect inline all immutable block .. *)
      begin match  simpl  arg with 
        | Lglobal_module g 
          ->    
          Lam.prim 
            ~primitive:(Pfield(i,Lam_compat.Fld_na))
            ~args:[Lam.global_module g ]
            loc
        | Lvar v as l-> 
          Lam_util.field_flatten_get (fun _ -> Lam.prim ~primitive ~args:[l] loc )
            v  i meta.ident_tbl 
        | _ ->  
          Lam.prim ~primitive ~args:[simpl arg] loc 
      end
    | Lprim {primitive = Pval_from_option | Pval_from_option_not_nest; args = [Lvar v]} as x -> 
      begin match Ident_hashtbl.find_opt meta.ident_tbl v with 
        | Some (OptionalBlock (l,_)) -> l
        | _ -> x 
      end 
    | Lglobal_module _ -> lam 
    | Lprim {primitive; args; loc } 
      -> Lam.prim ~primitive ~args:(Ext_list.map args simpl) loc

    | Lifthenelse(Lprim {primitive = Pis_not_none; args =  [Lvar id ]} as l1, l2, l3) 
      -> 
      begin match Ident_hashtbl.find_opt meta.ident_tbl id with 
        | Some (ImmutableBlock ( _) | (MutableBlock _  ) 
               | Normal_optional _)
          -> simpl l2 
        | Some (OptionalBlock(l, Null)) -> 
          Lam.if_ 
            (Lam.not_ (Location.none) ( Lam.prim ~primitive:Pis_null ~args:[l] Location.none)) 
            (simpl l2) (simpl l3)
        | Some (OptionalBlock(l, Undefined)) -> 
          Lam.if_
            (Lam.not_  Location.none (Lam.prim ~primitive:Pis_undefined ~args:[l] Location.none))
            (simpl l2)   (simpl l3)
        | Some (OptionalBlock(l, Null_undefined)) -> 
          Lam.if_
            (Lam.not_ Location.none
               ( Lam.prim ~primitive:Pis_null_undefined  ~args:[l] Location.none) )  
            (simpl l2) (simpl l3)
        | Some _
        | None -> Lam.if_ l1 (simpl l2) (simpl l3)
      end
    (* could be the code path
       {[ match x with 
         | h::hs -> 
       ]}
    *)             
    | Lifthenelse (l1, l2, l3) -> 
      begin match l1 with 
        | Lvar id when id_is_for_sure_true_in_boolean meta.ident_tbl id-> 
          simpl l2 
        | _ -> 
          Lam.if_ (simpl  l1) (simpl  l2) (simpl  l3)
      end   
    | Lconst _ -> lam
    | Llet(str, v, l1, l2) ->
      Lam.let_ str v (simpl l1) (simpl l2 )
    | Lletrec(bindings, body) ->
      let bindings = Ext_list.map_snd  bindings simpl in 
      Lam.letrec bindings (simpl body) 

    (* complicated 
        1. inline this function
        2. ...
        exports.Make=
        function(funarg)
    {var $$let=Make(funarg);
      return [0, $$let[5],... $$let[16]]}
    *)      
    | Lapply{fn = 
               Lprim {primitive = Pfield (index, _) ;
                      args = [ Lglobal_module ident ];
                      _} as l1;
             args; loc ; status} ->
      begin
        match  Lam_compile_env.cached_find_ml_id_pos ident index meta.env with                   
        | {closed_lambda=Some Lfunction{params; body; _} } 
          (** be more cautious when do cross module inlining *)
          when
            Ext_list.same_length params args &&
            Ext_list.for_all args (fun arg ->
                match arg with 
                | Lvar p -> 
                  begin 
                    match Ident_hashtbl.find_opt meta.ident_tbl p with
                    | Some v  -> v <> Parameter
                    | None -> true 
                  end
                |  _ -> true 
              ) -> 
          simpl @@
          Lam_beta_reduce.propogate_beta_reduce
            meta params body args
        | _ -> 
          Lam.apply (simpl l1) (Ext_list.map args simpl) loc status


      end
    (* Function inlining interact with other optimizations...

        - parameter attributes
        - scope issues 
        - code bloat 
    *)      
    | Lapply{fn = (Lvar v as fn);  args; loc ; status} ->
      (* Check info for always inlining *)

      (* Ext_log.dwarn __LOC__ "%s/%d" v.name v.stamp;     *)
      let normal () = Lam.apply ( simpl fn) (Ext_list.map args simpl) loc status in
      begin 
        match Ident_hashtbl.find_opt meta.ident_tbl v with
        | Some (FunctionId {lambda = Some(Lfunction {params; body} as _m,
                                          rec_flag)
                           })
          -> 

          if Ext_list.same_length args params (* && false *)
          then               
            if Lam_inline_util.maybe_functor v.name  
            (* && (Ident_set.mem v meta.export_idents) && false *)
            then 
              (* TODO: check l1 if it is exported, 
                 if so, maybe not since in that case, 
                 we are going to have two copy?
              *)

              (* Check: recursive applying may result in non-termination *)
              begin
                (* Ext_log.dwarn __LOC__ "beta .. %s/%d" v.name v.stamp ; *)
                simpl (Lam_beta_reduce.propogate_beta_reduce meta params body args) 
              end
            else 
            if (* Lam_analysis.size body < Lam_analysis.small_inline_size *)
              Lam_analysis.ok_to_inline_fun_when_app ~body params args 
            then 

              (* let param_map =  *)
              (*   Lam_analysis.free_variables meta.export_idents  *)
              (*     (Lam_analysis.param_map_of_list params) body in *)
              (* let old_count = List.length params in *)
              (* let new_count = Ident_map.cardinal param_map in *)
              let param_map = 
                Lam_closure.is_closed_with_map 
                  meta.export_idents params body in
              let is_export_id = Ident_set.mem meta.export_idents v in
              match is_export_id, param_map with 
              | false, (_, param_map)
              | true, (true, param_map) -> 
                begin match rec_flag with 
                  
                  | Lam_rec  ->  Lam_beta_reduce.propogate_beta_reduce_with_map meta param_map params body args
                  | Lam_self_rec -> normal ()
                  | Lam_non_rec -> 
                    simpl 
                      (Lam_beta_reduce.propogate_beta_reduce_with_map meta param_map params body args)
                end
              | _ -> normal ()
            else 
              normal ()
          else
            normal ()
        | Some _
        | None -> normal ()

      end

    | Lapply{ fn = Lfunction{ params; body}; args; _}
      when  Ext_list.same_length params args ->
      simpl (Lam_beta_reduce.propogate_beta_reduce meta params body args)
    (* | Lapply{ fn = Lfunction{function_kind =  Tupled;  params; body};  *)
    (*          args = [Lprim {primitive = Pmakeblock _; args; _}]; _} *)
    (*   (\** TODO: keep track of this parameter in ocaml trunk, *)
    (*       can we switch to the tupled backend? *)
    (*   *\) *)
    (*   when  Ext_list.same_length params args -> *)
    (*   simpl (Lam_beta_reduce.propogate_beta_reduce meta params body args) *)

    | Lapply {fn = l1; args =  ll;  loc ; status} ->
      Lam.apply (simpl  l1) (Ext_list.map ll simpl) loc status
    | Lfunction {arity; params; body = l}
      -> Lam.function_ ~arity ~params  ~body:(simpl  l)
    | Lswitch (l, {sw_failaction; 
                   sw_consts; 
                   sw_blocks;
                   sw_numblocks;
                   sw_numconsts;
                  }) ->
      Lam.switch (simpl  l)
        {sw_consts = 
           Ext_list.map_snd  sw_consts simpl;
         sw_blocks = Ext_list.map_snd sw_blocks simpl;
         sw_numconsts;
         sw_numblocks;
         sw_failaction = Ext_option.map sw_failaction simpl
        }
    | Lstringswitch(l, sw, d) ->
      Lam.stringswitch (simpl  l )
        (Ext_list.map_snd  sw simpl)
        (Ext_option.map d simpl)
    | Lstaticraise (i,ls) -> 
      Lam.staticraise i (Ext_list.map ls simpl )
    | Lstaticcatch (l1, ids, l2) -> 
      Lam.staticcatch (simpl  l1) ids (simpl  l2)
    | Ltrywith (l1, v, l2) -> Lam.try_ (simpl  l1) v (simpl  l2)
    | Lsequence(l1, l2)
      -> Lam.seq (simpl  l1) (simpl  l2)
    | Lwhile(l1, l2)
      -> Lam.while_ (simpl  l1) (simpl l2)
    | Lfor(flag, l1, l2, dir, l3)
      -> 
      Lam.for_ flag (simpl  l1) (simpl  l2) dir (simpl  l3)
    | Lassign(v, l) ->
      (* Lalias-bound variables are never assigned, so don't increase
         v's refsimpl *)
      Lam.assign v (simpl  l)
    | Lsend (u, m, o, ll, v) 
      -> 
      Lam.send u (simpl m) (simpl o) (Ext_list.map ll simpl) v
  in 
  simpl lam



end
module Lam_stats_export : sig 
#1 "lam_stats_export.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)




val get_dependent_module_effect:
  Lam_stats.t -> 
  string option ->
  Lam_module_ident.t list ->
  string option

val export_to_cmj : 
  Lam_stats.t ->
  Js_cmj_format.effect ->
  Lam.t Ident_map.t ->
  Js_cmj_format.cmj_case ->
  Js_cmj_format.t


end = struct
#1 "lam_stats_export.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






let pp = Format.fprintf 
(* we should exclude meaninglist names and do the convert as well *)

(* let meaningless_names  = ["*opt*"; "param";] *)



let single_na = Js_cmj_format.single_na

let values_of_export 
  (meta : Lam_stats.t) 
  (export_map  : Lam.t Ident_map.t)
  : Js_cmj_format.cmj_value String_map.t 
  = 
  Ext_list.fold_left meta.exports  String_map.empty    
    (fun  acc x ->
       let arity : Js_cmj_format.arity =
         match Ident_hashtbl.find_opt meta.ident_tbl x with 
         | Some (FunctionId {arity ; _}) -> Single arity 
         | Some (ImmutableBlock(elems)) ->  
           Submodule(Ext_array.map elems (fun x -> 
               match x with 
               | NA -> Lam_arity.na
               | SimpleForm lam -> Lam_arity_analysis.get_arity  meta lam)
             )
         | Some _ 
         | None ->
           begin match Ident_map.find_opt export_map x with 
             | Some (Lprim {primitive = Pmakeblock (_,_, Immutable); args }) ->
               Submodule (Ext_array.of_list_map args (fun lam -> 
                   Lam_arity_analysis.get_arity meta lam))
             | Some _
             | None -> single_na
           end
       in
       let persistent_closed_lambda = 
         if not !Js_config.cross_module_inline then None
         else match Ident_map.find_opt export_map x with 
         | Some lambda  -> 
           if Lam_analysis.safe_to_inline lambda
           (* when inlning a non function, we have to be very careful,
              only truly immutable values can be inlined
           *)
           then
             if Lam_inline_util.should_be_functor x.name lambda (* can also be submodule *)
             then
               if Lam_closure.is_closed lambda (* TODO: seriealize more*)
               then Some lambda
               else None
             else 
               let lam_size = Lam_analysis.size lambda in
               (* TODO:
                  1. global need re-assocate when do the beta reduction 
                  2. [lambda_exports] is not precise
               *)
               let free_variables =
                 Lam_closure.free_variables Ident_set.empty Ident_map.empty lambda in
               if  lam_size < Lam_analysis.small_inline_size  && 
                   Ident_map.is_empty free_variables
               then 
                 begin
                   Ext_log.dwarn ~__POS__ "%s recorded for inlining @." x.name ;
                   Some lambda
                 end
               else None
           else
             None
         | None -> None  in 
       String_map.add  acc x.name  Js_cmj_format.{arity ; persistent_closed_lambda }
    )

(* ATTENTION: all runtime modules, if it is not hard required, 
  it should be okay to not reference it 
*)
let get_dependent_module_effect 
  (meta : Lam_stats.t) 
  (maybe_pure : string option) 
  (external_ids : Lam_module_ident.t list) = 
  if maybe_pure = None then
    let non_pure_module =  
      Ext_list.find_first_not external_ids
        (fun id -> 
           id.kind = Runtime ||
           Lam_compile_env.query_and_add_if_not_exist id 
             (Has_env meta.env )
             ~not_found:(fun _ -> false ) 
             ~found:(fun {pure} -> pure)
        ) in 
    Ext_option.map  non_pure_module (fun x -> Lam_module_ident.name x)
  else 
    maybe_pure



(* Note that 
   [lambda_exports] is 
   lambda expression to be exported
   for the js backend, we compile to js 
   for the inliner, we try to seriaize it -- 
   relies on other optimizations to make this happen
   {[
     exports.Make = function () {.....}
   ]}
   TODO: check that we don't do this in browser environment
*)
let export_to_cmj 
    (meta : Lam_stats.t ) 
    effect 
    export_map
    cmj_case
  : Js_cmj_format.t = 
  let values =  values_of_export meta export_map in
  
  Js_cmj_format.mk
    ~values
    ~effect 
    ~npm_package_path: (Js_packages_state.get_packages_info ())
   ~cmj_case 
    (* FIXME: make sure [-o] would not change its case 
      add test for ns/non-ns
    *)
  


end
module Lam_compile_main : sig 
#1 "lam_compile_main.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** BuckleScript entry point in the OCaml compiler *) 

(** Compile and register the hook of function to compile  a lambda to JS IR 
 *)

(** For toplevel, [filename] is [""] which is the same as
    {!Env.get_unit_name ()}
 *)
val compile :  
  string -> 
  Env.t ->   
  Lambda.lambda -> 
  J.deps_program

val lambda_as_module :  
  Env.t ->
  string ->
  Lambda.lambda -> 
  unit

end = struct
#1 "lam_compile_main.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








module E = Js_exp_make 
module S = Js_stmt_make  

let get_cmj_case output_prefix : Ext_namespace.file_kind = 
  let little = 
    Ext_char.is_lower_case (Filename.basename output_prefix).[0] 
  in 
  match little, !Js_config.bs_suffix with 
  | true, true -> Little_bs
  | true, false -> Little_js
  | false, true -> Upper_bs 
  | false, false -> Upper_js
  

let compile_group (meta : Lam_stats.t) 
    (x : Lam_group.t) : Js_output.t  = 
  match x with 
  (* 
        We need

        2. [E.builtin_dot] for javascript builtin
        3. [E.mldot]
     *)
  (* ATTENTION: check {!Lam_compile_global} for consistency  *)      
  (** Special handling for values in [Pervasives] *)  
  (* 
         we delegate [stdout, stderr, and stdin] into [caml_io] module, 
         the motivation is to help dead code eliminatiion, it's helpful 
         to make those parts pure (not a function call), then it can be removed 
         if unused 
      *)                     

  (* QUICK hack to make hello world example nicer,
     Note the arity of [print_endline] is already analyzed before, 
     so it should be safe
  *)

  | Single (kind, id, lam) -> 
    (* let lam = Optimizer.simplify_lets [] lam in  *)
    (* can not apply again, it's wrong USE it with care*)
    (* ([Js_stmt_make.comment (Gen_of_env.query_type id  env )], None)  ++ *)
    Lam_compile.compile_lambda { continuation = Declare (kind, id);
                                    jmp_table = Lam_compile_context.empty_handler_map;
                                    meta
                                  } lam

  | Recursive id_lams   -> 
    Lam_compile.compile_recursive_lets 
      { continuation = EffectCall ReturnFalse; 
        jmp_table = Lam_compile_context.empty_handler_map;
        meta
      } 
      id_lams
  | Nop lam -> (* TODO: Side effect callls, log and see statistics *)
    Lam_compile.compile_lambda {continuation = EffectCall ReturnFalse;
                                jmp_table = Lam_compile_context.empty_handler_map;
                                meta
                               } lam

;;

 (** Also need analyze its depenency is pure or not *)
let no_side_effects (rest : Lam_group.t list) : string option = 
  Ext_list.find_opt rest (fun x -> 
      match x with 
      | Single(kind,id,body) -> 
        begin 
          match kind with 
          | Strict | Variable -> 
            if not @@ Lam_analysis.no_side_effects body 
            then Some  (Printf.sprintf "%s" id.name)
            else None
          | _ -> None
        end
      | Recursive bindings -> 
        Ext_list.find_opt  bindings (fun (id,lam) -> 
            if not @@ Lam_analysis.no_side_effects lam 
            then Some (Printf.sprintf "%s" id.Ident.name )
            else None
          )
      | Nop lam -> 
        if not @@ Lam_analysis.no_side_effects lam 
        then 
          (*  (Lam_util.string_of_lambda lam) *)
          Some ""
        else None (* TODO :*))


let _d  = fun env s lam -> 

    lam

(** Actually simplify_lets is kind of global optimization since it requires you to know whether 
    it's used or not 
*)
let compile  
    (output_prefix : string) 
    (env : Env.t) 
    (lam : Lambda.lambda)   = 
  let export_idents = Translmod.get_export_identifiers() in
  let export_ident_sets = Ident_set.of_list export_idents in 
  (* To make toplevel happy - reentrant for js-demo *)
  let () = 
      
    Lam_compile_env.reset () ;
  in 
  let lam, may_required_modules = Lam_convert.convert export_ident_sets lam in 

  let _j = Js_pass_debug.dump in
  let lam = _d env "initial"  lam in
  let lam  = Lam_pass_deep_flatten.deep_flatten lam in
  let lam = _d  env "flatten0" lam in
  let meta = 
    Lam_pass_collect.count_alias_globals env 
      export_idents export_ident_sets lam in
  let lam = 
    let lam =  
      lam
      |> _d env "flattern1"
      |>  Lam_pass_exits.simplify_exits
      |> _d env "simplyf_exits"
      |> (fun lam -> Lam_pass_collect.collect_helper meta lam; lam)
      |>  Lam_pass_remove_alias.simplify_alias  meta
      |> _d env "simplify_alias"
      |> Lam_pass_deep_flatten.deep_flatten
      |> _d env "flatten2"
    in  (* Inling happens*)

    let ()  = Lam_pass_collect.collect_helper meta lam in
    let lam = Lam_pass_remove_alias.simplify_alias meta lam  in
    let lam = Lam_pass_deep_flatten.deep_flatten lam in
    let ()  = Lam_pass_collect.collect_helper meta lam in
    let lam = 
      lam
      |> _d env "alpha_before"
      |> Lam_pass_alpha_conversion.alpha_conversion meta
      |> _d env "alpha_after"
      |> Lam_pass_exits.simplify_exits in    
    let () = Lam_pass_collect.collect_helper meta lam in


    lam
    |> _d env "simplify_alias_before"
    |>  Lam_pass_remove_alias.simplify_alias meta 
    |> _d env "alpha_conversion"
    |>  Lam_pass_alpha_conversion.alpha_conversion meta
    |> _d env "before-simplify_lets"
    (* we should investigate a better way to put different passes : )*)
    |> Lam_pass_lets_dce.simplify_lets 

    |> _d env "before-simplify-exits"
    (* |> (fun lam -> Lam_pass_collect.collect_helper meta lam 
       ; Lam_pass_remove_alias.simplify_alias meta lam) *)
    (* |> Lam_group_pass.scc_pass
       |> _d "scc" *)
    |> Lam_pass_exits.simplify_exits
    |> _d env "simplify_lets"
    
  in

  let ({Lam_coercion.groups = groups } as coerced_input , meta) = 
    Lam_coercion.coerce_and_group_big_lambda  meta lam
  in 

  
  let maybe_pure = no_side_effects groups in
  
  let body  =     
    Ext_list.map groups (fun group -> compile_group meta group)
    |> Js_output.concat
    |> Js_output.output_as_block
  in
    
  (* The file is not big at all compared with [cmo] *)
  (* Ext_marshal.to_file (Ext_path.chop_extension filename ^ ".mj")  js; *)
  let meta_exports = meta.exports in 
  let export_set = Ident_set.of_list meta_exports in 
  let js : J.program = 
      { 
        exports = meta_exports ; 
        export_set; 
        block = body}
  in
  js 
  |> _j "initial"
  |> Js_pass_flatten.program
  |> _j "flattern"
  |> Js_pass_tailcall_inline.tailcall_inline
  |> _j "inline_and_shake"
  |> Js_pass_flatten_and_mark_dead.program
  |> _j "flatten_and_mark_dead"
  (* |> Js_inline_and_eliminate.inline_and_shake *)
  (* |> _j "inline_and_shake" *)
  |> (fun js -> ignore @@ Js_pass_scope.program  js ; js )
  |> Js_shake.shake_program
  |> _j "shake"
  |> ( fun (program:  J.program) -> 
      let external_module_ids = 
        Lam_compile_env.get_required_modules  
          may_required_modules  
          (Js_fold_basic.calculate_hard_dependencies program.block)
        |>
        (fun x ->
           if !Js_config.sort_imports then
             Ext_list.sort_via_array x
               (fun id1 id2 ->
                  Ext_string.compare (Lam_module_ident.name id1) (Lam_module_ident.name id2)
               ) 
           else
             x
        )
      in
      Warnings.check_fatal ();  
      let effect = 
        Lam_stats_export.get_dependent_module_effect
        meta maybe_pure external_module_ids in 
      let v : Js_cmj_format.t = 
        Lam_stats_export.export_to_cmj 
          meta  
          effect 
          coerced_input.export_map
          (get_cmj_case output_prefix)
      in
      (if not @@ !Clflags.dont_write_files then
         Js_cmj_format.to_file 
          ~check_exists:(not !Js_config.force_cmj)
           (output_prefix ^ Literals.suffix_cmj) v);
      {J.program = program ; side_effect = effect ; modules = external_module_ids }      
    )
;;

let (//) = Filename.concat  

let lambda_as_module 
    finalenv 
    (output_prefix : string)
    (lam : Lambda.lambda) = 
  let lambda_output = 
    compile  output_prefix finalenv lam in
  let basename =  
    Ext_namespace.change_ext_ns_suffix 
      (Filename.basename
         output_prefix) 
      (if !Js_config.bs_suffix then Literals.suffix_bs_js else Literals.suffix_js) 
  in
  let package_info = Js_packages_state.get_packages_info () in 
  if Js_packages_info.is_empty package_info  then     
    Js_dump_program.dump_deps_program ~output_prefix NodeJS lambda_output stdout      
  else
    Js_packages_info.iter package_info (fun {module_system; path = _path} -> 
        let output_chan chan  = 
          Js_dump_program.dump_deps_program ~output_prefix
            module_system 
            lambda_output
            chan in
        if not @@ !Clflags.dont_write_files then 
          Ext_pervasives.with_file_as_chan

            (Lazy.force Ext_path.package_dir //
             _path //
             basename
             (* #913 only generate little-case js file *)
            ) output_chan )
  


(* We can use {!Env.current_unit = "Pervasives"} to tell if it is some specific module, 
    We need handle some definitions in standard libraries in a special way, most are io specific, 
    includes {!Pervasives.stdin, Pervasives.stdout, Pervasives.stderr}

    However, use filename instead of {!Env.current_unit} is more honest, since node-js module system is coupled with the file name 
*)

end
module Ast_invariants : sig 
#1 "ast_invariants.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                   Jeremie Dimino, Jane Street Europe                   *)
(*                                                                        *)
(*   Copyright 2015 Jane Street Group LLC                                 *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Check AST invariants *)

val structure : Parsetree.structure -> unit
val signature : Parsetree.signature -> unit

end = struct
#1 "ast_invariants.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                   Jeremie Dimino, Jane Street Europe                   *)
(*                                                                        *)
(*   Copyright 2015 Jane Street Group LLC                                 *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Asttypes
open Parsetree
open Ast_iterator

let err = Syntaxerr.ill_formed_ast

let empty_record loc = err loc "Records cannot be empty."
let empty_variant loc = err loc "Variant types cannot be empty."
let invalid_tuple loc = err loc "Tuples must have at least 2 components."
let no_args loc = err loc "Function application with no argument."
let empty_let loc = err loc "Let with no bindings."
let empty_type loc = err loc "Type declarations cannot be empty."
let complex_id loc = err loc "Functor application not allowed here."

let simple_longident id =
  let rec is_simple = function
    | Longident.Lident _ -> true
    | Longident.Ldot (id, _) -> is_simple id
    | Longident.Lapply _ -> false
  in
  if not (is_simple id.txt) then complex_id id.loc

let iterator =
  let super = Ast_iterator.default_iterator in
  let type_declaration self td =
    super.type_declaration self td;
    let loc = td.ptype_loc in
    match td.ptype_kind with
    | Ptype_record [] -> empty_record loc
    | Ptype_variant [] -> empty_variant loc
    | _ -> ()
  in
  let typ self ty =
    super.typ self ty;
    let loc = ty.ptyp_loc in
    match ty.ptyp_desc with
    | Ptyp_tuple ([] | [_]) -> invalid_tuple loc
    | Ptyp_class (id, _) -> simple_longident id
    | Ptyp_package (_, cstrs) ->
      List.iter (fun (id, _) -> simple_longident id) cstrs
    | _ -> ()
  in
  let pat self pat =
    begin match pat.ppat_desc with
    | Ppat_construct (_, Some ({ppat_desc = Ppat_tuple _} as p))
      when Builtin_attributes.explicit_arity pat.ppat_attributes ->
        super.pat self p (* allow unary tuple, see GPR#523. *)
    | _ ->
        super.pat self pat
    end;
    let loc = pat.ppat_loc in
    match pat.ppat_desc with
    | Ppat_tuple ([] | [_]) -> invalid_tuple loc
    | Ppat_record ([], _) -> empty_record loc
    | Ppat_construct (id, _) -> simple_longident id
    | Ppat_record (fields, _) ->
      List.iter (fun (id, _) -> simple_longident id) fields
    | _ -> ()
  in
  let expr self exp =
    begin match exp.pexp_desc with
    | Pexp_construct (_, Some ({pexp_desc = Pexp_tuple _} as e))
      when Builtin_attributes.explicit_arity exp.pexp_attributes ->
        super.expr self e (* allow unary tuple, see GPR#523. *)
    | _ ->
        super.expr self exp
    end;
    let loc = exp.pexp_loc in
    match exp.pexp_desc with
    | Pexp_tuple ([] | [_]) -> invalid_tuple loc
    | Pexp_record ([], _) -> empty_record loc
    | Pexp_apply (_, []) -> no_args loc
    | Pexp_let (_, [], _) -> empty_let loc
    | Pexp_ident id
    | Pexp_construct (id, _)
    | Pexp_field (_, id)
    | Pexp_setfield (_, id, _)
    | Pexp_new id
    | Pexp_open (_, id, _) -> simple_longident id
    | Pexp_record (fields, _) ->
      List.iter (fun (id, _) -> simple_longident id) fields
    | _ -> ()
  in
  let extension_constructor self ec =
    super.extension_constructor self ec;
    match ec.pext_kind with
    | Pext_rebind id -> simple_longident id
    | _ -> ()
  in
  let class_expr self ce =
    super.class_expr self ce;
    let loc = ce.pcl_loc in
    match ce.pcl_desc with
    | Pcl_apply (_, []) -> no_args loc
    | Pcl_constr (id, _) -> simple_longident id
    | _ -> ()
  in
  let module_type self mty =
    super.module_type self mty;
    match mty.pmty_desc with
    | Pmty_alias id -> simple_longident id
    | _ -> ()
  in
  let open_description self opn =
    super.open_description self opn;
    simple_longident opn.popen_lid
  in
  let with_constraint self wc =
    super.with_constraint self wc;
    match wc with
    | Pwith_type (id, _)
    | Pwith_module (id, _) -> simple_longident id
    | _ -> ()
  in
  let module_expr self me =
    super.module_expr self me;
    match me.pmod_desc with
    | Pmod_ident id -> simple_longident id
    | _ -> ()
  in
  let structure_item self st =
    super.structure_item self st;
    let loc = st.pstr_loc in
    match st.pstr_desc with
    | Pstr_type (_, []) -> empty_type loc
    | Pstr_value (_, []) -> empty_let loc
    | _ -> ()
  in
  let signature_item self sg =
    super.signature_item self sg;
    let loc = sg.psig_loc in
    match sg.psig_desc with
    | Psig_type (_, []) -> empty_type loc
    | _ -> ()
  in
  { super with
    type_declaration
  ; typ
  ; pat
  ; expr
  ; extension_constructor
  ; class_expr
  ; module_expr
  ; module_type
  ; open_description
  ; with_constraint
  ; structure_item
  ; signature_item
  }

let structure st = iterator.structure iterator st
let signature sg = iterator.signature iterator sg

end
module Parse : sig 
#1 "parse.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Entry points in the parser *)

val implementation : Lexing.lexbuf -> Parsetree.structure
val interface : Lexing.lexbuf -> Parsetree.signature
val toplevel_phrase : Lexing.lexbuf -> Parsetree.toplevel_phrase
val use_file : Lexing.lexbuf -> Parsetree.toplevel_phrase list
val core_type : Lexing.lexbuf -> Parsetree.core_type
val expression : Lexing.lexbuf -> Parsetree.expression
val pattern : Lexing.lexbuf -> Parsetree.pattern

end = struct
#1 "parse.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Entry points in the parser *)

(* Skip tokens to the end of the phrase *)

let rec skip_phrase lexbuf =
  try
    match Lexer.token lexbuf with
      Parser.SEMISEMI | Parser.EOF -> ()
    | _ -> skip_phrase lexbuf
  with
    | Lexer.Error (Lexer.Unterminated_comment _, _)
    | Lexer.Error (Lexer.Unterminated_string, _)
    | Lexer.Error (Lexer.Unterminated_string_in_comment _, _)
    | Lexer.Error (Lexer.Illegal_character _, _) -> skip_phrase lexbuf
;;

let maybe_skip_phrase lexbuf =
  if Parsing.is_current_lookahead Parser.SEMISEMI
  || Parsing.is_current_lookahead Parser.EOF
  then ()
  else skip_phrase lexbuf

let wrap parsing_fun lexbuf =
  try
    Docstrings.init ();
    Lexer.init ();
    let ast = parsing_fun Lexer.token lexbuf in
    Parsing.clear_parser();
    Docstrings.warn_bad_docstrings ();
    ast
  with
  | Lexer.Error(Lexer.Illegal_character _, _) as err
    when !Location.input_name = "//toplevel//"->
      skip_phrase lexbuf;
      raise err
  | Syntaxerr.Error _ as err
    when !Location.input_name = "//toplevel//" ->
      maybe_skip_phrase lexbuf;
      raise err
  | Parsing.Parse_error | Syntaxerr.Escape_error ->
      let loc = Location.curr lexbuf in
      if !Location.input_name = "//toplevel//"
      then maybe_skip_phrase lexbuf;
      raise(Syntaxerr.Error(Syntaxerr.Other loc))

let implementation = wrap Parser.implementation
and interface = wrap Parser.interface
and toplevel_phrase = wrap Parser.toplevel_phrase
and use_file = wrap Parser.use_file
and core_type = wrap Parser.parse_core_type
and expression = wrap Parser.parse_expression
and pattern = wrap Parser.parse_pattern

end
module Pparse : sig 
#1 "pparse.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*         Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt       *)
(*                                                                        *)
(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Driver for the parser, external preprocessors and ast plugin hooks *)

open Format

type error =
  | CannotRun of string
  | WrongMagic of string

exception Error of error

val preprocess : string -> string
val remove_preprocessed : string -> unit

type 'a ast_kind =
| Structure : Parsetree.structure ast_kind
| Signature : Parsetree.signature ast_kind

val read_ast : 'a ast_kind -> string -> 'a
val write_ast : 'a ast_kind -> string -> 'a -> unit

val file : formatter -> tool_name:string -> string ->
  (Lexing.lexbuf -> 'a) -> 'a ast_kind -> 'a

val apply_rewriters: ?restore:bool -> tool_name:string ->
  'a ast_kind -> 'a -> 'a
  (** If [restore = true] (the default), cookies set by external
      rewriters will be kept for later calls. *)

val apply_rewriters_str:
  ?restore:bool -> tool_name:string -> Parsetree.structure ->
  Parsetree.structure
val apply_rewriters_sig:
  ?restore:bool -> tool_name:string -> Parsetree.signature ->
  Parsetree.signature

val report_error : formatter -> error -> unit


val parse_implementation:
  formatter -> tool_name:string -> string -> Parsetree.structure
val parse_interface:
  formatter -> tool_name:string -> string -> Parsetree.signature

(* [call_external_preprocessor sourcefile pp] *)
val call_external_preprocessor : string -> string -> string
val open_and_check_magic : string -> string -> in_channel * bool

module ImplementationHooks : Misc.HookSig with type t = Parsetree.structure
module InterfaceHooks : Misc.HookSig with type t = Parsetree.signature

end = struct
#1 "pparse.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*         Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt       *)
(*                                                                        *)
(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Format

type error =
  | CannotRun of string
  | WrongMagic of string

exception Error of error

(* Optionally preprocess a source file *)

let call_external_preprocessor sourcefile pp =
      let tmpfile = Filename.temp_file "ocamlpp" "" in
      let comm = Printf.sprintf "%s %s > %s"
                                pp (Filename.quote sourcefile) tmpfile
      in
      if Ccomp.command comm <> 0 then begin
        Misc.remove_file tmpfile;
        raise (Error (CannotRun comm));
      end;
      tmpfile

let preprocess sourcefile =
  match !Clflags.preprocessor with
    None -> sourcefile
  | Some pp ->
      Profile.record "-pp"
        (call_external_preprocessor sourcefile) pp


let remove_preprocessed inputfile =
  match !Clflags.preprocessor with
    None -> ()
  | Some _ -> Misc.remove_file inputfile

type 'a ast_kind =
| Structure : Parsetree.structure ast_kind
| Signature : Parsetree.signature ast_kind

let magic_of_kind : type a . a ast_kind -> string = function
  | Structure -> Config.ast_impl_magic_number
  | Signature -> Config.ast_intf_magic_number

(* Note: some of the functions here should go to Ast_mapper instead,
   which would encapsulate the "binary AST" protocol. *)

let write_ast (type a) (kind : a ast_kind) fn (ast : a) =
  let oc = open_out_bin fn in
  output_string oc (magic_of_kind kind);
  output_value oc (!Location.input_name : string);
  output_value oc (ast : a);
  close_out oc

let apply_rewriter kind fn_in ppx =
  let magic = magic_of_kind kind in
  let fn_out = Filename.temp_file "camlppx" "" in
  let comm =
    Printf.sprintf "%s %s %s" ppx (Filename.quote fn_in) (Filename.quote fn_out)
  in
  let ok = Ccomp.command comm = 0 in
  Misc.remove_file fn_in;
  if not ok then begin
    Misc.remove_file fn_out;
    raise (Error (CannotRun comm));
  end;
  if not (Sys.file_exists fn_out) then
    raise (Error (WrongMagic comm));
  (* check magic before passing to the next ppx *)
  let ic = open_in_bin fn_out in
  let buffer =
    try really_input_string ic (String.length magic) with End_of_file -> "" in
  close_in ic;
  if buffer <> magic then begin
    Misc.remove_file fn_out;
    raise (Error (WrongMagic comm));
  end;
  fn_out

let read_ast (type a) (kind : a ast_kind) fn : a =
  let ic = open_in_bin fn in
  try
    let magic = magic_of_kind kind in
    let buffer = really_input_string ic (String.length magic) in
    assert(buffer = magic); (* already checked by apply_rewriter *)
    Location.input_name := (input_value ic : string);
    let ast = (input_value ic : a) in
    close_in ic;
    Misc.remove_file fn;
    ast
  with exn ->
    close_in ic;
    Misc.remove_file fn;
    raise exn

let rewrite kind ppxs ast =
  let fn = Filename.temp_file "camlppx" "" in
  write_ast kind fn ast;
  let fn = List.fold_left (apply_rewriter kind) fn (List.rev ppxs) in
  read_ast kind fn

let apply_rewriters_str ?(restore = true) ~tool_name ast =
  match !Clflags.all_ppx with
  | [] -> ast
  | ppxs ->
      ast
      |> Ast_mapper.add_ppx_context_str ~tool_name
      |> rewrite Structure ppxs
      |> Ast_mapper.drop_ppx_context_str ~restore

let apply_rewriters_sig ?(restore = true) ~tool_name ast =
  match !Clflags.all_ppx with
  | [] -> ast
  | ppxs ->
      ast
      |> Ast_mapper.add_ppx_context_sig ~tool_name
      |> rewrite Signature ppxs
      |> Ast_mapper.drop_ppx_context_sig ~restore

let apply_rewriters ?restore ~tool_name
    (type a) (kind : a ast_kind) (ast : a) : a =
  match kind with
  | Structure ->
      apply_rewriters_str ?restore ~tool_name ast
  | Signature ->
      apply_rewriters_sig ?restore ~tool_name ast

(* Parse a file or get a dumped syntax tree from it *)

exception Outdated_version

let open_and_check_magic inputfile ast_magic =
  let ic = open_in_bin inputfile in
  let is_ast_file =
    try
      let buffer = really_input_string ic (String.length ast_magic) in
      if buffer = ast_magic then true
      else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
        raise Outdated_version
      else false
    with
      Outdated_version ->
        Misc.fatal_error "OCaml and preprocessor have incompatible versions"
    | _ -> false
  in
  (ic, is_ast_file)

let parse (type a) (kind : a ast_kind) lexbuf : a =
  match kind with
  | Structure -> Parse.implementation lexbuf
  | Signature -> Parse.interface lexbuf

let file_aux ppf ~tool_name inputfile (type a) parse_fun invariant_fun
             (kind : a ast_kind) =
  let ast_magic = magic_of_kind kind in
  let (ic, is_ast_file) = open_and_check_magic inputfile ast_magic in
  let ast =
    try
      if is_ast_file then begin
        if !Clflags.fast then
          (* FIXME make this a proper warning *)
          fprintf ppf "@[Warning: %s@]@."
            "option -unsafe used with a preprocessor returning a syntax tree";
        Location.input_name := (input_value ic : string);
        (input_value ic : a)
      end else begin
        seek_in ic 0;
        let lexbuf = Lexing.from_channel ic in
        Location.init lexbuf inputfile;
        Profile.record_call "parser" (fun () -> parse_fun lexbuf)
      end
    with x -> close_in ic; raise x
  in
  close_in ic;
  let ast =
    Profile.record_call "-ppx" (fun () ->
      apply_rewriters ~restore:false ~tool_name kind ast) in
  if is_ast_file || !Clflags.all_ppx <> [] then invariant_fun ast;
  ast

let file ppf ~tool_name inputfile parse_fun ast_kind =
  file_aux ppf ~tool_name inputfile parse_fun ignore ast_kind

let report_error ppf = function
  | CannotRun cmd ->
      fprintf ppf "Error while running external preprocessor@.\
                   Command line: %s@." cmd
  | WrongMagic cmd ->
      fprintf ppf "External preprocessor does not produce a valid file@.\
                   Command line: %s@." cmd

let () =
  Location.register_error_of_exn
    (function
      | Error err -> Some (Location.error_of_printer_file report_error err)
      | _ -> None
    )

let parse_file ~tool_name invariant_fun apply_hooks kind ppf sourcefile =
  Location.input_name := sourcefile;
  let inputfile = preprocess sourcefile in
  let ast =
    try file_aux ppf ~tool_name inputfile (parse kind) invariant_fun kind
    with exn ->
      remove_preprocessed inputfile;
      raise exn
  in
  remove_preprocessed inputfile;
  let ast = apply_hooks { Misc.sourcefile } ast in
  ast

module ImplementationHooks = Misc.MakeHooks(struct
    type t = Parsetree.structure
  end)
module InterfaceHooks = Misc.MakeHooks(struct
    type t = Parsetree.signature
  end)

let parse_implementation ppf ~tool_name sourcefile =
  Profile.record_call "parsing" (fun () ->
    parse_file ~tool_name Ast_invariants.structure
      ImplementationHooks.apply_hooks Structure ppf sourcefile)
let parse_interface ppf ~tool_name sourcefile =
  Profile.record_call "parsing" (fun () ->
    parse_file ~tool_name Ast_invariants.signature
      InterfaceHooks.apply_hooks Signature ppf sourcefile)

end
module Pprintast : sig 
#1 "pprintast.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Hongbo Zhang (University of Pennsylvania)                  *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

type space_formatter = (unit, Format.formatter, unit) format

val toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit
val expression : Format.formatter -> Parsetree.expression -> unit
val string_of_expression : Parsetree.expression -> string
val top_phrase: Format.formatter -> Parsetree.toplevel_phrase -> unit
val core_type: Format.formatter -> Parsetree.core_type -> unit
val pattern: Format.formatter -> Parsetree.pattern -> unit
val signature: Format.formatter -> Parsetree.signature -> unit
val structure: Format.formatter -> Parsetree.structure -> unit
val string_of_structure: Parsetree.structure -> string

end = struct
#1 "pprintast.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                      Thomas Gazagnaire, OCamlPro                       *)
(*                   Fabrice Le Fessant, INRIA Saclay                     *)
(*               Hongbo Zhang, University of Pennsylvania                 *)
(*                                                                        *)
(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *)
(* Printing code expressions *)
(* Authors:  Ed Pizzi, Fabrice Le Fessant *)
(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *)
(* TODO more fine-grained precedence pretty-printing *)

open Asttypes
open Format
open Location
open Longident
open Parsetree
open Ast_helper

let prefix_symbols  = [ '!'; '?'; '~' ] ;;
let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/';
                      '$'; '%'; '#' ]

(* type fixity = Infix| Prefix  *)
let special_infix_strings =
  ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ]

(* determines if the string is an infix string.
   checks backwards, first allowing a renaming postfix ("_102") which
   may have resulted from Pexp -> Texp -> Pexp translation, then checking
   if all the characters in the beginning of the string are valid infix
   characters. *)
let fixity_of_string  = function
  | s when List.mem s special_infix_strings -> `Infix s
  | s when List.mem s.[0] infix_symbols -> `Infix s
  | s when List.mem s.[0] prefix_symbols -> `Prefix s
  | s when s.[0] = '.' -> `Mixfix s
  | _ -> `Normal

let view_fixity_of_exp = function
  | {pexp_desc = Pexp_ident {txt=Lident l;_}; pexp_attributes = []} ->
      fixity_of_string l
  | _ -> `Normal

let is_infix  = function  | `Infix _ -> true | _  -> false
let is_mixfix = function `Mixfix _ -> true | _ -> false

(* which identifiers are in fact operators needing parentheses *)
let needs_parens txt =
  let fix = fixity_of_string txt in
  is_infix fix
  || is_mixfix fix
  || List.mem txt.[0] prefix_symbols

(* some infixes need spaces around parens to avoid clashes with comment
   syntax *)
let needs_spaces txt =
  txt.[0]='*' || txt.[String.length txt - 1] = '*'

(* add parentheses to binders when they are in fact infix or prefix operators *)
let protect_ident ppf txt =
  let format : (_, _, _) format =
    if not (needs_parens txt) then "%s"
    else if needs_spaces txt then "(@;%s@;)"
    else "(%s)"
  in fprintf ppf format txt

let protect_longident ppf print_longident longprefix txt =
  let format : (_, _, _) format =
    if not (needs_parens txt) then "%a.%s"
    else if needs_spaces txt then  "%a.(@;%s@;)"
    else "%a.(%s)" in
  fprintf ppf format print_longident longprefix txt

type space_formatter = (unit, Format.formatter, unit) format

let override = function
  | Override -> "!"
  | Fresh -> ""

(* variance encoding: need to sync up with the [parser.mly] *)
let type_variance = function
  | Invariant -> ""
  | Covariant -> "+"
  | Contravariant -> "-"

type construct =
  [ `cons of expression list
  | `list of expression list
  | `nil
  | `normal
  | `simple of Longident.t
  | `tuple ]

let view_expr x =
  match x.pexp_desc with
  | Pexp_construct ( {txt= Lident "()"; _},_) -> `tuple
  | Pexp_construct ( {txt= Lident "[]";_},_) -> `nil
  | Pexp_construct ( {txt= Lident"::";_},Some _) ->
      let rec loop exp acc = match exp with
          | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_);
             pexp_attributes = []} ->
              (List.rev acc,true)
          | {pexp_desc=
             Pexp_construct ({txt=Lident "::";_},
                             Some ({pexp_desc= Pexp_tuple([e1;e2]);
                                    pexp_attributes = []}));
             pexp_attributes = []}
            ->
              loop e2 (e1::acc)
          | e -> (List.rev (e::acc),false) in
      let (ls,b) = loop x []  in
      if b then
        `list ls
      else `cons ls
  | Pexp_construct (x,None) -> `simple (x.txt)
  | _ -> `normal

let is_simple_construct :construct -> bool = function
  | `nil | `tuple | `list _ | `simple _  -> true
  | `cons _ | `normal -> false

let pp = fprintf

type ctxt = {
  pipe : bool;
  semi : bool;
  ifthenelse : bool;
}

let reset_ctxt = { pipe=false; semi=false; ifthenelse=false }
let under_pipe ctxt = { ctxt with pipe=true }
let under_semi ctxt = { ctxt with semi=true }
let under_ifthenelse ctxt = { ctxt with ifthenelse=true }
(*
let reset_semi ctxt = { ctxt with semi=false }
let reset_ifthenelse ctxt = { ctxt with ifthenelse=false }
let reset_pipe ctxt = { ctxt with pipe=false }
*)

let list : 'a . ?sep:space_formatter -> ?first:space_formatter ->
  ?last:space_formatter -> (Format.formatter -> 'a -> unit) ->
  Format.formatter -> 'a list -> unit
  = fun ?sep ?first ?last fu f xs ->
    let first = match first with Some x -> x |None -> ("": _ format6)
    and last = match last with Some x -> x |None -> ("": _ format6)
    and sep = match sep with Some x -> x |None -> ("@ ": _ format6) in
    let aux f = function
      | [] -> ()
      | [x] -> fu f x
      | xs ->
          let rec loop  f = function
            | [x] -> fu f x
            | x::xs ->  fu f x; pp f sep; loop f xs;
            | _ -> assert false in begin
            pp f first; loop f xs; pp f last;
          end in
    aux f xs

let option : 'a. ?first:space_formatter -> ?last:space_formatter ->
  (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit
  = fun  ?first  ?last fu f a ->
    let first = match first with Some x -> x | None -> ("": _ format6)
    and last = match last with Some x -> x | None -> ("": _ format6) in
    match a with
    | None -> ()
    | Some x -> pp f first; fu f x; pp f last

let paren: 'a . ?first:space_formatter -> ?last:space_formatter ->
  bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit
  = fun  ?(first=("": _ format6)) ?(last=("": _ format6)) b fu f x ->
    if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")")
    else fu f x

let rec longident f = function
  | Lident s -> protect_ident f s
  | Ldot(y,s) -> protect_longident f longident y s
  | Lapply (y,s) ->
      pp f "%a(%a)" longident y longident s

let longident_loc f x = pp f "%a" longident x.txt

let constant f = function
  | Pconst_char i -> pp f "%C"  i
  | Pconst_string (i, None) -> pp f "%S" i
  | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim
  | Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i
  | Pconst_integer (i, Some m) ->
    paren (i.[0]='-') (fun f (i, m) -> pp f "%s%c" i m) f (i,m)
  | Pconst_float (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i
  | Pconst_float (i, Some m) -> paren (i.[0]='-') (fun f (i,m) ->
      pp f "%s%c" i m) f (i,m)

(* trailing space*)
let mutable_flag f = function
  | Immutable -> ()
  | Mutable -> pp f "mutable@;"
let virtual_flag f  = function
  | Concrete -> ()
  | Virtual -> pp f "virtual@;"

(* trailing space added *)
let rec_flag f rf =
  match rf with
  | Nonrecursive -> ()
  | Recursive -> pp f "rec "
let nonrec_flag f rf =
  match rf with
  | Nonrecursive -> pp f "nonrec "
  | Recursive -> ()
let direction_flag f = function
  | Upto -> pp f "to@ "
  | Downto -> pp f "downto@ "
let private_flag f = function
  | Public -> ()
  | Private -> pp f "private@ "

let constant_string f s = pp f "%S" s
let tyvar f str = pp f "'%s" str
let tyvar_loc f str = pp f "'%s" str.txt
let string_quot f x = pp f "`%s" x

(* c ['a,'b] *)
let rec class_params_def ctxt f =  function
  | [] -> ()
  | l ->
      pp f "[%a] " (* space *)
        (list (type_param ctxt) ~sep:",") l

and type_with_label ctxt f (label, c) =
  match label with
  | Nolabel    -> core_type1 ctxt f c (* otherwise parenthesize *)
  | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c
  | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c

and core_type ctxt f x =
  if x.ptyp_attributes <> [] then begin
    pp f "((%a)%a)" (core_type ctxt) {x with ptyp_attributes=[]}
      (attributes ctxt) x.ptyp_attributes
  end
  else match x.ptyp_desc with
    | Ptyp_arrow (l, ct1, ct2) ->
        pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
          (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2
    | Ptyp_alias (ct, s) ->
        pp f "@[<2>%a@;as@;'%s@]" (core_type1 ctxt) ct s
    | Ptyp_poly ([], ct) ->
        core_type ctxt f ct
    | Ptyp_poly (sl, ct) ->
        pp f "@[<2>%a%a@]"
          (fun f l ->
             pp f "%a"
               (fun f l -> match l with
                  | [] -> ()
                  | _ ->
                      pp f "%a@;.@;"
                        (list tyvar_loc ~sep:"@;")  l)
               l)
          sl (core_type ctxt) ct
    | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x

and core_type1 ctxt f x =
  if x.ptyp_attributes <> [] then core_type ctxt f x
  else match x.ptyp_desc with
    | Ptyp_any -> pp f "_";
    | Ptyp_var s -> tyvar f  s;
    | Ptyp_tuple l ->  pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l
    | Ptyp_constr (li, l) ->
        pp f (* "%a%a@;" *) "%a%a"
          (fun f l -> match l with
             |[] -> ()
             |[x]-> pp f "%a@;" (core_type1 ctxt)  x
             | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l)
          l longident_loc li
    | Ptyp_variant (l, closed, low) ->
        let type_variant_helper f x =
          match x with
          | Rtag (l, attrs, _, ctl) ->
              pp f "@[<2>%a%a@;%a@]" string_quot l.txt
                (fun f l -> match l with
                   |[] -> ()
                   | _ -> pp f "@;of@;%a"
                            (list (core_type ctxt) ~sep:"&")  ctl) ctl
                (attributes ctxt) attrs
          | Rinherit ct -> core_type ctxt f ct in
        pp f "@[<2>[%a%a]@]"
          (fun f l ->
             match l, closed with
             | [], Closed -> ()
             | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *)
             | _ ->
                 pp f "%s@;%a"
                   (match (closed,low) with
                    | (Closed,None) -> ""
                    | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*)
                    | (Open,_) -> ">")
                   (list type_variant_helper ~sep:"@;<1 -2>| ") l) l
          (fun f low -> match low with
             |Some [] |None -> ()
             |Some xs ->
                 pp f ">@ %a"
                   (list string_quot) xs) low
    | Ptyp_object (l, o) ->
        let core_field_type f = function
          | Otag (l, attrs, ct) ->
            pp f "@[<hov2>%s: %a@ %a@ @]" l.txt
              (core_type ctxt) ct (attributes ctxt) attrs (* Cf #7200 *)
          | Oinherit ct ->
            pp f "@[<hov2>%a@ @]" (core_type ctxt) ct
        in
        let field_var f = function
          | Asttypes.Closed -> ()
          | Asttypes.Open ->
              match l with
              | [] -> pp f ".."
              | _ -> pp f " ;.."
        in
        pp f "@[<hov2><@ %a%a@ > @]" (list core_field_type ~sep:";") l
          field_var o (* Cf #7200 *)
    | Ptyp_class (li, l) ->   (*FIXME*)
        pp f "@[<hov2>%a#%a@]"
          (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l
          longident_loc li
    | Ptyp_package (lid, cstrs) ->
        let aux f (s, ct) =
          pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct  in
        (match cstrs with
         |[] -> pp f "@[<hov2>(module@ %a)@]" longident_loc lid
         |_ ->
             pp f "@[<hov2>(module@ %a@ with@ %a)@]" longident_loc lid
               (list aux  ~sep:"@ and@ ")  cstrs)
    | Ptyp_extension e -> extension ctxt f e
    | _ -> paren true (core_type ctxt) f x

(********************pattern********************)
(* be cautious when use [pattern], [pattern1] is preferred *)
and pattern ctxt f x =
  let rec list_of_pattern acc = function (* only consider ((A|B)|C)*)
    | {ppat_desc= Ppat_or (p1,p2); ppat_attributes = []} ->
        list_of_pattern  (p2::acc) p1
    | x -> x::acc
  in
  if x.ppat_attributes <> [] then begin
    pp f "((%a)%a)" (pattern ctxt) {x with ppat_attributes=[]}
      (attributes ctxt) x.ppat_attributes
  end
  else match x.ppat_desc with
    | Ppat_alias (p, s) ->
        pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt (* RA*)
    | Ppat_or _ -> (* *)
        pp f "@[<hov0>%a@]" (list ~sep:"@,|" (pattern ctxt))
          (list_of_pattern [] x)
    | _ -> pattern1 ctxt f x

and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit =
  let rec pattern_list_helper f = function
    | {ppat_desc =
         Ppat_construct
           ({ txt = Lident("::") ;_},
            Some ({ppat_desc = Ppat_tuple([pat1; pat2]);_}));
       ppat_attributes = []}

      ->
        pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*)
    | p -> pattern1 ctxt f p
  in
  if x.ppat_attributes <> [] then pattern ctxt f x
  else match x.ppat_desc with
    | Ppat_variant (l, Some p) ->
        pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p
    | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> simple_pattern ctxt f x
    | Ppat_construct (({txt;_} as li), po) ->
        (* FIXME The third field always false *)
        if txt = Lident "::" then
          pp f "%a" pattern_list_helper x
        else
          (match po with
           | Some x -> pp f "%a@;%a"  longident_loc li (simple_pattern ctxt) x
           | None -> pp f "%a" longident_loc li)
    | _ -> simple_pattern ctxt f x

and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit =
  if x.ppat_attributes <> [] then pattern ctxt f x
  else match x.ppat_desc with
    | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), _) -> pp f  "%s" x
    | Ppat_any -> pp f "_";
    | Ppat_var ({txt = txt;_}) -> protect_ident f txt
    | Ppat_array l ->
        pp f "@[<2>[|%a|]@]"  (list (pattern1 ctxt) ~sep:";") l
    | Ppat_unpack (s) ->
        pp f "(module@ %s)@ " s.txt
    | Ppat_type li ->
        pp f "#%a" longident_loc li
    | Ppat_record (l, closed) ->
        let longident_x_pattern f (li, p) =
          match (li,p) with
          | ({txt=Lident s;_ },
             {ppat_desc=Ppat_var {txt;_};
              ppat_attributes=[]; _})
            when s = txt ->
              pp f "@[<2>%a@]"  longident_loc li
          | _ ->
              pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p
        in
        begin match closed with
        | Closed ->
            pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l
        | _ ->
            pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l
        end
    | Ppat_tuple l ->
        pp f "@[<1>(%a)@]" (list  ~sep:",@;" (pattern1 ctxt))  l (* level1*)
    | Ppat_constant (c) -> pp f "%a" constant c
    | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2
    | Ppat_variant (l,None) ->  pp f "`%s" l
    | Ppat_constraint (p, ct) ->
        pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct
    | Ppat_lazy p ->
        pp f "@[<2>(lazy@;%a)@]" (pattern1 ctxt) p
    | Ppat_exception p ->
        pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p
    | Ppat_extension e -> extension ctxt f e
    | Ppat_open (lid, p) ->
        let with_paren =
        match p.ppat_desc with
        | Ppat_array _ | Ppat_record _
        | Ppat_construct (({txt=Lident ("()"|"[]");_}), _) -> false
        | _ -> true in
        pp f "@[<2>%a.%a @]" longident_loc lid
          (paren with_paren @@ pattern1 ctxt) p
    | _ -> paren true (pattern ctxt) f x

and label_exp ctxt f (l,opt,p) =
  match l with
  | Nolabel ->
      (* single case pattern parens needed here *)
      pp f "%a@ " (simple_pattern ctxt) p
  | Optional rest ->
      begin match p with
      | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []}
        when txt = rest ->
          (match opt with
           | Some o -> pp f "?(%s=@;%a)@;" rest  (expression ctxt) o
           | None -> pp f "?%s@ " rest)
      | _ ->
          (match opt with
           | Some o ->
               pp f "?%s:(%a=@;%a)@;"
                 rest (pattern1 ctxt) p (expression ctxt) o
           | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p)
      end
  | Labelled l -> match p with
    | {ppat_desc  = Ppat_var {txt;_}; ppat_attributes = []}
      when txt = l ->
        pp f "~%s@;" l
    | _ ->  pp f "~%s:%a@;" l (simple_pattern ctxt) p

and sugar_expr ctxt f e =
  if e.pexp_attributes <> [] then false
  else match e.pexp_desc with
  | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _};
                  pexp_attributes=[]; _}, args)
    when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin
      let print_indexop a path_prefix assign left right print_index indices
          rem_args =
        let print_path ppf = function
          | None -> ()
          | Some m -> pp ppf ".%a" longident m in
        match assign, rem_args with
            | false, [] ->
              pp f "@[%a%a%s%a%s@]"
                (simple_expr ctxt) a print_path path_prefix
                left (list ~sep:"," print_index) indices right; true
            | true, [v] ->
              pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]"
                (simple_expr ctxt) a print_path path_prefix
                left (list ~sep:"," print_index) indices right
                (simple_expr ctxt) v; true
            | _ -> false in
      match id, List.map snd args with
      | Lident "!", [e] ->
        pp f "@[<hov>!%a@]" (simple_expr ctxt) e; true
      | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin
          let assign = func = "set" in
          let print = print_indexop a None assign in
          match path, other_args with
          | Lident "Array", i :: rest ->
            print ".(" ")" (expression ctxt) [i] rest
          | Lident "String", i :: rest ->
            print ".[" "]" (expression ctxt) [i] rest
          | Ldot (Lident "Bigarray", "Array1"), i1 :: rest ->
            print ".{" "}" (simple_expr ctxt) [i1] rest
          | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest ->
            print ".{" "}" (simple_expr ctxt) [i1; i2] rest
          | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest ->
            print ".{" "}" (simple_expr ctxt) [i1; i2; i3] rest
          | Ldot (Lident "Bigarray", "Genarray"),
            {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest ->
              print ".{" "}" (simple_expr ctxt) indexes rest
          | _ -> false
        end
      | (Lident s | Ldot(_,s)) , a :: i :: rest
        when s.[0] = '.' ->
          let n = String.length s in
          (* extract operator:
             assignment operators end with [right_bracket ^ "<-"],
             access operators end with [right_bracket] directly
          *)
          let assign = s.[n - 1] = '-'  in
          let kind =
            (* extract the right end bracket *)
            if assign then s.[n - 3] else s.[n - 1] in
          let left, right = match kind with
            | ')' -> '(', ")"
            | ']' -> '[', "]"
            | '}' -> '{', "}"
            | _ -> assert false in
          let path_prefix = match id with
            | Ldot(m,_) -> Some m
            | _ -> None in
          let left = String.sub s 0 (1+String.index s left) in
          print_indexop a path_prefix assign left right
            (expression ctxt) [i] rest
      | _ -> false
    end
  | _ -> false

and expression ctxt f x =
  if x.pexp_attributes <> [] then
    pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]}
      (attributes ctxt) x.pexp_attributes
  else match x.pexp_desc with
    | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _
      when ctxt.pipe || ctxt.semi ->
        paren true (expression reset_ctxt) f x
    | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse ->
        paren true (expression reset_ctxt) f x
    | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letexception _
        when ctxt.semi ->
        paren true (expression reset_ctxt) f x
    | Pexp_fun (l, e0, p, e) ->
        pp f "@[<2>fun@;%a->@;%a@]"
          (label_exp ctxt) (l, e0, p)
          (expression ctxt) e
    | Pexp_function l ->
        pp f "@[<hv>function%a@]" (case_list ctxt) l
    | Pexp_match (e, l) ->
        pp f "@[<hv0>@[<hv0>@[<2>match %a@]@ with@]%a@]"
          (expression reset_ctxt) e (case_list ctxt) l

    | Pexp_try (e, l) ->
        pp f "@[<0>@[<hv2>try@ %a@]@ @[<0>with%a@]@]"
             (* "try@;@[<2>%a@]@\nwith@\n%a"*)
          (expression reset_ctxt) e  (case_list ctxt) l
    | Pexp_let (rf, l, e) ->
        (* pp f "@[<2>let %a%a in@;<1 -2>%a@]"
           (*no indentation here, a new line*) *)
        (*   rec_flag rf *)
        pp f "@[<2>%a in@;<1 -2>%a@]"
          (bindings reset_ctxt) (rf,l)
          (expression ctxt) e
    | Pexp_apply (e, l) ->
        begin if not (sugar_expr ctxt f x) then
            match view_fixity_of_exp e with
            | `Infix s ->
                begin match l with
                | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] ->
                    (* FIXME associativity label_x_expression_param *)
                    pp f "@[<2>%a@;%s@;%a@]"
                      (label_x_expression_param reset_ctxt) arg1 s
                      (label_x_expression_param ctxt) arg2
                | _ ->
                    pp f "@[<2>%a %a@]"
                      (simple_expr ctxt) e
                      (list (label_x_expression_param ctxt)) l
                end
            | `Prefix s ->
                let s =
                  if List.mem s ["~+";"~-";"~+.";"~-."] &&
                   (match l with
                    (* See #7200: avoid turning (~- 1) into (- 1) which is
                       parsed as an int literal *)
                    |[(_,{pexp_desc=Pexp_constant _})] -> false
                    | _ -> true)
                  then String.sub s 1 (String.length s -1)
                  else s in
                begin match l with
                | [(Nolabel, x)] ->
                  pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x
                | _   ->
                  pp f "@[<2>%a %a@]" (simple_expr ctxt) e
                    (list (label_x_expression_param ctxt)) l
                end
            | _ ->
                pp f "@[<hov2>%a@]" begin fun f (e,l) ->
                  pp f "%a@ %a" (expression2 ctxt) e
                    (list (label_x_expression_param reset_ctxt))  l
                    (* reset here only because [function,match,try,sequence]
                       are lower priority *)
                end (e,l)
        end

    | Pexp_construct (li, Some eo)
      when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*)
        (match view_expr x with
         | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;"
         | `normal ->
             pp f "@[<2>%a@;%a@]" longident_loc li
               (simple_expr ctxt) eo
         | _ -> assert false)
    | Pexp_setfield (e1, li, e2) ->
        pp f "@[<2>%a.%a@ <-@ %a@]"
          (simple_expr ctxt) e1 longident_loc li (simple_expr ctxt) e2
    | Pexp_ifthenelse (e1, e2, eo) ->
        (* @;@[<2>else@ %a@]@] *)
        let fmt:(_,_,_)format ="@[<hv0>@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in
        let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in
        pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2
          (fun f eo -> match eo with
             | Some x ->
                 pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x
             | None -> () (* pp f "()" *)) eo
    | Pexp_sequence _ ->
        let rec sequence_helper acc = function
          | {pexp_desc=Pexp_sequence(e1,e2); pexp_attributes = []} ->
              sequence_helper (e1::acc) e2
          | v -> List.rev (v::acc) in
        let lst = sequence_helper [] x in
        pp f "@[<hv>%a@]"
          (list (expression (under_semi ctxt)) ~sep:";@;") lst
    | Pexp_new (li) ->
        pp f "@[<hov2>new@ %a@]" longident_loc li;
    | Pexp_setinstvar (s, e) ->
        pp f "@[<hov2>%s@ <-@ %a@]" s.txt (expression ctxt) e
    | Pexp_override l -> (* FIXME *)
        let string_x_expression f (s, e) =
          pp f "@[<hov2>%s@ =@ %a@]" s.txt (expression ctxt) e in
        pp f "@[<hov2>{<%a>}@]"
          (list string_x_expression  ~sep:";"  )  l;
    | Pexp_letmodule (s, me, e) ->
        pp f "@[<hov2>let@ module@ %s@ =@ %a@ in@ %a@]" s.txt
          (module_expr reset_ctxt) me (expression ctxt) e
    | Pexp_letexception (cd, e) ->
        pp f "@[<hov2>let@ exception@ %a@ in@ %a@]"
          (extension_constructor ctxt) cd
          (expression ctxt) e
    | Pexp_assert e ->
        pp f "@[<hov2>assert@ %a@]" (simple_expr ctxt) e
    | Pexp_lazy (e) ->
        pp f "@[<hov2>lazy@ %a@]" (simple_expr ctxt) e
    (* Pexp_poly: impossible but we should print it anyway, rather than
       assert false *)
    | Pexp_poly (e, None) ->
        pp f "@[<hov2>!poly!@ %a@]" (simple_expr ctxt) e
    | Pexp_poly (e, Some ct) ->
        pp f "@[<hov2>(!poly!@ %a@ : %a)@]"
          (simple_expr ctxt) e (core_type ctxt) ct
    | Pexp_open (ovf, lid, e) ->
        pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid
          (expression ctxt) e
    | Pexp_variant (l,Some eo) ->
        pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo
    | Pexp_extension e -> extension ctxt f e
    | Pexp_unreachable -> pp f "."
    | _ -> expression1 ctxt f x

and expression1 ctxt f x =
  if x.pexp_attributes <> [] then expression ctxt f x
  else match x.pexp_desc with
    | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs
    | _ -> expression2 ctxt f x
(* used in [Pexp_apply] *)

and expression2 ctxt f x =
  if x.pexp_attributes <> [] then expression ctxt f x
  else match x.pexp_desc with
    | Pexp_field (e, li) ->
        pp f "@[<hov2>%a.%a@]" (simple_expr ctxt) e longident_loc li
    | Pexp_send (e, s) -> pp f "@[<hov2>%a#%s@]" (simple_expr ctxt) e s.txt

    | _ -> simple_expr ctxt f x

and simple_expr ctxt f x =
  if x.pexp_attributes <> [] then expression ctxt f x
  else match x.pexp_desc with
    | Pexp_construct _  when is_simple_construct (view_expr x) ->
        (match view_expr x with
         | `nil -> pp f "[]"
         | `tuple -> pp f "()"
         | `list xs ->
             pp f "@[<hv0>[%a]@]"
               (list (expression (under_semi ctxt)) ~sep:";@;") xs
         | `simple x -> longident f x
         | _ -> assert false)
    | Pexp_ident li ->
        longident_loc f li
    (* (match view_fixity_of_exp x with *)
    (* |`Normal -> longident_loc f li *)
    (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *)
    | Pexp_constant c -> constant f c;
    | Pexp_pack me ->
        pp f "(module@;%a)" (module_expr ctxt) me
    | Pexp_newtype (lid, e) ->
        pp f "fun@;(type@;%s)@;->@;%a" lid.txt (expression ctxt) e
    | Pexp_tuple l ->
        pp f "@[<hov2>(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l
    | Pexp_constraint (e, ct) ->
        pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct
    | Pexp_coerce (e, cto1, ct) ->
        pp f "(%a%a :> %a)" (expression ctxt) e
          (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*)
          (core_type ctxt) ct
    | Pexp_variant (l, None) -> pp f "`%s" l
    | Pexp_record (l, eo) ->
        let longident_x_expression f ( li, e) =
          match e with
          |  {pexp_desc=Pexp_ident {txt;_};
              pexp_attributes=[]; _} when li.txt = txt ->
              pp f "@[<hov2>%a@]" longident_loc li
          | _ ->
              pp f "@[<hov2>%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e
        in
        pp f "@[<hv0>@[<hv2>{@;%a%a@]@;}@]"(* "@[<hov2>{%a%a}@]" *)
          (option ~last:" with@;" (simple_expr ctxt)) eo
          (list longident_x_expression ~sep:";@;") l
    | Pexp_array (l) ->
        pp f "@[<0>@[<2>[|%a|]@]@]"
          (list (simple_expr (under_semi ctxt)) ~sep:";") l
    | Pexp_while (e1, e2) ->
        let fmt : (_,_,_) format = "@[<2>while@;%a@;do@;%a@;done@]" in
        pp f fmt (expression ctxt) e1 (expression ctxt) e2
    | Pexp_for (s, e1, e2, df, e3) ->
        let fmt:(_,_,_)format =
          "@[<hv0>@[<hv2>@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" in
        let expression = expression ctxt in
        pp f fmt (pattern ctxt) s expression e1 direction_flag
          df expression e2 expression e3
    | _ ->  paren true (expression ctxt) f x

and attributes ctxt f l =
  List.iter (attribute ctxt f) l

and item_attributes ctxt f l =
  List.iter (item_attribute ctxt f) l

and attribute ctxt f (s, e) =
  pp f "@[<2>[@@%s@ %a]@]" s.txt (payload ctxt) e

and item_attribute ctxt f (s, e) =
  pp f "@[<2>[@@@@%s@ %a]@]" s.txt (payload ctxt) e

and floating_attribute ctxt f (s, e) =
  pp f "@[<2>[@@@@@@%s@ %a]@]" s.txt (payload ctxt) e

and value_description ctxt f x =
  (* note: value_description has an attribute field,
           but they're already printed by the callers this method *)
  pp f "@[<hov2>%a%a@]" (core_type ctxt) x.pval_type
    (fun f x ->
       if x.pval_prim <> []
       then pp f "@ =@ %a" (list constant_string) x.pval_prim
    ) x

and extension ctxt f (s, e) =
  pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e

and item_extension ctxt f (s, e) =
  pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e

and exception_declaration ctxt f ext =
  pp f "@[<hov2>exception@ %a@]" (extension_constructor ctxt) ext

and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} =
  let class_type_field f x =
    match x.pctf_desc with
    | Pctf_inherit (ct) ->
        pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct
          (item_attributes ctxt) x.pctf_attributes
    | Pctf_val (s, mf, vf, ct) ->
        pp f "@[<2>val @ %a%a%s@ :@ %a@]%a"
          mutable_flag mf virtual_flag vf s.txt (core_type ctxt) ct
          (item_attributes ctxt) x.pctf_attributes
    | Pctf_method (s, pf, vf, ct) ->
        pp f "@[<2>method %a %a%s :@;%a@]%a"
          private_flag pf virtual_flag vf s.txt (core_type ctxt) ct
          (item_attributes ctxt) x.pctf_attributes
    | Pctf_constraint (ct1, ct2) ->
        pp f "@[<2>constraint@ %a@ =@ %a@]%a"
          (core_type ctxt) ct1 (core_type ctxt) ct2
          (item_attributes ctxt) x.pctf_attributes
    | Pctf_attribute a -> floating_attribute ctxt f a
    | Pctf_extension e ->
        item_extension ctxt f e;
        item_attributes ctxt f x.pctf_attributes
  in
  pp f "@[<hv0>@[<hv2>object@[<1>%a@]@ %a@]@ end@]"
    (fun f -> function
         {ptyp_desc=Ptyp_any; ptyp_attributes=[]; _} -> ()
       | ct -> pp f " (%a)" (core_type ctxt) ct) ct
    (list class_type_field ~sep:"@;") l

(* call [class_signature] called by [class_signature] *)
and class_type ctxt f x =
  match x.pcty_desc with
  | Pcty_signature cs ->
      class_signature ctxt f cs;
      attributes ctxt f x.pcty_attributes
  | Pcty_constr (li, l) ->
      pp f "%a%a%a"
        (fun f l -> match l with
           | [] -> ()
           | _  -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l
        longident_loc li
        (attributes ctxt) x.pcty_attributes
  | Pcty_arrow (l, co, cl) ->
      pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
        (type_with_label ctxt) (l,co)
        (class_type ctxt) cl
  | Pcty_extension e ->
      extension ctxt f e;
      attributes ctxt f x.pcty_attributes
  | Pcty_open (ovf, lid, e) ->
      pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid
        (class_type ctxt) e

(* [class type a = object end] *)
and class_type_declaration_list ctxt f l =
  let class_type_declaration kwd f x =
    let { pci_params=ls; pci_name={ txt; _ }; _ } = x in
    pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd
      virtual_flag x.pci_virt
      (class_params_def ctxt) ls txt
      (class_type ctxt) x.pci_expr
      (item_attributes ctxt) x.pci_attributes
  in
  match l with
  | [] -> ()
  | [x] -> class_type_declaration "class type" f x
  | x :: xs ->
      pp f "@[<v>%a@,%a@]"
        (class_type_declaration "class type") x
        (list ~sep:"@," (class_type_declaration "and")) xs

and class_field ctxt f x =
  match x.pcf_desc with
  | Pcf_inherit (ovf, ce, so) ->
      pp f "@[<2>inherit@ %s@ %a%a@]%a" (override ovf)
        (class_expr ctxt) ce
        (fun f so -> match so with
           | None -> ();
           | Some (s) -> pp f "@ as %s" s.txt ) so
        (item_attributes ctxt) x.pcf_attributes
  | Pcf_val (s, mf, Cfk_concrete (ovf, e)) ->
      pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf)
        mutable_flag mf s.txt
        (expression ctxt) e
        (item_attributes ctxt) x.pcf_attributes
  | Pcf_method (s, pf, Cfk_virtual ct) ->
      pp f "@[<2>method virtual %a %s :@;%a@]%a"
        private_flag pf s.txt
        (core_type ctxt) ct
        (item_attributes ctxt) x.pcf_attributes
  | Pcf_val (s, mf, Cfk_virtual ct) ->
      pp f "@[<2>val virtual %a%s :@ %a@]%a"
        mutable_flag mf s.txt
        (core_type ctxt) ct
        (item_attributes ctxt) x.pcf_attributes
  | Pcf_method (s, pf, Cfk_concrete (ovf, e)) ->
      let bind e =
        binding ctxt f
          {pvb_pat=
             {ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]};
           pvb_expr=e;
           pvb_attributes=[];
           pvb_loc=Location.none;
          }
      in
      pp f "@[<2>method%s %a%a@]%a"
        (override ovf)
        private_flag pf
        (fun f -> function
           | {pexp_desc=Pexp_poly (e, Some ct); pexp_attributes=[]; _} ->
               pp f "%s :@;%a=@;%a"
                 s.txt (core_type ctxt) ct (expression ctxt) e
           | {pexp_desc=Pexp_poly (e, None); pexp_attributes=[]; _} ->
               bind e
           | _ -> bind e) e
        (item_attributes ctxt) x.pcf_attributes
  | Pcf_constraint (ct1, ct2) ->
      pp f "@[<2>constraint %a =@;%a@]%a"
        (core_type ctxt) ct1
        (core_type ctxt) ct2
        (item_attributes ctxt) x.pcf_attributes
  | Pcf_initializer (e) ->
      pp f "@[<2>initializer@ %a@]%a"
        (expression ctxt) e
        (item_attributes ctxt) x.pcf_attributes
  | Pcf_attribute a -> floating_attribute ctxt f a
  | Pcf_extension e ->
      item_extension ctxt f e;
      item_attributes ctxt f x.pcf_attributes

and class_structure ctxt f { pcstr_self = p; pcstr_fields =  l } =
  pp f "@[<hv0>@[<hv2>object%a@;%a@]@;end@]"
    (fun f p -> match p.ppat_desc with
       | Ppat_any -> ()
       | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p
       | _ -> pp f " (%a)" (pattern ctxt) p) p
    (list (class_field ctxt)) l

and class_expr ctxt f x =
  if x.pcl_attributes <> [] then begin
    pp f "((%a)%a)" (class_expr ctxt) {x with pcl_attributes=[]}
      (attributes ctxt) x.pcl_attributes
  end else
    match x.pcl_desc with
    | Pcl_structure (cs) -> class_structure ctxt f cs
    | Pcl_fun (l, eo, p, e) ->
        pp f "fun@ %a@ ->@ %a"
          (label_exp ctxt) (l,eo,p)
          (class_expr ctxt) e
    | Pcl_let (rf, l, ce) ->
        pp f "%a@ in@ %a"
          (bindings ctxt) (rf,l)
          (class_expr ctxt) ce
    | Pcl_apply (ce, l) ->
        pp f "((%a)@ %a)" (* Cf: #7200 *)
          (class_expr ctxt) ce
          (list (label_x_expression_param ctxt)) l
    | Pcl_constr (li, l) ->
        pp f "%a%a"
          (fun f l-> if l <>[] then
              pp f "[%a]@ "
                (list (core_type ctxt) ~sep:",") l) l
          longident_loc li
    | Pcl_constraint (ce, ct) ->
        pp f "(%a@ :@ %a)"
          (class_expr ctxt) ce
          (class_type ctxt) ct
    | Pcl_extension e -> extension ctxt f e
    | Pcl_open (ovf, lid, e) ->
        pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid
          (class_expr ctxt) e

and module_type ctxt f x =
  if x.pmty_attributes <> [] then begin
    pp f "((%a)%a)" (module_type ctxt) {x with pmty_attributes=[]}
      (attributes ctxt) x.pmty_attributes
  end else
    match x.pmty_desc with
    | Pmty_ident li ->
        pp f "%a" longident_loc li;
    | Pmty_alias li ->
        pp f "(module %a)" longident_loc li;
    | Pmty_signature (s) ->
        pp f "@[<hv0>@[<hv2>sig@ %a@]@ end@]" (* "@[<hov>sig@ %a@ end@]" *)
          (list (signature_item ctxt)) s (* FIXME wrong indentation*)
    | Pmty_functor (_, None, mt2) ->
        pp f "@[<hov2>functor () ->@ %a@]" (module_type ctxt) mt2
    | Pmty_functor (s, Some mt1, mt2) ->
        if s.txt = "_" then
          pp f "@[<hov2>%a@ ->@ %a@]"
            (module_type ctxt) mt1 (module_type ctxt) mt2
        else
          pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt
            (module_type ctxt) mt1 (module_type ctxt) mt2
    | Pmty_with (mt, l) ->
        let with_constraint f = function
          | Pwith_type (li, ({ptype_params= ls ;_} as td)) ->
              let ls = List.map fst ls in
              pp f "type@ %a %a =@ %a"
                (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
                ls longident_loc li (type_declaration ctxt) td
          | Pwith_module (li, li2) ->
              pp f "module %a =@ %a" longident_loc li longident_loc li2;
          | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) ->
              let ls = List.map fst ls in
              pp f "type@ %a %a :=@ %a"
                (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
                ls longident_loc li
                (type_declaration ctxt) td
          | Pwith_modsubst (li, li2) ->
             pp f "module %a :=@ %a" longident_loc li longident_loc li2 in
        (match l with
         | [] -> pp f "@[<hov2>%a@]" (module_type ctxt) mt
         | _ -> pp f "@[<hov2>(%a@ with@ %a)@]"
                  (module_type ctxt) mt (list with_constraint ~sep:"@ and@ ") l)
    | Pmty_typeof me ->
        pp f "@[<hov2>module@ type@ of@ %a@]" (module_expr ctxt) me
    | Pmty_extension e -> extension ctxt f e

and signature ctxt f x =  list ~sep:"@\n" (signature_item ctxt) f x

and signature_item ctxt f x : unit =
  match x.psig_desc with
  | Psig_type (rf, l) ->
      type_def_list ctxt f (rf, l)
  | Psig_value vd ->
      let intro = if vd.pval_prim = [] then "val" else "external" in
      pp f "@[<2>%s@ %a@ :@ %a@]%a" intro
        protect_ident vd.pval_name.txt
        (value_description ctxt) vd
        (item_attributes ctxt) vd.pval_attributes
  | Psig_typext te ->
      type_extension ctxt f te
  | Psig_exception ed ->
      exception_declaration ctxt f ed
  | Psig_class l ->
      let class_description kwd f ({pci_params=ls;pci_name={txt;_};_} as x) =
        pp f "@[<2>%s %a%a%s@;:@;%a@]%a" kwd
          virtual_flag x.pci_virt
          (class_params_def ctxt) ls txt
          (class_type ctxt) x.pci_expr
          (item_attributes ctxt) x.pci_attributes
      in begin
        match l with
        | [] -> ()
        | [x] -> class_description "class" f x
        | x :: xs ->
            pp f "@[<v>%a@,%a@]"
              (class_description "class") x
              (list ~sep:"@," (class_description "and")) xs
      end
  | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias;
                            pmty_attributes=[]; _};_} as pmd) ->
      pp f "@[<hov>module@ %s@ =@ %a@]%a" pmd.pmd_name.txt
        longident_loc alias
        (item_attributes ctxt) pmd.pmd_attributes
  | Psig_module pmd ->
      pp f "@[<hov>module@ %s@ :@ %a@]%a"
        pmd.pmd_name.txt
        (module_type ctxt) pmd.pmd_type
        (item_attributes ctxt) pmd.pmd_attributes
  | Psig_open od ->
      pp f "@[<hov2>open%s@ %a@]%a"
        (override od.popen_override)
        longident_loc od.popen_lid
        (item_attributes ctxt) od.popen_attributes
  | Psig_include incl ->
      pp f "@[<hov2>include@ %a@]%a"
        (module_type ctxt) incl.pincl_mod
        (item_attributes ctxt) incl.pincl_attributes
  | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
      pp f "@[<hov2>module@ type@ %s%a@]%a"
        s.txt
        (fun f md -> match md with
           | None -> ()
           | Some mt ->
               pp_print_space f () ;
               pp f "@ =@ %a" (module_type ctxt) mt
        ) md
        (item_attributes ctxt) attrs
  | Psig_class_type (l) -> class_type_declaration_list ctxt f l
  | Psig_recmodule decls ->
      let rec  string_x_module_type_list f ?(first=true) l =
        match l with
        | [] -> () ;
        | pmd :: tl ->
            if not first then
              pp f "@ @[<hov2>and@ %s:@ %a@]%a" pmd.pmd_name.txt
                (module_type ctxt) pmd.pmd_type
                (item_attributes ctxt) pmd.pmd_attributes
            else
              pp f "@[<hov2>module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt
                (module_type ctxt) pmd.pmd_type
                (item_attributes ctxt) pmd.pmd_attributes;
            string_x_module_type_list f ~first:false tl
      in
      string_x_module_type_list f decls
  | Psig_attribute a -> floating_attribute ctxt f a
  | Psig_extension(e, a) ->
      item_extension ctxt f e;
      item_attributes ctxt f a

and module_expr ctxt f x =
  if x.pmod_attributes <> [] then
    pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]}
      (attributes ctxt) x.pmod_attributes
  else match x.pmod_desc with
    | Pmod_structure (s) ->
        pp f "@[<hv2>struct@;@[<0>%a@]@;<1 -2>end@]"
          (list (structure_item ctxt) ~sep:"@\n") s;
    | Pmod_constraint (me, mt) ->
        pp f "@[<hov2>(%a@ :@ %a)@]"
          (module_expr ctxt) me
          (module_type ctxt) mt
    | Pmod_ident (li) ->
        pp f "%a" longident_loc li;
    | Pmod_functor (_, None, me) ->
        pp f "functor ()@;->@;%a" (module_expr ctxt) me
    | Pmod_functor (s, Some mt, me) ->
        pp f "functor@ (%s@ :@ %a)@;->@;%a"
          s.txt (module_type ctxt) mt (module_expr ctxt) me
    | Pmod_apply (me1, me2) ->
        pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2
        (* Cf: #7200 *)
    | Pmod_unpack e ->
        pp f "(val@ %a)" (expression ctxt) e
    | Pmod_extension e -> extension ctxt f e

and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x

and payload ctxt f = function
  | PStr [{pstr_desc = Pstr_eval (e, attrs)}] ->
      pp f "@[<2>%a@]%a"
        (expression ctxt) e
        (item_attributes ctxt) attrs
  | PStr x -> structure ctxt f x
  | PTyp x -> pp f ":"; core_type ctxt f x
  | PSig x -> pp f ":"; signature ctxt f x
  | PPat (x, None) -> pp f "?"; pattern ctxt f x
  | PPat (x, Some e) ->
      pp f "?"; pattern ctxt f x;
      pp f " when "; expression ctxt f e

(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *)
and binding ctxt f {pvb_pat=p; pvb_expr=x; _} =
  (* .pvb_attributes have already been printed by the caller, #bindings *)
  let rec pp_print_pexp_function f x =
    if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x
    else match x.pexp_desc with
      | Pexp_fun (label, eo, p, e) ->
          if label=Nolabel then
            pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e
          else
            pp f "%a@ %a"
              (label_exp ctxt) (label,eo,p) pp_print_pexp_function e
      | Pexp_newtype (str,e) ->
          pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e
      | _ -> pp f "=@;%a" (expression ctxt) x
  in
  let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in
  let is_desugared_gadt p e =
    let gadt_pattern =
      match p with
      | {ppat_desc=Ppat_constraint({ppat_desc=Ppat_var _} as pat,
                                   {ptyp_desc=Ptyp_poly (args_tyvars, rt)});
         ppat_attributes=[]}->
          Some (pat, args_tyvars, rt)
      | _ -> None in
    let rec gadt_exp tyvars e =
      match e with
      | {pexp_desc=Pexp_newtype (tyvar, e); pexp_attributes=[]} ->
          gadt_exp (tyvar :: tyvars) e
      | {pexp_desc=Pexp_constraint (e, ct); pexp_attributes=[]} ->
          Some (List.rev tyvars, e, ct)
      | _ -> None in
    let gadt_exp = gadt_exp [] e in
    match gadt_pattern, gadt_exp with
    | Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct)
      when tyvars_str pt_tyvars = tyvars_str e_tyvars ->
      let ety = Typ.varify_constructors e_tyvars e_ct in
      if ety = pt_ct then
      Some (p, pt_tyvars, e_ct, e) else None
    | _ -> None in
  if x.pexp_attributes <> []
  then pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x else
  match is_desugared_gadt p x with
  | Some (p, [], ct, e) ->
      pp f "%a@;: %a@;=@;%a"
        (simple_pattern ctxt) p (core_type ctxt) ct (expression ctxt) e
  | Some (p, tyvars, ct, e) -> begin
    pp f "%a@;: type@;%a.@;%a@;=@;%a"
    (simple_pattern ctxt) p (list pp_print_string ~sep:"@;")
    (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e
    end
  | None -> begin
      match p with
      | {ppat_desc=Ppat_constraint(p ,ty);
         ppat_attributes=[]} -> (* special case for the first*)
          begin match ty with
          | {ptyp_desc=Ptyp_poly _; ptyp_attributes=[]} ->
              pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p
                (core_type ctxt) ty (expression ctxt) x
          | _ ->
              pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p
                (core_type ctxt) ty (expression ctxt) x
          end
      | {ppat_desc=Ppat_var _; ppat_attributes=[]} ->
          pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x
      | _ ->
          pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x
    end

(* [in] is not printed *)
and bindings ctxt f (rf,l) =
  let binding kwd rf f x =
    pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf
      (binding ctxt) x (item_attributes ctxt) x.pvb_attributes
  in
  match l with
  | [] -> ()
  | [x] -> binding "let" rf f x
  | x::xs ->
      pp f "@[<v>%a@,%a@]"
        (binding "let" rf) x
        (list ~sep:"@," (binding "and" Nonrecursive)) xs

and structure_item ctxt f x =
  match x.pstr_desc with
  | Pstr_eval (e, attrs) ->
      pp f "@[<hov2>;;%a@]%a"
        (expression ctxt) e
        (item_attributes ctxt) attrs
  | Pstr_type (_, []) -> assert false
  | Pstr_type (rf, l)  -> type_def_list ctxt f (rf, l)
  | Pstr_value (rf, l) ->
      (* pp f "@[<hov2>let %a%a@]"  rec_flag rf bindings l *)
      pp f "@[<2>%a@]" (bindings ctxt) (rf,l)
  | Pstr_typext te -> type_extension ctxt f te
  | Pstr_exception ed -> exception_declaration ctxt f ed
  | Pstr_module x ->
      let rec module_helper = function
        | {pmod_desc=Pmod_functor(s,mt,me'); pmod_attributes = []} ->
            if mt = None then pp f "()"
            else Misc.may (pp f "(%s:%a)" s.txt (module_type ctxt)) mt;
            module_helper me'
        | me -> me
      in
      pp f "@[<hov2>module %s%a@]%a"
        x.pmb_name.txt
        (fun f me ->
           let me = module_helper me in
           match me with
           | {pmod_desc=
                Pmod_constraint
                  (me',
                   ({pmty_desc=(Pmty_ident (_)
                               | Pmty_signature (_));_} as mt));
              pmod_attributes = []} ->
               pp f " :@;%a@;=@;%a@;"
                 (module_type ctxt) mt (module_expr ctxt) me'
           | _ -> pp f " =@ %a" (module_expr ctxt) me
        ) x.pmb_expr
        (item_attributes ctxt) x.pmb_attributes
  | Pstr_open od ->
      pp f "@[<2>open%s@;%a@]%a"
        (override od.popen_override)
        longident_loc od.popen_lid
        (item_attributes ctxt) od.popen_attributes
  | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
      pp f "@[<hov2>module@ type@ %s%a@]%a"
        s.txt
        (fun f md -> match md with
           | None -> ()
           | Some mt ->
               pp_print_space f () ;
               pp f "@ =@ %a" (module_type ctxt) mt
        ) md
        (item_attributes ctxt) attrs
  | Pstr_class l ->
      let extract_class_args cl =
        let rec loop acc = function
          | {pcl_desc=Pcl_fun (l, eo, p, cl'); pcl_attributes = []} ->
              loop ((l,eo,p) :: acc) cl'
          | cl -> List.rev acc, cl
        in
        let args, cl = loop [] cl in
        let constr, cl =
          match cl with
          | {pcl_desc=Pcl_constraint (cl', ct); pcl_attributes = []} ->
              Some ct, cl'
          | _ -> None, cl
        in
        args, constr, cl
      in
      let class_constraint f ct = pp f ": @[%a@] " (class_type ctxt) ct in
      let class_declaration kwd f
          ({pci_params=ls; pci_name={txt;_}; _} as x) =
        let args, constr, cl = extract_class_args x.pci_expr in
        pp f "@[<2>%s %a%a%s %a%a=@;%a@]%a" kwd
          virtual_flag x.pci_virt
          (class_params_def ctxt) ls txt
          (list (label_exp ctxt)) args
          (option class_constraint) constr
          (class_expr ctxt) cl
          (item_attributes ctxt) x.pci_attributes
      in begin
        match l with
        | [] -> ()
        | [x] -> class_declaration "class" f x
        | x :: xs ->
            pp f "@[<v>%a@,%a@]"
              (class_declaration "class") x
              (list ~sep:"@," (class_declaration "and")) xs
      end
  | Pstr_class_type l -> class_type_declaration_list ctxt f l
  | Pstr_primitive vd ->
      pp f "@[<hov2>external@ %a@ :@ %a@]%a"
        protect_ident vd.pval_name.txt
        (value_description ctxt) vd
        (item_attributes ctxt) vd.pval_attributes
  | Pstr_include incl ->
      pp f "@[<hov2>include@ %a@]%a"
        (module_expr ctxt) incl.pincl_mod
        (item_attributes ctxt) incl.pincl_attributes
  | Pstr_recmodule decls -> (* 3.07 *)
      let aux f = function
        | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) ->
            pp f "@[<hov2>@ and@ %s:%a@ =@ %a@]%a" pmb.pmb_name.txt
              (module_type ctxt) typ
              (module_expr ctxt) expr
              (item_attributes ctxt) pmb.pmb_attributes
        | _ -> assert false
      in
      begin match decls with
      | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 ->
          pp f "@[<hv>@[<hov2>module@ rec@ %s:%a@ =@ %a@]%a@ %a@]"
            pmb.pmb_name.txt
            (module_type ctxt) typ
            (module_expr ctxt) expr
            (item_attributes ctxt) pmb.pmb_attributes
            (fun f l2 -> List.iter (aux f) l2) l2
      | _ -> assert false
      end
  | Pstr_attribute a -> floating_attribute ctxt f a
  | Pstr_extension(e, a) ->
      item_extension ctxt f e;
      item_attributes ctxt f a

and type_param ctxt f (ct, a) =
  pp f "%s%a" (type_variance a) (core_type ctxt) ct

and type_params ctxt f = function
  | [] -> ()
  | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l

and type_def_list ctxt f (rf, l) =
  let type_decl kwd rf f x =
    let eq =
      if (x.ptype_kind = Ptype_abstract)
         && (x.ptype_manifest = None) then ""
      else " ="
    in
    pp f "@[<2>%s %a%a%s%s%a@]%a" kwd
      nonrec_flag rf
      (type_params ctxt) x.ptype_params
      x.ptype_name.txt eq
      (type_declaration ctxt) x
      (item_attributes ctxt) x.ptype_attributes
  in
  match l with
  | [] -> assert false
  | [x] -> type_decl "type" rf f x
  | x :: xs -> pp f "@[<v>%a@,%a@]"
                 (type_decl "type" rf) x
                 (list ~sep:"@," (type_decl "and" Recursive)) xs

and record_declaration ctxt f lbls =
  let type_record_field f pld =
    pp f "@[<2>%a%s:@;%a@;%a@]"
      mutable_flag pld.pld_mutable
      pld.pld_name.txt
      (core_type ctxt) pld.pld_type
      (attributes ctxt) pld.pld_attributes
  in
  pp f "{@\n%a}"
    (list type_record_field ~sep:";@\n" )  lbls

and type_declaration ctxt f x =
  (* type_declaration has an attribute field,
     but it's been printed by the caller of this method *)
  let priv f =
    match x.ptype_private with
    | Public -> ()
    | Private -> pp f "@;private"
  in
  let manifest f =
    match x.ptype_manifest with
    | None -> ()
    | Some y ->
        if x.ptype_kind = Ptype_abstract then
          pp f "%t@;%a" priv (core_type ctxt) y
        else
          pp f "@;%a" (core_type ctxt) y
  in
  let constructor_declaration f pcd =
    pp f "|@;";
    constructor_declaration ctxt f
      (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes)
  in
  let repr f =
    let intro f =
      if x.ptype_manifest = None then ()
      else pp f "@;="
    in
    match x.ptype_kind with
    | Ptype_variant xs ->
        pp f "%t%t@\n%a" intro priv
          (list ~sep:"@\n" constructor_declaration) xs
    | Ptype_abstract -> ()
    | Ptype_record l ->
        pp f "%t%t@;%a" intro priv (record_declaration ctxt) l
    | Ptype_open -> pp f "%t%t@;.." intro priv
  in
  let constraints f =
    List.iter
      (fun (ct1,ct2,_) ->
         pp f "@[<hov2>@ constraint@ %a@ =@ %a@]"
           (core_type ctxt) ct1 (core_type ctxt) ct2)
      x.ptype_cstrs
  in
  pp f "%t%t%t" manifest repr constraints

and type_extension ctxt f x =
  let extension_constructor f x =
    pp f "@\n|@;%a" (extension_constructor ctxt) x
  in
  pp f "@[<2>type %a%a += %a@ %a@]%a"
    (fun f -> function
       | [] -> ()
       | l ->
           pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l)
    x.ptyext_params
    longident_loc x.ptyext_path
    private_flag x.ptyext_private (* Cf: #7200 *)
    (list ~sep:"" extension_constructor)
    x.ptyext_constructors
    (item_attributes ctxt) x.ptyext_attributes

and constructor_declaration ctxt f (name, args, res, attrs) =
  let name =
    match name with
    | "::" -> "(::)"
    | s -> s in
  match res with
  | None ->
      pp f "%s%a@;%a" name
        (fun f -> function
           | Pcstr_tuple [] -> ()
           | Pcstr_tuple l ->
             pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l
           | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l
        ) args
        (attributes ctxt) attrs
  | Some r ->
      pp f "%s:@;%a@;%a" name
        (fun f -> function
           | Pcstr_tuple [] -> core_type1 ctxt f r
           | Pcstr_tuple l -> pp f "%a@;->@;%a"
                                (list (core_type1 ctxt) ~sep:"@;*@;") l
                                (core_type1 ctxt) r
           | Pcstr_record l ->
               pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r
        )
        args
        (attributes ctxt) attrs

and extension_constructor ctxt f x =
  (* Cf: #7200 *)
  match x.pext_kind with
  | Pext_decl(l, r) ->
      constructor_declaration ctxt f (x.pext_name.txt, l, r, x.pext_attributes)
  | Pext_rebind li ->
      pp f "%s%a@;=@;%a" x.pext_name.txt
        (attributes ctxt) x.pext_attributes
        longident_loc li

and case_list ctxt f l : unit =
  let aux f {pc_lhs; pc_guard; pc_rhs} =
    pp f "@;| @[<2>%a%a@;->@;%a@]"
      (pattern ctxt) pc_lhs (option (expression ctxt) ~first:"@;when@;")
      pc_guard (expression (under_pipe ctxt)) pc_rhs
  in
  list aux f l ~sep:""

and label_x_expression_param ctxt f (l,e) =
  let simple_name = match e with
    | {pexp_desc=Pexp_ident {txt=Lident l;_};
       pexp_attributes=[]} -> Some l
    | _ -> None
  in match l with
  | Nolabel  -> expression2 ctxt f e (* level 2*)
  | Optional str ->
      if Some str = simple_name then
        pp f "?%s" str
      else
        pp f "?%s:%a" str (simple_expr ctxt) e
  | Labelled lbl ->
      if Some lbl = simple_name then
        pp f "~%s" lbl
      else
        pp f "~%s:%a" lbl (simple_expr ctxt) e

and directive_argument f x =
  match x with
  | Pdir_none -> ()
  | Pdir_string (s) -> pp f "@ %S" s
  | Pdir_int (n, None) -> pp f "@ %s" n
  | Pdir_int (n, Some m) -> pp f "@ %s%c" n m
  | Pdir_ident (li) -> pp f "@ %a" longident li
  | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b)

let toplevel_phrase f x =
  match x with
  | Ptop_def (s) ->pp f "@[<hov0>%a@]"  (list (structure_item reset_ctxt)) s
   (* pp_open_hvbox f 0; *)
   (* pp_print_list structure_item f s ; *)
   (* pp_close_box f (); *)
  | Ptop_dir (s, da) ->
   pp f "@[<hov2>#%s@ %a@]" s directive_argument da
   (* pp f "@[<hov2>#%s@ %a@]" s directive_argument da *)

let expression f x =
  pp f "@[%a@]" (expression reset_ctxt) x

let string_of_expression x =
  ignore (flush_str_formatter ()) ;
  let f = str_formatter in
  expression f x;
  flush_str_formatter ()

let string_of_structure x =
  ignore (flush_str_formatter ());
  let f = str_formatter in
  structure reset_ctxt f x;
  flush_str_formatter ()

let top_phrase f x =
  pp_print_newline f ();
  toplevel_phrase f x;
  pp f ";;";
  pp_print_newline f ()

let core_type = core_type reset_ctxt
let pattern = pattern reset_ctxt
let signature = signature reset_ctxt
let structure = structure reset_ctxt

end
module Ast_bs_open : sig 
#1 "ast_bs_open.mli"
(* Copyright (C) 2019- Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)




 val convertBsErrorFunction :    
   Location.t -> 
   Bs_ast_mapper.mapper -> 
   Ast_helper.attrs -> 
   Parsetree.case list ->
   Parsetree.expression

end = struct
#1 "ast_bs_open.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


let isCamlExceptionOrOpenVariant : Longident.t = 
  Ldot (Ldot (Lident "Js","Exn"), "isCamlExceptionOrOpenVariant")

  
let obj_magic : Longident.t = 
  Ldot (Lident "Obj", "magic")


let rec checkCases (cases : Parsetree.case list) = 
  List.iter check_case cases 
and check_case case = 
  check_pat case.pc_lhs 
and check_pat (pat : Parsetree.pattern) = 
  match pat.ppat_desc with 
  | Ppat_construct _ -> ()
  | Ppat_or (l,r) -> 
    check_pat l; check_pat r 
  | _ ->  Location.raise_errorf ~loc:pat.ppat_loc "Unsupported pattern in `bs.open`" 

let convertBsErrorFunction loc  
  (self : Bs_ast_mapper.mapper) 
  attrs 
  (cases : Parsetree.case list ) =
  let open Ast_helper in
  let txt  = "match" in 
  let txt_expr = Exp.ident ~loc {txt = Lident txt; loc} in 
  let none = Exp.construct ~loc {txt = Ast_literal.predef_none ; loc} None in
  let () = checkCases cases in  
  let cases = self.cases self cases in 
  Ast_compatible.fun_ ~attrs ~loc ( Pat.var ~loc  {txt; loc })
    (Exp.ifthenelse
    ~loc 
    (Ast_compatible.app1 ~loc (Exp.ident ~loc {txt = isCamlExceptionOrOpenVariant ; loc}) txt_expr )
    (Exp.match_ ~loc 
       (Exp.constraint_ ~loc 
          (Ast_compatible.app1  ~loc (Exp.ident ~loc {txt =  obj_magic; loc})  txt_expr)
          (Ast_literal.type_exn ~loc ())
       )
      (Ext_list.map_append cases 
        [ Exp.case  (Pat.any ~loc ()) none] 
        (fun x ->
           let pc_rhs = x.pc_rhs in 
           let  loc  = pc_rhs.pexp_loc in
           {
             x with pc_rhs = Exp.construct ~loc {txt = Ast_literal.predef_some;loc} (Some pc_rhs)
                        
           })))
    (Some none))
    
                       
    

end
module Ast_core_type_class_type : sig 
#1 "ast_core_type_class_type.mli"
(* Copyright (C) 2018 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



val handle_class_type_fields :  
  Bs_ast_mapper.mapper ->
  Parsetree.class_type_field list -> 
  Parsetree.class_type_field list 

val typ_mapper :
  bool ref ->
  Bs_ast_mapper.mapper ->
  Parsetree.core_type ->  
  Parsetree.core_type
end = struct
#1 "ast_core_type_class_type.ml"
(* Copyright (C) 2018 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
open Ast_helper

let process_getter_setter 
    ~not_getter_setter
    ~(get : Parsetree.core_type -> _ -> Parsetree.attributes -> _) ~set
    loc name
    (attrs : Ast_attributes.t)
    (ty : Parsetree.core_type) (acc : _ list)  =
  match Ast_attributes.process_method_attributes_rev attrs with 
  | {get = None; set = None}, _  ->  not_getter_setter ty :: acc 
  | st , pctf_attributes
    -> 
    let get_acc = 
      match st.set with 
      | Some `No_get -> acc 
      | None 
      | Some `Get -> 
        let lift txt = 
          Typ.constr ~loc {txt ; loc} [ty] in
        let (null,undefined) =                
          match st with 
          | {get = Some (null, undefined) } -> (null, undefined)
          | {get = None} -> (false, false ) in 
        let ty = 
          match (null,undefined) with 
          | false, false -> ty
          | true, false -> lift Ast_literal.Lid.js_null
          | false, true -> lift Ast_literal.Lid.js_undefined
          | true , true -> lift Ast_literal.Lid.js_null_undefined in
        get ty name pctf_attributes
        :: acc  
    in 
    if st.set = None then get_acc 
    else
      set ty 

    ({name with txt = name.Asttypes.txt ^ Literals.setter_suffix} : _ Asttypes.loc)

      pctf_attributes         
      :: get_acc 


let handle_class_type_field self
    ({pctf_loc = loc } as ctf : Parsetree.class_type_field)
    acc =
  match ctf.pctf_desc with 
  | Pctf_method 
      (name, private_flag, virtual_flag, ty) 
    ->
    let not_getter_setter (ty : Parsetree.core_type) =
      let ty = 
        match ty.ptyp_desc with 
        | Ptyp_arrow (label, args, body) 
          ->
          Ast_util.to_method_type
            ty.ptyp_loc  self label args body

        | Ptyp_poly (strs, {ptyp_desc = Ptyp_arrow (label, args, body);
                            ptyp_loc})
          ->
          {ty with ptyp_desc = 
                     Ptyp_poly(strs,             
                               Ast_util.to_method_type
                                 ptyp_loc  self label args body  )}
        | _ -> 
          self.typ self ty
      in 
      {ctf with 
       pctf_desc = 
         Pctf_method (name , private_flag, virtual_flag, ty)}
    in
    let get ty name pctf_attributes =
      {ctf with 
       pctf_desc =  
         Pctf_method (name , 
                      private_flag, 
                      virtual_flag, 
                      self.typ self ty
                     );
       pctf_attributes} in
    let set ty name pctf_attributes =
      {ctf with 
       pctf_desc =
         Pctf_method (name, 
                      private_flag,
                      virtual_flag,
                      Ast_util.to_method_type
                        loc self Ast_compatible.no_label ty
                        (Ast_literal.type_unit ~loc ())
                     );
       pctf_attributes} in
    process_getter_setter ~not_getter_setter ~get ~set loc name ctf.pctf_attributes ty acc     

  | Pctf_inherit _ 
  | Pctf_val _ 
  | Pctf_constraint _
  | Pctf_attribute _ 
  | Pctf_extension _  -> 
    Bs_ast_mapper.default_mapper.class_type_field self ctf :: acc 
      

let default_typ_mapper = Bs_ast_mapper.default_mapper.typ
(*
  Attributes are very hard to attribute
  (since ptyp_attributes could happen in so many places), 
  and write ppx extensions correctly, 
  we can only use it locally
*)

let typ_mapper 
    record_as_js_object
    (self : Bs_ast_mapper.mapper)
    (ty : Parsetree.core_type) 
  = 
  match ty with
  | {ptyp_desc = Ptyp_extension({txt = ("bs.obj"|"obj")}, PTyp ty)}
    -> 
    Ext_ref.non_exn_protect record_as_js_object true 
      (fun _ -> self.typ self ty )
  | {ptyp_attributes ;
     ptyp_desc = Ptyp_arrow (label, args, body);
     (* let it go without regard label names, 
        it will report error later when the label is not empty
     *)     
     ptyp_loc = loc
    } ->
    begin match  Ast_attributes.process_attributes_rev ptyp_attributes with 
      | Uncurry _, ptyp_attributes ->
        Ast_util.to_uncurry_type loc self label args body 
      | Meth_callback _, ptyp_attributes ->
        Ast_util.to_method_callback_type loc self label args body
      | Method _, ptyp_attributes ->
        Ast_util.to_method_type loc self label args body
      | Nothing , _ -> 
        Bs_ast_mapper.default_mapper.typ self ty
    end
  | {
    ptyp_desc =  Ptyp_object ( methods, closed_flag) ;
    ptyp_loc = loc 
  } -> 
    let (+>) attr (typ : Parsetree.core_type) =
      {typ with ptyp_attributes = attr :: typ.ptyp_attributes} in           
    let new_methods =
      Ext_list.fold_right  methods []  (fun  meth_ acc ->
        match meth_ with 

        | Parsetree.Oinherit _ -> meth_ :: acc 
        | Parsetree.Otag 
        
          (label, ptyp_attrs, core_type) -> 
          let get ty name attrs =
            let attrs, core_type =
              match Ast_attributes.process_attributes_rev attrs with
              | Nothing, attrs -> attrs, ty (* #1678 *)
              | Uncurry attr , attrs ->
                attrs, attr +> ty
              | Method _, _
                -> Location.raise_errorf ~loc "bs.get/set conflicts with bs.meth"
              | Meth_callback attr, attrs ->
                attrs, attr +> ty 
            in 
            Ast_compatible.object_field name  attrs (self.typ self core_type) in
          let set ty name attrs =
            let attrs, core_type =
              match Ast_attributes.process_attributes_rev attrs with
              | Nothing, attrs -> attrs, ty
              | Uncurry attr, attrs ->
                attrs, attr +> ty 
              | Method _, _
                -> Location.raise_errorf ~loc "bs.get/set conflicts with bs.meth"
              | Meth_callback attr, attrs ->
                attrs, attr +> ty
            in               
            Ast_compatible.object_field name attrs (Ast_util.to_method_type loc self Ast_compatible.no_label core_type 
              (Ast_literal.type_unit ~loc ())) in
          let not_getter_setter ty =
            let attrs, core_type =
              match Ast_attributes.process_attributes_rev ptyp_attrs with
              | Nothing, attrs -> attrs, ty
              | Uncurry attr, attrs ->
                attrs, attr +> ty 
              | Method attr, attrs -> 
                attrs, attr +> ty 
              | Meth_callback attr, attrs ->
                attrs, attr +> ty  in            
            Ast_compatible.object_field label attrs (self.typ self core_type) in
          process_getter_setter ~not_getter_setter ~get ~set
            loc label ptyp_attrs core_type acc
        )in      
    let inner_type =
      { ty
        with ptyp_desc = Ptyp_object(new_methods, closed_flag);
      } in 
    if !record_as_js_object then 
      Ast_comb.to_js_type loc inner_type          
    else inner_type
  | _ -> default_typ_mapper self ty
    
let handle_class_type_fields self fields = 
  Ext_list.fold_right fields []
  (handle_class_type_field self)
  

end
module Ast_derive_util : sig 
#1 "ast_derive_util.mli"
(* Copyright (C) 2017 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

(** Given a type declaration, extaract the type expression, mostly 
  used in code gen later
 *)
 val core_type_of_type_declaration :
  Parsetree.type_declaration -> Parsetree.core_type

val new_type_of_type_declaration : 
  Parsetree.type_declaration -> 
  string -> 
  Parsetree.core_type * Parsetree.type_declaration


val mk_fun :
  loc:Location.t ->
  Parsetree.core_type ->
  string -> Parsetree.expression -> Parsetree.expression
val destruct_label_declarations :
  loc:Location.t ->
  string ->
  Parsetree.label_declaration list ->
  (Parsetree.core_type * Parsetree.expression) list * string list

val notApplicable:   
  Location.t ->
  string -> 
  unit 

val invalid_config : Parsetree.expression -> 'a   
end = struct
#1 "ast_derive_util.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

open Ast_helper

let core_type_of_type_declaration 
    (tdcl : Parsetree.type_declaration) = 
  match tdcl with 
  | {ptype_name = {txt ; loc};
     ptype_params ;
    } -> 
    Typ.constr 
      {txt = Lident txt ; loc}
      (Ext_list.map ptype_params  fst)

let new_type_of_type_declaration 
    (tdcl : Parsetree.type_declaration) newName = 
  match tdcl with 
  | {ptype_name = { loc};
     ptype_params ;
    } -> 
    (Typ.constr 
      {txt = Lident newName ; loc}
      (Ext_list.map ptype_params fst ),
      { Parsetree.ptype_params = tdcl.ptype_params;
        ptype_name = {txt = newName;loc};
        ptype_kind = Ptype_abstract; 
        ptype_attributes = [];
        ptype_loc = tdcl.ptype_loc;
        ptype_cstrs = []; ptype_private = Public; ptype_manifest = None}
    )
      

let mk_fun ~loc (typ : Parsetree.core_type) 
    (value : string) body
  : Parsetree.expression = 
  Ast_compatible.fun_
    (Pat.constraint_ (Pat.var {txt = value ; loc}) typ)
    body

let destruct_label_declarations ~loc
    (arg_name : string)
    (labels : Parsetree.label_declaration list) : 
  (Parsetree.core_type * Parsetree.expression) list * string list 
  =
  Ext_list.fold_right labels ([], [])
    (fun {pld_name = {txt}; pld_type} 
      (core_type_exps, labels) -> 
      ((pld_type, 
        Exp.field (Exp.ident {txt = Lident arg_name ; loc}) 
          {txt = Lident txt ; loc}) :: core_type_exps),
      txt :: labels 
    ) 

let notApplicable 
  loc derivingName = 
  Location.prerr_warning 
    loc
    (Warnings.Bs_derive_warning ( derivingName ^ " not applicable to this type"))
    
let invalid_config (config : Parsetree.expression) = 
  Location.raise_errorf ~loc:config.pexp_loc "such configuration is not supported"
    
end
module Ast_derive_js_mapper : sig 
#1 "ast_derive_js_mapper.mli"
(* Copyright (C) 2017 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



val init : unit -> unit
end = struct
#1 "ast_derive_js_mapper.ml"
(* Copyright (C) 2017 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

open Ast_helper
module U = Ast_derive_util
type tdcls = Parsetree.type_declaration list 

let js_field (o : Parsetree.expression) m = 
  Ast_compatible.app2
    (Exp.ident {txt = Lident "##"; loc = o.pexp_loc})
    o
    (Exp.ident m)




let handle_config (config : Parsetree.expression option) = 
  match config with 
  | Some config -> 
    (match config.pexp_desc with 
     | Pexp_record (
         [ 
           {txt = Lident "newType"}, 
           {pexp_desc = 
              (Pexp_construct 
                 (
                   {txt =
                      Lident ("true" 
                             | "false" 
                               as x)}, None)
              | Pexp_ident {txt = Lident ("newType" as x)}
              )
           }
         ],None)
       ->  not (x = "false")
     | Pexp_ident {txt = Lident ("newType")} 
       -> true
     | _ -> U.invalid_config config)
  | None -> false
let noloc = Location.none
(* [eraseType] will be instrumented, be careful about the name conflict*)  
let eraseTypeLit = "jsMapperEraseType"
let eraseTypeExp = Exp.ident {loc = noloc; txt = Lident eraseTypeLit}
let eraseType x = 
  Ast_compatible.app1 eraseTypeExp  x
let eraseTypeStr = 
  let any = Typ.any () in 
  Str.primitive 
    (Val.mk ~prim:["%identity"] {loc = noloc; txt = eraseTypeLit}
       (Ast_compatible.arrow any any)
    )

let app2 = Ast_compatible.app2
let app3 = Ast_compatible.app3

let (<=~) a b =   
  app2 (Exp.ident {loc = noloc; txt = Lident "<="}) a b 
let (-~) a b =   
  app2 (Exp.ident {loc = noloc; txt = Ldot(Lident "Pervasives","-")})
    a b 
let (+~) a b =   
  app2 (Exp.ident {loc = noloc; txt = Ldot(Lident "Pervasives","+")})
    a b 
let (&&~) a b =   
  app2 (Exp.ident {loc = noloc; txt = Ldot(Lident "Pervasives","&&")})
    a b 
let (->~) a b = Ast_compatible.arrow a b 
let jsMapperRt =     
  Longident.Ldot (Lident "Js", "MapperRt")

let search upper polyvar array = 
  app3
    (Exp.ident ({loc = noloc; 
                 txt = Longident.Ldot (jsMapperRt,"binarySearch") })
    )                                 
    upper
    (eraseType polyvar)
    array

let revSearch len constantArray exp =   
  app3 
    (Exp.ident 
       {loc= noloc; 
        txt = Longident.Ldot (jsMapperRt, "revSearch")})
    len
    constantArray
    exp

let revSearchAssert  len constantArray exp =   
  app3 
    (Exp.ident 
       {loc= noloc; 
        txt = Longident.Ldot (jsMapperRt, "revSearchAssert")})
    len
    constantArray
    exp

let toInt exp array =     
  app2
    (Exp.ident 
       { loc=noloc; 
         txt = Longident.Ldot (jsMapperRt, "toInt")})
    (eraseType exp)
    array
let fromInt len array exp = 
  app3
    (Exp.ident 
       {loc = noloc; 
        txt = Longident.Ldot (jsMapperRt,"fromInt")})
    len
    array
    exp

let fromIntAssert len array exp = 
  app3
    (Exp.ident 
       {loc = noloc; 
        txt = Longident.Ldot (jsMapperRt,"fromIntAssert")})
    len
    array
    exp


let assertExp e = 
  Exp.extension 
    ({Asttypes.loc = noloc; txt = "assert"},
     (PStr 
        [Str.eval e ]
     )
    )
let derivingName = "jsConverter"

(* let notApplicable loc = 
   Location.prerr_warning 
    loc
    (Warnings.Bs_derive_warning ( derivingName ^ " not applicable to this type")) *)

let init () =      
  Ast_derive.register
    derivingName
    (fun ( x : Parsetree.expression option) -> 
       let createType = handle_config x in 

       {
         structure_gen = (fun (tdcls : tdcls) _ -> 
             let handle_tdcl (tdcl: Parsetree.type_declaration) =
               let core_type = U.core_type_of_type_declaration tdcl
               in 
               let name = tdcl.ptype_name.txt in 
               let toJs = name ^ "ToJs" in 
               let fromJs = name ^ "FromJs" in 
               let constantArray = "jsMapperConstantArray" in 
               let loc = tdcl.ptype_loc in 
               let patToJs = {Asttypes.loc; txt = toJs} in 
               let patFromJs = {Asttypes.loc; txt = fromJs} in 
               let param = "param" in 

               let ident_param = {Asttypes.txt = Longident.Lident param; loc} in 
               let pat_param = {Asttypes.loc; txt = param} in 
               let exp_param = Exp.ident ident_param in 
               let newType,newTdcl =
                 U.new_type_of_type_declaration tdcl ("abs_" ^ name) in 
               let newTypeStr = Ast_compatible.rec_type_str [newTdcl] in   
               let toJsBody body = 
                 Ast_comb.single_non_rec_value patToJs
                   (Ast_compatible.fun_ (Pat.constraint_ (Pat.var pat_param) core_type) 
                      body )
               in 
               let (+>) a ty = 
                 Exp.constraint_ (eraseType a) ty in 
               let (+:) a ty =                  
                 eraseType (Exp.constraint_ a ty) in 
               let coerceResultToNewType e =
                 if createType then 
                   e +> newType
                 else e  in                  
               match tdcl.ptype_kind with  
               | Ptype_record label_declarations -> 
                 let exp = 
                   coerceResultToNewType
                     (Exp.extension 
                        (
                          {Asttypes.loc; txt = "bs.obj"},
                          (PStr
                             [Str.eval  
                                (Exp.record
                                   (Ext_list.map label_declarations
                                      (fun {pld_name = {loc; txt } }  -> 
                                         let label = 
                                           {Asttypes.loc; txt = Longident.Lident txt } in 
                                         label,Exp.field exp_param label) ) None)]))) in 
                 let toJs = 
                   toJsBody exp
                 in 
                 let obj_exp = 
                   Exp.record
                     (Ext_list.map label_declarations
                        (fun {pld_name = {loc; txt } } -> 
                           let label = 
                             {Asttypes.loc; txt = Longident.Lident txt } in 
                           label,
                           js_field exp_param  label) ) None in 
                 let fromJs = 
                   Ast_comb.single_non_rec_value patFromJs
                     (Ast_compatible.fun_ (Pat.var pat_param)
                        (if createType then                                             
                           (Exp.let_ Nonrecursive
                              [Vb.mk 
                                 (Pat.var pat_param) 
                                 (exp_param +: newType)]
                              (Exp.constraint_ obj_exp core_type) )
                         else 
                           (Exp.constraint_ obj_exp core_type) ))
                 in
                 let rest = 
                   [
                     toJs;
                     fromJs
                   ] in 
                 if createType then eraseTypeStr:: newTypeStr :: rest else rest 
               | Ptype_abstract -> 
                 (match Ast_polyvar.is_enum_polyvar tdcl with 
                  | Some row_fields ->               
                    let expConstantArray =   
                      Exp.ident {loc; txt = Longident.Lident constantArray} in 
                    let result :  _ list = 
                      Ext_list.map row_fields (fun tag -> 
                          match tag with 
                          | Rtag (label, attrs, _, []) -> 
                            (Ast_compatible.hash_label label,
                             match Ast_attributes.iter_process_bs_string_as_ast attrs with 
                             | Some name -> 
                               name
                             | None -> 
                               Ast_compatible.const_exp_string(Ast_compatible.label_of_name label)
                            )
                          | _ -> assert false (* checked by [is_enum_polyvar] *)
                        ) in 
                    let result_len = List.length result in 
                    let exp_len = Ast_compatible.const_exp_int result_len in 
                    let v = [
                      eraseTypeStr;
                      Ast_comb.single_non_rec_value 
                        {loc; txt = constantArray}
                        (Exp.array
                           (Ext_list.map (List.sort (fun (a,_) (b,_) -> compare (a:int) b) result)
                              (fun (i,str) -> 
                                 Exp.tuple 
                                   [
                                     Ast_compatible.const_exp_int i;
                                     str
                                   ]
                              ) ));
                      (
                        toJsBody
                          (coerceResultToNewType 
                             (search
                                exp_len
                                exp_param
                                expConstantArray 
                             ))
                      );
                      Ast_comb.single_non_rec_value
                        patFromJs
                        (Ast_compatible.fun_
                           (Pat.var pat_param)
                           (if createType then 
                              revSearchAssert
                                exp_len
                                expConstantArray
                                (exp_param +: newType)
                              +>
                              core_type
                            else 
                              revSearch                                      
                                exp_len
                                expConstantArray
                                exp_param                                      
                              +>
                              Ast_core_type.lift_option_type core_type
                           )
                        )
                    ] in 
                    if createType then 
                      newTypeStr :: v 
                    else v 
                  | None -> 
                    U.notApplicable 
                      tdcl.Parsetree.ptype_loc 
                      derivingName;
                    []
                 )

               | Ptype_variant ctors -> 
                 if Ast_polyvar.is_enum_constructors ctors then 
                   let xs = Ast_polyvar.map_constructor_declarations_into_ints ctors in 
                   match xs with 
                   | `New xs ->
                     let constantArrayExp = Exp.ident {loc; txt = Lident constantArray} in
                     let exp_len = Ast_compatible.const_exp_int (List.length ctors) in
                     let v = [
                       eraseTypeStr;
                       Ast_comb.single_non_rec_value 
                         {loc; txt = constantArray}
                         (Ast_compatible.const_exp_int_list_as_array xs)
                       ;
                       toJsBody                        
                         (
                           coerceResultToNewType @@
                           toInt
                             exp_param
                             constantArrayExp
                         )                       
                       ;
                       Ast_comb.single_non_rec_value
                         patFromJs
                         (Ast_compatible.fun_
                            (Pat.var pat_param)
                            (
                              if createType then 
                                fromIntAssert
                                  exp_len
                                  constantArrayExp
                                  (exp_param +: newType)
                                +>
                                core_type
                              else 
                                fromInt                                 
                                  exp_len
                                  constantArrayExp
                                  exp_param
                                +>
                                Ast_core_type.lift_option_type core_type

                            )
                         )
                     ] in 
                     if createType then newTypeStr :: v else v 
                   | `Offset offset  ->                      
                     let v = 
                       [  eraseTypeStr;
                          toJsBody (
                            coerceResultToNewType
                              (eraseType exp_param +~ Ast_compatible.const_exp_int offset)
                          )
                          ;
                          let len = List.length ctors in 
                          let range_low = Ast_compatible.const_exp_int (offset + 0) in 
                          let range_upper = Ast_compatible.const_exp_int (offset + len - 1) in 

                          Ast_comb.single_non_rec_value
                            {loc ; txt = fromJs}
                            (Ast_compatible.fun_
                               (Pat.var pat_param)
                               (if createType then 
                                  (Exp.let_ Nonrecursive
                                     [Vb.mk
                                        (Pat.var pat_param)
                                        (exp_param +: newType)
                                     ]
                                     (
                                       Exp.sequence
                                         (assertExp 
                                            ((exp_param <=~ range_upper) &&~ (range_low <=~ exp_param))
                                         )
                                         (exp_param  -~ Ast_compatible.const_exp_int offset))
                                  )
                                  +>
                                  core_type
                                else
                                  Exp.ifthenelse
                                    ( (exp_param <=~ range_upper) &&~ (range_low <=~ exp_param))
                                    (Exp.construct {loc; txt = Ast_literal.predef_some} 
                                       ( Some (exp_param -~ Ast_compatible.const_exp_int offset)))
                                    (Some (Exp.construct {loc; txt = Ast_literal.predef_none} None))
                                  +>
                                  Ast_core_type.lift_option_type core_type
                               )
                            )
                       ] in 
                     if createType then newTypeStr :: v else v 
                 else 
                   begin 
                     U.notApplicable 
                       tdcl.Parsetree.ptype_loc 
                       derivingName;
                     []  
                   end
               | Ptype_open -> 
                 U.notApplicable tdcl.Parsetree.ptype_loc 
                   derivingName;
                 [] in 
             Ext_list.flat_map tdcls handle_tdcl
           );
         signature_gen = 
           (fun (tdcls : tdcls) _ -> 
              let handle_tdcl tdcl =
                let core_type = U.core_type_of_type_declaration tdcl 
                in 
                let name = tdcl.ptype_name.txt in 
                let toJs = name ^ "ToJs" in 
                let fromJs = name ^ "FromJs" in 
                let loc = tdcl.ptype_loc in 
                let patToJs = {Asttypes.loc; txt = toJs} in 
                let patFromJs = {Asttypes.loc; txt = fromJs} in 
                let toJsType result = 
                  Ast_comb.single_non_rec_val patToJs (Ast_compatible.arrow core_type result) in
                let newType,newTdcl =
                  U.new_type_of_type_declaration tdcl ("abs_" ^ name) in 
                let newTypeStr = Ast_compatible.rec_type_sig [newTdcl] in                     
                let (+?) v rest = if createType then v :: rest else rest in 
                match tdcl.ptype_kind with  
                | Ptype_record label_declarations ->            

                  let objType flag =                     
                    Ast_comb.to_js_type loc @@  
                    Ast_compatible.object_
                      (Ext_list.map label_declarations
                         (fun {pld_name = {loc; txt }; pld_type } -> 
                            txt, [], pld_type)) 
                      flag in                   
                  newTypeStr +? 
                  [
                    toJsType (if createType then newType else  objType Closed);
                    Ast_comb.single_non_rec_val patFromJs 
                      ( (if createType then  newType else objType Open)->~ core_type)
                  ] 

                | Ptype_abstract ->   
                  (match Ast_polyvar.is_enum_polyvar tdcl with 
                   | Some _ ->                     
                     let ty1 =  
                       if createType then newType else 
                         (Ast_literal.type_string ()) in 
                     let ty2 = 
                       if createType then core_type
                       else Ast_core_type.lift_option_type core_type in 
                     newTypeStr +? 
                     [
                       toJsType ty1;
                       Ast_comb.single_non_rec_val     
                         patFromJs
                         (ty1 ->~ ty2)
                     ] 

                   | None -> 
                     U.notApplicable tdcl.Parsetree.ptype_loc 
                       derivingName;
                     [])

                | Ptype_variant ctors 
                  -> 
                  if Ast_polyvar.is_enum_constructors ctors then 
                    let ty1 = 
                      if createType then newType 
                      else Ast_literal.type_int() in 
                    let ty2 = 
                      if createType then core_type
                      else Ast_core_type.lift_option_type core_type in 
                    newTypeStr +? 
                    [
                      toJsType ty1;
                      Ast_comb.single_non_rec_val
                        patFromJs
                        (ty1 ->~ ty2)
                    ] 

                  else 
                    begin
                      U.notApplicable tdcl.Parsetree.ptype_loc 
                        derivingName;
                      []
                    end
                | Ptype_open -> 
                  U.notApplicable tdcl.Parsetree.ptype_loc 
                    derivingName;
                  [] in 
              Ext_list.flat_map tdcls handle_tdcl

           );
         expression_gen = None 
       } 
    )
  ;

end
module Ast_derive_projector : sig 
#1 "ast_derive_projector.mli"
(* Copyright (C) 2017 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



val init : unit -> unit

end = struct
#1 "ast_derive_projector.ml"
open Ast_helper

let invalid_config (config : Parsetree.expression) = 
  Location.raise_errorf ~loc:config.pexp_loc "such configuration is not supported"



type tdcls = Parsetree.type_declaration list 

(* #if OCAML_VERSION =~ ">4.03.0" then 
let constructor_arguments_length (xs : Parsetree.constructor_arguments) = 
  match xs with 
  | Pcstr_tuple xs -> List.length xs 
  | Pcstr_record xs -> List.length xs (* inline record FIXME*) 
#else
let constructor_arguments_length = List.length 
#end *)
let derivingName = "accessors" 
let init () =
  
  Ast_derive.register
    derivingName
    (fun (x : Parsetree.expression option) ->
       Ext_option.iter x invalid_config;
       {structure_gen = 
          begin fun (tdcls : tdcls) _explict_nonrec ->
            let handle_tdcl tdcl = 
              let core_type = Ast_derive_util.core_type_of_type_declaration tdcl in 
              match tdcl.ptype_kind with 
              | Ptype_record label_declarations 
                ->                  
                Ext_list.map label_declarations (
                  fun ({pld_name = {loc; txt = pld_label} as pld_name} : Parsetree.label_declaration) -> 
                    let txt = "param" in
                    Ast_comb.single_non_rec_value pld_name
                      (Ast_compatible.fun_
                         (Pat.constraint_ (Pat.var {txt ; loc}) core_type )
                         (Exp.field (Exp.ident {txt = Lident txt ; loc}) 
                            {txt = Longident.Lident pld_label ; loc}) )
                )
              | Ptype_variant constructor_declarations 
                ->                 
                Ext_list.map constructor_declarations
                  (fun {pcd_name = {loc ; txt = con_name} ; pcd_args ; pcd_loc; pcd_res }
                    -> (* TODO: add type annotations *)

                      let pcd_args = 
                        match pcd_args with 
                        | Pcstr_tuple pcd_args -> pcd_args 
                        | Pcstr_record _ -> assert false in  
                        
                      let little_con_name = Ext_string.uncapitalize_ascii con_name  in
                      let arity = List.length pcd_args in 
                      let annotate_type = 
                        match pcd_res with 
                        | None -> core_type
                        | Some x -> x in  
                      Ast_comb.single_non_rec_value {loc ; txt = little_con_name}
                        (
                          if arity = 0 then (*TODO: add a prefix, better inter-op with FFI *)
                            (Exp.constraint_
                               (Exp.construct {loc ; txt = Longident.Lident con_name } None)
                               annotate_type
                            )
                          else 
                            begin 
                              let vars = 
                                Ext_list.init  arity (fun x -> "param_" ^ string_of_int x ) in 
                              let exp = 
                                Exp.constraint_
                                  ( 
                                    Exp.construct {loc ; txt = Longident.Lident con_name} @@ 
                                    Some
                                      (if  arity = 1 then 
                                          Exp.ident { loc ; txt = Lident (List.hd vars )}
                                        else 
                                          Exp.tuple (Ext_list.map vars 
                                                       (fun x -> Exp.ident {loc ; txt = Lident x})))) annotate_type
                              in 
                              Ext_list.fold_right vars exp (fun var b -> 
                                  Ast_compatible.fun_  (Pat.var {loc ; txt = var}) b 
                                ) 

                            end)
                  )
              | Ptype_abstract | Ptype_open ->
                Ast_derive_util.notApplicable tdcl.ptype_loc derivingName ; 
               []
              (* Location.raise_errorf "projector only works with record" *)
            in Ext_list.flat_map tdcls handle_tdcl


          end;
        signature_gen = 
          begin fun (tdcls : Parsetree.type_declaration list) _explict_nonrec -> 
            let handle_tdcl tdcl = 
              let core_type = Ast_derive_util.core_type_of_type_declaration tdcl in 
              match tdcl.ptype_kind with 
              | Ptype_record label_declarations 
                ->                 
                Ext_list.map label_declarations (fun {pld_name; pld_type}  -> 
                    Ast_comb.single_non_rec_val pld_name (Ast_compatible.arrow core_type pld_type )
                  )
              | Ptype_variant constructor_declarations 
                ->                 
                Ext_list.map constructor_declarations
                  (fun  {pcd_name = {loc ; txt = con_name} ; pcd_args ; pcd_loc; pcd_res}
                    -> 
                                          
                      let pcd_args = 
                        match pcd_args with 
                        | Pcstr_tuple pcd_args -> pcd_args 
                        | Pcstr_record _ -> assert false in 
                        
                      let annotate_type = 
                        match pcd_res with
                        | Some x -> x 
                        | None -> core_type in 
                      Ast_comb.single_non_rec_val {loc ; txt = (Ext_string.uncapitalize_ascii con_name)}
                        (Ext_list.fold_right pcd_args annotate_type (fun x acc -> Ast_compatible.arrow x acc)))
              | Ptype_open | Ptype_abstract -> 
              Ast_derive_util.notApplicable tdcl.ptype_loc derivingName ; 
              [] 
            in 
            Ext_list.flat_map tdcls handle_tdcl 
          end;
        expression_gen = None
       }
    )


end
module Ast_open_cxt : sig 
#1 "ast_open_cxt.mli"
(* Copyright (C) 2019 - Present Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type loc = Location.t 

type whole 
type t = whole list

val restore_exp :
   Parsetree.expression -> 
   t -> 
   Parsetree.expression

val destruct :    
  Parsetree.expression -> 
  t -> 
  Parsetree.expression * t 

val destruct_open_tuple :    
  Parsetree.expression -> 
  t -> 
  (t * Parsetree.expression list * Parsetree.attributes ) option 
end = struct
#1 "ast_open_cxt.ml"
(* Copyright (C) 2019 - Present Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type loc = Location.t 

type whole =
  | Let_open of
      (Asttypes.override_flag * Longident.t Asttypes.loc * loc *
       Parsetree.attributes)

type t = whole list

type exp = Parsetree.expression

type destruct_output =
  exp list
  
(**
   destruct such pattern
   {[ A.B.let open C in (a,b)]}
*)
let rec destruct_open_tuple
    (e : Parsetree.expression)
    (acc : t)
  : (t * destruct_output * _) option =
  match e.pexp_desc with
  | Pexp_open (flag, lid, cont)
    ->
    destruct_open_tuple
      cont
      (Let_open (flag, lid, e.pexp_loc, e.pexp_attributes) :: acc)
  | Pexp_tuple es -> Some (acc, es, e.pexp_attributes)
  | _ -> None

let rec destruct
    (e : Parsetree.expression)
    (acc : t) 
  =
  match e.pexp_desc with
  | Pexp_open (flag, lid, cont)
    ->
    destruct
      cont
      (Let_open (flag, lid, e.pexp_loc, e.pexp_attributes) :: acc)
  | _ -> e, acc
  


let restore_exp 
    (xs : Parsetree.expression) 
    (qualifiers : t) : Parsetree.expression = 
  Ext_list.fold_left qualifiers xs (fun x hole  ->
      match hole with
      | Let_open (flag, lid,loc,attrs) ->
        ({
          pexp_desc = Pexp_open (flag,lid,x);
          pexp_attributes = attrs;
          pexp_loc = loc
        } : Parsetree.expression)
    ) 
end
module Ast_exp_apply : sig 
#1 "ast_exp_apply.mli"
(* Copyright (C) 2018 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



val app_exp_mapper :   
  Parsetree.expression ->
  Bs_ast_mapper.mapper ->
  Parsetree.expression ->
  Ast_compatible.args -> 
  Parsetree.expression
end = struct
#1 "ast_exp_apply.ml"
(* Copyright (C) 2018 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

open Ast_helper
type exp = Parsetree.expression

let rec no_need_bound (exp : exp) =
  match exp.pexp_desc with
  | Pexp_ident { txt = Lident _} -> true
  | Pexp_constraint(e,_) -> no_need_bound e
  | _ -> false

let ocaml_obj_id = "__ocaml_internal_obj"

let bound (e : exp) (cb : exp -> _) =
  if no_need_bound e then cb e
  else
    let loc = e.pexp_loc in
    Exp.let_ ~loc Nonrecursive
      [ Vb.mk ~loc (Pat.var ~loc {txt = ocaml_obj_id; loc}) e ]
      (cb (Exp.ident ~loc {txt = Lident ocaml_obj_id; loc}))

let default_expr_mapper = Bs_ast_mapper.default_mapper.expr      

let check_and_discard (args : Ast_compatible.args) = 
  Ext_list.map args (fun (label,x) -> 
      if not (Ast_compatible.is_arg_label_simple label) then 
        Bs_syntaxerr.err x.pexp_loc Label_in_uncurried_bs_attribute;
      x  
    )

type app_pattern = {
  op : string;  
  loc : Location.t; 
  args : Parsetree.expression list
}

(* match fn as *)   
let view_as_app (fn : exp) s : app_pattern option =      
  match fn.pexp_desc with 
  | Pexp_apply ({pexp_desc = Pexp_ident {txt = Lident op; loc}}, args ) 
    when Ext_list.has_string s op
    -> 
      Some {op; loc; args = check_and_discard args}
  | _ -> None 



let inner_ops = ["##"; "#@"]      
let infix_ops = [ "|."; "#=" ; "##"]
let app_exp_mapper 
  (e : exp)
  (self : Bs_ast_mapper.mapper)
  (fn : exp)
  (args : Ast_compatible.args) : exp = 
  (* - (f##paint) 1 2 
     - (f#@paint) 1 2 
  *)
  match view_as_app fn inner_ops with
  | Some { op;  loc;
           args = [obj;
          {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _}]}
    ->  
    {e with pexp_desc = 
        (if op = "##" then
        Ast_util.method_apply 
        else Ast_util.property_apply)
        loc self obj name (check_and_discard args) }
   | Some {op; loc} ->
      Location.raise_errorf ~loc "%s expect f%sproperty arg0 arg2 form" op op
   | None -> 
    match view_as_app e infix_ops with   
    | Some { op = "|."; args =  [obj_arg; fn];loc} ->
      (*
        a |. f
        a |. f b c [@bs]  --> f a b c [@bs]
        a |. M.(f b c) --> M.f a M.b M.c
        a |. (g |. b)
        a |. M.Some
      *)
      let new_obj_arg = self.expr self obj_arg in
      let fn = self.expr self fn in 
      begin match fn with
        | {pexp_desc = Pexp_apply (fn, args); pexp_loc; pexp_attributes} ->
          Bs_ast_invariant.warn_discarded_unused_attributes pexp_attributes;
          { pexp_desc = Pexp_apply(fn, (Ast_compatible.no_label, new_obj_arg) :: args);
            pexp_attributes = [];
            pexp_loc = pexp_loc}
        | {pexp_desc = Pexp_construct(ctor,None); pexp_loc; pexp_attributes} -> 
          {fn with pexp_desc = Pexp_construct(ctor, Some new_obj_arg)}
        | _ ->
          begin match Ast_open_cxt.destruct fn [] with             
            | {pexp_desc = Pexp_tuple xs; pexp_attributes = tuple_attrs}, wholes ->  
              Ast_open_cxt.restore_exp (bound new_obj_arg (fun bounded_obj_arg ->
                  {
                    pexp_desc =
                      Pexp_tuple (
                        Ext_list.map xs (fun fn ->
                            match fn with
                            | {pexp_desc = Pexp_apply (fn,args); pexp_loc; pexp_attributes }
                              ->
                              Bs_ast_invariant.warn_discarded_unused_attributes pexp_attributes;
                              { Parsetree.pexp_desc = Pexp_apply(fn, (Ast_compatible.no_label, bounded_obj_arg) :: args);
                                pexp_attributes = [];
                                pexp_loc = pexp_loc}
                            | {pexp_desc = Pexp_construct(ctor,None); pexp_loc; pexp_attributes}    
                              -> 
                              {fn with pexp_desc = Pexp_construct(ctor, Some bounded_obj_arg)}
                            | _ ->
                              Ast_compatible.app1 ~loc:fn.pexp_loc fn bounded_obj_arg
                          ));
                    pexp_attributes = tuple_attrs;
                    pexp_loc = fn.pexp_loc;
                  })) wholes
            |  {pexp_desc = Pexp_apply (e, args); pexp_attributes},  (_ :: _ as wholes) ->   
              let fn = Ast_open_cxt.restore_exp e wholes in 
              let args = Ext_list.map args (fun (lab,exp) -> lab, Ast_open_cxt.restore_exp exp wholes) in 
              Bs_ast_invariant.warn_discarded_unused_attributes pexp_attributes; 
              { pexp_desc = Pexp_apply(fn, (Ast_compatible.no_label, new_obj_arg) :: args);
                pexp_attributes = [];
                pexp_loc = loc}
            | _ -> Ast_compatible.app1 ~loc fn new_obj_arg
           end
      end
    | Some { op = "##" ; loc; args =  [obj; rest]} ->
      (* - obj##property
         - obj#(method a b )
         we should warn when we discard attributes 
         gpr#1063 foo##(bar##baz) we should rewrite (bar##baz)
             first  before pattern match.
             currently the pattern match is written in a top down style.
             Another corner case: f##(g a b [@bs])
      *)
      begin match rest with
          {pexp_desc = Pexp_apply(
                {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _},
                args
              ); pexp_attributes = attrs }
           -> 
          Bs_ast_invariant.warn_discarded_unused_attributes attrs ;
          {e with pexp_desc = Ast_util.method_apply loc self obj name (check_and_discard args)}
        | 
            {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _}
            (* f##paint  *)
          ->
          { e with pexp_desc =
                     Ast_util.js_property loc (self.expr self obj) name
          }
        | _ -> Location.raise_errorf ~loc "invalid ## syntax"
        end  
      
    (* we can not use [:=] for precedece cases
       like {[i @@ x##length := 3 ]}
       is parsed as {[ (i @@ x##length) := 3]}
       since we allow user to create Js objects in OCaml, it can be of
       ref type
       {[
         let u = object (self)
           val x = ref 3
           method setX x = self##x := 32
           method getX () = !self##x
         end
       ]}
    *)
    | Some {op = "#="; loc; args = [obj; arg]}  ->
      begin match view_as_app obj ["##"] with
        | Some { args = [obj; {pexp_desc = Pexp_ident {txt = Lident name}}]}
         -> 
          Exp.constraint_ ~loc
            { e with
              pexp_desc =
                Ast_util.method_apply loc self obj
                  (name ^ Literals.setter_suffix) [arg]  }
            (Ast_literal.type_unit ~loc ())
        | _ -> assert false
      end
    | Some { op = "|.";  loc; } ->
      Location.raise_errorf ~loc
        "invalid |. syntax, it can only be used as binary operator"
    | Some {op = "##"; loc } ->
      Location.raise_errorf ~loc
        "Js object ## expect syntax like obj##(paint (a,b)) "
    | Some {op; } -> Location.raise_errorf "invalid %s syntax" op
    | None ->
      match
        Ext_list.exclude_with_val
          e.pexp_attributes 
          Ast_attributes.is_bs with
      | None -> default_expr_mapper self e
      | Some pexp_attributes ->

        {e with pexp_desc = Ast_util.uncurry_fn_apply e.pexp_loc self fn (check_and_discard args) ;
                pexp_attributes }
      
  


end
module Ast_external : sig 
#1 "ast_external.mli"
(* Copyright (C) 2018 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


val handleExternalInSig:
  Bs_ast_mapper.mapper ->
  Parsetree.value_description ->
  Parsetree.signature_item ->
  Parsetree.signature_item

val handleExternalInStru:
  Bs_ast_mapper.mapper ->
  Parsetree.value_description ->
  Parsetree.structure_item ->
  Parsetree.structure_item
  

end = struct
#1 "ast_external.ml"
(* Copyright (C) 2018 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


let handleExternalInSig
    (self : Bs_ast_mapper.mapper)
    (prim : Parsetree.value_description)
    (sigi : Parsetree.signature_item)
  : Parsetree.signature_item
  =
  let loc = prim.pval_loc in  
  let pval_type = self.typ self prim.pval_type in
  let pval_attributes = self.attributes self prim.pval_attributes in
  match prim.pval_prim with
  | [] 
  | _ :: _ :: _ ->
    Location.raise_errorf
      ~loc
      "only a single string is allowed in bs external" 
  | [ v ] ->
    match Ast_external_process.handle_attributes_as_string
            loc
            pval_type
            pval_attributes
            prim.pval_name.txt            
            v 
    with
    | {pval_type; pval_prim; pval_attributes; no_inline_cross_module} ->        
      {sigi with
       psig_desc =
         Psig_value
           {prim with
            pval_type ;
            pval_prim = if no_inline_cross_module then [] else pval_prim ;
            pval_attributes
           }}
  
let handleExternalInStru
    (self : Bs_ast_mapper.mapper)
    (prim : Parsetree.value_description)
    (str : Parsetree.structure_item)
  : Parsetree.structure_item =
  let loc = prim.pval_loc in 
  let pval_type = self.typ self prim.pval_type in
  let pval_attributes = self.attributes self prim.pval_attributes in
  match prim.pval_prim with
  | [] | _ :: _ :: _
    -> 
    Location.raise_errorf
      ~loc 
      "only a single string is allowed in bs external" 
  | [ v] ->
    match Ast_external_process.handle_attributes_as_string
            loc
            pval_type 
            pval_attributes 
            prim.pval_name.txt
            v with 
    | { pval_type; pval_prim; pval_attributes; no_inline_cross_module} ->
      let external_result = 
        {str with
         pstr_desc =
           Pstr_primitive
             {prim with
              pval_type ;
              pval_prim;
              pval_attributes
             }} in 
      if not no_inline_cross_module then   
        external_result
      else
        let open Ast_helper in 
        Str.include_ ~loc 
          (Incl.mk ~loc 
             (Mod.constraint_ ~loc
                (Mod.structure ~loc 
                   [external_result])
                (Mty.signature ~loc [
                    {
                      psig_desc = Psig_value {
                          prim with 
                          pval_type ; 
                          pval_prim = [];
                          pval_attributes ;
                        };
                      psig_loc = loc
                    }])))


end
module Ast_derive_abstract : sig 
#1 "ast_derive_abstract.mli"
(* Copyright (C) 2017 Authors of BuckleScript
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type abstractKind = 
  | Not_abstract
  | Light_abstract
  | Complex_abstract 

val isAbstract : 
  Ast_payload.action list -> abstractKind
(** if only [abstract] happens  [true]
    if [abstract] does not appear [false]
    if [abstract] happens with other, raise exception
*)  


val handleTdclsInStr : 
  light:bool -> 
  Parsetree.type_declaration list -> Parsetree.structure

val handleTdclsInSig:  
  light:bool ->
  Parsetree.type_declaration list -> Parsetree.signature
end = struct
#1 "ast_derive_abstract.ml"
(* Copyright (C) 2017 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


(* let derivingName = "abstract" *)
module U = Ast_derive_util
open Ast_helper
type tdcls = Parsetree.type_declaration list

type abstractKind = 
  | Not_abstract
  | Light_abstract
  | Complex_abstract 

let  isAbstract (xs :Ast_payload.action list) = 
  match xs with 
  | [{loc; txt = "abstract"}, 
    (None 
    )]  -> 
    Complex_abstract
  | [{loc; txt = "abstract"}, 
    Some {pexp_desc = Pexp_ident {txt = Lident "light"}}  
    ] -> Light_abstract
  | [{loc; txt = "abstract"}, Some _ ]
    -> 
      Location.raise_errorf ~loc "invalid config for abstract"
  | xs -> 
    Ext_list.iter xs (function (({loc; txt}),_) ->  
      match txt with 
      | "abstract" -> 
        Location.raise_errorf ~loc 
          "bs.deriving abstract does not work with any other deriving"
      | _ -> ()
    ) ;
    Not_abstract
(* let handle_config (config : Parsetree.expression option) =
  match config with
  | Some config ->
    U.invalid_config config
  | None -> () *)



let get_optional_attrs =
  [ 
    Ast_attributes.bs_get; 
    Ast_attributes.bs_return_undefined
    ]
(** For this attributes, its type was wrapped as an option,
   so we can still reuse existing frame work
*)  

let get_attrs = [ Ast_attributes.bs_get_arity]
let set_attrs = [Ast_attributes.bs_set]

let deprecated name = 
  Ast_attributes.deprecated  
    ("use " ^ name ^ "Get instead, or swith to the new [@bs.deriving {abstract: light}] for the type declaration (OCaml syntax: [@@bs.deriving {abstract = light}])")


let handleTdcl 
  light
  (tdcl : Parsetree.type_declaration) 
  : Parsetree.type_declaration * Parsetree.value_description list 
  =
  let core_type = U.core_type_of_type_declaration tdcl in
  let loc = tdcl.ptype_loc in
  let type_name = tdcl.ptype_name.txt in
  let newTdcl = {
    tdcl with
    ptype_kind = Ptype_abstract;
    ptype_attributes = [];
    (* avoid non-terminating*)
  } in
  match tdcl.ptype_kind with
  | Ptype_record label_declarations ->
    let is_private = tdcl.ptype_private = Private in
    let has_optional_field =
      Ext_list.exists label_declarations (fun {pld_type; pld_attributes} ->
          Ast_attributes.has_bs_optional pld_attributes
        )  in
    let setter_accessor, makeType, labels =
      Ext_list.fold_right
        label_declarations
        ([],
         (if has_optional_field then
            Ast_compatible.arrow ~loc  (Ast_literal.type_unit ()) core_type
          else  core_type),
         [])
        (fun
          ({pld_name =
              {txt = label_name; loc = label_loc} as pld_name;
            pld_type;
            pld_mutable;
            pld_attributes;
            pld_loc
           }:
             Parsetree.label_declaration) (acc, maker, labels) ->
          let prim_as_name, newLabel =
            match Ast_attributes.iter_process_bs_string_as pld_attributes with
            | None ->
              label_name, pld_name
            | Some new_name ->
              new_name, {pld_name with txt = new_name}
          in
          let prim = [prim_as_name] in 
          let is_optional = Ast_attributes.has_bs_optional pld_attributes in
          
          let maker, acc =
            if is_optional then
              let optional_type = Ast_core_type.lift_option_type pld_type in
              (Ast_compatible.opt_arrow ~loc:pld_loc label_name 
             pld_type  
              

                maker,
              let aux light deprec pld_name : Parsetree.value_description = 
                (Val.mk ~loc:pld_loc
                 (if light then pld_name else 
                  {pld_name with txt = pld_name.txt ^ "Get"})
                ~attrs:(if deprec then deprecated (pld_name.Asttypes.txt) :: get_optional_attrs  
                        else get_optional_attrs) ~prim
                (Ast_compatible.arrow ~loc  core_type optional_type)
                ) in 
                if not light then 
                  aux true true pld_name :: aux false false pld_name  :: acc
                else  aux true false pld_name :: acc                   
              )
            else
              Ast_compatible.label_arrow ~loc:pld_loc label_name pld_type maker,
              (
                let aux light deprec pld_name = 
                  Val.mk ~loc:pld_loc 
                    (if light then pld_name else 
                       {pld_name with txt = pld_name.txt ^ "Get"}
                    ) ~attrs:(if deprec then deprecated pld_name.Asttypes.txt :: get_attrs else get_attrs)
                    ~prim:(
                ["" ; (* Not needed actually*)
                External_ffi_types.to_string 
                (Ffi_bs (
                  [{arg_type = Nothing; arg_label = External_arg_spec.empty_label}],
                  Return_identity,
                  Js_get {js_get_name = prim_as_name; js_get_scopes = []}
                  ))] )
               (Ast_compatible.arrow ~loc  core_type pld_type)
               in 
               if not light then 
                aux true true pld_name ::aux false false pld_name :: acc 
               else aux true false pld_name :: acc 
              )
          in
          let is_current_field_mutable = pld_mutable = Mutable in
          let acc =
            if is_current_field_mutable then
              let setter_type =
                (Ast_compatible.arrow core_type
                   (Ast_compatible.arrow
                      pld_type (* setter *)
                      (Ast_literal.type_unit ()))) in
              Val.mk ~loc:pld_loc
                {loc = label_loc; txt = label_name ^ "Set"}
                (* setter *)
                ~attrs:set_attrs
                ~prim setter_type
              :: acc
            else acc in
          acc,
          maker,
          (is_optional, newLabel)::labels
        ) 
    in
    newTdcl,
    (if is_private then
       setter_accessor
     else
       let myPrims =
        Ast_external_process.pval_prim_of_option_labels
          labels
          has_optional_field
        in
       let myMaker =
         Val.mk  ~loc
           {loc; txt = type_name}
           ~prim:myPrims makeType in
       (myMaker :: setter_accessor))

  | Ptype_abstract
  | Ptype_variant _
  | Ptype_open ->
    (* Looks obvious that it does not make sense to warn *)
    (* U.notApplicable tdcl.ptype_loc derivingName;  *)
    tdcl, []

let handleTdclsInStr ~light tdcls =
  let tdcls, code =
    Ext_list.fold_right tdcls ([],[]) (fun tdcl (tdcls, sts)  ->
        match handleTdcl light tdcl with
          ntdcl, value_descriptions ->
          ntdcl::tdcls,
          Ext_list.map_append value_descriptions sts (fun x -> Str.primitive x) 
      ) in
Ast_compatible.rec_type_str tdcls :: code
(* still need perform transformation for non-abstract type*)

let handleTdclsInSig ~light tdcls =
  let tdcls, code =
    Ext_list.fold_right tdcls ([],[]) (fun tdcl (tdcls, sts)  ->
        match handleTdcl light tdcl with
          ntdcl, value_descriptions ->
          ntdcl::tdcls,
          Ext_list.map_append value_descriptions sts (fun x -> Sig.value x) 
      ) in
  Ast_compatible.rec_type_sig tdcls :: code

end
module Ast_tdcls : sig 
#1 "ast_tdcls.mli"
(* Copyright (C) 2018 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


val handleTdclsInSigi :
  Bs_ast_mapper.mapper ->
  Parsetree.signature_item ->
  Parsetree.type_declaration list -> Ast_signature.item


val handleTdclsInStru :
  Bs_ast_mapper.mapper ->
  Parsetree.structure_item ->
  Parsetree.type_declaration list -> Ast_structure.item

end = struct
#1 "ast_tdcls.ml"
(* Copyright (C) 2018 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

open Ast_helper

(**
   [newTdcls tdcls newAttrs]
   functional update attributes of last declaration *)
let newTdcls
    (tdcls : Parsetree.type_declaration list)
    (newAttrs : Parsetree.attributes)
  : Parsetree.type_declaration list
  =
  match tdcls with
  | [ x ] ->
    [{ x with Parsetree.ptype_attributes = newAttrs}]
  | _ ->
    Ext_list.map_last tdcls
      (fun last x ->
         if last then
           { x with
             Parsetree.ptype_attributes = newAttrs}
         else x )
      




let handleTdclsInSigi
    (self : Bs_ast_mapper.mapper)
    (sigi : Parsetree.signature_item)
    (tdcls : Parsetree.type_declaration list)
  : Ast_signature.item =
  begin match Ast_attributes.process_derive_type
                (Ext_list.last tdcls).ptype_attributes  with
  | {bs_deriving = Some actions; explict_nonrec}, newAttrs
    ->
    let loc = sigi.psig_loc in
    let originalTdclsNewAttrs = newTdcls tdcls newAttrs in (* remove the processed attr*)
    let newTdclsNewAttrs = self.type_declaration_list self originalTdclsNewAttrs in
    let kind = Ast_derive_abstract.isAbstract actions in
    if kind <> Not_abstract then

      let  codes = Ast_derive_abstract.handleTdclsInSig ~light:(kind = Light_abstract) originalTdclsNewAttrs in

      Ast_signature.fuseAll ~loc
        (
          Sig.include_ ~loc
            (Incl.mk ~loc
               (Mty.typeof_ ~loc
                  (Mod.constraint_ ~loc
                     (Mod.structure ~loc [

                         Ast_compatible.rec_type_str ~loc newTdclsNewAttrs

                         ] )
                     (Mty.signature ~loc [])) ) )
          :: (* include module type of struct [processed_code for checking like invariance ]end *)
          self.signature self  codes
        )
    else
      Ast_signature.fuseAll ~loc
        ( 
          Ast_compatible.rec_type_sig ~loc newTdclsNewAttrs
        ::
         self.signature
           self
           (Ast_derive.gen_signature tdcls actions explict_nonrec))
  | {bs_deriving = None }, _  ->
    Bs_ast_mapper.default_mapper.signature_item self sigi

  end


let handleTdclsInStru
    (self : Bs_ast_mapper.mapper)
    (str : Parsetree.structure_item)
    (tdcls : Parsetree.type_declaration list)
  : Ast_structure.item =
  begin match
      Ast_attributes.process_derive_type
        ((Ext_list.last tdcls).ptype_attributes) with
  | {bs_deriving = Some actions;
     explict_nonrec
    }, newAttrs ->
    let loc = str.pstr_loc in
    let originalTdclsNewAttrs = newTdcls tdcls newAttrs in
    let newStr : Parsetree.structure_item =
      Ast_compatible.rec_type_str ~loc (self.type_declaration_list self originalTdclsNewAttrs)
    in
    let kind = Ast_derive_abstract.isAbstract actions in 
    if kind <> Not_abstract then

      let codes =
          Ast_derive_abstract.handleTdclsInStr ~light:(kind = Light_abstract) originalTdclsNewAttrs in
      (* use [tdcls2] avoid nonterminating *)
      Ast_structure.fuseAll ~loc
        (
          Ast_structure.constraint_ ~loc [newStr] []
          :: (* [include struct end : sig end] for error checking *)
          self.structure self codes)


    else
      Ast_structure.fuseAll ~loc
        (newStr ::
         self.structure self
           (
             List.map
               (fun action ->
                  Ast_derive.gen_structure_signature
                    loc
                    tdcls action explict_nonrec
               )    actions
           ))
  | {bs_deriving = None }, _  ->
    Bs_ast_mapper.default_mapper.structure_item self str
  end



end
module Ast_tuple_pattern_flatten : sig 
#1 "ast_tuple_pattern_flatten.mli"
(* Copyright (C) 2018 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)




val value_bindings_mapper :
  Bs_ast_mapper.mapper ->
  Parsetree.value_binding list ->
  Parsetree.value_binding list

end = struct
#1 "ast_tuple_pattern_flatten.ml"
(* Copyright (C) 2018 Authors of BuckleScript
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type loc = Location.t

type exp = Parsetree.expression

type pat = Parsetree.pattern



let rec is_simple_pattern (p : Parsetree.pattern) =
  match p.ppat_desc with
  | Ppat_any -> true
  | Ppat_var _ -> true
  | Ppat_constraint(p,_) -> is_simple_pattern p
  | _ -> false


(*
  [let (a,b) = M.N.(c,d) ]
  =>
  [ let a = M.N.c
    and b = M.N.d ]
*)
let flattern_tuple_pattern_vb
    (self : Bs_ast_mapper.mapper)
    (vb :  Parsetree.value_binding)
    (acc : Parsetree.value_binding list) 
  : Parsetree.value_binding list =
  let pvb_pat = self.pat self vb.pvb_pat in
  let pvb_expr = self.expr self vb.pvb_expr in
  let pvb_attributes = self.attributes self vb.pvb_attributes in
  match pvb_pat.ppat_desc with
  | Ppat_tuple xs when List.for_all is_simple_pattern xs ->
    begin match Ast_open_cxt.destruct_open_tuple pvb_expr []  with
      | Some (wholes, es, tuple_attributes)
        when
          Ext_list.for_all xs is_simple_pattern &&
          Ext_list.same_length es xs
        ->
        Bs_ast_invariant.warn_discarded_unused_attributes tuple_attributes ; (* will be dropped*)
        Ext_list.fold_right2 xs es acc (fun pat exp acc->
            {
              pvb_pat =
                pat;
              pvb_expr =                 
                Ast_open_cxt.restore_exp  exp wholes ;
              pvb_attributes;
              pvb_loc = vb.pvb_loc ;
            } :: acc
          ) 
      | _ ->
        {pvb_pat ;
         pvb_expr ;
         pvb_loc = vb.pvb_loc;
         pvb_attributes} :: acc
    end
  | _ ->
    {pvb_pat ;
     pvb_expr ;
     pvb_loc = vb.pvb_loc ;
     pvb_attributes} :: acc


let value_bindings_mapper 
    (self : Bs_ast_mapper.mapper) 
    (vbs : Parsetree.value_binding list) =
  (* Bs_ast_mapper.default_mapper.value_bindings self  vbs   *)
  Ext_list.fold_right vbs [] (fun vb acc ->
      flattern_tuple_pattern_vb self vb acc
    ) 

end
module Bs_builtin_ppx : sig 
#1 "bs_builtin_ppx.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)




val rewrite_signature :   
  Parsetree.signature -> 
  Parsetree.signature

val rewrite_implementation : 
  Parsetree.structure -> 
  Parsetree.structure






(* object 
    for setter : we can push more into [Lsend] and enclose it with a unit type

    for getter :

    (* Invariant: we expect the typechecker & lambda emitter  
       will not do agressive inlining
       Worst things could happen
    {[
      let x = y## case 3  in 
      x 2
    ]}
       in normal case, it should be compiled into Lambda
    {[
      let x = Lsend(y,case, [3]) in 
      Lapp(x,2)
    ]}

       worst:
    {[ Lsend(y, case, [3,2])
    ]}               
       for setter(include case setter), this could 
       be prevented by type system, for getter.

       solution: we can prevent this by rewrite into 
    {[
      Fn.run1  (!x# case) v 
      ]}
       *)

      *)

end = struct
#1 "bs_builtin_ppx.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)






(* When we design a ppx, we should keep it simple, and also think about
   how it would work with other tools like merlin and ocamldep  *)

(**
   1. extension point
   {[
     [%bs.raw{| blabla |}]
   ]}
   will be desugared into
   {[
     let module Js =
     struct unsafe_js : string -> 'a end
     in Js.unsafe_js {| blabla |}
   ]}
   The major benefit is to better error reporting (with locations).
   Otherwise

   {[

     let f u = Js.unsafe_js u
     let _ = f (1 + 2)
   ]}
   And if it is inlined some where
*)


let record_as_js_object = ref false (* otherwise has an attribute *)
let no_export = ref false

let () =
  Ast_derive_projector.init ();
  Ast_derive_js_mapper.init ()

let reset () =
  record_as_js_object := false ;
  no_export  :=  false



type mapper = Bs_ast_mapper.mapper
let default_mapper = Bs_ast_mapper.default_mapper
let default_expr_mapper = Bs_ast_mapper.default_mapper.expr 

let expr_mapper  (self : mapper) (e : Parsetree.expression) =
        match e.pexp_desc with
        (** Its output should not be rewritten anymore *)
        | Pexp_extension extension ->
          Ast_exp_extension.handle_extension record_as_js_object e self extension
        | Pexp_constant (

            Pconst_string
            
            (s, (Some delim)))
          ->
            Ast_utf8_string_interp.transform e s delim
        (** End rewriting *)
        | Pexp_function cases ->
          (* {[ function [@bs.exn]
                | Not_found -> 0
                | Invalid_argument -> 1
              ]}*)
          (match Ast_attributes.process_pexp_fun_attributes_rev e.pexp_attributes with
           | false, _ ->
             default_expr_mapper self  e
           | true, pexp_attributes ->
             Ast_bs_open.convertBsErrorFunction e.pexp_loc self  pexp_attributes cases)
          
        | Pexp_fun (arg_label, _, pat , body)
          when Ast_compatible.is_arg_label_simple arg_label
          ->
          begin match Ast_attributes.process_attributes_rev e.pexp_attributes with
            | Nothing, _
              -> default_expr_mapper self e
            | Uncurry _, pexp_attributes
              ->
              {e with
               pexp_desc = Ast_util.to_uncurry_fn e.pexp_loc self pat body  ;
               pexp_attributes}
            | Method _ , _
              ->  Location.raise_errorf ~loc:e.pexp_loc "bs.meth is not supported in function expression"
            | Meth_callback _, pexp_attributes
              ->
              {e with pexp_desc = Ast_util.to_method_callback e.pexp_loc  self pat body ;
                      pexp_attributes }
          end
        | Pexp_apply (fn, args  ) ->
          Ast_exp_apply.app_exp_mapper e self fn args
        | Pexp_record (label_exprs, opt_exp)  ->
           (* could be supported using `Object.assign`?
               type
               {[
                 external update : 'a Js.t -> 'b Js.t -> 'a Js.t = ""
                 constraint 'b :> 'a
               ]}
            *)
          if !record_as_js_object then
            (match opt_exp with
             | None ->
               { e with
                 pexp_desc =
                   Ast_util.record_as_js_object e.pexp_loc self label_exprs;
               }
             | Some e ->
               Location.raise_errorf
                 ~loc:e.pexp_loc "`with` construct is not supported in bs.obj ")
          else
            default_expr_mapper self e
        | Pexp_object {pcstr_self;  pcstr_fields} ->
            (match Ast_attributes.process_bs e.pexp_attributes with
            | true, pexp_attributes
              ->
              {e with
               pexp_desc =
                 Ast_util.ocaml_obj_as_js_object
                   e.pexp_loc self pcstr_self pcstr_fields;
               pexp_attributes
              }
            | false , _ ->
              default_expr_mapper self e)
        | _ ->  default_expr_mapper self e


let typ_mapper (self : mapper) (typ : Parsetree.core_type) = 
  Ast_core_type_class_type.typ_mapper record_as_js_object self typ

let class_type_mapper (self : mapper) ({pcty_attributes; pcty_loc} as ctd : Parsetree.class_type) = 
  match Ast_attributes.process_bs pcty_attributes with
  | false,  _ ->
    default_mapper.class_type self ctd
  | true, pcty_attributes ->
      (match ctd.pcty_desc with
      | Pcty_signature ({pcsig_self; pcsig_fields })
        ->
        let pcsig_self = self.typ self pcsig_self in
        {ctd with
         pcty_desc = Pcty_signature {
             pcsig_self ;
             pcsig_fields = Ast_core_type_class_type.handle_class_type_fields self pcsig_fields
           };
         pcty_attributes
        }               
 
     | Pcty_open _ (* let open M in CT *)

      | Pcty_constr _
      | Pcty_extension _
      | Pcty_arrow _ ->
        Location.raise_errorf ~loc:pcty_loc "invalid or unused attribute `bs`")
(* {[class x : int -> object
             end [@bs]
           ]}
           Actually this is not going to happpen as below is an invalid syntax
           {[class type x = int -> object
               end[@bs]]}
*)
let setupChromeDebugger : Longident.t =  Ldot (Ldot (Lident"Belt","Debug"), "setupChromeDebugger")

let signature_item_mapper (self : mapper) (sigi : Parsetree.signature_item) =        
      match sigi.psig_desc with
      | Psig_type (
        
          _rf, 
          
           (_ :: _ as tdcls)) ->  (*FIXME: check recursive handling*)
          Ast_tdcls.handleTdclsInSigi self sigi tdcls
      | Psig_value ({pval_attributes; pval_prim} as value_desc)
        
        ->
        let pval_attributes = self.attributes self pval_attributes in 
        if pval_prim <> [] && (*  It is external *)
          Ast_attributes.external_needs_to_be_encoded pval_attributes then 
          Ast_external.handleExternalInSig self value_desc sigi
        else 
          (match 
           Ast_attributes.has_inline_payload_in_sig
           pval_attributes with 
         | Some ({loc},PStr [{pstr_desc = Pstr_eval ({pexp_desc },_)}]) ->
           begin match pexp_desc with
             | Pexp_constant (

               Pconst_string
               
               (s,dec)) -> 
               Bs_ast_invariant.warn_discarded_unused_attributes pval_attributes;
               { sigi with 
                 psig_desc = Psig_value
                     { 
                       value_desc with
                       pval_prim = External_ffi_types.inline_string_primitive s dec;
                       pval_attributes = []
                     }}
             | Pexp_constant(
               
               Pconst_integer (s,None)
               
               ) ->         
               Bs_ast_invariant.warn_discarded_unused_attributes pval_attributes;
                
               let s = int_of_string s in  

               { sigi with 
                 psig_desc = Psig_value
                     { 
                       value_desc with
                       pval_prim = External_ffi_types.inline_int_primitive s ;
                       pval_attributes = []
                     }}
              | Pexp_construct ({txt = Lident ("true" | "false" as txt)}, None)       
                -> 
                Bs_ast_invariant.warn_discarded_unused_attributes pval_attributes;
                { sigi with 
                 psig_desc = Psig_value
                     { 
                       value_desc with
                       pval_prim = External_ffi_types.inline_bool_primitive (txt = "true") ;
                       pval_attributes = []
                     }}
              | _ -> 
                Location.raise_errorf ~loc "invalid payload in bs.inline"
           end 
         | Some ({loc}, _) ->                  
           Location.raise_errorf ~loc "invalid payload in bs.inline"
         | None ->
          default_mapper.signature_item self sigi
          )
      | _ -> default_mapper.signature_item self sigi



let structure_item_mapper (self : mapper) (str : Parsetree.structure_item) =
  match str.pstr_desc with
  | Pstr_extension ( ({txt = ("bs.raw"| "raw") ; loc}, payload), _attrs)
    ->
    Ast_util.handle_raw_structure loc payload
  | Pstr_extension (({txt = ("bs.debugger.chrome" | "debugger.chrome") ;loc}, payload),_)
    ->          
    Ast_structure.dummy_item loc
  | Pstr_type (

          _rf, 
          
          (_ :: _ as tdcls )) (* [ {ptype_attributes} as tdcl ] *)->
          Ast_tdcls.handleTdclsInStru self str tdcls
   | Pstr_primitive prim when Ast_attributes.external_needs_to_be_encoded prim.pval_attributes
      ->
      Ast_external.handleExternalInStru self prim str
   | Pstr_value 
    (Nonrecursive, [
      {
        pvb_pat = ({ppat_desc = Ppat_var pval_name} as pvb_pat); 
        pvb_expr ; 
        pvb_attributes ; 
        pvb_loc}]) 
    
    ->   
    let pvb_expr = self.expr self pvb_expr in 
    let pvb_attributes = self.attributes self pvb_attributes in 
    let has_inline_property = Ast_attributes.has_inline_in_stru pvb_attributes in
    begin match pvb_expr.pexp_desc, has_inline_property with 
    | Pexp_constant(

               Pconst_string
               

              (s,dec)), true 
    ->      
        Bs_ast_invariant.warn_discarded_unused_attributes pvb_attributes; 
        {str with pstr_desc = Pstr_primitive  {
             pval_name = pval_name ;
             pval_type = Ast_literal.type_string (); 
             pval_loc = pvb_loc;
             pval_attributes = [];
             pval_prim = External_ffi_types.inline_string_primitive s dec
           } } 
    | Pexp_constant(
      
      Pconst_integer (s,None)
      
      ), true   
      -> 
     
      let s = int_of_string s in  

      Bs_ast_invariant.warn_discarded_unused_attributes pvb_attributes; 
      {str with pstr_desc = Pstr_primitive  {
           pval_name = pval_name ;
           pval_type = Ast_literal.type_int (); 
           pval_loc = pvb_loc;
           pval_attributes = [];
           pval_prim = External_ffi_types.inline_int_primitive s
         } }
    | Pexp_construct ({txt = Lident ("true" | "false" as txt) },None), true -> 
      Bs_ast_invariant.warn_discarded_unused_attributes pvb_attributes; 
      {str with pstr_desc = Pstr_primitive  {
           pval_name = pval_name ;
           pval_type = Ast_literal.type_bool (); 
           pval_loc = pvb_loc;
           pval_attributes = [];
           pval_prim = External_ffi_types.inline_bool_primitive (txt = "true")
         } }
    | _ -> 
      { str with pstr_desc =  Pstr_value(Nonrecursive, [{pvb_pat ; pvb_expr; pvb_attributes; pvb_loc}])}
    end 
  | _ -> default_mapper.structure_item self str


    
let rec unsafe_mapper : mapper =
  { default_mapper with
    expr = expr_mapper;
    typ = typ_mapper ;
    class_type = class_type_mapper;      
    signature_item =  signature_item_mapper ;
    value_bindings = Ast_tuple_pattern_flatten.value_bindings_mapper;
    structure_item = structure_item_mapper
  }


type action_table = 
  (Parsetree.expression option -> unit) String_map.t
(** global configurations below *)
let common_actions_table :
  (string *  (Parsetree.expression option -> unit)) list =
  [
  ]


let structural_config_table : action_table =
  String_map.of_list
    (( "no_export" ,
       (fun x ->
          no_export := (
            match x with
            |Some e -> Ast_payload.assert_bool_lit e
            | None -> true)
       ))
     :: common_actions_table)

let signature_config_table : action_table =
  String_map.of_list common_actions_table


let rewrite_signature (x : Parsetree.signature) =  
  let result = 
    match x with
    | {psig_desc = Psig_attribute ({txt = "ocaml.ppx.context"},_)}
      :: {psig_desc = Psig_attribute ({txt = "bs.config"; loc}, payload); _} :: rest
    | {psig_desc = Psig_attribute ({txt = "bs.config"; loc}, payload); _} :: rest
      ->          
      Ext_list.iter (Ast_payload.ident_or_record_as_config loc payload) 
        (Ast_payload.table_dispatch signature_config_table) ;
      unsafe_mapper.signature unsafe_mapper rest          
    | _ ->
      unsafe_mapper.signature  unsafe_mapper x in
  reset ();
  (* Keep this check, since the check is not inexpensive*)
  Bs_ast_invariant.emit_external_warnings_on_signature result;
  result

(* Note we also drop attributes like [@@@bs.deriving ] for convenience*)    
let rewrite_implementation (x : Parsetree.structure) =  
  let result =
    match x with
    | {pstr_desc = Pstr_attribute ({txt = "ocaml.ppx.context"},_)}
      :: {pstr_desc = Pstr_attribute ({txt = "bs.config"; loc}, payload); _} :: rest
    | {pstr_desc = Pstr_attribute ({txt = "bs.config"; loc}, payload); _} :: rest
      ->
      begin
        Ext_list.iter (Ast_payload.ident_or_record_as_config loc payload)
          (Ast_payload.table_dispatch structural_config_table) ;
        let rest = unsafe_mapper.structure unsafe_mapper rest in
        if !no_export then
          Ast_helper.[Str.include_ ~loc
             (Incl.mk ~loc
                (Mod.constraint_ ~loc
                   (Mod.structure ~loc rest  )
                   (Mty.signature ~loc [])
                ))]
        else rest
      end
    | _ ->
      unsafe_mapper.structure  unsafe_mapper x  in
  reset ();
  (* Keep this check since it is not inexpensive*)
  Bs_ast_invariant.emit_external_warnings_on_structure result;
  result





end
module Reactjs_jsx_ppx_v2
= struct
#1 "reactjs_jsx_ppx_v2.ml"
# 1 "syntax/reactjs_jsx_ppx.cppo.ml"
(*
  This is the file that handles turning Reason JSX' agnostic function call into
  a ReasonReact-specific function call. Aka, this is a macro, using OCaml's ppx
  facilities; https://whitequark.org/blog/2014/04/16/a-guide-to-extension-
  points-in-ocaml/
  You wouldn't use this file directly; it's used by BuckleScript's
  bsconfig.json. Specifically, there's a field called `react-jsx` inside the
  field `reason`, which enables this ppx through some internal call in bsb
*)

(*
  There are two different transforms that can be selected in this file (v2 and v3):
  v2:
  transform `[@JSX] div(~props1=a, ~props2=b, ~children=[foo, bar], ())` into
  `ReactDOMRe.createElement("div", ~props={"props1": 1, "props2": b}, [|foo,
  bar|])`.
  transform `[@JSX] div(~props1=a, ~props2=b, ~children=foo, ())` into
  `ReactDOMRe.createElementVariadic("div", ~props={"props1": 1, "props2": b}, foo)`.
  transform the upper-cased case
  `[@JSX] Foo.createElement(~key=a, ~ref=b, ~foo=bar, ~children=[], ())` into
  `ReasonReact.element(~key=a, ~ref=b, Foo.make(~foo=bar, [||]))`
  transform `[@JSX] [foo]` into
  `ReactDOMRe.createElement(ReasonReact.fragment, [|foo|])`
  v3:
  transform `[@JSX] div(~props1=a, ~props2=b, ~children=[foo, bar], ())` into
  `ReactDOMRe.createDOMElementVariadic("div", ReactDOMRe.domProps(~props1=1, ~props2=b), [|foo, bar|])`.
  transform the upper-cased case
  `[@JSX] Foo.createElement(~key=a, ~ref=b, ~foo=bar, ~children=[], ())` into
  `React.createElement(Foo.make, Foo.makeProps(~key=a, ~ref=b, ~foo=bar, ()))`
  transform the upper-cased case
  `[@JSX] Foo.createElement(~foo=bar, ~children=[foo, bar], ())` into
  `React.createElementVariadic(Foo.make, Foo.makeProps(~foo=bar, ~children=React.null, ()), [|foo, bar|])`
  transform `[@JSX] [foo]` into
  `ReactDOMRe.createElement(ReasonReact.fragment, [|foo|])`
*)

open Ast_helper
open Ast_mapper
open Asttypes
open Parsetree
open Longident

let rec find_opt p = function
  | [] -> None
  | x :: l -> if p x then Some x else find_opt p l


# 49 "syntax/reactjs_jsx_ppx.cppo.ml"
let nolabel = Nolabel
let labelled str = Labelled str
let optional str = Optional str
let isOptional str = match str with
| Optional _ -> true
| _ -> false
let isLabelled str = match str with
| Labelled _ -> true
| _ -> false
let getLabel str = match str with
| Optional str | Labelled str -> str
| Nolabel -> ""
let optionIdent = Lident "option"

let argIsKeyRef = function
  | (Labelled ("key" | "ref"), _) | (Optional ("key" | "ref"), _) -> true
  | _ -> false
let constantString ~loc str = Ast_helper.Exp.constant ~loc (Pconst_string (str, None))

# 84 "syntax/reactjs_jsx_ppx.cppo.ml"
let safeTypeFromValue valueStr =
let valueStr = getLabel valueStr in
match String.sub valueStr 0 1 with
| "_" -> "T" ^ valueStr
| _ -> valueStr
let keyType loc = Typ.constr ~loc {loc; txt=optionIdent} [Typ.constr ~loc {loc; txt=Lident "string"} []]

type 'a children = | ListLiteral of 'a | Exact of 'a
type componentConfig = {
  propsName: string;
}

(* if children is a list, convert it to an array while mapping each element. If not, just map over it, as usual *)
let transformChildrenIfListUpper ~loc ~mapper theList =
  let rec transformChildren_ theList accum =
    (* not in the sense of converting a list to an array; convert the AST
       reprensentation of a list to the AST reprensentation of an array *)
    match theList with
    | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> begin
      match accum with
      | [singleElement] -> Exact singleElement
      | accum -> ListLiteral (List.rev accum |> Exp.array ~loc)
      end
    | {pexp_desc = Pexp_construct (
        {txt = Lident "::"},
        Some {pexp_desc = Pexp_tuple (v::acc::[])}
      )} ->
      transformChildren_ acc ((mapper.expr mapper v)::accum)
    | notAList -> Exact (mapper.expr mapper notAList)
  in
  transformChildren_ theList []

let transformChildrenIfList ~loc ~mapper theList =
  let rec transformChildren_ theList accum =
    (* not in the sense of converting a list to an array; convert the AST
       reprensentation of a list to the AST reprensentation of an array *)
    match theList with
    | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} ->
      List.rev accum |> Exp.array ~loc
    | {pexp_desc = Pexp_construct (
        {txt = Lident "::"},
        Some {pexp_desc = Pexp_tuple (v::acc::[])}
      )} ->
      transformChildren_ acc ((mapper.expr mapper v)::accum)
    | notAList -> mapper.expr mapper notAList
  in
  transformChildren_ theList []

let extractChildren ?(removeLastPositionUnit=false) ~loc propsAndChildren =
  let rec allButLast_ lst acc = match lst with
    | [] -> []
    
# 136 "syntax/reactjs_jsx_ppx.cppo.ml"
    | (Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})::[] -> acc
    | (Nolabel, _)::rest -> raise (Invalid_argument "JSX: found non-labelled argument before the last position")
    
# 142 "syntax/reactjs_jsx_ppx.cppo.ml"
    | arg::rest -> allButLast_ rest (arg::acc)
  in
  let allButLast lst = allButLast_ lst [] |> List.rev in
  match (List.partition (fun (label, _) -> label = labelled "children") propsAndChildren) with
  | ([], props) ->
    (* no children provided? Place a placeholder list *)
    (Exp.construct ~loc {loc; txt = Lident "[]"} None, if removeLastPositionUnit then allButLast props else props)
  | ([(_, childrenExpr)], props) ->
    (childrenExpr, if removeLastPositionUnit then allButLast props else props)
  | _ -> raise (Invalid_argument "JSX: somehow there's more than one `children` label")

(* Helper method to look up the [@react.component] attribute *)
let hasAttr (loc, _) =
  loc.txt = "react.component"

(* Helper method to filter out any attribute that isn't [@react.component] *)
let otherAttrsPure (loc, _) =
  loc.txt <> "react.component"

(* Iterate over the attributes and try to find the [@react.component] attribute *)
let hasAttrOnBinding {pvb_attributes} = find_opt hasAttr pvb_attributes <> None

(* Filter the [@react.component] attribute and immutably replace them on the binding *)
let filterAttrOnBinding binding = {binding with pvb_attributes = List.filter otherAttrsPure binding.pvb_attributes}

(* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *)
let getFnName binding =
  match binding with
  | {pvb_pat = {
      ppat_desc = Ppat_var {txt}
    }} -> txt
  | _ -> raise (Invalid_argument "react.component calls cannot be destructured.")

(* Lookup the value of `props` otherwise raise Invalid_argument error *)
let getPropsNameValue _acc (loc, exp) =
    match (loc, exp) with
    | ({ txt = Lident "props" }, { pexp_desc = Pexp_ident {txt = Lident str} }) -> { propsName = str }
    | ({ txt }, _) -> raise (Invalid_argument ("react.component only accepts props as an option, given: " ^ Longident.last txt))

(* Lookup the `props` record or string as part of [@react.component] and store the name for use when rewriting *)
let getPropsAttr payload =
  let defaultProps = {propsName = "Props"} in
  match payload with
  | Some(PStr(
    {pstr_desc = Pstr_eval ({
      pexp_desc = Pexp_record (recordFields, None)
      }, _)}::_rest
      )) ->
      List.fold_left getPropsNameValue defaultProps recordFields
  | Some(PStr({pstr_desc = Pstr_eval ({pexp_desc = Pexp_ident {txt = Lident "props"}}, _)}::_rest)) -> {propsName = "props"}
  | Some(PStr({pstr_desc = Pstr_eval (_, _)}::_rest)) -> raise (Invalid_argument ("react.component accepts a record config with props as an options."))
  | _ -> defaultProps

(* Plucks the label, loc, and type_ from an AST node *)
let pluckLabelDefaultLocType (label, default, _, _, loc, type_) = (label, default, loc, type_)

(* Lookup the filename from the location information on the AST node and turn it into a valid module identifier *)
let filenameFromLoc (pstr_loc: Location.t) =
  let fileName = match pstr_loc.loc_start.pos_fname with
  | "" -> !Location.input_name
  | fileName -> fileName
  in
  let fileName = try
      Filename.chop_extension (Filename.basename fileName)
    with | Invalid_argument _-> fileName in
  
# 208 "syntax/reactjs_jsx_ppx.cppo.ml"
  let fileName = String.capitalize_ascii fileName in
  
# 212 "syntax/reactjs_jsx_ppx.cppo.ml"
  fileName

(* Build a string representation of a module name with segments separated by $ *)
let makeModuleName fileName nestedModules fnName =
  let fullModuleName = match (fileName, nestedModules, fnName) with
  (* TODO: is this even reachable? It seems like the fileName always exists *)
  | ("", nestedModules, "make") -> nestedModules
  | ("", nestedModules, fnName) -> List.rev (fnName :: nestedModules)
  | (fileName, nestedModules, "make") -> fileName :: (List.rev nestedModules)
  | (fileName, nestedModules, fnName) -> fileName :: (List.rev (fnName :: nestedModules))
  in
  let fullModuleName = String.concat "$" fullModuleName in
  fullModuleName

(*
  AST node builders
  These functions help us build AST nodes that are needed when transforming a [@react.component] into a
  constructor and a props external
*)

(* Build an AST node representing all named args for the `external` definition for a component's props *)
let rec recursivelyMakeNamedArgsForExternal list args =
  match list with
  | (label, default, loc, interiorType)::tl ->
    recursivelyMakeNamedArgsForExternal tl (Typ.arrow
    ~loc
    label
    (match (label, interiorType, default) with
    (* ~foo=1 *)
    | (label, None, Some _) ->
    
# 243 "syntax/reactjs_jsx_ppx.cppo.ml"
    {
      ptyp_desc = Ptyp_var (safeTypeFromValue label);
      ptyp_loc = loc;
      ptyp_attributes = [];
    }
    
# 259 "syntax/reactjs_jsx_ppx.cppo.ml"
    (* ~foo: int=1 *)
    | (label, Some type_, Some _) ->
    
# 262 "syntax/reactjs_jsx_ppx.cppo.ml"
    type_
    
# 269 "syntax/reactjs_jsx_ppx.cppo.ml"
    (* ~foo: option(int)=? *)
    | (label, Some ({ptyp_desc = Ptyp_constr ({txt=(Lident "option")}, [type_])}), _)
    | (label, Some ({ptyp_desc = Ptyp_constr ({txt=(Ldot (Lident "*predef*", "option"))}, [type_])}), _)
    (* ~foo: int=? - note this isnt valid. but we want to get a type error *)
    | (label, Some type_, _) when isOptional label ->
    
# 275 "syntax/reactjs_jsx_ppx.cppo.ml"
    type_
    
# 282 "syntax/reactjs_jsx_ppx.cppo.ml"
    (* ~foo=? *)
    | (label, None, _) when isOptional label ->
    
# 285 "syntax/reactjs_jsx_ppx.cppo.ml"
    {
      ptyp_desc = Ptyp_var (safeTypeFromValue label);
      ptyp_loc = loc;
      ptyp_attributes = [];
    }
    
# 301 "syntax/reactjs_jsx_ppx.cppo.ml"
    (* ~foo *)
    | (label, None, _) ->
    {
      ptyp_desc = Ptyp_var (safeTypeFromValue label);
      ptyp_loc = loc;
      ptyp_attributes = [];
    }
    | (label, Some type_, _) ->
    type_
    )
    args)
  | [] -> args

(* Build an AST node for the [@bs.obj] representing props for a component *)
let makePropsValue fnName loc namedArgListWithKeyAndRef propsType =
  let propsName = fnName ^ "Props" in {
  pval_name = {txt = propsName; loc};
  pval_type =
      recursivelyMakeNamedArgsForExternal
        namedArgListWithKeyAndRef
        (Typ.arrow
          nolabel
          {
            ptyp_desc = Ptyp_constr ({txt= Lident("unit"); loc}, []);
            ptyp_loc = loc;
            ptyp_attributes = [];
          }
          propsType
        );
  pval_prim = [""];
  pval_attributes = [({txt = "bs.obj"; loc = loc}, PStr [])];
  pval_loc = loc;
}

(* Build an AST node representing an `external` with the definition of the [@bs.obj] *)
let makePropsExternal fnName loc namedArgListWithKeyAndRef propsType =
  {
    pstr_loc = loc;
    pstr_desc = Pstr_primitive (makePropsValue fnName loc namedArgListWithKeyAndRef propsType)
  }

(* Build an AST node for the signature of the `external` definition *)
let makePropsExternalSig fnName loc namedArgListWithKeyAndRef propsType =
  {
    psig_loc = loc;
    psig_desc = Psig_value (makePropsValue fnName loc namedArgListWithKeyAndRef propsType)
  }

(* Build an AST node for the props name when converted to a Js.t inside the function signature  *)
let makePropsName ~loc name =
  {
    ppat_desc = Ppat_var {txt = name; loc};
    ppat_loc = loc;
    ppat_attributes = [];
  }

# 358 "syntax/reactjs_jsx_ppx.cppo.ml"
let makeObjectField loc (str, _attrs, type_) =
  (* intentionally not using attrs - they probably don't work on object fields. use on *Props instead *)
  Otag ({ loc; txt = str }, [], {type_ with ptyp_attributes = []})

# 363 "syntax/reactjs_jsx_ppx.cppo.ml"
(* Build an AST node representing a "closed" Js.t object representing a component's props *)
let makePropsType ~loc namedTypeList =
  Typ.mk ~loc (
    Ptyp_constr({txt= Ldot (Lident("Js"), "t"); loc}, [{
        
# 368 "syntax/reactjs_jsx_ppx.cppo.ml"
        ptyp_desc = Ptyp_object(
          List.map (makeObjectField loc) namedTypeList,
          Closed
        );
        
# 375 "syntax/reactjs_jsx_ppx.cppo.ml"
        ptyp_loc = loc;
        ptyp_attributes = [];
      }])
    )

(* Builds an AST node for the entire `external` definition of props *)
let makeExternalDecl fnName loc namedArgListWithKeyAndRef namedTypeList =
  makePropsExternal
    fnName
    loc
    (List.map pluckLabelDefaultLocType namedArgListWithKeyAndRef)
    (makePropsType ~loc namedTypeList)

(* TODO: some line number might still be wrong *)
let jsxMapper () =

  let jsxVersion = ref None in

  let transformUppercaseCall3 modulePath mapper loc attrs _ callArguments =
    let (children, argsWithLabels) = extractChildren ~loc ~removeLastPositionUnit:true callArguments in
    let argsForMake = argsWithLabels in
    let childrenExpr = transformChildrenIfListUpper ~loc ~mapper children in
    let recursivelyTransformedArgsForMake = argsForMake |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression)) in
    let childrenArg = ref None in
    let args = recursivelyTransformedArgsForMake
      @ (match childrenExpr with
        | Exact children -> [(labelled "children", children)]
        | ListLiteral ({ pexp_desc = Pexp_array list }) when list = [] -> []
        | ListLiteral expression ->
        (* this is a hack to support react components that introspect into their children *)
        (childrenArg := Some expression;
        [(labelled "children", Exp.ident ~loc {loc; txt = Ldot (Lident "React", "null")})]))
      @ [(nolabel, Exp.construct ~loc {loc; txt = Lident "()"} None)] in
    let isCap str = let first = String.sub str 0 1 in
    
# 410 "syntax/reactjs_jsx_ppx.cppo.ml"
    let capped = String.uppercase_ascii first in first = capped in
    
# 414 "syntax/reactjs_jsx_ppx.cppo.ml"
    let ident = match modulePath with
    | Lident _ -> Ldot (modulePath, "make")
    | (Ldot (_modulePath, value) as fullPath) when isCap value -> Ldot (fullPath, "make")
    | modulePath -> modulePath in
    let propsIdent = match ident with
    | Lident path -> Lident (path ^ "Props")
    | Ldot(ident, path) -> Ldot (ident, path ^ "Props")
    | _ -> raise (Invalid_argument "JSX name can't be the result of function applications") in
    let props =
    Exp.apply ~attrs ~loc (Exp.ident ~loc {loc; txt = propsIdent}) args in
    (* handle key, ref, children *)
      (* React.createElement(Component.make, props, ...children) *)
    match (!childrenArg) with
    | None ->
      (Exp.apply
        ~loc
        ~attrs
        (Exp.ident ~loc {loc; txt = Ldot (Lident "React", "createElement")})
        ([
          (nolabel, Exp.ident ~loc {txt = ident; loc});
          (nolabel, props)
        ]))
     | Some children ->
       (Exp.apply
         ~loc
         ~attrs
         (Exp.ident ~loc {loc; txt = Ldot (Lident "React", "createElementVariadic")})
         ([
           (nolabel, Exp.ident ~loc {txt = ident; loc});
           (nolabel, props);
           (nolabel, children)
         ]))
     in

    let transformLowercaseCall3 mapper loc attrs callArguments id =
      let (children, nonChildrenProps) = extractChildren ~loc callArguments in
      let componentNameExpr = constantString ~loc id in
      let childrenExpr = transformChildrenIfList ~loc ~mapper children in
      let createElementCall = match children with
        (* [@JSX] div(~children=[a]), coming from <div> a </div> *)
        | {
            pexp_desc =
             Pexp_construct ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple _ })
             | Pexp_construct ({txt = Lident "[]"}, None)
          } -> "createDOMElementVariadic"
        (* [@JSX] div(~children= value), coming from <div> ...(value) </div> *)
        | _ -> raise (Invalid_argument "A spread as a DOM element's \
          children don't make sense written together. You can simply remove the spread.")
      in
      let args = match nonChildrenProps with
        | [_justTheUnitArgumentAtEnd] ->
          [
            (* "div" *)
            (nolabel, componentNameExpr);
            (* [|moreCreateElementCallsHere|] *)
            (nolabel, childrenExpr)
          ]
        | nonEmptyProps ->
          let propsCall =
            Exp.apply
              ~loc
              (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", "domProps")})
              (nonEmptyProps |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression)))
          in
          [
            (* "div" *)
            (nolabel, componentNameExpr);
            (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *)
            (labelled "props", propsCall);
            (* [|moreCreateElementCallsHere|] *)
            (nolabel, childrenExpr)
          ] in
      Exp.apply
        ~loc
        (* throw away the [@JSX] attribute and keep the others, if any *)
        ~attrs
        (* ReactDOMRe.createElement *)
        (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", createElementCall)})
        args
    in

  let transformUppercaseCall modulePath mapper loc attrs _ callArguments =
    let (children, argsWithLabels) = extractChildren ~loc ~removeLastPositionUnit:true callArguments in
    let (argsKeyRef, argsForMake) = List.partition argIsKeyRef argsWithLabels in
    let childrenExpr = transformChildrenIfList ~loc ~mapper children in
    let recursivelyTransformedArgsForMake = argsForMake |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression)) in
    let args = recursivelyTransformedArgsForMake @ [ (nolabel, childrenExpr) ] in
    let wrapWithReasonReactElement e = (* ReasonReact.element(~key, ~ref, ...) *)
      Exp.apply
        ~loc
        (Exp.ident ~loc {loc; txt = Ldot (Lident "ReasonReact", "element")})
        (argsKeyRef @ [(nolabel, e)]) in
    Exp.apply
      ~loc
      ~attrs
      (* Foo.make *)
      (Exp.ident ~loc {loc; txt = Ldot (modulePath, "make")})
      args
    |> wrapWithReasonReactElement in

  let transformLowercaseCall mapper loc attrs callArguments id =
    let (children, nonChildrenProps) = extractChildren ~loc callArguments in
    let componentNameExpr = constantString ~loc id in
    let childrenExpr = transformChildrenIfList ~loc ~mapper children in
    let createElementCall = match children with
      (* [@JSX] div(~children=[a]), coming from <div> a </div> *)
      | {
          pexp_desc =
           Pexp_construct ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple _ })
           | Pexp_construct ({txt = Lident "[]"}, None)
        } -> "createElement"
      (* [@JSX] div(~children=[|a|]), coming from <div> ...[|a|] </div> *)
      | { pexp_desc = (Pexp_array _) } ->
        raise (Invalid_argument "A spread + an array literal as a DOM element's \
          children would cancel each other out, and thus don't make sense written \
          together. You can simply remove the spread and the array literal.")
      (* [@JSX] div(~children= <div />), coming from <div> ...<div/> </div> *)
      | {
          pexp_attributes
        } when pexp_attributes |> List.exists (fun (attribute, _) -> attribute.txt = "JSX") ->
        raise (Invalid_argument "A spread + a JSX literal as a DOM element's \
          children don't make sense written together. You can simply remove the spread.")
      | _ -> "createElementVariadic"
    in
    let args = match nonChildrenProps with
      | [_justTheUnitArgumentAtEnd] ->
        [
          (* "div" *)
          (nolabel, componentNameExpr);
          (* [|moreCreateElementCallsHere|] *)
          (nolabel, childrenExpr)
        ]
      | nonEmptyProps ->
        let propsCall =
          Exp.apply
            ~loc
            (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", "props")})
            (nonEmptyProps |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression)))
        in
        [
          (* "div" *)
          (nolabel, componentNameExpr);
          (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *)
          (labelled "props", propsCall);
          (* [|moreCreateElementCallsHere|] *)
          (nolabel, childrenExpr)
        ] in
    Exp.apply
      ~loc
      (* throw away the [@JSX] attribute and keep the others, if any *)
      ~attrs
      (* ReactDOMRe.createElement *)
      (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", createElementCall)})
      args
  in

  let rec recursivelyTransformNamedArgsForMake mapper expr list =
    let expr = mapper.expr mapper expr in
    match expr.pexp_desc with
    (* TODO: make this show up with a loc. *)
    
# 575 "syntax/reactjs_jsx_ppx.cppo.ml"
    | Pexp_fun (Labelled "key", _, _, _)
    | Pexp_fun (Optional "key", _, _, _) -> raise (Invalid_argument "Key cannot be accessed inside of a component. Don't worry - you can always key a component from its parent!")
    | Pexp_fun (Labelled "ref", _, _, _)
    | Pexp_fun (Optional "ref", _, _, _) -> raise (Invalid_argument "Ref cannot be passed as a normal prop. Please use `forwardRef` API instead.")
    
# 585 "syntax/reactjs_jsx_ppx.cppo.ml"
    | Pexp_fun (arg, default, pattern, expression) when isOptional arg || isLabelled arg ->
      let alias = (match pattern with
      | {ppat_desc = Ppat_alias (_, {txt}) | Ppat_var {txt}} -> txt
      | {ppat_desc = Ppat_any} -> "_"
      | _ -> getLabel arg) in
      let type_ = (match pattern with
      | {ppat_desc = Ppat_constraint (_, type_)} -> Some type_
      | _ -> None) in

      recursivelyTransformNamedArgsForMake mapper expression ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: list)
    
# 596 "syntax/reactjs_jsx_ppx.cppo.ml"
    | Pexp_fun (Nolabel, _, { ppat_desc = (Ppat_construct ({txt = Lident "()"}, _) | Ppat_any)}, expression) ->
        (expression.pexp_desc, list, None)
    | Pexp_fun (Nolabel, _, { ppat_desc = Ppat_var ({txt})}, expression) ->
        (expression.pexp_desc, list, Some txt)
    
# 606 "syntax/reactjs_jsx_ppx.cppo.ml"
    | innerExpression -> (innerExpression, list, None)
  in


  let argToType types (name, default, _noLabelName, _alias, loc, type_) = match (type_, name, default) with
    | (Some ({ptyp_desc = Ptyp_constr ({txt=(Lident "option")}, [type_])}), name, _) when isOptional name ->
      (getLabel name, [], {
        type_ with
        ptyp_desc = Ptyp_constr ({loc=type_.ptyp_loc; txt=optionIdent}, [type_]);
      }) :: types
    | (Some type_, name, Some _default) ->
      (getLabel name, [], {
      ptyp_desc = Ptyp_constr ({loc; txt=optionIdent}, [type_]);
      ptyp_loc = loc;
      ptyp_attributes = [];
      }) :: types
    | (Some type_, name, _) ->
      (getLabel name, [], type_) :: types
    | (None, name, _) when isOptional name ->
      (getLabel name, [], {
        ptyp_desc = Ptyp_constr ({loc; txt=optionIdent}, [{
          ptyp_desc = Ptyp_var (safeTypeFromValue name);
          ptyp_loc = loc;
          ptyp_attributes = [];
        }]);
        ptyp_loc = loc;
        ptyp_attributes = [];
        }) :: types
    | (None, name, _) when isLabelled name ->
      (getLabel name, [], {
        ptyp_desc = Ptyp_var (safeTypeFromValue name);
        ptyp_loc = loc;
        ptyp_attributes = [];
        }) :: types
    | _ -> types
  in

  let argToConcreteType types (name, loc, type_) = match name with
    | name when isLabelled name ->
    (getLabel name, [], type_) :: types
    | name when isOptional name ->
  
# 648 "syntax/reactjs_jsx_ppx.cppo.ml"
  (getLabel name, [], Typ.constr ~loc {loc; txt=optionIdent} [type_]) :: types
    
# 652 "syntax/reactjs_jsx_ppx.cppo.ml"
    | _ -> types
  in

  let nestedModules = ref([]) in
  let transformComponentDefinition mapper structure returnStructures = match structure with
  (* external *)
  | ({
      pstr_loc;
      pstr_desc = Pstr_primitive ({
        pval_name = { txt = fnName };
        pval_attributes;
        pval_type;
      } as value_description)
    } as pstr) ->
    (match List.filter hasAttr pval_attributes with
    | [] -> structure :: returnStructures
    | [_] ->
    let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) =
      (match ptyp_desc with
      | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) when isLabelled name || isOptional name ->
        getPropTypes ((name, ptyp_loc, type_)::types) rest
      
# 674 "syntax/reactjs_jsx_ppx.cppo.ml"
      | Ptyp_arrow (Nolabel, _type, rest) ->
        
# 678 "syntax/reactjs_jsx_ppx.cppo.ml"
        getPropTypes types rest
      | Ptyp_arrow (name, type_, returnValue) when isLabelled name || isOptional name ->
        (returnValue, (name, returnValue.ptyp_loc, type_)::types)
      | _ -> (fullType, types))
    in
    let (innerType, propTypes) = getPropTypes [] pval_type in
    let namedTypeList = List.fold_left argToConcreteType [] propTypes in
    let pluckLabelAndLoc (label, loc, type_) = (label, None (* default *), loc, Some type_) in
    let retPropsType = makePropsType ~loc:pstr_loc namedTypeList in
    let externalPropsDecl = makePropsExternal fnName pstr_loc ((
      optional "key",
      None,
      pstr_loc,
      Some(keyType pstr_loc)
    ) :: List.map pluckLabelAndLoc propTypes) retPropsType in
    (* can't be an arrow because it will defensively uncurry *)
    let newExternalType = Ptyp_constr (
      {loc = pstr_loc; txt = Ldot ((Lident "React"), "componentLike")},
      [retPropsType; innerType]
    ) in
    let newStructure = {
      pstr with pstr_desc = Pstr_primitive {
        value_description with pval_type = {
          pval_type with ptyp_desc = newExternalType;
        };
        pval_attributes = List.filter otherAttrsPure pval_attributes;
      }
    } in
    externalPropsDecl :: newStructure :: returnStructures
    | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time"))
  (* let component = ... *)
  | {
      pstr_loc;
      pstr_desc = Pstr_value (
        recFlag,
        valueBindings
      )
    } ->
      let mapBinding binding = if (hasAttrOnBinding binding) then
        let fnName = getFnName binding in
        let fileName = filenameFromLoc pstr_loc in
        let fullModuleName = makeModuleName fileName !nestedModules fnName in
        let emptyLoc = Location.in_file fileName in
        let modifiedBinding binding =
          let expression = binding.pvb_expr in
          let wrapExpressionWithBinding expressionFn expression = {(filterAttrOnBinding binding) with pvb_expr = expressionFn expression} in
          (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *)
          let rec spelunkForFunExpression expression = (match expression with
          (* let make = (~prop) => ... *)
          | {
            pexp_desc = Pexp_fun _
          } -> ((fun expressionDesc -> {expression with pexp_desc = expressionDesc}), expression)
          (* let make = {let foo = bar in (~prop) => ...} *)
          | {
              pexp_desc = Pexp_let (recursive, vbs, returnExpression)
            } ->
            (* here's where we spelunk! *)
            let (wrapExpression, realReturnExpression) = spelunkForFunExpression returnExpression in
            ((fun expressionDesc -> {expression with pexp_desc = Pexp_let (recursive, vbs, wrapExpression expressionDesc)}), realReturnExpression)
          (* let make = React.forwardRef((~prop) => ...) *)
          
# 739 "syntax/reactjs_jsx_ppx.cppo.ml"
          | { pexp_desc = Pexp_apply (wrapperExpression, [(Nolabel, innerFunctionExpression)]) } ->
            
# 743 "syntax/reactjs_jsx_ppx.cppo.ml"
            let (wrapExpression, realReturnExpression) = spelunkForFunExpression innerFunctionExpression in
            ((fun expressionDesc -> {
              expression with pexp_desc =
                Pexp_apply (wrapperExpression, [(nolabel, wrapExpression expressionDesc)])
              }),
              realReturnExpression
            )
          | {
              pexp_desc = Pexp_sequence (wrapperExpression, innerFunctionExpression)
            } ->
            let (wrapExpression, realReturnExpression) = spelunkForFunExpression innerFunctionExpression in
            ((fun expressionDesc -> {
              expression with pexp_desc =
                Pexp_sequence (wrapperExpression, wrapExpression expressionDesc)
              }),
              realReturnExpression
            )
          | _ -> raise (Invalid_argument "react.component calls can only be on function definitions or component wrappers (forwardRef, memo).")
          ) in
          let (wrapExpression, expression) = spelunkForFunExpression expression in
          (wrapExpressionWithBinding wrapExpression, expression)
        in
        let (bindingWrapper, expression) = modifiedBinding binding in
        let reactComponentAttribute = try
          Some(List.find hasAttr binding.pvb_attributes)
        with | Not_found -> None in
        let (attr_loc, payload) = match reactComponentAttribute with
        | Some (loc, payload) -> (loc.loc, Some payload)
        | None -> (emptyLoc, None) in
        let props = getPropsAttr payload in
        (* do stuff here! *)
        let (innerFunctionExpression, namedArgList, forwardRef) = recursivelyTransformNamedArgsForMake mapper expression [] in
        let namedArgListWithKeyAndRef = (optional("key"), None, Pat.var {txt = "key"; loc = emptyLoc}, "key", emptyLoc, Some(keyType emptyLoc)) :: namedArgList in
        let namedArgListWithKeyAndRef = match forwardRef with
        | Some(_) ->  (optional("ref"), None, Pat.var {txt = "key"; loc = emptyLoc}, "ref", emptyLoc, None) :: namedArgListWithKeyAndRef
        | None -> namedArgListWithKeyAndRef
        in
        let namedTypeList = List.fold_left argToType [] namedArgList in
        let externalDecl = makeExternalDecl fnName attr_loc namedArgListWithKeyAndRef namedTypeList in
        let makeLet innerExpression (label, default, pattern, _alias, loc, _type) =
          let labelString = (match label with | label when isOptional label || isLabelled label -> getLabel label | _ -> raise (Invalid_argument "This should never happen")) in
          let expression = (Exp.apply ~loc
            (Exp.ident ~loc {txt = (Lident "##"); loc })
            [
              (nolabel, Exp.ident ~loc {txt = (Lident props.propsName); loc });
              (nolabel, Exp.ident ~loc {
                txt = (Lident labelString);
                loc
              })
            ]
          ) in
          let expression = match (default) with
          | (Some default) -> Exp.match_ expression [
            Exp.case
              (Pat.construct {loc; txt=Lident "Some"} (Some (Pat.var ~loc {txt = labelString; loc})))
              (Exp.ident ~loc {txt = (Lident labelString); loc = { loc with Location.loc_ghost = true }});
            Exp.case
              (Pat.construct {loc; txt=Lident "None"} None)
              default
          ]
          | None -> expression in
          let letExpression = Vb.mk
            pattern
            expression in
          Exp.let_ ~loc Nonrecursive [letExpression] innerExpression in
        let innerExpression = List.fold_left makeLet (Exp.mk innerFunctionExpression) namedArgList in
        let innerExpressionWithRef = match (forwardRef) with
        | Some txt ->
          {innerExpression with pexp_desc = Pexp_fun (nolabel, None, {
            ppat_desc = Ppat_var { txt; loc = emptyLoc };
            ppat_loc = emptyLoc;
            ppat_attributes = [];
          }, innerExpression)}
        | None -> innerExpression
        in
        let fullExpression = (Pexp_fun (
          nolabel,
          None,
          {
            ppat_desc = Ppat_constraint (
              makePropsName ~loc:emptyLoc props.propsName,
              makePropsType ~loc:emptyLoc namedTypeList
            );
            ppat_loc = emptyLoc;
            ppat_attributes = [];
          },
          innerExpressionWithRef
        )) in
        let fullExpression = match (fullModuleName) with
        | ("") -> fullExpression
        | (txt) -> Pexp_let (
            Nonrecursive,
            [Vb.mk
              ~loc:emptyLoc
              (Pat.var ~loc:emptyLoc {loc = emptyLoc; txt})
              (Exp.mk ~loc:emptyLoc fullExpression)
            ],
            (Exp.ident ~loc:emptyLoc {loc = emptyLoc; txt = Lident txt})
          )
        in
        let newBinding = bindingWrapper fullExpression in
        (Some externalDecl, newBinding)
      else
        (None, binding)
      in
      let structuresAndBinding = List.map mapBinding valueBindings in
      let otherStructures (extern, binding) (externs, bindings) =
        let externs = match extern with
        | Some extern -> extern :: externs
        | None -> externs in
        (externs, binding :: bindings)
      in
      let (externs, bindings) = List.fold_right otherStructures structuresAndBinding ([], []) in
      externs @ {
        pstr_loc;
        pstr_desc = Pstr_value (
          recFlag,
          bindings
        )
      } :: returnStructures
    | structure -> structure :: returnStructures in

  let reactComponentTransform mapper structures =
  List.fold_right (transformComponentDefinition mapper) structures [] in

  let transformComponentSignature _mapper signature returnSignatures = match signature with
  | ({
      psig_loc;
      psig_desc = Psig_value ({
        pval_name = { txt = fnName };
        pval_attributes;
        pval_type;
      } as psig_desc)
    } as psig) ->
    (match List.filter hasAttr pval_attributes with
    | [] -> signature :: returnSignatures
    | [_] ->
    let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) =
      (match ptyp_desc with
      | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) when isOptional name || isLabelled name ->
        getPropTypes ((name, ptyp_loc, type_)::types) rest
      
# 885 "syntax/reactjs_jsx_ppx.cppo.ml"
      | Ptyp_arrow (Nolabel, _type, rest) ->
        
# 889 "syntax/reactjs_jsx_ppx.cppo.ml"
        getPropTypes types rest
      | Ptyp_arrow (name, type_, returnValue) when isOptional name || isLabelled name ->
        (returnValue, (name, returnValue.ptyp_loc, type_)::types)
      | _ -> (fullType, types))
    in
    let (innerType, propTypes) = getPropTypes [] pval_type in
    let namedTypeList = List.fold_left argToConcreteType [] propTypes in
    let pluckLabelAndLoc (label, loc, type_) = (label, None, loc, Some type_) in
    let retPropsType = makePropsType ~loc:psig_loc namedTypeList in
    let externalPropsDecl = makePropsExternalSig fnName psig_loc ((
      optional "key",
      None,
      psig_loc,
      Some(keyType psig_loc)
    ) :: List.map pluckLabelAndLoc propTypes) retPropsType in
        (* can't be an arrow because it will defensively uncurry *)
    let newExternalType = Ptyp_constr (
      {loc = psig_loc; txt = Ldot ((Lident "React"), "componentLike")},
      [retPropsType; innerType]
    ) in
    let newStructure = {
      psig with psig_desc = Psig_value {
        psig_desc with pval_type = {
          pval_type with ptyp_desc = newExternalType;
        };
        pval_attributes = List.filter otherAttrsPure pval_attributes;
      }
    } in
    externalPropsDecl :: newStructure :: returnSignatures
    | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time"))
  | signature -> signature :: returnSignatures in

  let reactComponentSignatureTransform mapper signatures =
  List.fold_right (transformComponentSignature mapper) signatures [] in


  let transformJsxCall mapper callExpression callArguments attrs =
    (match callExpression.pexp_desc with
     | Pexp_ident caller ->
       (match caller with
        | {txt = Lident "createElement"} ->
          raise (Invalid_argument "JSX: `createElement` should be preceeded by a module name.")

        (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *)
        | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} ->
          (match !jsxVersion with
          
# 936 "syntax/reactjs_jsx_ppx.cppo.ml"
          | None
          | Some 2 -> transformUppercaseCall modulePath mapper loc attrs callExpression callArguments
          
# 942 "syntax/reactjs_jsx_ppx.cppo.ml"
          | Some 3 -> transformUppercaseCall3 modulePath mapper loc attrs callExpression callArguments
          | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 2 or 3"))

        (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *)
        (* turn that into
          ReactDOMRe.createElement(~props=ReactDOMRe.props(~props1=foo, ~props2=bar, ()), [|bla|]) *)
        | {loc; txt = Lident id} ->
          (match !jsxVersion with
          
# 951 "syntax/reactjs_jsx_ppx.cppo.ml"
          | None
          | Some 2 -> transformLowercaseCall mapper loc attrs callArguments id
          
# 957 "syntax/reactjs_jsx_ppx.cppo.ml"
          | Some 3 -> transformLowercaseCall3 mapper loc attrs callArguments id
          | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 2 or 3"))

        | {txt = Ldot (_, anythingNotCreateElementOrMake)} ->
          raise (
            Invalid_argument
              ("JSX: the JSX attribute should be attached to a `YourModuleName.createElement` or `YourModuleName.make` call. We saw `"
               ^ anythingNotCreateElementOrMake
               ^ "` instead"
              )
          )

        | {txt = Lapply _} ->
          (* don't think there's ever a case where this is reached *)
          raise (
            Invalid_argument "JSX: encountered a weird case while processing the code. Please report this!"
          )
       )
     | _ ->
       raise (
         Invalid_argument "JSX: `createElement` should be preceeded by a simple, direct module name."
       )
    ) in

  let signature =
    (fun mapper signature -> default_mapper.signature mapper @@ reactComponentSignatureTransform mapper signature) in

  let structure =
    (fun mapper structure -> match structure with
      (*
        match against [@bs.config {foo, jsx: ...}] at the file-level. This
        indicates which version of JSX we're using. This code stays here because
        we used to have 2 versions of JSX PPX (and likely will again in the
        future when JSX PPX changes). So the architecture for switching between
        JSX behavior stayed here. To create a new JSX ppx, copy paste this
        entire file and change the relevant parts.
        Description of architecture: in bucklescript's bsconfig.json, you can
        specify a project-wide JSX version. You can also specify a file-level
        JSX version. This degree of freedom allows a person to convert a project
        one file at time onto the new JSX, when it was released. It also enabled
        a project to depend on a third-party which is still using an old version
        of JSX
      *)
      | ({
          pstr_desc = Pstr_attribute (
            {txt = "ocaml.ppx.context"} ,
            _
          )
        }::
        {
          pstr_loc;
          pstr_desc = Pstr_attribute (
            ({txt = "bs.config"} as bsConfigLabel),
            PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (recordFields, b)} as innerConfigRecord, a)} as configRecord]
          )
        }
        ::restOfStructure ) | ({
          pstr_loc;
          pstr_desc = Pstr_attribute (
            ({txt = "bs.config"} as bsConfigLabel),
            PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (recordFields, b)} as innerConfigRecord, a)} as configRecord]
          )
        }::restOfStructure) -> begin
          let (jsxField, recordFieldsWithoutJsx) = recordFields |> List.partition (fun ({txt}, _) -> txt = Lident "jsx") in
          match (jsxField, recordFieldsWithoutJsx) with
          (* no file-level jsx config found *)
          | ([], _) -> default_mapper.structure mapper structure
          (* {jsx: 2} *)
          
# 1026 "syntax/reactjs_jsx_ppx.cppo.ml"
          | ((_, {pexp_desc = Pexp_constant (Pconst_integer (version, None))})::rest, recordFieldsWithoutJsx) -> begin
              
# 1030 "syntax/reactjs_jsx_ppx.cppo.ml"
              (match version with
              
# 1032 "syntax/reactjs_jsx_ppx.cppo.ml"
              | "2" -> jsxVersion := Some 2
              | "3" -> jsxVersion := Some 3
              
# 1038 "syntax/reactjs_jsx_ppx.cppo.ml"
              | _ -> raise (Invalid_argument "JSX: the file-level bs.config's jsx version must be 2 or 3"));
              match recordFieldsWithoutJsx with
              (* record empty now, remove the whole bs.config attribute *)
              | [] -> default_mapper.structure mapper @@ reactComponentTransform mapper restOfStructure
              | fields -> default_mapper.structure mapper ({
                pstr_loc;
                pstr_desc = Pstr_attribute (
                  bsConfigLabel,
                  PStr [{configRecord with pstr_desc = Pstr_eval ({innerConfigRecord with pexp_desc = Pexp_record (fields, b)}, a)}]
                )
              }::(reactComponentTransform mapper restOfStructure))
            end
        | _ -> raise (Invalid_argument "JSX: the file-level bs.config's {jsx: ...} config accepts only a version number")
      end
      | structures -> begin
        default_mapper.structure mapper @@ reactComponentTransform mapper structures
      end
    ) in

  let expr =
    (fun mapper expression -> match expression with
       (* Does the function application have the @JSX attribute? *)
       | {
           pexp_desc = Pexp_apply (callExpression, callArguments);
           pexp_attributes
         } ->
         let (jsxAttribute, nonJSXAttributes) = List.partition (fun (attribute, _) -> attribute.txt = "JSX") pexp_attributes in
         (match (jsxAttribute, nonJSXAttributes) with
         (* no JSX attribute *)
         | ([], _) -> default_mapper.expr mapper expression
         | (_, nonJSXAttributes) -> transformJsxCall mapper callExpression callArguments nonJSXAttributes)

       (* is it a list with jsx attribute? Reason <>foo</> desugars to [@JSX][foo]*)
       | {
           pexp_desc =
            Pexp_construct ({txt = Lident "::"; loc}, Some {pexp_desc = Pexp_tuple _})
            | Pexp_construct ({txt = Lident "[]"; loc}, None);
           pexp_attributes
         } as listItems ->
          let (jsxAttribute, nonJSXAttributes) = List.partition (fun (attribute, _) -> attribute.txt = "JSX") pexp_attributes in
          (match (jsxAttribute, nonJSXAttributes) with
          (* no JSX attribute *)
          | ([], _) -> default_mapper.expr mapper expression
          | (_, nonJSXAttributes) ->
            let fragment = Exp.ident ~loc {loc; txt = Ldot (Lident "ReasonReact", "fragment")} in
            let childrenExpr = transformChildrenIfList ~loc ~mapper listItems in
            let args = [
              (* "div" *)
              (nolabel, fragment);
              (* [|moreCreateElementCallsHere|] *)
              (nolabel, childrenExpr)
            ] in
            Exp.apply
              ~loc
              (* throw away the [@JSX] attribute and keep the others, if any *)
              ~attrs:nonJSXAttributes
              (* ReactDOMRe.createElement *)
              (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", "createElement")})
              args
         )
       (* Delegate to the default mapper, a deep identity traversal *)
       | e -> default_mapper.expr mapper e) in

  let module_binding =
    (fun mapper module_binding ->
      let _ = nestedModules := module_binding.pmb_name.txt :: !nestedModules in
      let mapped = default_mapper.module_binding mapper module_binding in
      let _ = nestedModules := List.tl !nestedModules in
      mapped
    ) in

  { default_mapper with structure; expr; signature; module_binding; }

let rewrite_implementation (code: Parsetree.structure) : Parsetree.structure =
  let mapper = jsxMapper () in
  mapper.structure mapper code
let rewrite_signature (code : Parsetree.signature) : Parsetree.signature =
  let mapper = jsxMapper () in
  mapper.signature mapper code


end
module Reactjs_jsx_ppx_v3
= struct
#1 "reactjs_jsx_ppx_v3.ml"
# 1 "syntax/reactjs_jsx_ppx.cppo.ml"
(*
  This is the file that handles turning Reason JSX' agnostic function call into
  a ReasonReact-specific function call. Aka, this is a macro, using OCaml's ppx
  facilities; https://whitequark.org/blog/2014/04/16/a-guide-to-extension-
  points-in-ocaml/
  You wouldn't use this file directly; it's used by BuckleScript's
  bsconfig.json. Specifically, there's a field called `react-jsx` inside the
  field `reason`, which enables this ppx through some internal call in bsb
*)

(*
  There are two different transforms that can be selected in this file (v2 and v3):
  v2:
  transform `[@JSX] div(~props1=a, ~props2=b, ~children=[foo, bar], ())` into
  `ReactDOMRe.createElement("div", ~props={"props1": 1, "props2": b}, [|foo,
  bar|])`.
  transform `[@JSX] div(~props1=a, ~props2=b, ~children=foo, ())` into
  `ReactDOMRe.createElementVariadic("div", ~props={"props1": 1, "props2": b}, foo)`.
  transform the upper-cased case
  `[@JSX] Foo.createElement(~key=a, ~ref=b, ~foo=bar, ~children=[], ())` into
  `ReasonReact.element(~key=a, ~ref=b, Foo.make(~foo=bar, [||]))`
  transform `[@JSX] [foo]` into
  `ReactDOMRe.createElement(ReasonReact.fragment, [|foo|])`
  v3:
  transform `[@JSX] div(~props1=a, ~props2=b, ~children=[foo, bar], ())` into
  `ReactDOMRe.createDOMElementVariadic("div", ReactDOMRe.domProps(~props1=1, ~props2=b), [|foo, bar|])`.
  transform the upper-cased case
  `[@JSX] Foo.createElement(~key=a, ~ref=b, ~foo=bar, ~children=[], ())` into
  `React.createElement(Foo.make, Foo.makeProps(~key=a, ~ref=b, ~foo=bar, ()))`
  transform the upper-cased case
  `[@JSX] Foo.createElement(~foo=bar, ~children=[foo, bar], ())` into
  `React.createElementVariadic(Foo.make, Foo.makeProps(~foo=bar, ~children=React.null, ()), [|foo, bar|])`
  transform `[@JSX] [foo]` into
  `ReactDOMRe.createElement(ReasonReact.fragment, [|foo|])`
*)

open Ast_helper
open Ast_mapper
open Asttypes
open Parsetree
open Longident

let rec find_opt p = function
  | [] -> None
  | x :: l -> if p x then Some x else find_opt p l


# 49 "syntax/reactjs_jsx_ppx.cppo.ml"
let nolabel = Nolabel
let labelled str = Labelled str
let optional str = Optional str
let isOptional str = match str with
| Optional _ -> true
| _ -> false
let isLabelled str = match str with
| Labelled _ -> true
| _ -> false
let getLabel str = match str with
| Optional str | Labelled str -> str
| Nolabel -> ""
let optionIdent = Lident "option"

let argIsKeyRef = function
  | (Labelled ("key" | "ref"), _) | (Optional ("key" | "ref"), _) -> true
  | _ -> false
let constantString ~loc str = Ast_helper.Exp.constant ~loc (Pconst_string (str, None))

# 84 "syntax/reactjs_jsx_ppx.cppo.ml"
let safeTypeFromValue valueStr =
let valueStr = getLabel valueStr in
match String.sub valueStr 0 1 with
| "_" -> "T" ^ valueStr
| _ -> valueStr
let keyType loc = Typ.constr ~loc {loc; txt=optionIdent} [Typ.constr ~loc {loc; txt=Lident "string"} []]

type 'a children = | ListLiteral of 'a | Exact of 'a
type componentConfig = {
  propsName: string;
}

(* if children is a list, convert it to an array while mapping each element. If not, just map over it, as usual *)
let transformChildrenIfListUpper ~loc ~mapper theList =
  let rec transformChildren_ theList accum =
    (* not in the sense of converting a list to an array; convert the AST
       reprensentation of a list to the AST reprensentation of an array *)
    match theList with
    | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> begin
      match accum with
      | [singleElement] -> Exact singleElement
      | accum -> ListLiteral (List.rev accum |> Exp.array ~loc)
      end
    | {pexp_desc = Pexp_construct (
        {txt = Lident "::"},
        Some {pexp_desc = Pexp_tuple (v::acc::[])}
      )} ->
      transformChildren_ acc ((mapper.expr mapper v)::accum)
    | notAList -> Exact (mapper.expr mapper notAList)
  in
  transformChildren_ theList []

let transformChildrenIfList ~loc ~mapper theList =
  let rec transformChildren_ theList accum =
    (* not in the sense of converting a list to an array; convert the AST
       reprensentation of a list to the AST reprensentation of an array *)
    match theList with
    | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} ->
      List.rev accum |> Exp.array ~loc
    | {pexp_desc = Pexp_construct (
        {txt = Lident "::"},
        Some {pexp_desc = Pexp_tuple (v::acc::[])}
      )} ->
      transformChildren_ acc ((mapper.expr mapper v)::accum)
    | notAList -> mapper.expr mapper notAList
  in
  transformChildren_ theList []

let extractChildren ?(removeLastPositionUnit=false) ~loc propsAndChildren =
  let rec allButLast_ lst acc = match lst with
    | [] -> []
    
# 136 "syntax/reactjs_jsx_ppx.cppo.ml"
    | (Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})::[] -> acc
    | (Nolabel, _)::rest -> raise (Invalid_argument "JSX: found non-labelled argument before the last position")
    
# 142 "syntax/reactjs_jsx_ppx.cppo.ml"
    | arg::rest -> allButLast_ rest (arg::acc)
  in
  let allButLast lst = allButLast_ lst [] |> List.rev in
  match (List.partition (fun (label, _) -> label = labelled "children") propsAndChildren) with
  | ([], props) ->
    (* no children provided? Place a placeholder list *)
    (Exp.construct ~loc {loc; txt = Lident "[]"} None, if removeLastPositionUnit then allButLast props else props)
  | ([(_, childrenExpr)], props) ->
    (childrenExpr, if removeLastPositionUnit then allButLast props else props)
  | _ -> raise (Invalid_argument "JSX: somehow there's more than one `children` label")

(* Helper method to look up the [@react.component] attribute *)
let hasAttr (loc, _) =
  loc.txt = "react.component"

(* Helper method to filter out any attribute that isn't [@react.component] *)
let otherAttrsPure (loc, _) =
  loc.txt <> "react.component"

(* Iterate over the attributes and try to find the [@react.component] attribute *)
let hasAttrOnBinding {pvb_attributes} = find_opt hasAttr pvb_attributes <> None

(* Filter the [@react.component] attribute and immutably replace them on the binding *)
let filterAttrOnBinding binding = {binding with pvb_attributes = List.filter otherAttrsPure binding.pvb_attributes}

(* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *)
let getFnName binding =
  match binding with
  | {pvb_pat = {
      ppat_desc = Ppat_var {txt}
    }} -> txt
  | _ -> raise (Invalid_argument "react.component calls cannot be destructured.")

(* Lookup the value of `props` otherwise raise Invalid_argument error *)
let getPropsNameValue _acc (loc, exp) =
    match (loc, exp) with
    | ({ txt = Lident "props" }, { pexp_desc = Pexp_ident {txt = Lident str} }) -> { propsName = str }
    | ({ txt }, _) -> raise (Invalid_argument ("react.component only accepts props as an option, given: " ^ Longident.last txt))

(* Lookup the `props` record or string as part of [@react.component] and store the name for use when rewriting *)
let getPropsAttr payload =
  let defaultProps = {propsName = "Props"} in
  match payload with
  | Some(PStr(
    {pstr_desc = Pstr_eval ({
      pexp_desc = Pexp_record (recordFields, None)
      }, _)}::_rest
      )) ->
      List.fold_left getPropsNameValue defaultProps recordFields
  | Some(PStr({pstr_desc = Pstr_eval ({pexp_desc = Pexp_ident {txt = Lident "props"}}, _)}::_rest)) -> {propsName = "props"}
  | Some(PStr({pstr_desc = Pstr_eval (_, _)}::_rest)) -> raise (Invalid_argument ("react.component accepts a record config with props as an options."))
  | _ -> defaultProps

(* Plucks the label, loc, and type_ from an AST node *)
let pluckLabelDefaultLocType (label, default, _, _, loc, type_) = (label, default, loc, type_)

(* Lookup the filename from the location information on the AST node and turn it into a valid module identifier *)
let filenameFromLoc (pstr_loc: Location.t) =
  let fileName = match pstr_loc.loc_start.pos_fname with
  | "" -> !Location.input_name
  | fileName -> fileName
  in
  let fileName = try
      Filename.chop_extension (Filename.basename fileName)
    with | Invalid_argument _-> fileName in
  
# 208 "syntax/reactjs_jsx_ppx.cppo.ml"
  let fileName = String.capitalize_ascii fileName in
  
# 212 "syntax/reactjs_jsx_ppx.cppo.ml"
  fileName

(* Build a string representation of a module name with segments separated by $ *)
let makeModuleName fileName nestedModules fnName =
  let fullModuleName = match (fileName, nestedModules, fnName) with
  (* TODO: is this even reachable? It seems like the fileName always exists *)
  | ("", nestedModules, "make") -> nestedModules
  | ("", nestedModules, fnName) -> List.rev (fnName :: nestedModules)
  | (fileName, nestedModules, "make") -> fileName :: (List.rev nestedModules)
  | (fileName, nestedModules, fnName) -> fileName :: (List.rev (fnName :: nestedModules))
  in
  let fullModuleName = String.concat "$" fullModuleName in
  fullModuleName

(*
  AST node builders
  These functions help us build AST nodes that are needed when transforming a [@react.component] into a
  constructor and a props external
*)

(* Build an AST node representing all named args for the `external` definition for a component's props *)
let rec recursivelyMakeNamedArgsForExternal list args =
  match list with
  | (label, default, loc, interiorType)::tl ->
    recursivelyMakeNamedArgsForExternal tl (Typ.arrow
    ~loc
    label
    (match (label, interiorType, default) with
    (* ~foo=1 *)
    | (label, None, Some _) ->
    
# 243 "syntax/reactjs_jsx_ppx.cppo.ml"
    {
      ptyp_desc = Ptyp_var (safeTypeFromValue label);
      ptyp_loc = loc;
      ptyp_attributes = [];
    }
    
# 259 "syntax/reactjs_jsx_ppx.cppo.ml"
    (* ~foo: int=1 *)
    | (label, Some type_, Some _) ->
    
# 262 "syntax/reactjs_jsx_ppx.cppo.ml"
    type_
    
# 269 "syntax/reactjs_jsx_ppx.cppo.ml"
    (* ~foo: option(int)=? *)
    | (label, Some ({ptyp_desc = Ptyp_constr ({txt=(Lident "option")}, [type_])}), _)
    | (label, Some ({ptyp_desc = Ptyp_constr ({txt=(Ldot (Lident "*predef*", "option"))}, [type_])}), _)
    (* ~foo: int=? - note this isnt valid. but we want to get a type error *)
    | (label, Some type_, _) when isOptional label ->
    
# 275 "syntax/reactjs_jsx_ppx.cppo.ml"
    type_
    
# 282 "syntax/reactjs_jsx_ppx.cppo.ml"
    (* ~foo=? *)
    | (label, None, _) when isOptional label ->
    
# 285 "syntax/reactjs_jsx_ppx.cppo.ml"
    {
      ptyp_desc = Ptyp_var (safeTypeFromValue label);
      ptyp_loc = loc;
      ptyp_attributes = [];
    }
    
# 301 "syntax/reactjs_jsx_ppx.cppo.ml"
    (* ~foo *)
    | (label, None, _) ->
    {
      ptyp_desc = Ptyp_var (safeTypeFromValue label);
      ptyp_loc = loc;
      ptyp_attributes = [];
    }
    | (label, Some type_, _) ->
    type_
    )
    args)
  | [] -> args

(* Build an AST node for the [@bs.obj] representing props for a component *)
let makePropsValue fnName loc namedArgListWithKeyAndRef propsType =
  let propsName = fnName ^ "Props" in {
  pval_name = {txt = propsName; loc};
  pval_type =
      recursivelyMakeNamedArgsForExternal
        namedArgListWithKeyAndRef
        (Typ.arrow
          nolabel
          {
            ptyp_desc = Ptyp_constr ({txt= Lident("unit"); loc}, []);
            ptyp_loc = loc;
            ptyp_attributes = [];
          }
          propsType
        );
  pval_prim = [""];
  pval_attributes = [({txt = "bs.obj"; loc = loc}, PStr [])];
  pval_loc = loc;
}

(* Build an AST node representing an `external` with the definition of the [@bs.obj] *)
let makePropsExternal fnName loc namedArgListWithKeyAndRef propsType =
  {
    pstr_loc = loc;
    pstr_desc = Pstr_primitive (makePropsValue fnName loc namedArgListWithKeyAndRef propsType)
  }

(* Build an AST node for the signature of the `external` definition *)
let makePropsExternalSig fnName loc namedArgListWithKeyAndRef propsType =
  {
    psig_loc = loc;
    psig_desc = Psig_value (makePropsValue fnName loc namedArgListWithKeyAndRef propsType)
  }

(* Build an AST node for the props name when converted to a Js.t inside the function signature  *)
let makePropsName ~loc name =
  {
    ppat_desc = Ppat_var {txt = name; loc};
    ppat_loc = loc;
    ppat_attributes = [];
  }

# 358 "syntax/reactjs_jsx_ppx.cppo.ml"
let makeObjectField loc (str, _attrs, type_) =
  (* intentionally not using attrs - they probably don't work on object fields. use on *Props instead *)
  Otag ({ loc; txt = str }, [], {type_ with ptyp_attributes = []})

# 363 "syntax/reactjs_jsx_ppx.cppo.ml"
(* Build an AST node representing a "closed" Js.t object representing a component's props *)
let makePropsType ~loc namedTypeList =
  Typ.mk ~loc (
    Ptyp_constr({txt= Ldot (Lident("Js"), "t"); loc}, [{
        
# 368 "syntax/reactjs_jsx_ppx.cppo.ml"
        ptyp_desc = Ptyp_object(
          List.map (makeObjectField loc) namedTypeList,
          Closed
        );
        
# 375 "syntax/reactjs_jsx_ppx.cppo.ml"
        ptyp_loc = loc;
        ptyp_attributes = [];
      }])
    )

(* Builds an AST node for the entire `external` definition of props *)
let makeExternalDecl fnName loc namedArgListWithKeyAndRef namedTypeList =
  makePropsExternal
    fnName
    loc
    (List.map pluckLabelDefaultLocType namedArgListWithKeyAndRef)
    (makePropsType ~loc namedTypeList)

(* TODO: some line number might still be wrong *)
let jsxMapper () =

  let jsxVersion = ref None in

  let transformUppercaseCall3 modulePath mapper loc attrs _ callArguments =
    let (children, argsWithLabels) = extractChildren ~loc ~removeLastPositionUnit:true callArguments in
    let argsForMake = argsWithLabels in
    let childrenExpr = transformChildrenIfListUpper ~loc ~mapper children in
    let recursivelyTransformedArgsForMake = argsForMake |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression)) in
    let childrenArg = ref None in
    let args = recursivelyTransformedArgsForMake
      @ (match childrenExpr with
        | Exact children -> [(labelled "children", children)]
        | ListLiteral ({ pexp_desc = Pexp_array list }) when list = [] -> []
        | ListLiteral expression ->
        (* this is a hack to support react components that introspect into their children *)
        (childrenArg := Some expression;
        [(labelled "children", Exp.ident ~loc {loc; txt = Ldot (Lident "React", "null")})]))
      @ [(nolabel, Exp.construct ~loc {loc; txt = Lident "()"} None)] in
    let isCap str = let first = String.sub str 0 1 in
    
# 410 "syntax/reactjs_jsx_ppx.cppo.ml"
    let capped = String.uppercase_ascii first in first = capped in
    
# 414 "syntax/reactjs_jsx_ppx.cppo.ml"
    let ident = match modulePath with
    | Lident _ -> Ldot (modulePath, "make")
    | (Ldot (_modulePath, value) as fullPath) when isCap value -> Ldot (fullPath, "make")
    | modulePath -> modulePath in
    let propsIdent = match ident with
    | Lident path -> Lident (path ^ "Props")
    | Ldot(ident, path) -> Ldot (ident, path ^ "Props")
    | _ -> raise (Invalid_argument "JSX name can't be the result of function applications") in
    let props =
    Exp.apply ~attrs ~loc (Exp.ident ~loc {loc; txt = propsIdent}) args in
    (* handle key, ref, children *)
      (* React.createElement(Component.make, props, ...children) *)
    match (!childrenArg) with
    | None ->
      (Exp.apply
        ~loc
        ~attrs
        (Exp.ident ~loc {loc; txt = Ldot (Lident "React", "createElement")})
        ([
          (nolabel, Exp.ident ~loc {txt = ident; loc});
          (nolabel, props)
        ]))
     | Some children ->
       (Exp.apply
         ~loc
         ~attrs
         (Exp.ident ~loc {loc; txt = Ldot (Lident "React", "createElementVariadic")})
         ([
           (nolabel, Exp.ident ~loc {txt = ident; loc});
           (nolabel, props);
           (nolabel, children)
         ]))
     in

    let transformLowercaseCall3 mapper loc attrs callArguments id =
      let (children, nonChildrenProps) = extractChildren ~loc callArguments in
      let componentNameExpr = constantString ~loc id in
      let childrenExpr = transformChildrenIfList ~loc ~mapper children in
      let createElementCall = match children with
        (* [@JSX] div(~children=[a]), coming from <div> a </div> *)
        | {
            pexp_desc =
             Pexp_construct ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple _ })
             | Pexp_construct ({txt = Lident "[]"}, None)
          } -> "createDOMElementVariadic"
        (* [@JSX] div(~children= value), coming from <div> ...(value) </div> *)
        | _ -> raise (Invalid_argument "A spread as a DOM element's \
          children don't make sense written together. You can simply remove the spread.")
      in
      let args = match nonChildrenProps with
        | [_justTheUnitArgumentAtEnd] ->
          [
            (* "div" *)
            (nolabel, componentNameExpr);
            (* [|moreCreateElementCallsHere|] *)
            (nolabel, childrenExpr)
          ]
        | nonEmptyProps ->
          let propsCall =
            Exp.apply
              ~loc
              (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", "domProps")})
              (nonEmptyProps |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression)))
          in
          [
            (* "div" *)
            (nolabel, componentNameExpr);
            (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *)
            (labelled "props", propsCall);
            (* [|moreCreateElementCallsHere|] *)
            (nolabel, childrenExpr)
          ] in
      Exp.apply
        ~loc
        (* throw away the [@JSX] attribute and keep the others, if any *)
        ~attrs
        (* ReactDOMRe.createElement *)
        (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", createElementCall)})
        args
    in

  let transformUppercaseCall modulePath mapper loc attrs _ callArguments =
    let (children, argsWithLabels) = extractChildren ~loc ~removeLastPositionUnit:true callArguments in
    let (argsKeyRef, argsForMake) = List.partition argIsKeyRef argsWithLabels in
    let childrenExpr = transformChildrenIfList ~loc ~mapper children in
    let recursivelyTransformedArgsForMake = argsForMake |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression)) in
    let args = recursivelyTransformedArgsForMake @ [ (nolabel, childrenExpr) ] in
    let wrapWithReasonReactElement e = (* ReasonReact.element(~key, ~ref, ...) *)
      Exp.apply
        ~loc
        (Exp.ident ~loc {loc; txt = Ldot (Lident "ReasonReact", "element")})
        (argsKeyRef @ [(nolabel, e)]) in
    Exp.apply
      ~loc
      ~attrs
      (* Foo.make *)
      (Exp.ident ~loc {loc; txt = Ldot (modulePath, "make")})
      args
    |> wrapWithReasonReactElement in

  let transformLowercaseCall mapper loc attrs callArguments id =
    let (children, nonChildrenProps) = extractChildren ~loc callArguments in
    let componentNameExpr = constantString ~loc id in
    let childrenExpr = transformChildrenIfList ~loc ~mapper children in
    let createElementCall = match children with
      (* [@JSX] div(~children=[a]), coming from <div> a </div> *)
      | {
          pexp_desc =
           Pexp_construct ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple _ })
           | Pexp_construct ({txt = Lident "[]"}, None)
        } -> "createElement"
      (* [@JSX] div(~children=[|a|]), coming from <div> ...[|a|] </div> *)
      | { pexp_desc = (Pexp_array _) } ->
        raise (Invalid_argument "A spread + an array literal as a DOM element's \
          children would cancel each other out, and thus don't make sense written \
          together. You can simply remove the spread and the array literal.")
      (* [@JSX] div(~children= <div />), coming from <div> ...<div/> </div> *)
      | {
          pexp_attributes
        } when pexp_attributes |> List.exists (fun (attribute, _) -> attribute.txt = "JSX") ->
        raise (Invalid_argument "A spread + a JSX literal as a DOM element's \
          children don't make sense written together. You can simply remove the spread.")
      | _ -> "createElementVariadic"
    in
    let args = match nonChildrenProps with
      | [_justTheUnitArgumentAtEnd] ->
        [
          (* "div" *)
          (nolabel, componentNameExpr);
          (* [|moreCreateElementCallsHere|] *)
          (nolabel, childrenExpr)
        ]
      | nonEmptyProps ->
        let propsCall =
          Exp.apply
            ~loc
            (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", "props")})
            (nonEmptyProps |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression)))
        in
        [
          (* "div" *)
          (nolabel, componentNameExpr);
          (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *)
          (labelled "props", propsCall);
          (* [|moreCreateElementCallsHere|] *)
          (nolabel, childrenExpr)
        ] in
    Exp.apply
      ~loc
      (* throw away the [@JSX] attribute and keep the others, if any *)
      ~attrs
      (* ReactDOMRe.createElement *)
      (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", createElementCall)})
      args
  in

  let rec recursivelyTransformNamedArgsForMake mapper expr list =
    let expr = mapper.expr mapper expr in
    match expr.pexp_desc with
    (* TODO: make this show up with a loc. *)
    
# 575 "syntax/reactjs_jsx_ppx.cppo.ml"
    | Pexp_fun (Labelled "key", _, _, _)
    | Pexp_fun (Optional "key", _, _, _) -> raise (Invalid_argument "Key cannot be accessed inside of a component. Don't worry - you can always key a component from its parent!")
    | Pexp_fun (Labelled "ref", _, _, _)
    | Pexp_fun (Optional "ref", _, _, _) -> raise (Invalid_argument "Ref cannot be passed as a normal prop. Please use `forwardRef` API instead.")
    
# 585 "syntax/reactjs_jsx_ppx.cppo.ml"
    | Pexp_fun (arg, default, pattern, expression) when isOptional arg || isLabelled arg ->
      let alias = (match pattern with
      | {ppat_desc = Ppat_alias (_, {txt}) | Ppat_var {txt}} -> txt
      | {ppat_desc = Ppat_any} -> "_"
      | _ -> getLabel arg) in
      let type_ = (match pattern with
      | {ppat_desc = Ppat_constraint (_, type_)} -> Some type_
      | _ -> None) in

      recursivelyTransformNamedArgsForMake mapper expression ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: list)
    
# 596 "syntax/reactjs_jsx_ppx.cppo.ml"
    | Pexp_fun (Nolabel, _, { ppat_desc = (Ppat_construct ({txt = Lident "()"}, _) | Ppat_any)}, expression) ->
        (expression.pexp_desc, list, None)
    | Pexp_fun (Nolabel, _, { ppat_desc = Ppat_var ({txt})}, expression) ->
        (expression.pexp_desc, list, Some txt)
    
# 606 "syntax/reactjs_jsx_ppx.cppo.ml"
    | innerExpression -> (innerExpression, list, None)
  in


  let argToType types (name, default, _noLabelName, _alias, loc, type_) = match (type_, name, default) with
    | (Some ({ptyp_desc = Ptyp_constr ({txt=(Lident "option")}, [type_])}), name, _) when isOptional name ->
      (getLabel name, [], {
        type_ with
        ptyp_desc = Ptyp_constr ({loc=type_.ptyp_loc; txt=optionIdent}, [type_]);
      }) :: types
    | (Some type_, name, Some _default) ->
      (getLabel name, [], {
      ptyp_desc = Ptyp_constr ({loc; txt=optionIdent}, [type_]);
      ptyp_loc = loc;
      ptyp_attributes = [];
      }) :: types
    | (Some type_, name, _) ->
      (getLabel name, [], type_) :: types
    | (None, name, _) when isOptional name ->
      (getLabel name, [], {
        ptyp_desc = Ptyp_constr ({loc; txt=optionIdent}, [{
          ptyp_desc = Ptyp_var (safeTypeFromValue name);
          ptyp_loc = loc;
          ptyp_attributes = [];
        }]);
        ptyp_loc = loc;
        ptyp_attributes = [];
        }) :: types
    | (None, name, _) when isLabelled name ->
      (getLabel name, [], {
        ptyp_desc = Ptyp_var (safeTypeFromValue name);
        ptyp_loc = loc;
        ptyp_attributes = [];
        }) :: types
    | _ -> types
  in

  let argToConcreteType types (name, loc, type_) = match name with
    | name when isLabelled name ->
    (getLabel name, [], type_) :: types
    | name when isOptional name ->
  
# 648 "syntax/reactjs_jsx_ppx.cppo.ml"
  (getLabel name, [], Typ.constr ~loc {loc; txt=optionIdent} [type_]) :: types
    
# 652 "syntax/reactjs_jsx_ppx.cppo.ml"
    | _ -> types
  in

  let nestedModules = ref([]) in
  let transformComponentDefinition mapper structure returnStructures = match structure with
  (* external *)
  | ({
      pstr_loc;
      pstr_desc = Pstr_primitive ({
        pval_name = { txt = fnName };
        pval_attributes;
        pval_type;
      } as value_description)
    } as pstr) ->
    (match List.filter hasAttr pval_attributes with
    | [] -> structure :: returnStructures
    | [_] ->
    let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) =
      (match ptyp_desc with
      | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) when isLabelled name || isOptional name ->
        getPropTypes ((name, ptyp_loc, type_)::types) rest
      
# 674 "syntax/reactjs_jsx_ppx.cppo.ml"
      | Ptyp_arrow (Nolabel, _type, rest) ->
        
# 678 "syntax/reactjs_jsx_ppx.cppo.ml"
        getPropTypes types rest
      | Ptyp_arrow (name, type_, returnValue) when isLabelled name || isOptional name ->
        (returnValue, (name, returnValue.ptyp_loc, type_)::types)
      | _ -> (fullType, types))
    in
    let (innerType, propTypes) = getPropTypes [] pval_type in
    let namedTypeList = List.fold_left argToConcreteType [] propTypes in
    let pluckLabelAndLoc (label, loc, type_) = (label, None (* default *), loc, Some type_) in
    let retPropsType = makePropsType ~loc:pstr_loc namedTypeList in
    let externalPropsDecl = makePropsExternal fnName pstr_loc ((
      optional "key",
      None,
      pstr_loc,
      Some(keyType pstr_loc)
    ) :: List.map pluckLabelAndLoc propTypes) retPropsType in
    (* can't be an arrow because it will defensively uncurry *)
    let newExternalType = Ptyp_constr (
      {loc = pstr_loc; txt = Ldot ((Lident "React"), "componentLike")},
      [retPropsType; innerType]
    ) in
    let newStructure = {
      pstr with pstr_desc = Pstr_primitive {
        value_description with pval_type = {
          pval_type with ptyp_desc = newExternalType;
        };
        pval_attributes = List.filter otherAttrsPure pval_attributes;
      }
    } in
    externalPropsDecl :: newStructure :: returnStructures
    | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time"))
  (* let component = ... *)
  | {
      pstr_loc;
      pstr_desc = Pstr_value (
        recFlag,
        valueBindings
      )
    } ->
      let mapBinding binding = if (hasAttrOnBinding binding) then
        let fnName = getFnName binding in
        let fileName = filenameFromLoc pstr_loc in
        let fullModuleName = makeModuleName fileName !nestedModules fnName in
        let emptyLoc = Location.in_file fileName in
        let modifiedBinding binding =
          let expression = binding.pvb_expr in
          let wrapExpressionWithBinding expressionFn expression = {(filterAttrOnBinding binding) with pvb_expr = expressionFn expression} in
          (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *)
          let rec spelunkForFunExpression expression = (match expression with
          (* let make = (~prop) => ... *)
          | {
            pexp_desc = Pexp_fun _
          } -> ((fun expressionDesc -> {expression with pexp_desc = expressionDesc}), expression)
          (* let make = {let foo = bar in (~prop) => ...} *)
          | {
              pexp_desc = Pexp_let (recursive, vbs, returnExpression)
            } ->
            (* here's where we spelunk! *)
            let (wrapExpression, realReturnExpression) = spelunkForFunExpression returnExpression in
            ((fun expressionDesc -> {expression with pexp_desc = Pexp_let (recursive, vbs, wrapExpression expressionDesc)}), realReturnExpression)
          (* let make = React.forwardRef((~prop) => ...) *)
          
# 739 "syntax/reactjs_jsx_ppx.cppo.ml"
          | { pexp_desc = Pexp_apply (wrapperExpression, [(Nolabel, innerFunctionExpression)]) } ->
            
# 743 "syntax/reactjs_jsx_ppx.cppo.ml"
            let (wrapExpression, realReturnExpression) = spelunkForFunExpression innerFunctionExpression in
            ((fun expressionDesc -> {
              expression with pexp_desc =
                Pexp_apply (wrapperExpression, [(nolabel, wrapExpression expressionDesc)])
              }),
              realReturnExpression
            )
          | {
              pexp_desc = Pexp_sequence (wrapperExpression, innerFunctionExpression)
            } ->
            let (wrapExpression, realReturnExpression) = spelunkForFunExpression innerFunctionExpression in
            ((fun expressionDesc -> {
              expression with pexp_desc =
                Pexp_sequence (wrapperExpression, wrapExpression expressionDesc)
              }),
              realReturnExpression
            )
          | _ -> raise (Invalid_argument "react.component calls can only be on function definitions or component wrappers (forwardRef, memo).")
          ) in
          let (wrapExpression, expression) = spelunkForFunExpression expression in
          (wrapExpressionWithBinding wrapExpression, expression)
        in
        let (bindingWrapper, expression) = modifiedBinding binding in
        let reactComponentAttribute = try
          Some(List.find hasAttr binding.pvb_attributes)
        with | Not_found -> None in
        let (attr_loc, payload) = match reactComponentAttribute with
        | Some (loc, payload) -> (loc.loc, Some payload)
        | None -> (emptyLoc, None) in
        let props = getPropsAttr payload in
        (* do stuff here! *)
        let (innerFunctionExpression, namedArgList, forwardRef) = recursivelyTransformNamedArgsForMake mapper expression [] in
        let namedArgListWithKeyAndRef = (optional("key"), None, Pat.var {txt = "key"; loc = emptyLoc}, "key", emptyLoc, Some(keyType emptyLoc)) :: namedArgList in
        let namedArgListWithKeyAndRef = match forwardRef with
        | Some(_) ->  (optional("ref"), None, Pat.var {txt = "key"; loc = emptyLoc}, "ref", emptyLoc, None) :: namedArgListWithKeyAndRef
        | None -> namedArgListWithKeyAndRef
        in
        let namedTypeList = List.fold_left argToType [] namedArgList in
        let externalDecl = makeExternalDecl fnName attr_loc namedArgListWithKeyAndRef namedTypeList in
        let makeLet innerExpression (label, default, pattern, _alias, loc, _type) =
          let labelString = (match label with | label when isOptional label || isLabelled label -> getLabel label | _ -> raise (Invalid_argument "This should never happen")) in
          let expression = (Exp.apply ~loc
            (Exp.ident ~loc {txt = (Lident "##"); loc })
            [
              (nolabel, Exp.ident ~loc {txt = (Lident props.propsName); loc });
              (nolabel, Exp.ident ~loc {
                txt = (Lident labelString);
                loc
              })
            ]
          ) in
          let expression = match (default) with
          | (Some default) -> Exp.match_ expression [
            Exp.case
              (Pat.construct {loc; txt=Lident "Some"} (Some (Pat.var ~loc {txt = labelString; loc})))
              (Exp.ident ~loc {txt = (Lident labelString); loc = { loc with Location.loc_ghost = true }});
            Exp.case
              (Pat.construct {loc; txt=Lident "None"} None)
              default
          ]
          | None -> expression in
          let letExpression = Vb.mk
            pattern
            expression in
          Exp.let_ ~loc Nonrecursive [letExpression] innerExpression in
        let innerExpression = List.fold_left makeLet (Exp.mk innerFunctionExpression) namedArgList in
        let innerExpressionWithRef = match (forwardRef) with
        | Some txt ->
          {innerExpression with pexp_desc = Pexp_fun (nolabel, None, {
            ppat_desc = Ppat_var { txt; loc = emptyLoc };
            ppat_loc = emptyLoc;
            ppat_attributes = [];
          }, innerExpression)}
        | None -> innerExpression
        in
        let fullExpression = (Pexp_fun (
          nolabel,
          None,
          {
            ppat_desc = Ppat_constraint (
              makePropsName ~loc:emptyLoc props.propsName,
              makePropsType ~loc:emptyLoc namedTypeList
            );
            ppat_loc = emptyLoc;
            ppat_attributes = [];
          },
          innerExpressionWithRef
        )) in
        let fullExpression = match (fullModuleName) with
        | ("") -> fullExpression
        | (txt) -> Pexp_let (
            Nonrecursive,
            [Vb.mk
              ~loc:emptyLoc
              (Pat.var ~loc:emptyLoc {loc = emptyLoc; txt})
              (Exp.mk ~loc:emptyLoc fullExpression)
            ],
            (Exp.ident ~loc:emptyLoc {loc = emptyLoc; txt = Lident txt})
          )
        in
        let newBinding = bindingWrapper fullExpression in
        (Some externalDecl, newBinding)
      else
        (None, binding)
      in
      let structuresAndBinding = List.map mapBinding valueBindings in
      let otherStructures (extern, binding) (externs, bindings) =
        let externs = match extern with
        | Some extern -> extern :: externs
        | None -> externs in
        (externs, binding :: bindings)
      in
      let (externs, bindings) = List.fold_right otherStructures structuresAndBinding ([], []) in
      externs @ {
        pstr_loc;
        pstr_desc = Pstr_value (
          recFlag,
          bindings
        )
      } :: returnStructures
    | structure -> structure :: returnStructures in

  let reactComponentTransform mapper structures =
  List.fold_right (transformComponentDefinition mapper) structures [] in

  let transformComponentSignature _mapper signature returnSignatures = match signature with
  | ({
      psig_loc;
      psig_desc = Psig_value ({
        pval_name = { txt = fnName };
        pval_attributes;
        pval_type;
      } as psig_desc)
    } as psig) ->
    (match List.filter hasAttr pval_attributes with
    | [] -> signature :: returnSignatures
    | [_] ->
    let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) =
      (match ptyp_desc with
      | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) when isOptional name || isLabelled name ->
        getPropTypes ((name, ptyp_loc, type_)::types) rest
      
# 885 "syntax/reactjs_jsx_ppx.cppo.ml"
      | Ptyp_arrow (Nolabel, _type, rest) ->
        
# 889 "syntax/reactjs_jsx_ppx.cppo.ml"
        getPropTypes types rest
      | Ptyp_arrow (name, type_, returnValue) when isOptional name || isLabelled name ->
        (returnValue, (name, returnValue.ptyp_loc, type_)::types)
      | _ -> (fullType, types))
    in
    let (innerType, propTypes) = getPropTypes [] pval_type in
    let namedTypeList = List.fold_left argToConcreteType [] propTypes in
    let pluckLabelAndLoc (label, loc, type_) = (label, None, loc, Some type_) in
    let retPropsType = makePropsType ~loc:psig_loc namedTypeList in
    let externalPropsDecl = makePropsExternalSig fnName psig_loc ((
      optional "key",
      None,
      psig_loc,
      Some(keyType psig_loc)
    ) :: List.map pluckLabelAndLoc propTypes) retPropsType in
        (* can't be an arrow because it will defensively uncurry *)
    let newExternalType = Ptyp_constr (
      {loc = psig_loc; txt = Ldot ((Lident "React"), "componentLike")},
      [retPropsType; innerType]
    ) in
    let newStructure = {
      psig with psig_desc = Psig_value {
        psig_desc with pval_type = {
          pval_type with ptyp_desc = newExternalType;
        };
        pval_attributes = List.filter otherAttrsPure pval_attributes;
      }
    } in
    externalPropsDecl :: newStructure :: returnSignatures
    | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time"))
  | signature -> signature :: returnSignatures in

  let reactComponentSignatureTransform mapper signatures =
  List.fold_right (transformComponentSignature mapper) signatures [] in


  let transformJsxCall mapper callExpression callArguments attrs =
    (match callExpression.pexp_desc with
     | Pexp_ident caller ->
       (match caller with
        | {txt = Lident "createElement"} ->
          raise (Invalid_argument "JSX: `createElement` should be preceeded by a module name.")

        (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *)
        | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} ->
          (match !jsxVersion with
          
# 939 "syntax/reactjs_jsx_ppx.cppo.ml"
          | Some 2 -> transformUppercaseCall modulePath mapper loc attrs callExpression callArguments
          | None
          
# 942 "syntax/reactjs_jsx_ppx.cppo.ml"
          | Some 3 -> transformUppercaseCall3 modulePath mapper loc attrs callExpression callArguments
          | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 2 or 3"))

        (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *)
        (* turn that into
          ReactDOMRe.createElement(~props=ReactDOMRe.props(~props1=foo, ~props2=bar, ()), [|bla|]) *)
        | {loc; txt = Lident id} ->
          (match !jsxVersion with
          
# 954 "syntax/reactjs_jsx_ppx.cppo.ml"
          | Some 2 -> transformLowercaseCall mapper loc attrs callArguments id
          | None
          
# 957 "syntax/reactjs_jsx_ppx.cppo.ml"
          | Some 3 -> transformLowercaseCall3 mapper loc attrs callArguments id
          | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 2 or 3"))

        | {txt = Ldot (_, anythingNotCreateElementOrMake)} ->
          raise (
            Invalid_argument
              ("JSX: the JSX attribute should be attached to a `YourModuleName.createElement` or `YourModuleName.make` call. We saw `"
               ^ anythingNotCreateElementOrMake
               ^ "` instead"
              )
          )

        | {txt = Lapply _} ->
          (* don't think there's ever a case where this is reached *)
          raise (
            Invalid_argument "JSX: encountered a weird case while processing the code. Please report this!"
          )
       )
     | _ ->
       raise (
         Invalid_argument "JSX: `createElement` should be preceeded by a simple, direct module name."
       )
    ) in

  let signature =
    (fun mapper signature -> default_mapper.signature mapper @@ reactComponentSignatureTransform mapper signature) in

  let structure =
    (fun mapper structure -> match structure with
      (*
        match against [@bs.config {foo, jsx: ...}] at the file-level. This
        indicates which version of JSX we're using. This code stays here because
        we used to have 2 versions of JSX PPX (and likely will again in the
        future when JSX PPX changes). So the architecture for switching between
        JSX behavior stayed here. To create a new JSX ppx, copy paste this
        entire file and change the relevant parts.
        Description of architecture: in bucklescript's bsconfig.json, you can
        specify a project-wide JSX version. You can also specify a file-level
        JSX version. This degree of freedom allows a person to convert a project
        one file at time onto the new JSX, when it was released. It also enabled
        a project to depend on a third-party which is still using an old version
        of JSX
      *)
      | ({
          pstr_desc = Pstr_attribute (
            {txt = "ocaml.ppx.context"} ,
            _
          )
        }::
        {
          pstr_loc;
          pstr_desc = Pstr_attribute (
            ({txt = "bs.config"} as bsConfigLabel),
            PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (recordFields, b)} as innerConfigRecord, a)} as configRecord]
          )
        }
        ::restOfStructure ) | ({
          pstr_loc;
          pstr_desc = Pstr_attribute (
            ({txt = "bs.config"} as bsConfigLabel),
            PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (recordFields, b)} as innerConfigRecord, a)} as configRecord]
          )
        }::restOfStructure) -> begin
          let (jsxField, recordFieldsWithoutJsx) = recordFields |> List.partition (fun ({txt}, _) -> txt = Lident "jsx") in
          match (jsxField, recordFieldsWithoutJsx) with
          (* no file-level jsx config found *)
          | ([], _) -> default_mapper.structure mapper structure
          (* {jsx: 2} *)
          
# 1026 "syntax/reactjs_jsx_ppx.cppo.ml"
          | ((_, {pexp_desc = Pexp_constant (Pconst_integer (version, None))})::rest, recordFieldsWithoutJsx) -> begin
              
# 1030 "syntax/reactjs_jsx_ppx.cppo.ml"
              (match version with
              
# 1032 "syntax/reactjs_jsx_ppx.cppo.ml"
              | "2" -> jsxVersion := Some 2
              | "3" -> jsxVersion := Some 3
              
# 1038 "syntax/reactjs_jsx_ppx.cppo.ml"
              | _ -> raise (Invalid_argument "JSX: the file-level bs.config's jsx version must be 2 or 3"));
              match recordFieldsWithoutJsx with
              (* record empty now, remove the whole bs.config attribute *)
              | [] -> default_mapper.structure mapper @@ reactComponentTransform mapper restOfStructure
              | fields -> default_mapper.structure mapper ({
                pstr_loc;
                pstr_desc = Pstr_attribute (
                  bsConfigLabel,
                  PStr [{configRecord with pstr_desc = Pstr_eval ({innerConfigRecord with pexp_desc = Pexp_record (fields, b)}, a)}]
                )
              }::(reactComponentTransform mapper restOfStructure))
            end
        | _ -> raise (Invalid_argument "JSX: the file-level bs.config's {jsx: ...} config accepts only a version number")
      end
      | structures -> begin
        default_mapper.structure mapper @@ reactComponentTransform mapper structures
      end
    ) in

  let expr =
    (fun mapper expression -> match expression with
       (* Does the function application have the @JSX attribute? *)
       | {
           pexp_desc = Pexp_apply (callExpression, callArguments);
           pexp_attributes
         } ->
         let (jsxAttribute, nonJSXAttributes) = List.partition (fun (attribute, _) -> attribute.txt = "JSX") pexp_attributes in
         (match (jsxAttribute, nonJSXAttributes) with
         (* no JSX attribute *)
         | ([], _) -> default_mapper.expr mapper expression
         | (_, nonJSXAttributes) -> transformJsxCall mapper callExpression callArguments nonJSXAttributes)

       (* is it a list with jsx attribute? Reason <>foo</> desugars to [@JSX][foo]*)
       | {
           pexp_desc =
            Pexp_construct ({txt = Lident "::"; loc}, Some {pexp_desc = Pexp_tuple _})
            | Pexp_construct ({txt = Lident "[]"; loc}, None);
           pexp_attributes
         } as listItems ->
          let (jsxAttribute, nonJSXAttributes) = List.partition (fun (attribute, _) -> attribute.txt = "JSX") pexp_attributes in
          (match (jsxAttribute, nonJSXAttributes) with
          (* no JSX attribute *)
          | ([], _) -> default_mapper.expr mapper expression
          | (_, nonJSXAttributes) ->
            let fragment = Exp.ident ~loc {loc; txt = Ldot (Lident "ReasonReact", "fragment")} in
            let childrenExpr = transformChildrenIfList ~loc ~mapper listItems in
            let args = [
              (* "div" *)
              (nolabel, fragment);
              (* [|moreCreateElementCallsHere|] *)
              (nolabel, childrenExpr)
            ] in
            Exp.apply
              ~loc
              (* throw away the [@JSX] attribute and keep the others, if any *)
              ~attrs:nonJSXAttributes
              (* ReactDOMRe.createElement *)
              (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", "createElement")})
              args
         )
       (* Delegate to the default mapper, a deep identity traversal *)
       | e -> default_mapper.expr mapper e) in

  let module_binding =
    (fun mapper module_binding ->
      let _ = nestedModules := module_binding.pmb_name.txt :: !nestedModules in
      let mapped = default_mapper.module_binding mapper module_binding in
      let _ = nestedModules := List.tl !nestedModules in
      mapped
    ) in

  { default_mapper with structure; expr; signature; module_binding; }

let rewrite_implementation (code: Parsetree.structure) : Parsetree.structure =
  let mapper = jsxMapper () in
  mapper.structure mapper code
let rewrite_signature (code : Parsetree.signature) : Parsetree.signature =
  let mapper = jsxMapper () in
  mapper.signature mapper code


end
module Ppx_entry
= struct
#1 "ppx_entry.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


let rewrite_signature (ast : Parsetree.signature) : Parsetree.signature =  
  let ast = 
    match !Js_config.jsx_version with
    | 2 -> Reactjs_jsx_ppx_v2.rewrite_signature ast 
    | 3 -> Reactjs_jsx_ppx_v3.rewrite_signature ast 
    | _ -> ast 
    (* react-jsx ppx relies on built-in ones like `##` *)
  in 

  if !Js_config.no_builtin_ppx_mli then ast else 
    Bs_builtin_ppx.rewrite_signature ast 

let rewrite_implementation (ast : Parsetree.structure) : Parsetree.structure =   
  let ast = 
    match !Js_config.jsx_version with 
    | 2 -> Reactjs_jsx_ppx_v2.rewrite_implementation ast 
    | 3 -> Reactjs_jsx_ppx_v3.rewrite_implementation ast 
    | _ -> ast 
  in 
  if !Js_config.no_builtin_ppx_ml then ast else
  begin
    Bs_builtin_ppx.rewrite_implementation ast 
  end
  
end
module Printast : sig 
#1 "printast.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*              Damien Doligez, projet Para, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Parsetree;;
open Format;;

val interface : formatter -> signature_item list -> unit;;
val implementation : formatter -> structure_item list -> unit;;
val top_phrase : formatter -> toplevel_phrase -> unit;;

val expression: int -> formatter -> expression -> unit
val structure: int -> formatter -> structure -> unit
val payload: int -> formatter -> payload -> unit

end = struct
#1 "printast.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*              Damien Doligez, projet Para, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Asttypes;;
open Format;;
open Lexing;;
open Location;;
open Parsetree;;

let fmt_position with_name f l =
  let fname = if with_name then l.pos_fname else "" in
  if l.pos_lnum = -1
  then fprintf f "%s[%d]" fname l.pos_cnum
  else fprintf f "%s[%d,%d+%d]" fname l.pos_lnum l.pos_bol
               (l.pos_cnum - l.pos_bol)
;;

let fmt_location f loc =
  let p_2nd_name = loc.loc_start.pos_fname <> loc.loc_end.pos_fname in
  fprintf f "(%a..%a)" (fmt_position true) loc.loc_start
                       (fmt_position p_2nd_name) loc.loc_end;
  if loc.loc_ghost then fprintf f " ghost";
;;

let rec fmt_longident_aux f x =
  match x with
  | Longident.Lident (s) -> fprintf f "%s" s;
  | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s;
  | Longident.Lapply (y, z) ->
      fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z;
;;

let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x;;

let fmt_longident_loc f (x : Longident.t loc) =
  fprintf f "\"%a\" %a" fmt_longident_aux x.txt fmt_location x.loc;
;;

let fmt_string_loc f (x : string loc) =
  fprintf f "\"%s\" %a" x.txt fmt_location x.loc;
;;

let fmt_char_option f = function
  | None -> fprintf f "None"
  | Some c -> fprintf f "Some %c" c

let fmt_constant f x =
  match x with
  | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m;
  | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c);
  | Pconst_string (s, None) -> fprintf f "PConst_string(%S,None)" s;
  | Pconst_string (s, Some delim) ->
      fprintf f "PConst_string (%S,Some %S)" s delim;
  | Pconst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m;
;;

let fmt_mutable_flag f x =
  match x with
  | Immutable -> fprintf f "Immutable";
  | Mutable -> fprintf f "Mutable";
;;

let fmt_virtual_flag f x =
  match x with
  | Virtual -> fprintf f "Virtual";
  | Concrete -> fprintf f "Concrete";
;;

let fmt_override_flag f x =
  match x with
  | Override -> fprintf f "Override";
  | Fresh -> fprintf f "Fresh";
;;

let fmt_closed_flag f x =
  match x with
  | Closed -> fprintf f "Closed"
  | Open -> fprintf f "Open"

let fmt_rec_flag f x =
  match x with
  | Nonrecursive -> fprintf f "Nonrec";
  | Recursive -> fprintf f "Rec";
;;

let fmt_direction_flag f x =
  match x with
  | Upto -> fprintf f "Up";
  | Downto -> fprintf f "Down";
;;

let fmt_private_flag f x =
  match x with
  | Public -> fprintf f "Public";
  | Private -> fprintf f "Private";
;;

let line i f s (*...*) =
  fprintf f "%s" (String.make ((2*i) mod 72) ' ');
  fprintf f s (*...*)
;;

let list i f ppf l =
  match l with
  | [] -> line i ppf "[]\n";
  | _ :: _ ->
     line i ppf "[\n";
     List.iter (f (i+1) ppf) l;
     line i ppf "]\n";
;;

let option i f ppf x =
  match x with
  | None -> line i ppf "None\n";
  | Some x ->
      line i ppf "Some\n";
      f (i+1) ppf x;
;;

let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li;;
let string i ppf s = line i ppf "\"%s\"\n" s;;
let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s;;
let arg_label i ppf = function
  | Nolabel -> line i ppf "Nolabel\n"
  | Optional s -> line i ppf "Optional \"%s\"\n" s
  | Labelled s -> line i ppf "Labelled \"%s\"\n" s
;;

let rec core_type i ppf x =
  line i ppf "core_type %a\n" fmt_location x.ptyp_loc;
  attributes i ppf x.ptyp_attributes;
  let i = i+1 in
  match x.ptyp_desc with
  | Ptyp_any -> line i ppf "Ptyp_any\n";
  | Ptyp_var (s) -> line i ppf "Ptyp_var %s\n" s;
  | Ptyp_arrow (l, ct1, ct2) ->
      line i ppf "Ptyp_arrow\n";
      arg_label i ppf l;
      core_type i ppf ct1;
      core_type i ppf ct2;
  | Ptyp_tuple l ->
      line i ppf "Ptyp_tuple\n";
      list i core_type ppf l;
  | Ptyp_constr (li, l) ->
      line i ppf "Ptyp_constr %a\n" fmt_longident_loc li;
      list i core_type ppf l;
  | Ptyp_variant (l, closed, low) ->
      line i ppf "Ptyp_variant closed=%a\n" fmt_closed_flag closed;
      list i label_x_bool_x_core_type_list ppf l;
      option i (fun i -> list i string) ppf low
  | Ptyp_object (l, c) ->
      line i ppf "Ptyp_object %a\n" fmt_closed_flag c;
      let i = i + 1 in
      List.iter (
        function
          | Otag (l, attrs, t) ->
            line i ppf "method %s\n" l.txt;
            attributes i ppf attrs;
            core_type (i + 1) ppf t
          | Oinherit ct ->
              line i ppf "Oinherit\n";
              core_type (i + 1) ppf ct
      ) l
  | Ptyp_class (li, l) ->
      line i ppf "Ptyp_class %a\n" fmt_longident_loc li;
      list i core_type ppf l
  | Ptyp_alias (ct, s) ->
      line i ppf "Ptyp_alias \"%s\"\n" s;
      core_type i ppf ct;
  | Ptyp_poly (sl, ct) ->
      line i ppf "Ptyp_poly%a\n"
        (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x.txt)) sl;
      core_type i ppf ct;
  | Ptyp_package (s, l) ->
      line i ppf "Ptyp_package %a\n" fmt_longident_loc s;
      list i package_with ppf l;
  | Ptyp_extension (s, arg) ->
      line i ppf "Ptyp_extension \"%s\"\n" s.txt;
      payload i ppf arg

and package_with i ppf (s, t) =
  line i ppf "with type %a\n" fmt_longident_loc s;
  core_type i ppf t

and pattern i ppf x =
  line i ppf "pattern %a\n" fmt_location x.ppat_loc;
  attributes i ppf x.ppat_attributes;
  let i = i+1 in
  match x.ppat_desc with
  | Ppat_any -> line i ppf "Ppat_any\n";
  | Ppat_var (s) -> line i ppf "Ppat_var %a\n" fmt_string_loc s;
  | Ppat_alias (p, s) ->
      line i ppf "Ppat_alias %a\n" fmt_string_loc s;
      pattern i ppf p;
  | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c;
  | Ppat_interval (c1, c2) ->
      line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2;
  | Ppat_tuple (l) ->
      line i ppf "Ppat_tuple\n";
      list i pattern ppf l;
  | Ppat_construct (li, po) ->
      line i ppf "Ppat_construct %a\n" fmt_longident_loc li;
      option i pattern ppf po;
  | Ppat_variant (l, po) ->
      line i ppf "Ppat_variant \"%s\"\n" l;
      option i pattern ppf po;
  | Ppat_record (l, c) ->
      line i ppf "Ppat_record %a\n" fmt_closed_flag c;
      list i longident_x_pattern ppf l;
  | Ppat_array (l) ->
      line i ppf "Ppat_array\n";
      list i pattern ppf l;
  | Ppat_or (p1, p2) ->
      line i ppf "Ppat_or\n";
      pattern i ppf p1;
      pattern i ppf p2;
  | Ppat_lazy p ->
      line i ppf "Ppat_lazy\n";
      pattern i ppf p;
  | Ppat_constraint (p, ct) ->
      line i ppf "Ppat_constraint\n";
      pattern i ppf p;
      core_type i ppf ct;
  | Ppat_type (li) ->
      line i ppf "Ppat_type\n";
      longident_loc i ppf li
  | Ppat_unpack s ->
      line i ppf "Ppat_unpack %a\n" fmt_string_loc s;
  | Ppat_exception p ->
      line i ppf "Ppat_exception\n";
      pattern i ppf p
  | Ppat_open (m,p) ->
      line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m;
      pattern i ppf p
  | Ppat_extension (s, arg) ->
      line i ppf "Ppat_extension \"%s\"\n" s.txt;
      payload i ppf arg

and expression i ppf x =
  line i ppf "expression %a\n" fmt_location x.pexp_loc;
  attributes i ppf x.pexp_attributes;
  let i = i+1 in
  match x.pexp_desc with
  | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li;
  | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c;
  | Pexp_let (rf, l, e) ->
      line i ppf "Pexp_let %a\n" fmt_rec_flag rf;
      list i value_binding ppf l;
      expression i ppf e;
  | Pexp_function l ->
      line i ppf "Pexp_function\n";
      list i case ppf l;
  | Pexp_fun (l, eo, p, e) ->
      line i ppf "Pexp_fun\n";
      arg_label i ppf l;
      option i expression ppf eo;
      pattern i ppf p;
      expression i ppf e;
  | Pexp_apply (e, l) ->
      line i ppf "Pexp_apply\n";
      expression i ppf e;
      list i label_x_expression ppf l;
  | Pexp_match (e, l) ->
      line i ppf "Pexp_match\n";
      expression i ppf e;
      list i case ppf l;
  | Pexp_try (e, l) ->
      line i ppf "Pexp_try\n";
      expression i ppf e;
      list i case ppf l;
  | Pexp_tuple (l) ->
      line i ppf "Pexp_tuple\n";
      list i expression ppf l;
  | Pexp_construct (li, eo) ->
      line i ppf "Pexp_construct %a\n" fmt_longident_loc li;
      option i expression ppf eo;
  | Pexp_variant (l, eo) ->
      line i ppf "Pexp_variant \"%s\"\n" l;
      option i expression ppf eo;
  | Pexp_record (l, eo) ->
      line i ppf "Pexp_record\n";
      list i longident_x_expression ppf l;
      option i expression ppf eo;
  | Pexp_field (e, li) ->
      line i ppf "Pexp_field\n";
      expression i ppf e;
      longident_loc i ppf li;
  | Pexp_setfield (e1, li, e2) ->
      line i ppf "Pexp_setfield\n";
      expression i ppf e1;
      longident_loc i ppf li;
      expression i ppf e2;
  | Pexp_array (l) ->
      line i ppf "Pexp_array\n";
      list i expression ppf l;
  | Pexp_ifthenelse (e1, e2, eo) ->
      line i ppf "Pexp_ifthenelse\n";
      expression i ppf e1;
      expression i ppf e2;
      option i expression ppf eo;
  | Pexp_sequence (e1, e2) ->
      line i ppf "Pexp_sequence\n";
      expression i ppf e1;
      expression i ppf e2;
  | Pexp_while (e1, e2) ->
      line i ppf "Pexp_while\n";
      expression i ppf e1;
      expression i ppf e2;
  | Pexp_for (p, e1, e2, df, e3) ->
      line i ppf "Pexp_for %a\n" fmt_direction_flag df;
      pattern i ppf p;
      expression i ppf e1;
      expression i ppf e2;
      expression i ppf e3;
  | Pexp_constraint (e, ct) ->
      line i ppf "Pexp_constraint\n";
      expression i ppf e;
      core_type i ppf ct;
  | Pexp_coerce (e, cto1, cto2) ->
      line i ppf "Pexp_coerce\n";
      expression i ppf e;
      option i core_type ppf cto1;
      core_type i ppf cto2;
  | Pexp_send (e, s) ->
      line i ppf "Pexp_send \"%s\"\n" s.txt;
      expression i ppf e;
  | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li;
  | Pexp_setinstvar (s, e) ->
      line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s;
      expression i ppf e;
  | Pexp_override (l) ->
      line i ppf "Pexp_override\n";
      list i string_x_expression ppf l;
  | Pexp_letmodule (s, me, e) ->
      line i ppf "Pexp_letmodule %a\n" fmt_string_loc s;
      module_expr i ppf me;
      expression i ppf e;
  | Pexp_letexception (cd, e) ->
      line i ppf "Pexp_letexception\n";
      extension_constructor i ppf cd;
      expression i ppf e;
  | Pexp_assert (e) ->
      line i ppf "Pexp_assert\n";
      expression i ppf e;
  | Pexp_lazy (e) ->
      line i ppf "Pexp_lazy\n";
      expression i ppf e;
  | Pexp_poly (e, cto) ->
      line i ppf "Pexp_poly\n";
      expression i ppf e;
      option i core_type ppf cto;
  | Pexp_object s ->
      line i ppf "Pexp_object\n";
      class_structure i ppf s
  | Pexp_newtype (s, e) ->
      line i ppf "Pexp_newtype \"%s\"\n" s.txt;
      expression i ppf e
  | Pexp_pack me ->
      line i ppf "Pexp_pack\n";
      module_expr i ppf me
  | Pexp_open (ovf, m, e) ->
      line i ppf "Pexp_open %a \"%a\"\n" fmt_override_flag ovf
        fmt_longident_loc m;
      expression i ppf e
  | Pexp_extension (s, arg) ->
      line i ppf "Pexp_extension \"%s\"\n" s.txt;
      payload i ppf arg
  | Pexp_unreachable ->
      line i ppf "Pexp_unreachable"

and value_description i ppf x =
  line i ppf "value_description %a %a\n" fmt_string_loc
       x.pval_name fmt_location x.pval_loc;
  attributes i ppf x.pval_attributes;
  core_type (i+1) ppf x.pval_type;
  list (i+1) string ppf x.pval_prim

and type_parameter i ppf (x, _variance) = core_type i ppf x

and type_declaration i ppf x =
  line i ppf "type_declaration %a %a\n" fmt_string_loc x.ptype_name
       fmt_location x.ptype_loc;
  attributes i ppf x.ptype_attributes;
  let i = i+1 in
  line i ppf "ptype_params =\n";
  list (i+1) type_parameter ppf x.ptype_params;
  line i ppf "ptype_cstrs =\n";
  list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs;
  line i ppf "ptype_kind =\n";
  type_kind (i+1) ppf x.ptype_kind;
  line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private;
  line i ppf "ptype_manifest =\n";
  option (i+1) core_type ppf x.ptype_manifest

and attributes i ppf l =
  let i = i + 1 in
  List.iter
    (fun (s, arg) ->

      line i ppf "attribute %a \"%s\"\n"  fmt_location (s: _ Asttypes.loc).loc s.txt;    

      payload (i + 1) ppf arg;
    )
    l

and payload i ppf = function
  | PStr x -> structure i ppf x
  | PSig x -> signature i ppf x
  | PTyp x -> core_type i ppf x
  | PPat (x, None) -> pattern i ppf x
  | PPat (x, Some g) ->
    pattern i ppf x;
    line i ppf "<when>\n";
    expression (i + 1) ppf g


and type_kind i ppf x =
  match x with
  | Ptype_abstract ->
      line i ppf "Ptype_abstract\n"
  | Ptype_variant l ->
      line i ppf "Ptype_variant\n";
      list (i+1) constructor_decl ppf l;
  | Ptype_record l ->
      line i ppf "Ptype_record\n";
      list (i+1) label_decl ppf l;
  | Ptype_open ->
      line i ppf "Ptype_open\n";

and type_extension i ppf x =
  line i ppf "type_extension\n";
  attributes i ppf x.ptyext_attributes;
  let i = i+1 in
  line i ppf "ptyext_path = %a\n" fmt_longident_loc x.ptyext_path;
  line i ppf "ptyext_params =\n";
  list (i+1) type_parameter ppf x.ptyext_params;
  line i ppf "ptyext_constructors =\n";
  list (i+1) extension_constructor ppf x.ptyext_constructors;
  line i ppf "ptyext_private = %a\n" fmt_private_flag x.ptyext_private;

and extension_constructor i ppf x =
  line i ppf "extension_constructor %a\n" fmt_location x.pext_loc;
  attributes i ppf x.pext_attributes;
  let i = i + 1 in
  line i ppf "pext_name = \"%s\"\n" x.pext_name.txt;
  line i ppf "pext_kind =\n";
  extension_constructor_kind (i + 1) ppf x.pext_kind;

and extension_constructor_kind i ppf x =
  match x with
      Pext_decl(a, r) ->
        line i ppf "Pext_decl\n";
        constructor_arguments (i+1) ppf a;
        option (i+1) core_type ppf r;
    | Pext_rebind li ->
        line i ppf "Pext_rebind\n";
        line (i+1) ppf "%a\n" fmt_longident_loc li;

and class_type i ppf x =
  line i ppf "class_type %a\n" fmt_location x.pcty_loc;
  attributes i ppf x.pcty_attributes;
  let i = i+1 in
  match x.pcty_desc with
  | Pcty_constr (li, l) ->
      line i ppf "Pcty_constr %a\n" fmt_longident_loc li;
      list i core_type ppf l;
  | Pcty_signature (cs) ->
      line i ppf "Pcty_signature\n";
      class_signature i ppf cs;
  | Pcty_arrow (l, co, cl) ->
      line i ppf "Pcty_arrow\n";
      arg_label i ppf l;
      core_type i ppf co;
      class_type i ppf cl;
  | Pcty_extension (s, arg) ->
      line i ppf "Pcty_extension \"%s\"\n" s.txt;
      payload i ppf arg
  | Pcty_open (ovf, m, e) ->
      line i ppf "Pcty_open %a \"%a\"\n" fmt_override_flag ovf
        fmt_longident_loc m;
      class_type i ppf e

and class_signature i ppf cs =
  line i ppf "class_signature\n";
  core_type (i+1) ppf cs.pcsig_self;
  list (i+1) class_type_field ppf cs.pcsig_fields;

and class_type_field i ppf x =
  line i ppf "class_type_field %a\n" fmt_location x.pctf_loc;
  let i = i+1 in
  attributes i ppf x.pctf_attributes;
  match x.pctf_desc with
  | Pctf_inherit (ct) ->
      line i ppf "Pctf_inherit\n";
      class_type i ppf ct;
  | Pctf_val (s, mf, vf, ct) ->
      line i ppf "Pctf_val \"%s\" %a %a\n" s.txt fmt_mutable_flag mf
           fmt_virtual_flag vf;
      core_type (i+1) ppf ct;
  | Pctf_method (s, pf, vf, ct) ->
      line i ppf "Pctf_method \"%s\" %a %a\n" s.txt fmt_private_flag pf
           fmt_virtual_flag vf;
      core_type (i+1) ppf ct;
  | Pctf_constraint (ct1, ct2) ->
      line i ppf "Pctf_constraint\n";
      core_type (i+1) ppf ct1;
      core_type (i+1) ppf ct2;
  | Pctf_attribute (s, arg) ->
      line i ppf "Pctf_attribute \"%s\"\n" s.txt;
      payload i ppf arg
  | Pctf_extension (s, arg) ->
      line i ppf "Pctf_extension \"%s\"\n" s.txt;
     payload i ppf arg

and class_description i ppf x =
  line i ppf "class_description %a\n" fmt_location x.pci_loc;
  attributes i ppf x.pci_attributes;
  let i = i+1 in
  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
  line i ppf "pci_params =\n";
  list (i+1) type_parameter ppf x.pci_params;
  line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
  line i ppf "pci_expr =\n";
  class_type (i+1) ppf x.pci_expr;

and class_type_declaration i ppf x =
  line i ppf "class_type_declaration %a\n" fmt_location x.pci_loc;
  attributes i ppf x.pci_attributes;
  let i = i+1 in
  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
  line i ppf "pci_params =\n";
  list (i+1) type_parameter ppf x.pci_params;
  line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
  line i ppf "pci_expr =\n";
  class_type (i+1) ppf x.pci_expr;

and class_expr i ppf x =
  line i ppf "class_expr %a\n" fmt_location x.pcl_loc;
  attributes i ppf x.pcl_attributes;
  let i = i+1 in
  match x.pcl_desc with
  | Pcl_constr (li, l) ->
      line i ppf "Pcl_constr %a\n" fmt_longident_loc li;
      list i core_type ppf l;
  | Pcl_structure (cs) ->
      line i ppf "Pcl_structure\n";
      class_structure i ppf cs;
  | Pcl_fun (l, eo, p, e) ->
      line i ppf "Pcl_fun\n";
      arg_label i ppf l;
      option i expression ppf eo;
      pattern i ppf p;
      class_expr i ppf e;
  | Pcl_apply (ce, l) ->
      line i ppf "Pcl_apply\n";
      class_expr i ppf ce;
      list i label_x_expression ppf l;
  | Pcl_let (rf, l, ce) ->
      line i ppf "Pcl_let %a\n" fmt_rec_flag rf;
      list i value_binding ppf l;
      class_expr i ppf ce;
  | Pcl_constraint (ce, ct) ->
      line i ppf "Pcl_constraint\n";
      class_expr i ppf ce;
      class_type i ppf ct;
  | Pcl_extension (s, arg) ->
      line i ppf "Pcl_extension \"%s\"\n" s.txt;
      payload i ppf arg
  | Pcl_open (ovf, m, e) ->
      line i ppf "Pcl_open %a \"%a\"\n" fmt_override_flag ovf
        fmt_longident_loc m;
      class_expr i ppf e

and class_structure i ppf { pcstr_self = p; pcstr_fields = l } =
  line i ppf "class_structure\n";
  pattern (i+1) ppf p;
  list (i+1) class_field ppf l;

and class_field i ppf x =
  line i ppf "class_field %a\n" fmt_location x.pcf_loc;
  let i = i + 1 in
  attributes i ppf x.pcf_attributes;
  match x.pcf_desc with
  | Pcf_inherit (ovf, ce, so) ->
      line i ppf "Pcf_inherit %a\n" fmt_override_flag ovf;
      class_expr (i+1) ppf ce;
      option (i+1) string_loc ppf so;
  | Pcf_val (s, mf, k) ->
      line i ppf "Pcf_val %a\n" fmt_mutable_flag mf;
      line (i+1) ppf "%a\n" fmt_string_loc s;
      class_field_kind (i+1) ppf k
  | Pcf_method (s, pf, k) ->
      line i ppf "Pcf_method %a\n" fmt_private_flag pf;
      line (i+1) ppf "%a\n" fmt_string_loc s;
      class_field_kind (i+1) ppf k
  | Pcf_constraint (ct1, ct2) ->
      line i ppf "Pcf_constraint\n";
      core_type (i+1) ppf ct1;
      core_type (i+1) ppf ct2;
  | Pcf_initializer (e) ->
      line i ppf "Pcf_initializer\n";
      expression (i+1) ppf e;
  | Pcf_attribute (s, arg) ->
      line i ppf "Pcf_attribute \"%s\"\n" s.txt;
      payload i ppf arg
  | Pcf_extension (s, arg) ->
      line i ppf "Pcf_extension \"%s\"\n" s.txt;
      payload i ppf arg

and class_field_kind i ppf = function
  | Cfk_concrete (o, e) ->
      line i ppf "Concrete %a\n" fmt_override_flag o;
      expression i ppf e
  | Cfk_virtual t ->
      line i ppf "Virtual\n";
      core_type i ppf t

and class_declaration i ppf x =
  line i ppf "class_declaration %a\n" fmt_location x.pci_loc;
  attributes i ppf x.pci_attributes;
  let i = i+1 in
  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
  line i ppf "pci_params =\n";
  list (i+1) type_parameter ppf x.pci_params;
  line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
  line i ppf "pci_expr =\n";
  class_expr (i+1) ppf x.pci_expr;

and module_type i ppf x =
  line i ppf "module_type %a\n" fmt_location x.pmty_loc;
  attributes i ppf x.pmty_attributes;
  let i = i+1 in
  match x.pmty_desc with
  | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident_loc li;
  | Pmty_alias li -> line i ppf "Pmty_alias %a\n" fmt_longident_loc li;
  | Pmty_signature (s) ->
      line i ppf "Pmty_signature\n";
      signature i ppf s;
  | Pmty_functor (s, mt1, mt2) ->
      line i ppf "Pmty_functor %a\n" fmt_string_loc s;
      Misc.may (module_type i ppf) mt1;
      module_type i ppf mt2;
  | Pmty_with (mt, l) ->
      line i ppf "Pmty_with\n";
      module_type i ppf mt;
      list i with_constraint ppf l;
  | Pmty_typeof m ->
      line i ppf "Pmty_typeof\n";
      module_expr i ppf m;
  | Pmty_extension (s, arg) ->
      line i ppf "Pmod_extension \"%s\"\n" s.txt;
      payload i ppf arg

and signature i ppf x = list i signature_item ppf x

and signature_item i ppf x =
  line i ppf "signature_item %a\n" fmt_location x.psig_loc;
  let i = i+1 in
  match x.psig_desc with
  | Psig_value vd ->
      line i ppf "Psig_value\n";
      value_description i ppf vd;
  | Psig_type (rf, l) ->
      line i ppf "Psig_type %a\n" fmt_rec_flag rf;
      list i type_declaration ppf l;
  | Psig_typext te ->
      line i ppf "Psig_typext\n";
      type_extension i ppf te
  | Psig_exception ext ->
      line i ppf "Psig_exception\n";
      extension_constructor i ppf ext;
  | Psig_module pmd ->
      line i ppf "Psig_module %a\n" fmt_string_loc pmd.pmd_name;
      attributes i ppf pmd.pmd_attributes;
      module_type i ppf pmd.pmd_type
  | Psig_recmodule decls ->
      line i ppf "Psig_recmodule\n";
      list i module_declaration ppf decls;
  | Psig_modtype x ->
      line i ppf "Psig_modtype %a\n" fmt_string_loc x.pmtd_name;
      attributes i ppf x.pmtd_attributes;
      modtype_declaration i ppf x.pmtd_type
  | Psig_open od ->
      line i ppf "Psig_open %a %a\n"
        fmt_override_flag od.popen_override
        fmt_longident_loc od.popen_lid;
      attributes i ppf od.popen_attributes
  | Psig_include incl ->
      line i ppf "Psig_include\n";
      module_type i ppf incl.pincl_mod;
      attributes i ppf incl.pincl_attributes
  | Psig_class (l) ->
      line i ppf "Psig_class\n";
      list i class_description ppf l;
  | Psig_class_type (l) ->
      line i ppf "Psig_class_type\n";
      list i class_type_declaration ppf l;
  | Psig_extension ((s, arg), attrs) ->
      line i ppf "Psig_extension \"%s\"\n" s.txt;
      attributes i ppf attrs;
      payload i ppf arg
  | Psig_attribute (s, arg) ->
      line i ppf "Psig_attribute \"%s\"\n" s.txt;
      payload i ppf arg

and modtype_declaration i ppf = function
  | None -> line i ppf "#abstract"
  | Some mt -> module_type (i+1) ppf mt

and with_constraint i ppf x =
  match x with
  | Pwith_type (lid, td) ->
      line i ppf "Pwith_type %a\n" fmt_longident_loc lid;
      type_declaration (i+1) ppf td;
  | Pwith_typesubst (lid, td) ->
      line i ppf "Pwith_typesubst %a\n" fmt_longident_loc lid;
      type_declaration (i+1) ppf td;
  | Pwith_module (lid1, lid2) ->
      line i ppf "Pwith_module %a = %a\n"
        fmt_longident_loc lid1
        fmt_longident_loc lid2;
  | Pwith_modsubst (lid1, lid2) ->
      line i ppf "Pwith_modsubst %a = %a\n"
        fmt_longident_loc lid1
        fmt_longident_loc lid2;

and module_expr i ppf x =
  line i ppf "module_expr %a\n" fmt_location x.pmod_loc;
  attributes i ppf x.pmod_attributes;
  let i = i+1 in
  match x.pmod_desc with
  | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident_loc li;
  | Pmod_structure (s) ->
      line i ppf "Pmod_structure\n";
      structure i ppf s;
  | Pmod_functor (s, mt, me) ->
      line i ppf "Pmod_functor %a\n" fmt_string_loc s;
      Misc.may (module_type i ppf) mt;
      module_expr i ppf me;
  | Pmod_apply (me1, me2) ->
      line i ppf "Pmod_apply\n";
      module_expr i ppf me1;
      module_expr i ppf me2;
  | Pmod_constraint (me, mt) ->
      line i ppf "Pmod_constraint\n";
      module_expr i ppf me;
      module_type i ppf mt;
  | Pmod_unpack (e) ->
      line i ppf "Pmod_unpack\n";
      expression i ppf e;
  | Pmod_extension (s, arg) ->
      line i ppf "Pmod_extension \"%s\"\n" s.txt;
      payload i ppf arg

and structure i ppf x = list i structure_item ppf x

and structure_item i ppf x =
  line i ppf "structure_item %a\n" fmt_location x.pstr_loc;
  let i = i+1 in
  match x.pstr_desc with
  | Pstr_eval (e, attrs) ->
      line i ppf "Pstr_eval\n";
      attributes i ppf attrs;
      expression i ppf e;
  | Pstr_value (rf, l) ->
      line i ppf "Pstr_value %a\n" fmt_rec_flag rf;
      list i value_binding ppf l;
  | Pstr_primitive vd ->
      line i ppf "Pstr_primitive\n";
      value_description i ppf vd;
  | Pstr_type (rf, l) ->
      line i ppf "Pstr_type %a\n" fmt_rec_flag rf;
      list i type_declaration ppf l;
  | Pstr_typext te ->
      line i ppf "Pstr_typext\n";
      type_extension i ppf te
  | Pstr_exception ext ->
      line i ppf "Pstr_exception\n";
      extension_constructor i ppf ext;
  | Pstr_module x ->
      line i ppf "Pstr_module\n";
      module_binding i ppf x
  | Pstr_recmodule bindings ->
      line i ppf "Pstr_recmodule\n";
      list i module_binding ppf bindings;
  | Pstr_modtype x ->
      line i ppf "Pstr_modtype %a\n" fmt_string_loc x.pmtd_name;
      attributes i ppf x.pmtd_attributes;
      modtype_declaration i ppf x.pmtd_type
  | Pstr_open od ->
      line i ppf "Pstr_open %a %a\n"
        fmt_override_flag od.popen_override
        fmt_longident_loc od.popen_lid;
      attributes i ppf od.popen_attributes
  | Pstr_class (l) ->
      line i ppf "Pstr_class\n";
      list i class_declaration ppf l;
  | Pstr_class_type (l) ->
      line i ppf "Pstr_class_type\n";
      list i class_type_declaration ppf l;
  | Pstr_include incl ->
      line i ppf "Pstr_include";
      attributes i ppf incl.pincl_attributes;
      module_expr i ppf incl.pincl_mod
  | Pstr_extension ((s, arg), attrs) ->
      line i ppf "Pstr_extension \"%s\"\n" s.txt;
      attributes i ppf attrs;
      payload i ppf arg
  | Pstr_attribute (s, arg) ->
      line i ppf "Pstr_attribute \"%s\"\n" s.txt;
      payload i ppf arg

and module_declaration i ppf pmd =
  string_loc i ppf pmd.pmd_name;
  attributes i ppf pmd.pmd_attributes;
  module_type (i+1) ppf pmd.pmd_type;

and module_binding i ppf x =
  string_loc i ppf x.pmb_name;
  attributes i ppf x.pmb_attributes;
  module_expr (i+1) ppf x.pmb_expr

and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
  line i ppf "<constraint> %a\n" fmt_location l;
  core_type (i+1) ppf ct1;
  core_type (i+1) ppf ct2;

and constructor_decl i ppf
                     {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} =
  line i ppf "%a\n" fmt_location pcd_loc;
  line (i+1) ppf "%a\n" fmt_string_loc pcd_name;
  attributes i ppf pcd_attributes;
  constructor_arguments (i+1) ppf pcd_args;
  option (i+1) core_type ppf pcd_res

and constructor_arguments i ppf = function
  | Pcstr_tuple l -> list i core_type ppf l
  | Pcstr_record l -> list i label_decl ppf l

and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}=
  line i ppf "%a\n" fmt_location pld_loc;
  attributes i ppf pld_attributes;
  line (i+1) ppf "%a\n" fmt_mutable_flag pld_mutable;
  line (i+1) ppf "%a" fmt_string_loc pld_name;
  core_type (i+1) ppf pld_type

and longident_x_pattern i ppf (li, p) =
  line i ppf "%a\n" fmt_longident_loc li;
  pattern (i+1) ppf p;

and case i ppf {pc_lhs; pc_guard; pc_rhs} =
  line i ppf "<case>\n";
  pattern (i+1) ppf pc_lhs;
  begin match pc_guard with
  | None -> ()
  | Some g -> line (i+1) ppf "<when>\n"; expression (i + 2) ppf g
  end;
  expression (i+1) ppf pc_rhs;

and value_binding i ppf x =
  line i ppf "<def>\n";
  attributes (i+1) ppf x.pvb_attributes;
  pattern (i+1) ppf x.pvb_pat;
  expression (i+1) ppf x.pvb_expr

and string_x_expression i ppf (s, e) =
  line i ppf "<override> %a\n" fmt_string_loc s;
  expression (i+1) ppf e;

and longident_x_expression i ppf (li, e) =
  line i ppf "%a\n" fmt_longident_loc li;
  expression (i+1) ppf e;

and label_x_expression i ppf (l,e) =
  line i ppf "<arg>\n";
  arg_label i ppf l;
  expression (i+1) ppf e;

and label_x_bool_x_core_type_list i ppf x =
  match x with
    Rtag (l, attrs, b, ctl) ->
      line i ppf "Rtag \"%s\" %s\n" l.txt (string_of_bool b);
      attributes (i+1) ppf attrs;
      list (i+1) core_type ppf ctl
  | Rinherit (ct) ->
      line i ppf "Rinherit\n";
      core_type (i+1) ppf ct
;;

let rec toplevel_phrase i ppf x =
  match x with
  | Ptop_def (s) ->
      line i ppf "Ptop_def\n";
      structure (i+1) ppf s;
  | Ptop_dir (s, da) ->
      line i ppf "Ptop_dir \"%s\"\n" s;
      directive_argument i ppf da;

and directive_argument i ppf x =
  match x with
  | Pdir_none -> line i ppf "Pdir_none\n"
  | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s;
  | Pdir_int (n, None) -> line i ppf "Pdir_int %s\n" n;
  | Pdir_int (n, Some m) -> line i ppf "Pdir_int %s%c\n" n m;
  | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li;
  | Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b);
;;

let interface ppf x = list 0 signature_item ppf x;;

let implementation ppf x = list 0 structure_item ppf x;;

let top_phrase ppf x = toplevel_phrase 0 ppf x;;

end
module Printtyped : sig 
#1 "printtyped.mli"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*              Damien Doligez, projet Para, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Typedtree;;
open Format;;

val interface : formatter -> signature -> unit;;
val implementation : formatter -> structure -> unit;;

val implementation_with_coercion :
    formatter -> (structure * module_coercion) -> unit;;

end = struct
#1 "printtyped.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                   Fabrice Le Fessant, INRIA Saclay                     *)
(*                                                                        *)
(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Asttypes;;
open Format;;
open Lexing;;
open Location;;
open Typedtree;;

let fmt_position f l =
  if l.pos_lnum = -1
  then fprintf f "%s[%d]" l.pos_fname l.pos_cnum
  else fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol
               (l.pos_cnum - l.pos_bol)
;;

let fmt_location f loc =
  fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end;
  if loc.loc_ghost then fprintf f " ghost";
;;

let rec fmt_longident_aux f x =
  match x with
  | Longident.Lident (s) -> fprintf f "%s" s;
  | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s;
  | Longident.Lapply (y, z) ->
      fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z;
;;

let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt;;

let fmt_ident = Ident.print

let rec fmt_path_aux f x =
  match x with
  | Path.Pident (s) -> fprintf f "%a" fmt_ident s;
  | Path.Pdot (y, s, _pos) -> fprintf f "%a.%s" fmt_path_aux y s;
  | Path.Papply (y, z) ->
      fprintf f "%a(%a)" fmt_path_aux y fmt_path_aux z;
;;

let fmt_path f x = fprintf f "\"%a\"" fmt_path_aux x;;

let fmt_constant f x =
  match x with
  | Const_int (i) -> fprintf f "Const_int %d" i;
  | Const_char (c) -> fprintf f "Const_char %02x" (Char.code c);
  | Const_string (s, None) -> fprintf f "Const_string(%S,None)" s;
  | Const_string (s, Some delim) ->
      fprintf f "Const_string (%S,Some %S)" s delim;
  | Const_float (s) -> fprintf f "Const_float %s" s;
  | Const_int32 (i) -> fprintf f "Const_int32 %ld" i;
  | Const_int64 (i) -> fprintf f "Const_int64 %Ld" i;
  | Const_nativeint (i) -> fprintf f "Const_nativeint %nd" i;
;;

let fmt_mutable_flag f x =
  match x with
  | Immutable -> fprintf f "Immutable";
  | Mutable -> fprintf f "Mutable";
;;

let fmt_virtual_flag f x =
  match x with
  | Virtual -> fprintf f "Virtual";
  | Concrete -> fprintf f "Concrete";
;;

let fmt_override_flag f x =
  match x with
  | Override -> fprintf f "Override";
  | Fresh -> fprintf f "Fresh";
;;

let fmt_closed_flag f x =
  match x with
  | Closed -> fprintf f "Closed"
  | Open -> fprintf f "Open"

let fmt_rec_flag f x =
  match x with
  | Nonrecursive -> fprintf f "Nonrec";
  | Recursive -> fprintf f "Rec";
;;

let fmt_direction_flag f x =
  match x with
  | Upto -> fprintf f "Up";
  | Downto -> fprintf f "Down";
;;

let fmt_private_flag f x =
  match x with
  | Public -> fprintf f "Public";
  | Private -> fprintf f "Private";
;;

let line i f s (*...*) =
  fprintf f "%s" (String.make (2*i) ' ');
  fprintf f s (*...*)
;;

let list i f ppf l =
  match l with
  | [] -> line i ppf "[]\n";
  | _ :: _ ->
     line i ppf "[\n";
     List.iter (f (i+1) ppf) l;
     line i ppf "]\n";
;;

let array i f ppf a =
  if Array.length a = 0 then
    line i ppf "[]\n"
  else begin
    line i ppf "[\n";
    Array.iter (f (i+1) ppf) a;
    line i ppf "]\n"
  end
;;

let option i f ppf x =
  match x with
  | None -> line i ppf "None\n";
  | Some x ->
      line i ppf "Some\n";
      f (i+1) ppf x;
;;

let longident i ppf li = line i ppf "%a\n" fmt_longident li;;
let string i ppf s = line i ppf "\"%s\"\n" s;;
let arg_label i ppf = function
  | Nolabel -> line i ppf "Nolabel\n"
  | Optional s -> line i ppf "Optional \"%s\"\n" s
  | Labelled s -> line i ppf "Labelled \"%s\"\n" s
;;

let record_representation i ppf = let open Types in function
  | Record_regular -> line i ppf "Record_regular\n"
  | Record_float -> line i ppf "Record_float\n"
  | Record_unboxed b -> line i ppf "Record_unboxed %b\n" b
  | Record_inlined {tag = i} -> line i ppf "Record_inlined %d\n" i
  | Record_extension -> line i ppf "Record_extension\n"

let attributes i ppf l =
  let i = i + 1 in
  List.iter
    (fun (s, arg) ->
      line i ppf "attribute \"%s\"\n" s.txt;
      Printast.payload (i + 1) ppf arg;
    )
    l

let rec core_type i ppf x =
  line i ppf "core_type %a\n" fmt_location x.ctyp_loc;
  attributes i ppf x.ctyp_attributes;
  let i = i+1 in
  match x.ctyp_desc with
  | Ttyp_any -> line i ppf "Ttyp_any\n";
  | Ttyp_var (s) -> line i ppf "Ttyp_var %s\n" s;
  | Ttyp_arrow (l, ct1, ct2) ->
      line i ppf "Ttyp_arrow\n";
      arg_label i ppf l;
      core_type i ppf ct1;
      core_type i ppf ct2;
  | Ttyp_tuple l ->
      line i ppf "Ttyp_tuple\n";
      list i core_type ppf l;
  | Ttyp_constr (li, _, l) ->
      line i ppf "Ttyp_constr %a\n" fmt_path li;
      list i core_type ppf l;
  | Ttyp_variant (l, closed, low) ->
      line i ppf "Ttyp_variant closed=%a\n" fmt_closed_flag closed;
      list i label_x_bool_x_core_type_list ppf l;
      option i (fun i -> list i string) ppf low
  | Ttyp_object (l, c) ->
      line i ppf "Ttyp_object %a\n" fmt_closed_flag c;
      let i = i + 1 in
      List.iter (function
        | OTtag (s, attrs, t) ->
            line i ppf "method %s\n" s.txt;
            attributes i ppf attrs;
            core_type (i + 1) ppf t
        | OTinherit ct ->
            line i ppf "OTinherit\n";
            core_type (i + 1) ppf ct
        ) l
  | Ttyp_class (li, _, l) ->
      line i ppf "Ttyp_class %a\n" fmt_path li;
      list i core_type ppf l;
  | Ttyp_alias (ct, s) ->
      line i ppf "Ttyp_alias \"%s\"\n" s;
      core_type i ppf ct;
  | Ttyp_poly (sl, ct) ->
      line i ppf "Ttyp_poly%a\n"
        (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x)) sl;
      core_type i ppf ct;
  | Ttyp_package { pack_path = s; pack_fields = l } ->
      line i ppf "Ttyp_package %a\n" fmt_path s;
      list i package_with ppf l;

and package_with i ppf (s, t) =
  line i ppf "with type %a\n" fmt_longident s;
  core_type i ppf t

and pattern i ppf x =
  line i ppf "pattern %a\n" fmt_location x.pat_loc;
  attributes i ppf x.pat_attributes;
  let i = i+1 in
  match x.pat_extra with
    | (Tpat_unpack, _, attrs) :: rem ->
        line i ppf "Tpat_unpack\n";
        attributes i ppf attrs;
        pattern i ppf { x with pat_extra = rem }
    | (Tpat_constraint cty, _, attrs) :: rem ->
        line i ppf "Tpat_constraint\n";
        attributes i ppf attrs;
        core_type i ppf cty;
        pattern i ppf { x with pat_extra = rem }
    | (Tpat_type (id, _), _, attrs) :: rem ->
        line i ppf "Tpat_type %a\n" fmt_path id;
        attributes i ppf attrs;
        pattern i ppf { x with pat_extra = rem }
    | (Tpat_open (id,_,_), _, attrs)::rem ->
        line i ppf "Tpat_open \"%a\"\n" fmt_path id;
        attributes i ppf attrs;
        pattern i ppf { x with pat_extra = rem }
    | [] ->
  match x.pat_desc with
  | Tpat_any -> line i ppf "Tpat_any\n";
  | Tpat_var (s,_) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s;
  | Tpat_alias (p, s,_) ->
      line i ppf "Tpat_alias \"%a\"\n" fmt_ident s;
      pattern i ppf p;
  | Tpat_constant (c) -> line i ppf "Tpat_constant %a\n" fmt_constant c;
  | Tpat_tuple (l) ->
      line i ppf "Tpat_tuple\n";
      list i pattern ppf l;
  | Tpat_construct (li, _, po) ->
      line i ppf "Tpat_construct %a\n" fmt_longident li;
      list i pattern ppf po;
  | Tpat_variant (l, po, _) ->
      line i ppf "Tpat_variant \"%s\"\n" l;
      option i pattern ppf po;
  | Tpat_record (l, _c) ->
      line i ppf "Tpat_record\n";
      list i longident_x_pattern ppf l;
  | Tpat_array (l) ->
      line i ppf "Tpat_array\n";
      list i pattern ppf l;
  | Tpat_or (p1, p2, _) ->
      line i ppf "Tpat_or\n";
      pattern i ppf p1;
      pattern i ppf p2;
  | Tpat_lazy p ->
      line i ppf "Tpat_lazy\n";
      pattern i ppf p;

and expression_extra i ppf x attrs =
  match x with
  | Texp_constraint ct ->
      line i ppf "Texp_constraint\n";
      attributes i ppf attrs;
      core_type i ppf ct;
  | Texp_coerce (cto1, cto2) ->
      line i ppf "Texp_coerce\n";
      attributes i ppf attrs;
      option i core_type ppf cto1;
      core_type i ppf cto2;
  | Texp_open (ovf, m, _, _) ->
      line i ppf "Texp_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m;
      attributes i ppf attrs;
  | Texp_poly cto ->
      line i ppf "Texp_poly\n";
      attributes i ppf attrs;
      option i core_type ppf cto;
  | Texp_newtype s ->
      line i ppf "Texp_newtype \"%s\"\n" s;
      attributes i ppf attrs;

and expression i ppf x =
  line i ppf "expression %a\n" fmt_location x.exp_loc;
  attributes i ppf x.exp_attributes;
  let i =
    List.fold_left (fun i (extra,_,attrs) ->
                      expression_extra i ppf extra attrs; i+1)
      (i+1) x.exp_extra
  in
  match x.exp_desc with
  | Texp_ident (li,_,_) -> line i ppf "Texp_ident %a\n" fmt_path li;
  | Texp_instvar (_, li,_) -> line i ppf "Texp_instvar %a\n" fmt_path li;
  | Texp_constant (c) -> line i ppf "Texp_constant %a\n" fmt_constant c;
  | Texp_let (rf, l, e) ->
      line i ppf "Texp_let %a\n" fmt_rec_flag rf;
      list i value_binding ppf l;
      expression i ppf e;
  | Texp_function { arg_label = p; param = _; cases; partial = _; } ->
      line i ppf "Texp_function\n";
      arg_label i ppf p;
      list i case ppf cases;
  | Texp_apply (e, l) ->
      line i ppf "Texp_apply\n";
      expression i ppf e;
      list i label_x_expression ppf l;
  | Texp_match (e, l1, l2, _partial) ->
      line i ppf "Texp_match\n";
      expression i ppf e;
      list i case ppf l1;
      list i case ppf l2;
  | Texp_try (e, l) ->
      line i ppf "Texp_try\n";
      expression i ppf e;
      list i case ppf l;
  | Texp_tuple (l) ->
      line i ppf "Texp_tuple\n";
      list i expression ppf l;
  | Texp_construct (li, _, eo) ->
      line i ppf "Texp_construct %a\n" fmt_longident li;
      list i expression ppf eo;
  | Texp_variant (l, eo) ->
      line i ppf "Texp_variant \"%s\"\n" l;
      option i expression ppf eo;
  | Texp_record { fields; representation; extended_expression } ->
      line i ppf "Texp_record\n";
      let i = i+1 in
      line i ppf "fields =\n";
      array (i+1) record_field ppf fields;
      line i ppf "representation =\n";
      record_representation (i+1) ppf representation;
      line i ppf "extended_expression =\n";
      option (i+1) expression ppf extended_expression;
  | Texp_field (e, li, _) ->
      line i ppf "Texp_field\n";
      expression i ppf e;
      longident i ppf li;
  | Texp_setfield (e1, li, _, e2) ->
      line i ppf "Texp_setfield\n";
      expression i ppf e1;
      longident i ppf li;
      expression i ppf e2;
  | Texp_array (l) ->
      line i ppf "Texp_array\n";
      list i expression ppf l;
  | Texp_ifthenelse (e1, e2, eo) ->
      line i ppf "Texp_ifthenelse\n";
      expression i ppf e1;
      expression i ppf e2;
      option i expression ppf eo;
  | Texp_sequence (e1, e2) ->
      line i ppf "Texp_sequence\n";
      expression i ppf e1;
      expression i ppf e2;
  | Texp_while (e1, e2) ->
      line i ppf "Texp_while\n";
      expression i ppf e1;
      expression i ppf e2;
  | Texp_for (s, _, e1, e2, df, e3) ->
      line i ppf "Texp_for \"%a\" %a\n" fmt_ident s fmt_direction_flag df;
      expression i ppf e1;
      expression i ppf e2;
      expression i ppf e3;
  | Texp_send (e, Tmeth_name s, eo) ->
      line i ppf "Texp_send \"%s\"\n" s;
      expression i ppf e;
      option i expression ppf eo
  | Texp_send (e, Tmeth_val s, eo) ->
      line i ppf "Texp_send \"%a\"\n" fmt_ident s;
      expression i ppf e;
      option i expression ppf eo
  | Texp_new (li, _, _) -> line i ppf "Texp_new %a\n" fmt_path li;
  | Texp_setinstvar (_, s, _, e) ->
      line i ppf "Texp_setinstvar \"%a\"\n" fmt_path s;
      expression i ppf e;
  | Texp_override (_, l) ->
      line i ppf "Texp_override\n";
      list i string_x_expression ppf l;
  | Texp_letmodule (s, _, me, e) ->
      line i ppf "Texp_letmodule \"%a\"\n" fmt_ident s;
      module_expr i ppf me;
      expression i ppf e;
  | Texp_letexception (cd, e) ->
      line i ppf "Texp_letexception\n";
      extension_constructor i ppf cd;
      expression i ppf e;
  | Texp_assert (e) ->
      line i ppf "Texp_assert";
      expression i ppf e;
  | Texp_lazy (e) ->
      line i ppf "Texp_lazy";
      expression i ppf e;
  | Texp_object (s, _) ->
      line i ppf "Texp_object";
      class_structure i ppf s
  | Texp_pack me ->
      line i ppf "Texp_pack";
      module_expr i ppf me
  | Texp_unreachable ->
      line i ppf "Texp_unreachable"
  | Texp_extension_constructor (li, _) ->
      line i ppf "Texp_extension_constructor %a" fmt_longident li

and value_description i ppf x =
  line i ppf "value_description %a %a\n" fmt_ident x.val_id fmt_location
       x.val_loc;
  attributes i ppf x.val_attributes;
  core_type (i+1) ppf x.val_desc;
  list (i+1) string ppf x.val_prim;

and type_parameter i ppf (x, _variance) = core_type i ppf x

and type_declaration i ppf x =
  line i ppf "type_declaration %a %a\n" fmt_ident x.typ_id fmt_location
       x.typ_loc;
  attributes i ppf x.typ_attributes;
  let i = i+1 in
  line i ppf "ptype_params =\n";
  list (i+1) type_parameter ppf x.typ_params;
  line i ppf "ptype_cstrs =\n";
  list (i+1) core_type_x_core_type_x_location ppf x.typ_cstrs;
  line i ppf "ptype_kind =\n";
  type_kind (i+1) ppf x.typ_kind;
  line i ppf "ptype_private = %a\n" fmt_private_flag x.typ_private;
  line i ppf "ptype_manifest =\n";
  option (i+1) core_type ppf x.typ_manifest;

and type_kind i ppf x =
  match x with
  | Ttype_abstract ->
      line i ppf "Ttype_abstract\n"
  | Ttype_variant l ->
      line i ppf "Ttype_variant\n";
      list (i+1) constructor_decl ppf l;
  | Ttype_record l ->
      line i ppf "Ttype_record\n";
      list (i+1) label_decl ppf l;
  | Ttype_open ->
      line i ppf "Ttype_open\n"

and type_extension i ppf x =
  line i ppf "type_extension\n";
  attributes i ppf x.tyext_attributes;
  let i = i+1 in
  line i ppf "ptyext_path = %a\n" fmt_path x.tyext_path;
  line i ppf "ptyext_params =\n";
  list (i+1) type_parameter ppf x.tyext_params;
  line i ppf "ptyext_constructors =\n";
  list (i+1) extension_constructor ppf x.tyext_constructors;
  line i ppf "ptyext_private = %a\n" fmt_private_flag x.tyext_private;

and extension_constructor i ppf x =
  line i ppf "extension_constructor %a\n" fmt_location x.ext_loc;
  attributes i ppf x.ext_attributes;
  let i = i + 1 in
  line i ppf "pext_name = \"%a\"\n" fmt_ident x.ext_id;
  line i ppf "pext_kind =\n";
  extension_constructor_kind (i + 1) ppf x.ext_kind;

and extension_constructor_kind i ppf x =
  match x with
      Text_decl(a, r) ->
        line i ppf "Text_decl\n";
        constructor_arguments (i+1) ppf a;
        option (i+1) core_type ppf r;
    | Text_rebind(p, _) ->
        line i ppf "Text_rebind\n";
        line (i+1) ppf "%a\n" fmt_path p;

and class_type i ppf x =
  line i ppf "class_type %a\n" fmt_location x.cltyp_loc;
  attributes i ppf x.cltyp_attributes;
  let i = i+1 in
  match x.cltyp_desc with
  | Tcty_constr (li, _, l) ->
      line i ppf "Tcty_constr %a\n" fmt_path li;
      list i core_type ppf l;
  | Tcty_signature (cs) ->
      line i ppf "Tcty_signature\n";
      class_signature i ppf cs;
  | Tcty_arrow (l, co, cl) ->
      line i ppf "Tcty_arrow\n";
      arg_label i ppf l;
      core_type i ppf co;
      class_type i ppf cl;
  | Tcty_open (ovf, m, _, _, e) ->
      line i ppf "Tcty_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m;
      class_type i ppf e

and class_signature i ppf { csig_self = ct; csig_fields = l } =
  line i ppf "class_signature\n";
  core_type (i+1) ppf ct;
  list (i+1) class_type_field ppf l;

and class_type_field i ppf x =
  line i ppf "class_type_field %a\n" fmt_location x.ctf_loc;
  let i = i+1 in
  attributes i ppf x.ctf_attributes;
  match x.ctf_desc with
  | Tctf_inherit (ct) ->
      line i ppf "Tctf_inherit\n";
      class_type i ppf ct;
  | Tctf_val (s, mf, vf, ct) ->
      line i ppf "Tctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf
           fmt_virtual_flag vf;
      core_type (i+1) ppf ct;
  | Tctf_method (s, pf, vf, ct) ->
      line i ppf "Tctf_method \"%s\" %a %a\n" s fmt_private_flag pf
           fmt_virtual_flag vf;
      core_type (i+1) ppf ct;
  | Tctf_constraint (ct1, ct2) ->
      line i ppf "Tctf_constraint\n";
      core_type (i+1) ppf ct1;
      core_type (i+1) ppf ct2;
  | Tctf_attribute (s, arg) ->
      line i ppf "Tctf_attribute \"%s\"\n" s.txt;
      Printast.payload i ppf arg

and class_description i ppf x =
  line i ppf "class_description %a\n" fmt_location x.ci_loc;
  attributes i ppf x.ci_attributes;
  let i = i+1 in
  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
  line i ppf "pci_params =\n";
  list (i+1) type_parameter ppf x.ci_params;
  line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt;
  line i ppf "pci_expr =\n";
  class_type (i+1) ppf x.ci_expr;

and class_type_declaration i ppf x =
  line i ppf "class_type_declaration %a\n" fmt_location x.ci_loc;
  let i = i+1 in
  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
  line i ppf "pci_params =\n";
  list (i+1) type_parameter ppf x.ci_params;
  line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt;
  line i ppf "pci_expr =\n";
  class_type (i+1) ppf x.ci_expr;

and class_expr i ppf x =
  line i ppf "class_expr %a\n" fmt_location x.cl_loc;
  attributes i ppf x.cl_attributes;
  let i = i+1 in
  match x.cl_desc with
  | Tcl_ident (li, _, l) ->
      line i ppf "Tcl_ident %a\n" fmt_path li;
      list i core_type ppf l;
  | Tcl_structure (cs) ->
      line i ppf "Tcl_structure\n";
      class_structure i ppf cs;
  | Tcl_fun (l, p, _, ce, _) ->
      line i ppf "Tcl_fun\n";
      arg_label i ppf l;
      pattern i ppf p;
      class_expr i ppf ce
  | Tcl_apply (ce, l) ->
      line i ppf "Tcl_apply\n";
      class_expr i ppf ce;
      list i label_x_expression ppf l;
  | Tcl_let (rf, l1, l2, ce) ->
      line i ppf "Tcl_let %a\n" fmt_rec_flag rf;
      list i value_binding ppf l1;
      list i ident_x_loc_x_expression_def ppf l2;
      class_expr i ppf ce;
  | Tcl_constraint (ce, Some ct, _, _, _) ->
      line i ppf "Tcl_constraint\n";
      class_expr i ppf ce;
      class_type i ppf ct
  | Tcl_constraint (ce, None, _, _, _) -> class_expr i ppf ce
  | Tcl_open (ovf, m, _, _, e) ->
      line i ppf "Tcty_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m;
      class_expr i ppf e

and class_structure i ppf { cstr_self = p; cstr_fields = l } =
  line i ppf "class_structure\n";
  pattern (i+1) ppf p;
  list (i+1) class_field ppf l;

and class_field i ppf x =
  line i ppf "class_field %a\n" fmt_location x.cf_loc;
  let i = i + 1 in
  attributes i ppf x.cf_attributes;
  match x.cf_desc with
  | Tcf_inherit (ovf, ce, so, _, _) ->
      line i ppf "Tcf_inherit %a\n" fmt_override_flag ovf;
      class_expr (i+1) ppf ce;
      option (i+1) string ppf so;
  | Tcf_val (s, mf, _, k, _) ->
      line i ppf "Tcf_val \"%s\" %a\n" s.txt fmt_mutable_flag mf;
      class_field_kind (i+1) ppf k
  | Tcf_method (s, pf, k) ->
      line i ppf "Tcf_method \"%s\" %a\n" s.txt fmt_private_flag pf;
      class_field_kind (i+1) ppf k
  | Tcf_constraint (ct1, ct2) ->
      line i ppf "Tcf_constraint\n";
      core_type (i+1) ppf ct1;
      core_type (i+1) ppf ct2;
  | Tcf_initializer (e) ->
      line i ppf "Tcf_initializer\n";
      expression (i+1) ppf e;
  | Tcf_attribute (s, arg) ->
      line i ppf "Tcf_attribute \"%s\"\n" s.txt;
      Printast.payload i ppf arg

and class_field_kind i ppf = function
  | Tcfk_concrete (o, e) ->
      line i ppf "Concrete %a\n" fmt_override_flag o;
      expression i ppf e
  | Tcfk_virtual t ->
      line i ppf "Virtual\n";
      core_type i ppf t

and class_declaration i ppf x =
  line i ppf "class_declaration %a\n" fmt_location x.ci_loc;
  let i = i+1 in
  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
  line i ppf "pci_params =\n";
  list (i+1) type_parameter ppf x.ci_params;
  line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt;
  line i ppf "pci_expr =\n";
  class_expr (i+1) ppf x.ci_expr;

and module_type i ppf x =
  line i ppf "module_type %a\n" fmt_location x.mty_loc;
  attributes i ppf x.mty_attributes;
  let i = i+1 in
  match x.mty_desc with
  | Tmty_ident (li,_) -> line i ppf "Tmty_ident %a\n" fmt_path li;
  | Tmty_alias (li,_) -> line i ppf "Tmty_alias %a\n" fmt_path li;
  | Tmty_signature (s) ->
      line i ppf "Tmty_signature\n";
      signature i ppf s;
  | Tmty_functor (s, _, mt1, mt2) ->
      line i ppf "Tmty_functor \"%a\"\n" fmt_ident s;
      Misc.may (module_type i ppf) mt1;
      module_type i ppf mt2;
  | Tmty_with (mt, l) ->
      line i ppf "Tmty_with\n";
      module_type i ppf mt;
      list i longident_x_with_constraint ppf l;
  | Tmty_typeof m ->
      line i ppf "Tmty_typeof\n";
      module_expr i ppf m;

and signature i ppf x = list i signature_item ppf x.sig_items

and signature_item i ppf x =
  line i ppf "signature_item %a\n" fmt_location x.sig_loc;
  let i = i+1 in
  match x.sig_desc with
  | Tsig_value vd ->
      line i ppf "Tsig_value\n";
      value_description i ppf vd;
  | Tsig_type (rf, l) ->
      line i ppf "Tsig_type %a\n" fmt_rec_flag rf;
      list i type_declaration ppf l;
  | Tsig_typext e ->
      line i ppf "Tsig_typext\n";
      type_extension i ppf e;
  | Tsig_exception ext ->
      line i ppf "Tsig_exception\n";
      extension_constructor i ppf ext
  | Tsig_module md ->
      line i ppf "Tsig_module \"%a\"\n" fmt_ident md.md_id;
      attributes i ppf md.md_attributes;
      module_type i ppf md.md_type
  | Tsig_recmodule decls ->
      line i ppf "Tsig_recmodule\n";
      list i module_declaration ppf decls;
  | Tsig_modtype x ->
      line i ppf "Tsig_modtype \"%a\"\n" fmt_ident x.mtd_id;
      attributes i ppf x.mtd_attributes;
      modtype_declaration i ppf x.mtd_type
  | Tsig_open od ->
      line i ppf "Tsig_open %a %a\n"
           fmt_override_flag od.open_override
           fmt_path od.open_path;
      attributes i ppf od.open_attributes
  | Tsig_include incl ->
      line i ppf "Tsig_include\n";
      attributes i ppf incl.incl_attributes;
      module_type i ppf incl.incl_mod
  | Tsig_class (l) ->
      line i ppf "Tsig_class\n";
      list i class_description ppf l;
  | Tsig_class_type (l) ->
      line i ppf "Tsig_class_type\n";
      list i class_type_declaration ppf l;
  | Tsig_attribute (s, arg) ->
      line i ppf "Tsig_attribute \"%s\"\n" s.txt;
      Printast.payload i ppf arg

and module_declaration i ppf md =
  line i ppf "%a" fmt_ident md.md_id;
  attributes i ppf md.md_attributes;
  module_type (i+1) ppf md.md_type;

and module_binding i ppf x =
  line i ppf "%a\n" fmt_ident x.mb_id;
  attributes i ppf x.mb_attributes;
  module_expr (i+1) ppf x.mb_expr

and modtype_declaration i ppf = function
  | None -> line i ppf "#abstract"
  | Some mt -> module_type (i + 1) ppf mt

and with_constraint i ppf x =
  match x with
  | Twith_type (td) ->
      line i ppf "Twith_type\n";
      type_declaration (i+1) ppf td;
  | Twith_typesubst (td) ->
      line i ppf "Twith_typesubst\n";
      type_declaration (i+1) ppf td;
  | Twith_module (li,_) -> line i ppf "Twith_module %a\n" fmt_path li;
  | Twith_modsubst (li,_) -> line i ppf "Twith_modsubst %a\n" fmt_path li;

and module_expr i ppf x =
  line i ppf "module_expr %a\n" fmt_location x.mod_loc;
  attributes i ppf x.mod_attributes;
  let i = i+1 in
  match x.mod_desc with
  | Tmod_ident (li,_) -> line i ppf "Tmod_ident %a\n" fmt_path li;
  | Tmod_structure (s) ->
      line i ppf "Tmod_structure\n";
      structure i ppf s;
  | Tmod_functor (s, _, mt, me) ->
      line i ppf "Tmod_functor \"%a\"\n" fmt_ident s;
      Misc.may (module_type i ppf) mt;
      module_expr i ppf me;
  | Tmod_apply (me1, me2, _) ->
      line i ppf "Tmod_apply\n";
      module_expr i ppf me1;
      module_expr i ppf me2;
  | Tmod_constraint (me, _, Tmodtype_explicit mt, _) ->
      line i ppf "Tmod_constraint\n";
      module_expr i ppf me;
      module_type i ppf mt;
  | Tmod_constraint (me, _, Tmodtype_implicit, _) -> module_expr i ppf me
  | Tmod_unpack (e, _) ->
      line i ppf "Tmod_unpack\n";
      expression i ppf e;

and structure i ppf x = list i structure_item ppf x.str_items

and structure_item i ppf x =
  line i ppf "structure_item %a\n" fmt_location x.str_loc;
  let i = i+1 in
  match x.str_desc with
  | Tstr_eval (e, attrs) ->
      line i ppf "Tstr_eval\n";
      attributes i ppf attrs;
      expression i ppf e;
  | Tstr_value (rf, l) ->
      line i ppf "Tstr_value %a\n" fmt_rec_flag rf;
      list i value_binding ppf l;
  | Tstr_primitive vd ->
      line i ppf "Tstr_primitive\n";
      value_description i ppf vd;
  | Tstr_type (rf, l) ->
      line i ppf "Tstr_type %a\n" fmt_rec_flag rf;
      list i type_declaration ppf l;
  | Tstr_typext te ->
      line i ppf "Tstr_typext\n";
      type_extension i ppf te
  | Tstr_exception ext ->
      line i ppf "Tstr_exception\n";
      extension_constructor i ppf ext;
  | Tstr_module x ->
      line i ppf "Tstr_module\n";
      module_binding i ppf x
  | Tstr_recmodule bindings ->
      line i ppf "Tstr_recmodule\n";
      list i module_binding ppf bindings
  | Tstr_modtype x ->
      line i ppf "Tstr_modtype \"%a\"\n" fmt_ident x.mtd_id;
      attributes i ppf x.mtd_attributes;
      modtype_declaration i ppf x.mtd_type
  | Tstr_open od ->
      line i ppf "Tstr_open %a %a\n"
           fmt_override_flag od.open_override
           fmt_path od.open_path;
      attributes i ppf od.open_attributes
  | Tstr_class (l) ->
      line i ppf "Tstr_class\n";
      list i class_declaration ppf (List.map (fun (cl, _) -> cl) l);
  | Tstr_class_type (l) ->
      line i ppf "Tstr_class_type\n";
      list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l);
  | Tstr_include incl ->
      line i ppf "Tstr_include";
      attributes i ppf incl.incl_attributes;
      module_expr i ppf incl.incl_mod;
  | Tstr_attribute (s, arg) ->
      line i ppf "Tstr_attribute \"%s\"\n" s.txt;
      Printast.payload i ppf arg

and longident_x_with_constraint i ppf (li, _, wc) =
  line i ppf "%a\n" fmt_path li;
  with_constraint (i+1) ppf wc;

and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
  line i ppf "<constraint> %a\n" fmt_location l;
  core_type (i+1) ppf ct1;
  core_type (i+1) ppf ct2;

and constructor_decl i ppf {cd_id; cd_name = _; cd_args; cd_res; cd_loc;
                            cd_attributes} =
  line i ppf "%a\n" fmt_location cd_loc;
  line (i+1) ppf "%a\n" fmt_ident cd_id;
  attributes i ppf cd_attributes;
  constructor_arguments (i+1) ppf cd_args;
  option (i+1) core_type ppf cd_res

and constructor_arguments i ppf = function
  | Cstr_tuple l -> list i core_type ppf l
  | Cstr_record l -> list i label_decl ppf l

and label_decl i ppf {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc;
                      ld_attributes} =
  line i ppf "%a\n" fmt_location ld_loc;
  attributes i ppf ld_attributes;
  line (i+1) ppf "%a\n" fmt_mutable_flag ld_mutable;
  line (i+1) ppf "%a" fmt_ident ld_id;
  core_type (i+1) ppf ld_type

and longident_x_pattern i ppf (li, _, p) =
  line i ppf "%a\n" fmt_longident li;
  pattern (i+1) ppf p;

and case i ppf {c_lhs; c_guard; c_rhs} =
  line i ppf "<case>\n";
  pattern (i+1) ppf c_lhs;
  begin match c_guard with
  | None -> ()
  | Some g -> line (i+1) ppf "<when>\n"; expression (i + 2) ppf g
  end;
  expression (i+1) ppf c_rhs;

and value_binding i ppf x =
  line i ppf "<def>\n";
  attributes (i+1) ppf x.vb_attributes;
  pattern (i+1) ppf x.vb_pat;
  expression (i+1) ppf x.vb_expr

and string_x_expression i ppf (s, _, e) =
  line i ppf "<override> \"%a\"\n" fmt_path s;
  expression (i+1) ppf e;

and record_field i ppf = function
  | _, Overridden (li, e) ->
      line i ppf "%a\n" fmt_longident li;
      expression (i+1) ppf e;
  | _, Kept _ ->
      line i ppf "<kept>"

and label_x_expression i ppf (l, e) =
  line i ppf "<arg>\n";
  arg_label (i+1) ppf l;
  (match e with None -> () | Some e -> expression (i+1) ppf e)

and ident_x_loc_x_expression_def i ppf (l,_, e) =
  line i ppf "<def> \"%a\"\n" fmt_ident l;
  expression (i+1) ppf e;

and label_x_bool_x_core_type_list i ppf x =
  match x with
    Ttag (l, attrs, b, ctl) ->
      line i ppf "Ttag \"%s\" %s\n" l.txt (string_of_bool b);
      attributes (i+1) ppf attrs;
      list (i+1) core_type ppf ctl
  | Tinherit (ct) ->
      line i ppf "Tinherit\n";
      core_type (i+1) ppf ct
;;

let interface ppf x = list 0 signature_item ppf x.sig_items;;

let implementation ppf x = list 0 structure_item ppf x.str_items;;

let implementation_with_coercion ppf (x, _) = implementation ppf x

end
module Js_implementation : sig 
#1 "js_implementation.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)








(** High level compilation module *) 

(** This module defines a function to compile the program directly into [js]
    given [filename] and [outputprefix], 
    it will be useful if we don't care about bytecode output(generating js only).
 *)
val interface : Format.formatter -> string -> string -> unit

val interface_mliast : Format.formatter -> string -> string  -> unit
  


val after_parsing_impl : 
  Format.formatter -> 
  string ->
  Parsetree.structure ->
  unit
(** [after_parsing_impl ppf sourcefile outputprefix ast ]
    Make sure you need run {!Compmisc.init_path} for set up
    Used in eval
*)

val implementation : Format.formatter -> string -> string -> unit
(** [implementation ppf sourcefile outprefix] compiles to JS directly *) 

val implementation_mlast : Format.formatter -> string -> string -> unit

val implementation_map : Format.formatter -> string -> string -> unit
end = struct
#1 "js_implementation.ml"
(***********************************************************************)
(*                                                                     *)
(*                                OCaml                                *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)

(* adapted by bucklescript from [driver/compile.ml] for convenience    *)

open Format
open Typedtree
open Compenv



let fprintf = Format.fprintf



let print_if ppf flag printer arg =
  if !flag then fprintf ppf "%a@." printer arg;
  arg



let after_parsing_sig ppf  outputprefix ast  =
  if !Js_config.binary_ast then
    begin 
      Binary_ast.write_ast
        Mli
        ~sourcefile:!Location.input_name
        ~output:(outputprefix ^ if !Js_config.is_reason  then Literals.suffix_reiast else Literals.suffix_mliast)
        (* to support relocate to another directory *)
        ast 

    end;
  if !Js_config.syntax_only then 
    Warnings.check_fatal()
  else 
    begin 

      if Js_config.get_diagnose () then
        Format.fprintf Format.err_formatter "Building %s@." !Location.input_name;    
      let modulename = module_of_filename ppf !Location.input_name outputprefix in
      Lam_compile_env.reset () ;
      let initial_env = Compmisc.initial_env () in
      Env.set_unit_name modulename;

      let tsg = Typemod.type_interface 

          !Location.input_name

          initial_env ast in
      if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg;
      let sg = tsg.sig_type in
      if !Clflags.print_types then
        Printtyp.wrap_printing_env initial_env (fun () ->
            fprintf std_formatter "%a@."
              Printtyp.signature (Typemod.simplify_signature sg));
      ignore (Includemod.signatures initial_env sg sg);
      Typecore.force_delayed_checks ();
      Warnings.check_fatal ();
      if not !Clflags.print_types then begin

        let deprecated = Builtin_attributes.deprecated_of_sig ast in
        let sg =
          Env.save_signature ~deprecated sg modulename (outputprefix ^ ".cmi")
        in
        
        Typemod.save_signature modulename tsg outputprefix !Location.input_name
          initial_env sg ;
      end
    end



let interface ppf fname outputprefix =
  Compmisc.init_path false;
  Pparse.parse_interface ~tool_name:Js_config.tool_name ppf fname
  |> Ppx_entry.rewrite_signature
  |> print_if ppf Clflags.dump_parsetree Printast.interface
  |> print_if ppf Clflags.dump_source Pprintast.signature 
  |> after_parsing_sig ppf  outputprefix 

let interface_mliast ppf fname outputprefix  = 
  Compmisc.init_path false;
  Binary_ast.read_ast Mli fname 
  |> print_if ppf Clflags.dump_parsetree Printast.interface
  |> print_if ppf Clflags.dump_source Pprintast.signature 
  |> after_parsing_sig ppf  outputprefix 


let get_lambda = fun   

              {Lambda.code = lambda}
              -> lambda 

let after_parsing_impl ppf  outputprefix ast =
  
  if !Js_config.binary_ast then
    Binary_ast.write_ast ~sourcefile:!Location.input_name 
      Ml ~output:(outputprefix ^ 
        if !Js_config.is_reason then  Literals.suffix_reast else Literals.suffix_mlast
        )
      ast ;
  if !Js_config.syntax_only then 
    Warnings.check_fatal ()
  else 
    begin
      if Js_config.get_diagnose () then
        Format.fprintf Format.err_formatter "Building %s@." !Location.input_name;      
      let modulename = Ext_filename.module_name outputprefix in
      Lam_compile_env.reset () ;
      let env = Compmisc.initial_env() in
      Env.set_unit_name modulename;

      let (typedtree, coercion, finalenv, current_signature) =
        ast 
        |> Typemod.type_implementation_more ?check_exists:(if !Js_config.force_cmi then None else Some ()) !Location.input_name outputprefix modulename env 
        |> print_if ppf Clflags.dump_typedtree
          (fun fmt (ty,co,_,_) -> Printtyped.implementation_with_coercion fmt  (ty,co))
      in
      if !Clflags.print_types || !Js_config.cmi_only then begin
        Warnings.check_fatal ();
      end else begin
        (typedtree, coercion)
        |> Translmod.transl_implementation modulename
        |> (fun lambda -> 
            print_if ppf Clflags.dump_rawlambda Printlambda.lambda (get_lambda lambda)
            |>
            Lam_compile_main.lambda_as_module
              finalenv  
              outputprefix 
          );
      end;
        Stypes.dump (Some (outputprefix ^ ".annot"));
    end
let implementation ppf fname outputprefix =
  Compmisc.init_path false;
  Pparse.parse_implementation ~tool_name:Js_config.tool_name ppf fname
  |> Ppx_entry.rewrite_implementation
  |> print_if ppf Clflags.dump_parsetree Printast.implementation
  |> print_if ppf Clflags.dump_source Pprintast.structure
  |> after_parsing_impl ppf outputprefix 

let implementation_mlast ppf fname outputprefix = 
  Compmisc.init_path false;
  Binary_ast.read_ast Ml fname
  |> print_if ppf Clflags.dump_parsetree Printast.implementation
  |> print_if ppf Clflags.dump_source Pprintast.structure
  |> after_parsing_impl ppf  outputprefix 







let make_structure_item ~ns cunit : Parsetree.structure_item =
  let open Ast_helper in 
  let loc = Location.none in 
  Str.module_ 
    (Mb.mk {txt = cunit; loc  }
       (Mod.ident 
          {txt = Lident 
               ( Ext_namespace.make ~ns cunit)
          ; loc}))


(** decoding [.mlmap]
  keep in sync {!Bsb_namespace_map_gen.output}
*)
let implementation_map ppf sourcefile outputprefix = 
  let ichan = open_in_bin sourcefile in 
  seek_in ichan (Ext_digest.length +1);
  let list_of_modules = Ext_io.rev_lines_of_chann ichan in 
  close_in ichan;
  let ns = Ext_filename.module_name sourcefile in
  let ml_ast = Ext_list.fold_left list_of_modules [] (fun acc line -> 
      if Ext_string.is_empty line then acc 
      else make_structure_item ~ns line :: acc 
    )  in 
  Compmisc.init_path false;
  ml_ast
  |> print_if ppf Clflags.dump_parsetree Printast.implementation
  |> print_if ppf Clflags.dump_source Pprintast.structure
  |> after_parsing_impl ppf outputprefix 


end
module Ocaml_options : sig 
#1 "ocaml_options.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)



val mk_impl : (string -> unit) -> string * Arg.spec * string
val mk_intf : (string -> unit) -> string * Arg.spec * string
val mk__ : (string -> unit) -> string * Arg.spec * string
(**
   [ocaml_options] are command options inherited from ocaml 
   bytecode compiler except three options 
   [impl] [intf] and [annoymous] which is in another module 
   due to  dependencies
*)
val ocaml_options : (string * Arg.spec * string) list

end = struct
#1 "ocaml_options.ml"
(***********************************************************************)
(*                                                                     *)
(*                                OCaml                                *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)

(** Need sync up with {!Main_args} and {!Optmain} *)

let mk_absname f =
  "-absname", Arg.Unit f, " Show absolute filenames in error messages"
;;

let mk_annot f =
  "-annot", Arg.Unit f, " Save information in <filename>.annot"
;;

let mk_binannot f =
  "-bin-annot", Arg.Unit f, " Save typedtree in <filename>.cmt"
;;

let mk_c f =
  "-c", Arg.Unit f, " Compile only (do not link)"
;;

let mk_config f =
  "-config", Arg.Unit f, " Print configuration values and exit"
;;

let mk_g_byt f =
  "-g", Arg.Unit f, " Save debugging information"
;;

let mk_i f =
  "-i", Arg.Unit f, " Print inferred interface"
;;

let mk_I f =
  "-I", Arg.String f, "<dir>  Add <dir> to the list of include directories"
;;

let mk_impl f =
  "-impl", Arg.String f, "<file>  Compile <file> as a .ml file"
;;

let mk_intf f =
  "-intf", Arg.String f, "<file>  Compile <file> as a .mli file"
;;

let mk_intf_suffix f =
  "-intf-suffix", Arg.String f,
  "<string>  Suffix for interface files (default: .mli)"
;;

let mk_keep_docs f =
  "-keep-docs", Arg.Unit f, " Keep documentation strings in .cmi files"
;;

let mk_keep_locs f =
  "-keep-locs", Arg.Unit f, " Keep locations in .cmi files"
;;

let mk_labels f =
  "-labels", Arg.Unit f, " Use commuting label mode"
;;

let mk_no_alias_deps f =
  "-no-alias-deps", Arg.Unit f,
  " Do not record dependencies for module aliases"
;;

let mk_no_app_funct f =
  "-no-app-funct", Arg.Unit f, " Deactivate applicative functors"
;;

let mk_no_check_prims f =
  "-no-check-prims", Arg.Unit f, " Do not check runtime for primitives"
;;

let mk_noassert f =
  "-noassert", Arg.Unit f, " Do not compile assertion checks"
;;

let mk_nolabels f =
  "-nolabels", Arg.Unit f, " Ignore non-optional labels in types"
;;

let mk_nostdlib f =
  "-nostdlib", Arg.Unit f,
  " Do not add default directory to the list of include directories"
;;

let mk_o f =
  "-o", Arg.String f, "<file>  Set output file name to <file>"
;;

let mk_open f =
  "-open", Arg.String f, "<module>  Opens the module <module> before typing"

let mk_pp f =
  "-pp", Arg.String f, "<command>  Pipe sources through preprocessor <command>"
;;

let mk_ppx f =
  "-ppx", Arg.String f,
  "<command>  Pipe abstract syntax trees through preprocessor <command>"
;;

let mk_principal f =
  "-principal", Arg.Unit f, " Check principality of type inference"
;;

let mk_rectypes f =
  "-rectypes", Arg.Unit f, " Allow arbitrary recursive types"
;;

let mk_safe_string f =
  "-safe-string", Arg.Unit f, " Make strings immutable"
;;

let mk_short_paths f =
  "-short-paths", Arg.Unit f, " Shorten paths in types"
;;

let mk_stdin f =
  "-stdin", Arg.Unit f, " Read script from standard input"
;;

let mk_strict_sequence f =
  "-strict-sequence", Arg.Unit f,
  " Left-hand part of a sequence must have type unit"
;;

let mk_unsafe f =
  "-unsafe", Arg.Unit f,
  " Do not compile bounds checking on array and string access"
;;

let mk_v f =
  "-v", Arg.Unit f,
  " Print compiler version and location of standard library and exit"
;;

let mk_verbose f =
  "-verbose", Arg.Unit f, " Print calls to external commands"
;;

let mk_version f =
  "-version", Arg.Unit f, " Print version and exit"
;;

let mk_vnum f =
  "-vnum", Arg.Unit f, " Print version number and exit"
;;

let mk_w f =
  "-w", Arg.String f,
  Printf.sprintf
  "<list>  Enable or disable warnings according to <list>:\n\
  \        +<spec>   enable warnings in <spec>\n\
  \        -<spec>   disable warnings in <spec>\n\
  \        @<spec>   enable warnings in <spec> and treat them as errors\n\
  \     <spec> can be:\n\
  \        <num>             a single warning number\n\
  \        <num1>..<num2>    a range of consecutive warning numbers\n\
  \        <letter>          a predefined set\n\
  \     default setting is %S" Warnings.defaults_w
;;

let mk_warn_error f =
  "-warn-error", Arg.String f,
  Printf.sprintf
  "<list>  Enable or disable error status for warnings according\n\
  \     to <list>.  See option -w for the syntax of <list>.\n\
  \     Default setting is %S" Warnings.defaults_warn_error
;;

let mk_warn_help f =
  "-warn-help", Arg.Unit f, " Show description of warning numbers"
;;

let mk_where f =
  "-where", Arg.Unit f, " Print location of standard library and exit"
;;

let mk_color f =
  "-color", Arg.Symbol (["auto"; "always"; "never"], f),
  Printf.sprintf
  "  Enable or disable colors in compiler messages\n\
  \    The following settings are supported:\n\
  \      auto    use heuristics to enable colors only if supported\n\
  \      always  enable colors\n\
  \      never   disable colors\n\
  \    The default setting is 'auto', and the current heuristic\n\
  \    checks that the TERM environment variable exists and is\n\
  \    not empty or \"dumb\", and that isatty(stderr) holds."
;;


let mk_nopervasives f =
  "-nopervasives", Arg.Unit f, " (undocumented)"
;;

let mk_dparsetree f =
  "-dparsetree", Arg.Unit f, " (undocumented)"
;;

let mk_dtypedtree f =
  "-dtypedtree", Arg.Unit f, " (undocumented)"
;;

let mk_drawlambda f =
  "-drawlambda", Arg.Unit f, " (undocumented)"
;;

let mk_dsource f =
  "-dsource", Arg.Unit f, " (undocumented)"
;;

let mk_dlambda f =
  "-dlambda", Arg.Unit f, " (undocumented)"
;;

let mk_opaque f =
  "-opaque", Arg.Unit f,
  " Does not generate cross-module optimization information\n\
  \     (reduces necessary recompilation on module change)"
;;

let mk_strict_formats f =
  "-strict-formats", Arg.Unit f,
  " Reject invalid formats accepted by legacy implementations\n\
  \     (Warning: Invalid formats may behave differently from\n\
  \      previous OCaml versions, and will become always-rejected\n\
  \      in future OCaml versions. You should use this flag\n\
  \      to detect and fix invalid formats.)"
;;

let mk__ f =
  "-", Arg.String f,
  "<file>  Treat <file> as a file name (even if it starts with `-')"
;;

let show_config () =
  Config.print_config stdout;
  exit 0;
;;

let bs_version_string = 
  "BuckleScript " ^ Bs_version.version ^
  " (Using OCaml" ^ Config.version ^ " )" 

let print_version_string () = 
  print_string bs_version_string;
  print_newline (); 
  exit 0 

let standard_library =

      Config.standard_library
  

let print_standard_library () = 
  print_string standard_library; print_newline(); exit 0

let ocaml_options = 
  let set r () = r := true in 
  let unset r () = r := false in 
  let _absname = set Location.absname in 
  let _color option = 
    match Clflags.parse_color_setting option with
    | None -> ()
    | Some setting -> Clflags.color := Some setting in 
  (* let _annot = set annotations in  *)
  let _binannot = set Clflags.binary_annotations in 
  let _c = set Clflags.compile_only in 
  let _config = show_config in 
  (* let _g = set debug in  *)
  let _i () = Clflags.print_types := true; Clflags.compile_only := true in 
  let _I s = Clflags.include_dirs := s :: !Clflags.include_dirs in 
  (* let _impl = impl in  *)
  (* let _intf = intf in  *)
  let _intf_suffix s = Config.interface_suffix := s in 
  let _keep_docs = set Clflags.keep_docs in 
  let _keep_locs = set Clflags.keep_locs in 
  let _labels = unset Clflags.classic in 
  let _no_alias_deps = set Clflags.transparent_modules in 
  let _no_app_funct = unset Clflags.applicative_functors in 
  let _noassert = set Clflags.noassert in 
  let _nolabels = set Clflags.classic in 
  let _nostdlib = set Clflags.no_std_include in 
  let _o s = Clflags.output_name := Some s in 
  let _open s = Clflags.open_modules := s :: !Clflags.open_modules in 
  let _pp s = Clflags.preprocessor := Some s in 
  let _ppx s = Compenv.first_ppx := s :: !Compenv.first_ppx in 
  let _principal = set Clflags.principal in 
  let _rectypes = set Clflags.recursive_types in 
  (* let _safe_string = unset unsafe_string in  *)
  let _short_paths = unset Clflags.real_paths in 
  let _strict_sequence = set Clflags.strict_sequence in 
  let _strict_formats = set Clflags.strict_formats in 
  let _unsafe = set Clflags.fast in 
  (* let _unsafe_string = set unsafe_string in  *)
  (* let _v () = print_version_and_library "compiler" in  *)
  let _v = print_version_string in 
  let _version = print_version_string in 
  let _vnum = print_version_string in 
  let _w = (Warnings.parse_options false) in
  let _warn_error = (Warnings.parse_options true) in
  let _warn_help = Warnings.help_warnings in
  let _where = print_standard_library in 
  let _verbose = set Clflags.verbose in 
  let _nopervasives = set Clflags.nopervasives in
  let _dsource = set Clflags.dump_source in 
  let _dparsetree = set Clflags.dump_parsetree in 
  let _dtypedtree = set Clflags.dump_typedtree in
  let _drawlambda = set Clflags.dump_rawlambda in
  let _dlambda = set Clflags.dump_lambda in
  (* let anonymous = anonymous in *)

  [ mk_absname _absname;
    (* mk_annot _annot; *)
    mk_binannot _binannot;
    mk_c _c;
    mk_config _config;
    (* mk_g_byt _g; *)
    mk_i _i;
    mk_I _I;
    mk_color _color;
    (* mk_impl _impl; *)
    (* mk_intf _intf; *)
    mk_intf_suffix _intf_suffix;
    mk_keep_docs _keep_docs;
    mk_keep_locs _keep_locs;
    mk_labels _labels;
    mk_no_alias_deps _no_alias_deps;
    mk_no_app_funct _no_app_funct;
    mk_noassert _noassert;
    mk_nolabels _nolabels;
    mk_nostdlib _nostdlib;
    mk_o _o;
    mk_open _open;
    mk_pp _pp;
    mk_ppx _ppx;
    mk_principal _principal;
    mk_rectypes _rectypes;
    (* mk_safe_string _safe_string; *)
    mk_short_paths _short_paths;
    mk_strict_sequence _strict_sequence;
    mk_strict_formats _strict_formats;
    mk_unsafe _unsafe;
    mk_v _v;
    mk_verbose _verbose;
    mk_version _version;
    mk_vnum _vnum;
    mk_w _w;
    mk_warn_error _warn_error;
    mk_warn_help _warn_help;
    mk_where _where;
    mk_color _color;
    (* mk__ anonymous; *)
    mk_nopervasives _nopervasives;
    mk_dsource _dsource;
    mk_dparsetree _dparsetree;
    mk_dtypedtree _dtypedtree;
    mk_drawlambda _drawlambda;
    mk_dlambda _dlambda ]


end
module Reason_syntax_util : sig 
#1 "reason_syntax_util.mli"
# 1 "outcome_printer/reason_syntax_util.cppo.mli"
(* Hello! Welcome to the Reason syntax util logic.

  This file's shared between the Reason repo and the BuckleScript repo. In
  Reason, it's in src/reason-parser. In BuckleScript, it's in
  jscomp/outcome_printer. We periodically copy this file from Reason (the source
  of truth) to BuckleScript, then uncomment the #if #else #end cppo macros you
  see in the file. That's because BuckleScript's on OCaml 4.02 while Reason's on
  4.04; so the #if macros surround the pieces of code that are different between
  the two compilers.

  When you modify this file, please make sure you're not dragging in too many
  things. You don't necessarily have to test the file on both Reason and
  BuckleScript; ping @chenglou and a few others and we'll keep them synced up by
  patching the right parts, through the power of types(tm)
*)

val ml_to_reason_swap : string -> string

val escape_string : string -> string

(* Everything below is used by reason repo but not the BuckleScript repo *)


end = struct
#1 "reason_syntax_util.ml"
# 1 "outcome_printer/reason_syntax_util.cppo.ml"
(* Hello! Welcome to the Reason syntax util logic.

  This file's shared between the Reason repo and the BuckleScript repo. In
  Reason, it's in src/reason-parser. In BuckleScript, it's in
  jscomp/outcome_printer. We periodically copy this file from Reason (the source
  of truth) to BuckleScript, then uncomment the #if #else #end cppo macros you
  see in the file. That's because BuckleScript's on OCaml 4.02 while Reason's on
  4.04; so the #if macros surround the pieces of code that are different between
  the two compilers.

  When you modify this file, please make sure you're not dragging in too many
  things. You don't necessarily have to test the file on both Reason and
  BuckleScript; ping @chenglou and a few others and we'll keep them synced up by
  patching the right parts, through the power of types(tm)
*)


# 21 "outcome_printer/reason_syntax_util.cppo.ml"
open Asttypes
open Ast_mapper
open Parsetree
open Longident

(** Check to see if the string `s` is made up of `keyword` and zero or more
    trailing `_` characters. *)
let potentially_conflicts_with ~keyword s =
  let s_length = String.length s in
  let keyword_length = String.length keyword in
  (* It can't be a match if s is shorter than keyword *)
  s_length >= keyword_length && (
    try
      (* Ensure s starts with keyword... *)
      for i = 0 to keyword_length - 1 do
        if keyword.[i] <> s.[i] then raise Exit;
      done;
      (* ...and contains nothing else except trailing _ characters *)
      for i = keyword_length to s_length - 1 do
        if s.[i] <> '_' then raise Exit;
      done;
      (* If we've made it this far there's a potential conflict *)
      true
    with
    | Exit -> false
  )

(** Add/remove an appropriate suffix when mangling potential keywords *)
let string_add_suffix x = x ^ "_"
let string_drop_suffix x = String.sub x 0 (String.length x - 1)

(** What do these *_swap functions do? Here's an example: Reason code uses `!`
    for logical not, while ocaml uses `not`. So, for converting between reason
    and ocaml syntax, ocaml `not` converts to `!`, reason `!` converts to
    `not`.

    In more complicated cases where a reserved keyword exists in one syntax but
    not the other, these functions translate any potentially conflicting
    identifier into the same identifier with a suffix attached, or remove the
    suffix when converting back. Two examples:

    reason to ocaml:

    pub: invalid in reason to begin with
    pub_: pub
    pub__: pub_

    ocaml to reason:

    pub: pub_
    pub_: pub__
    pub__: pub___

    =====

    reason to ocaml:

    match: match_
    match_: match__
    match__: match___

    ocaml to reason:

    match: invalid in ocaml to begin with
    match_: match
    match__: match_
*)

let reason_to_ml_swap = function
  | "!" -> "not"
  | "^" -> "!"
  | "++" -> "^"
  | "===" -> "=="
  | "==" -> "="
  (* ===\/ and !==\/ are not representable in OCaml but
   * representable in Reason
   *)
  | "\\!==" -> "!=="
  |  "\\===" -> "==="
  | "!=" -> "<>"
  | "!==" -> "!="
  | x when (
    potentially_conflicts_with ~keyword:"match" x
    || potentially_conflicts_with ~keyword:"method" x
    || potentially_conflicts_with ~keyword:"private" x
    || potentially_conflicts_with ~keyword:"not" x) -> string_add_suffix x
  | x when (
    potentially_conflicts_with ~keyword:"switch_" x
    || potentially_conflicts_with ~keyword:"pub_" x
    || potentially_conflicts_with ~keyword:"pri_" x) -> string_drop_suffix x
  | everything_else -> everything_else

let ml_to_reason_swap = function
  | "not" -> "!"
  | "!" -> "^"
  | "^" -> "++"
  | "==" -> "==="
  | "=" -> "=="
  (* ===\/ and !==\/ are not representable in OCaml but
   * representable in Reason
   *)
  | "!==" -> "\\!=="
  |  "===" -> "\\==="
  | "<>" -> "!="
  | "!=" -> "!=="
  | x when (
    potentially_conflicts_with ~keyword:"match_" x
    || potentially_conflicts_with ~keyword:"method_" x
    || potentially_conflicts_with ~keyword:"private_" x
    || potentially_conflicts_with ~keyword:"not_" x) -> string_drop_suffix x
  | x when (
    potentially_conflicts_with ~keyword:"switch" x
    || potentially_conflicts_with ~keyword:"pub" x
    || potentially_conflicts_with ~keyword:"pri" x) -> string_add_suffix x
  | everything_else -> everything_else

let escape_string str =
  let buf = Buffer.create (String.length str) in
  String.iter (fun c ->
      match c with
      | '\t' -> Buffer.add_string buf "\\t"
      | '\r' -> Buffer.add_string buf "\\r"
      | '\n' -> Buffer.add_string buf "\\n"
      | '\\' -> Buffer.add_string buf "\\\\"
      | '"'  -> Buffer.add_string buf "\\\""
      | c when c < ' ' -> Buffer.add_string buf (Char.escaped c)
      | c -> Buffer.add_char buf c
    ) str;
  Buffer.contents buf

(* the stuff below contains side-effects and are not used by BuckleScript's
  vendored version of reason_syntax_util.ml. So we can neglect it *)


end
module Tweaked_reason_oprint
= struct
#1 "tweaked_reason_oprint.ml"
# 1 "outcome_printer/tweaked_reason_oprint.cppo.ml"
(* Hello! Welcome to the Reason "outcome printer" logic. This logic takes the
  AST nodes and turn them into text, for Merlin, rtop and terminal errors
  reporting to be in Reason syntax.

  If you've navigated around in the Reason codebase, you might have seen the
  other printer called reason_pprint_ast, our actual, main pretty-printer. Why
  is this one separated from reason_pprint_ast? Because the outcome printer's
  use-case is a bit different and needs different entry points blablabla...
  These are mostly excuses. But for example, currently, `Js.t({. foo: bar})` by
  itself is *invalid syntax* for a pretty printer (the correct, minimal valid
  code would be `type myObject = Js.t({. foo: bar})`), but the terminal error
  report do want to provide just that snippet and have you print it. Hopefully
  OCaml can unify actual code pretty-printing and terminal type info pretty-
  printing one day.

  This also means the outcome printer doesn't use the normal Parsetree,
  Ast_helper and others you might have seen in other files. It has its own
  small AST definition here:
  https://github.com/ocaml/ocaml/blob/4.04/typing/outcometree.mli

  The rest of this file's logic is just pattern-matching on these tree node
  variants & using Format to pretty-print them nicely.
  *)

(*
  This file's shared between the Reason repo and the BuckleScript repo. In
  Reason, it's in src/reason-parser/. In BuckleScript, it's in
  jscomp/outcome_printer/. We periodically copy this file from Reason (the
  source of truth) to BuckleScript, then uncomment the #if #else #end cppo
  macros you see in the file. That's because BuckleScript's on OCaml 4.02 while
  Reason's on 4.04; so the #if macros surround the pieces of code that are
  different between the two compilers.

  When you modify this file, please make sure you're not dragging in too many
  things. You don't necessarily have to test the file on both Reason and
  BuckleScript; ping @chenglou and a few others and we'll keep them synced up by
  patching the right parts, through the power of types(tm)
*)


# 44 "outcome_printer/tweaked_reason_oprint.cppo.ml"
open Format
open Outcometree

exception Ellipsis

let cautious f ppf arg =
  try f ppf arg with
    Ellipsis -> fprintf ppf "..."

# 62 "outcome_printer/tweaked_reason_oprint.cppo.ml"
let rec print_ident ppf =
  function
    Oide_ident s -> !Oprint.out_ident ppf s
  | Oide_dot (id, s) ->
      print_ident ppf id; pp_print_char ppf '.'; !Oprint.out_ident ppf s
  | Oide_apply (id1, id2) ->
      fprintf ppf "%a(%a)" print_ident id1 print_ident id2

# 71 "outcome_printer/tweaked_reason_oprint.cppo.ml"
let parenthesized_ident name =
  (List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"])
  ||
  (match name.[0] with
      'a'..'z' | 'A'..'Z' | '\223'..'\246' | '\248'..'\255' | '_' ->
        false
    | _ -> true)

let value_ident ppf name =
  if parenthesized_ident name then
    fprintf ppf "( %s )" (Reason_syntax_util.ml_to_reason_swap name)
  else
    pp_print_string ppf name

(* Values *)

let valid_float_lexeme s =
  let l = String.length s in
  let rec loop i =
    if i >= l then s ^ "." else
    match s.[i] with
    | '0' .. '9' | '-' -> loop (i+1)
    | _ -> s
  in loop 0

let float_repres f =
  match classify_float f with
    FP_nan -> "nan"
  | FP_infinite ->
      if f < 0.0 then "neg_infinity" else "infinity"
  | _ ->
      let float_val =
        let s1 = Printf.sprintf "%.12g" f in
        if f = float_of_string s1 then s1 else
        let s2 = Printf.sprintf "%.15g" f in
        if f = float_of_string s2 then s2 else
        Printf.sprintf "%.18g" f
      in valid_float_lexeme float_val

let parenthesize_if_neg ppf fmt v isneg =
  if isneg then pp_print_char ppf '(';
  fprintf ppf fmt v;
  if isneg then pp_print_char ppf ')'



let print_out_value ppf tree =
  let rec print_tree_1 ppf =
    function
    (* for the next few cases, please see context at https://github.com/facebook/reason/pull/1516#issuecomment-337069150 *)
    | Oval_constr (name, [Oval_constr ((Oide_ident "()"), [])]) ->
      (* for normal variants, but sugar Foo(()) to Foo() *)
       fprintf ppf "@[<1>%a()@]" print_ident name
    | Oval_constr (name, [param]) ->
      (* for normal variants *)
       fprintf ppf "@[<1>%a(%a)@]" print_ident name print_constr_param param
    | Oval_constr (name, (_ :: _ as params)) ->
        fprintf ppf "@[<1>%a(%a)@]" print_ident name
            (print_tree_list print_tree_1 ",") params
    | Oval_variant (name, Some (Oval_constr ((Oide_ident "()"), []))) ->
      (* for polymorphic variants, but sugar `foo(()) to `foo() *)
      fprintf ppf "@[<2>`%s()@]" name
    | Oval_variant (name, Some param) ->
      (* for polymorphic variants *)
      fprintf ppf "@[<2>`%s(%a)@]" name print_constr_param param
    | tree -> print_simple_tree ppf tree
  and print_constr_param ppf = function
    | Oval_int i -> parenthesize_if_neg ppf "%i" i (i < 0)
    | Oval_int32 i -> parenthesize_if_neg ppf "%lil" i (i < 0l)
    | Oval_int64 i -> parenthesize_if_neg ppf "%LiL" i (i < 0L)
    | Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i (i < 0n)
    | Oval_float f -> parenthesize_if_neg ppf "%s" (float_repres f) (f < 0.0)
    | tree -> print_simple_tree ppf tree
  and print_simple_tree ppf =
    function
      Oval_int i -> fprintf ppf "%i" i
    | Oval_int32 i -> fprintf ppf "%lil" i
    | Oval_int64 i -> fprintf ppf "%LiL" i
    | Oval_nativeint i -> fprintf ppf "%nin" i
    | Oval_float f -> pp_print_string ppf (float_repres f)
    | Oval_char c -> fprintf ppf "%C" c
    
# 153 "outcome_printer/tweaked_reason_oprint.cppo.ml"
    | Oval_string (s,_,_) ->
        
# 157 "outcome_printer/tweaked_reason_oprint.cppo.ml"
        begin try fprintf ppf "\"%s\"" (Reason_syntax_util.escape_string s) with
          Invalid_argument s when s = "String.create" -> fprintf ppf "<huge string>"
        end
    | Oval_list tl ->
        fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ",") tl
    | Oval_array tl ->
        fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ",") tl
    | Oval_constr (name, []) -> print_ident ppf name
    | Oval_variant (name, None) -> fprintf ppf "`%s" name
    | Oval_stuff s -> pp_print_string ppf s
    | Oval_record fel ->
        fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel
    | Oval_ellipsis -> raise Ellipsis
    | Oval_printer f -> f ppf
    | Oval_tuple tree_list ->
        fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list
    | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree
  and print_fields first ppf =
    function
      [] -> ()
    | (name, tree) :: fields ->
        if not first then fprintf ppf ",@ ";
        fprintf ppf "@[<1>%a:@ %a@]" print_ident name (cautious print_tree_1)
          tree;
        print_fields false ppf fields
  and print_tree_list print_item sep ppf tree_list =
    let rec print_list first ppf =
      function
        [] -> ()
      | tree :: tree_list ->
          if not first then fprintf ppf "%s@ " sep;
          print_item ppf tree;
          print_list false ppf tree_list
    in
    cautious (print_list true) ppf tree_list
  in
  cautious print_tree_1 ppf tree

(* Types *)

let rec print_list_init pr sep ppf =
  function
    [] -> ()
  | a :: l -> sep ppf; pr ppf a; print_list_init pr sep ppf l

let rec print_list pr sep ppf =
  function
    [] -> ()
  | [a] -> pr ppf a
  | a :: l -> pr ppf a; sep ppf; print_list pr sep ppf l

let pr_present =
  print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ")

let pr_vars =
  print_list (fun ppf s -> fprintf ppf "'%s" s) (fun ppf -> fprintf ppf "@ ")

type label =
  | Nonlabeled
  | Labeled of string
  | Optional of string

let get_label lbl =
  if lbl = "" then Nonlabeled
  else if String.get lbl 0 = '?' then
    Optional (String.sub lbl 1 @@ String.length lbl - 1)
  else Labeled lbl

let rec print_out_type ppf =
  function
  | Otyp_alias (ty, s) ->
      fprintf ppf "@[%a@ as '%s@]" print_out_type ty s
  | Otyp_poly (sl, ty) ->
      fprintf ppf "@[<hov 2>%a.@ %a@]"
        pr_vars sl
        print_out_type ty
  | ty ->
      print_out_type_1 ~uncurried:false ppf ty

and print_arg ppf (lab, typ) =
  let suffix =
    match get_label lab with
    | Nonlabeled -> ""
    | Labeled lab ->
        pp_print_string ppf "~";
        pp_print_string ppf lab;
        pp_print_string ppf ": ";
        ""
    | Optional lab ->
        pp_print_string ppf "~";
        pp_print_string ppf lab;
        pp_print_string ppf ": ";
        "=?"
  in
  print_out_type_2 ppf typ;
  pp_print_string ppf suffix;

and print_out_type_1 ~uncurried ppf =
  function
    (Otyp_arrow _ as x) ->
      let rec collect_args acc typ = match typ with
        | Otyp_arrow (lbl, ty1, ty2) ->
            collect_args ((lbl, ty1)::acc) ty2
        | _ -> (List.rev acc, typ)
      in
      pp_open_box ppf 0;
      let (args, result) = collect_args [] x  in
      let should_wrap_with_parens =
        (* uncurried arguments are always wrapped in parens *)
        if uncurried then true
        else match args with
        | [_, Otyp_tuple _] -> true
        | [_, Otyp_arrow _] -> true
        (* single argument should not be wrapped *)
        | ["", _] -> false
        | _ -> true
      in
      if should_wrap_with_parens then pp_print_string ppf "(";
      if uncurried then fprintf ppf ".@ ";
      print_list print_arg (fun ppf -> fprintf ppf ",@ ") ppf args;
      if should_wrap_with_parens then pp_print_string ppf ")";

      pp_print_string ppf " =>";
      pp_print_space ppf ();
      print_out_type_1 ~uncurried ppf result;
      pp_close_box ppf ()
  | ty -> print_out_type_2 ppf ty
and print_out_type_2 ppf =
  function
    Otyp_tuple tyl ->
      fprintf ppf "@[<0>(%a)@]" (print_typlist print_simple_out_type ",") tyl
  | ty -> print_simple_out_type ppf ty
and print_simple_out_type ppf =
  function
    Otyp_class (ng, id, tyl) ->
      fprintf ppf "@[%s#%a%a@]" (if ng then "_" else "")
        print_ident id print_typargs tyl

  (* BuckleScript-specific external. See the manual for the usage of [@bs]. This
    [@bs] is processed into a type that looks like `Js.Internal.fn ...`. This
    leaks during error reporting, where the type is printed. Here, we print it
    back from `Js.Internal.fn([ `Arity_2 ('c, 'd) ], 'e)` into `('a => 'b => int) [@bs]` *)
  (* same for `Js.Internal.fn(...)`. Either might shown *)
  | Otyp_constr (
      (Oide_dot (
        (Oide_dot ((Oide_ident "Js"), "Internal") | Oide_ident "Js_internal"),
        ("fn" | "meth" as name)
      ) as id),
      ([Otyp_variant(_, Ovar_fields [variant, _, tys], _, _); result] as tyl)
    ) ->
      (* Otyp_arrow *)
      let make tys result =
        if tys = [] then
          Otyp_arrow ("", Otyp_constr (Oide_ident "unit", []),result)
        else
          match tys with
          | [ Otyp_tuple tys as single] ->
            if variant = "Arity_1" then
              Otyp_arrow ("", single, result)
            else
              List.fold_right (fun x acc -> Otyp_arrow ("", x, acc)) tys result
          | [single] ->
            Otyp_arrow ("", single, result)
          | _ ->
            raise_notrace Not_found
      in
      begin match (make tys result) with
      | exception _ ->
        begin
          pp_open_box ppf 0;
          print_typargs ppf tyl;
          print_ident ppf id;
          pp_close_box ppf ()
        end
      | res ->
        begin match name  with
        | "fn" -> print_out_type_1 ~uncurried:true ppf res
        | "meth" -> fprintf ppf "@[<0>(%a)@ [@bs.meth]@]" (print_out_type_1 ~uncurried:false) res
        | _ -> assert false
        end
      end
  (* also BuckleScript-specific. See the comment in the previous pattern *)
  | Otyp_constr (
      (Oide_dot (
        (Oide_dot ((Oide_ident "Js"), "Internal") | Oide_ident "Js_internal"), "meth_callback" ) as id
      ),
      ([Otyp_variant(_, Ovar_fields [variant, _, tys], _,_); result] as tyl)
    ) ->
      let make tys result =
        match tys with
        | [Otyp_tuple tys as single] ->
          if variant = "Arity_1" then
            Otyp_arrow ("", single, result)
          else
            List.fold_right (fun x acc  -> Otyp_arrow("", x, acc) ) tys result
        | [single] ->
          Otyp_arrow ("", single, result)
        | _ ->
          raise_notrace Not_found
      in
      begin match (make tys result) with
      | exception _ ->
        begin
          pp_open_box ppf 0;
          print_typargs ppf tyl;
          print_ident ppf id;
          pp_close_box ppf ()
        end
      | res ->
        fprintf ppf "@[<0>(%a)@ [@bs.this]@]" (print_out_type_1 ~uncurried:false) res
      end
  (* also BuckleScript-specific. Turns Js.t({. foo: bar}) into {. "foo": bar} *)
  | Otyp_constr (
      (Oide_dot ((Oide_ident "Js"), "t")),
      [Otyp_object (fields, rest)]
    ) ->
      let dot = match rest with
        Some non_gen -> (if non_gen then "_" else "") ^ ".."
      | None -> "."
      in
      fprintf ppf "@[<2>{%s %a}@]" dot (print_object_fields ~quote_fields:true) fields

  | Otyp_constr (id, tyl) ->
      pp_open_box ppf 0;
      print_ident ppf id;
      begin match tyl with
      | [] -> ()
      | _ ->
        print_typargs ppf tyl;
      end;
      pp_close_box ppf ()
  | Otyp_object (fields, rest) ->
    let dot = match rest with
      Some non_gen -> (if non_gen then "_" else "") ^ ".."
    | None -> "."
    in
    fprintf ppf "@[<2>{%s %a}@]" dot (print_object_fields ~quote_fields:false) fields
  | Otyp_stuff s -> pp_print_string ppf s
  | Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s
  | Otyp_variant (non_gen, row_fields, closed, tags) ->
      let print_present ppf =
        function
          None | Some [] -> ()
        | Some l -> fprintf ppf "@;<1 -2>> @[<hov>%a@]" pr_present l
      in
      let print_fields ppf =
        function
          Ovar_fields fields ->
            print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ")
              ppf fields
        
# 408 "outcome_printer/tweaked_reason_oprint.cppo.ml"
        | Ovar_typ typ -> print_simple_out_type ppf typ
      
# 413 "outcome_printer/tweaked_reason_oprint.cppo.ml"
      in
      fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a ]@]" (if non_gen then "_" else "")
        (if closed then if tags = None then " " else "< "
         else if tags = None then "> " else "? ")
        print_fields row_fields
        print_present tags
  | Otyp_alias _ | Otyp_poly _ as ty ->
      fprintf ppf "@[<1>(%a)@]" print_out_type ty;
  | Otyp_tuple _ | Otyp_arrow _ as ty ->
    (* no parentheses needed; the callsites already wrap these *)
      fprintf ppf "@[<1>%a@]" print_out_type ty;
  | Otyp_abstract | Otyp_open
  | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> ()
  | Otyp_module (p, n, tyl) ->
      fprintf ppf "@[<1>(module %s" p;
      let first = ref true in
      List.iter2
        (fun s t ->
          let sep = if !first then (first := false; "with") else "and" in
          fprintf ppf " %s type %s = %a" sep s print_out_type t
        )
        n tyl;
      fprintf ppf ")@]"
  
# 437 "outcome_printer/tweaked_reason_oprint.cppo.ml"
  | Otyp_attribute (t, attr) ->
        fprintf ppf "@[<1>(%a [@@%s])@]" print_out_type t attr.oattr_name

# 441 "outcome_printer/tweaked_reason_oprint.cppo.ml"
and print_object_fields ~quote_fields ppf =
  function
    [] -> ()
  | [field, typ] ->
    let field = (if quote_fields then "\"" ^ field ^ "\"" else field) in
    fprintf ppf "%s: %a" field print_out_type typ;
    (print_object_fields ~quote_fields) ppf []
  | (field, typ) :: rest ->
    let field = (if quote_fields then "\"" ^ field ^ "\"" else field) in
    fprintf ppf "%s: %a,@ %a" field print_out_type typ (print_object_fields ~quote_fields) rest
and print_row_field ppf (l, opt_amp, tyl) =
  let pr_of ppf =
    if opt_amp then fprintf ppf " &@ "
    else fprintf ppf "" in
  let parens = match tyl with
    | [ (Otyp_tuple _) ] -> false (* tuples already have parentheses *)
    (* [< `Ok(string & int) ] ----> string & int
     * [< `Ok(string) ] -----> string *)
    | _::_ -> true
    | _ -> false in
  fprintf ppf "@[<hv 2>`%s%t%s%a%s@]"
    l
    pr_of
    (if parens then "(" else "")
    (print_typlist print_out_type " &") tyl
    (if parens then ")" else "")
and print_typlist print_elem sep ppf =
  function
    [] -> ()
  | [ty] -> print_elem ppf ty
  | ty :: tyl ->
      print_elem ppf ty;
      pp_print_string ppf sep;
      pp_print_space ppf ();
      print_typlist print_elem sep ppf tyl
and print_out_wrap_type ppf =
  function
  | (Otyp_constr (_, _::_)) as ty ->
      print_out_type ppf ty
  | ty -> print_simple_out_type ppf ty
and print_typargs ppf =
  function
    [] -> ()
  | [ty1] ->
      pp_print_string ppf "(";
      print_out_wrap_type ppf ty1;
      pp_print_string ppf ")"
  | tyl ->
      pp_print_string ppf "(";
      pp_open_box ppf 1;
      print_typlist print_out_wrap_type "," ppf tyl;
      pp_close_box ppf ();
      pp_print_string ppf ")"

let out_type = ref print_out_type

(* Class types *)

let type_parameter ppf (ty, (co, cn)) =
  fprintf ppf "%s%s"
    (if not cn then "+" else if not co then "-" else "")
    (if ty = "_" then ty else "'"^ty)

let print_out_class_params ppf =
  function
    [] -> ()
  | tyl ->
      fprintf ppf "(@[<1>%a@])@ "
        (print_list type_parameter (fun ppf -> fprintf ppf ",@ "))
        tyl

let rec print_out_class_type ppf =
  function
    Octy_constr (id, tyl) ->
      let pr_tyl ppf =
        function
          [] -> ()
        | tyl ->
            fprintf ppf "@[<1> %a@]" (print_typlist print_out_wrap_type "") tyl
      in
      fprintf ppf "@[%a%a@]" print_ident id pr_tyl tyl
  | Octy_arrow (lab, argument_type, return_class_type) ->
      (* class arrow types need to be printed differently. For one, you can't do:

        class a: a => b

        because due to existing parsing issues, the `a` neds to be wrapped in parens (unlike normal arrow types).
        We can change this logic once this is no longer true
       *)
      let rec print_class_type_arguments_that_might_be_arrow ppf = function
        | Otyp_arrow ("", typ1, typ2) ->
          fprintf ppf "@[%a,@ %a@]"
            print_out_type typ1
            print_class_type_arguments_that_might_be_arrow typ2
        | Otyp_arrow (_, typ1, typ2) ->
          fprintf ppf "@[~%s: %a,@ %a@]"
            lab
            print_out_type typ1
            print_class_type_arguments_that_might_be_arrow typ2
        | argument_not_arrow -> fprintf ppf "%a" print_out_type argument_not_arrow
      in
      fprintf ppf "@[(%a) =>@ %a@]"
        print_class_type_arguments_that_might_be_arrow argument_type
        print_out_class_type return_class_type
  | Octy_signature (self_ty, csil) ->
      let pr_param ppf =
        function
          Some ty -> fprintf ppf "@ @[(%a)@]" print_out_type ty
        | None -> ()
      in
      fprintf ppf "@[<hv 2>@[<2>{%a@]@ %a@;<1 -2>}@]" pr_param self_ty
        (print_list print_out_class_sig_item (fun ppf -> fprintf ppf ";@ "))
        csil
and print_out_class_sig_item ppf =
  function
    Ocsg_constraint (ty1, ty2) ->
      fprintf ppf "@[<2>as %a =@ %a@]" print_out_type ty1
        print_out_type ty2
  | Ocsg_method (name, priv, virt, ty) ->
      fprintf ppf "@[<2>%s%s%s:@ %a@]"
        (if priv then "pri " else "pub ") (if virt then "virtual " else "")
        name print_out_type ty
  | Ocsg_value (name, mut, vr, ty) ->
      fprintf ppf "@[<2>val %s%s%s:@ %a@]"
        (if mut then "mutable " else "")
        (if vr then "virtual " else "")
        name print_out_type ty

(* Signature *)

let is_rec_next = function
  | Osig_class (_, _, _, _, Orec_next)::_
  | Osig_class_type (_, _, _, _, Orec_next)::_
  | Osig_module (_, _, Orec_next)::_
  | Osig_type (_, Orec_next)::_ -> true
  | _ -> false

let rec print_out_functor ppf =
  function
    Omty_functor (_, None, mty_res) ->
      fprintf ppf "() %a" print_out_functor mty_res
  | Omty_functor (name , Some mty_arg, mty_res) ->
      fprintf ppf "(%s : %a) => %a" name
        print_out_module_type mty_arg print_out_functor mty_res
  | m -> fprintf ppf "%a" print_out_module_type m
and print_out_module_type ppf =
  function
    Omty_abstract -> ()
  | Omty_functor _ as t ->
      fprintf ppf "@[<2>%a@]" print_out_functor t
  | Omty_ident id -> fprintf ppf "%a" print_ident id
  | Omty_signature sg ->
      fprintf ppf "@[<hv 2>{@ %a@;<1 -2>}@]" print_out_signature sg
  | Omty_alias id -> fprintf ppf "(module %a)" print_ident id
and print_out_signature ppf =
  function
    [] -> ()
  | [item] ->
      fprintf ppf "%a;" print_out_sig_item item
  | Osig_typext(ext, Oext_first) :: items ->
      (* Gather together the extension constructors *)
      let rec gather_extensions acc items =
        match items with
            Osig_typext(ext, Oext_next) :: items ->
              gather_extensions
                ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc)
                items
          | _ -> (List.rev acc, items)
      in
      let exts, items =
        gather_extensions
          [(ext.oext_name, ext.oext_args, ext.oext_ret_type)]
          items
      in
      let te =
        { otyext_name = ext.oext_type_name;
          otyext_params = ext.oext_type_params;
          otyext_constructors = exts;
          otyext_private = ext.oext_private }
      in
      let sep = if is_rec_next items then "" else ";" in
      fprintf ppf "%a%s@ %a" print_out_type_extension te sep print_out_signature items
  | item :: items ->
      let sep = if is_rec_next items then "" else ";" in
      fprintf ppf "%a%s@ %a" print_out_sig_item item sep print_out_signature items
and print_out_sig_item ppf =
  function
    Osig_class (vir_flag, name, params, clt, rs) ->
      fprintf ppf "@[<2>%s%s@ %s %a@,:@ %a@]"
        (if rs = Orec_next then "and" else "class")
        (if vir_flag then " virtual" else "") name print_out_class_params params
        print_out_class_type clt
  | Osig_class_type (vir_flag, name, params, clt, rs) ->
      fprintf ppf "@[<2>%s%s@ %s %a@,=@ %a@]"
        (if rs = Orec_next then "and" else "class type")
        (if vir_flag then " virtual" else "") name print_out_class_params params
        print_out_class_type clt
  | Osig_typext (ext, Oext_exception) ->
      fprintf ppf "@[<2>exception %a@]"
        print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type)
  | Osig_typext (ext, _) ->
      print_out_extension_constructor ppf ext
  | Osig_modtype (name, Omty_abstract) ->
      fprintf ppf "@[<2>module type %s@]" name
  | Osig_modtype (name, mty) ->
      fprintf ppf "@[<2>module type %s =@ %a@]" name print_out_module_type mty
  | Osig_module (name, Omty_alias id, _) ->
      fprintf ppf "@[<2>module %s =@ %a@]" name print_ident id
  | Osig_module (name, mty, rs) ->
      fprintf ppf "@[<2>%s %s:@ %a@]"
        (match rs with Orec_not -> "module"
                    | Orec_first -> "module rec"
                    | Orec_next -> "and")
        name print_out_module_type mty
  | Osig_type(td, rs) ->
      print_out_type_decl
        (match rs with
          | Orec_not   -> "type nonrec"
          | Orec_first -> "type"
          | Orec_next  -> "and")
        ppf td
  
# 663 "outcome_printer/tweaked_reason_oprint.cppo.ml"
  | Osig_ellipsis ->
    fprintf ppf "..."
  | Osig_value {oval_name; oval_type; oval_prims; oval_attributes} ->
    let printAttributes ppf = List.iter (fun a -> fprintf ppf "[@@%s]" a.oattr_name) in
    
# 672 "outcome_printer/tweaked_reason_oprint.cppo.ml"
    let keyword = if oval_prims = [] then "let" else "external" in
    let (hackyBucklescriptExternalAnnotation, rhsValues) = List.partition (fun item ->
      (* "BS:" is considered as a bucklescript external annotation, `[@bs.module]` and the sort.

        "What's going on here? Isn't [@bs.foo] supposed to be an attribute in oval_attributes?"
        Usually yes. But here, we're intercepting things a little too late. BuckleScript already
        finished its pre/post-processing work before we get to print anything. The original
        attribute is already gone, replaced by a "BS:asdfasdfasd" thing here.
      *)
      String.length item >= 3 && item.[0] = 'B' && item.[1] = 'S' && item.[2] = ':'
    ) oval_prims in
    let print_right_hand_side ppf =
      function
        [] -> ()
      | s :: sl ->
          fprintf ppf "@ = \"%s\"" s;
          List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl
    in
    fprintf ppf "@[<2>%a%a%s %a:@ %a%a@]"
      (fun ppf -> List.iter (fun _ -> fprintf ppf "[@@bs...]@ ")) hackyBucklescriptExternalAnnotation
      printAttributes oval_attributes
      keyword
      value_ident oval_name
      !out_type oval_type
      print_right_hand_side rhsValues

and print_out_type_decl kwd ppf td =
  let print_constraints ppf =
    List.iter
      (fun (ty1, ty2) ->
         fprintf ppf "@ @[<2>constraint %a =@ %a@]" print_out_type ty1
           print_out_type ty2)
      td.otype_cstrs
  in
  let type_defined ppf =
    match td.otype_params with
      [] -> pp_print_string ppf td.otype_name
    | [param] -> fprintf ppf "@[%s(%a)@]" td.otype_name type_parameter param
    | _ ->
        fprintf ppf "@[%s(@[%a@])@]"
          td.otype_name
          (print_list type_parameter (fun ppf -> fprintf ppf ",@ "))
          td.otype_params
  in
  let print_manifest ppf =
    function
      Otyp_manifest (ty, _) -> fprintf ppf " =@ %a" print_out_type ty
    | _ -> ()
  in
  let print_name_params ppf =
    fprintf ppf "%s %t%a" kwd type_defined print_manifest td.otype_type
  in
  let ty =
    match td.otype_type with
      Otyp_manifest (_, ty) -> ty
    | _ -> td.otype_type
  in
  let print_private ppf = function
    Asttypes.Private -> fprintf ppf " pri"
  | Asttypes.Public -> ()
  in
  let print_out_tkind ppf = function
  | Otyp_abstract -> ()
  | Otyp_record lbls ->
      fprintf ppf " =%a {%a@;<1 -2>}"
        print_private td.otype_private
        (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls
  | Otyp_sum constrs ->
      fprintf ppf " =%a@;<1 2>%a"
        print_private td.otype_private
        (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs
  | Otyp_open ->
      fprintf ppf " = .."
  | ty ->
      fprintf ppf " =%a@;<1 2>%a"
        print_private td.otype_private
        print_out_type ty
  in
  fprintf ppf "@[<2>@[<hv 2>%t%a@]%t@]"
    print_name_params
    print_out_tkind ty
    print_constraints

and print_out_constr ppf (name, tyl,ret_type_opt) =
  match ret_type_opt with
  | None ->
      begin match tyl with
      | [] ->
          pp_print_string ppf name
      | [Otyp_record lbls] ->
        fprintf ppf "@[<2>%s({%a@;<1 -2>})@]" name
          (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls
      | _ ->
          fprintf ppf "@[<2>%s(%a)@]" name
            (print_typlist print_simple_out_type ",") tyl
      end
  | Some ret_type ->
      begin match tyl with
      | [] ->
          fprintf ppf "@[<2>%s:@ %a@]" name print_simple_out_type ret_type
      | [Otyp_record lbls] ->
        fprintf ppf "@[<2>%s({%a@;<1 -2>}): %a@]" name
          (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls
          print_simple_out_type ret_type
      | _ ->
          fprintf ppf "@[<2>%s(%a): %a@]" name
            (print_typlist print_simple_out_type ",") tyl
            print_simple_out_type ret_type
      end


and print_out_label ppf (name, mut, arg) =
  fprintf ppf "@[<2>%s%s:@ %a@]," (if mut then "mutable " else "") name
    print_out_type arg

and print_out_extension_constructor ppf ext =
  let print_extended_type ppf =
    let print_type_parameter ppf ty =
      fprintf ppf "%s"
        (if ty = "_" then ty else "'"^ty)
    in
      match ext.oext_type_params with
        [] -> fprintf ppf "%s" ext.oext_type_name
      | [ty_param] ->
        fprintf ppf "@[%a@ %s@]"
          print_type_parameter
          ty_param
          ext.oext_type_name
      | _ ->
        fprintf ppf "@[(@[%a)@]@ %s@]"
          (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ "))
          ext.oext_type_params
          ext.oext_type_name
  in
  fprintf ppf "@[<hv 2>type %t +=%s@;<1 2>%a@]"
    print_extended_type
    (if ext.oext_private = Asttypes.Private then " pri" else "")
    print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type)

and print_out_type_extension ppf te =
  let print_extended_type ppf =
    let print_type_parameter ppf ty =
      fprintf ppf "%s"
        (if ty = "_" then ty else "'"^ty)
    in
    match te.otyext_params with
      [] -> fprintf ppf "%s" te.otyext_name
    | [param] ->
      fprintf ppf "@[%a@ %s@]"
        print_type_parameter param
        te.otyext_name
    | _ ->
        fprintf ppf "@[(@[%a)@]@ %s@]"
          (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ "))
          te.otyext_params
          te.otyext_name
  in
  fprintf ppf "@[<hv 2>type %t +=%s@;<1 2>%a@]"
    print_extended_type
    (if te.otyext_private = Asttypes.Private then " pri" else "")
    (print_list print_out_constr (fun ppf -> fprintf ppf "@ | "))
    te.otyext_constructors

(* Phrases *)

let print_out_exception ppf exn outv =
  match exn with
    Sys.Break -> fprintf ppf "Interrupted.@."
  | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@."
  | Stack_overflow ->
      fprintf ppf "Stack overflow during evaluation (looping recursion?).@."
  | _ -> fprintf ppf "@[Exception:@ %a.@]@." print_out_value outv

let rec print_items ppf =
  function
    [] -> ()
  | (Osig_typext(ext, Oext_first), None) :: items ->
      (* Gather together extension constructors *)
      let rec gather_extensions acc items =
        match items with
            (Osig_typext(ext, Oext_next), None) :: items ->
              gather_extensions
                ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc)
                items
          | _ -> (List.rev acc, items)
      in
      let exts, items =
        gather_extensions
          [(ext.oext_name, ext.oext_args, ext.oext_ret_type)]
          items
      in
      let te =
        { otyext_name = ext.oext_type_name;
          otyext_params = ext.oext_type_params;
          otyext_constructors = exts;
          otyext_private = ext.oext_private }
      in
        fprintf ppf "@[%a@]" print_out_type_extension te;
        if items <> [] then fprintf ppf "@ %a" print_items items
  | (tree, valopt) :: items ->
      begin match valopt with
        Some v ->
          fprintf ppf "@[<2>%a =@ %a;@]" print_out_sig_item tree
            print_out_value v
      | None -> fprintf ppf "@[%a;@]" print_out_sig_item tree
      end;
      if items <> [] then fprintf ppf "@ %a" print_items items

let print_out_phrase ppf =
  function
    Ophr_eval (outv, ty) ->
      fprintf ppf "@[- : %a@ =@ %a@]@." print_out_type ty print_out_value outv
  | Ophr_signature [] -> ()
  | Ophr_signature items -> fprintf ppf "@[<v>%a@]@." print_items items
  | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv

end
module Reason_outcome_printer_main
= struct
#1 "reason_outcome_printer_main.ml"
(* This is used by js_main.ml *)
let setup  = lazy begin
  Oprint.out_value := Tweaked_reason_oprint.print_out_value;
  Oprint.out_type := Tweaked_reason_oprint.print_out_type;
  Oprint.out_class_type := Tweaked_reason_oprint.print_out_class_type;
  Oprint.out_module_type := Tweaked_reason_oprint.print_out_module_type;
  Oprint.out_sig_item := Tweaked_reason_oprint.print_out_sig_item;
  Oprint.out_signature := Tweaked_reason_oprint.print_out_signature;
  Oprint.out_type_extension := Tweaked_reason_oprint.print_out_type_extension;
  Oprint.out_phrase := Tweaked_reason_oprint.print_out_phrase
end  

end
module Super_misc : sig 
#1 "super_misc.mli"
(** Range coordinates all 1-indexed, like for editors. Otherwise this code
  would have way too many off-by-one errors *)
val print_file: is_warning:bool -> range:(int * int) * (int * int) -> lines:string array -> Format.formatter -> unit -> unit

end = struct
#1 "super_misc.ml"
(* This file has nothing to do with misc.ml in ocaml's source. Just thought it'd be an appropriate parallel to call it so *)

let fprintf = Format.fprintf

let string_slice ~start str =
  let last = String.length str in
  if last <= start then "" else String.sub str start (last - start)

let sp = Printf.sprintf

let number_of_digits n =
  let digits = ref 1 in
  let nn = ref n in
  while ((!nn) / 10) > 0 do (nn := ((!nn) / 10); digits := ((!digits) + 1))
    done;
  !digits

let pad ?(ch=' ') content n =
  (String.make (n - (String.length content)) ch) ^ content

let leading_space_count str =
  let rec _leading_space_count str str_length current_index =
    if current_index == str_length then current_index
    else if (str.[current_index]) <> ' ' then current_index 
    else _leading_space_count str str_length (current_index + 1)
  in
  _leading_space_count str (String.length str) 0

type current_printed_line_status = 
  | Is_error_start_line
  | Is_error_end_line
  | Strictly_between_start_and_end
  | Only_error_line
  | Not_error_line

(* Range coordinates all 1-indexed, like for editors. Otherwise this code
  would have way too many off-by-one errors *)
let print_file 
~is_warning 
(* start_line_start_char inclusive, end_line_end_char exclusive *)
~range:((start_line, start_line_start_char), (end_line, end_line_end_char)) 
~lines
ppf 
() =
  (* show 2 lines before & after the erroring lines. if there are too many lines, trim the middle *)
  let first_shown_line = max 1 (start_line - 2) in
  let last_shown_line = min (Array.length lines) (end_line + 2) in
  let max_line_number_number_of_digits = number_of_digits last_shown_line in
  (* sometimes the code's very indented, and we'd end up displaying quite a
    few columsn of leading whitespace; left-trim these. The general spirit is
    to center the erroring spot. In this case, almost literally *)
  (* to achieve this, go through the shown lines and check the minimum number of leading whitespaces *)
  let columns_to_cut = ref None in
  for i = first_shown_line to last_shown_line do
    let current_line = lines.(i - 1) in
    (* disregard lines that are empty or are nothing but whitespace *)
    if String.length (String.trim current_line) == 0 then ()
    else
      let current_line_leading_space_count = leading_space_count current_line in
      match !columns_to_cut with
      | None ->
        columns_to_cut := Some current_line_leading_space_count
      | Some n when n > current_line_leading_space_count ->
        columns_to_cut := Some current_line_leading_space_count
      | Some n -> ()
  done;
  let columns_to_cut = match !columns_to_cut with
  | None -> 0
  | Some n -> n
  in
  (* coloring *)
  let highlighted_line_number : _ format = if is_warning then "@{<info>%s@}%a" else "@{<error>%s@}%a" in

  let print_char_maybe_highlight ~begin_highlight_line ~end_highlight_line ch =
    let highlighted_open_tag: _ format = if is_warning then "@{<info>" else "@{<error>" in
    if begin_highlight_line then fprintf ppf highlighted_open_tag;
    fprintf ppf "%c@," ch;
    if end_highlight_line then fprintf ppf "@}"
  in

  let print_separator ppf () = 
    (* these are unicode chars. They're not of length 1. Careful; we need to
      explicitly tell Format to treat them as length 1 *)
    if columns_to_cut = 0 then fprintf ppf " @{<dim>@<1>│@} "
    else fprintf ppf " @{<dim>@<1>┆@} "
  in

  fprintf ppf "@[<v 0>";
  (* inclusive *)
  for i = first_shown_line to last_shown_line do
    (* should some lines be ellipsed from the output? If we're showing more than 5 lines, then yes *)
    if end_line - start_line >= 5 && i >= start_line + 2 && i <= end_line - 2 then begin
      if i = start_line + 2 then
        (* Insert one line that's just a dimmed "..." *)
        let padded_line_number = pad "." max_line_number_number_of_digits in
        fprintf ppf "@{<dim>%s@}%a@{<dim>...@}@," padded_line_number print_separator ()
      end
    else
      let current_line = lines.(i - 1) in
      let padded_line_number = pad (string_of_int i) max_line_number_number_of_digits in

      fprintf ppf "@[<h 0>";

      fprintf ppf "@[<h 0>";

      if i < start_line || i > end_line then begin
        (* normal, non-highlighted line *)
        fprintf ppf "%s%a" padded_line_number print_separator ()
      end else begin
        (* highlighted *)
        fprintf ppf highlighted_line_number padded_line_number print_separator ()
      end;

      fprintf ppf "@]"; (* h *)

      fprintf ppf "@[<hov 0>";

      let current_line_status = 
        if i > start_line && i < end_line then Strictly_between_start_and_end
        else if i = start_line && i = end_line then Only_error_line
        else if i = start_line then Is_error_start_line
        else if i = end_line then Is_error_end_line
        else Not_error_line
      in
      let offset_current_line = current_line |> string_slice ~start:columns_to_cut in
      let offset_current_line_length = String.length offset_current_line in
      let offset_start_line_start_char = start_line_start_char - columns_to_cut in
      (* end_line_end_char is exclusive *)
      let offset_end_line_end_char = end_line_end_char - columns_to_cut in
      (* inclusive. To be consistent with using 1-indexed indices and count and i, j will be 1-indexed too *)
      for j = 1 to offset_current_line_length do
        let current_char = offset_current_line.[j - 1] in
        match current_line_status with
        | Strictly_between_start_and_end -> 
          print_char_maybe_highlight 
            ~begin_highlight_line:(j = 1) 
            ~end_highlight_line:(j = offset_current_line_length)
            current_char 
        | Only_error_line ->
          print_char_maybe_highlight 
            ~begin_highlight_line:(j = offset_start_line_start_char) 
            ~end_highlight_line:(j = offset_end_line_end_char)
            current_char 
        | Is_error_start_line ->
          print_char_maybe_highlight 
            ~begin_highlight_line:(j = offset_start_line_start_char) 
            ~end_highlight_line:(j = offset_current_line_length)
            current_char 
        | Is_error_end_line ->
          print_char_maybe_highlight 
            ~begin_highlight_line:(j = 1) 
            ~end_highlight_line:(j = offset_end_line_end_char)
            current_char 
        | Not_error_line ->
          print_char_maybe_highlight 
            ~begin_highlight_line:false 
            ~end_highlight_line:false
            current_char 
    done;

    fprintf ppf "@]"; (* hov *)

    fprintf ppf "@]@," (* h *)

  done;
  fprintf ppf "@]" (* v *)

end
module Super_warnings
= struct
#1 "super_warnings.ml"
let fprintf = Format.fprintf
(* taken from https://github.com/BuckleScript/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/utils/warnings.ml#L251 *)
(* actual modified message branches are commented *)
let message (warning : Warnings.t)  =
  match warning with
  | Partial_match "" ->
      "You forgot to handle a possible case here, though we don't have more information on the value."
  | Partial_match s ->
      "You forgot to handle a possible case here, for example: \n" ^ s
  | Unerasable_optional_argument ->
      String.concat ""
        ["This optional parameter in final position will, in practice, not be optional.\n";
        "  Reorder the parameters so that at least one non-optional one is in final position or, if all parameters are optional, insert a final ().\n\n";
        "  Explanation: If the final parameter is optional, it'd be unclear whether a function application that omits it should be considered fully applied, or partially applied. Imagine writing `let title = display(\"hello!\")`, only to realize `title` isn't your desired result, but a curried call that takes a final optional argument, e.g. `~showDate`.\n\n";
        "  Formal rule: an optional argument is considered intentionally omitted when the 1st positional (i.e. neither labeled nor optional) argument defined after it is passed in."
        ]
  | Bad_module_name (modname) ->
      "This file's name is potentially invalid. The build systems conventionally turn a file name into a module name by upper-casing the first letter. " ^ modname ^ " isn't a valid module name.\n" ^
      "Note: some build systems might e.g. turn kebab-case into CamelCase module, which is why this isn't a hard error."
  | Statement_type -> "This expression returns a value, but you're not doing anything with it. If this is on purpose, wrap it with `ignore`."
  | Useless_record_with ->
      "All the fields are already explicitly listed in this record. You can remove the `...` spread."
  | _ -> Warnings.message warning
;;

end
module Super_location
= struct
#1 "super_location.ml"
open Misc
open Asttypes
open Parsetree
open Types
open Typedtree
open Btype
open Ctype

open Format
open Printtyp

open Location

let file_lines filePath =
  (* open_in_bin works on windows, as opposed to open_in, afaik? *)
  let chan = open_in_bin filePath in
  let lines = ref [] in
  try
    while true do
      lines := (input_line chan) :: !lines
     done;
     (* leave this here to make things type. The loop will definitly raise *)
     [||]
  with
  | End_of_file -> begin
      close_in chan;
      List.rev (!lines) |> Array.of_list
    end

let setup_colors () =
  Misc.Color.setup !Clflags.color

let print_filename ppf file =
  match file with
  (* modified *)
  | "_none_"
  | "" -> Format.fprintf ppf "(No file name)"
  | real_file -> Format.fprintf ppf "%s" (Location.show_filename real_file)

let print_loc ~normalizedRange ppf loc =
  setup_colors ();
  let (file, _, _) = Location.get_pos_info loc.loc_start in
  if file = "//toplevel//" then begin
    if highlight_locations ppf [loc] then () else
      fprintf ppf "Characters %i-%i"
              loc.loc_start.pos_cnum loc.loc_end.pos_cnum
  end else
    let dim_loc ppf = function
    | None -> ()
    | Some ((start_line, start_line_start_char), (end_line, end_line_end_char)) ->
      if start_line = end_line then
        if start_line_start_char = end_line_end_char then
          fprintf ppf " @{<dim>%i:%i@}" start_line start_line_start_char
        else
          fprintf ppf " @{<dim>%i:%i-%i@}" start_line start_line_start_char end_line_end_char
      else
        fprintf ppf " @{<dim>%i:%i-%i:%i@}" start_line start_line_start_char end_line end_line_end_char
    in
    fprintf ppf "@{<filename>%a@}%a" print_filename file dim_loc normalizedRange
;;

let print ~message_kind intro ppf loc =
  if loc.loc_start.pos_fname = "//toplevel//"
  && highlight_locations ppf [loc] then ()
  else
    begin match message_kind with
    | `warning -> fprintf ppf "@[@{<info>%s@}@]@," intro
    | `warning_as_error -> fprintf ppf "@[@{<error>%s@} (configured as error) @]@," intro
    | `error -> fprintf ppf "@[@{<error>%s@}@]@," intro
    end;
    (* ocaml's reported line/col numbering is horrible and super error-prone
      when being handled programmatically (or humanly for that matter. If you're
      an ocaml contributor reading this: who the heck reads the character count
      starting from the first erroring character?) *)
    let (file, start_line, start_char) = Location.get_pos_info loc.loc_start in
    let (_, end_line, end_char) = Location.get_pos_info loc.loc_end in
    (* line is 1-indexed, column is 0-indexed. We convert all of them to 1-indexed to avoid confusion *)
    (* start_char is inclusive, end_char is exclusive *)
    let normalizedRange =
      if start_char == -1 || end_char == -1 then
        (* happens sometimes. Syntax error for example *)
        None
      else if start_line = end_line && start_char >= end_char then
        (* in some errors, starting char and ending char can be the same. But
           since ending char was supposed to be exclusive, here it might end up
           smaller than the starting char if we naively did start_char + 1 to
           just the starting char and forget ending char *)
        let same_char = start_char + 1 in
        Some ((start_line, same_char), (end_line, same_char))
      else
        (* again: end_char is exclusive, so +1-1=0 *)
        Some ((start_line, start_char + 1), (end_line, end_char))
    in
    fprintf ppf "@[%a@]@," (print_loc ~normalizedRange) loc;
    match normalizedRange with
    | None -> ()
    | Some range -> begin
      try
        let lines = file_lines file in
        (* we're putting the line break `@,` here rather than above, because this
           branch might not be reached (aka no inline file content display) so
           we don't wanna end up with two line breaks in the the consequent *)
        fprintf ppf "@,%a"
          (Super_misc.print_file ~is_warning:(message_kind=`warning) ~lines ~range)
          ()
      with
      (* this might happen if the file is e.g. "", "_none_" or any of the fake file name placeholders.
        we've already printed the location above, so nothing more to do here. *)
      | Sys_error _ -> ()
    end
;;

(* taken from https://github.com/BuckleScript/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/parsing/location.ml#L380 *)
(* This is the error report entry point. We'll replace the default reporter with this one. *)
let rec super_error_reporter ppf ({Location.loc; msg; sub; if_highlight} as err) =
  let highlighted =
    if if_highlight <> "" then
      let rec collect_locs locs {Location.loc; sub; if_highlight; _} =
        List.fold_left collect_locs (loc :: locs) sub
      in
      let locs = collect_locs [] err in
      Location.highlight_locations ppf locs
    else
      false
  in
  if highlighted then
    Format.pp_print_string ppf if_highlight
  else begin
    setup_colors ();
    (* open a vertical box. Everything in our message is indented 2 spaces *)
    Format.fprintf ppf "@[<v 2>@,%a@,%s@,@]" (print ~message_kind:`error "We've found a bug for you!") loc msg;
    List.iter (Format.fprintf ppf "@,@[%a@]" super_error_reporter) sub;
    (* no need to flush here; location's report_exception (which uses this ultimately) flushes *)
  end

(* extracted from https://github.com/BuckleScript/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/parsing/location.ml#L299 *)
(* This is the warning report entry point. We'll replace the default printer with this one *)
let super_warning_printer loc ppf w =

  match Warnings.report w with
  | `Inactive -> ()
  | `Active { Warnings. number; message; is_error; sub_locs } ->
    setup_colors ();
    let message_kind = if is_error then `warning_as_error else `warning in
    Format.fprintf ppf "@[<v 2>@,%a@,%s@,@]"
      (print ~message_kind ("Warning number " ^ (Warnings.number w |> string_of_int)))
      loc
      (Super_warnings.message w);
    (* at this point, you can display sub_locs too, from e.g. https://github.com/ocaml/ocaml/commit/f6d53cc38f87c67fbf49109f5fb79a0334bab17a
      but we won't bother for now *)

;;

(* taken from https://github.com/BuckleScript/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/parsing/location.ml#L354 *)
let print_phanton_error_prefix ppf =
  (* modified from the original. We use only 2 indentations for error report
    (see super_error_reporter above) *)
  Format.pp_print_as ppf 2 ""

let errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") fmt =
  Location.pp_ksprintf
    ~before:print_phanton_error_prefix
    (fun msg -> {loc; msg; sub; if_highlight})
    fmt

let error_of_printer loc print x =
  errorf ~loc "%a@?" print x

let error_of_printer_file print x =
  error_of_printer (in_file !input_name) print x

(* This will be called in super_main. This is how you override the default error and warning printers *)
let setup () =
  Location.error_reporter := super_error_reporter;
  Location.warning_printer := super_warning_printer;

end
module Super_env
= struct
#1 "super_env.ml"
let fprintf = Format.fprintf

(* taken from https://github.com/BuckleScript/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/typing/env.ml#L1842 *)
(* modified branches are commented *)
let report_error ppf = function
  | Env.Illegal_renaming(name, modname, filename) ->
      (* modified *)
      fprintf ppf
        "@[You referred to the module %s, but we've found one called %s instead.@ \
          Is the name's casing right?@]"
        name modname
  | Inconsistent_import(name, source1, source2) ->
      (* modified *)
     fprintf ppf "@[<v>\
        @[@{<info>It's possible that your build is stale.@}@ Try to clean the artifacts and build again?@]@,@,\
        @[@{<info>Here's the original error message@}@]@,\
      @]";
      fprintf ppf
        "@[<hov>The files %a@ and %a@ \
              make inconsistent assumptions@ over interface %s@]"
      Location.print_filename source1 Location.print_filename source2 name
  | Need_recursive_types(import, export) ->
      fprintf ppf
        "@[<hov>Unit %s imports from %s, which uses recursive types.@ %s@]"
        export import "The compilation flag -rectypes is required"

  | Depend_on_unsafe_string_unit(import, export) ->
      fprintf ppf
        "@[<hov>Unit %s imports from %s, compiled with -unsafe-string.@ %s@]"
        export import "This compiler has been configured in strict \
                       safe-string mode (-force-safe-string)"

  | Missing_module(_, path1, path2) ->
      fprintf ppf "@[@[<hov>";
      if Path.same path1 path2 then
        fprintf ppf "Internal path@ %s@ is dangling." (Path.name path1)
      else
        fprintf ppf "Internal path@ %s@ expands to@ %s@ which is dangling."
          (Path.name path1) (Path.name path2);
      fprintf ppf "@]@ @[%s@ %s@ %s.@]@]"
        "The compiled interface for module" (Ident.name (Path.head path2))
        "was not found"
  | Illegal_value_name(_loc, name) ->
      fprintf ppf "'%s' is not a valid value identifier."
        name

(* This will be called in super_main. This is how you'd override the default error printer from the compiler & register new error_of_exn handlers *)
let setup () =
  Location.register_error_of_exn
    (function
      | Env.Error (Missing_module (loc, _, _)
              | Illegal_value_name (loc, _)
               as err) when loc <> Location.none ->
          Some (Super_location.error_of_printer loc report_error err)
      | Env.Error err -> Some (Super_location.error_of_printer_file report_error err)
      | _ -> None
    )

end
module Super_pparse
= struct
#1 "super_pparse.ml"
let fprintf = Format.fprintf

(* taken from https://github.com/BuckleScript/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/driver/pparse.ml#L170 *)
(* modified branches are commented *)
let report_error ppf () = 
      fprintf ppf
        "@[<v>@{<info>There's been an error running Reason's parser on a file.@}@,\
          The error location should be slightly above this message.@,\
          @[Please file an issue on@ github.com/facebook/reason.@ Thanks!@]@]"


let setup () =
  Location.register_error_of_exn
    (function
      | Ast_reason_pp.Pp_error -> 
        Some (Super_location.error_of_printer_file report_error ())
      | _ -> None
    )

end
module Super_reason_react : sig 
#1 "super_reason_react.mli"
val component_spec_weak_type_variables: Types.type_expr -> bool * bool * bool
(** Used by super_typemod when we detect the message "... contains type variables that cannot be generalized" *)

val component_spec_weak_type_variables_in_module_type: Types.module_type -> (bool * bool * bool) list
(** Used by super_typemod when we detect the message "... contains type variables that cannot be generalized" *)

val state_escape_scope: (Types.type_expr * Types.type_expr) list -> bool
(** Used by super_typecore when we detect the message "The type constructor state would escape its scope" *)

val trace_both_component_spec: (Types.type_expr * Types.type_expr) list -> bool
(** Used by super_typecore when we detect the message "The type constructor state would escape its scope" *)

val is_component_spec_wanted_react_element: (Types.type_expr * Types.type_expr) list -> bool
(** Used by super_typecore when we detect the message "This has type componentSpec but expected reactElement" *)

end = struct
#1 "super_reason_react.ml"
(* This file detects common error from
  [ReasonReact](https://reasonml.github.io/reason-react/) and provide
  situation-specific hints. See the mli file to see which heurisics we detect
  and related comments *)
open Types

let rec drill_through_tlink_and_tsubst t =
  match t.desc with
  | Tlink t
  | Tsubst t -> drill_through_tlink_and_tsubst t
  | _ -> t

let is_weak_type_after_drilling t =
  match drill_through_tlink_and_tsubst t with
  | {desc = Tvar _} -> true
  | _ -> false

let component_spec_weak_type_variables t =
  match drill_through_tlink_and_tsubst t with
  (* ReasonReact <=0.3.4 *)
  | {desc = Tconstr (
      Pdot ((Pident {name = "ReasonReact"}), "componentSpec", _),
      [state; _initial_state; retained_props; _initial_retained_props; action],
      _
    )} ->
    (
      state |> is_weak_type_after_drilling,
      retained_props |> is_weak_type_after_drilling,
      action |> is_weak_type_after_drilling
    )
  (* future ReasonReact version with retainedProps removed *)
  | {desc = Tconstr (
      Pdot ((Pident {name = "ReasonReact"}), "componentSpec", _),
      [state; _initial_state; action],
      _
    )} ->
    (
      state |> is_weak_type_after_drilling,
      false,
      action |> is_weak_type_after_drilling
    )
  | _ -> (false, false, false)

let component_spec_weak_type_variables_in_module_type (mty : Types.module_type) =
  match mty with
  | Mty_signature signature_values ->
      signature_values
        |> List.map (function
          | Sig_value (_id, value_desc) ->
            let typ = value_desc.val_type in
            component_spec_weak_type_variables typ
          | _ -> (false, false, false)
        )
        |> List.filter (function
          | (false, false, false) -> false
          | _ -> true
        )
  | _ -> []

(* `trace` is a funny data structure. It's an always even list of tuples. This error:
  this is foo (aliased as array(int)), wanted bar (aliased as array(string))
  the incompatible part: int vs string
  gives the following `trace` data structure:
  [
    (foo, array(int)),
    (bar, array(string)),
    (_, int),
    (_, string)
  ]
 *)
(* recursively walk the trace from right to left, calling f and checking if f matches part of the trace *)
let check_each_trace_chunk_bottom_up f = fun t ->
  let t_flipped = List.rev t in
  let rec check f = function
  (* we flipped the trace, so instead of [t1, t2, t3, t4, ...] it's [t4, t3, ...] *)
  | (_alias2, type2) :: (_alias1, type1) :: rest ->
    if f (type1, type2) then true
    else check f rest
  | _ -> false
  in
  check f t_flipped


let state_escape_scope = check_each_trace_chunk_bottom_up (function
  (* https://github.com/BuckleScript/ocaml/blob/ddf5a739cc0978dab5e553443825791ba7b0cef9/typing/printtyp.ml?#L1348 *)
  (* so apparently that's the logic for detecting "the constructor out of scope" error *)
  | ({desc = Tconstr (p, _, _)}, {desc = Tvar _; level})
    when level < Path.binding_time p -> true
  | _ -> false
)

let trace_both_component_spec = check_each_trace_chunk_bottom_up (function
  | ({desc = Tconstr (
      (Pdot ((Pident {name = "ReasonReact"}), "componentSpec", _)),
      ([state1; _; _; _; action1] | [state1; _; action1]),
      _
    )},
    {desc = Tconstr (
      (Pdot ((Pident {name = "ReasonReact"}), "componentSpec", _)),
      ([state2; _; _; _; action2] | [state2; _; action2]),
      _
    )})
    -> true
  | _ -> false
)

let is_component_spec_wanted_react_element = check_each_trace_chunk_bottom_up (function
  | ({desc = Tconstr (
      (Pdot ((Pident {name = "ReasonReact"}), "componentSpec", _)),
      ([state1; _; _; _; action1] | [state1; _; action1]),
      _
    )},
    {desc = Tconstr (
      (Pdot ((Pident {name = "ReasonReact"}), "reactElement", _)),
      _,
      _
    )}) -> true
  | _ -> false
)

end
module Super_typecore
= struct
#1 "super_typecore.ml"
open Misc
open Asttypes
open Parsetree
open Types
open Typedtree
open Btype
open Ctype

let fprintf = Format.fprintf
let sprintf = Format.sprintf
let longident = Printtyp.longident
let super_report_unification_error = Printtyp.super_report_unification_error
let reset_and_mark_loops = Printtyp.reset_and_mark_loops
let type_expr = Printtyp.type_expr

let tagged tag fn ppf arg =
    Format.pp_open_tag ppf tag;
    fn ppf arg;
    Format.pp_close_tag ppf ()

let rec bottom_aliases = function
  | (_, one) :: (_, two) :: rest -> begin match bottom_aliases rest with
    | Some types -> Some types
    | None -> Some (one, two)
  end
  | _ -> None

let simple_conversions = [
  (("float", "int"), "int_of_float");
  (("int", "float"), "float_of_int");
  (("int", "string"), "string_of_int");
  (("float", "string"), "string_of_float");
]

let print_simple_conversion ppf (actual, expected) =
  try (
    let converter = List.assoc (actual, expected) simple_conversions in
    Format.pp_print_newline ppf ();
    Format.pp_print_newline ppf ();
    fprintf ppf "You can convert a @{<info>%s@} to a @{<info>%s@} with @{<info>%s@}." actual expected converter
  ) with | Not_found -> ()

let print_simple_message ppf = function
  | ("float", "int") -> fprintf ppf "@[If this is a literal, you want a number without a trailing dot (e.g. @{<info>20@}).@]"
  | ("int", "float") -> fprintf ppf "@[If this is a literal, you want a number with a trailing dot (e.g. @{<info>20.@}).@]"
  | _ -> ()

let show_extra_help ppf env trace = begin
  match bottom_aliases trace with
  | Some ({desc = Tconstr (actualPath, actualArgs, _)}, {desc = Tconstr (expectedPath, expextedArgs, _)}) -> begin
    match (actualPath, actualArgs, expectedPath, expextedArgs) with
    | (Pident {name = actualName}, [], Pident {name = expectedName}, []) -> begin
      print_simple_conversion ppf (actualName, expectedName);
      print_simple_message ppf (actualName, expectedName);
    end
    | _ -> ()
  end;
  | _ -> ();
end

(* given type1 is foo => bar => baz(qux) and type 2 is bar => baz(qux), return Some(foo) *)
let rec collect_missing_arguments env type1 type2 = match type1 with
  (* why do we use Ctype.matches here? Please see https://github.com/BuckleScript/bucklescript/pull/2554 *)
  | {desc=Tarrow (label, argtype, typ, _)} when Ctype.matches env typ type2 ->
    Some [(label, argtype)]
  | {desc=Tarrow (label, argtype, typ, _)} -> begin
    match collect_missing_arguments env typ type2 with
    | Some res -> Some ((label, argtype) :: res)
    | None -> None
    end
  | _ -> None

let check_bs_arity_mismatch ppf trace =
  let arity t = match t.desc with
    | Tvariant { row_fields = [(label,_)] } ->
        let label_len = String.length label in
        let arity_str = "Arity_" in
        let arity_len = String.length arity_str in
        if arity_len < label_len &&
          String.sub label 0 arity_len = arity_str
        then
          try
            Some (int_of_string (String.sub label arity_len (label_len-arity_len)))
          with _ -> None
        else None
    | _ ->
        None in
  let check_mismatch t1 t2 = match (arity t1, arity t2) with
    | Some n1, Some n2 ->
        fprintf ppf "@[@{<info>Found uncurried application [@bs] with arity %d, where arity %d was expected.@}@]" n1 n2;
        true
    | None, _
    | _, None ->
        false in
  let rec traverse = function
    | (_arity1, type1) :: (_arity2, type2) :: rest ->
        if traverse rest
        then true
        else check_mismatch type1 type2
    | _ ->
        false in
  ignore (traverse trace)

let print_expr_type_clash env trace ppf =
  (* this is the most frequent error. Do whatever we can to provide specific
    guidance to this generic error before giving up *)
  if Super_reason_react.state_escape_scope trace && Super_reason_react.trace_both_component_spec trace then
    fprintf ppf "@[<v>\
      @[@{<info>Is this a ReasonReact reducerComponent or component with retained props?@}@ \
      If so, is the type for state, retained props or action declared _after_@ the component declaration?@ \
      @{<info>Moving these types above the component declaration@} should resolve this!@]\
    @]"
    (* This one above shouldn't catch any false positives, so we can safely not display the original type clash error. *)
  else if Super_reason_react.is_component_spec_wanted_react_element trace then
    fprintf ppf "@[<v>\
      @[@{<info>Did you want to create a ReasonReact element without using JSX?@}@ If not, disregard this.@ \
      If so, don't forget to wrap this value in `ReasonReact.element` yourself:@ https://reasonml.github.io/reason-react/docs/en/jsx.html#capitalized@]@,@,\
      @[@{<info>Here's the original error message@}@]@,\
    @]";
    begin
    let bottom_aliases_result = bottom_aliases trace in
    let missing_arguments = match bottom_aliases_result with
    | Some (actual, expected) -> collect_missing_arguments env actual expected
    | None -> assert false
    in
    let print_arguments =
      Format.pp_print_list
        ~pp_sep:(fun ppf _ -> fprintf ppf ",@ ")
        (fun ppf (label, argtype) ->

          match label with
          | Nolabel -> fprintf ppf "@[%a@]" type_expr argtype
          | Labelled label ->
            fprintf ppf "@[(~%s: %a)@]" label type_expr argtype
          | Optional label ->
            fprintf ppf "@[(?%s: %a)@]" label type_expr argtype

        )
    in
    match missing_arguments with
    | Some [singleArgument] ->
      (* btw, you can't say "final arguments". Intermediate labeled
        arguments might be the ones missing *)
      fprintf ppf "@[@{<info>This call is missing an argument@} of type@ %a@]"
        print_arguments [singleArgument]
    | Some arguments ->
      fprintf ppf "@[<hv>@{<info>This call is missing arguments@} of type:@ %a@]"
        print_arguments arguments
    | None ->
      let missing_parameters = match bottom_aliases_result with
      | Some (actual, expected) -> collect_missing_arguments env expected actual
      | None -> assert false
      in
      begin match missing_parameters with
      | Some [singleParameter] ->
        fprintf ppf "@[This value might need to be @{<info>wrapped in a function@ that@ takes@ an@ extra@ parameter@}@ of@ type@ %a@]@,@,"
          print_arguments [singleParameter];
        fprintf ppf "@[@{<info>Here's the original error message@}@]@,"
      | Some arguments ->
        fprintf ppf "@[This value seems to @{<info>need to be wrapped in a function that takes extra@ arguments@}@ of@ type:@ @[<hv>%a@]@]@,@,"
          print_arguments arguments;
        fprintf ppf "@[@{<info>Here's the original error message@}@]@,"
      | None -> ()
      end;
      (* final fallback: show the generic type mismatch error *)
      check_bs_arity_mismatch ppf trace;
      super_report_unification_error ppf env trace
        (function ppf ->
            fprintf ppf "This has type:")
        (function ppf ->
            fprintf ppf "But somewhere wanted:");
      show_extra_help ppf env trace;
    end

(* taken from https://github.com/BuckleScript/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/typing/typecore.ml#L3769 *)
(* modified branches are commented *)
let report_error env ppf = function
  | Typecore.Constructor_arity_mismatch(lid, expected, provided) ->
      (* modified *)
      fprintf ppf
       "@[This variant constructor, %a, expects %i %s; here, we've %sfound %i.@]"
       longident lid expected (if expected == 1 then "argument" else "arguments") (if provided < expected then "only " else "") provided
  | Label_mismatch(lid, trace) ->
      (* modified *)
      super_report_unification_error ppf env trace
        (function ppf ->
           fprintf ppf "The record field %a@ belongs to the type"
                   longident lid)
        (function ppf ->
           fprintf ppf "but is mixed here with fields of type")
  | Pattern_type_clash trace ->
      (* modified *)
      super_report_unification_error ppf env trace
        (function ppf ->
          fprintf ppf "This pattern matches values of type")
        (function ppf ->
          fprintf ppf "but a pattern was expected which matches values of type")
  | Or_pattern_type_clash (id, trace) ->
      (* modified *)
      super_report_unification_error ppf env trace
        (function ppf ->
          fprintf ppf "The variable %s on the left-hand side of this or-pattern has type" (Ident.name id))
        (function ppf ->
          fprintf ppf "but on the right-hand side it has type")
  | Expr_type_clash trace ->
      (* modified *)
      fprintf ppf "@[<v>";
      print_expr_type_clash env trace ppf;
      fprintf ppf "@]"
  | Apply_non_function typ ->
      (* modified *)
      reset_and_mark_loops typ;
      begin match (repr typ).desc with
        Tarrow (_, _inputType, returnType, _) ->
          let rec countNumberOfArgs count {desc} = match desc with
          | Tarrow (_, _inputType, returnType, _) -> countNumberOfArgs (count + 1) returnType
          | _ -> count
          in
          let countNumberOfArgs = countNumberOfArgs 1 in
          let acceptsCount = countNumberOfArgs returnType in
          fprintf ppf "@[<v>@[<2>This function has type@ @{<info>%a@}@]"
            type_expr typ;
          fprintf ppf "@ @[It only accepts %i %s; here, it's called with more.@]@]"
                      acceptsCount (if acceptsCount == 1 then "argument" else "arguments")
      | Tconstr (
          (Path.Pdot (((Pdot (Path.Pident {name="Js"}, "Internal", _)) | (Pident {name="Js_internal"})), ("fn" | "meth"), _)),
          _,
          _
        )
        ->
          fprintf
            ppf
            "@[<v>This is an uncurried BuckleScript function. @{<info>It must be applied with a dot@}.@,@,\
            Like this: @{<info>foo(. a, b)@}@,\
            Not like this: @{<dim>foo(a, b)@}@,@,\
            This guarantees that your function is fully applied. More info here:@,\
            https://bucklescript.github.io/docs/en/function.html#solution-guaranteed-uncurrying@]"
      | _ ->
          fprintf ppf "@[<v>@[<2>This expression has type@ %a@]@ %s@]"
            type_expr typ
            "It is not a function."
      end
  | Coercion_failure (ty, ty', trace, b) ->
      (* modified *)
      super_report_unification_error ppf env trace
        (function ppf ->
           let ty, ty' = Printtyp.prepare_expansion (ty, ty') in
           fprintf ppf
             "This expression cannot be coerced to type@;<1 2>%a;@ it has type"
           (Printtyp.type_expansion ty) ty')
        (function ppf ->
           fprintf ppf "but is here used with type");
      if b then
        fprintf ppf ".@.@[<hov>%s@ %s@]"
          "This simple coercion was not fully general."
          "Consider using a double coercion."
  | Too_many_arguments (in_function, ty) ->
      (* modified *)
      reset_and_mark_loops ty;
      if in_function then begin
        fprintf ppf "@[This function expects too many arguments,@ ";
        fprintf ppf "it should have type@ %a@]"
          type_expr ty
      end else begin
        fprintf ppf "@[This expression should not be a function,@ ";
        fprintf ppf "the expected type is@ %a@]"
          type_expr ty
      end
  | Less_general (kind, trace) ->
      (* modified *)
      super_report_unification_error ppf env trace
        (fun ppf -> fprintf ppf "This %s has type" kind)
        (fun ppf -> fprintf ppf "which is less general than")
  | Recursive_local_constraint trace ->
      (* modified *)
      super_report_unification_error ppf env trace
        (function ppf ->
           fprintf ppf "Recursive local constraint when unifying")
        (function ppf ->
           fprintf ppf "with")
  | anythingElse ->
      Typecore.super_report_error_no_wrap_printing_env env ppf anythingElse

let report_error env ppf err =
  Printtyp.wrap_printing_env env (fun () -> report_error env ppf err)

(* This will be called in super_main. This is how you'd override the default error printer from the compiler & register new error_of_exn handlers *)
let setup () =
  Location.register_error_of_exn
    (function
      | Typecore.Error (loc, env, err) ->
        Some (Super_location.error_of_printer loc (report_error env) err)
      | Typecore.Error_forward err ->
        Some err
      | _ ->
        None
    )

end
module Super_typemod
= struct
#1 "super_typemod.ml"
open Printtyp

let fprintf = Format.fprintf

let non_generalizable_msg ppf ~result ~is_module print_fallback_msg =
  let contain_vs_be =
    if is_module then "This module seems to contain" else "This seems to be" in
  match result with
  | (_, true, _) :: _ ->
    fprintf ppf "@[<v>\
      @{<info>%s a ReasonReact reducerComponentWithRetainedProps?@}@ \
      The retained props feature is deprecated.@ \
      Please use a regular @{<info>reducerComponent@} and keep the props you want to retain in state.\
    @]"
    contain_vs_be
  | (true, _, _) :: _->
    fprintf ppf "@[<v>\
      @[\
        @{<info>%s a ReasonReact reducerComponent?@}@ \
        We don't have@ all@ the@ type@ info@ for@ its@ @{<info>state@}.@ \
        Make sure you've done the following: @]@,@,\
        @[- Define the component `make` function@]@,\
        @[- Define `reducer` in that `make` body@]@,\
        @[- Annotate reducer's second parameter (state) with the desired state type\
      @]\
    @]"
    contain_vs_be
  | (_, _, true) :: _->
    fprintf ppf "@[<v>\
      @[\
        @{<info>%s a ReasonReact reducerComponent?@}@ \
        We don't have@ all@ the@ type@ info@ for@ its@ @{<info>action@}.@ \
        Make sure you've done the following: @]@,@,\
        @[- Define the component `make` function@]@,\
        @[- Define `reducer` in that `make` body@]@,\
        @[- Annotate reducer's first parameter (action) with the desired action type\
      @]\
    @]"
    contain_vs_be
  | _ ->
    fprintf ppf
      "%a@,@,\
      @[This happens when the type system senses there's a mutation/side-effect,@ in combination with a polymorphic value.@,\
      @{<info>Using or annotating that value usually solves it.@}@ \
      More info:@ https://realworldocaml.org/v1/en/html/imperative-programming-1.html#side-effects-and-weak-polymorphism@]"
    print_fallback_msg ()

(* taken from https://github.com/BuckleScript/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/typing/typemod.ml#L1754 *)
(* modified branches are commented *)
let report_error ppf = function
  | Typemod.Non_generalizable typ ->
      (* modified *)
      fprintf ppf "@[<v>";
      non_generalizable_msg
        ppf
        ~result:([Super_reason_react.component_spec_weak_type_variables typ])
        ~is_module:false
        (fun ppf () ->
          fprintf ppf
          "@[This expression's type contains type variables that can't be generalized:@,@{<error>%a@}@]"
          type_scheme typ);
      fprintf ppf "@]"
  | Non_generalizable_module mty ->
      (* modified *)
      fprintf ppf "@[<v>";
      non_generalizable_msg
        ppf
        ~result:(Super_reason_react.component_spec_weak_type_variables_in_module_type mty)
        ~is_module:true
        (fun ppf () ->
          fprintf ppf
            "@[The type of this module contains type variables that cannot be generalized:@,@{<error>%a@}@]"
            modtype mty);
        fprintf ppf "@]"
  | anythingElse ->
      Typemod.super_report_error_no_wrap_printing_env ppf anythingElse

let report_error env ppf err =
  Printtyp.wrap_printing_env env (fun () -> report_error ppf err)

(* This will be called in super_main. This is how you'd override the default error printer from the compiler & register new error_of_exn handlers *)
let setup () =
  Location.register_error_of_exn
    (function
      | Typemod.Error (loc, env, err) ->
        Some (Super_location.error_of_printer loc (report_error env) err)
      | Typemod.Error_forward err ->
        Some err
      | _ ->
        None
    )

end
module Super_typetexp
= struct
#1 "super_typetexp.ml"
open Misc
open Asttypes
open Parsetree
open Types
open Typedtree
open Btype
open Ctype

open Format
open Printtyp

(* taken from https://github.com/BuckleScript/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/typing/typetexp.ml#L869 *)
let spellcheck ppf fold env lid =
  let cutoff =
    match String.length (Longident.last lid) with
      | 1 | 2 -> 0
      | 3 | 4 -> 1
      | 5 | 6 -> 2
      | _ -> 3
  in
  let compare target head acc =
    let (best_choice, best_dist) = acc in
    match Misc.edit_distance target head cutoff with
      | None -> (best_choice, best_dist)
      | Some dist ->
        let choice =
          if dist < best_dist then [head]
          else if dist = best_dist then head :: best_choice
          else best_choice in
        (choice, min dist best_dist)
  in
  let init = ([], max_int) in
  let handle (choice, _dist) =
    match List.rev choice with
      | [] -> ()
      | last :: rev_rest ->
        (* the modified part *)
        fprintf ppf "@[<v 2>@,@,@{<info>Hint: Did you mean %s%s%s?@}@]"
          (String.concat ", " (List.rev rev_rest))
          (if rev_rest = [] then "" else " or ")
          last
  in
  (* flush now to get the error report early, in the (unheard of) case
     where the linear search would take a bit of time; in the worst
     case, the user has seen the error, she can interrupt the process
     before the spell-checking terminates. *)
  fprintf ppf "@?";
  match lid with
    | Longident.Lapply _ -> ()
    | Longident.Lident s ->
      handle (fold (compare s) None env init)
    | Longident.Ldot (r, s) ->
      handle (fold (compare s) (Some r) env init)

let spellcheck ppf fold =
  spellcheck ppf (fun f -> fold (fun s _ _ x -> f s x))

let fold_descr fold get_name f = fold (fun descr acc -> f (get_name descr) acc)
let fold_constructors x  = fold_descr Env.fold_constructors (fun d -> d.cstr_name) x
let fold_labels x = fold_descr Env.fold_labels (fun d -> d.lbl_name) x

(* taken from https://github.com/BuckleScript/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/typing/typetexp.ml#L918 *)
(* modified branches are commented *)
let report_error env ppf = function
  | Typetexp.Unbound_type_constructor lid ->
    (* modified *)
    fprintf ppf "This type constructor's parameter, `%a`, can't be found. Is it a typo?" longident lid;
    spellcheck ppf Env.fold_types env lid;
  | Unbound_value lid ->
      (* modified *)
      begin
        match lid with
        | Ldot (outer, inner) ->
          fprintf ppf "The value %s can't be found in %a"
            inner
            Printtyp.longident outer;
        | other_ident -> fprintf ppf "The value %a can't be found" Printtyp.longident other_ident
      end;
      spellcheck ppf Env.fold_values env lid;
  | Unbound_module lid ->
      (* modified *)
      begin match lid with
      | Lident "Str" ->
        begin
          fprintf ppf "@[\
              @{<info>The module or file %a can't be found.@}@,@,\
              Are you trying to use the standard library's Str?@ \
              If you're compiling to JavaScript,@ use @{<info>Js.Re@} instead.@ \
              Otherwise, add str.cma to your ocamlc/ocamlopt command.\
            @]"
            longident lid
        end
      | lid ->
        begin
          fprintf ppf "@[<v>\
              @{<info>The module or file %a can't be found.@}@,\
              @[<v 2>- If it's a third-party dependency:@,\
                - Did you list it in bsconfig.json?@,\
                - @[Did you run `bsb` instead of `bsb -make-world`@ (latter builds third-parties)@]?\
              @]@,\
              - Did you include the file's directory in bsconfig.json?@]\
            @]"
            longident lid
        end
      end;
      spellcheck ppf Env.fold_modules env lid
  | Unbound_constructor lid ->
      (* modified *)
      fprintf ppf "@[<v>\
      @{<info>The variant constructor %a can't be found.@}@,@,\
      @[<v 2>- If it's defined in another module or file, bring it into scope by:@,\
        @[- Annotating it with said module name:@ @{<info>let food = MyModule.Apple@}@]@,\
        @[- Or specifying its type:@ @{<info>let food: MyModule.fruit = Apple@}@]\
      @]@,\
      - @[Constructors and modules are both capitalized.@ Did you want the latter?@ Then instead of @{<dim>let foo = Bar@}, try @{<info>module Foo = Bar@}.@]\
      @]"
      longident lid;

      Typetexp.spellcheck ppf fold_constructors env lid

  | Unbound_label lid ->
      (* modified *)
      fprintf ppf "@[<v>\
      @{<info>The record field %a can't be found.@}@,@,\
      If it's defined in another module or file, bring it into scope by:@,\
      @[- Annotating it with said module name:@ @{<info>let baby = {MyModule.age: 3}@}@]@,\
      @[- Or specifying its type:@ @{<info>let baby: MyModule.person = {age: 3}@}@]\
      @]"
      longident lid;

      Typetexp.spellcheck ppf fold_labels env lid

  | anythingElse ->
      Typetexp.report_error env ppf anythingElse

(* This will be called in super_main. This is how you'd override the default error printer from the compiler & register new error_of_exn handlers *)
let setup () =
  Location.register_error_of_exn
    (function
      | Typetexp.Error (loc, env, err) ->
        Some (Super_location.error_of_printer loc (report_error env) err)
      (* typetexp doesn't expose Error_forward  *)
      (* | Error_forward err ->
        Some err *)
      | _ ->
        None
    )

end
module Super_main
= struct
#1 "super_main.ml"
(* the entry point. This is used by js_main.ml *)
let setup =
  lazy (match Ext_sys.getenv_opt "BS_VSCODE" with 
  | Some ("true" | "1") -> 
    ()
  | Some _ | None -> 
    Super_location.setup ();
    Super_typetexp.setup ();
    Super_typemod.setup ();
    Super_typecore.setup ();
    Super_env.setup ();
    Super_pparse.setup ())

end
module Js_main : sig 
#1 "js_main.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)


end = struct
#1 "js_main.ml"
(***********************************************************************)
(*                                                                     *)
(*                                OCaml                                *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)


let process_interface_file ppf name =
  Js_implementation.interface ppf name (Compenv.output_prefix name)
let process_implementation_file ppf name =
  Js_implementation.implementation ppf name (Compenv.output_prefix name)


let setup_reason_context () = 
  Js_config.is_reason := true;
  Lazy.force Super_main.setup;
  Lazy.force Reason_outcome_printer_main.setup

let reason_pp ~sourcefile  = 
  setup_reason_context ();
  Ast_reason_pp.pp sourcefile

type valid_input = 
  | Ml 
  | Mli
  | Re
  | Rei
  | Mlast    
  | Mliast 
  | Reast
  | Reiast
  | Mlmap
  | Cmi

(** This is per-file based, 
    when [ocamlc] [-c -o another_dir/xx.cmi] 
    it will return (another_dir/xx)
*)    


let process_file ppf sourcefile = 
  (* This is a better default then "", it will be changed later 
     The {!Location.input_name} relies on that we write the binary ast 
     properly
  *)
  Location.input_name := sourcefile;  
  let ext = Ext_filename.get_extension_maybe sourcefile in 
  let input = 
    if ext = Literals.suffix_ml  then 
      Ml
    else if  ext = Literals.suffix_re then
      Re
    else if ext = !Config.interface_suffix then 
      Mli  
    else if  ext = Literals.suffix_rei  then
      Rei
    else if ext =  Literals.suffix_mlast then 
      Mlast 
    else if ext = Literals.suffix_mliast then 
      Mliast
    else if ext = Literals.suffix_reast then   
      Reast 
    else if ext = Literals.suffix_reiast then   
      Reiast
    else if ext =  Literals.suffix_mlmap  then 
      Mlmap 
    else if ext =  Literals.suffix_cmi then 
      Cmi
    else 
      raise(Arg.Bad("don't know what to do with " ^ sourcefile)) in 
  let opref = Compenv.output_prefix sourcefile in 
  match input with 
  | Re ->     
    setup_reason_context ();
    Js_implementation.implementation ppf (reason_pp ~sourcefile) opref   
  | Rei ->
    setup_reason_context ();
    Js_implementation.interface ppf (reason_pp ~sourcefile) opref 
  | Reiast 
    -> 
    setup_reason_context ();
    Js_implementation.interface_mliast ppf sourcefile opref   
  | Reast 
    -> 
    setup_reason_context ();
    Js_implementation.implementation_mlast ppf sourcefile opref
  | Ml ->
    Js_implementation.implementation ppf sourcefile opref 
  | Mli  ->   
    Js_implementation.interface ppf sourcefile opref   
  | Mliast 
    -> Js_implementation.interface_mliast ppf sourcefile opref 
  | Mlast 
    -> Js_implementation.implementation_mlast ppf sourcefile opref
  | Mlmap 
    -> Js_implementation.implementation_map ppf sourcefile opref
  | Cmi
    ->
    let cmi_sign = (Cmi_format.read_cmi sourcefile).cmi_sign in 
    Printtyp.signature Format.std_formatter cmi_sign ; 
    Format.pp_print_newline Format.std_formatter ()
      

let usage = "Usage: bsc <options> <files>\nOptions are:"

let ppf = Format.err_formatter

(* Error messages to standard error formatter *)
let anonymous filename =
  Compenv.readenv ppf 
  
    (Before_compile filename)
    
    ; process_file ppf filename;;
let impl filename =
  Compenv.readenv ppf 
  
    (Before_compile filename)
      
  ; process_implementation_file ppf filename;;
let intf filename =
  Compenv.readenv ppf 
  
    (Before_compile filename)
      
  ; process_interface_file ppf filename;;



let eval (s : string) ~suffix =
  let tmpfile = Filename.temp_file "eval" suffix in 
  Ext_io.write_file tmpfile s;   
  Ext_pervasives.finally  tmpfile anonymous ~clean:(fun _ ->
      try Sys.remove tmpfile with _ -> () 
    )

let (//) = Filename.concat




                       
let define_variable s =
  match Ext_string.split ~keep_empty:true s '=' with
  | [key; v] -> 
    if not @@ Lexer.define_key_value key v  then 
      raise (Arg.Bad ("illegal definition: " ^ s))
  | _ -> raise (Arg.Bad ("illegal definition: " ^ s))

  
let buckle_script_flags : (string * Arg.spec * string) list =
  ("-bs-super-errors",
    Arg.Unit 
      (* needs to be set here instead of, say, setting a
        Js_config.better_errors flag; otherwise, when `anonymous` runs, we
        don't have time to set the custom printer before it starts outputting
        warnings *)
      (fun _ -> Lazy.force Super_main.setup)
     ,
   " Better error message combined with other tools "
  )
   :: 
  ("-bs-re-out",
    Arg.Unit (fun _ -> Lazy.force Reason_outcome_printer_main.setup),
   " Print compiler output in Reason syntax"
  )
  ::
  ("-bs-jsx",
    Arg.Int (fun i -> Js_config.jsx_version := i),
    " Set jsx version"
  )
  :: 
  ("-bs-refmt",
    Arg.String (fun s -> Js_config.refmt := Some s),
    " Set customized refmt path"
  )
 
  ::
  (
    "-bs-gentype",
    Arg.String (fun s -> Clflags.bs_gentype := Some s),
    " Pass gentype command"
  )
  ::
  ("-bs-suffix",
    Arg.Set Js_config.bs_suffix,
    " Set suffix to .bs.js"
  )  
  :: 
  ("-bs-no-implicit-include", Arg.Set Clflags.no_implicit_current_dir
  , " Don't include current dir implicitly")
  ::
  ("-bs-read-cmi", Arg.Unit (fun _ -> Clflags.assume_no_mli := Clflags.Mli_exists), 
    " (internal) Assume mli always exist ")
  ::
  ("-bs-D", Arg.String define_variable,
     " Define conditional variable e.g, -D DEBUG=true"
  )
  :: 
  ("-bs-quiet", Arg.Set Clflags.bs_quiet,
    " Quiet mode (no warnings printed)"
  )
  ::
  ("-bs-list-conditionals",
   Arg.Unit (fun () -> Lexer.list_variables Format.err_formatter),
   " List existing conditional variables")
  ::
  (
    "-bs-binary-ast", Arg.Set Js_config.binary_ast,
    " Generate binary .mli_ast and ml_ast"
  )
  ::
  ("-bs-syntax-only", 
   Arg.Set Js_config.syntax_only,
   " only check syntax"
  )
  ::
  ("-bs-no-bin-annot", Arg.Clear Clflags.binary_annotations, 
   " disable binary annotations (by default on)")
  ::
  ("-bs-eval", 
   Arg.String (fun  s -> eval s ~suffix:Literals.suffix_ml), 
   " (experimental) Set the string to be evaluated in OCaml syntax"
  )
  ::
  ("-e", 
   Arg.String (fun  s -> eval s ~suffix:Literals.suffix_re), 
   " (experimental) Set the string to be evaluated in ReasonML syntax"
  )
  ::
  (
    "-bs-cmi-only",
    Arg.Set Js_config.cmi_only,
    " Stop after generating cmi file"
  )
  ::
  (
  "-bs-cmi",
    Arg.Set Js_config.force_cmi,
    " Not using cached cmi, always generate cmi"
  )
  ::
  ("-bs-cmj", 
    Arg.Set Js_config.force_cmj,
    " Not using cached cmj, always generate cmj"
  )
  ::
  ("-bs-g",
    Arg.Unit 
    (fun _ -> Js_config.debug := true;
      Lexer.replace_directive_bool "DEBUG" true
    ),
    " debug mode"
  )
  ::
  (
    "-bs-sort-imports",
    Arg.Set Js_config.sort_imports,
    " Sort the imports by lexical order so the output will be more stable (default false)"
  )
  ::
  ( "-bs-no-sort-imports", 
    Arg.Clear Js_config.sort_imports,
    " No sort (see -bs-sort-imports)"
  )
  ::
  ("-bs-package-name", 
   Arg.String Js_packages_state.set_package_name, 
   " set package name, useful when you want to produce npm packages")
  ::
  ( "-bs-ns", 
   Arg.String Js_packages_state.set_package_map, 
   " set package map, not only set package name but also use it as a namespace"    
  )
  :: 
  ("-bs-no-version-header", 
   Arg.Set Js_config.no_version_header,
   " Don't print version header"
  )
  ::
  ("-bs-package-output", 
   Arg.String 
    Js_packages_state.update_npm_package_path, 
   " set npm-output-path: [opt_module]:path, for example: 'lib/cjs', 'amdjs:lib/amdjs', 'es6:lib/es6' ")
  ::
  ("-bs-no-warn-unimplemented-external",
    Arg.Set Js_config.no_warn_unimplemented_external,
    " disable warnings on unimplmented c externals"
  )
  ::
  ("-bs-no-builtin-ppx-ml", 
   Arg.Set Js_config.no_builtin_ppx_ml,
   "disable built-in ppx for ml files (internal use)")
  :: 
  ("-bs-no-builtin-ppx-mli",
   Arg.Set Js_config.no_builtin_ppx_mli,
   "disable built-in ppx for mli files (internal use)")
  :: 
  ("-bs-cross-module-opt", 
   Arg.Set Js_config.cross_module_inline, 
   "enable cross module inlining(experimental), default(false)")
  :: 
  ("-bs-diagnose",
   Arg.Set Js_config.diagnose, 
   " More verbose output")
  :: 
  ("-bs-no-check-div-by-zero",
   Arg.Clear Js_config.check_div_by_zero, 
   " unsafe mode, don't check div by zero and mod by zero")
  ::
  ("-bs-noassertfalse",
    Arg.Set Clflags.no_assert_false,
    " no code for assert false"
  )  

  :: Ocaml_options.mk_impl impl
  :: Ocaml_options.mk_intf intf 
  :: Ocaml_options.mk__ anonymous
  :: Ocaml_options.ocaml_options


  


let _ = 

  Bs_conditional_initial.setup_env ();
  try
    Compenv.readenv ppf Before_args;
    Arg.parse buckle_script_flags anonymous usage    
  with x -> 
    begin

      Location.report_exception ppf x;
      exit 2
    end

end
