From f1cb71f9ce96a001f9d55a210636fdf5f273a0fa Mon Sep 17 00:00:00 2001 From: Jacques Garrigue Date: Sat, 15 Sep 2001 13:57:43 +0000 Subject: [PATCH] new tool addlabels git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3762 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- Changes | 7 +- tools/.cvsignore | 2 +- tools/Makefile | 22 ++- tools/addlabels.ml | 368 +++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 393 insertions(+), 6 deletions(-) create mode 100644 tools/addlabels.ml diff --git a/Changes b/Changes index be144af53..b69417971 100644 --- a/Changes +++ b/Changes @@ -5,6 +5,7 @@ Language: - Switched the default behaviour to labels mode (labels are compulsory), but allows omitting labels when a function application is complete. -nolabels mode is available but deprecated for programming. + (See also scrapelabels and addlabels tools lower) - Removed all labels in the standard libraries, except labltk. Labelized versions are kept for ArrayLabels, ListLabels, StringLabels and UnixLabels. "open StdLabels" gives access to the first three. @@ -34,8 +35,10 @@ Toplevel environment: Tools: - New tool ocamlmklib to help build mixed Caml/C libraries. -- New tool scrapelabels to remove (non-optional) labels in interfaces, - providing a quick and dirty transition from ocaml 3.02. +- New tool scrapelabels and addlabels, to either remove (non-optional) + labels in interfaces, or automatically add them in the definitions. + They provide easy transition from classic mode ocaml 3.02 sources, + depending on whether you want to keep labels or not. - ocamldep: added -pp option to handle preprocessed source files. Run-time system: diff --git a/tools/.cvsignore b/tools/.cvsignore index fe7e2268d..8dcc03428 100644 --- a/tools/.cvsignore +++ b/tools/.cvsignore @@ -16,4 +16,4 @@ ocaml299to3 ocamlmklib lexer301.ml scrapelabels - +addlabels diff --git a/tools/Makefile b/tools/Makefile index d686559b8..3d4f85950 100644 --- a/tools/Makefile +++ b/tools/Makefile @@ -101,6 +101,12 @@ ocaml299to3: $(OCAML299TO3) lexer299.ml: lexer299.mll $(CAMLLEX) lexer299.mll +#install:: +# cp ocaml299to3 $(BINDIR)/ocaml299to3$(EXE) + +clean:: + rm -f ocaml299to3 lexer299.ml + # Label remover for interface files (upgrade 3.02 to 3.03) SCRAPELABELS= lexer301.cmo scrapelabels.cmo @@ -111,11 +117,21 @@ scrapelabels: $(SCRAPELABELS) lexer301.ml: lexer301.mll $(CAMLLEX) lexer301.mll -#install:: -# cp ocaml299to3 $(BINDIR)/ocaml299to3$(EXE) +clean:: + rm -f scrapelabels lexer301.ml + +# Insert labels following an interface file (upgrade 3.02 to 3.03) + +ADDLABELS_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ + linenum.cmo warnings.cmo location.cmo longident.cmo \ + syntaxerr.cmo parser.cmo lexer.cmo parse.cmo + +addlabels: addlabels.ml + $(CAMLC) $(LINKFLAGS) -w sl -o addlabels \ + $(ADDLABELS_IMPORTS) addlabels.ml clean:: - rm -f ocaml299to3 lexer299.ml + rm -f addlabels # The preprocessor for asm generators diff --git a/tools/addlabels.ml b/tools/addlabels.ml new file mode 100644 index 000000000..954b52c08 --- /dev/null +++ b/tools/addlabels.ml @@ -0,0 +1,368 @@ +(* $Id$ *) + +open StdLabels +open Asttypes +open Parsetree + +let norec = ref false + +let input_file file = + let ic = try open_in file with _ -> failwith ("input_file : " ^ file) in + let b = Buffer.create 1024 in + let buf = String.create 1024 and len = ref 0 in + while len := input ic buf 0 1024; !len > 0 do + Buffer.add_substring b buf 0 !len + done; + close_in ic; + Buffer.contents b + +module SMap = struct + include Map.Make(struct type t = string let compare = compare end) + let rec removes l m = + match l with [] -> m + | k::l -> + let m = try remove k m with Not_found -> m in + removes l m +end + +let rec labels_of_sty sty = + match sty.ptyp_desc with + Ptyp_arrow (lab, _, rem) -> lab :: labels_of_sty rem + | Ptyp_alias (rem, _) -> labels_of_sty rem + | _ -> [] + +let rec labels_of_cty cty = + match cty.pcty_desc with + Pcty_fun (lab, _, rem) -> lab :: labels_of_cty rem + | _ -> [] + +let rec pattern_vars pat = + match pat.ppat_desc with + Ppat_var s -> [s] + | Ppat_alias (pat, s) -> + s :: pattern_vars pat + | Ppat_tuple l + | Ppat_array l -> + List.concat (List.map pattern_vars l) + | Ppat_construct (_, Some pat, _) + | Ppat_variant (_, Some pat) + | Ppat_constraint (pat, _) -> + pattern_vars pat + | Ppat_record l -> + List.concat (List.map l ~f:(fun (_,p) -> pattern_vars p)) + | Ppat_or (pat1, pat2) -> + pattern_vars pat1 @ pattern_vars pat2 + | Ppat_any | Ppat_constant _ | Ppat_construct _ | Ppat_variant _ + | Ppat_type _ -> + [] + +let pattern_name pat = + match pat.ppat_desc with + Ppat_var s -> Some s + | Ppat_constraint ({ppat_desc = Ppat_var s}, _) -> Some s + | _ -> None + +let insertions = ref [] +let add_insertion pos s = insertions := (pos,s) :: !insertions +let sort_insertions () = + List.sort !insertions ~cmp:(fun (pos1,_) (pos2,_) -> pos1 - pos2) + +let is_space = function ' '|'\t'|'\n'|'\r' -> true | _ -> false +let is_alphanum = function 'A'..'Z'|'a'..'z'|'_'|'\192'..'\214'|'\216'..'\246' + | '\248'..'\255'|'\''|'0'..'9' -> true + | _ -> false + +(* Remove "(" or "begin" before a pattern *) +let rec insertion_point pos ~text = + let pos' = ref (pos-1) in + while is_space text.[!pos'] do decr pos' done; + if text.[!pos'] = '(' then insertion_point !pos' ~text else + if !pos' >= 5 && String.sub text ~pos:(!pos'-4) ~len:5 = "begin" + && not (is_alphanum text.[!pos'-5]) then insertion_point (!pos'-4) ~text + else pos + +(* Search "=" or "->" before "function" *) +let rec insertion_point2 pos ~text = + let pos' = ref (pos-1) in + while is_space text.[!pos'] do decr pos' done; + if text.[!pos'] = '(' then insertion_point2 !pos' ~text else + if !pos' >= 5 && String.sub text ~pos:(!pos'-4) ~len:5 = "begin" + && not (is_alphanum text.[!pos'-5]) then insertion_point2 (!pos'-4) ~text + else if text.[!pos'] = '=' then Some !pos' else + if !pos' >= 1 && text.[!pos'-1] = '-' && text.[!pos'] = '>' + then Some (!pos' - 1) + else None + +let rec insert_labels ~labels ~text expr = + match labels, expr.pexp_desc with + l::labels, Pexp_function(l', _, [pat, rem]) -> + if l <> "" && l.[0] <> '?' && l' = "" then begin + let pos = insertion_point pat.ppat_loc.Location.loc_start ~text in + match pattern_name pat with + | Some name when l = name -> add_insertion pos "~" + | _ -> add_insertion pos ("~" ^ l ^ ":") + end; + insert_labels ~labels ~text rem + | l::labels, Pexp_function(l', _, lst) -> + let pos = expr.pexp_loc.Location.loc_start in + if l <> "" && l.[0] <> '?' && l' = "" + && String.sub text ~pos ~len:8 = "function" then begin + String.blit ~src:"match th" ~src_pos:0 ~dst:text + ~dst_pos:pos ~len:8; + add_insertion (pos+6) (l ^ " wi"); + match insertion_point2 pos ~text with + Some pos' -> + add_insertion pos' ("~" ^ l ^ " ") + | None -> + add_insertion pos ("fun ~" ^ l ^ " -> ") + end; + List.iter lst ~f:(fun (p,e) -> insert_labels ~labels ~text e) + | _, Pexp_match( _, lst) -> + List.iter lst ~f:(fun (p,e) -> insert_labels ~labels ~text e) + | _, Pexp_try(expr, lst) -> + insert_labels ~labels ~text expr; + List.iter lst ~f:(fun (p,e) -> insert_labels ~labels ~text e) + | _, ( Pexp_let(_,_,e) | Pexp_sequence(_,e) | Pexp_when(_,e) + | Pexp_constraint(e,_,_) | Pexp_letmodule(_,_,e) + | Pexp_ifthenelse(_,e,None) ) -> + insert_labels ~labels ~text e + | _, Pexp_ifthenelse (_, e1, Some e2) -> + insert_labels ~labels ~text e1; + insert_labels ~labels ~text e2 + | _ -> + () + +let rec insert_labels_class ~labels ~text expr = + match labels, expr.pcl_desc with + l::labels, Pcl_fun(l', _, pat, rem) -> + if l <> "" && l.[0] <> '?' && l' = "" then begin + let pos = insertion_point pat.ppat_loc.Location.loc_start ~text in + match pattern_name pat with + | Some name when l = name -> add_insertion pos "~" + | _ -> add_insertion pos ("~" ^ l ^ ":") + end; + insert_labels_class ~labels ~text rem + | labels, (Pcl_constraint (expr, _) | Pcl_let (_, _, expr)) -> + insert_labels_class ~labels ~text expr + | _ -> + () + +let rec insert_labels_app ~labels ~text args = + match labels, args with + l::labels, (l',arg)::args -> + if l <> "" && l.[0] <> '?' && l' = "" then begin + let pos0 = arg.pexp_loc.Location.loc_start in + let pos = insertion_point pos0 ~text in + match arg.pexp_desc with + | Pexp_ident(Longident.Lident name) when l = name && pos = pos0 -> + add_insertion pos "~" + | _ -> add_insertion pos ("~" ^ l ^ ":") + end; + insert_labels_app ~labels ~text args + | _ -> + () + +let rec add_labels_expr ~text ~values ~classes expr = + let add_labels_rec = add_labels_expr ~text ~values ~classes in + match expr.pexp_desc with + Pexp_apply ({pexp_desc=Pexp_ident(Longident.Lident s)}, args) -> + begin try + let labels = SMap.find s values in + insert_labels_app ~labels ~text args + with Not_found -> () + end; + List.iter args ~f:(fun (_,e) -> add_labels_rec e) + | Pexp_apply ({pexp_desc=Pexp_new (Longident.Lident s)}, args) -> + begin try + let labels = SMap.find s classes in + insert_labels_app ~labels ~text args + with Not_found -> () + end + | Pexp_let (recp, lst, expr) -> + let vars = List.concat (List.map lst ~f:(fun (p,_) -> pattern_vars p)) in + let vals = SMap.removes vars values in + List.iter lst ~f: + begin fun (_,e) -> + add_labels_expr e ~text ~classes + ~values:(if recp = Recursive then vals else values) + end; + add_labels_expr expr ~text ~classes ~values:vals + | Pexp_function (_, None, lst) -> + List.iter lst ~f: + begin fun (p,e) -> + add_labels_expr e ~text ~classes + ~values:(SMap.removes (pattern_vars p) values) + end + | Pexp_function (_, Some e, lst) + | Pexp_match (e, lst) + | Pexp_try (e, lst) -> + add_labels_rec e; + List.iter lst ~f: + begin fun (p,e) -> + add_labels_expr e ~text ~classes + ~values:(SMap.removes (pattern_vars p) values) + end + | Pexp_apply (e, args) -> + List.iter add_labels_rec (e :: List.map snd args) + | Pexp_tuple l | Pexp_array l -> + List.iter add_labels_rec l + | Pexp_construct (_, Some e, _) + | Pexp_variant (_, Some e) + | Pexp_field (e, _) + | Pexp_constraint (e, _, _) + | Pexp_send (e, _) + | Pexp_setinstvar (_, e) + | Pexp_letmodule (_, _, e) + | Pexp_assert e -> + add_labels_rec e + | Pexp_record (lst, opt) -> + List.iter lst ~f:(fun (_,e) -> add_labels_rec e); + begin match opt with Some e -> add_labels_rec e | None -> () end + | Pexp_setfield (e1, _, e2) + | Pexp_ifthenelse (e1, e2, None) + | Pexp_sequence (e1, e2) + | Pexp_while (e1, e2) + | Pexp_when (e1, e2) -> + add_labels_rec e1; add_labels_rec e2 + | Pexp_ifthenelse (e1, e2, Some e3) -> + add_labels_rec e1; add_labels_rec e2; add_labels_rec e3 + | Pexp_for (s, e1, e2, _, e3) -> + add_labels_rec e1; add_labels_rec e2; + add_labels_expr e3 ~text ~classes ~values:(SMap.removes [s] values) + | Pexp_override lst -> + List.iter lst ~f:(fun (_,e) -> add_labels_rec e) + | Pexp_ident _ | Pexp_constant _ | Pexp_construct _ | Pexp_variant _ + | Pexp_new _ | Pexp_assertfalse -> + () + +let rec add_labels_class ~text ~classes ~values cl = + match cl.pcl_desc with + Pcl_constr _ -> () + | Pcl_structure (p, l) -> + let values = SMap.removes (pattern_vars p) values in + List.fold_left l ~init:values ~f: + begin fun values -> function + | Pcf_val (s, _, e, _) -> + add_labels_expr ~text ~classes ~values e; + SMap.removes [s] values + | Pcf_meth (_, _, e, _) | Pcf_init e -> + add_labels_expr ~text ~classes ~values e; + values + | Pcf_inher _ | Pcf_virt _ | Pcf_cstr _ -> values + | Pcf_let _ -> values (* not in the grammar *) + end; + () + | Pcl_fun (_, opt, pat, cl) -> + begin match opt with None -> () + | Some e -> add_labels_expr ~text ~classes ~values e + end; + let values = SMap.removes (pattern_vars pat) values in + add_labels_class ~text ~classes ~values cl + | Pcl_apply (cl, args) -> + List.map args ~f:(fun (_,e) -> add_labels_expr ~text ~classes ~values e); + add_labels_class ~text ~classes ~values cl + | Pcl_let (recp, lst, cl) -> + let vars = List.concat (List.map lst ~f:(fun (p,_) -> pattern_vars p)) in + let vals = SMap.removes vars values in + List.iter lst ~f: + begin fun (_,e) -> + add_labels_expr e ~text ~classes + ~values:(if recp = Recursive then vals else values) + end; + add_labels_class cl ~text ~classes ~values:vals + | Pcl_constraint (cl, _) -> + add_labels_class ~text ~classes ~values cl + +let add_labels ~intf ~impl ~file = + insertions := []; + let values, classes = + List.fold_left intf ~init:(SMap.empty, SMap.empty) ~f: + begin fun (values, classes as acc) item -> + match item.psig_desc with + Psig_value (name, {pval_type = sty}) -> + (SMap.add name (labels_of_sty sty) values, classes) + | Psig_class l -> + (values, + List.fold_left l ~init:classes ~f: + begin fun classes {pci_name=name; pci_expr=cty} -> + SMap.add name (labels_of_cty cty) classes + end) + | _ -> + acc + end + in + let text = input_file file in + List.fold_right impl ~init:(values, classes) ~f: + begin fun item (values, classes as acc) -> + match item.pstr_desc with + Pstr_value (recp, l) -> + List.iter l ~f: + begin fun (pat, expr) -> + begin match pattern_name pat with + | Some s -> + begin try + let labels = SMap.find s values in + insert_labels ~labels ~text expr; + add_labels_expr ~text ~values ~classes expr + with Not_found -> () + end + | None -> () + end; + end; + let names = + List.concat (List.map l ~f:(fun (p,_) -> pattern_vars p)) in + (SMap.removes names values, classes) + | Pstr_class l -> + List.iter l ~f: + begin fun {pci_name=name; pci_expr=expr} -> + try + let labels = SMap.find name classes in + insert_labels_class ~labels ~text expr; + add_labels_class ~text ~values ~classes expr + with Not_found -> () + end; + let names = List.map l ~f:(fun pci -> pci.pci_name) in + (values, SMap.removes names classes) + | _ -> + acc + end; + if !insertions <> [] then begin + Sys.rename file (file ^ ".bak"); + let oc = open_out file in + let last_pos = + List.fold_left (sort_insertions ()) ~init:0 ~f: + begin fun pos (pos', s) -> + output oc text pos (pos'-pos); + output_string oc s; + pos' + end in + if last_pos < String.length text then + output oc text last_pos (String.length text - last_pos); + close_out oc + end + else prerr_endline ("No labels to insert in " ^ file) + +let process_file file = + prerr_endline ("Processing " ^ file); + if Filename.check_suffix file ".ml" then + let intf = Filename.chop_suffix file ".ml" ^ ".mli" in + let ic = open_in intf in + let lexbuf = Lexing.from_channel ic in + let intf = Parse.interface lexbuf in + close_in ic; + let ic = open_in file in + let lexbuf = Lexing.from_channel ic in + let impl = Parse.implementation lexbuf in + close_in ic; + add_labels ~intf ~impl ~file + else prerr_endline (file ^ " is not an implementation") + +let main () = + let files = ref [] in + Arg.parse ["-norec", Arg.Set norec, "do not labelize recursive calls"] + (fun f -> files := f :: !files) + "addlabels [-norec] "; + let files = List.rev !files in + List.iter files ~f:process_file + +let () = main ()