diff options
| author |  Maxime Dénès <mail@maximedenes.fr> | 2014-04-21 00:18:55 -0400 |
|---|---|---|
| committer | Maxime Dénès <mail@maximedenes.fr> | 2014-07-22 17:55:06 -0400 |
| commit | b828495753da8f1685e7ca5b6897a580e7bd3f09 (patch) | |
| tree | c71ec56671b95721aa5ea3975fad5f07f3c9fd61 | |
| parent | 4cd0becc84208525443d7ca4e9cc8214d00df319 (diff) | |
First attempt at a fix for guard condition on cofixpoints.
| -rw-r--r-- | kernel/inductive.ml | 5 | ||||
| -rw-r--r-- | kernel/type_errors.ml | 1 | ||||
| -rw-r--r-- | kernel/type_errors.mli | 1 | ||||
| -rw-r--r-- | toplevel/himsg.ml | 4 |
4 files changed, 11 insertions, 0 deletions
diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 9cfa5c632..eae4c098d 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -1171,6 +1171,8 @@ let check_one_cofix env nbfix def deftype = raise (CoFixGuardError (env,UnguardedRecursiveCall c)) | Case (_,p,tm,vrest) -> + begin + try let _ = codomain_is_coind env p in if (noccur_with_meta n nbfix p) then if (noccur_with_meta n nbfix tm) then if (List.for_all (noccur_with_meta n nbfix) args) then @@ -1181,6 +1183,9 @@ let check_one_cofix env nbfix def deftype = raise (CoFixGuardError (env,RecCallInCaseArg c)) else raise (CoFixGuardError (env,RecCallInCasePred c)) + with CoFixGuardError _ -> + raise (CoFixGuardError (env, ReturnPredicateNotCoInductive c)) + end | Meta _ -> () | Evar _ -> diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index 30dcbafe6..d0ecf9e9b 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -30,6 +30,7 @@ type guard_error = | RecCallInCaseArg of constr | RecCallInCasePred of constr | NotGuardedForm of constr + | ReturnPredicateNotCoInductive of constr type arity_error = | NonInformativeToInformative diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index 09310b42b..37370377d 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -31,6 +31,7 @@ type guard_error = | RecCallInCaseArg of constr | RecCallInCasePred of constr | NotGuardedForm of constr + | ReturnPredicateNotCoInductive of constr type arity_error = | NonInformativeToInformative diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 16d324029..a0a3d947e 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -425,6 +425,10 @@ let explain_ill_formed_rec_body env err names i fixenv vdefj = str "Sub-expression " ++ pr_lconstr_env env c ++ strbrk " not in guarded form (should be a constructor," ++ strbrk " an abstraction, a match, a cofix or a recursive call)" + | ReturnPredicateNotCoInductive c -> + str "The return clause of the following pattern matching should be" ++ + strbrk "a coinductive type:" ++ + spc () ++ pr_lconstr_env env c in prt_name i ++ str " is ill-formed." ++ fnl () ++ pr_ne_context_of (str "In environment") env ++ |