merge changes + handle or-patterns

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/multimatch@5254 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

bytecomp/bytegen.ml

@@ -126,16 +126,20 @@ let rec push_dummies n k = match n with
 
 (**** Auxiliary for compiling "let rec" ****)
 
+type rhs_kind =
+  | RHS_block of int
+  | RHS_nonrec
+;;
 let rec size_of_lambda = function
   | Lfunction(kind, params, body) as funct ->
-      1 + IdentSet.cardinal(free_variables funct)
-  | Lprim(Pmakeblock(tag, mut), args) -> List.length args
-  | Lprim(Pmakearray kind, args) -> List.length args
+      RHS_block (1 + IdentSet.cardinal(free_variables funct))
   | Llet(str, id, arg, body) -> size_of_lambda body
   | Lletrec(bindings, body) -> size_of_lambda body
+  | Lprim(Pmakeblock(tag, mut), args) -> RHS_block (List.length args)
+  | Lprim(Pmakearray kind, args) -> RHS_block (List.length args)
   | Levent (lam, _) -> size_of_lambda lam
   | Lsequence (lam, lam') -> size_of_lambda lam'
-  | _ -> fatal_error "Bytegen.size_of_lambda"
+  | _ -> RHS_nonrec
 
 (**** Merging consecutive events ****)
 
@@ -460,19 +464,27 @@ let rec comp_expr env exp sz cont =
         let decl_size =
           List.map (fun (id, exp) -> (id, exp, size_of_lambda exp)) decl in
         let rec comp_decl new_env sz i = function
-            [] ->
+          | [] ->
               comp_expr new_env body sz (add_pop ndecl cont)
-          | (id, exp, blocksize) :: rem ->
+          | (id, exp, RHS_block blocksize) :: rem ->
               comp_expr new_env exp sz
                 (Kpush :: Kacc i :: Kccall("update_dummy", 2) ::
-                 comp_decl new_env sz (i-1) rem) in
+                 comp_decl new_env sz (i-1) rem)
+          | (id, exp, RHS_nonrec) :: rem ->
+              comp_decl new_env sz (i-1) rem
+        in
         let rec comp_init new_env sz = function
-            [] ->
+          | [] ->
               comp_decl new_env sz ndecl decl_size
-          | (id, exp, blocksize) :: rem ->
+          | (id, exp, RHS_block blocksize) :: rem ->
               Kconst(Const_base(Const_int blocksize)) ::
               Kccall("alloc_dummy", 1) :: Kpush ::
-              comp_init (add_var id (sz+1) new_env) (sz+1) rem in
+              comp_init (add_var id (sz+1) new_env) (sz+1) rem
+          | (id, exp, RHS_nonrec) :: rem ->
+              comp_expr new_env exp sz
+                (Kpush ::
+                 comp_init (add_var id (sz+1) new_env) (sz+1) rem)
+        in
         comp_init env sz decl_size
       end
   | Lprim(Pidentity, [arg]) ->
@@ -666,7 +678,7 @@ let rec comp_expr env exp sz cont =
       let event kind info =
         { ev_pos = 0;                   (* patched in emitcode *)
           ev_module = !compunit_name;
-          ev_char = lev.lev_loc;
+          ev_char = lev.lev_pos;
           ev_kind = kind;
           ev_info = info;
           ev_typenv = lev.lev_env;

bytecomp/instruct.ml

@@ -22,7 +22,7 @@ type compilation_env =
 type debug_event =
   { mutable ev_pos: int;                (* Position in bytecode *)
     ev_module: string;                  (* Name of defining module *)
-    ev_char: int;                       (* Location in source file *)
+    ev_char: Lexing.position;           (* Position in source file *)
     ev_kind: debug_event_kind;          (* Before/after event *)
     ev_info: debug_event_info;          (* Extra information *)
     ev_typenv: Env.summary;             (* Typing environment *)

bytecomp/instruct.mli

@@ -39,7 +39,7 @@ type compilation_env =
 type debug_event =
   { mutable ev_pos: int;                (* Position in bytecode *)
     ev_module: string;                  (* Name of defining module *)
-    ev_char: int;                       (* Location in source file *)
+    ev_char: Lexing.position;           (* Position in source file *)
     ev_kind: debug_event_kind;          (* Before/after event *)
     ev_info: debug_event_info;          (* Extra information *)
     ev_typenv: Env.summary;             (* Typing environment *)

bytecomp/lambda.ml

@@ -146,7 +146,7 @@ and lambda_switch =
     sw_failaction : lambda option}
 
 and lambda_event =
-  { lev_loc: int;
+  { lev_pos: Lexing.position;
     lev_kind: lambda_event_kind;
     lev_repr: int ref option;
     lev_env: Env.summary }

bytecomp/lambda.mli

@@ -154,7 +154,7 @@ and lambda_switch =
     sw_blocks: (int * lambda) list;     (* Tag block cases *)
     sw_failaction : lambda option}      (* Action to take if failure *)
 and lambda_event =
-  { lev_loc: int;
+  { lev_pos: Lexing.position;
     lev_kind: lambda_event_kind;
     lev_repr: int ref option;
     lev_env: Env.summary }

bytecomp/matching.ml

@@ -1900,7 +1900,7 @@ let rec event_branch repr lam =
       lam
   | (Levent(lam', ev), Some r) ->
       incr r;
-      Levent(lam', {lev_loc = ev.lev_loc;
+      Levent(lam', {lev_pos = ev.lev_pos;
                     lev_kind = ev.lev_kind;
                     lev_repr = repr;
                     lev_env = ev.lev_env})
@@ -2209,12 +2209,19 @@ let compile_matching loc repr handler_fun arg pat_act_list partial =
       lambda
 
 let partial_function loc () =
+  let fname = match loc.Location.loc_start.Lexing.pos_fname with
+              | "" -> !Location.input_name
+              | x -> x
+  in
+  let pos = loc.Location.loc_start in
+  let line = pos.Lexing.pos_lnum in
+  let char = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in
   Lprim(Praise, [Lprim(Pmakeblock(0, Immutable),
           [transl_path Predef.path_match_failure;
            Lconst(Const_block(0,
-              [Const_base(Const_string !Location.input_name);
-               Const_base(Const_int loc.Location.loc_start);
-               Const_base(Const_int loc.Location.loc_end)]))])])
+              [Const_base(Const_string fname);
+               Const_base(Const_int line);
+               Const_base(Const_int char)]))])])
 
 let for_function loc repr param pat_act_list partial =
   compile_matching loc repr (partial_function loc) param pat_act_list partial

bytecomp/printinstr.ml

@@ -97,7 +97,8 @@ let instruction ppf = function
   | Kisout -> fprintf ppf "\tisout"
   | Kgetmethod -> fprintf ppf "\tgetmethod"
   | Kstop -> fprintf ppf "\tstop"
-  | Kevent ev -> fprintf ppf "\tevent %i" ev.ev_char
+  | Kevent ev -> fprintf ppf "\tevent \"%s\" %i" ev.ev_char.Lexing.pos_fname
+                                                 ev.ev_char.Lexing.pos_cnum
 
 let rec instruction_list ppf = function
     [] -> ()

bytecomp/printlambda.ml

@@ -284,7 +284,7 @@ let rec lam ppf = function
        | Lev_before -> "before"
        | Lev_after _  -> "after"
        | Lev_function -> "funct-body" in
-      fprintf ppf "@[<2>(%s %i@ %a)@]" kind ev.lev_loc lam expr
+      fprintf ppf "@[<2>(%s %i@ %a)@]" kind ev.lev_pos.Lexing.pos_cnum lam expr
   | Lifused(id, expr) ->
       fprintf ppf "@[<2>(ifused@ %a@ %a)@]" Ident.print id lam expr
 

bytecomp/translcore.ml

@@ -299,23 +299,19 @@ let transl_primitive p =
 
 let check_recursive_lambda idlist lam =
   let rec check_top idlist = function
-      Lfunction(kind, params, body) as funct -> true
-    | Lprim(Pmakeblock(tag, mut), args) ->
-        List.for_all (check idlist) args
-    | Lprim(Pmakearray(Paddrarray|Pintarray), args) ->
-        List.for_all (check idlist) args
+    | Lvar v -> not (List.mem v idlist)
     | Llet(str, id, arg, body) ->
         check idlist arg && check_top (add_let id arg idlist) body
     | Lletrec(bindings, body) ->
         let idlist' = add_letrec bindings idlist in
         List.for_all (fun (id, arg) -> check idlist' arg) bindings &&
         check_top idlist' body
+    | Lsequence (lam1, lam2) -> check idlist lam1 && check_top idlist lam2
     | Levent (lam, _) -> check_top idlist lam
-    | _ -> false
+    | lam -> check idlist lam
 
   and check idlist = function
-      Lvar _ -> true
-    | Lconst cst -> true
+    | Lvar _ -> true
     | Lfunction(kind, params, body) -> true
     | Llet(str, id, arg, body) ->
         check idlist arg && check (add_let id arg idlist) body
@@ -327,6 +323,7 @@ let check_recursive_lambda idlist lam =
         List.for_all (check idlist) args
     | Lprim(Pmakearray(Paddrarray|Pintarray), args) ->
         List.for_all (check idlist) args
+    | Lsequence (lam1, lam2) -> check idlist lam1 && check idlist lam2
     | Levent (lam, _) -> check idlist lam
     | lam ->
         let fv = free_variables lam in
@@ -406,15 +403,15 @@ let event_before exp lam = match lam with
 | Lstaticraise (_,_) -> lam
 | _ ->
   if !Clflags.debug
-  then Levent(lam, {lev_loc = exp.exp_loc.Location.loc_start;
+  then Levent(lam, {lev_pos = exp.exp_loc.Location.loc_start;
                     lev_kind = Lev_before;
                     lev_repr = None;
                     lev_env = Env.summary exp.exp_env})
   else lam
 
 let event_after exp lam =
   if !Clflags.debug
-  then Levent(lam, {lev_loc = exp.exp_loc.Location.loc_end;
+  then Levent(lam, {lev_pos = exp.exp_loc.Location.loc_end;
                     lev_kind = Lev_after exp.exp_type;
                     lev_repr = None;
                     lev_env = Env.summary exp.exp_env})
@@ -425,7 +422,7 @@ let event_function exp lam =
     let repr = Some (ref 0) in
     let (info, body) = lam repr in
     (info,
-     Levent(body, {lev_loc = exp.exp_loc.Location.loc_start;
+     Levent(body, {lev_pos = exp.exp_loc.Location.loc_start;
                    lev_kind = Lev_function;
                    lev_repr = repr;
                    lev_env = Env.summary exp.exp_env}))
@@ -434,12 +431,19 @@ let event_function exp lam =
 
 
 let assert_failed loc =
+  let fname = match loc.Location.loc_start.Lexing.pos_fname with
+              | "" -> !Location.input_name
+              | x -> x
+  in
+  let pos = loc.Location.loc_start in
+  let line = pos.Lexing.pos_lnum in
+  let char = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in
   Lprim(Praise, [Lprim(Pmakeblock(0, Immutable),
           [transl_path Predef.path_assert_failure;
            Lconst(Const_block(0,
-              [Const_base(Const_string !Location.input_name);
-               Const_base(Const_int loc.Location.loc_start);
-               Const_base(Const_int loc.Location.loc_end)]))])])
+              [Const_base(Const_string fname);
+               Const_base(Const_int line);
+               Const_base(Const_int char)]))])])
 ;;
 
 (* Translation of expressions *)

parsing/lexer.mli

@@ -26,7 +26,7 @@ type error =
   | Keyword_as_label of string
 ;;
 
-exception Error of error * int * int
+exception Error of error * Location.t
 
 open Format