From c7c92e6a0641c10d5ecd90e23ecbb697e0d20d69 Mon Sep 17 00:00:00 2001 From: Jacques Garrigue Date: Mon, 6 Dec 1999 17:05:19 +0000 Subject: [PATCH] Nettoyage de l'optimisation des valeurs par defaut dans translcore.ml. Ajout de Default a Asttypes.rec_flag. git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2670 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- bytecomp/translcore.ml | 45 +++++++++++++++++++++++++++++++++++++----- parsing/asttypes.mli | 2 +- parsing/printast.ml | 1 + typing/typeclass.ml | 2 +- typing/typecore.ml | 4 ++-- 5 files changed, 45 insertions(+), 9 deletions(-) diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 67ee026d2..d399d0bda 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -280,6 +280,39 @@ let rec name_pattern default = function | Tpat_alias(p, id) -> id | _ -> name_pattern default rem +(* Push the default values under the functional abstractions *) + +let rec push_defaults loc bindings pat_expr_list partial = + match pat_expr_list with + [pat, ({exp_desc = Texp_function(pl,partial)} as exp)] -> + let pl = push_defaults exp.exp_loc bindings pl partial in + [pat, {exp with exp_desc = Texp_function(pl, partial)}] + | [pat, ({exp_desc = Texp_let + (Default, cases, ({exp_desc = Texp_function _} as e2))} as e1)] -> + push_defaults loc (cases :: bindings) [pat, e2] partial + | [pat, exp] -> + let exp = + List.fold_left + (fun exp cases -> + {exp with exp_desc = Texp_let(Nonrecursive, cases, exp)}) + exp bindings + in + [pat, exp] + | (pat, exp) :: _ when bindings <> [] -> + let param = name_pattern "param" pat_expr_list in + let exp = + { exp with exp_loc = loc; exp_desc = + Texp_match + ({exp with exp_type = pat.pat_type; exp_desc = + Texp_ident (Path.Pident param, + {val_type = pat.pat_type; val_kind = Val_reg})}, + pat_expr_list, partial) } + in + push_defaults loc bindings + [{pat with pat_desc = Tpat_var param}, exp] Total + | _ -> + pat_expr_list + (* Insertion of debugging events *) let event_before exp lam = @@ -329,8 +362,8 @@ let rec transl_exp e = let ((kind, params), body) = event_function e (function repr -> - transl_function e.exp_loc !Clflags.native_code repr [] partial - pat_expr_list) + let pl = push_defaults e.exp_loc [] pat_expr_list partial in + transl_function e.exp_loc !Clflags.native_code repr partial pl) in Lfunction(kind, params, body) | Texp_apply({exp_desc = Texp_ident(path, {val_kind = Val_prim p})}, args) @@ -523,14 +556,15 @@ and transl_apply lam sargs = in build_apply lam [] (List.map (may_map transl_exp) sargs) -and transl_function loc untuplify_fn repr bindings partial pat_expr_list = +and transl_function loc untuplify_fn repr partial pat_expr_list = match pat_expr_list with [pat, ({exp_desc = Texp_function(pl,partial')} as exp)] -> let param = name_pattern "param" pat_expr_list in let ((_, params), body) = - transl_function exp.exp_loc false repr bindings partial' pl in + transl_function exp.exp_loc false repr partial' pl in ((Curried, param :: params), Matching.for_function loc None (Lvar param) [pat, body] partial) +(* | [({pat_desc = Tpat_var id} as pat), ({exp_desc = Texp_let(Nonrecursive, cases, ({exp_desc = Texp_function _} as e2))} as e1)] @@ -556,6 +590,7 @@ and transl_function loc untuplify_fn repr bindings partial pat_expr_list = in transl_function loc untuplify_fn repr bindings Total [{pat with pat_desc = Tpat_var param}, exp] +*) | ({pat_desc = Tpat_tuple pl}, _) :: _ when untuplify_fn -> begin try let size = List.length pl in @@ -581,7 +616,7 @@ and transl_function loc untuplify_fn repr bindings partial pat_expr_list = and transl_let rec_flag pat_expr_list body = match rec_flag with - Nonrecursive -> + Nonrecursive | Default -> let rec transl = function [] -> body diff --git a/parsing/asttypes.mli b/parsing/asttypes.mli index cd30e3b5a..5aa9603a2 100644 --- a/parsing/asttypes.mli +++ b/parsing/asttypes.mli @@ -20,7 +20,7 @@ type constant = | Const_string of string | Const_float of string -type rec_flag = Nonrecursive | Recursive +type rec_flag = Nonrecursive | Recursive | Default type direction_flag = Upto | Downto diff --git a/parsing/printast.ml b/parsing/printast.ml index df30e7410..448aab72f 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -58,6 +58,7 @@ let fmt_rec_flag f x = match x with | Nonrecursive -> Format.fprintf f "Nonrec"; | Recursive -> Format.fprintf f "Rec"; + | Default -> Format.fprintf f "Default"; ;; let fmt_direction_flag f x = diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 98d3cb217..b9a9c9d63 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -579,7 +579,7 @@ and class_expr cl_num val_env met_env scl = {pcl_loc = scl.pcl_loc; pcl_desc = Pcl_fun(l, None, {ppat_loc = loc; ppat_desc = Ppat_var"*opt*"}, {pcl_loc = scl.pcl_loc; pcl_desc = - Pcl_let(Nonrecursive, [spat, smatch], sbody)})} + Pcl_let(Default, [spat, smatch], sbody)})} in class_expr cl_num val_env met_env sfun | Pcl_fun (l, _, spat, scl') -> diff --git a/typing/typecore.ml b/typing/typecore.ml index 2a515bc69..65bb402b6 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -1054,7 +1054,7 @@ and type_expect env sexp ty_expected = {pexp_loc = sexp.pexp_loc; pexp_desc = Pexp_function(l, None,[{ppat_loc = loc; ppat_desc = Ppat_var"*opt*"}, {pexp_loc = sexp.pexp_loc; pexp_desc = - Pexp_let(Nonrecursive,[spat,smatch],sbody)}])} + Pexp_let(Default, [spat, smatch], sbody)}])} in type_expect env sfun ty_expected | Pexp_function (l, _, caselist) -> @@ -1129,7 +1129,7 @@ and type_let env rec_flag spat_sexp_list = (fun pat (_, sexp) -> unify_pat env pat (type_approx env sexp)) pat_list spat_sexp_list; let exp_env = - match rec_flag with Nonrecursive -> env | Recursive -> new_env in + match rec_flag with Nonrecursive | Default -> env | Recursive -> new_env in let exp_list = List.map2 (fun (spat, sexp) pat -> type_expect exp_env sexp pat.pat_type)