Get rid of the Default case in Asttype.rec_flag.

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

bytecomp/translcore.ml

@@ -506,8 +506,9 @@ let rec push_defaults loc bindings pat_expr_list partial =
     [pat, ({exp_desc = Texp_function(l, pl,partial)} as exp)] ->
       let pl = push_defaults exp.exp_loc bindings pl partial in
       [pat, {exp with exp_desc = Texp_function(l, pl, partial)}]
-  | [pat, {exp_desc = Texp_let
-             (Default, cases, ({exp_desc = Texp_function _} as e2))}] ->
+  | [pat, {exp_attributes=["#default",_];
+           exp_desc = Texp_let
+             (Nonrecursive, cases, ({exp_desc = Texp_function _} as e2))}] ->
       push_defaults loc (cases :: bindings) [pat, e2] partial
   | [pat, exp] ->
       let exp =
@@ -965,7 +966,7 @@ and transl_function loc untuplify_fn repr partial pat_expr_list =
 
 and transl_let rec_flag pat_expr_list body =
   match rec_flag with
-    Nonrecursive | Default ->
+    Nonrecursive ->
       let rec transl = function
         [] ->
           body

experimental/frisch/extension_points.txt

@@ -332,6 +332,20 @@ directly to the parameters fields:
      ptype_loc: Location.t }
 
 
+--- Getting rid of 'Default' case in Astypes.rec_flag
+
+This constructor was used internally only during the compilation of
+default expression for optional arguments, in order to trigger a
+subsequent optimization (see PR#5975).  This behavior is now
+implemented by creating an attribute internally (whose name "#default"
+cannot be used in real programs).
+
+Rationale:
+
+ - Attributes give a way to encode information local to the
+   type-checker without polluting the definition of the Parsetree.
+
+
 === More TODOs
 
 - Adapt pprintast.

parsing/asttypes.mli

@@ -21,7 +21,7 @@ type constant =
   | Const_int64 of int64
   | Const_nativeint of nativeint
 
-type rec_flag = Nonrecursive | Recursive | Default
+type rec_flag = Nonrecursive | Recursive
 
 type direction_flag = Upto | Downto
 

parsing/pprintast.ml

@@ -187,7 +187,7 @@ class printer  ()= object(self:'self)
   (* trailing space added *)        
   method rec_flag f = function
     | Nonrecursive -> ()
-    | Recursive | Default -> pp f "rec "
+    | Recursive -> pp f "rec "
   method direction_flag f = function
     | Upto -> pp f "to@ "
     | Downto -> pp f "downto@ "

parsing/printast.ml

@@ -84,7 +84,6 @@ let fmt_rec_flag f x =
   match x with
   | Nonrecursive -> fprintf f "Nonrec";
   | Recursive -> fprintf f "Rec";
-  | Default -> fprintf f "Default";
 ;;
 
 let fmt_direction_flag f x =

tools/cmt2annot.ml

@@ -96,7 +96,6 @@ let iterator rebuild_env =
           let open Location in
           let doit loc_start = bind_bindings {scope with loc_start} bindings in
           begin match rec_flag, rem with
-          | Default, _ -> ()
           | Recursive, _ -> doit loc.loc_start
           | Nonrecursive, [] -> doit loc.loc_end
           | Nonrecursive,  {str_loc = loc2} :: _ -> doit loc2.loc_start

typing/printtyped.ml

@@ -87,7 +87,6 @@ let fmt_rec_flag f x =
   match x with
   | Nonrecursive -> fprintf f "Nonrec";
   | Recursive -> fprintf f "Rec";
-  | Default -> fprintf f "Default";
 ;;
 
 let fmt_direction_flag f x =

typing/typeclass.ml

@@ -860,7 +860,9 @@ and class_expr cl_num val_env met_env scl =
         Cl.fun_ ~loc:scl.pcl_loc
           l None
           (Pat.var ~loc (mknoloc "*opt*"))
-          (Cl.let_ ~loc:scl.pcl_loc Default [spat, smatch] sbody)
+          (Cl.let_ ~loc:scl.pcl_loc Nonrecursive [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') ->

typing/typecore.ml

@@ -1882,10 +1882,10 @@ and type_expect_ ?in_function env sexp ty_expected =
         ty_expected
   | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
       let scp =
-        match rec_flag with
-        | Recursive -> Some (Annot.Idef loc)
-        | Nonrecursive -> Some (Annot.Idef sbody.pexp_loc)
-        | Default -> None
+        match sexp.pexp_attributes, rec_flag with
+        | ["#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
@@ -1923,7 +1923,7 @@ and type_expect_ ?in_function env sexp ty_expected =
           l None
           [
            Pat.var ~loc (mknoloc "*opt*"),
-           Exp.let_ ~loc Default [spat, smatch] sbody;
+           Exp.let_ ~loc Nonrecursive ~attrs:["#default",Exp.constant (Const_int 0)] [spat, smatch] sbody;
           ]
       in
       type_expect ?in_function env sfun ty_expected

typing/typemod.ml

@@ -985,7 +985,6 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
                 | [] -> loc.Location.loc_end
                 | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start
               in Some (Annot.Idef {scope with Location.loc_start = start})
-          | Default -> None
         in
         let (defs, newenv) =
           Typecore.type_binding env rec_flag sdefs scope in