merge from head

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

bytecomp/bytegen.ml

@@ -463,27 +463,30 @@ let rec comp_expr env exp sz cont =
       end else begin
         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, 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)
-          | (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
+          | [] -> comp_nonrec new_env sz ndecl decl_size
           | (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
           | (id, exp, RHS_nonrec) :: rem ->
+              Kconst(Const_base(Const_int 0)) :: Kpush ::
+              comp_init (add_var id (sz+1) new_env) (sz+1) rem
+        and comp_nonrec new_env sz i = function
+          | [] -> comp_rec new_env sz ndecl decl_size
+          | (id, exp, RHS_block blocksize) :: rem ->
+              comp_nonrec new_env sz (i-1) rem
+          | (id, exp, RHS_nonrec) :: rem ->
+              comp_expr new_env exp sz
+                (Kassign (i-1) :: comp_nonrec new_env sz (i-1) rem)
+        and comp_rec new_env sz i = function
+          | [] -> comp_expr new_env body sz (add_pop ndecl cont)
+          | (id, exp, RHS_block blocksize) :: rem ->
               comp_expr new_env exp sz
-                (Kpush ::
-                 comp_init (add_var id (sz+1) new_env) (sz+1) rem)
+                (Kpush :: Kacc i :: Kccall("update_dummy", 2) ::
+                 comp_rec new_env sz (i-1) rem)
+          | (id, exp, RHS_nonrec) :: rem ->
+              comp_rec new_env sz (i-1) rem
         in
         comp_init env sz decl_size
       end

bytecomp/translcore.ml

@@ -327,14 +327,13 @@ let check_recursive_lambda idlist lam =
     | Levent (lam, _) -> check idlist lam
     | lam ->
         let fv = free_variables lam in
-        List.for_all (fun id -> not(IdentSet.mem id fv)) idlist
+        not (List.exists (fun id -> IdentSet.mem id fv) idlist)
 
   and add_let id arg idlist =
-    match arg with
-      Lvar id' -> if List.mem id' idlist then id :: idlist else idlist
-    | Llet(_, _, _, body) -> add_let id body idlist
-    | Lletrec(_, body) -> add_let id body idlist
-    | _ -> idlist
+    let fv = free_variables arg in
+    if List.exists (fun id -> IdentSet.mem id fv) idlist
+    then id :: idlist
+    else idlist
 
   and add_letrec bindings idlist =
     List.fold_right (fun (id, arg) idl -> add_let id arg idl)
@@ -624,7 +623,7 @@ let rec transl_exp e =
   | Texp_assertfalse -> assert_failed e.exp_loc
   | Texp_lazy e ->
       let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in
-      Lprim(Pmakeblock(Obj.lazy_tag, Immutable), [fn])
+      Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn])
 
 and transl_list expr_list =
   List.map transl_exp expr_list

parsing/location.mli

@@ -24,7 +24,7 @@ type t = {
 
 (* 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
+   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.
 *)

toplevel/toploop.ml

@@ -336,6 +336,7 @@ let refill_lexbuf buffer len =
 let empty_lexbuf lb =
   lb.lex_curr_pos <- 0;
   lb.lex_abs_pos <- 0;
+  lb.lex_curr_p <- {lb.lex_curr_p with pos_cnum = 0};
   lb.lex_buffer_len <- 0
 
 (* Toplevel initialization. Performed here instead of at the

typing/typecore.ml

@@ -592,92 +592,104 @@ let type_format loc fmt =
   let incomplete i =
     raise (Error (loc, Bad_format (String.sub fmt i (len - i)))) in
   let rec scan_format i =
-    if i >= len then ty_result else
+    if i >= len then ty_aresult, ty_result else
     match fmt.[i] with
-    | '%' -> scan_flags i (i+1)
-    | _ -> scan_format (i+1)
+    | '%' -> scan_flags i (i + 1)
+    | _ -> scan_format (i + 1)
   and scan_flags i j =
     if j >= len then incomplete i else
     match fmt.[j] with
-    | '#' | '0' | '-' | ' ' | '+' -> scan_flags i (j+1)
-    | _ -> scan_width i j
-  and scan_width i j =
+    | '#' | '0' | '-' | ' ' | '+' -> scan_flags i (j + 1)
+    | _ -> scan_skip i j
+  and scan_skip i j =
     if j >= len then incomplete i else
-    match fmt.[j] with
-    | '*' -> ty_arrow Predef.type_int (scan_dot i (j+1))
-    | '.' -> scan_precision i (j+1)
-    | _ -> scan_fixed_width i j
-  and scan_fixed_width i j =
-    if j >= len then incomplete i else
-    match fmt.[j] with
-    | '0' .. '9' | '-' | '+' -> scan_fixed_width i (j+1)
-    | '.' -> scan_precision i (j+1)
-    | _ -> scan_conversion i j
-  and scan_dot i j =
-    if j >= len then incomplete i else
-    match fmt.[j] with
-    | '.' -> scan_precision i (j+1)
-    | _ -> scan_conversion i j
-  and scan_precision i j =
-    if j >= len then incomplete i else
-    match fmt.[j] with
-    | '*' -> ty_arrow Predef.type_int (scan_conversion i (j+1))
-    | _ -> scan_fixed_precision i j
-  and scan_fixed_precision i j =
-    if j >= len then incomplete i else
-    match fmt.[j] with
-    | '0' .. '9' | '-' | '+' -> scan_fixed_precision i (j+1)
-    | _ -> scan_conversion i j
-  and scan_conversion i j =
-    if j >= len then incomplete i else
-    match fmt.[j] with
-    | '%' -> scan_format (j+1)
-    | 's' | 'S' | '[' ->
-        ty_arrow Predef.type_string (scan_format (j+1))
-    | 'c' | 'C' ->
-        ty_arrow Predef.type_char (scan_format (j+1))
-    | 'b' | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' ->
-        ty_arrow Predef.type_int (scan_format (j+1))
-    | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' ->
-        ty_arrow Predef.type_float (scan_format (j+1))
-    | 'B' ->
-        ty_arrow Predef.type_bool (scan_format (j+1))
-    | 'a' ->
-        let ty_arg = newvar() in
-        ty_arrow (ty_arrow ty_input (ty_arrow ty_arg ty_aresult))
-          (ty_arrow ty_arg (scan_format (j+1)))
-    | 't' ->
-        ty_arrow (ty_arrow ty_input ty_aresult) (scan_format (j+1))
-    | 'l' ->
-        if j+1 >= len then incomplete i else begin
-          match fmt.[j+1] with
-          | 'b' | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
-              ty_arrow Predef.type_int32 (scan_format (j+2))
-          | c ->
-              raise(Error(loc, Bad_format(String.sub fmt i (j-i+2))))
-        end
-    | 'n' ->
-        if j+1 >= len then incomplete i else begin
-          match fmt.[j+1] with
-          | 'b' | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
-              ty_arrow Predef.type_nativeint (scan_format (j+2))
-          | c ->
-              raise(Error(loc, Bad_format(String.sub fmt i (j-i+2))))
-        end
-    | 'L' ->
-        if j+1 >= len then incomplete i else begin
-          match fmt.[j+1] with
-          | 'b' | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
-              ty_arrow Predef.type_int64 (scan_format (j+2))
-          | c ->
-              raise(Error(loc, Bad_format(String.sub fmt i (j-i+2))))
-        end
-    | c ->
-        raise(Error(loc, Bad_format(String.sub fmt i (j-i+1))))
-  in
+      match fmt.[j] with
+      | '_' -> scan_rest true i j
+      | _ -> scan_rest false i j
+  and scan_rest skip i j =
+    let rec scan_width i j =
+      if j >= len then incomplete i else
+      match fmt.[j] with
+      | '*' ->
+          let ty_aresult, ty_result = scan_dot i (j + 1) in
+          ty_aresult, ty_arrow Predef.type_int ty_result
+      | '_' -> scan_fixed_width i (j + 1)
+      | '.' -> scan_precision i (j + 1)
+      | _ -> scan_fixed_width i j
+    and scan_fixed_width i j =
+      if j >= len then incomplete i else
+      match fmt.[j] with
+      | '0' .. '9' | '-' | '+' -> scan_fixed_width i (j + 1)
+      | '.' -> scan_precision i (j + 1)
+      | _ -> scan_conversion i j
+    and scan_dot i j =
+      if j >= len then incomplete i else
+      match fmt.[j] with
+      | '.' -> scan_precision i (j + 1)
+      | _ -> scan_conversion i j
+    and scan_precision i j =
+      if j >= len then incomplete i else
+      match fmt.[j] with
+      | '*' ->
+          let ty_aresult, ty_result = scan_conversion i (j + 1) in
+          ty_aresult, ty_arrow Predef.type_int ty_result
+      | _ -> scan_fixed_precision i j
+    and scan_fixed_precision i j =
+      if j >= len then incomplete i else
+      match fmt.[j] with
+      | '0' .. '9' | '-' | '+' -> scan_fixed_precision i (j + 1)
+      | _ -> scan_conversion i j
+
+    and conversion j ty_arg =
+      let ty_aresult, ty_result = scan_format (j + 1) in
+      ty_aresult,
+      if skip then ty_result else ty_arrow ty_arg ty_result
+
+    and scan_conversion i j =
+      if j >= len then incomplete i else
+      match fmt.[j] with
+      | '%' -> scan_format (j + 1)
+      | 's' | 'S' | '[' -> conversion j Predef.type_string
+      | 'c' | 'C' -> conversion j Predef.type_char
+      | 'b' | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' ->
+          conversion j Predef.type_int
+      | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> conversion j Predef.type_float
+      | 'B' -> conversion j Predef.type_bool
+      | 'a' ->
+          let ty_arg = newvar() in
+          let ty_a = ty_arrow ty_input (ty_arrow ty_arg ty_aresult) in 
+          let ty_aresult, ty_result = conversion j ty_arg in
+          ty_aresult, ty_arrow ty_a ty_result
+      | 'r' ->
+          let ty_res = newvar() in
+          let ty_r = ty_arrow ty_input ty_res in
+          let ty_aresult, ty_result = conversion j ty_res in
+          ty_arrow ty_r ty_aresult, ty_result
+      | 't' -> conversion j (ty_arrow ty_input ty_aresult)
+      | 'n' when j + 1 = len -> conversion j Predef.type_int
+      | 'l' | 'n' | 'L' as conv ->
+          let j = j + 1 in
+          if j >= len then incomplete i else begin
+            match fmt.[j] with
+            | 'b' | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
+                let ty_arg =
+                 match conv with
+                 | 'l' -> Predef.type_int32
+                 | 'n' -> Predef.type_nativeint
+                 | _ -> Predef.type_int64 in
+                conversion j ty_arg
+            | c ->
+               if conv = 'n' then conversion (j - 1) Predef.type_int else
+               raise(Error(loc, Bad_format(String.sub fmt i (j - i))))
+          end
+      | c ->
+          raise(Error(loc, Bad_format(String.sub fmt i (j - i + 1)))) in
+    scan_width i j in
+
+  let ty_ares, ty_res = scan_format 0 in
   newty
     (Tconstr(Predef.path_format,
-             [scan_format 0; ty_input; ty_aresult; ty_result],
+             [ty_res; ty_input; ty_ares; ty_result],
              ref Mnil))
 
 (* Approximate the type of an expression, for better recursion *)
@@ -930,8 +942,8 @@ let rec type_exp env sexp =
         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
+              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(sexp.pexp_loc, Label_missing missing))
@@ -1556,7 +1568,7 @@ and type_expect ?in_function env sexp ty_expected =
           exp_loc = sexp.pexp_loc;
           exp_type =
             (* Terrible hack for format strings *)
-            begin match (repr ty_expected).desc with
+            begin match (repr (expand_head env ty_expected)).desc with
               Tconstr(path, _, _) when Path.same path Predef.path_format ->
                 type_format sexp.pexp_loc s
             | _ -> instance Predef.type_string