Commit 7b337aef authored by charguer's avatar charguer

Merge branch 'cfml2' of git+ssh://scm.gforge.inria.fr//gitroot/cfml/cfml into cfml2

parents fc40fc7d ec836ce2
xwhile: error reporting when arguments don't have the right types.
notation "# H" uniquement lorsque H est au type hprop. xwhile: error reporting when arguments don't have the right types.
rename xextract to xpull; and xgen to xpush. rename xextract to xpull; and xgen to xpush.
todo: model K/E -> list V infix_eq_
comparable_type A || comparable_value x || comparable_value y comparable_type A || comparable_value x || comparable_value y
x = y : A x = y : A
comparable_value x || comparable_value y comparable_value x || comparable_value y
x = y : A x = y : A
forall x : int, comparable_value x forall x : int, comparable_value x
mettre trop de let pour les fonctions builtin;
xuntag_goal. => dans xcf.
CFPrint.tag
app_def
infix_eq_
assume
MAJOR TODAY MAJOR TODAY
...@@ -40,8 +23,12 @@ MAJOR TODAY ...@@ -40,8 +23,12 @@ MAJOR TODAY
- for downto - for downto
- inline CFHeader.pred as -1
MAJOR NEXT MAJOR NEXT
- xchanges
- record with - record with
- when clauses - when clauses
...@@ -50,55 +37,38 @@ MAJOR NEXT ...@@ -50,55 +37,38 @@ MAJOR NEXT
- xabstract => reimplement and rename as xgen - xabstract => reimplement and rename as xgen
- open no scope in CF.
- add support for pure records
MAJOR NEXT NEXT MAJOR NEXT NEXT
- record single field and array single cell notation - record single field and array single cell notation
Notation "x `. f '~>' S" := Notation "x `. f '~>' S" :=
Notation "x `[ i ] '~>' S" := Notation "x `[ i ] '~>' S" :=
- realize array specification using single-cell array specifications - realize array specification using single-cell array specifications
- see if we can get rid of make_cmj
MAJOR POSTPONED MAJOR POSTPONED
- support float - support float
- add support for pure records
=> need type information for normalization
=> how to shared typed/untyped AST
- implement the work around for type abbreviations: - implement the work around for type abbreviations:
type typerecb1 = | Typerecb_1 of typerecb2 type typerecb1 = | Typerecb_1 of typerecb2
and typerecb2 = typerecb1 list and typerecb2 = typerecb1 list
SANITY
- discuss the naming scheme
=> type t --> t_ || x'
=> var fresh x --> x12__
=> var x' --> x_prime_
=> var (++) --> plus_plus_infix_ || infix_plus_plus_
=> PB: plus_plus_infix' !
=> var x_ --> forbidden
- reject programs with constructor names ending with "_"
(e.g. "A_" is already used for type variables *)
- reject variable names and type definition that belongs to the list - would it be better to perform all renaming during normalization phase?
builtin_type_constructors
- rename on the fly coq keyword such as exists, forall, etc.. - have a flag to control whether functions such as "min", "max", "abs", etc..
=> requires a list of all coq keywords: see should be systematically let-bound; this would allow binding these names.
else if name = "exists" then "exists__"
else if name = "forall" then "forall__"
- prevent rebinding of List
- restriction on not binding "min" and "max" might be a bit restrictive.. ##################################################################
# FUTURE WORK
- need to prevent double-underscore in the names?
OTHER LANGUAGES OTHER LANGUAGES
...@@ -130,7 +100,31 @@ MAKEFILE BEAUTIFY ...@@ -130,7 +100,31 @@ MAKEFILE BEAUTIFY
- make systematic use of || (rm -f $@; exit 1) in cfml calls - make systematic use of || (rm -f $@; exit 1) in cfml calls
- In the makefile.Coq, when building the .vq and obtaining - In the makefile.Coq, when building the .vq and obtaining
"Error: /home/charguer/tlc/src/LibPer.vio: premature end of file. Try to rebuild it." "Error: /home/charguer/tlc/src/LibPer.vio: premature end of file. Try to rebuild it."
=> then delete the .vio file => then delete the .vio file
(useful for compilations interrupted using CTRL+C) (useful for compilations interrupted using CTRL+C)
=> even better, wrap "coqc -quick" with an atomic commit of its result. => even better, wrap "coqc -quick" with an atomic commit of its result.
##################################################################
# PROPOSAL FOR DEFENSIVE CODE
- VStack.ml contains a verified stack implemementation using CFML.
(not polluted by any runtime checks).
- SStack.ml is a wrapper for VStack which adds asserts;
e.g. let pop s = assert (!s <> nil); VStack.pop s
- The file SStack.ml is processed using a special mode of CFML,
in which "assert t" is interpreted as "t needs to run safely
and produce some boolean; and the rest of the code may
assume this boolean to be true". Formally:
(Assert F) H Q :=
exists (P:Prop),
(F H (fun (b:bool) => [b = true <-> P] \* H))
/\ (H \* [P] ==> Q tt)
During the proof, the user needs to provide the proposition
[P] that is tested by the assertion. This proposition can
be assumed to be true after the assert is executed.
...@@ -24,9 +24,31 @@ let f () : 'a list = ...@@ -24,9 +24,31 @@ let f () : 'a list =
*) *)
(********************************************************************)
(* ** Encoding of names *)
(* type renaming_t_ = int --rejected *)
(* type renaming_t__ = int --rejected *)
(* type renaming_t1 = C_ --rejected *)
type renaming_t' = int
type renaming_t2 = C'
type 'a renaming_t3 = int
type 'a_ renaming_t4 = int
let renaming_demo () =
(* let x_ = 3 in --rejected *)
(* let x__ = 3 in --rejected *)
let x = 3 in
let x' = 3 in
let x_' = 3 in
let exists = 3 in
let array = 3 in
()
(********************************************************************) (********************************************************************)
(* ** Return *) (* ** Return *)
let ret_unit x = let ret_unit x =
() ()
......
This diff is collapsed.
...@@ -21,4 +21,13 @@ clean: ...@@ -21,4 +21,13 @@ clean:
# TODO: understand if myocamldeb is needed or not. # TODO: understand if myocamldeb is needed or not.
\ No newline at end of file
#####################################################################
doc: README.html
README.html: README.md
pandoc -o $@ $<
#####################################################################
# Binaries
`main`
: for building `*_ml.v` files from `*.ml` files. The `*_ml.v` files contain the characteristic formulae.
`makecmj`
: for building `*.cmj` files from `*.ml` and `*.mli` files, which are like `*.cmi` files, but named differently to avoid conflicts. The `*.cmj` files are required for the separate compilation performed by the `main` tool.
#####################################################################
# Compilation of the binaries
Execute:
```
make
```
#####################################################################
# Options for `main` and `makecmj`
`-I` *folder*
: Add an include directory where to look for `*.cmj` files.
`-rectypes`
: Allow type-checking with recursive types.
`-nostdlib`
: Use this file to compile `*.ml` files from the standard library.
`-nopervasives`
: Use this file to compile Pervasives.ml.
#####################################################################
# Options for `main`
`-o` *FILENAME*
: Set the output file name. By default, `*_ml.v` for `*.ml`
`-rectypes`
: Allow type-checking with recursive types.
`-left2right`
: Assume that side-effects are performed in the left subexpressions first, unlike OCaml's convention.
`-only_normalize`
: Normalize the code, but do not attempt building the characteristic formula file.
`-debug`
: Trace the various steps performed by the tool.
`-width`
: Set the pretty-printing width for the output file.
`-credits`
: [FUTURE USE] Generate characteristic formulae with time credits.
#####################################################################
# Organization of the code
`main.ml`
: Drives the operations.
`renaming.ml`
: Contains the convention for mapping names of variables, types, constructors and modules. It includes the list of builtin types and operators that are treated specially.
`normalize.ml`
: Describes a source-to-source translation at the level of the parse tree. This translation implements a form of A-normalization: it pulls out all side-effectful sub-expressions, and all function definitions, into seperate let bindings. This translation also rejects programs using features that are not supported by CFML.
`formula.ml`
: Describes a data type called `formula`, which serves as an intermediate representation for characteristic formulae before they get dumped as Coq syntax.
`coq.ml`
: Describes a data type called `coq`, which serves as a structured representation for Coq terms.
`characteristic.ml`
: Converts a typed abstract syntax tree into a structure of type `formula`.
`formula_to_coq.ml`
: Converts a structure of type `formula` into a structured `coq` term.
`print_coq.ml`
: Converts a structured `coq` term into a pretty-printed string.
`print_past.ml`
: Prints an AST, obtained from the parser.
`print_tast.ml`
: Prints a typed AST, obtained from type-checker.
#####################################################################
# Debugging
For debugging purposes, when compiling a `*.ml` file, the `main` tool
generates three files:
* `output/*_original.ml`
* `output/*_normalized.ml`
* `output/*_normalized_types.ml`
These files are not in valid syntax, and are not pretty-printed,
but they allow debugging the normalization process.
...@@ -233,7 +233,7 @@ let rec pattern_variables p : typed_vars = (* ignores aliases *) ...@@ -233,7 +233,7 @@ let rec pattern_variables p : typed_vars = (* ignores aliases *)
let aux = pattern_variables in let aux = pattern_variables in
match p.pat_desc with match p.pat_desc with
| Tpat_any -> not_in_normal_form loc "wildcard patterns remain after normalization" | Tpat_any -> not_in_normal_form loc "wildcard patterns remain after normalization"
| Tpat_var s -> [Ident.name s, coq_typ_pat p] | Tpat_var s -> [var_name (Ident.name s), coq_typ_pat p]
| Tpat_alias (p, s) -> aux p | Tpat_alias (p, s) -> aux p
| Tpat_constant c -> [] | Tpat_constant c -> []
| Tpat_tuple l -> list_concat_map aux l | Tpat_tuple l -> list_concat_map aux l
...@@ -252,7 +252,7 @@ let rec lift_pat ?(through_aliases=true) p : coq = ...@@ -252,7 +252,7 @@ let rec lift_pat ?(through_aliases=true) p : coq =
let aux = lift_pat ~through_aliases:through_aliases in let aux = lift_pat ~through_aliases:through_aliases in
match p.pat_desc with match p.pat_desc with
| Tpat_var s -> | Tpat_var s ->
Coq_var (Ident.name s) Coq_var (var_name (Ident.name s))
| Tpat_constant (Const_int n) -> | Tpat_constant (Const_int n) ->
Coq_int n Coq_int n
| Tpat_tuple l -> | Tpat_tuple l ->
...@@ -262,7 +262,7 @@ let rec lift_pat ?(through_aliases=true) p : coq = ...@@ -262,7 +262,7 @@ let rec lift_pat ?(through_aliases=true) p : coq =
| Tpat_alias (p, ak) -> | Tpat_alias (p, ak) ->
begin match ak with begin match ak with
| TPat_alias id -> | TPat_alias id ->
if through_aliases then aux p else Coq_var (Ident.name id) if through_aliases then aux p else Coq_var (var_name (Ident.name id))
| TPat_constraint ty -> | TPat_constraint ty ->
let typ = lift_typ_exp ty.ctyp_type in let typ = lift_typ_exp ty.ctyp_type in
Coq_annot (aux p, typ) Coq_annot (aux p, typ)
...@@ -430,7 +430,7 @@ let exp_is_inlined_primitive e oargs = ...@@ -430,7 +430,7 @@ let exp_is_inlined_primitive e oargs =
let lift_exp_path env p = let lift_exp_path env p =
match find_primitive (Path.name p) with match find_primitive (Path.name p) with
| None -> | None ->
let x = lift_path_name (protect_infix_path p) in let x = lift_path_name (var_path p) in
coq_app_var_wilds x (typ_arity_var env p) coq_app_var_wilds x (typ_arity_var env p)
| Some y -> | Some y ->
Coq_var y Coq_var y
...@@ -570,8 +570,7 @@ let pattern_name p = ...@@ -570,8 +570,7 @@ let pattern_name p =
(** Takes a function name and encodes its name in case of an infix operator *) (** Takes a function name and encodes its name in case of an infix operator *)
let pattern_name_protect_infix p = let pattern_name_protect_infix p =
protect_infix (pattern_name p) var_name (pattern_name p)
(** An alternative version of function extract_label_names, for obtaining record labels *) (** An alternative version of function extract_label_names, for obtaining record labels *)
...@@ -960,7 +959,7 @@ let rec cfg_structure_item s : cftops = ...@@ -960,7 +959,7 @@ let rec cfg_structure_item s : cftops =
[ Cftop_coqs [ Coqtop_require_import [ lift_full_path_name path ] ] ] [ Cftop_coqs [ Coqtop_require_import [ lift_full_path_name path ] ] ]
| Tstr_primitive(id, descr) -> | Tstr_primitive(id, descr) ->
let id = protect_infix (Ident.name id) in let id = var_name (Ident.name id) in
let fvs, typ = lift_typ_sch descr.val_desc.ctyp_type in let fvs, typ = lift_typ_sch descr.val_desc.ctyp_type in
let typ = coq_fun_types fvs typ in let typ = coq_fun_types fvs typ in
[ Cftop_val (id, typ) ] [ Cftop_val (id, typ) ]
...@@ -980,20 +979,25 @@ let rec cfg_structure_item s : cftops = ...@@ -980,20 +979,25 @@ let rec cfg_structure_item s : cftops =
a type abbreviation. *) a type abbreviation. *)
and cfg_type_abbrev (name,dec) = and cfg_type_abbrev (name,dec) =
let x = type_constr_name (Ident.name name) in let loc = dec.typ_loc in
let x = Ident.name name in
check_type_constr_name loc x;
let name = type_constr_name x in
let args = List.map name_of_type dec.typ_type.type_params in let args = List.map name_of_type dec.typ_type.type_params in
let sort = coq_impl_types (List.length args) in let sort = coq_impl_types (List.length args) in
let coqs = match dec.typ_type.type_manifest with let coqs = match dec.typ_type.type_manifest with
| None -> [Coqtop_param (x, sort)] | None -> [Coqtop_param (name, sort)]
| Some t -> [Coqtop_def ((x, sort), coq_fun_types args (lift_typ_exp t)); | Some t -> [Coqtop_def ((name, sort), coq_fun_types args (lift_typ_exp t));
Coqtop_hint_unfold ([x],"typeclass_instances") ] in Coqtop_hint_unfold ([name],"typeclass_instances") ] in
coqs coqs
(** Generate the top-level Coq declarations associated with (** Generate the top-level Coq declarations associated with
a record definition. *) a record definition. *)
and cfg_type_record (name,dec) = and cfg_type_record (name,dec) =
let loc = dec.typ_loc in
let x = Ident.name name in let x = Ident.name name in
check_type_constr_name loc x;
let name_of_field lbl = let name_of_field lbl =
record_field_name lbl in record_field_name lbl in
let fields = match dec.typ_type.type_kind with Type_record (l,_) -> l | _ -> assert false in let fields = match dec.typ_type.type_kind with Type_record (l,_) -> l | _ -> assert false in
...@@ -1241,22 +1245,25 @@ and cfg_algebraics decls = ...@@ -1241,22 +1245,25 @@ and cfg_algebraics decls =
(* -- todo: Caml types often clash with Caml program variables, since in Coq (* -- todo: Caml types often clash with Caml program variables, since in Coq
they get put in the same namespace *) they get put in the same namespace *)
let trans_ind (name,dec) = let trans_ind (name,dec) =
let loc = dec.typ_loc in
let x = Ident.name name in let x = Ident.name name in
check_type_constr_name loc x;
let branches = match dec.typ_type.type_kind with Type_variant l -> l | _ -> assert false in let branches = match dec.typ_type.type_kind with Type_variant l -> l | _ -> assert false in
let params = List.map name_of_type dec.typ_type.type_params in let params = List.map name_of_type dec.typ_type.type_params in
let ret_typ = coq_apps (Coq_var (type_constr_name x)) (coq_vars params) in let ret_typ = coq_apps (Coq_var (type_constr_name x)) (coq_vars params) in
let get_typed_constructor (c,ts) = let get_typed_constructor (c,ts) =
check_constr_name loc c;
(c, coq_impls (List.map lift_typ_exp ts) ret_typ) in (c, coq_impls (List.map lift_typ_exp ts) ret_typ) in
let coqind_decl = let coqind_decl =
if List.length decls = 1 then if List.length decls = 1 then
{ coqind_name = type_constr_name x; { coqind_name = type_constr_name x;
coqind_constructor_name = record_constructor_name x; coqind_constructor_name = algebraic_constructor_name x;
coqind_targs = coq_types params; coqind_targs = coq_types params;
coqind_ret = Coq_type; coqind_ret = Coq_type;
coqind_branches = List.map get_typed_constructor branches; } coqind_branches = List.map get_typed_constructor branches; }
else else
{ coqind_name = type_constr_name x; { coqind_name = type_constr_name x;
coqind_constructor_name = record_constructor_name x; coqind_constructor_name = algebraic_constructor_name x;
coqind_targs = []; coqind_targs = [];
coqind_ret = coq_impl_types (List.length params); coqind_ret = coq_impl_types (List.length params);
coqind_branches = List.map coqind_branches = List.map
......
...@@ -79,7 +79,7 @@ let rec coqtops_of_imp_cf cf = ...@@ -79,7 +79,7 @@ let rec coqtops_of_imp_cf cf =
let h_curried = coq_apps (Coq_var "curried") [narity; coq_var f] in let h_curried = coq_apps (Coq_var "curried") [narity; coq_var f] in
let h_body_hyp = coq_apps (coq_of_cf cf1) [h; q] in let h_body_hyp = coq_apps (coq_of_cf cf1) [h; q] in
let args = List.map (fun (x,t) -> coq_apps coq_dyn_at [t; coq_var x]) targs in let args = List.map (fun (x,t) -> coq_apps coq_dyn_at [t; coq_var x]) targs in
let h_body_conc = coq_apps (Coq_var "app_def") [coq_var f; coq_list args; h; q] in let h_body_conc = coq_apps (Coq_var "CFML.CFApp.app_def") [coq_var f; coq_list args; h; q] in
let h_body_2 = Coq_impl (h_body_hyp, h_body_conc) in let h_body_2 = Coq_impl (h_body_hyp, h_body_conc) in
let h_body_1 = coq_foralls [("H", hprop); ("Q", Coq_impl (typ, hprop))] h_body_2 in let h_body_1 = coq_foralls [("H", hprop); ("Q", Coq_impl (typ, hprop))] h_body_2 in
let h_body = coq_forall_types fvs (coq_foralls targs h_body_1) in let h_body = coq_forall_types fvs (coq_foralls targs h_body_1) in
...@@ -177,7 +177,30 @@ let rec coqtops_of_imp_cf cf = ...@@ -177,7 +177,30 @@ let rec coqtops_of_imp_cf cf =
funhq "tag_seq" (coq_exist "Q'" wild_to_hprop (coq_conj c1 c2)) funhq "tag_seq" (coq_exist "Q'" wild_to_hprop (coq_conj c1 c2))
(* (!S: fun H Q => exists Q', F1 H Q /\ F2 (Q' tt) Q *) (* (!S: fun H Q => exists Q', F1 H Q /\ F2 (Q' tt) Q *)
| Cf_for (i_name,v1,v2,cf) -> | Cf_for (i_name,v1,v2,cf) ->
let s = Coq_var "S" in
let i = Coq_var i_name in
let typs = Coq_impl (coq_int,formula_type) in
let locals = Coq_app (Coq_var "CFML.CFHeaps.is_local_pred", s) in
let snext = coq_apps s [ coq_plus i (Coq_int 1) ] in
let cf_step = Cf_seq (cf, Cf_manual snext) in
let cf_ret = Cf_ret coq_tt in
let cond = coq_apps (Coq_var "TLC.LibReflect.isTrue") [ coq_le i v2 ] in
let cf_if = Cf_caseif (cond, cf_step, cf_ret) in
let bodys = coq_of_cf cf_if in
let hypr = coq_foralls [(i_name, coq_int); ("H", hprop); ("Q", Coq_impl (coq_unit, hprop))] (Coq_impl (coq_apps bodys [h;q], (coq_apps s [i;h;q]))) in
funhq "tag_for" (Coq_forall (("S",typs), coq_impls [locals; hypr] (coq_apps s [v1;h;q])))
(* (!For (fun H Q => forall S:int->~~unit, is_local_pred S ->
(forall i H Q,
(If_ i <= v2
Then Seq (F1 ;; S (i+1)) H Q))
Else Ret tt) H Q
-> S i H Q)
-> S v1 H Q) *)
(*--todo:optimize using rec calls *)
(* DEPRECATED
let s = Coq_var "S" in let s = Coq_var "S" in
let i = Coq_var i_name in let i = Coq_var i_name in
let typs = Coq_impl (coq_int,formula_type) in let typs = Coq_impl (coq_int,formula_type) in
...@@ -192,20 +215,14 @@ let rec coqtops_of_imp_cf cf = ...@@ -192,20 +215,14 @@ let rec coqtops_of_imp_cf cf =
let bodys = coq_conj ple pgt in let bodys = coq_conj ple pgt in
let hypr = coq_foralls [(i_name, coq_int); ("H", hprop); ("Q", Coq_impl (coq_unit, hprop))] (Coq_impl (bodys,(coq_apps s [i;h;q]))) in let hypr = coq_foralls [(i_name, coq_int); ("H", hprop); ("Q", Coq_impl (coq_unit, hprop))] (Coq_impl (bodys,(coq_apps s [i;h;q]))) in
funhq "tag_for" (Coq_forall (("S",typs), coq_impls [locals; hypr] (coq_apps s [v1;h;q]))) funhq "tag_for" (Coq_forall (("S",typs), coq_impls [locals; hypr] (coq_apps s [v1;h;q])))
(* (!For (fun H Q => forall S:int->~~unit, is_local_pred S -> *)
(forall i H Q,
((i <= v2 -> !Seq (fun H Q => exists Q', Q1 H Q' /\ S (i+1) (Q' tt) Q) H Q))
/\ (i > v2 -> !Ret: (fun H Q => H ==> Q tt) H Q) ))
-> S i H Q)
-> S v1 H Q) *)
(*--todo:optimize using rec calls *)
| Cf_while (cf1,cf2) -> | Cf_while (cf1,cf2) ->
let r = Coq_var "R" in let r = Coq_var "R" in
let typr = formula_type in let typr = formula_type in
let cfseq = Cf_seq (cf2, Cf_manual r) in let cf_step = Cf_seq (cf2, Cf_manual r) in
let cfret = Cf_ret coq_tt in let cf_ret = Cf_ret coq_tt in
let cfif = Cf_caseif (Coq_var "_c", cfseq, cfret) in let cfif = Cf_caseif (Coq_var "_c", cf_step, cf_ret) in
let bodyr = coq_of_cf (Cf_let (("_c",coq_bool), cf1, cfif)) in let bodyr = coq_of_cf (Cf_let (("_c",coq_bool), cf1, cfif)) in
let hypr = coq_foralls [("H", hprop); ("Q", Coq_impl (coq_unit, hprop))] (Coq_impl (coq_apps bodyr [h;q],(coq_apps r [h;q]))) in let hypr = coq_foralls [("H", hprop); ("Q", Coq_impl (coq_unit, hprop))] (Coq_impl (coq_apps bodyr [h;q],(coq_apps r [h;q]))) in
let localr = Coq_app (Coq_var "CFML.CFHeaps.is_local", r) in let localr = Coq_app (Coq_var "CFML.CFHeaps.is_local", r) in
......
...@@ -13,7 +13,7 @@ let trace s = ...@@ -13,7 +13,7 @@ let trace s =
let ppf = Format.std_formatter let ppf = Format.std_formatter
let onlycmj = ref false let only_normalize = ref false
let no_mystd_include = ref false let no_mystd_include = ref false
...@@ -34,7 +34,7 @@ let spec = ...@@ -34,7 +34,7 @@ let spec =
("-nostdlib", Arg.Set no_mystd_include, " do not include standard library"); ("-nostdlib", Arg.Set no_mystd_include, " do not include standard library");
("-nopervasives", Arg.Set Clflags.nopervasives, " do not include standard pervasives file"); ("-nopervasives", Arg.Set Clflags.nopervasives, " do not include standard pervasives file");
("-o", Arg.String (fun s -> outputfile := Some s), " set the output file name"); ("-o", Arg.String (fun s -> outputfile := Some s), " set the output file name");
("-onlycmj", Arg.Set onlycmj, " only generate the .cmj file, not the .v file"); ("-only_normalize", Arg.Set only_normalize, " only generate the .cmj file, not the .v file");
("-debug", Arg.Set is_tracing, " trace the various steps"); ("-debug", Arg.Set is_tracing, " trace the various steps");
("-width", Arg.Set_int Print_coq.width, " set pretty-printing width for the .v file"); ("-width", Arg.Set_int Print_coq.width, " set pretty-printing width for the .v file");
] ]
...@@ -121,12 +121,12 @@ let _ = ...@@ -121,12 +121,12 @@ let _ =
in in
(*---------------------------------------------------*) (*---------------------------------------------------*)
trace "5) dumping .cmj file"; trace "5) dumping normalized file";
file_put_contents (debugdirBase ^ "_normalized_typed.ml") (Print_tast.string_of_structure typedtree2); file_put_contents (debugdirBase ^ "_normalized_typed.ml") (Print_tast.string_of_structure typedtree2);
(* ignore (typedtree2); *) (* ignore (typedtree2); *)
if !onlycmj then begin if !only_normalize then begin
trace "6) exiting since -onlycmj"; trace "6) exiting since -only_normalize";
exit 0; exit 0;
end; end;
......
...@@ -24,7 +24,7 @@ let fullname_of_lident idt = ...@@ -24,7 +24,7 @@ let fullname_of_lident idt =
String.concat "." words String.concat "." words
let check_lident loc idt = (* DEPRECATED *) let check_lident loc idt = (* DEPRECATED *)
check_var loc (name_of_lident idt) check_var_name loc (name_of_lident idt)
(*#########################################################################*) (*#########################################################################*)
...@@ -120,9 +120,9 @@ let normalize_pattern p = ...@@ -120,9 +120,9 @@ let normalize_pattern p =
| Ppat_any -> Ppat_var (next_name()) | Ppat_any -> Ppat_var (next_name())
| Ppat_var s -> | Ppat_var s ->
(* hack to handle generated vars *) (* hack to handle generated vars *)
if loc <> Location.none then check_var loc s; if loc <> Location.none then check_var_name loc s;
Ppat_var s Ppat_var s
| Ppat_alias (p, s) -> check_var loc s; Ppat_alias (aux p, s) | Ppat_alias (p, s) -> check_var_name loc s; Ppat_alias (aux p, s)