Commit 2c287e3c authored by charguer's avatar charguer

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.*)
......
......@@ -17,10 +17,10 @@ open Printf
(*#########################################################################*)
(* ** Error messages *)
exception Not_in_normal_form of string
exception Not_in_normal_form of Location.t * string
let not_in_normal_form s =
raise (Not_in_normal_form s)
let not_in_normal_form loc s =
raise (Not_in_normal_form (loc, s))
(*#########################################################################*)
......@@ -105,7 +105,7 @@ let rec fv_btyp ?(through_arrow = true) t =
| Btyp_constr (id,ts) -> list_concat_map aux ts
| Btyp_tuple ts -> list_concat_map aux ts
| Btyp_var (b,s) -> [s]
| Btyp_poly (ss,t) -> unsupported "poly-types"
| Btyp_poly (ss,t) -> unsupported_noloc "poly-types"
| Btyp_alias (t,s) -> s :: aux t
(** Translates a [btyp] into a Coq type *)
......@@ -125,14 +125,14 @@ let rec lift_btyp t =
| Btyp_tuple ts ->
coq_prod (List.map aux ts)
| Btyp_var (b,s) ->
if b then unsupported "non-generalizable free type variables (of the form '_a); please add a type annotation";
if b then unsupported_noloc "non-generalizable free type variables (of the form '_a); please add a type annotation";
Coq_var s
| Btyp_poly (ss,t) ->
unsupported "poly-types"
unsupported_noloc "poly-types"
| Btyp_alias (t1,s) ->
let occ = fv_btyp ~through_arrow:false t1 in
if List.mem s occ
then unsupported ("found a recursive type that is not erased by an arrow:" ^ (print_out_type t));
then unsupported_noloc ("found a recursive type that is not erased by an arrow:" ^ (print_out_type t));
aux t1
(* TEMPORARILY DEPRECATED
......@@ -182,7 +182,7 @@ let rec path_decompose = function
| Pdot(p, s, pos) ->
let (f,r) = path_decompose p in
(f ^ r ^ ".", s)
| Papply(p1, p2) -> unsupported "application in paths"
| Papply(p1, p2) -> unsupported_noloc "application in paths"
(** Extracts a record path_name / path from a type *)
......@@ -229,24 +229,26 @@ let coq_of_constructor p c =
(** Compute the free variables of a pattern *)
let rec pattern_variables p : typed_vars = (* ignores aliases *)
let loc = p.pat_loc in
let aux = pattern_variables in
match p.pat_desc with
| Tpat_any -> not_in_normal_form "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_alias (p, s) -> aux p
| Tpat_constant c -> []
| Tpat_tuple l -> list_concat_map aux l
| Tpat_construct (p, c, ps) -> list_concat_map aux ps
| Tpat_lazy p1 -> aux p1
| Tpat_variant (_,_,_) -> unsupported "variant patterns"
| Tpat_record _ -> unsupported "record patterns"
| Tpat_array pats -> unsupported "array patterns"
| Tpat_or (_,p1,p2) -> unsupported "or patterns"
| Tpat_variant (_,_,_) -> unsupported loc "variant patterns"
| Tpat_record _ -> unsupported loc "record patterns"
| Tpat_array pats -> unsupported loc "array patterns"
| Tpat_or (_,p1,p2) -> unsupported loc "or patterns"
(** Translate a Caml pattern into a Coq expression, and
ignores the aliases found in the pattern *)
let rec lift_pat ?(through_aliases=true) p : coq =
let loc = p.pat_loc in
let aux = lift_pat ~through_aliases:through_aliases in
match p.pat_desc with
| Tpat_var s ->
......@@ -266,17 +268,18 @@ let rec lift_pat ?(through_aliases=true) p : coq =
end
| Tpat_lazy p1 ->
aux p1
| Tpat_record _ -> unsupported "record patterns" (* todo! *)
| Tpat_array pats -> unsupported "array patterns" (* todo! *)
| Tpat_constant _ -> unsupported "only integer constant are supported"
| Tpat_any -> not_in_normal_form "wildcard patterns remain after normalization"
| Tpat_variant (_,_,_) -> unsupported "variant patterns"
| Tpat_or (_,p1,p2) -> unsupported "or patterns in depth"
| Tpat_record _ -> unsupported loc "record patterns" (* todo! *)
| Tpat_array pats -> unsupported loc "array patterns" (* todo! *)
| Tpat_constant _ -> unsupported loc "only integer constant are supported"
| Tpat_any -> not_in_normal_form loc "wildcard patterns remain after normalization"
| Tpat_variant (_,_,_) -> unsupported loc "variant patterns"
| Tpat_or (_,p1,p2) -> unsupported loc "or patterns in depth"
(** Extracts the aliases from a Caml pattern, in the form of an
association list mapping variables to Coq expressions *)
let pattern_aliases p : (typed_var*coq) list =
let loc = p.pat_loc in
let rec aux p =
match p.pat_desc with
| Tpat_var s -> []
......@@ -291,18 +294,18 @@ let pattern_aliases p : (typed_var*coq) list =
| TPat_type pp -> aux p1
end
| Tpat_lazy p1 -> aux p1
| Tpat_record _ -> unsupported "record patterns" (* todo! *)
| Tpat_array pats -> unsupported "array patterns" (* todo! *)
| Tpat_constant _ -> unsupported "only integer constant are supported"
| Tpat_any -> not_in_normal_form "wildcard patterns remain after normalization"
| Tpat_variant (_,_,_) -> unsupported "variant patterns"
| Tpat_or (_,p1,p2) -> unsupported "or patterns"
| Tpat_record _ -> unsupported loc "record patterns" (* todo! *)
| Tpat_array pats -> unsupported loc "array patterns" (* todo! *)
| Tpat_constant _ -> unsupported loc "only integer constant are supported"
| Tpat_any -> not_in_normal_form loc "wildcard patterns remain after normalization"
| Tpat_variant (_,_,_) -> unsupported loc "variant patterns"
| Tpat_or (_,p1,p2) -> unsupported loc "or patterns"
in
List.rev (aux p)
(*#########################################################################*)
(* ** Helper functions for primitive functions *)
(* ** Helper functions for various things *)
let register_cf x =
Coqtop_register ("database_cf", x, cf_axiom_name x)
......@@ -311,7 +314,7 @@ let register_spec x v =
Coqtop_register ("database_spec", x, v)
(* TODO: rewrite this function by using a normalization functiont that returns p *)
(* TODO: rewrite this function by using a normalization function that returns p *)
let rec prefix_for_label typ =
match typ.desc with
| Tconstr (p, _, _) -> lift_path_name p
......@@ -339,30 +342,80 @@ let string_of_label typ lbl =
string_of_label_with (prefix_for_label typ) lbl
*)
let simplify_apply_args oargs =
List.map (function (lab, Some e, Required) -> e | _ -> unsupported "optional arguments") oargs
(*#########################################################################*)
(* ** Helper functions for primitive functions *)
let simplify_apply_args loc oargs =
List.map (function (lab, Some e, Required) -> e | _ -> unsupported loc "optional arguments") oargs
let get_qualified_pervasives_name f =
let name = Path.name f in
if !Clflags.nopervasives
then "Pervasives." ^ name (* unqualified name when from inside Pervasives *)
else name (* qualified name otherwise *)
let exp_find_inlined_primitive e oargs =
let args = simplify_apply_args oargs in
match e.exp_desc, args with
| Texp_ident (f,d), [n; {exp_desc = Texp_constant (Const_int m)}]
when m <> 0 && let x = Path.name f in x = "Pervasives.mod" || x = "Pervasives./" ->
find_inlined_primitive (Path.name f) Primitive_binary_only_non_zero_second_arg
| Texp_ident (f,d), _ ->
let r = find_inlined_primitive (Path.name f) (List.length args) in
(* debug: Printf.printf "exp_find_inlined_primitive: %s %d\n" (Path.name f) (List.length args);
if r = None then Printf.printf "failed\n"; *)
r
| _ -> None
let loc = e.exp_loc in
let args = simplify_apply_args loc oargs in
match e.exp_desc with
| Texp_ident (f,d) ->
let name = get_qualified_pervasives_name f in
let exp_is_inlined_primitive e oargs =
exp_find_inlined_primitive e oargs <> None
let debug() =
Printf.printf "exp_find_inlined_primitive: %s\n arity: %d\n name: %s\n" (Path.name f) (List.length args) name
in
(* debug(); *)
begin match args with
| [n; {exp_desc = Texp_constant (Const_int m)}]
when m <> 0
&& List.mem name ["Pervasives.mod"; "Pervasives./"] ->
begin match find_inlined_primitive name with
| Some (Primitive_binary_div_or_mod, coq_name) -> Some coq_name
| _ -> None
end
let exp_get_inlined_primitive e oargs =
match exp_find_inlined_primitive e oargs with
| Some x -> x
| _ -> failwith "get_inlined_primitive: not an inlined primitive"
| [e1; e2]
when List.mem name ["Pervasives.&&"; "Pervasives.||"] ->
begin match find_inlined_primitive (Path.name f) with
| Some (Primitive_binary_lazy, coq_name) -> Some coq_name
| _ -> None
end
| [e1; e2]
when List.mem name ["Pervasives.="; "Pervasives.<>"; "Pervasives.<=";
"Pervasives.>="; "Pervasives.<"; "Pervasives.>";
"Pervasives.min"; "Pervasives.max"; ] ->
let is_number =
begin match btyp_of_typ_exp e1.exp_type with
| Btyp_constr (id,[]) when Path.name id = "int" -> true
end in
(* Remark: by typing, [e2] has the same type as [e1] *)
if not is_number then
unsupported loc (Printf.sprintf "comparison operators on non integer arguments (here, %s)" (string_of_type_exp e1.exp_type));
begin match find_inlined_primitive name with
| Some (Primitive_binary_only_numbers, coq_name) -> Some coq_name
| _ -> failwith ("in exp_find_inlined_primitive, could not find the coq translation of the function: " ^ name)
end
| _ ->
let arity = List.length args in
begin match find_inlined_primitive name with
| Some (Primitive_unary, coq_name) when arity = 1 -> Some coq_name
| Some (Primitive_binary, coq_name) when arity = 2 -> Some coq_name
| _ -> None
end
(* debug: Printf.printf "exp_find_inlined_primitive: %s %d\n" (Path.name f) (List.length args);
if r = None then Printf.printf "failed\n"; *)
end
| _ -> None
let exp_is_inlined_primitive e oargs =
exp_find_inlined_primitive e oargs <> None
(*#########################################################################*)
......@@ -383,7 +436,10 @@ let lift_exp_path env p =
expression provided is not a value. *)
let rec lift_val env e =
let loc = e.exp_loc in
let aux = lift_val env in
let fail () =
not_in_normal_form loc ("in liftval: " ^ Print_tast.string_of_expression false e) in
match e.exp_desc with
| Texp_ident (p,d) ->
lift_exp_path env p
......@@ -392,13 +448,13 @@ let rec lift_val env e =
| Texp_constant (Const_int n) ->
Coq_int n
| Texp_constant _ ->
unsupported "only integer constant are supported"
unsupported loc "only integer constant are supported"
| Texp_tuple el ->
Coq_tuple (List.map aux el)
| Texp_construct (p, c, es) ->
coq_apps (coq_of_constructor p c) (List.map aux es)
| Texp_record (l, opt_init_expr) ->
if opt_init_expr <> None then unsupported "record-with expression"; (* todo *)
if opt_init_expr <> None then unsupported loc "record-with expression"; (* todo *)
if List.length l < 1 then failwith "record should have at least one field";
let labels = ((fun (p,li,ei) -> li) (List.hd l)).lbl_all in
let args = Array.make (Array.length labels) (Coq_var "dummy") in
......@@ -412,9 +468,13 @@ let rec lift_val env e =
| _ -> failwith "record should have a type-constructor as type"
in
coq_apps (coq_var_at constr) (typ_args @ Array.to_list args)
| Texp_apply (funct, oargs) when exp_is_inlined_primitive funct oargs ->
let f = exp_get_inlined_primitive funct oargs in
let args = simplify_apply_args oargs in
| Texp_apply (funct, oargs) ->
let fo = exp_find_inlined_primitive funct oargs in
let f = match fo with
| Some f -> f
| _ -> fail()
in
let args = simplify_apply_args loc oargs in
coq_apps (Coq_var f) (List.map aux args)
| Texp_lazy e ->
aux e
......@@ -424,34 +484,34 @@ let rec lift_val env e =
aux e
(* --uncomment for debugging
| Texp_function _ -> not_in_normal_form "function"
| Texp_apply _ -> not_in_normal_form "apply"
| Texp_assertfalse -> not_in_normal_form "assert false"
| Texp_try(body, pat_expr_list) -> not_in_normal_form "try expression"
| Texp_variant(l, arg) -> not_in_normal_form "variant expression"
| Texp_setfield(arg, p, lbl, newval) -> not_in_normal_form "set-field expression"
| Texp_array expr_list -> not_in_normal_form "array expressions"
| Texp_ifthenelse(cond, ifso, None) -> not_in_normal_form "if-then-without-else expressions"
| Texp_sequence(expr1, expr2) -> not_in_normal_form "sequence expressions"
| Texp_while(cond, body) -> not_in_normal_form "while expressions"
| Texp_for(param, low, high, dir, body) -> not_in_normal_form "for expressions"
| Texp_when(cond, body) -> not_in_normal_form "when expressions"
| Texp_send(_ , _, _) -> not_in_normal_form "send expressions"
| Texp_new (cl, _) -> not_in_normal_form "new expressions"
| Texp_instvar(path_self, path) -> not_in_normal_form "inst-var expressions"
| Texp_setinstvar(path_self, path, expr) -> not_in_normal_form "set-inst-var expressions"
| Texp_override(path_self, modifs) -> not_in_normal_form "override expressions"
| Texp_letmodule(id, modl, body) -> not_in_normal_form "let-module expressions"
| Texp_assert (cond) -> not_in_normal_form "assert expressions"
| Texp_object (_, _) -> not_in_normal_form "object expressions"
| Texp_poly _ -> not_in_normal_form "object expressions"
| Texp_newtype _ -> not_in_normal_form "object expressions"
| Texp_pack _ -> not_in_normal_form "object expressions"
| Texp_let _ -> not_in_normal_form "let"
| Texp_match _ -> not_in_normal_form "match"
| Texp_field _ -> not_in_normal_form "field"
| Texp_function _ -> not_in_normal_form loc "function"
| Texp_apply _ -> not_in_normal_form loc "apply"
| Texp_assertfalse -> not_in_normal_form loc "assert false"
| Texp_try(body, pat_expr_list) -> not_in_normal_form loc "try expression"
| Texp_variant(l, arg) -> not_in_normal_form loc "variant expression"
| Texp_setfield(arg, p, lbl, newval) -> not_in_normal_form loc "set-field expression"
| Texp_array expr_list -> not_in_normal_form loc "array expressions"
| Texp_ifthenelse(cond, ifso, None) -> not_in_normal_form loc "if-then-without-else expressions"
| Texp_sequence(expr1, expr2) -> not_in_normal_form loc "sequence expressions"
| Texp_while(cond, body) -> not_in_normal_form loc "while expressions"
| Texp_for(param, low, high, dir, body) -> not_in_normal_form loc "for expressions"
| Texp_when(cond, body) -> not_in_normal_form loc "when expressions"
| Texp_send(_ , _, _) -> not_in_normal_form loc "send expressions"
| Texp_new (cl, _) -> not_in_normal_form loc "new expressions"
| Texp_instvar(path_self, path) -> not_in_normal_form loc "inst-var expressions"
| Texp_setinstvar(path_self, path, expr) -> not_in_normal_form loc "set-inst-var expressions"
| Texp_override(path_self, modifs) -> not_in_normal_form loc "override expressions"
| Texp_letmodule(id, modl, body) -> not_in_normal_form loc "let-module expressions"
| Texp_assert (cond) -> not_in_normal_form loc "assert expressions"
| Texp_object (_, _) -> not_in_normal_form loc "object expressions"
| Texp_poly _ -> not_in_normal_form loc "object expressions"
| Texp_newtype _ -> not_in_normal_form loc "object expressions"
| Texp_pack _ -> not_in_normal_form loc "object expressions"
| Texp_let _ -> not_in_normal_form loc "let"
| Texp_match _ -> not_in_normal_form loc "match"
| Texp_field _ -> not_in_normal_form loc "field"
*)
| _ -> not_in_normal_form ("in liftval: " ^ Print_tast.string_of_expression false e)
| _ -> fail()
(* --todo: could be a value in a purely-functional setting
| Texp_field (e, lbl) ->
......@@ -522,7 +582,7 @@ let rec extract_label_names_simple env ty =
| Type_record (fields, _) ->
List.map (fun (name, _, _) -> name) fields
| Type_abstract when td.type_manifest <> None ->
failwith "unsupported building of a record with abstract type"
unsupported_noloc "building of a record with abstract type"
| _ -> assert false
end
| _ -> assert false
......@@ -533,12 +593,13 @@ let rec extract_label_names_simple env ty =
(** Translate a Caml expression into its Coq characteristic formula *)
let rec cfg_exp env e =
let rec cfg_exp env e =
let loc = e.exp_loc in
let aux = cfg_exp env in
let lift e = lift_val env e in
let ret e = Cf_ret (lift e) in
let not_normal () =
not_in_normal_form (Print_tast.string_of_expression false e) in
not_in_normal_form loc (Print_tast.string_of_expression false e) in
match e.exp_desc with
| Texp_ident (x,d) -> ret e
| Texp_open (p, {exp_desc = Texp_ident _}) -> assert false
......@@ -548,7 +609,7 @@ let rec cfg_exp env e =
(* TODO: only in purely function setting: | Texp_record (lbl_expr_list, opt_init_expr) -> ret e*)
| Texp_record (lbl_expr_list, opt_init_expr) ->
if opt_init_expr <> None then unsupported "record-with"; (* TODO *)
if opt_init_expr <> None then unsupported loc "record-with"; (* TODO *)
let (pathfront,pathend) = get_record_decomposed_name_for_exp e in
let func = Coq_var (pathfront ^ (record_make_name pathend)) in (* tood: move the underscore *)
let named_args = List.map (fun (p,li,ei) -> (li.lbl_name,ei)) lbl_expr_list in
......@@ -581,7 +642,7 @@ let rec cfg_exp env e =
| Recursive -> env
(* --todo: add better support for local polymorphic recursion
List.fold_left (fun (pat,bod) acc -> Ident.add (pattern_ident pat) 0 acc) env pat_expr_list *)
| Default -> unsupported "Default recursion mode"
| Default -> unsupported loc "Default recursion mode"
in
let ncs = List.map (fun (pat,bod) -> (pattern_name_protect_infix pat, cfg_func env' fvs pat bod)) pat_expr_list in
let cf_body = cfg_exp env' body in
......@@ -614,8 +675,8 @@ let rec cfg_exp env e =
let v =
try lift_val env bod
with Not_in_normal_form s ->
raise (Not_in_normal_form (s ^ " (only value can satisfy the value restriction)"))
with Not_in_normal_form (loc2, s) ->
raise (Not_in_normal_form (loc2, s ^ " (only value can satisfy the value restriction)"))
in
let env' = Ident.add (pattern_ident pat) (List.length fvs_strict) env in
let cf = cfg_exp env' body in
......@@ -626,7 +687,7 @@ let rec cfg_exp env e =
end else begin
if fvs_strict <> [] || fvs_others <> []
then not_in_normal_form ("(unsatisfied value restriction) "
then not_in_normal_form loc ("(unsatisfied value restriction) "
^ (Print_tast.string_of_expression false e));
let cf1 = cfg_exp env bod in
let env' = Ident.add (pattern_ident pat) (List.length fvs_strict) env in
......@@ -642,7 +703,7 @@ let rec cfg_exp env e =
Cf_caseif (lift cond, aux ifso, aux ifnot)
| Texp_apply (funct, oargs) ->
let args = simplify_apply_args oargs in
let args = simplify_apply_args loc oargs in
let tr = coq_typ e in
let ts = List.map coq_typ args in
Cf_app (ts, tr, lift funct, List.map lift args)
......@@ -656,8 +717,8 @@ let rec cfg_exp env e =
| Texp_when (econd, ebody) ->
let w =
try lift_val env econd
with Not_in_normal_form s ->
raise (Not_in_normal_form (s ^ " (Only total expressions are allowed in when clauses)"))
with Not_in_normal_form (loc2, s) ->
raise (Not_in_normal_form (loc2, s ^ " (Only total expressions are allowed in when clauses)"))
in
Some w, aux ebody
| _ -> None, aux body
......@@ -685,10 +746,10 @@ let rec cfg_exp env e =
| Texp_for(param, low, high, dir, body) ->
begin match dir with
| Upto -> Cf_for (Ident.name param, lift low, lift high, aux body)
| Downto -> unsupported "for-downto expressions" (* later *)
| Downto -> unsupported loc "for-downto expressions" (* later *)
end
| Texp_array expr_list -> unsupported "array expressions" (* later *)
| Texp_array expr_list -> unsupported loc "array expressions" (* later *)
| Texp_field (arg, p, lbl) ->
let tr = coq_typ e in
......@@ -702,30 +763,31 @@ let rec cfg_exp env e =
let func = Coq_var (record_field_set_name lbl.lbl_name) in
Cf_app ([ts1;ts2], coq_unit, func, [lift arg; lift newval])
| Texp_try(body, pat_expr_list) -> unsupported "try expression"
| Texp_variant(l, arg) -> unsupported "variant expression"
| Texp_ifthenelse(cond, ifso, None) -> unsupported "if-then-without-else expressions should have been normalized"
| Texp_when(cond, body) -> unsupported "when expressions outside of pattern matching"
| Texp_send(_, _, _) -> unsupported "send expressions"
| Texp_new (cl, _) -> unsupported "new expressions"
| Texp_instvar(path_self, path) -> unsupported "inst-var expressions"
| Texp_setinstvar(path_self, path, expr) -> unsupported "set-inst-var expressions"
| Texp_override(path_self, modifs) -> unsupported "override expressions"
| Texp_letmodule(id, modl, body) -> unsupported "let-module expressions"
| Texp_object _ -> unsupported "object expressions"
| Texp_poly (_,_) -> unsupported "poly"
| Texp_newtype (_,_) -> unsupported "newtype"
| Texp_pack _ -> unsupported "pack"
| Texp_open (_,_) -> unsupported "open in term"
| Texp_try(body, pat_expr_list) -> unsupported loc "try expression"
| Texp_variant(l, arg) -> unsupported loc "variant expression"
| Texp_ifthenelse(cond, ifso, None) -> unsupported loc "if-then-without-else expressions should have been normalized"
| Texp_when(cond, body) -> unsupported loc "when expressions outside of pattern matching"
| Texp_send(_, _, _) -> unsupported loc "send expressions"
| Texp_new (cl, _) -> unsupported loc "new expressions"
| Texp_instvar(path_self, path) -> unsupported loc "inst-var expressions"
| Texp_setinstvar(path_self, path, expr) -> unsupported loc "set-inst-var expressions"
| Texp_override(path_self, modifs) -> unsupported loc "override expressions"
| Texp_letmodule(id, modl, body) -> unsupported loc "let-module expressions"
| Texp_object _ -> unsupported loc "object expressions"
| Texp_poly (_,_) -> unsupported loc "poly"
| Texp_newtype (_,_) -> unsupported loc "newtype"
| Texp_pack _ -> unsupported loc "pack"
| Texp_open (_,_) -> unsupported loc "open in term"
| Texp_constraint (e,_,_) -> aux e
and cfg_func env fvs pat bod =
let rec get_typed_args acc e =
let loc = e.exp_loc in
match e.exp_desc with
| Texp_function (_,[p1,e1],partial)
| Texp_constraint ({exp_desc = Texp_function (_,[p1,e1],partial)},_,_) ->
if partial <> Total
then not_in_normal_form (Print_tast.string_of_expression false e);
then not_in_normal_form loc (Print_tast.string_of_expression false e);
get_typed_args ((pattern_name p1, coq_typ_pat p1)::acc) e1
| _ -> List.rev acc, e
in
......@@ -758,6 +820,7 @@ let is_type_record (name,dec) =
a top-level declaration from a module. *)
let rec cfg_structure_item s : cftops =
let loc = s.str_loc in
match s.str_desc with
| Tstr_value(rf, fvs, pat_expr_list) ->
reset_local_labels();
......@@ -775,7 +838,7 @@ let rec cfg_structure_item s : cftops =
| Recursive -> Ident.empty
(* --todo: better support for polymorphic recursion
List.fold_left (fun (pat,bod) acc -> Ident.add (pattern_ident pat) 0 acc) env pat_expr_list *)
| Default -> unsupported "Default recursion mode"
| Default -> unsupported loc "Default recursion mode"
in
let ncs = List.map (fun (pat,bod) -> (pattern_name_protect_infix pat, cfg_func env' fvs pat bod)) pat_expr_list in
(List.map (fun (name,_) -> Cftop_val (name, val_type)) ncs)
......@@ -813,8 +876,9 @@ let rec cfg_structure_item s : cftops =
let v =
try lift_val (Ident.empty) bod
with Not_in_normal_form s ->
raise (Not_in_normal_form (s ^ " (only value can satisfy the value restriction)"))
with Not_in_normal_form (loc2, s) ->
(* TODO: here and elsewhere, use a wrapper for extending the errors *)
raise (Not_in_normal_form (loc2, s ^ " (only value can satisfy the value restriction)"))
in
let v_typed = coq_annot v typ in
let implicits =
......@@ -830,10 +894,10 @@ let rec cfg_structure_item s : cftops =
(* term let-binding -- later *)
end else begin
failwith "unsupported top-level binding of terms that are not values";
unsupported loc "top-level binding of terms that are not values";
(* if fvs_strict <> [] || fvs_others <> []
then not_in_normal_form ("(unsatisfied value restriction) "
then not_in_normal_form loc ("(unsatisfied value restriction) "
^ (Print_tast.string_of_expression false e));
let cf1 = cfg_exp env bod in
let env' = Ident.add (pattern_ident pat) (List.length fvs_strict) env in
......@@ -846,7 +910,7 @@ let rec cfg_structure_item s : cftops =
end (* for skip_cf *)
end else
unsupported ("mutually-recursive values that are not all functions");
unsupported loc ("mutually-recursive values that are not all functions");
| Tstr_type(decls) -> [ Cftop_coqs (cfg_type_decls decls) ]
......@@ -870,11 +934,11 @@ let rec cfg_structure_item s : cftops =
| Tstr_exn_rebind(id, path) ->
[] (* unsupported "exceptions" *)
| Tstr_recmodule bindings -> unsupported "recursive modules"
| Tstr_class _ -> unsupported "objects"
| Tstr_class_type _ -> unsupported "objects"
| Tstr_include (m,ids) -> unsupported "module-include"
| Tstr_eval expr -> unsupported "top level eval expression (let _)"
| Tstr_recmodule bindings -> unsupported loc "recursive modules"
| Tstr_class _ -> unsupported loc "objects"
| Tstr_class_type _ -> unsupported loc "objects"
| Tstr_include (m,ids) -> unsupported loc "module-include"
| Tstr_eval expr -> unsupported loc "top level eval expression (let _)"