relaxation de la semantique des effets de bords sur les parametres

optionels, pour permettre une compilation plus efficace.
modifie' translcore, typedtree, typecore, typeclass


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

8 files changed, 50 insertions, 33 deletions

diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 264d7e7d88..361df9259b 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -453,8 +453,9 @@ let rec transl_exp e =
       in
       Lfunction(kind, params, body)
   | Texp_apply({exp_desc = Texp_ident(path, {val_kind = Val_prim p})}, args)
-    when List.length args = p.prim_arity && List.for_all ((<>) None) args ->
-      let args = List.map (function Some x -> x | None -> assert false) args in
+    when List.length args = p.prim_arity
+    && List.for_all (fun (arg,_) -> arg <> None) args ->
+      let args = List.map (function Some x, _ -> x | _ -> assert false) args in
       let prim = transl_prim p args in
       let lam = Lprim(prim, transl_list args) in
       begin match prim with Pccall _ -> event_after e lam | _ -> lam end
@@ -610,7 +611,7 @@ and transl_apply lam sargs =
         Lapply(lexp, args)
   in
   let rec build_apply lam args = function
-      None :: l ->
+      (None, optional) :: l ->
         let defs = ref [] in
         let protect name lam =
           match lam with
@@ -620,13 +621,16 @@ and transl_apply lam sargs =
               defs := (id, lam) :: !defs;
               Lvar id
         in
+        let args, args' =
+          if List.for_all (fun (_,opt) -> opt = Optional) args then [], args
+          else args, [] in
         let lam =
-          if args = [] then lam else lapply lam (List.rev args) in
+          if args = [] then lam else lapply lam (List.rev_map fst args) in
         let handle = protect "func" lam
-        and l = List.map (may_map (protect "arg")) l
+        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] l with
+          match build_apply handle ((Lvar id_arg, optional)::args') l with
             Lfunction(Curried, ids, lam) ->
               Lfunction(Curried, id_arg::ids, lam)
           | Levent(Lfunction(Curried, ids, lam), _) ->
@@ -637,12 +641,12 @@ and transl_apply lam sargs =
         List.fold_left
           (fun body (id, lam) -> Llet(Strict, id, lam, body))
           body !defs
-    | Some arg :: l ->
-        build_apply lam (arg :: args) l
+    | (Some arg, optional) :: l ->
+        build_apply lam ((arg, optional) :: args) l
     | [] ->
-        lapply lam (List.rev args)
+        lapply lam (List.rev_map fst args)
   in
-  build_apply lam [] (List.map (may_map transl_exp) sargs)
+  build_apply lam [] (List.map (fun (x,o) -> may_map transl_exp x, o) sargs)
 
 and transl_function loc untuplify_fn repr partial pat_expr_list =
   match pat_expr_list with
diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli
index 998189ec03..3ad655b229 100644
--- a/bytecomp/translcore.mli
+++ b/bytecomp/translcore.mli
@@ -23,7 +23,7 @@ open Lambda
 val name_pattern: string -> (pattern * 'a) list -> Ident.t
 
 val transl_exp: expression -> lambda
-val transl_apply: lambda -> expression option list -> lambda
+val transl_apply: lambda -> (expression option * optional) list -> lambda
 val transl_let:
       rec_flag -> (pattern * expression) list -> lambda -> lambda
 val transl_primitive: Primitive.description -> lambda
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index 201e2b8b92..c224c5fbed 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -641,7 +641,7 @@ and search_pos_class_expr ~pos cl =
         search_pos_class_expr cl ~pos
     | Tclass_apply (cl, el) ->
         search_pos_class_expr cl ~pos;
-        List.iter el ~f:(Misc.may (search_pos_expr ~pos))
+        List.iter el ~f:(fun (x,_) -> Misc.may (search_pos_expr ~pos) x)
     | Tclass_let (_, pel, iel, cl) ->
         List.iter pel ~f:
           begin fun (pat, exp) ->
@@ -678,7 +678,7 @@ and search_pos_expr ~pos exp =
         search_pos_expr exp ~pos
       end
   | Texp_apply (exp, l) ->
-      List.iter l ~f:(Misc.may (search_pos_expr ~pos));
+      List.iter l ~f:(fun (x,_) -> Misc.may (search_pos_expr ~pos) x);
       search_pos_expr exp ~pos
   | Texp_match (exp, l, _) ->
       search_pos_expr exp ~pos;
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index c772af545f..2669e0763e 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -622,7 +622,9 @@ and class_expr cl_num val_env met_env scl =
       let rec type_args args omitted ty_fun sargs more_sargs =
         match ty_fun with
         | Tcty_fun (l, ty, ty_fun) when sargs <> [] || more_sargs <> [] ->
-            let name = Btype.label_name l in
+            let name = Btype.label_name l
+            and optional =
+              if Btype.is_optional l then Optional else Required in
             let sargs, more_sargs, arg =
               if !Clflags.classic && not (Btype.is_optional l) then begin
                 match sargs, more_sargs with
@@ -661,7 +663,7 @@ and class_expr cl_num val_env met_env scl =
                 else None
             in
             let omitted = if arg = None then (l,ty) :: omitted else omitted in
-            type_args (arg::args) omitted ty_fun sargs more_sargs
+            type_args ((arg,optional)::args) omitted ty_fun sargs more_sargs
         | _ ->
             match sargs @ more_sargs with
               (l, sarg0)::_ ->
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 3b9be8b248..0a6829ba5d 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -430,8 +430,8 @@ let rec is_nonexpansive exp =
   | Texp_let(rec_flag, pat_exp_list, body) ->
       List.for_all (fun (pat, exp) -> is_nonexpansive exp) pat_exp_list &&
       is_nonexpansive body
-  | Texp_apply(e, None::el) ->
-      is_nonexpansive e && List.for_all is_nonexpansive_opt el
+  | Texp_apply(e, (None,_)::el) ->
+      is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map fst el)
   | Texp_function _ -> true
   | Texp_tuple el ->
       List.for_all is_nonexpansive el
@@ -840,7 +840,8 @@ let rec type_exp env sexp =
                               [Some {exp_desc = Texp_ident(path, desc);
                                      exp_loc = obj.exp_loc;
                                      exp_type = desc.val_type;
-                                     exp_env = env }]),
+                                     exp_env = env },
+                               Required]),
                    typ)
               |  _ ->
                   assert false
@@ -969,7 +970,9 @@ and type_argument env sarg ty_expected =
       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 ->
-            make_args (Some(option_none ty_arg sarg.pexp_loc) :: args) ty_fun
+            make_args
+              ((Some(option_none ty_arg sarg.pexp_loc), Optional) :: args)
+              ty_fun
         | Tarrow (l,_,_) when l = "" || !Clflags.classic ->
             args, ty_fun
         | Tvar ->  args, ty_fun
@@ -990,7 +993,8 @@ and type_argument env sarg ty_expected =
       let func texp =
         { texp with exp_type = ty_fun; exp_desc =
           Texp_function([eta_pat, {texp with exp_type = ty_res; exp_desc =
-                                   Texp_apply (texp, args@[Some eta_var])}],
+                                   Texp_apply (texp, args@
+                                               [Some eta_var, Required])}],
                         Total) } in
       if is_nonexpansive texp then func texp else
       (* let-expand to have side effects *)
@@ -1009,7 +1013,9 @@ and type_application env funct sargs =
   let ignored = ref [] in
   let rec type_unknown_args args omitted ty_fun = function
       [] ->
-        (List.rev_map (function None -> None | Some f -> Some (f ())) args,
+        (List.rev_map
+           (function None, x -> None, x | Some f, x -> Some (f ()), x)
+           args,
          result_type omitted ty_fun)
     | (l1, sarg1) :: sargl ->
         let (ty1, ty2) =
@@ -1028,18 +1034,21 @@ and type_application env funct sargs =
             | _ ->
                 raise(Error(funct.exp_loc,
                             Apply_non_function funct.exp_type)) in
+        let optional = if is_optional l1 then Optional else Required in
         let arg1 () =
           let arg1 = type_expect env sarg1 ty1 in
-          if is_optional l1 then unify_exp env arg1 (type_option(newvar()));
+          if optional = Optional then
+            unify_exp env arg1 (type_option(newvar()));
           arg1
         in
-        type_unknown_args (Some arg1 :: args) omitted ty2 sargl
+        type_unknown_args ((Some arg1, optional) :: args) omitted ty2 sargl
   in
   let rec type_args args omitted ty_fun ty_old sargs more_sargs =
     match expand_head env ty_fun with
       {desc=Tarrow (l, ty, ty_fun); level=lv} as ty_fun'
       when sargs <> [] || more_sargs <> [] ->
-        let name = label_name l in
+        let name = label_name l
+        and optional = if is_optional l then Optional else Required in
         let sargs, more_sargs, arg =
           if !Clflags.classic && not (is_optional l) then begin
             (* In classic mode, omitted = [] *)
@@ -1063,14 +1072,14 @@ and type_application env funct sargs =
                 in (l', sarg0, sargs @ sargs1, sargs2)
             in
             sargs, more_sargs,
-            if is_optional l' || not (is_optional l) then
+            if optional = Required || is_optional l' then
               Some (fun () -> type_argument env sarg0 ty)
             else
               Some (fun () -> option_some (type_argument env sarg0 
                                              (extract_option_type env ty)))
           with Not_found ->
             sargs, more_sargs,
-            if is_optional l &&
+            if optional = Optional &&
               (List.mem_assoc "" sargs || List.mem_assoc "" more_sargs)
             then begin
               ignored := (l,ty,lv) :: !ignored;
@@ -1079,7 +1088,7 @@ and type_application env funct sargs =
         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 (arg::args) omitted ty_fun ty_old sargs more_sargs
+        type_args ((arg,optional)::args) omitted ty_fun ty_old sargs more_sargs
     | _ ->
         match sargs with
           (l, sarg0) :: _ when !Clflags.classic ->
@@ -1098,7 +1107,7 @@ and type_application env funct sargs =
           Location.prerr_warning exp.exp_loc Warnings.Partial_application
       | _ -> ()
       end;
-      ([Some exp], ty_res)
+      ([Some exp, Required], ty_res)
   | _ ->
       let ty = funct.exp_type in
       if !Clflags.classic then
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index 3e0f97a1bf..1d06dc5444 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -39,6 +39,7 @@ and pattern_desc =
   | Tpat_or of pattern * pattern
 
 type partial = Partial | Total
+type optional = Required | Optional
 
 type expression =
   { exp_desc: expression_desc;
@@ -51,7 +52,7 @@ and expression_desc =
   | Texp_constant of constant
   | Texp_let of rec_flag * (pattern * expression) list * expression
   | Texp_function of (pattern * expression) list * partial
-  | Texp_apply of expression * expression option list
+  | Texp_apply of expression * (expression option * optional) list
   | Texp_match of expression * (pattern * expression) list * partial
   | Texp_try of expression * (pattern * expression) list
   | Texp_tuple of expression list
@@ -89,7 +90,7 @@ and class_expr_desc =
     Tclass_ident of Path.t
   | Tclass_structure of class_structure
   | Tclass_fun of pattern * (Ident.t * expression) list * class_expr * partial
-  | Tclass_apply of class_expr * expression option list
+  | Tclass_apply of class_expr * (expression option * optional) list
   | Tclass_let of rec_flag *  (pattern * expression) list *
                   (Ident.t * expression) list * class_expr
   | Tclass_constraint of class_expr * string list * string list * Concr.t
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index e406d28aed..bf40a0cf76 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -38,6 +38,7 @@ and pattern_desc =
   | Tpat_or of pattern * pattern
 
 type partial = Partial | Total
+type optional = Required | Optional
 
 type expression =
   { exp_desc: expression_desc;
@@ -50,7 +51,7 @@ and expression_desc =
   | Texp_constant of constant
   | Texp_let of rec_flag * (pattern * expression) list * expression
   | Texp_function of (pattern * expression) list * partial
-  | Texp_apply of expression * expression option list
+  | Texp_apply of expression * (expression option * optional) list
   | Texp_match of expression * (pattern * expression) list * partial
   | Texp_try of expression * (pattern * expression) list
   | Texp_tuple of expression list
@@ -88,7 +89,7 @@ and class_expr_desc =
     Tclass_ident of Path.t
   | Tclass_structure of class_structure
   | Tclass_fun of pattern * (Ident.t * expression) list * class_expr * partial
-  | Tclass_apply of class_expr * expression option list
+  | Tclass_apply of class_expr * (expression option * optional) list
   | Tclass_let of rec_flag *  (pattern * expression) list *
                   (Ident.t * expression) list * class_expr
   | Tclass_constraint of class_expr * string list * string list * Concr.t
diff --git a/utils/config.mlp b/utils/config.mlp
index 9d94fb1e3f..0b0fa90468 100644
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -12,7 +12,7 @@
 
 (* $Id$ *)
 
-let version = "3.00+11 (2000-09-01)"
+let version = "3.00+12 (2000-09-04)"
 
 let standard_library =
   try