Une MAJ de sécurité est nécessaire sur notre version actuelle. Elle sera effectuée lundi 02/08 entre 12h30 et 13h. L'interruption de service devrait durer quelques minutes (probablement moins de 5 minutes).

Commit 2c287e3c authored by charguer's avatar charguer
Browse files

primitives

parent 41a5ef66
......@@ -3,8 +3,34 @@
URGENT
SANITY
- 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
builtin_type_constructors
- rename on the fly coq keyword such as exists, forall, etc..
=> requires a list of all coq keywords: see
else if name = "exists" then "exists__"
else if name = "forall" then "forall__"
- restriction on not binding "min" and "max" could be a bit restrictive..
LATER
- in print_tast and print_past, protect with parenth the infix names being bound
- make sure that check_var is called where needed
- need to prevent double-underscore in the names?
- unify the source code in main.ml and makecmj.ml
- check that there are no uses of labels in source files
......@@ -16,4 +42,15 @@ DEPRECATED?
- no longer rely on myocamldep
- incorrect CF generation for "let n = null"
\ No newline at end of file
- incorrect CF generation for "let n = null"
(*
(** Auxiliary function for the special case of compiling pervasives *)
let add_pervasives_prefix_if_needed p =
if !Clflags.nopervasives then "Pervasives." ^ p else p
let p = add_pervasives_prefix_if_needed p in
*)
\ No newline at end of file
......@@ -5,13 +5,34 @@ Require Import Demo_ml.
Require Import Pervasives_ml. (* optional, improves display of, e.g. [incr] *)
(*Open Scope tag_scope.*)
Print TLC.LibOrder.ge_from_le.
Definition f := (fun x_ y_ : int => TLC.LibReflect.isTrue (x_ >= y_)).
Print f.
Definition g := .
(fun x_ y_ : int => TLC.LibReflect.isTrue (TLC.LibOrder.lt (TLC.LibOrder.ge_from_le TLC.LibInt.le) x_ y_)).
"Pervasives.<=", (Primitive_binary_only_numbers, "(fun x_ y_ : int => TLC.LibReflect.isTrue (@TLC.LibOrder.le int TLC.LibInt.le_int_inst x_ y_))");
"Pervasives.>", (Primitive_binary_only_numbers, "(fun x_ y_ : int => TLC.LibReflect.isTrue (@TLC.LibOrder.gt int (TLC.LibOrder.gt_from_le TLC.LibInt.le_int_inst) x_ y_))");
"Pervasives.>=", (Primitive_binary_only_numbers, "(fun x_ y_ : int => TLC.LibReflect.isTrue (@TLC.LibOrder.ge int (TLC.LibOrder.ge_from_le TLC.LibInt.le_int_inst) x_ y_))");
Print f.
Locate ge_from_le.
Locate le_int_inst.
Definition g :=
(fun x_ y_ : int => TLC.LibReflect.isTrue (x_ <> y_))..
Print g.
Locate le_int_inst.
(*Open Scope tag_scope.*)
......
This diff is collapsed.
......@@ -88,3 +88,5 @@ val cfg_module : Ident.t -> Typedtree.module_expr -> Formula.cftops
*)
val cfg_file : Typedtree.structure -> Formula.cftop list
exception Not_in_normal_form of Location.t * string
......@@ -246,7 +246,7 @@ let rec coqtops_of_imp_cf cf =
*)
| Cf_manual c -> c
| Cf_letpure _ -> unsupported "letpure-expression in imperative mode"
| Cf_letpure _ -> unsupported_noloc "letpure-expression in imperative mode"
(* --todo: scope of type variables should be different than that of program variables: prefix them! *)
......
......@@ -93,9 +93,6 @@ let _ =
with _ -> Printf.printf "Could not create debug directory\n" end;
(*---------------------------------------------------*)
if sourcefile = "imper/MyLib.ml" then exit 0;
(*---------------------------------------------------*)
trace "2) reading and typing source file";
let (opt,inputfile) = process_implementation_file ppf sourcefile in
......@@ -114,11 +111,15 @@ let _ =
(*---------------------------------------------------*)
trace "4) typing normalized code";
let (typedtree2, _ : Typedtree.structure * Typedtree.module_coercion) =
match typecheck_implementation_file ppf sourcefile parsetree2 with
| None -> failwith "Could not typecheck the normalized source code\nCheck out the file output/_normalized.ml."
| Some typedtree2 -> typedtree2
in
let fail () =
failwith (Printf.sprintf "Could not typecheck the normalized source code\nCheck out the file %s_normalized.ml." debugdirBase) in
try
match typecheck_implementation_file ppf sourcefile parsetree2 with
| None -> fail() (* TODO: useful?*)
| Some typedtree2 -> typedtree2
with Typetexp.Error(loc, err) -> fail()
in
(*---------------------------------------------------*)
trace "5) dumping .cmj file";
file_put_contents (debugdirBase ^ "_normalized_typed.ml") (Print_tast.string_of_structure typedtree2);
......@@ -132,7 +133,15 @@ let _ =
(*---------------------------------------------------*)
trace "5) constructing caracteristic formula ast";
let cftops = Characteristic.cfg_file typedtree2 in
let cftops =
try Characteristic.cfg_file typedtree2
with
| Typetexp.Error(_, _) -> assert false
| Characteristic.Not_in_normal_form (loc, s) ->
Location.print_error Format.std_formatter loc;
Printf.printf " %s.\nThe normalized file does not appear to be in normal form.\nTo investigate, open %s_normalized.ml\nand %s_normalized_typed.ml.\n" s debugdirBase debugdirBase;
exit 1
in
(*---------------------------------------------------*)
trace "6) converting caracteristic formula ast to coq ast";
......
......@@ -210,9 +210,15 @@ let show_str s =
let output s =
Printf.printf "%s\n" s
let warning s =
let warning s = (* DEPRECATED? *)
Printf.printf "### WARNING: %s\n" s
let unsupported s =
failwith ("Unsupported language construction : " ^ s)
let unsupported_noloc s =
failwith ("Unsupported language construction : " ^ s)
let unsupported loc s =
Location.print_error Format.err_formatter loc;
unsupported_noloc s
(* TODO: report location *)
......@@ -124,4 +124,9 @@ val warning : string -> unit
(** Display a message explaining that a feature is not supported *)
val unsupported : string -> 'a
val unsupported_noloc : string -> 'a
(** Display a message explaining that a feature is not supported,
and report the location *)
val unsupported : Location.t -> string -> 'a
......@@ -23,7 +23,7 @@ let fullname_of_lident idt =
let words = Longident.flatten idt in
String.concat "." words
let check_lident loc idt =
let check_lident loc idt = (* DEPRECATED *)
check_var loc (name_of_lident idt)
......@@ -38,52 +38,58 @@ let reverse_if_right_to_left_order args =
(*#########################################################################*)
(* ** Detection of primitive functions and exception-raising *)
(** Obtain a full path for a variable expected to be bound only in Pervasives *)
let get_qualified_pervasives_name lident =
let name = name_of_lident lident in
if !Clflags.nopervasives
then name (* unqualified name when from inside Pervasives *)
else "Pervasives." ^ name (* qualified name otherwise *)
then "Pervasives." ^ name (* unqualified name when from inside Pervasives *)
else "Pervasives." ^ name (* name when from outside might be qualified or not; usually it is not, so we add the prefix; if it is already qualified, then we will miss it by prefixing once more.... maybe we need to check if the name already starts with Pervasives? TODO: fix this *)
let exp_is_inlined_primitive e largs =
let args = List.map snd largs in (* todo: check no labels*)
match e.pexp_desc, args with
| Pexp_ident f, [n; {pexp_desc = Pexp_constant (Const_int m)}]
(* Remark: we impose elsewhere a check that the names "mod" and "/"
and "&&" and "||" are not bound outside of Pervasives *)
when m <> 0 && let x = name_of_lident f in List.mem x ["mod"; "/"] ->
let name = get_qualified_pervasives_name f in
begin match find_inlined_primitive name with
| Some (Primitive_binary_only_non_zero_second_arg, coq_name) -> true
| _ -> false
match e.pexp_desc with
| Pexp_ident f ->
let shortname = name_of_lident f in
let name = get_qualified_pervasives_name f in
begin match args with
| [n; {pexp_desc = Pexp_constant (Const_int m)}]
(* Remark: we impose elsewhere a check that the names "mod" and "/"
and "&&" and "||" are not bound outside of Pervasives *)
when m <> 0 && List.mem shortname ["mod"; "/"] ->
begin match find_inlined_primitive name with
| Some (Primitive_binary_div_or_mod, coq_name) -> true
| _ -> false
end
| [e1; e2]
when List.mem shortname ["&&"; "||"] -> true
(* Remark: this check is not complete; it is only useful to ensure
that values_variables won't fail *)
| [e1; e2]
when List.mem shortname ["="; "<>"; "<="; ">="; "<"; ">"; "min"; "max"] -> true
(* Remark: here we don't check that the types of the arguments are numbers;
we will catch this later in the characteristic formula generation *)
| _ ->
let arity = List.length args in
begin match find_inlined_primitive name with
| Some (Primitive_unary, coq_name) when arity = 1 -> true
| Some (Primitive_binary, coq_name) when arity = 2 -> true
(* remark: this case should have been caught earlier by [is_lazy_binary_op], so:
| Some (Primitive_binary_lazy, coq_name) when arity = 2 -> assert false
*)
| _ -> false
end
| _ -> false
end
| Pexp_ident f, [e1; e2]
when let x = name_of_lident f in List.mem x ["&&"; "||"] -> true
(* Remark: this check is not complete; it is only useful to ensure
that values_variables won't fail *)
| Pexp_ident f, [e1; e2]
when let x = name_of_lident f in List.mem x ["="; "<>"; "<="; ">="; "<"; ">"] -> true
(* Remark: here we don't check that the types of the arguments are numbers;
we will catch this later in the characteristic formula generation *)
| Pexp_ident f,_ ->
let arity = List.length args in
begin match find_inlined_primitive ("Pervasives." ^ fullname_of_lident f) with
| Some (Primitive_unary, coq_name) when arity = 1 -> true
| Some (Primitive_binary, coq_name) when arity = 2 -> true
(* remark: this case should have been caught earlier by [is_lazy_binary_op], so:
| Some (Primitive_binary_lazy, coq_name) when arity = 2 -> assert false
*)
| _ -> false
end
| _ -> false
let is_failwith_function e =
match e.pexp_desc with
| Pexp_ident li ->
......@@ -106,6 +112,7 @@ let is_lazy_binary_op e =
(* ** Normalization of patterns *)
let normalize_pattern p =
let loc = p.ppat_loc in
let i = ref (-1) in
let next_name () =
incr i; (pattern_generated_name !i) in
......@@ -113,19 +120,22 @@ let normalize_pattern p =
let loc = p.ppat_loc in
{ p with ppat_desc = match p.ppat_desc with
| Ppat_any -> Ppat_var (next_name())
| Ppat_var s -> check_var loc s; Ppat_var s
| Ppat_var s ->
(* hack to handle generated vars *)
if loc <> Location.none then check_var loc s;
Ppat_var s
| Ppat_alias (p, s) -> check_var loc s; Ppat_alias (aux p, s)
| Ppat_constant c -> Ppat_constant c
| Ppat_tuple l -> Ppat_tuple (List.map aux l)
| Ppat_construct (li, po, b) -> Ppat_construct (li, option_map aux po, b)
| Ppat_variant (_,_) -> unsupported "variant patterns"
| Ppat_variant (_,_) -> unsupported loc "variant patterns"
| Ppat_record (l,f) -> Ppat_record (List.map (fun (li,pi) -> (li, aux pi)) l, f)
| Ppat_array pats -> unsupported "array patterns"
| Ppat_or (p1,p2) -> unsupported "or patterns are only supported at pattern root"
| Ppat_array pats -> unsupported loc "array patterns"
| Ppat_or (p1,p2) -> unsupported loc "or patterns are only supported at pattern root"
| Ppat_constraint (p,t) -> Ppat_constraint (aux p,t)
| Ppat_type t -> Ppat_type t
| Ppat_lazy p1 -> Ppat_lazy (aux p1)
| Ppat_unpack p1 -> unsupported "array unpack"
| Ppat_unpack p1 -> unsupported loc "array unpack"
} in
aux p
......@@ -134,6 +144,7 @@ let normalize_pattern p =
(* ** Free variables of patterns and values *)
let rec pattern_variables p =
let loc = p.ppat_loc in
let aux = pattern_variables in
match p.ppat_desc with
| Ppat_any -> []
......@@ -142,16 +153,17 @@ let rec pattern_variables p =
| Ppat_constant c -> []
| Ppat_tuple l -> list_concat_map aux l
| Ppat_construct (li, po, b) -> option_app [] aux po
| Ppat_variant (_,_) -> unsupported "variant patterns"
| Ppat_record (l,_) -> unsupported "record patterns" (* list_concat_map (fun (li,pi) -> aux pi) l *)
| Ppat_array pats -> unsupported "array patterns"
| Ppat_or (p1,p2) -> unsupported "or patterns are only supported at pattern root"
| Ppat_variant (_,_) -> unsupported loc "variant patterns"
| Ppat_record (l,_) -> unsupported loc "record patterns" (* list_concat_map (fun (li,pi) -> aux pi) l *)
| Ppat_array pats -> unsupported loc "array patterns"
| Ppat_or (p1,p2) -> unsupported loc "or patterns are only supported at pattern root"
| Ppat_constraint (p,t) -> aux p
| Ppat_type t -> []
| Ppat_lazy p1 -> aux p1
| Ppat_unpack p1 -> unsupported "array unpack"
| Ppat_unpack p1 -> unsupported loc "array unpack"
let rec values_variables e =
let loc = e.pexp_loc in
let aux = values_variables in
match e.pexp_desc with
| Pexp_ident (Lident x) -> [x]
......@@ -173,11 +185,11 @@ let rec values_variables e =
aux e
| _ -> failwith "Bug in normalization: values_variables called on a non-atomic value"
(*
| Pexp_record (l,Some eo) -> unsupported "record-with"
| Pexp_record (l,Some eo) -> unsupported loc "record-with"
| Pexp_record (l,None) ->
let l',bi = List.split (List.map (fun (i,(e,b)) -> ((i,e),b)) (assoc_list_map (aux false) l)) in
return (Pexp_record (l', None)), List.flatten bi
| Pexp_array l -> unsupported "array expression" (* Pexp_array (List.map aux l)*)
| Pexp_array l -> unsupported loc "array expression" (* Pexp_array (List.map aux l)*)
*)
......@@ -203,8 +215,8 @@ let get_assign_fct loc already_named new_name : expression -> bindings -> expres
then fun e b -> e,b
else let x = new_name() in
fun e b ->
let p = { ppat_loc = Location.none; ppat_desc = Ppat_var x } in
let e' = { pexp_loc = Location.none; pexp_desc = Pexp_ident (Lident x) } in
let p = { ppat_loc = loc; ppat_desc = Ppat_var x } in
let e' = { pexp_loc = loc; pexp_desc = Pexp_ident (Lident x) } in
e', b @ [ p, e ]
(* argument [named] indicates whether the context in which appear
......@@ -213,6 +225,7 @@ let get_assign_fct loc already_named new_name : expression -> bindings -> expres
is of the form [fun .. -> ..]. *)
let normalize_expression named e =
let loc = e.pexp_loc in
let i = ref (-1) in (* TODO: use a gensym function *)
let next_var () =
incr i; (variable_generated_name !i) in
......@@ -239,14 +252,14 @@ let normalize_expression named e =
let assign_var =
assign_fct next_var in
match e.pexp_desc with
| Pexp_ident li -> check_lident loc li; return (Pexp_ident li), []
| Pexp_ident li -> return (Pexp_ident li), []
| Pexp_constant c -> return (Pexp_constant c), []
| Pexp_let (Recursive, l, b) ->
let l' = List.map protect_branch l in
let b' = protect true b in
let e' = Pexp_let (Recursive, l', b') in
assign_var (return e') []
| Pexp_let (rf, [], e2) -> unsupported "let without any binding"
| Pexp_let (rf, [], e2) -> unsupported loc "let without any binding"
| Pexp_let (rf, [p1,e1], e2) ->
begin match p1.ppat_desc with
| Ppat_var x
......@@ -270,7 +283,7 @@ let normalize_expression named e =
| _ -> false
in
if not (List.for_all check_is_named_pat (List.map fst l))
then unsupported "let-rec with patterns not reduced to names";
then unsupported loc "let-rec with patterns not reduced to names";
aux true (List.fold_right (fun (pi,ei) eacc -> create_let loc [pi,ei] eacc) l e)
| Pexp_function (lab, None, [_]) ->
let rec protect_func (ms : (expression * pattern) list) (e : expression) =
......@@ -284,12 +297,12 @@ let normalize_expression named e =
(* todo: type annotations in pattern get lost *)
| Ppat_construct (li, None, b) when Longident.flatten li = ["()"] ->
let x = next_var() in
let px = { ppat_loc = Location.none; ppat_desc = Ppat_var x } in
let px = { ppat_loc = loc; ppat_desc = Ppat_var x } in
return (Pexp_function (lab, None, [px, protect_func ms e']))
| _ ->
let x = next_var() in
let px = { ppat_loc = Location.none; ppat_desc = Ppat_var x } in
let vx = { pexp_loc = Location.none; pexp_desc = Pexp_ident (Lident x) } in
let px = { ppat_loc = loc; ppat_desc = Ppat_var x } in
let vx = { pexp_loc = loc; pexp_desc = Pexp_ident (Lident x) } in
let ms' = (vx, p')::ms in
return (Pexp_function (lab, None, [px, protect_func ms' e']))
end
......@@ -302,23 +315,24 @@ let normalize_expression named e =
assign (protect_func [] e) []
| Pexp_function (lab, None, l) ->
let x = next_var() in (* todo: factorize next three lines of code *)
let px = { ppat_loc = Location.none; ppat_desc = Ppat_var x } in (* todo: better hack to remember created var *)
let vx = { pexp_loc = Location.none; pexp_desc = Pexp_ident (Lident x) } in
let px = { ppat_loc = Location.none (* hack to pass check-var *); ppat_desc = Ppat_var x } in (* todo: better hack to remember created var *)
let vx = { pexp_loc = Location.none (* hack to pass check-var *); pexp_desc = Pexp_ident (Lident x) } in
let e' = return (Pexp_match (vx, l)) in
aux named (return (Pexp_function (lab, None, [px,e'])))
(* [function /branches/] becomes [fun x => match x with /branches/] *)
| Pexp_function (p, Some _, l) ->
unsupported "function with optional expression"
unsupported loc "function with optional expression"
| Pexp_apply (e0, l) when is_failwith_function e0 ->
return Pexp_assertfalse, []
| Pexp_apply (e0, [e1; e2]) when is_lazy_binary_op e0 ->
| Pexp_apply (e0, [(l1,e1); (l2,e2)]) when is_lazy_binary_op e0 ->
(* TODO: assert that the labels are irrelevant here *)
let e0',b0 = aux false e0 in
let name = match e0.pexp_desc with Pexp_ident f -> name_of_lident f in
assert (b0 = []); (* since e0 should be "&&" or "||" *)
let e1',b1 = aux false e1 in
let e2',b2 = aux false e2 in
if b2 = [] then begin
let e' = return (Pexp_apply (e0', [e1'; e2'])) in
let e' = return (Pexp_apply (e0', [(l1,e1'); (l2,e2')])) in
e', b1
end else if name = "&&" then begin
(* produce: let <b1> in if <e1'> then (let <b2> in <e2'>) else false *)
......@@ -339,7 +353,7 @@ let normalize_expression named e =
let e0',b0 = aux false e0 in
let ei',bi = List.split (List.map (fun (lk,ek) -> let ek',bk = aux false ek in (lk, ek'), bk) l) in
let e' = return (Pexp_apply (e0', ei')) in
let b' = reverse_if_right_to_left_order (b0 @ (List.flatten bi)) in
let b' = List.flatten (reverse_if_right_to_left_order (b0::bi)) in
if exp_is_inlined_primitive e0 l
then e', b'
else assign_var e' b'
......@@ -358,13 +372,13 @@ let normalize_expression named e =
let e0',b0 =
if not is_naming_required then e0',b0 else begin
let x = next_var() in
let px = { ppat_loc = Location.none; ppat_desc = Ppat_var x } in
let vx = { pexp_loc = Location.none; pexp_desc = Pexp_ident (Lident x) } in
let px = { ppat_loc = loc; ppat_desc = Ppat_var x } in
let vx = { pexp_loc = loc; pexp_desc = Pexp_ident (Lident x) } in
vx, b0@[px,e0']
end in
let e' = Pexp_match (e0', List.map protect_branch l') in
assign_var (return e') b0
| Pexp_try (e,l) -> unsupported "exceptions"
| Pexp_try (e,l) -> unsupported loc "exceptions"
| Pexp_tuple l ->
let l',bi = List.split (List.map (aux false) l) in
let b = List.flatten (reverse_if_right_to_left_order bi) in
......@@ -374,8 +388,8 @@ let normalize_expression named e =
| Pexp_construct (li, Some e, bh) ->
let e',b = aux false e in
return (Pexp_construct (li, Some e', bh)), b
| Pexp_variant (l,eo) -> unsupported "variants"
| Pexp_record (l,Some eo) -> unsupported "record-with"
| Pexp_variant (l,eo) -> unsupported loc "variants"
| Pexp_record (l,Some eo) -> unsupported loc "record-with"
| Pexp_record (l,None) ->
let l',bi = List.split (List.map (fun (i,(e,b)) -> ((i,e),b)) (assoc_list_map (aux false) l)) in
let b = List.flatten (reverse_if_right_to_left_order bi) in
......@@ -425,11 +439,11 @@ let normalize_expression named e =
let econd' = protect false econd in
let ebody' = protect false ebody in
return (Pexp_when (econd', ebody')), []
| Pexp_send (_,_) -> unsupported "send expression"
| Pexp_new _ -> unsupported "new expression"
| Pexp_setinstvar (_,_) -> unsupported "set-inst-var expression"
| Pexp_override _ -> unsupported "Pexp_override expression"
| Pexp_letmodule (_,_,_) -> unsupported "let-module expression"
| Pexp_send (_,_) -> unsupported loc "send expression"
| Pexp_new _ -> unsupported loc "new expression"
| Pexp_setinstvar (_,_) -> unsupported loc "set-inst-var expression"
| Pexp_override _ -> unsupported loc "Pexp_override expression"
| Pexp_letmodule (_,_,_) -> unsupported loc "let-module expression"
| Pexp_assert e ->
let e',b = aux false e in
return (Pexp_assert e'), b
......@@ -438,11 +452,11 @@ let normalize_expression named e =
| Pexp_lazy e ->
let e',b = aux false e in
return (Pexp_lazy e'), b
| Pexp_poly (_,_) -> unsupported "poly expression"
| Pexp_object _ -> unsupported "objects"
| Pexp_newtype _ -> unsupported "newtype"
| Pexp_pack _ -> unsupported "pack"
| Pexp_open (id,e) -> unsupported "open local" (* Pexp_open (id,aux e), b *)
| Pexp_poly (_,_) -> unsupported loc "poly expression"
| Pexp_object _ -> unsupported loc "objects"
| Pexp_newtype _ -> unsupported loc "newtype"
| Pexp_pack _ -> unsupported loc "pack"
| Pexp_open (id,e) -> unsupported loc "open local" (* Pexp_open (id,aux e), b *)
(* [protect named e] calls the translation function [aux named e],
......@@ -468,19 +482,21 @@ let normalize_pattern_expression (p,e) =
(* ** Normalization of modules and top-level phrases *)
let rec normalize_module m =
let loc = m.pmod_loc in
{ m with pmod_desc = match m.pmod_desc with
| Pmod_ident li -> Pmod_ident li
| Pmod_structure s -> Pmod_structure (normalize_structure s)
| Pmod_functor (s,mt,me) -> Pmod_functor (s, mt, normalize_module me)
| Pmod_apply (me1,me2) -> Pmod_apply (normalize_module me1, normalize_module me2)
| Pmod_constraint (me,mt) -> Pmod_constraint (normalize_module me,mt)
| Pmod_unpack e -> unsupported "module unpack"
| Pmod_unpack e -> unsupported loc "module unpack"
}
and normalize_structure s =
List.map normalize_structure_item s
and normalize_structure_item si =
let loc = si.pstr_loc in
{ si with pstr_desc = match si.pstr_desc with
| Pstr_eval e -> Pstr_eval (normalize_expression true e)
| Pstr_value (r,l) -> Pstr_value (r, List.map normalize_pattern_expression l)
......@@ -489,11 +505,11 @@ and normalize_structure_item si =
| Pstr_exception (s,e) -> Pstr_exception (s,e)
| Pstr_exn_rebind (s,i) -> Pstr_exn_rebind (s,i)
| Pstr_module (s,m) -> Pstr_module (s, normalize_module m)
| Pstr_recmodule _ -> unsupported "recursive modules"
| Pstr_recmodule _ -> unsupported loc "recursive modules"
| Pstr_modtype (s,mt) -> Pstr_modtype (s,mt)
| Pstr_open li -> Pstr_open li
| Pstr_class _ -> unsupported "objects"
| Pstr_class_type _ -> unsupported "objects"
| Pstr_class _ -> unsupported loc "objects"
| Pstr_class_type _ -> unsupported loc "objects"
| Pstr_include m -> Pstr_include (normalize_module m)
}
......
......@@ -11,21 +11,24 @@ open Format
(*#########################################################################*)
(* ** Printing of base values *)
let parent_if_infix s =
if Renaming.is_infix_name s then sprintf "(%s)" s else s
let string_of_ident s =
Ident.name s
parent_if_infix (Ident.name s)
let string_of_lident idt =
let names = Longident.flatten idt in
String.concat "." names
parent_if_infix (String.concat "." names)
let string_of_constant = function
| Const_int n -> string_of_int n
| Const_char c -> String.make 1 c
| Const_string s -> s
| Const_float f -> f
| Const_int32 _ -> unsupported "int32 type"
| Const_int64 _ -> unsupported "int64 type"
| Const_nativeint _ -> unsupported "native int type"
| Const_int32 _ -> unsupported_noloc "int32 type"
| Const_int64 _ -> unsupported_noloc "int64 type"
| Const_nativeint _ -> unsupported_noloc "native int type"
let string_of_recflag = function
| Nonrecursive -> ""
......@@ -48,21 +51,21 @@ let string_of_pattern par p =
| Ppat_tuple l ->
show_par true (sprintf "%s" (show_list (aux false) "," l))
| Ppat_construct (li, po, b) ->
if (b != false) then unsupported "construct with options";
if (b != false) then unsupported_noloc "construct with options";
let s = sprintf "%s%s"
(string_of_lident li)
(show_option (aux true) po) in
show_par par s
| Ppat_lazy p1 ->
show_par par (sprintf "lazy %s" (aux true p1))
| Ppat_variant (_,_) -> unsupported "variant patterns"
| Ppat_record _ -> unsupported "record patterns"