Indent deprecation warning's userland message

.gitignore

@@ -413,5 +413,3 @@ _ocamltest
 lib/ocaml/
 man/
 
-_esy
-esy.lock

asmcomp/cmmgen.ml

@@ -1447,7 +1447,7 @@ struct
  let make_isout h arg = Cop (Ccmpa Clt, [h ; arg], Debuginfo.none)
  let make_isin h arg = Cop (Ccmpa Cge, [h ; arg], Debuginfo.none)
  let make_if cond ifso ifnot = Cifthenelse (cond, ifso, ifnot)
- let make_switch loc arg cases actions _names =
+ let make_switch loc arg cases actions ~offset:_ _names =
  make_switch arg cases actions (Debuginfo.from_location loc)
  let bind arg body = bind "switcher" arg body
 

bytecomp/matching.ml

@@ -1954,10 +1954,10 @@ module SArg = struct
  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 sw_names =
+ let make_switch loc arg cases acts ~offset sw_names =
  let l = ref [] in
  for i = Array.length cases-1 downto 0 do
- l := (i,acts.(cases.(i))) :: !l
+ l := (offset + i,acts.(cases.(i))) :: !l
  done ;
  Lswitch(arg,
  {sw_numconsts = Array.length cases ; sw_consts = !l ;
@@ -2500,6 +2500,11 @@ let make_test_sequence_variant_constant :
  ref
  = ref make_test_sequence_variant_constant 
 
+let is_poly_var_constant : Lambda.primitive lazy_t = lazy (
+ if !Config.bs_only then 
+ Pccall (Primitive.simple ~name:"#is_poly_var_const" ~arity:1 ~alloc:false)
+ else Pisint ) 
+
 let combine_variant names loc row arg partial ctx def
  (tag_lambda_list, total1, _pats) =
  let row = Btype.row_repr row in
@@ -2514,9 +2519,9 @@ let combine_variant names loc row arg partial ctx def
  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
+ Lifthenelse(Lprim (Lazy.force is_poly_var_constant, [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
+ and one_action = same_actions tag_lambda_list in (* reduandant work under bs context *)
  let fail, local_jumps =
  if
  sig_complete || (match partial with Total -> true | _ -> false)

bytecomp/switch.ml

@@ -106,7 +106,7 @@ module type S =
  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 -> Lambda.switch_names option -> act
+ val make_switch : Location.t -> act -> int array -> act array -> offset:int -> Lambda.switch_names option -> act
  val make_catch : act -> int * (act -> act)
  val make_exit : int -> act
  end
@@ -560,6 +560,9 @@ and enum top cases =
  do_make_if_out
  (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx)
  | _ ->
+ if (*true || *)!Config.bs_only then 
+ do_make_if_out
+ (Arg.make_const d) (Arg.make_offset ctx.arg (-l)) (mk_ifso ctx) (mk_ifno ctx) else
  Arg.bind
  (Arg.make_offset ctx.arg (-l))
  (fun arg ->
@@ -575,6 +578,9 @@ and enum top cases =
  do_make_if_in
  (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx)
  | _ ->
+ if (*true || *) !Config.bs_only then
+ do_make_if_in
+ (Arg.make_const d) (Arg.make_offset ctx.arg (-l)) (mk_ifso ctx) (mk_ifno ctx) else
  Arg.bind
  (Arg.make_offset ctx.arg (-l))
  (fun arg ->
@@ -750,12 +756,15 @@ let make_switch loc {cases=cases ; actions=actions} i j sw_names =
  (fun act i -> acts.(i) <- actions.(act))
  t ;
  (fun ctx ->
+ if !Config.bs_only then
+ Arg.make_switch ~offset:(ll+ctx.off) loc ctx.arg tbl acts sw_names
+ else 
  match -ll-ctx.off with
- | 0 -> Arg.make_switch loc ctx.arg tbl acts sw_names
+ | 0 -> Arg.make_switch loc ctx.arg tbl acts sw_names ~offset:0
  | _ ->
  Arg.bind
  (Arg.make_offset ctx.arg (-ll-ctx.off))
- (fun arg -> Arg.make_switch loc arg tbl acts sw_names))
+ (fun arg -> Arg.make_switch loc arg tbl acts sw_names ~offset:0))
 
 
 let make_clusters loc ({cases=cases ; actions=actions} as s) n_clusters k sw_names =

bytecomp/switch.mli

@@ -79,7 +79,7 @@ module type S =
  make_switch arg cases acts
  NB: cases is in the value form *)
  val make_switch :
- Location.t -> act -> int array -> act array -> Lambda.switch_names option -> act
+ Location.t -> act -> int array -> act array -> offset:int -> Lambda.switch_names option -> act
  (* Build last minute sharing of action stuff *)
  val make_catch : act -> int * (act -> act)
  val make_exit : int -> act

bytecomp/translcore.ml

@@ -940,6 +940,9 @@ let try_ids = Hashtbl.create 8
 
 let rec transl_exp e =
  List.iter (Translattribute.check_attribute e) e.exp_attributes;
+#if BS_ONLY then
+ transl_exp0 e
+#else
  let eval_once =
  (* Whether classes for immediate objects must be cached *)
  match e.exp_desc with
@@ -948,7 +951,7 @@ let rec transl_exp e =
  in
  if eval_once then transl_exp0 e else
  Translobj.oo_wrap e.exp_env true transl_exp0 e
-
+#end
 and transl_exp0 e =
  match e.exp_desc with
  Texp_ident(path, _, {val_kind = Val_prim p}) ->
@@ -1263,6 +1266,15 @@ and transl_exp0 e =
  | Texp_for(param, _, low, high, dir, body) ->
  Lfor(param, transl_exp low, transl_exp high, dir,
  event_before body (transl_exp body))
+#if BS_ONLY then 
+ | Texp_send(expr,met,_) -> 
+ let obj = transl_exp expr in 
+ begin match met with 
+ | Tmeth_name nm -> 
+ Lsend(Public(Some nm),Lambda.lambda_unit,obj,[],e.exp_loc)
+ | _ -> assert false 
+ end
+#else
  | Texp_send(_, _, Some exp) -> transl_exp exp
  | Texp_send(expr, met, None) ->
  let obj = transl_exp expr in
@@ -1275,6 +1287,7 @@ and transl_exp0 e =
  Lsend (kind, tag, obj, cache, e.exp_loc)
  in
  event_after e lam
+#end 
  | Texp_new (cl, {Location.loc=loc}, _) ->
  Lapply{ap_should_be_tailcall=false;
  ap_loc=loc;
@@ -1288,6 +1301,9 @@ and transl_exp0 e =
  | Texp_setinstvar(path_self, path, _, expr) ->
  transl_setinstvar e.exp_loc (transl_normal_path path_self) path expr
  | Texp_override(path_self, modifs) ->
+#if BS_ONLY then 
+ assert false
+#else 
  let cpy = Ident.create "copy" in
  Llet(Strict, Pgenval, cpy,
  Lapply{ap_should_be_tailcall=false;
@@ -1302,6 +1318,7 @@ and transl_exp0 e =
  (Lvar cpy) path expr, rem))
  modifs
  (Lvar cpy))
+#end 
  | Texp_letmodule(id, loc, modl, body) ->
  let defining_expr =
 #if true 

bytecomp/translmod.ml

@@ -15,7 +15,14 @@
 
 (* Translation from typed abstract syntax to lambda terms,
  for the module language *)
-
+#if BS_ONLY then 
+module Translobj = struct 
+ let oo_wrap _env _b f a = f a 
+ let reset_labels () : unit = () 
+ let transl_store_label_init _ _ _ _ : int * _ = assert false
+ let transl_label_init f = f () 
+end 
+#end
 open Misc
 open Asttypes
 open Longident
@@ -25,7 +32,7 @@ open Typedtree
 open Lambda
 open Translobj
 open Translcore
-open Translclass
+
 
 type error =
  Circular_dependency of Ident.t
@@ -364,15 +371,15 @@ let rec bound_value_identifiers = function
 
 
 (* Code to translate class entries in a structure *)
-
+#if undefined BS_ONLY then
 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))
+ (id, Translclass.transl_class ids id meths cl vf))
  cl_list)
-
+#end
 (* 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
@@ -632,13 +639,17 @@ and transl_structure loc fields cc rootpath final_env = function
  body
  in
  lam, size
+#if undefined BS_ONLY then 
  | 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
+#else 
+ | Tstr_class _ -> assert false 
+#end 
  | Tstr_include incl ->
  let ids = bound_value_identifiers incl.incl_type in
  let modl = incl.incl_mod in
@@ -972,14 +983,17 @@ let transl_store_structure glob map prims str =
  bindings
  (Lsequence(store_idents Location.none ids,
  transl_store rootpath (add_idents true ids subst) rem))
+#if BS_ONLY then 
+ | Tstr_class _ -> assert false 
+#else 
  | 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)
-
+#end
  | Tstr_include{
  incl_loc=loc;
  incl_mod= {
@@ -1235,12 +1249,16 @@ let transl_toplevel_item item =
  (fun id modl _loc -> transl_module Tcoerce_none (Some(Pident id)) modl)
  bindings
  (make_sequence toploop_setvalue_id idents)
+#if BS_ONLY then 
+ | Tstr_class _ -> assert false 
+#else 
  | 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)
+#end 
  | Tstr_include incl ->
  let ids = bound_value_identifiers incl.incl_type in
  let modl = incl.incl_mod in

parsing/builtin_attributes.ml

@@ -63,7 +63,8 @@ let cat s1 s2 =
  if s2 = "" then s1 else
 #if undefined BS_NO_COMPILER_PATCH then 
  if Clflags.bs_vscode then s1 ^ " " ^ s2
- else s1 ^ "\n" ^ s2 
+ (* 2 spaces indentation for the next line *)
+ else s1 ^ "\n " ^ s2 
 #else 
  s1 ^ "\n" ^ s2
 #end