diff options
Diffstat (limited to 'plugins/extraction/table.ml')
| -rw-r--r-- | plugins/extraction/table.ml | 146 |
1 files changed, 84 insertions, 62 deletions
diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index d7842e12..ff66d915 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -15,7 +15,7 @@ open Libobject open Goptions open Libnames open Globnames -open Errors +open CErrors open Util open Pp open Miniml @@ -295,81 +295,94 @@ let pr_long_global ref = pr_path (Nametab.path_of_global ref) let err s = errorlabstrm "Extraction" s +let warn_extraction_axiom_to_realize = + CWarnings.create ~name:"extraction-axiom-to-realize" ~category:"extraction" + (fun axioms -> + let s = if Int.equal (List.length axioms) 1 then "axiom" else "axioms" in + strbrk ("The following "^s^" must be realized in the extracted code:") + ++ hov 1 (spc () ++ prlist_with_sep spc safe_pr_global axioms) + ++ str "." ++ fnl ()) + +let warn_extraction_logical_axiom = + CWarnings.create ~name:"extraction-logical-axiom" ~category:"extraction" + (fun axioms -> + let s = + if Int.equal (List.length axioms) 1 then "axiom was" else "axioms were" + in + (strbrk ("The following logical "^s^" encountered:") ++ + hov 1 (spc () ++ prlist_with_sep spc safe_pr_global axioms ++ str ".\n") + ++ strbrk "Having invalid logical axiom in the environment when extracting" + ++ spc () ++ strbrk "may lead to incorrect or non-terminating ML terms." ++ + fnl ())) + let warning_axioms () = let info_axioms = Refset'.elements !info_axioms in - if List.is_empty info_axioms then () - else begin - let s = if Int.equal (List.length info_axioms) 1 then "axiom" else "axioms" in - msg_warning - (str ("The following "^s^" must be realized in the extracted code:") - ++ hov 1 (spc () ++ prlist_with_sep spc safe_pr_global info_axioms) - ++ str "." ++ fnl ()) - end; + if not (List.is_empty info_axioms) then + warn_extraction_axiom_to_realize info_axioms; let log_axioms = Refset'.elements !log_axioms in - if List.is_empty log_axioms then () - else begin - let s = if Int.equal (List.length log_axioms) 1 then "axiom was" else "axioms were" - in - msg_warning - (str ("The following logical "^s^" encountered:") ++ - hov 1 - (spc () ++ prlist_with_sep spc safe_pr_global log_axioms ++ str ".\n") - ++ - str "Having invalid logical axiom in the environment when extracting" ++ - spc () ++ str "may lead to incorrect or non-terminating ML terms." ++ - fnl ()) - end + if not (List.is_empty log_axioms) then + warn_extraction_logical_axiom log_axioms + +let warn_extraction_opaque_accessed = + CWarnings.create ~name:"extraction-opaque-accessed" ~category:"extraction" + (fun lst -> strbrk "The extraction is currently set to bypass opacity, " ++ + strbrk "the following opaque constant bodies have been accessed :" ++ + lst ++ str "." ++ fnl ()) + +let warn_extraction_opaque_as_axiom = + CWarnings.create ~name:"extraction-opaque-as-axiom" ~category:"extraction" + (fun lst -> strbrk "The extraction now honors the opacity constraints by default, " ++ + strbrk "the following opaque constants have been extracted as axioms :" ++ + lst ++ str "." ++ fnl () ++ + strbrk "If necessary, use \"Set Extraction AccessOpaque\" to change this." + ++ fnl ()) let warning_opaques accessed = let opaques = Refset'.elements !opaques in - if List.is_empty opaques then () - else + if not (List.is_empty opaques) then let lst = hov 1 (spc () ++ prlist_with_sep spc safe_pr_global opaques) in - if accessed then - msg_warning - (str "The extraction is currently set to bypass opacity,\n" ++ - str "the following opaque constant bodies have been accessed :" ++ - lst ++ str "." ++ fnl ()) - else - msg_warning - (str "The extraction now honors the opacity constraints by default,\n" ++ - str "the following opaque constants have been extracted as axioms :" ++ - lst ++ str "." ++ fnl () ++ - str "If necessary, use \"Set Extraction AccessOpaque\" to change this." - ++ fnl ()) - -let warning_both_mod_and_cst q mp r = - msg_warning - (str "The name " ++ pr_qualid q ++ str " is ambiguous, " ++ - str "do you mean module " ++ - pr_long_mp mp ++ - str " or object " ++ - pr_long_global r ++ str " ?" ++ fnl () ++ - str "First choice is assumed, for the second one please use " ++ - str "fully qualified name." ++ fnl ()) + if accessed then warn_extraction_opaque_accessed lst + else warn_extraction_opaque_as_axiom lst + +let warning_ambiguous_name = + CWarnings.create ~name:"extraction-ambiguous-name" ~category:"extraction" + (fun (q,mp,r) -> strbrk "The name " ++ pr_qualid q ++ strbrk " is ambiguous, " ++ + strbrk "do you mean module " ++ + pr_long_mp mp ++ + strbrk " or object " ++ + pr_long_global r ++ str " ?" ++ fnl () ++ + strbrk "First choice is assumed, for the second one please use " ++ + strbrk "fully qualified name." ++ fnl ()) let error_axiom_scheme r i = err (str "The type scheme axiom " ++ spc () ++ safe_pr_global r ++ spc () ++ str "needs " ++ int i ++ str " type variable(s).") +let warn_extraction_inside_module = + CWarnings.create ~name:"extraction-inside-module" ~category:"extraction" + (fun () -> strbrk "Extraction inside an opened module is experimental." ++ + strbrk "In case of problem, close it first.") + + let check_inside_module () = if Lib.is_modtype () then err (str "You can't do that within a Module Type." ++ fnl () ++ str "Close it and try again.") else if Lib.is_module () then - msg_warning - (str "Extraction inside an opened module is experimental.\n" ++ - str "In case of problem, close it first.\n") + warn_extraction_inside_module () let check_inside_section () = if Lib.sections_are_opened () then err (str "You can't do that within a section." ++ fnl () ++ str "Close it and try again.") -let warning_id s = - msg_warning (str ("The identifier "^s^ - " contains __ which is reserved for the extraction")) +let warn_extraction_reserved_identifier = + CWarnings.create ~name:"extraction-reserved-identifier" ~category:"extraction" + (fun s -> strbrk ("The identifier "^s^ + " contains __ which is reserved for the extraction")) + +let warning_id s = warn_extraction_reserved_identifier s let error_constant r = err (safe_pr_global r ++ str " is not a constant.") @@ -391,9 +404,15 @@ let error_no_module_expr mp = ++ str "some Declare Module outside any Module Type.\n" ++ str "This situation is currently unsupported by the extraction.") -let error_singleton_become_prop id = +let error_singleton_become_prop id og = + let loc = + match og with + | Some g -> fnl () ++ str "in " ++ safe_pr_global g ++ + str " (or in its mutual block)" + | None -> mt () + in err (str "The informative inductive type " ++ pr_id id ++ - str " has a Prop instance.\n" ++ + str " has a Prop instance" ++ loc ++ str "." ++ fnl () ++ str "This happens when a sort-polymorphic singleton inductive type\n" ++ str "has logical parameters, such as (I,I) : (True * True) : Prop.\n" ++ str "The Ocaml extraction cannot handle this situation yet.\n" ++ @@ -422,7 +441,7 @@ let error_MPfile_as_mod mp b = let argnames_of_global r = let typ = Global.type_of_global_unsafe r in let rels,_ = - decompose_prod (Reduction.whd_betadeltaiota (Global.env ()) typ) in + decompose_prod (Reduction.whd_all (Global.env ()) typ) in List.rev_map fst rels let msg_of_implicit = function @@ -441,25 +460,28 @@ let error_remaining_implicit k = str "You might also try Unset Extraction SafeImplicits to force" ++ fnl() ++ str "the extraction of unsafe code and review it manually.") +let warn_extraction_remaining_implicit = + CWarnings.create ~name:"extraction-remaining-implicit" ~category:"extraction" + (fun s -> strbrk ("At least an implicit occurs after extraction : "^s^".") ++ fnl () ++ + strbrk "Extraction SafeImplicits is unset, extracting nonetheless," + ++ strbrk "but this code is potentially unsafe, please review it manually.") + let warning_remaining_implicit k = let s = msg_of_implicit k in - msg_warning - (str ("At least an implicit occurs after extraction : "^s^".") ++ fnl () ++ - str "Extraction SafeImplicits is unset, extracting nonetheless," ++ fnl () - ++ str "but this code is potentially unsafe, please review it manually.") + warn_extraction_remaining_implicit s let check_loaded_modfile mp = match base_mp mp with | MPfile dp -> if not (Library.library_is_loaded dp) then begin match base_mp (Lib.current_mp ()) with | MPfile dp' when not (DirPath.equal dp dp') -> - err (str ("Please load library "^(DirPath.to_string dp^" first."))) + err (str "Please load library " ++ pr_dirpath dp ++ str " first.") | _ -> () end | _ -> () let info_file f = - Flags.if_verbose msg_info + Flags.if_verbose Feedback.msg_info (str ("The file "^f^" has been created by extraction.")) @@ -858,7 +880,7 @@ let extract_constant_inline inline r ids s = | ConstRef kn -> let env = Global.env () in let typ = Global.type_of_global_unsafe (ConstRef kn) in - let typ = Reduction.whd_betadeltaiota env typ in + let typ = Reduction.whd_all env typ in if Reduction.is_arity env typ then begin let nargs = Hook.get use_type_scheme_nb_args env typ in |