diff --git a/.Makefile.lint b/.Makefile.lint
deleted file mode 100644
index ba3d6165fcea41dd2aac3e8913ca5d297c6064de..0000000000000000000000000000000000000000
--- a/.Makefile.lint
+++ /dev/null
@@ -1,302 +0,0 @@
-ML_LINT_KO:=
-ML_LINT_KO+=src/kernel_internals/parsing/check_logic_parser.ml
-ML_LINT_KO+=src/kernel_internals/parsing/errorloc.ml
-ML_LINT_KO+=src/kernel_internals/parsing/errorloc.mli
-ML_LINT_KO+=src/kernel_internals/parsing/lexerhack.ml
-ML_LINT_KO+=src/kernel_internals/parsing/logic_preprocess.mli
-ML_LINT_KO+=src/kernel_internals/runtime/boot.ml
-ML_LINT_KO+=src/kernel_internals/runtime/machdeps.ml
-ML_LINT_KO+=src/kernel_internals/typing/allocates.ml
-ML_LINT_KO+=src/kernel_internals/typing/frontc.mli
-ML_LINT_KO+=src/kernel_internals/typing/infer_annotations.ml
-ML_LINT_KO+=src/kernel_internals/typing/mergecil.mli
-ML_LINT_KO+=src/kernel_internals/typing/translate_lightweight.ml
-ML_LINT_KO+=src/kernel_internals/typing/translate_lightweight.mli
-ML_LINT_KO+=src/kernel_internals/typing/unroll_loops.ml
-ML_LINT_KO+=src/kernel_internals/typing/unroll_loops.mli
-ML_LINT_KO+=src/kernel_services/abstract_interp/abstract_interp.ml
-ML_LINT_KO+=src/kernel_services/abstract_interp/abstract_interp.mli
-ML_LINT_KO+=src/kernel_services/abstract_interp/fval.mli
-ML_LINT_KO+=src/kernel_services/abstract_interp/int_Base.ml
-ML_LINT_KO+=src/kernel_services/abstract_interp/int_Base.mli
-ML_LINT_KO+=src/kernel_services/abstract_interp/int_Intervals_sig.mli
-ML_LINT_KO+=src/kernel_services/abstract_interp/ival.ml
-ML_LINT_KO+=src/kernel_services/abstract_interp/ival.mli
-ML_LINT_KO+=src/kernel_services/abstract_interp/lattice_messages.ml
-ML_LINT_KO+=src/kernel_services/abstract_interp/lattice_messages.mli
-ML_LINT_KO+=src/kernel_services/abstract_interp/lattice_type.mli
-ML_LINT_KO+=src/kernel_services/abstract_interp/lmap.ml
-ML_LINT_KO+=src/kernel_services/abstract_interp/lmap.mli
-ML_LINT_KO+=src/kernel_services/abstract_interp/lmap_bitwise.ml
-ML_LINT_KO+=src/kernel_services/abstract_interp/lmap_bitwise.mli
-ML_LINT_KO+=src/kernel_services/abstract_interp/locations.ml
-ML_LINT_KO+=src/kernel_services/abstract_interp/locations.mli
-ML_LINT_KO+=src/kernel_services/abstract_interp/map_lattice.ml
-ML_LINT_KO+=src/kernel_services/abstract_interp/map_lattice.mli
-ML_LINT_KO+=src/kernel_services/abstract_interp/offsetmap.ml
-ML_LINT_KO+=src/kernel_services/abstract_interp/offsetmap.mli
-ML_LINT_KO+=src/kernel_services/abstract_interp/offsetmap_bitwise_sig.mli
-ML_LINT_KO+=src/kernel_services/abstract_interp/offsetmap_sig.mli
-ML_LINT_KO+=src/kernel_services/abstract_interp/origin.ml
-ML_LINT_KO+=src/kernel_services/abstract_interp/origin.mli
-ML_LINT_KO+=src/kernel_services/abstract_interp/tr_offset.mli
-ML_LINT_KO+=src/kernel_services/analysis/bit_utils.ml
-ML_LINT_KO+=src/kernel_services/analysis/bit_utils.mli
-ML_LINT_KO+=src/kernel_services/analysis/dataflow2.ml
-ML_LINT_KO+=src/kernel_services/analysis/dataflow2.mli
-ML_LINT_KO+=src/kernel_services/analysis/dataflows.ml
-ML_LINT_KO+=src/kernel_services/analysis/dataflows.mli
-ML_LINT_KO+=src/kernel_services/analysis/dominators.ml
-ML_LINT_KO+=src/kernel_services/analysis/logic_interp.ml
-ML_LINT_KO+=src/kernel_services/analysis/loop.ml
-ML_LINT_KO+=src/kernel_services/analysis/ordered_stmt.ml
-ML_LINT_KO+=src/kernel_services/analysis/service_graph.ml
-ML_LINT_KO+=src/kernel_services/analysis/service_graph.mli
-ML_LINT_KO+=src/kernel_services/analysis/stmts_graph.ml
-ML_LINT_KO+=src/kernel_services/analysis/stmts_graph.mli
-ML_LINT_KO+=src/kernel_services/analysis/undefined_sequence.ml
-ML_LINT_KO+=src/kernel_services/analysis/wto_statement.ml
-ML_LINT_KO+=src/kernel_services/analysis/wto_statement.mli
-ML_LINT_KO+=src/kernel_services/ast_data/annotations.ml
-ML_LINT_KO+=src/kernel_services/ast_data/annotations.mli
-ML_LINT_KO+=src/kernel_services/ast_data/ast.ml
-ML_LINT_KO+=src/kernel_services/ast_data/ast.mli
-ML_LINT_KO+=src/kernel_services/ast_data/kernel_function.ml
-ML_LINT_KO+=src/kernel_services/ast_data/kernel_function.mli
-ML_LINT_KO+=src/kernel_services/ast_data/property_status.mli
-ML_LINT_KO+=src/kernel_services/ast_queries/cil_datatype.mli
-ML_LINT_KO+=src/kernel_services/ast_queries/cil_state_builder.mli
-ML_LINT_KO+=src/kernel_services/ast_queries/logic_const.mli
-ML_LINT_KO+=src/kernel_services/ast_transformations/clone.ml
-ML_LINT_KO+=src/kernel_services/ast_transformations/clone.mli
-ML_LINT_KO+=src/kernel_services/cmdline_parameters/cmdline.ml
-ML_LINT_KO+=src/kernel_services/cmdline_parameters/cmdline.mli
-ML_LINT_KO+=src/kernel_services/cmdline_parameters/parameter_category.ml
-ML_LINT_KO+=src/kernel_services/cmdline_parameters/parameter_category.mli
-ML_LINT_KO+=src/kernel_services/cmdline_parameters/parameter_customize.mli
-ML_LINT_KO+=src/kernel_services/cmdline_parameters/parameter_state.ml
-ML_LINT_KO+=src/kernel_services/cmdline_parameters/parameter_state.mli
-ML_LINT_KO+=src/kernel_services/cmdline_parameters/typed_parameter.ml
-ML_LINT_KO+=src/kernel_services/cmdline_parameters/typed_parameter.mli
-ML_LINT_KO+=src/kernel_services/parsetree/cabshelper.ml
-ML_LINT_KO+=src/kernel_services/parsetree/cabshelper.mli
-ML_LINT_KO+=src/kernel_services/parsetree/logic_ptree.mli
-ML_LINT_KO+=src/kernel_services/plugin_entry_points/db.ml
-ML_LINT_KO+=src/kernel_services/plugin_entry_points/db.mli
-ML_LINT_KO+=src/kernel_services/plugin_entry_points/emitter.ml
-ML_LINT_KO+=src/kernel_services/plugin_entry_points/emitter.mli
-ML_LINT_KO+=src/kernel_services/plugin_entry_points/journal.ml
-ML_LINT_KO+=src/kernel_services/plugin_entry_points/journal.mli
-ML_LINT_KO+=src/kernel_services/visitors/cabsvisit.ml
-ML_LINT_KO+=src/kernel_services/visitors/cabsvisit.mli
-ML_LINT_KO+=src/libraries/datatype/datatype.ml
-ML_LINT_KO+=src/libraries/datatype/datatype.mli
-ML_LINT_KO+=src/libraries/datatype/descr.ml
-ML_LINT_KO+=src/libraries/datatype/descr.mli
-ML_LINT_KO+=src/libraries/datatype/structural_descr.ml
-ML_LINT_KO+=src/libraries/datatype/structural_descr.mli
-ML_LINT_KO+=src/libraries/datatype/type.ml
-ML_LINT_KO+=src/libraries/datatype/type.mli
-ML_LINT_KO+=src/libraries/datatype/unmarshal.ml
-ML_LINT_KO+=src/libraries/datatype/unmarshal.mli
-ML_LINT_KO+=src/libraries/datatype/unmarshal_hashtbl_test.ml
-ML_LINT_KO+=src/libraries/datatype/unmarshal_test.ml
-ML_LINT_KO+=src/libraries/datatype/unmarshal_z.ml
-ML_LINT_KO+=src/libraries/project/project.ml
-ML_LINT_KO+=src/libraries/project/project.mli
-ML_LINT_KO+=src/libraries/project/project_skeleton.mli
-ML_LINT_KO+=src/libraries/project/state.ml
-ML_LINT_KO+=src/libraries/project/state.mli
-ML_LINT_KO+=src/libraries/project/state_builder.ml
-ML_LINT_KO+=src/libraries/project/state_builder.mli
-ML_LINT_KO+=src/libraries/project/state_dependency_graph.ml
-ML_LINT_KO+=src/libraries/project/state_dependency_graph.mli
-ML_LINT_KO+=src/libraries/project/state_selection.ml
-ML_LINT_KO+=src/libraries/project/state_selection.mli
-ML_LINT_KO+=src/libraries/project/state_topological.mli
-ML_LINT_KO+=src/libraries/stdlib/FCHashtbl.mli
-ML_LINT_KO+=src/libraries/stdlib/extlib.ml
-ML_LINT_KO+=src/libraries/stdlib/extlib.mli
-ML_LINT_KO+=src/libraries/utils/bag.ml
-ML_LINT_KO+=src/libraries/utils/binary_cache.ml
-ML_LINT_KO+=src/libraries/utils/bitvector.ml
-ML_LINT_KO+=src/libraries/utils/bitvector.mli
-ML_LINT_KO+=src/libraries/utils/cilconfig.ml
-ML_LINT_KO+=src/libraries/utils/command.ml
-ML_LINT_KO+=src/libraries/utils/command.mli
-ML_LINT_KO+=src/libraries/utils/escape.mli
-ML_LINT_KO+=src/libraries/utils/hook.ml
-ML_LINT_KO+=src/libraries/utils/hook.mli
-ML_LINT_KO+=src/libraries/utils/hptmap.ml
-ML_LINT_KO+=src/libraries/utils/hptmap.mli
-ML_LINT_KO+=src/libraries/utils/hptset.ml
-ML_LINT_KO+=src/libraries/utils/hptset.mli
-ML_LINT_KO+=src/libraries/utils/indexer.ml
-ML_LINT_KO+=src/libraries/utils/indexer.mli
-ML_LINT_KO+=src/libraries/utils/pretty_utils.ml
-ML_LINT_KO+=src/libraries/utils/pretty_utils.mli
-ML_LINT_KO+=src/libraries/utils/qstack.ml
-ML_LINT_KO+=src/libraries/utils/qstack.mli
-ML_LINT_KO+=src/libraries/utils/rangemap.ml
-ML_LINT_KO+=src/libraries/utils/rangemap.mli
-ML_LINT_KO+=src/libraries/utils/vector.ml
-ML_LINT_KO+=src/libraries/utils/vector.mli
-ML_LINT_KO+=src/libraries/utils/wto.ml
-ML_LINT_KO+=src/libraries/utils/wto.mli
-ML_LINT_KO+=src/plugins/aorai/Aorai.mli
-ML_LINT_KO+=src/plugins/aorai/aorai_dataflow.ml
-ML_LINT_KO+=src/plugins/aorai/aorai_dataflow.mli
-ML_LINT_KO+=src/plugins/aorai/data_for_aorai.ml
-ML_LINT_KO+=src/plugins/aorai/data_for_aorai.mli
-ML_LINT_KO+=src/plugins/aorai/logic_simplification.ml
-ML_LINT_KO+=src/plugins/aorai/logic_simplification.mli
-ML_LINT_KO+=src/plugins/aorai/ltl_output.ml
-ML_LINT_KO+=src/plugins/aorai/path_analysis.ml
-ML_LINT_KO+=src/plugins/aorai/utils_parser.ml
-ML_LINT_KO+=src/plugins/callgraph/callgraph_api.mli
-ML_LINT_KO+=src/plugins/callgraph/cg.ml
-ML_LINT_KO+=src/plugins/callgraph/cg.mli
-ML_LINT_KO+=src/plugins/callgraph/journalize.ml
-ML_LINT_KO+=src/plugins/callgraph/journalize.mli
-ML_LINT_KO+=src/plugins/callgraph/register.ml
-ML_LINT_KO+=src/plugins/callgraph/services.ml
-ML_LINT_KO+=src/plugins/callgraph/services.mli
-ML_LINT_KO+=src/plugins/callgraph/subgraph.ml
-ML_LINT_KO+=src/plugins/callgraph/subgraph.mli
-ML_LINT_KO+=src/plugins/callgraph/uses.ml
-ML_LINT_KO+=src/plugins/constant_propagation/propagationParameters.ml
-ML_LINT_KO+=src/plugins/constant_propagation/api.ml
-ML_LINT_KO+=src/plugins/from/callwise.ml
-ML_LINT_KO+=src/plugins/from/from_compute.ml
-ML_LINT_KO+=src/plugins/from/from_parameters.ml
-ML_LINT_KO+=src/plugins/from/from_register.ml
-ML_LINT_KO+=src/plugins/from/functionwise.ml
-ML_LINT_KO+=src/plugins/gui/analyses_manager.ml
-ML_LINT_KO+=src/plugins/gui/book_manager.ml
-ML_LINT_KO+=src/plugins/gui/book_manager.mli
-ML_LINT_KO+=src/plugins/gui/design.mli
-ML_LINT_KO+=src/plugins/gui/gtk_form.ml
-ML_LINT_KO+=src/plugins/gui/gtk_form.mli
-ML_LINT_KO+=src/plugins/gui/gui_printers.ml
-ML_LINT_KO+=src/plugins/gui/history.ml
-ML_LINT_KO+=src/plugins/gui/history.mli
-ML_LINT_KO+=src/plugins/gui/launcher.ml
-ML_LINT_KO+=src/plugins/gui/menu_manager.ml
-ML_LINT_KO+=src/plugins/gui/menu_manager.mli
-ML_LINT_KO+=src/plugins/gui/project_manager.ml
-ML_LINT_KO+=src/plugins/gui/project_manager.mli
-ML_LINT_KO+=src/plugins/gui/source_manager.mli
-ML_LINT_KO+=src/plugins/gui/warning_manager.ml
-ML_LINT_KO+=src/plugins/gui/warning_manager.mli
-ML_LINT_KO+=src/plugins/gui/wbox.ml
-ML_LINT_KO+=src/plugins/gui/wbox.mli
-ML_LINT_KO+=src/plugins/gui/wfile.ml
-ML_LINT_KO+=src/plugins/gui/widget.ml
-ML_LINT_KO+=src/plugins/gui/wpalette.ml
-ML_LINT_KO+=src/plugins/gui/wpalette.mli
-ML_LINT_KO+=src/plugins/gui/wpane.ml
-ML_LINT_KO+=src/plugins/gui/wpane.mli
-ML_LINT_KO+=src/plugins/gui/wtable.ml
-ML_LINT_KO+=src/plugins/gui/wtext.ml
-ML_LINT_KO+=src/plugins/gui/wtext.mli
-ML_LINT_KO+=src/plugins/impact/Impact.mli
-ML_LINT_KO+=src/plugins/impact/compute_impact.ml
-ML_LINT_KO+=src/plugins/impact/compute_impact.mli
-ML_LINT_KO+=src/plugins/impact/options.ml
-ML_LINT_KO+=src/plugins/impact/options.mli
-ML_LINT_KO+=src/plugins/impact/pdg_aux.ml
-ML_LINT_KO+=src/plugins/impact/pdg_aux.mli
-ML_LINT_KO+=src/plugins/impact/register.ml
-ML_LINT_KO+=src/plugins/inout/cumulative_analysis.ml
-ML_LINT_KO+=src/plugins/inout/cumulative_analysis.mli
-ML_LINT_KO+=src/plugins/inout/derefs.ml
-ML_LINT_KO+=src/plugins/inout/inout_parameters.ml
-ML_LINT_KO+=src/plugins/inout/inputs.ml
-ML_LINT_KO+=src/plugins/inout/operational_inputs.ml
-ML_LINT_KO+=src/plugins/inout/outputs.ml
-ML_LINT_KO+=src/plugins/inout/register.ml
-ML_LINT_KO+=src/plugins/loop_analysis/region_analysis.ml
-ML_LINT_KO+=src/plugins/loop_analysis/region_analysis_stmt.ml
-ML_LINT_KO+=src/plugins/metrics/metrics_acsl.ml
-ML_LINT_KO+=src/plugins/metrics/metrics_cabs.ml
-ML_LINT_KO+=src/plugins/metrics/metrics_cilast.mli
-ML_LINT_KO+=src/plugins/metrics/metrics_coverage.ml
-ML_LINT_KO+=src/plugins/metrics/metrics_gui.ml
-ML_LINT_KO+=src/plugins/metrics/metrics_parameters.ml
-ML_LINT_KO+=src/plugins/metrics/register.ml
-ML_LINT_KO+=src/plugins/metrics/register_gui.ml
-ML_LINT_KO+=src/plugins/occurrence/Occurrence.mli
-ML_LINT_KO+=src/plugins/occurrence/options.ml
-ML_LINT_KO+=src/plugins/occurrence/register.ml
-ML_LINT_KO+=src/plugins/occurrence/register_gui.ml
-ML_LINT_KO+=src/plugins/pdg/annot.ml
-ML_LINT_KO+=src/plugins/pdg/annot.mli
-ML_LINT_KO+=src/plugins/pdg/build.ml
-ML_LINT_KO+=src/plugins/pdg/ctrlDpds.ml
-ML_LINT_KO+=src/plugins/pdg/ctrlDpds.mli
-ML_LINT_KO+=src/plugins/pdg/marks.ml
-ML_LINT_KO+=src/plugins/pdg/marks.mli
-ML_LINT_KO+=src/plugins/pdg/pdg_parameters.ml
-ML_LINT_KO+=src/plugins/pdg/pdg_state.ml
-ML_LINT_KO+=src/plugins/pdg/pdg_state.mli
-ML_LINT_KO+=src/plugins/pdg/register.ml
-ML_LINT_KO+=src/plugins/pdg/sets.ml
-ML_LINT_KO+=src/plugins/pdg/sets.mli
-ML_LINT_KO+=src/plugins/pdg_types/pdgIndex.ml
-ML_LINT_KO+=src/plugins/pdg_types/pdgIndex.mli
-ML_LINT_KO+=src/plugins/pdg_types/pdgMarks.ml
-ML_LINT_KO+=src/plugins/pdg_types/pdgMarks.mli
-ML_LINT_KO+=src/plugins/pdg_types/pdgTypes.ml
-ML_LINT_KO+=src/plugins/pdg_types/pdgTypes.mli
-ML_LINT_KO+=src/plugins/postdominators/compute.ml
-ML_LINT_KO+=src/plugins/postdominators/postdominators_parameters.ml
-ML_LINT_KO+=src/plugins/postdominators/print.ml
-ML_LINT_KO+=src/plugins/print_api/print_interface.ml
-ML_LINT_KO+=src/plugins/scope/Scope.mli
-ML_LINT_KO+=src/plugins/scope/datascope.ml
-ML_LINT_KO+=src/plugins/scope/defs.ml
-ML_LINT_KO+=src/plugins/scope/zones.ml
-ML_LINT_KO+=src/plugins/security_slicing/components.ml
-ML_LINT_KO+=src/plugins/security_slicing/register_gui.ml
-ML_LINT_KO+=src/plugins/security_slicing/security_slicing_parameters.ml
-ML_LINT_KO+=src/plugins/security_slicing/security_slicing_parameters.mli
-ML_LINT_KO+=src/plugins/slicing/Slicing.mli
-ML_LINT_KO+=src/plugins/slicing/api.ml
-ML_LINT_KO+=src/plugins/slicing/fct_slice.ml
-ML_LINT_KO+=src/plugins/slicing/fct_slice.mli
-ML_LINT_KO+=src/plugins/slicing/printSlice.ml
-ML_LINT_KO+=src/plugins/slicing/register.ml
-ML_LINT_KO+=src/plugins/slicing/register_gui.ml
-ML_LINT_KO+=src/plugins/slicing/slicingActions.ml
-ML_LINT_KO+=src/plugins/slicing/slicingCmds.ml
-ML_LINT_KO+=src/plugins/slicing/slicingInternals.ml
-ML_LINT_KO+=src/plugins/slicing/slicingMacros.ml
-ML_LINT_KO+=src/plugins/slicing/slicingMarks.ml
-ML_LINT_KO+=src/plugins/slicing/slicingMarks.mli
-ML_LINT_KO+=src/plugins/slicing/slicingParameters.ml
-ML_LINT_KO+=src/plugins/slicing/slicingProject.ml
-ML_LINT_KO+=src/plugins/slicing/slicingSelect.ml
-ML_LINT_KO+=src/plugins/slicing/slicingState.ml
-ML_LINT_KO+=src/plugins/slicing/slicingTransform.ml
-ML_LINT_KO+=src/plugins/slicing/slicingTransform.mli
-ML_LINT_KO+=src/plugins/slicing/slicingTypes.ml
-ML_LINT_KO+=src/plugins/sparecode/globs.ml
-ML_LINT_KO+=src/plugins/sparecode/register.ml
-ML_LINT_KO+=src/plugins/sparecode/spare_marks.ml
-ML_LINT_KO+=src/plugins/sparecode/sparecode_params.ml
-ML_LINT_KO+=src/plugins/sparecode/sparecode_params.mli
-ML_LINT_KO+=src/plugins/sparecode/transform.ml
-ML_LINT_KO+=src/plugins/studia/Studia.mli
-ML_LINT_KO+=src/plugins/studia/options.ml
-ML_LINT_KO+=src/plugins/studia/reads.ml
-ML_LINT_KO+=src/plugins/studia/studia_gui.ml
-ML_LINT_KO+=src/plugins/studia/studia_gui.mli
-ML_LINT_KO+=src/plugins/users/users_register.ml
-ML_LINT_KO+=src/plugins/value_types/cilE.mli
-ML_LINT_KO+=src/plugins/value_types/function_Froms.ml
-ML_LINT_KO+=src/plugins/value_types/function_Froms.mli
-ML_LINT_KO+=src/plugins/value_types/inout_type.ml
-ML_LINT_KO+=src/plugins/value_types/precise_locs.ml
-ML_LINT_KO+=src/plugins/value_types/value_types.ml
-ML_LINT_KO+=src/plugins/value_types/value_types.mli
-ML_LINT_KO+=src/plugins/value_types/widen_type.ml
diff --git a/src/kernel_internals/parsing/check_logic_parser.ml b/src/kernel_internals/parsing/check_logic_parser.ml
index 639b8a991ccb7ff661606e73734fcc16cbaba00d..7698d60828bbc02e86de74097a8578a78ecb494c 100644
--- a/src/kernel_internals/parsing/check_logic_parser.ml
+++ b/src/kernel_internals/parsing/check_logic_parser.ml
@@ -34,12 +34,12 @@ let is_token_line s = String.length s >= 6 && String.sub s 0 6 = "%token"
let add_tokens s =
let rec add_token s1 =
- Scanf.sscanf s1 " %[A-Za-z0-9_] %s@$"
+ Scanf.sscanf s1 " %[A-Za-z0-9_] %s@$"
(fun kw tl ->
- if kw <> "" then begin
- tokens:=Strings.add kw !tokens;
- add_token tl
- end)
+ if kw <> "" then begin
+ tokens:=Strings.add kw !tokens;
+ add_token tl
+ end)
in
let s = String.sub s 7 (String.length s - 7) in
let s =
@@ -50,7 +50,7 @@ let add_tokens s =
in add_token s
let wildcard_rules =
- [ "bs_keyword"; "wildcard"; "keyword"; "c_keyword";
+ [ "bs_keyword"; "wildcard"; "keyword"; "c_keyword";
"non_logic_keyword"; "acsl_c_keyword"; "is_ext_spec";
"is_acsl_spec"; "is_acsl_decl_or_code_annot";
"is_acsl_other"; "post_cond";
@@ -76,7 +76,7 @@ let is_other_rule s =
end else false
let add_wildcards s =
- let s =
+ let s =
if String.contains s ':' then begin
let l = String.index s ':' in
String.sub s (l+1) (String.length s - l - 1)
@@ -85,10 +85,10 @@ let add_wildcards s =
let rec add_wildcard s =
Scanf.sscanf s " | %s { %_s@} %s"
(fun kw tl ->
- wildcards := Strings.add kw !wildcards;
- if tl <> "" then add_wildcard tl)
+ wildcards := Strings.add kw !wildcards;
+ if tl <> "" then add_wildcard tl)
in
- if s <> "" then
+ if s <> "" then
try
add_wildcard s
with Scanf.Scan_failure _ -> ()
@@ -106,21 +106,21 @@ let () =
end
end
else (* state is Wildcard *)
- if is_other_rule s then state:=Throw
- else add_wildcards s
+ if is_other_rule s then state:=Throw
+ else add_wildcards s
done
with End_of_file -> ()
let whitelist =
- List.fold_right
- Strings.add
+ List.fold_right
+ Strings.add
[ "EOF" ]
Strings.empty
let () =
let diff = Strings.diff (Strings.diff !tokens whitelist) !wildcards in
if not (Strings.is_empty diff) then begin
- prerr_endline
+ prerr_endline
"Some tokens are not captured by wildcard rules. This will cause issue \
if those tokens appear in a contract. Please add the following tokens \
in the appropriate rule:";
diff --git a/src/kernel_internals/parsing/errorloc.ml b/src/kernel_internals/parsing/errorloc.ml
index c86c90d612ac304fa9e99da7332fc533e5da9009..88146c24dd0f258bb7c2806430b3e843925ba50c 100644
--- a/src/kernel_internals/parsing/errorloc.ml
+++ b/src/kernel_internals/parsing/errorloc.ml
@@ -63,7 +63,7 @@ let startParsing fname =
if !current != dummyinfo then begin
Kernel.fatal
"[Errorloc.startParsing] supports only one open file: \
-You want to open %S and %S is still open"
+ You want to open %S and %S is still open"
fname (Lexing.lexeme_start_p !current.lexbuf).Lexing.pos_fname
end;
let inchan =
@@ -238,11 +238,11 @@ let parse_error ?(source=Cil_datatype.Position.of_lexing_pos (Lexing.lexeme_star
Pretty_utils.ksfprintf (fun str ->
Kernel.feedback ~source:start_pos "%s:@." str
~append:(fun fmt ->
- Format.fprintf fmt "%a%a\n"
- pp_location (start_pos, source)
- pretty_token (Lexing.lexeme !current.lexbuf);
- Format.fprintf fmt "%a@."
- (pp_context_from_file ~start_line:start_pos.Filepath.pos_lnum ~ctx:2) source);
+ Format.fprintf fmt "%a%a\n"
+ pp_location (start_pos, source)
+ pretty_token (Lexing.lexeme !current.lexbuf);
+ Format.fprintf fmt "%a@."
+ (pp_context_from_file ~start_line:start_pos.Filepath.pos_lnum ~ctx:2) source);
raise (Log.AbortError "kernel"))
msg
diff --git a/src/kernel_internals/parsing/errorloc.mli b/src/kernel_internals/parsing/errorloc.mli
index 76ceffd5a5afbf1ddd093864553bc0043a885aa0..9cd53021f395d966f92b86fba0ea24ce25610182 100644
--- a/src/kernel_internals/parsing/errorloc.mli
+++ b/src/kernel_internals/parsing/errorloc.mli
@@ -69,7 +69,7 @@ val finishParsing: unit -> unit (** Call this function to finish parsing and
of context before and after. [ctx] defaults to 2.
If [start_line] is specified, then all lines between [start_line] and
[pos.pos_lnum] are considered part of the error.
- *)
+*)
val pp_context_from_file:
?ctx:int -> ?start_line:int -> Format.formatter -> Filepath.position -> unit
diff --git a/src/kernel_internals/parsing/lexerhack.ml b/src/kernel_internals/parsing/lexerhack.ml
index aefd464cce3a0ac14566e89d26566eeef84272b3..8c9fe510a64b2491fb99a1b9116f5b6dbc7ca0e7 100644
--- a/src/kernel_internals/parsing/lexerhack.ml
+++ b/src/kernel_internals/parsing/lexerhack.ml
@@ -41,17 +41,17 @@
(* et Automatique). *)
(****************************************************************************)
-(* We provide here a pointer to a function. It will be set by the lexer and
- * used by the parser. In Ocaml lexers depend on parsers, so we we have put
+(* We provide here a pointer to a function. It will be set by the lexer and
+ * used by the parser. In Ocaml lexers depend on parsers, so we we have put
* such functions in a separate module. *)
-let add_identifier: (string -> unit) ref =
+let add_identifier: (string -> unit) ref =
ref (fun _ -> Kernel.fatal "Uninitialized add_identifier")
-let add_type: (string -> unit) ref =
- ref (fun _ -> Kernel.fatal "Uninitialized add_type")
+let add_type: (string -> unit) ref =
+ ref (fun _ -> Kernel.fatal "Uninitialized add_type")
-let push_context: (unit -> unit) ref =
- ref (fun _ -> Kernel.fatal "Uninitialized push_context")
+let push_context: (unit -> unit) ref =
+ ref (fun _ -> Kernel.fatal "Uninitialized push_context")
-let pop_context: (unit -> unit) ref =
+let pop_context: (unit -> unit) ref =
ref (fun _ -> Kernel.fatal "You called an uninitialized pop_context")
diff --git a/src/kernel_internals/parsing/logic_preprocess.mli b/src/kernel_internals/parsing/logic_preprocess.mli
index 6fbac6da4811d487029b23cd87ae846e02b0d23f..733b1dd9d19ecde54b003abb8edb3bbfac9c08ce 100644
--- a/src/kernel_internals/parsing/logic_preprocess.mli
+++ b/src/kernel_internals/parsing/logic_preprocess.mli
@@ -32,7 +32,7 @@
to the name of intermediate files generated for pre-processing annotations
(gcc pre-processing differs between .c and .cxx files)
- @raises Sys_error if the file cannot be opened.
+ @raises Sys_error if the file cannot be opened.
@modifies Oxygen-20120901: added suffix argument
diff --git a/src/kernel_internals/runtime/boot.ml b/src/kernel_internals/runtime/boot.ml
index 51cde96cb178def649b95a13dbfb1536cef1e9c4..800c1d18e13e6e55a801ece2afa85c49cc564585 100644
--- a/src/kernel_internals/runtime/boot.ml
+++ b/src/kernel_internals/runtime/boot.ml
@@ -74,7 +74,7 @@ let () =
~at_normal_exit:Cmdline.run_normal_exit_hook
~on_error:Cmdline.run_error_exit_hook;
-(* Implicit exit 0 if we haven't exited yet *)
+ (* Implicit exit 0 if we haven't exited yet *)
(*
Local Variables:
diff --git a/src/kernel_internals/runtime/machdeps.ml b/src/kernel_internals/runtime/machdeps.ml
index e0600a7d1a86c11d91df32dc7b6a85bba75c8e02..4bd90ef6e46128a61959726dfde251f5c7cca3f0 100644
--- a/src/kernel_internals/runtime/machdeps.ml
+++ b/src/kernel_internals/runtime/machdeps.ml
@@ -44,7 +44,7 @@
open Cil_types
let x86_16 = {
- version =
+ version =
"x86 16 bits mode (gcc like compiler) with big or huge memory model";
compiler = "generic";
cpp_arch_flags = ["-m16"];
@@ -72,8 +72,8 @@ let x86_16 = {
alignof_str = 1;
alignof_fun = -1;
alignof_aligned= 8;
- (* I don't know if attribute aligned is supported by any 16bits
- compiler. *)
+ (* I don't know if attribute aligned is supported by any 16bits
+ compiler. *)
char_is_unsigned = false;
const_string_literals = true;
little_endian = true;
diff --git a/src/kernel_internals/typing/allocates.ml b/src/kernel_internals/typing/allocates.ml
index 8eacc4836657838f88673684df5ba8f230c75604..dec3566fe2166838fc785c3911aaa83368fc63fa 100644
--- a/src/kernel_internals/typing/allocates.ml
+++ b/src/kernel_internals/typing/allocates.ml
@@ -28,9 +28,9 @@ let add_allocates_loop stmt =
let _behav = Cil.default_behavior_name in
let all_default _ rca r =
match rca.annot_content with
- | AAllocation (b, alloc) ->
- r && (b <> [] || alloc = FreeAllocAny)
- | _ -> r
+ | AAllocation (b, alloc) ->
+ r && (b <> [] || alloc = FreeAllocAny)
+ | _ -> r
in
let all_default = Annotations.fold_code_annot all_default stmt true in
if all_default then
@@ -47,19 +47,19 @@ let add_allocates_nothing_funspec kf =
~keep_empty:false Emitter.kernel kf ~behavior (FreeAlloc ([], []))
class vis_add_loop_allocates =
-object
- inherit Visitor.frama_c_inplace
+ object
+ inherit Visitor.frama_c_inplace
- method! vstmt s =
- (match s.skind with
- | Loop _ -> add_allocates_loop s;
- | _ -> ()
- );
- Cil.DoChildren
+ method! vstmt s =
+ (match s.skind with
+ | Loop _ -> add_allocates_loop s;
+ | _ -> ()
+ );
+ Cil.DoChildren
- method! vinst _ = Cil.SkipChildren
+ method! vinst _ = Cil.SkipChildren
-end
+ end
let add_allocates_nothing () =
Globals.Functions.iter add_allocates_nothing_funspec;
diff --git a/src/kernel_internals/typing/frontc.mli b/src/kernel_internals/typing/frontc.mli
index efffc819a965eef0bf33af373a4e6f7bc457a952..39a8679d320cf4a821f382b11809190abc220eb7 100644
--- a/src/kernel_internals/typing/frontc.mli
+++ b/src/kernel_internals/typing/frontc.mli
@@ -50,5 +50,5 @@ val setMSVCMode: unit -> unit
val add_syntactic_transformation: (Cabs.file -> Cabs.file) -> unit
(** the main command to parse a file. Return a thunk that can be used to
- convert the AST to CIL. *)
+ convert the AST to CIL. *)
val parse: Datatype.Filepath.t -> (unit -> Cil_types.file*Cabs.file)
diff --git a/src/kernel_internals/typing/infer_annotations.ml b/src/kernel_internals/typing/infer_annotations.ml
index ed8b063a39137b0d02d6ad19b8569be9bfe0f437..2fe91919b97468a14703d68482a841936cc37672 100644
--- a/src/kernel_internals/typing/infer_annotations.ml
+++ b/src/kernel_internals/typing/infer_annotations.ml
@@ -50,14 +50,14 @@ let assigns_from_prototype kf =
let pointer_args =
List.map
(fun vi ->
- let loc = vi.vdecl in
- let t = tvar (cvar_to_lvar vi) in
- let typ = vi.vtype in
- if Cil.isVoidPtrType typ then
- let const = typeHasAttribute "const" (Cil.typeOf_pointed typ) in
- let typ' = if const then Cil.charConstPtrType else Cil.charPtrType in
- (vi.vghost, Logic_utils.mk_cast ~loc typ' t, typ')
- else (vi.vghost, t, typ)
+ let loc = vi.vdecl in
+ let t = tvar (cvar_to_lvar vi) in
+ let typ = vi.vtype in
+ if Cil.isVoidPtrType typ then
+ let const = typeHasAttribute "const" (Cil.typeOf_pointed typ) in
+ let typ' = if const then Cil.charConstPtrType else Cil.charPtrType in
+ (vi.vghost, Logic_utils.mk_cast ~loc typ' t, typ')
+ else (vi.vghost, t, typ)
) pointer_args
in
(* Generate the term [*(t+(0..))] with the appropriate array bounds (if
@@ -77,32 +77,32 @@ let assigns_from_prototype kf =
type *)
let rec mk_offset set typ =
match Cil.unrollType typ with
- | TArray (typ_elem, size, _, _) ->
- let range = match size with
- | None -> make_range None
- | Some size ->
- make_range (Cil.constFoldToInt size)
- in
- let offs, typ = mk_offset true typ_elem in
- TIndex (range, offs), typ
- | _ ->
- TNoOffset,
- (if set then make_set_type (Ctype typ) else (Ctype typ))
+ | TArray (typ_elem, size, _, _) ->
+ let range = match size with
+ | None -> make_range None
+ | Some size ->
+ make_range (Cil.constFoldToInt size)
+ in
+ let offs, typ = mk_offset true typ_elem in
+ TIndex (range, offs), typ
+ | _ ->
+ TNoOffset,
+ (if set then make_set_type (Ctype typ) else (Ctype typ))
in
-(* make_set_type (Ctype typ_pointed) *)
+ (* make_set_type (Ctype typ_pointed) *)
let typ_pointed = Cil.typeOf_pointed typ in
(* Generate the initial term: [*(t+(0..))] for array types or char*
pointers, *t for other pointer types. It would have been better to
recognize formals with type [typ[]] instead of [typ *], but this
information is lost during normalization *)
- let t_range_node, set =
+ let t_range_node, set =
match findAttribute "arraylen" (typeAttr typ) with
- | [AInt length] -> TBinOp (PlusPI, t, make_range (Some length)), true
- | _ ->
- if Cil.isAnyCharPtrType typ
- then TBinOp (PlusPI, t, make_range None), true
- else t.term_node, false
+ | [AInt length] -> TBinOp (PlusPI, t, make_range (Some length)), true
+ | _ ->
+ if Cil.isAnyCharPtrType typ
+ then TBinOp (PlusPI, t, make_range None), true
+ else t.term_node, false
in
let offset_arrays, typ_with_offset = mk_offset true typ_pointed in
let t_range =
@@ -152,7 +152,7 @@ let assigns_from_prototype kf =
| TVoid _ ->
(* assigns all pointer args from basic args and content of pointer args *)
arguments
- | _ ->
+ | _ ->
(* assigns result from basic args and content of pointer args *)
let loc = vi.vdecl in
let result = Logic_const.(new_identified_term (tresult ~loc rtyp)) in
@@ -171,17 +171,17 @@ let emit_unknown_status_on_assigns kf bhv assigns =
in
Option.iter emit pptopt;
match assigns with
- | WritesAny -> ()
- | Writes froms ->
- let emit from =
- let pptopt =
- Property.ip_of_from
- kf Kglobal
- (Property.Id_contract (Datatype.String.Set.empty,bhv)) from
- in
- Option.iter emit pptopt
- in
- List.iter emit froms
+ | WritesAny -> ()
+ | Writes froms ->
+ let emit from =
+ let pptopt =
+ Property.ip_of_from
+ kf Kglobal
+ (Property.Id_contract (Datatype.String.Set.empty,bhv)) from
+ in
+ Option.iter emit pptopt
+ in
+ List.iter emit froms
module Is_populated =
State_builder.Hashtbl
@@ -191,19 +191,19 @@ module Is_populated =
let size = 17
let dependencies = [ Annotations.funspec_state ]
let name = "Infer_annotations.Is_populated"
- end)
+ end)
let () = Ast.add_linked_state Is_populated.self
let populate_funspec_aux kf spec =
let name = Kernel_function.get_name kf in
match spec.spec_behavior with
- | [] ->
+ | [] ->
(* case 1: there is no initial specification -> use generated_behavior *)
if not (is_frama_c_builtin name) then begin
Kernel.warning ~once:true ~current:true ~wkey:Kernel.wkey_missing_spec
"Neither code nor specification for function %a, \
-generating default assigns from the prototype"
+ generating default assigns from the prototype"
Kernel_function.pretty kf;
end;
let assigns = Writes (assigns_from_prototype kf) in
@@ -211,7 +211,7 @@ generating default assigns from the prototype"
Annotations.add_behaviors emitter kf [ bhv ];
emit_unknown_status_on_assigns kf bhv assigns
- | _ :: _ ->
+ | _ :: _ ->
(* case 2: there is a specification, so look at assigns clause *)
let bhv = match Cil.find_default_behavior spec with
| None -> Cil.mk_behavior ()
@@ -220,47 +220,47 @@ generating default assigns from the prototype"
if bhv.b_assigns = WritesAny then
(* case 2.2 : some assigns have to be generated *)
(* step 2.1: looks at unguarded behaviors and then at complete
- behaviors *)
+ behaviors *)
let warn_if_not_builtin explicit_name name orig_name =
- if not (is_frama_c_builtin name) then
- Kernel.warning ~once:true ~current:true
- "No code nor %s assigns clause for function %a, \
-generating default assigns from the %s"
- explicit_name Kernel_function.pretty kf orig_name
+ if not (is_frama_c_builtin name) then
+ Kernel.warning ~once:true ~current:true
+ "No code nor %s assigns clause for function %a, \
+ generating default assigns from the %s"
+ explicit_name Kernel_function.pretty kf orig_name
in
let assigns = Ast_info.merge_assigns_from_spec ~warn:false spec in
- let assigns =
- if assigns <> WritesAny then begin
- (* case 2.2.1. A correct assigns clause has been found *)
- warn_if_not_builtin "explicit" name "specification";
- assigns
- end else begin
- (* case 2.2.1. No correct assigns clause can be found *)
- let assigns =
- try (* Takes the union the assigns clauses, even if it
- is not advertised as complete behaviors.
- Not more arbitrary than using prototype to infer
- assigns.*)
- List.fold_left
- (fun acc bhv ->
- if Cil.is_default_behavior bhv then acc
- else match acc, bhv.b_assigns with
- | _, WritesAny -> raise Not_found
- | WritesAny, a -> a
- | Writes l1, Writes l2 -> Writes (l1 @ l2))
- WritesAny
- spec.spec_behavior
- with Not_found ->
- WritesAny
- in
- if assigns <> WritesAny then begin
- warn_if_not_builtin "implicit" name "specification" ;
- assigns
- end else begin (* The union gave WritesAny, so use the prototype *)
- warn_if_not_builtin "implicit" name "prototype";
+ let assigns =
+ if assigns <> WritesAny then begin
+ (* case 2.2.1. A correct assigns clause has been found *)
+ warn_if_not_builtin "explicit" name "specification";
+ assigns
+ end else begin
+ (* case 2.2.1. No correct assigns clause can be found *)
+ let assigns =
+ try (* Takes the union the assigns clauses, even if it
+ is not advertised as complete behaviors.
+ Not more arbitrary than using prototype to infer
+ assigns.*)
+ List.fold_left
+ (fun acc bhv ->
+ if Cil.is_default_behavior bhv then acc
+ else match acc, bhv.b_assigns with
+ | _, WritesAny -> raise Not_found
+ | WritesAny, a -> a
+ | Writes l1, Writes l2 -> Writes (l1 @ l2))
+ WritesAny
+ spec.spec_behavior
+ with Not_found ->
+ WritesAny
+ in
+ if assigns <> WritesAny then begin
+ warn_if_not_builtin "implicit" name "specification" ;
+ assigns
+ end else begin (* The union gave WritesAny, so use the prototype *)
+ warn_if_not_builtin "implicit" name "prototype";
Writes (assigns_from_prototype kf);
- end
- end
+ end
+ end
in
Annotations.add_assigns
~keep_empty:false emitter kf ~behavior:bhv.b_name assigns;
diff --git a/src/kernel_internals/typing/mergecil.mli b/src/kernel_internals/typing/mergecil.mli
index 04fdd93a827cde28be585647b04d3dce0a0fcc33..ccde88f5c4e1f8c6c8d9310c0ab0b057a02a9be6 100644
--- a/src/kernel_internals/typing/mergecil.mli
+++ b/src/kernel_internals/typing/mergecil.mli
@@ -43,12 +43,12 @@
(*
*
- * Copyright (c) 2001-2002,
+ * Copyright (c) 2001-2002,
* George C. Necula <necula@cs.berkeley.edu>
* Scott McPeak <smcpeak@cs.berkeley.edu>
* Wes Weimer <weimer@cs.berkeley.edu>
* All rights reserved.
- *
+ *
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are
* met:
@@ -85,4 +85,3 @@ val merge: Cil_types.file list -> string -> Cil_types.file
val translate_vinfo : Cil_types.varinfo -> Cil_types.varinfo
val translate_typinfo :Cil_types.typeinfo -> Cil_types.typeinfo
*)
-
diff --git a/src/kernel_internals/typing/translate_lightweight.ml b/src/kernel_internals/typing/translate_lightweight.ml
index 87ec8e5ac33969b260b21acc933182a7bed7d75f..b7c874412b5247262442ecde9c60ea8cf5810487 100644
--- a/src/kernel_internals/typing/translate_lightweight.ml
+++ b/src/kernel_internals/typing/translate_lightweight.ml
@@ -39,22 +39,22 @@ class annotateFunFromDeclspec =
let recover_from_attr_param params attrparam =
let rec aux = function
| AInt i ->
- Ast_info.constant_term
- Cil_datatype.Location.unknown i
+ Ast_info.constant_term
+ Cil_datatype.Location.unknown i
| AUnOp(Neg,AInt i) ->
Ast_info.constant_term
- Cil_datatype.Location.unknown (Integer.neg i)
+ Cil_datatype.Location.unknown (Integer.neg i)
| AStr s
| ACons(s,[]) ->
begin try
- let v = List.find (fun v -> v.vname = s) params in
- term_of_var v
+ let v = List.find (fun v -> v.vname = s) params in
+ term_of_var v
with Not_found -> raise No_recovery end
| ABinOp(bop,attr1,attr2) ->
mkterm
- (TBinOp(bop,aux attr1,aux attr2))
- Linteger
- Cil_datatype.Location.unknown
+ (TBinOp(bop,aux attr1,aux attr2))
+ Linteger
+ Cil_datatype.Location.unknown
| ACons _
| ASizeOf _
| ASizeOfE _
@@ -84,49 +84,49 @@ class annotateFunFromDeclspec =
let annotate_var params acc v =
List.fold_left
(fun acc attr ->
- match recover_from_attribute params attr with
- | None -> acc
- | Some(name,args) ->
- if name = "valid" || name = "valid_range" then
- let t1 = term_of_var v in
- let t1 = Logic_utils.mk_logic_pointer_or_StartOf t1 in
- let p = match name with
- | "valid" ->
- assert (args = []);
- Logic_const.pvalid (Logic_const.here_label,t1)
- | "valid_range" ->
- let args = match args with
- | [ b1; b2 ] -> (Logic_const.here_label,t1,b1,b2)
- | _ -> assert false
- in Logic_const.pvalid_range args
- | _ -> assert false
- in
- let app =
- Logic_const.new_predicate p
- in
- app :: acc
- else
- try
- let p =
- match Logic_env.find_all_logic_functions name with
- | [i] -> i
- | _ -> raise Not_found
- in
- assert (List.length p.l_profile = List.length(args) + 1);
- assert (List.length p.l_labels <= 1);
- let labels =
- match p.l_labels with
- | [] -> []
- | [_] -> [ Logic_const.here_label ]
- | _ -> assert false
- in
- let args = term_of_var v :: args in
- let app =
- Logic_const.new_predicate
- (Logic_const.unamed (Papp(p,labels,args)))
- in
- app :: acc
- with Not_found -> acc
+ match recover_from_attribute params attr with
+ | None -> acc
+ | Some(name,args) ->
+ if name = "valid" || name = "valid_range" then
+ let t1 = term_of_var v in
+ let t1 = Logic_utils.mk_logic_pointer_or_StartOf t1 in
+ let p = match name with
+ | "valid" ->
+ assert (args = []);
+ Logic_const.pvalid (Logic_const.here_label,t1)
+ | "valid_range" ->
+ let args = match args with
+ | [ b1; b2 ] -> (Logic_const.here_label,t1,b1,b2)
+ | _ -> assert false
+ in Logic_const.pvalid_range args
+ | _ -> assert false
+ in
+ let app =
+ Logic_const.new_predicate p
+ in
+ app :: acc
+ else
+ try
+ let p =
+ match Logic_env.find_all_logic_functions name with
+ | [i] -> i
+ | _ -> raise Not_found
+ in
+ assert (List.length p.l_profile = List.length(args) + 1);
+ assert (List.length p.l_labels <= 1);
+ let labels =
+ match p.l_labels with
+ | [] -> []
+ | [_] -> [ Logic_const.here_label ]
+ | _ -> assert false
+ in
+ let args = term_of_var v :: args in
+ let app =
+ Logic_const.new_predicate
+ (Logic_const.unamed (Papp(p,labels,args)))
+ in
+ app :: acc
+ with Not_found -> acc
) acc (typeAttrs v.vtype)
in
@@ -143,74 +143,74 @@ class annotateFunFromDeclspec =
let insert_spec behavior =
let ens =
List.fold_left
- (fun acc attr ->
- match recover_from_attribute params attr with
- | None -> acc
- | Some(name,args) ->
- if name = "valid" || name = "valid_range" then
- let t1 = Logic_const.tresult ~loc return_ty in
- let t1 = Logic_utils.mk_logic_pointer_or_StartOf t1 in
- let p = match name with
- | "valid" ->
- assert (args = []);
- Logic_const.pvalid (Logic_const.here_label,t1)
- | "valid_range" ->
- let args = match args with
- | [ b1; b2 ] -> (Logic_const.here_label,t1,b1,b2)
- | _ -> assert false
- in
- Logic_const.pvalid_range args
- | _ -> assert false
- in
- let app =
- Logic_const.new_predicate p
- in
- (Normal, app) :: acc
- else
- try
- let p =
- match Logic_env.find_all_logic_functions name with
- | [i] -> i
- | _ -> assert false
- in
- assert (List.length p.l_profile = List.length args + 1);
- assert (List.length p.l_labels <= 1);
- let res = Logic_const.tresult ~loc return_ty in
- let args = res :: args in
- let app =
- Logic_const.new_predicate
- (Logic_const.unamed (Papp(p,[],args)))
- in
- (Normal,app) :: acc
- with Not_found -> acc)
- behavior.b_post_cond
- (typeAttrs return_ty)
+ (fun acc attr ->
+ match recover_from_attribute params attr with
+ | None -> acc
+ | Some(name,args) ->
+ if name = "valid" || name = "valid_range" then
+ let t1 = Logic_const.tresult ~loc return_ty in
+ let t1 = Logic_utils.mk_logic_pointer_or_StartOf t1 in
+ let p = match name with
+ | "valid" ->
+ assert (args = []);
+ Logic_const.pvalid (Logic_const.here_label,t1)
+ | "valid_range" ->
+ let args = match args with
+ | [ b1; b2 ] -> (Logic_const.here_label,t1,b1,b2)
+ | _ -> assert false
+ in
+ Logic_const.pvalid_range args
+ | _ -> assert false
+ in
+ let app =
+ Logic_const.new_predicate p
+ in
+ (Normal, app) :: acc
+ else
+ try
+ let p =
+ match Logic_env.find_all_logic_functions name with
+ | [i] -> i
+ | _ -> assert false
+ in
+ assert (List.length p.l_profile = List.length args + 1);
+ assert (List.length p.l_labels <= 1);
+ let res = Logic_const.tresult ~loc return_ty in
+ let args = res :: args in
+ let app =
+ Logic_const.new_predicate
+ (Logic_const.unamed (Papp(p,[],args)))
+ in
+ (Normal,app) :: acc
+ with Not_found -> acc)
+ behavior.b_post_cond
+ (typeAttrs return_ty)
+ in
+ let ppt_ensures b =
+ Property.ip_ensures_of_behavior kf Kglobal b
in
- let ppt_ensures b =
- Property.ip_ensures_of_behavior kf Kglobal b
- in
- List.iter Property_status.remove (ppt_ensures behavior);
+ List.iter Property_status.remove (ppt_ensures behavior);
behavior.b_post_cond <- ens;
- List.iter Property_status.register (ppt_ensures behavior);
+ List.iter Property_status.register (ppt_ensures behavior);
in
let spec = Annotations.funspec ~populate:false kf in
List.iter insert_spec spec.spec_behavior
in
-object
- inherit Visitor.frama_c_inplace
+ object
+ inherit Visitor.frama_c_inplace
- method! vglob_aux = function
- | GFun(f,_) ->
- annotate_fun f.svar;
- SkipChildren
- | GFunDecl(_,v,_) ->
- if not v.vdefined then annotate_fun v;
- SkipChildren
- | GAnnot _ -> DoChildren
- | GCompTag _ | GType _ | GCompTagDecl _ | GEnumTagDecl _
- | GEnumTag _ | GAsm _ | GPragma _ | GText _ | GVar _ | GVarDecl _ ->
- SkipChildren
-end
+ method! vglob_aux = function
+ | GFun(f,_) ->
+ annotate_fun f.svar;
+ SkipChildren
+ | GFunDecl(_,v,_) ->
+ if not v.vdefined then annotate_fun v;
+ SkipChildren
+ | GAnnot _ -> DoChildren
+ | GCompTag _ | GType _ | GCompTagDecl _ | GEnumTagDecl _
+ | GEnumTag _ | GAsm _ | GPragma _ | GText _ | GVar _ | GVarDecl _ ->
+ SkipChildren
+ end
let interpret file =
let visitor = new annotateFunFromDeclspec in
diff --git a/src/kernel_internals/typing/translate_lightweight.mli b/src/kernel_internals/typing/translate_lightweight.mli
index c8c10c22efce2f3304141c4ca33d3040dea1eb69..ce9cbcb584c1190f71959e86cafe1320c3d322e1 100644
--- a/src/kernel_internals/typing/translate_lightweight.mli
+++ b/src/kernel_internals/typing/translate_lightweight.mli
@@ -24,7 +24,7 @@
(** Annotate files interpreting lightweight annotations. *)
-(** Code transformation that interprets __declspec annotations.
+(** Code transformation that interprets __declspec annotations.
Done after cleanup (see {! File.add_code_transformation_after_cleanup}).
Name of the transformation is "lightweight spec"
*)
diff --git a/src/kernel_internals/typing/unroll_loops.ml b/src/kernel_internals/typing/unroll_loops.ml
index cecd0aefe59e5453d5afca8d698d7ffa062fbd24..c60b1bb3b5a46aa9c4d125df8c79cf05d8de77db 100644
--- a/src/kernel_internals/typing/unroll_loops.ml
+++ b/src/kernel_internals/typing/unroll_loops.ml
@@ -38,53 +38,53 @@ let empty_info =
let update_info global_find_init emitter info spec =
match spec with
- | {term_type=typ} when Logic_typing.is_integral_type typ ->
- if Option.is_some info.unroll_number && not info.ignore_unroll then begin
- Kernel.warning ~once:true ~current:true
- "ignoring unrolling directive (directive already defined)";
- info
- end else begin
- try
- begin
- let t = Cil.visitCilTerm
- (new Logic_utils.simplify_const_lval global_find_init) spec
- in
- let i = Logic_utils.constFoldTermToInt t in
- match i with
- | Some i -> { info with unroll_number = Some (Integer.to_int i) }
- | None ->
- Kernel.warning ~once:true ~current:true
- "ignoring unrolling directive (not an understood constant \
- expression)";
- info
- end
- with Invalid_argument s ->
- Kernel.warning ~once:true ~current:true
- "ignoring unrolling directive (%s)" s;
- info
- end
- | {term_node=TConst (LStr "done") } -> { info with ignore_unroll = true }
- | {term_node=TConst (LStr "completely") } ->
- if Option.is_some info.total_unroll then begin
+ | {term_type=typ} when Logic_typing.is_integral_type typ ->
+ if Option.is_some info.unroll_number && not info.ignore_unroll then begin
+ Kernel.warning ~once:true ~current:true
+ "ignoring unrolling directive (directive already defined)";
+ info
+ end else begin
+ try
+ begin
+ let t = Cil.visitCilTerm
+ (new Logic_utils.simplify_const_lval global_find_init) spec
+ in
+ let i = Logic_utils.constFoldTermToInt t in
+ match i with
+ | Some i -> { info with unroll_number = Some (Integer.to_int i) }
+ | None ->
+ Kernel.warning ~once:true ~current:true
+ "ignoring unrolling directive (not an understood constant \
+ expression)";
+ info
+ end
+ with Invalid_argument s ->
Kernel.warning ~once:true ~current:true
- "found two total unroll pragmas";
+ "ignoring unrolling directive (%s)" s;
info
- end else { info with total_unroll = Some emitter }
- | _ ->
- Kernel.warning ~once:true ~current:true
- "ignoring invalid unrolling directive";
+ end
+ | {term_node=TConst (LStr "done") } -> { info with ignore_unroll = true }
+ | {term_node=TConst (LStr "completely") } ->
+ if Option.is_some info.total_unroll then begin
+ Kernel.warning ~once:true ~current:true
+ "found two total unroll pragmas";
info
+ end else { info with total_unroll = Some emitter }
+ | _ ->
+ Kernel.warning ~once:true ~current:true
+ "ignoring invalid unrolling directive";
+ info
let extract_from_pragmas global_find_init s =
let filter _ a = Logic_utils.is_loop_pragma a in
let pragmas = Annotations.code_annot_emitter ~filter s in
let get_infos info (a,e) =
match a.annot_content with
- | APragma (Loop_pragma (Unroll_specs specs)) ->
- List.fold_left (update_info global_find_init e) info specs
- | APragma (Loop_pragma _) -> info
- | _ -> assert false (* should have been filtered above. *)
- in
+ | APragma (Loop_pragma (Unroll_specs specs)) ->
+ List.fold_left (update_info global_find_init e) info specs
+ | APragma (Loop_pragma _) -> info
+ | _ -> assert false (* should have been filtered above. *)
+ in
List.fold_left get_infos empty_info pragmas
let fresh_label =
@@ -94,12 +94,12 @@ let fresh_label =
let loc, orig = match loc with
| None -> CurrentLoc.get (), false
| Some loc -> loc, true
- and new_label_name =
+ and new_label_name =
let prefix = match label_name with None -> "" | Some s -> s ^ "_"
in Format.sprintf "%sunrolling_%d_loop" prefix (- !counter)
in Label (new_label_name,
- loc,
- orig)
+ loc,
+ orig)
let copy_var =
let counter = ref (-1) in
@@ -107,7 +107,7 @@ let copy_var =
the counter at each variable's copy: copy_var () is called once per
copy of block with local variables, bearing no relationship with the
number of unrolling. counter could thus be an arbitrary integer as well.
- *)
+ *)
fun () ->
decr counter;
fun vi ->
@@ -140,24 +140,24 @@ let refresh_vars old_var new_var =
(* Takes care of local gotos and labels into C. *)
let update_gotos sid_tbl block =
let goto_updater =
- object
- inherit nopCilVisitor
- method! vstmt s = match s.skind with
- | Goto(sref,_loc) ->
+ object
+ inherit nopCilVisitor
+ method! vstmt s = match s.skind with
+ | Goto(sref,_loc) ->
(try (* A deep copy has already be done. Just modifies the reference in place. *)
let new_stmt = Cil_datatype.Stmt.Map.find !sref sid_tbl in
- sref := new_stmt
+ sref := new_stmt
with Not_found -> ()) ;
- DoChildren
- | _ -> DoChildren
- (* speed up: skip non interesting subtrees *)
- method! vvdec _ = SkipChildren (* via visitCilFunction *)
- method! vspec _ = SkipChildren (* via visitCilFunction *)
- method! vcode_annot _ = SkipChildren (* via Code_annot stmt *)
- method! vexpr _ = SkipChildren (* via stmt such as Return, IF, ... *)
- method! vlval _ = SkipChildren (* via stmt such as Set, Call, Asm, ... *)
- method! vattr _ = SkipChildren (* via Asm stmt *)
- end
+ DoChildren
+ | _ -> DoChildren
+ (* speed up: skip non interesting subtrees *)
+ method! vvdec _ = SkipChildren (* via visitCilFunction *)
+ method! vspec _ = SkipChildren (* via visitCilFunction *)
+ method! vcode_annot _ = SkipChildren (* via Code_annot stmt *)
+ method! vexpr _ = SkipChildren (* via stmt such as Return, IF, ... *)
+ method! vlval _ = SkipChildren (* via stmt such as Set, Call, Asm, ... *)
+ method! vattr _ = SkipChildren (* via Asm stmt *)
+ end
in visitCilBlock (goto_updater:>cilVisitor) block
let is_referenced stmt l =
@@ -166,8 +166,8 @@ let is_referenced stmt l =
inherit Visitor.frama_c_inplace
method! vlogic_label l =
match l with
- | StmtLabel s when !s == stmt -> raise Found.Found
- | _ -> DoChildren
+ | StmtLabel s when !s == stmt -> raise Found.Found
+ | _ -> DoChildren
end
in
try
@@ -181,64 +181,64 @@ let copy_annotations kf assoc labelled_stmt_tbl (break_continue_must_change, stm
let visitor = object
inherit Visitor.frama_c_copy (Project.current())
method! vlogic_var_use vi =
- match vi.lv_origin with
- None -> SkipChildren
- | Some vi ->
- begin
- try
- let vi'= snd (List.find (fun (x,_) -> x.vid = vi.vid) assoc) in
- ChangeTo (Option.get vi'.vlogic_var_assoc)
- with Not_found -> SkipChildren
- | Invalid_argument _ ->
- Kernel.abort
- "Loop unrolling: cannot find new representative for \
- local var %s"
- vi.vname
- end
+ match vi.lv_origin with
+ None -> SkipChildren
+ | Some vi ->
+ begin
+ try
+ let vi'= snd (List.find (fun (x,_) -> x.vid = vi.vid) assoc) in
+ ChangeTo (Option.get vi'.vlogic_var_assoc)
+ with Not_found -> SkipChildren
+ | Invalid_argument _ ->
+ Kernel.abort
+ "Loop unrolling: cannot find new representative for \
+ local var %s"
+ vi.vname
+ end
method! vlogic_label (label:logic_label) =
- match label with
- | StmtLabel (stmt) ->
- (try (* A deep copy has already been done.
- Just modifies the reference in place. *)
- let new_stmt = Cil_datatype.Stmt.Map.find !stmt labelled_stmt_tbl
- in ChangeTo (StmtLabel (ref new_stmt))
- with Not_found -> SkipChildren) ;
- | BuiltinLabel _ | FormalLabel _ -> SkipChildren
+ match label with
+ | StmtLabel (stmt) ->
+ (try (* A deep copy has already been done.
+ Just modifies the reference in place. *)
+ let new_stmt = Cil_datatype.Stmt.Map.find !stmt labelled_stmt_tbl
+ in ChangeTo (StmtLabel (ref new_stmt))
+ with Not_found -> SkipChildren) ;
+ | BuiltinLabel _ | FormalLabel _ -> SkipChildren
end
- in visitCilCodeAnnotation (visitor:>cilVisitor) (Logic_const.refresh_code_annotation a)
+ in visitCilCodeAnnotation (visitor:>cilVisitor) (Logic_const.refresh_code_annotation a)
in
let filter_annotation a = (* Special cases for some "breaks" and "continues" clauses. *)
- (* Note: it would be preferable to do that job in the visitor of 'fresh_annotation'... *)
+ (* Note: it would be preferable to do that job in the visitor of 'fresh_annotation'... *)
Kernel.debug ~dkey
"Copying an annotation to stmt %d from stmt %d@."
stmt_dst.sid stmt_src.sid;
(* TODO: transforms 'breaks' and 'continues' clauses into unimplemented
'gotos' clause (still undefined clause into ACSL!). *)
(* WORKS AROUND: since 'breaks' and 'continues' clauses have not be preserved
- into the unrolled stmts, and are not yet transformed into 'gotos' (see. TODO),
+ into the unrolled stmts, and are not yet transformed into 'gotos' (see. TODO),
they are not copied. *)
match break_continue_must_change, a with
| (None, None), _ -> Some a (* 'breaks' and 'continues' can be kept *)
- | _, { annot_content=AStmtSpec (s,spec) } ->
+ | _, { annot_content=AStmtSpec (s,spec) } ->
let filter_post_cond = function
- | Breaks, _ when (fst break_continue_must_change) != None ->
- Kernel.debug ~dkey "Uncopied 'breaks' clause to stmt %d@." stmt_dst.sid;
- false
- | Continues, _ when (snd break_continue_must_change) != None ->
- Kernel.debug ~dkey "Uncopied 'continues' clause to stmt %d@." stmt_dst.sid;
- false
- | _ -> true in
- let filter_behavior acc bhv =
- let bhv = { bhv with b_post_cond = List.filter filter_post_cond bhv.b_post_cond } in
- (* The default behavior cannot be removed if another behavior remains... *)
- if (Cil.is_empty_behavior bhv) && not (Cil.is_default_behavior bhv) then acc
- else bhv::acc
+ | Breaks, _ when (fst break_continue_must_change) != None ->
+ Kernel.debug ~dkey "Uncopied 'breaks' clause to stmt %d@." stmt_dst.sid;
+ false
+ | Continues, _ when (snd break_continue_must_change) != None ->
+ Kernel.debug ~dkey "Uncopied 'continues' clause to stmt %d@." stmt_dst.sid;
+ false
+ | _ -> true in
+ let filter_behavior acc bhv =
+ let bhv = { bhv with b_post_cond = List.filter filter_post_cond bhv.b_post_cond } in
+ (* The default behavior cannot be removed if another behavior remains... *)
+ if (Cil.is_empty_behavior bhv) && not (Cil.is_default_behavior bhv) then acc
+ else bhv::acc
in
- let filter_behaviors bhvs =
- (*... so the default behavior is removed there if it is alone. *)
- match List.fold_left filter_behavior [] bhvs with
- | [bhv] when Cil.is_empty_behavior bhv -> []
- | bhvs -> List.rev bhvs
+ let filter_behaviors bhvs =
+ (*... so the default behavior is removed there if it is alone. *)
+ match List.fold_left filter_behavior [] bhvs with
+ | [bhv] when Cil.is_empty_behavior bhv -> []
+ | bhvs -> List.rev bhvs
in
let spec = { spec with spec_behavior = filter_behaviors spec.spec_behavior } in
if Cil.is_empty_funspec spec then None (* No statement contract will be added *)
@@ -249,13 +249,13 @@ let copy_annotations kf assoc labelled_stmt_tbl (break_continue_must_change, stm
Annotations.fold_code_annot
(fun emitter annot acc ->
match filter_annotation annot with
- | None -> acc
- | Some filtred_annot -> (emitter, fresh_annotation filtred_annot) :: acc)
+ | None -> acc
+ | Some filtred_annot -> (emitter, fresh_annotation filtred_annot) :: acc)
stmt_src
[]
in
- List.iter
- (fun (e, a) -> Annotations.add_code_annot e ~kf stmt_dst a)
+ List.iter
+ (fun (e, a) -> Annotations.add_code_annot e ~kf stmt_dst a)
new_annots
let update_loop_current kf loop_current block =
@@ -268,8 +268,8 @@ let update_loop_current kf loop_current block =
| BuiltinLabel _ | FormalLabel _ | StmtLabel _ -> DoChildren
method! vstmt_aux s =
match s.skind with
- | Loop _ -> SkipChildren (* loop init and current are not the same here. *)
- | _ -> DoChildren
+ | Loop _ -> SkipChildren (* loop init and current are not the same here. *)
+ | _ -> DoChildren
end in
ignore (Visitor.visitFramacBlock vis block)
@@ -283,8 +283,8 @@ let update_loop_entry kf loop_entry stmt =
| BuiltinLabel _ | FormalLabel _ | StmtLabel _ -> DoChildren
method! vstmt_aux s =
match s.skind with
- | Loop _ -> SkipChildren (* loop init and current are not the same here. *)
- | _ -> DoChildren
+ | Loop _ -> SkipChildren (* loop init and current are not the same here. *)
+ | _ -> DoChildren
end in
ignore (Visitor.visitFramacStmt vis stmt)
@@ -307,21 +307,21 @@ let is_case_stmt s = List.exists Cil.is_case_label s.labels
let copy_block kf switch_label_action break_continue_must_change bl =
let new_switch_cases = ref [] in
let assoc = ref [] in
- let fundec =
+ let fundec =
try Kernel_function.get_definition kf
with Kernel_function.No_Definition -> assert false
- and annotated_stmts = ref [] (* for copying the annotations later. *)
+ and annotated_stmts = ref [] (* for copying the annotations later. *)
and labelled_stmt_tbl = Cil_datatype.Stmt.Map.empty
and calls_tbl = Cil_datatype.Stmt.Map.empty
in
let rec copy_stmt switch_label_action break_continue_must_change
labelled_stmt_tbl calls_tbl stmt =
let result =
- { labels = [];
+ { labels = [];
sid = Cil_const.Sid.next ();
- succs = [];
- preds = [];
- skind = stmt.skind;
+ succs = [];
+ preds = [];
+ skind = stmt.skind;
ghost = stmt.ghost;
sattr = []}
in
@@ -333,18 +333,18 @@ let copy_block kf switch_label_action break_continue_must_change bl =
and new_labels =
List.fold_left
(fun new_lbls -> function
- | Label (s, loc, gen) ->
- (if gen
- then fresh_label ~label_name:s ()
- else fresh_label ~label_name:s ~loc ()
- ) :: new_lbls
- | Case _ | Default _ as lbl ->
- if switch_label_action = Ignore
- then new_lbls
- else lbl :: new_lbls
+ | Label (s, loc, gen) ->
+ (if gen
+ then fresh_label ~label_name:s ()
+ else fresh_label ~label_name:s ~loc ()
+ ) :: new_lbls
+ | Case _ | Default _ as lbl ->
+ if switch_label_action = Ignore
+ then new_lbls
+ else lbl :: new_lbls
)
- []
- stmt.labels
+ []
+ stmt.labels
in
let () =
if switch_label_action = Move && is_case_stmt stmt then
@@ -368,12 +368,12 @@ let copy_block kf switch_label_action break_continue_must_change bl =
break_continue_must_change labelled_stmt_tbl new_calls_tbl stmt.skind
in
result.skind <- new_stmkind;
- if Annotations.has_code_annot stmt then
+ if Annotations.has_code_annot stmt then
begin
- Kernel.debug ~dkey
+ Kernel.debug ~dkey
"Found an annotation to copy for stmt %d from stmt %d@."
result.sid stmt.sid;
- annotated_stmts := (break_continue_must_change, stmt,result) :: !annotated_stmts;
+ annotated_stmts := (break_continue_must_change, stmt,result) :: !annotated_stmts;
end;
result, new_labelled_stmt_tbl, new_calls_tbl
@@ -385,137 +385,137 @@ let copy_block kf switch_label_action break_continue_must_change bl =
?(break_continue_must_change = break_continue_must_change) =
copy_block ~switch_label_action ~break_continue_must_change
in
- match stkind with
- | (Instr _ | Return _ | Throw _) as keep ->
- keep,labelled_stmt_tbl,calls_tbl
- | Goto (stmt_ref, loc) -> Goto (ref !stmt_ref, loc),labelled_stmt_tbl,calls_tbl
- | If (exp,bl1,bl2,loc) ->
- CurrentLoc.set loc;
- let new_block1,labelled_stmt_tbl,calls_tbl =
- copy_block labelled_stmt_tbl calls_tbl bl1
- in
- let new_block2,labelled_stmt_tbl,calls_tbl =
- copy_block labelled_stmt_tbl calls_tbl bl2
- in
- If(exp,new_block1,new_block2,loc),labelled_stmt_tbl,calls_tbl
- | Loop (a,bl,loc,_,_) ->
- CurrentLoc.set loc;
- let new_block,labelled_stmt_tbl,calls_tbl =
- copy_block
- (* from now on break and continue can be kept *)
- ~break_continue_must_change:(None, None)
- labelled_stmt_tbl
- calls_tbl
- bl
- in
- Loop (a,new_block,loc,None,None),labelled_stmt_tbl,calls_tbl
- | Block bl ->
- let new_block,labelled_stmt_tbl,calls_tbl =
- copy_block labelled_stmt_tbl calls_tbl bl
- in
- Block (new_block),labelled_stmt_tbl,calls_tbl
- | UnspecifiedSequence seq ->
- let change_calls lst calls_tbl =
- List.map
- (fun x -> ref (Cil_datatype.Stmt.Map.find !x calls_tbl)) lst
- in
- let new_seq,labelled_stmt_tbl,calls_tbl =
- List.fold_left
- (fun (seq,labelled_stmt_tbl,calls_tbl) (stmt,modified,writes,reads,calls) ->
- let stmt,labelled_stmt_tbl,calls_tbl =
- copy_stmt switch_label_action break_continue_must_change
- labelled_stmt_tbl calls_tbl stmt
- in
- (stmt,modified,writes,reads,change_calls calls calls_tbl)::seq,
- labelled_stmt_tbl,calls_tbl)
- ([],labelled_stmt_tbl,calls_tbl)
- seq
- in
- UnspecifiedSequence (List.rev new_seq),labelled_stmt_tbl,calls_tbl
- | Break loc ->
- (match break_continue_must_change with
- | None, _ -> stkind (* kept *)
- | (Some (brk_lbl_stmt)), _ -> Goto ((ref brk_lbl_stmt),loc)),
- labelled_stmt_tbl,
- calls_tbl
- | Continue loc ->
- (match break_continue_must_change with
- | _,None -> stkind (* kept *)
- | _,(Some (continue_lbl_stmt)) ->
- Goto ((ref continue_lbl_stmt),loc)),
- labelled_stmt_tbl,
+ match stkind with
+ | (Instr _ | Return _ | Throw _) as keep ->
+ keep,labelled_stmt_tbl,calls_tbl
+ | Goto (stmt_ref, loc) -> Goto (ref !stmt_ref, loc),labelled_stmt_tbl,calls_tbl
+ | If (exp,bl1,bl2,loc) ->
+ CurrentLoc.set loc;
+ let new_block1,labelled_stmt_tbl,calls_tbl =
+ copy_block labelled_stmt_tbl calls_tbl bl1
+ in
+ let new_block2,labelled_stmt_tbl,calls_tbl =
+ copy_block labelled_stmt_tbl calls_tbl bl2
+ in
+ If(exp,new_block1,new_block2,loc),labelled_stmt_tbl,calls_tbl
+ | Loop (a,bl,loc,_,_) ->
+ CurrentLoc.set loc;
+ let new_block,labelled_stmt_tbl,calls_tbl =
+ copy_block
+ (* from now on break and continue can be kept *)
+ ~break_continue_must_change:(None, None)
+ labelled_stmt_tbl
calls_tbl
- | Switch (e,block,stmts,loc) ->
- (* from now on break only can be kept *)
- let new_block,new_labelled_stmt_tbl,calls_tbl =
- copy_block
- (* Copy the switch labels, as the englobing switch is in the copy. *)
- ~switch_label_action:Copy
- ~break_continue_must_change:(None, (snd break_continue_must_change))
- labelled_stmt_tbl calls_tbl block
- in
- let stmts' =
- List.map
- (fun s -> Cil_datatype.Stmt.Map.find s new_labelled_stmt_tbl) stmts
- in
- Switch(e,new_block,stmts',loc),new_labelled_stmt_tbl,calls_tbl
- | TryCatch(t,c,loc) ->
- let t', labs, calls = copy_block labelled_stmt_tbl calls_tbl t in
- let treat_one_extra_binding mv mv' (bindings, labs, calls) (v,b) =
- let v' = copy_var () v in
- assoc := (v,v')::!assoc;
- let b', labs', calls' = copy_block labs calls b in
- refresh_vars [mv; v] [mv'; v'] b';
- (v',b')::bindings, labs', calls'
- in
- let treat_one_catch (catches, labs, calls) (v,b) =
- let v', vorig, vnew, labs', calls' =
- match v with
- | Catch_all -> Catch_all, [], [], labs, calls
- | Catch_exn(v,l) ->
- let v' = copy_var () v in
- assoc:=(v,v')::!assoc;
- let l', labs', calls' =
- List.fold_left
- (treat_one_extra_binding v v') ([],labs, calls) l
- in
- Catch_exn(v', List.rev l'), [v], [v'], labs', calls'
- in
- let (b', labs', calls') = copy_block labs' calls' b in
- refresh_vars vorig vnew b';
- (v', b')::catches, labs', calls'
- in
- let c', labs', calls' =
- List.fold_left treat_one_catch ([],labs, calls) c
+ bl
+ in
+ Loop (a,new_block,loc,None,None),labelled_stmt_tbl,calls_tbl
+ | Block bl ->
+ let new_block,labelled_stmt_tbl,calls_tbl =
+ copy_block labelled_stmt_tbl calls_tbl bl
+ in
+ Block (new_block),labelled_stmt_tbl,calls_tbl
+ | UnspecifiedSequence seq ->
+ let change_calls lst calls_tbl =
+ List.map
+ (fun x -> ref (Cil_datatype.Stmt.Map.find !x calls_tbl)) lst
+ in
+ let new_seq,labelled_stmt_tbl,calls_tbl =
+ List.fold_left
+ (fun (seq,labelled_stmt_tbl,calls_tbl) (stmt,modified,writes,reads,calls) ->
+ let stmt,labelled_stmt_tbl,calls_tbl =
+ copy_stmt switch_label_action break_continue_must_change
+ labelled_stmt_tbl calls_tbl stmt
+ in
+ (stmt,modified,writes,reads,change_calls calls calls_tbl)::seq,
+ labelled_stmt_tbl,calls_tbl)
+ ([],labelled_stmt_tbl,calls_tbl)
+ seq
+ in
+ UnspecifiedSequence (List.rev new_seq),labelled_stmt_tbl,calls_tbl
+ | Break loc ->
+ (match break_continue_must_change with
+ | None, _ -> stkind (* kept *)
+ | (Some (brk_lbl_stmt)), _ -> Goto ((ref brk_lbl_stmt),loc)),
+ labelled_stmt_tbl,
+ calls_tbl
+ | Continue loc ->
+ (match break_continue_must_change with
+ | _,None -> stkind (* kept *)
+ | _,(Some (continue_lbl_stmt)) ->
+ Goto ((ref continue_lbl_stmt),loc)),
+ labelled_stmt_tbl,
+ calls_tbl
+ | Switch (e,block,stmts,loc) ->
+ (* from now on break only can be kept *)
+ let new_block,new_labelled_stmt_tbl,calls_tbl =
+ copy_block
+ (* Copy the switch labels, as the englobing switch is in the copy. *)
+ ~switch_label_action:Copy
+ ~break_continue_must_change:(None, (snd break_continue_must_change))
+ labelled_stmt_tbl calls_tbl block
+ in
+ let stmts' =
+ List.map
+ (fun s -> Cil_datatype.Stmt.Map.find s new_labelled_stmt_tbl) stmts
+ in
+ Switch(e,new_block,stmts',loc),new_labelled_stmt_tbl,calls_tbl
+ | TryCatch(t,c,loc) ->
+ let t', labs, calls = copy_block labelled_stmt_tbl calls_tbl t in
+ let treat_one_extra_binding mv mv' (bindings, labs, calls) (v,b) =
+ let v' = copy_var () v in
+ assoc := (v,v')::!assoc;
+ let b', labs', calls' = copy_block labs calls b in
+ refresh_vars [mv; v] [mv'; v'] b';
+ (v',b')::bindings, labs', calls'
+ in
+ let treat_one_catch (catches, labs, calls) (v,b) =
+ let v', vorig, vnew, labs', calls' =
+ match v with
+ | Catch_all -> Catch_all, [], [], labs, calls
+ | Catch_exn(v,l) ->
+ let v' = copy_var () v in
+ assoc:=(v,v')::!assoc;
+ let l', labs', calls' =
+ List.fold_left
+ (treat_one_extra_binding v v') ([],labs, calls) l
+ in
+ Catch_exn(v', List.rev l'), [v], [v'], labs', calls'
in
- TryCatch(t',List.rev c',loc), labs', calls'
- | TryFinally _ | TryExcept _ -> assert false
+ let (b', labs', calls') = copy_block labs' calls' b in
+ refresh_vars vorig vnew b';
+ (v', b')::catches, labs', calls'
+ in
+ let c', labs', calls' =
+ List.fold_left treat_one_catch ([],labs, calls) c
+ in
+ TryCatch(t',List.rev c',loc), labs', calls'
+ | TryFinally _ | TryExcept _ -> assert false
and copy_block
~switch_label_action ~break_continue_must_change
labelled_stmt_tbl calls_tbl bl =
- let new_stmts,labelled_stmt_tbl,calls_tbl =
- List.fold_left
- (fun (block_l,labelled_stmt_tbl,calls_tbl) v ->
- let new_block,labelled_stmt_tbl,calls_tbl =
- copy_stmt switch_label_action break_continue_must_change
- labelled_stmt_tbl calls_tbl v
- in
- new_block::block_l, labelled_stmt_tbl,calls_tbl)
- ([],labelled_stmt_tbl,calls_tbl)
- bl.bstmts
- in
- let new_locals =
- List.map (copy_var ()) bl.blocals
- in
- fundec.slocals <- fundec.slocals @ new_locals;
- assoc:=(List.combine bl.blocals new_locals) @ !assoc;
- let new_block = mkBlock (List.rev new_stmts) in
- refresh_vars bl.blocals new_locals new_block;
- new_block.blocals <- new_locals;
- new_block,labelled_stmt_tbl,calls_tbl
+ let new_stmts,labelled_stmt_tbl,calls_tbl =
+ List.fold_left
+ (fun (block_l,labelled_stmt_tbl,calls_tbl) v ->
+ let new_block,labelled_stmt_tbl,calls_tbl =
+ copy_stmt switch_label_action break_continue_must_change
+ labelled_stmt_tbl calls_tbl v
+ in
+ new_block::block_l, labelled_stmt_tbl,calls_tbl)
+ ([],labelled_stmt_tbl,calls_tbl)
+ bl.bstmts
+ in
+ let new_locals =
+ List.map (copy_var ()) bl.blocals
+ in
+ fundec.slocals <- fundec.slocals @ new_locals;
+ assoc:=(List.combine bl.blocals new_locals) @ !assoc;
+ let new_block = mkBlock (List.rev new_stmts) in
+ refresh_vars bl.blocals new_locals new_block;
+ new_block.blocals <- new_locals;
+ new_block,labelled_stmt_tbl,calls_tbl
in
- let new_block, labelled_stmt_tbl, _calls_tbl =
+ let new_block, labelled_stmt_tbl, _calls_tbl =
(* [calls_tbl] is internal. No need to fix references afterwards here. *)
copy_block ~switch_label_action ~break_continue_must_change
labelled_stmt_tbl calls_tbl bl
@@ -528,14 +528,14 @@ let ast_has_changed = ref false
(* Update to take into account annotations*)
class do_it global_find_init ((force:bool),(times:int)) = object(self)
inherit Visitor.frama_c_inplace
- initializer ast_has_changed := false;
- (* We sometimes need to move labels between statements. This table
- maps the old statement to the new one *)
- val moved_labels = Cil_datatype.Stmt.Hashtbl.create 17
- (* The statements with a switch label that have been created in the copy.
- They must be added in the englobing switch, and the original statements
- must be removed (their switch labels have been removed by [copy_block]. *)
- val mutable cases = [] ;
+ initializer ast_has_changed := false;
+ (* We sometimes need to move labels between statements. This table
+ maps the old statement to the new one *)
+ val moved_labels = Cil_datatype.Stmt.Hashtbl.create 17
+ (* The statements with a switch label that have been created in the copy.
+ They must be added in the englobing switch, and the original statements
+ must be removed (their switch labels have been removed by [copy_block]. *)
+ val mutable cases = [] ;
val mutable gotos = [] ;
val mutable has_unrolled_loop = false ;
@@ -548,138 +548,138 @@ class do_it global_find_init ((force:bool),(times:int)) = object(self)
assert (not has_unrolled_loop) ;
let post_goto_updater =
(fun id ->
- if has_unrolled_loop then begin
- List.iter
+ if has_unrolled_loop then begin
+ List.iter
(fun s -> match s.skind with Goto(sref,_loc) ->
- (try
- let new_stmt =
- Cil_datatype.Stmt.Hashtbl.find moved_labels !sref
- in
- sref := new_stmt
- with Not_found -> ())
- | _ -> assert false)
+ (try
+ let new_stmt =
+ Cil_datatype.Stmt.Hashtbl.find moved_labels !sref
+ in
+ sref := new_stmt
+ with Not_found -> ())
+ | _ -> assert false)
gotos;
File.must_recompute_cfg id;
ast_has_changed:=true
end;
- has_unrolled_loop <- false ;
- gotos <- [] ;
- Cil_datatype.Stmt.Hashtbl.clear moved_labels ;
- id) in
- ChangeDoChildrenPost (fundec, post_goto_updater)
+ has_unrolled_loop <- false ;
+ gotos <- [] ;
+ Cil_datatype.Stmt.Hashtbl.clear moved_labels ;
+ id) in
+ ChangeDoChildrenPost (fundec, post_goto_updater)
method! vstmt_aux s = match s.skind with
- | Goto _ ->
+ | Goto _ ->
gotos <- s::gotos; (* gotos that may need to be updated *)
DoChildren
- | Switch _ -> (* Update the labels pointed to by the switch if needed *)
+ | Switch _ -> (* Update the labels pointed to by the switch if needed *)
let update s =
- if has_unrolled_loop then
+ if has_unrolled_loop then
(match s.skind with
- | Switch (e', b', lbls', loc') ->
- let labels_moved = ref false in
- let update_label s =
- try
- let s = Cil_datatype.Stmt.Hashtbl.find moved_labels s
- in labels_moved := true ; s
- with Not_found -> s
- in let moved_lbls = List.map update_label lbls' in
- let new_lbls =
- if cases = []
- then moved_lbls
- else
- (* Removes the statements that have no more switch labels. *)
- let lbls = List.filter is_case_stmt moved_lbls in
- (* Adds the new statement with switch labels. *)
- cases @ lbls
- in
- if !labels_moved || cases <> [] then begin
- s.skind <- Switch (e', b', new_lbls, loc');
- (* Resets the statement to be added to the englobing switch. *)
- cases <- [];
- end
- | _ -> ());
+ | Switch (e', b', lbls', loc') ->
+ let labels_moved = ref false in
+ let update_label s =
+ try
+ let s = Cil_datatype.Stmt.Hashtbl.find moved_labels s
+ in labels_moved := true ; s
+ with Not_found -> s
+ in let moved_lbls = List.map update_label lbls' in
+ let new_lbls =
+ if cases = []
+ then moved_lbls
+ else
+ (* Removes the statements that have no more switch labels. *)
+ let lbls = List.filter is_case_stmt moved_lbls in
+ (* Adds the new statement with switch labels. *)
+ cases @ lbls
+ in
+ if !labels_moved || cases <> [] then begin
+ s.skind <- Switch (e', b', new_lbls, loc');
+ (* Resets the statement to be added to the englobing switch. *)
+ cases <- [];
+ end
+ | _ -> ());
s
in
ChangeDoChildrenPost (s, update)
- | Loop _ ->
- let infos = extract_from_pragmas global_find_init s in
- let number = Option.value ~default:times infos.unroll_number in
- let total_unrolling = infos.total_unroll in
- let is_ignored_unrolling = not force && infos.ignore_unroll in
- let f sloop =
- Kernel.debug ~dkey
- "Unrolling loop stmt %d (%d times) inside function %a@."
- sloop.sid number Kernel_function.pretty (Option.get self#current_kf);
- file_has_unrolled_loop <- true ;
- has_unrolled_loop <- true ;
- match sloop.skind with
- | Loop(_,block,loc,_,_) ->
- (* Note: loop annotations are kept into the remaining loops,
- but are not transformed into statement contracts inside the
- unrolled parts. *)
- (* Note: a goto from outside a loop to inside that loop will still
- goes into the remaining loop. *)
- (* TODO: transforms loop annotations into statement contracts
- inside the unrolled parts. *)
- CurrentLoc.set loc;
- let break_lbl_stmt =
- let break_label = fresh_label () in
- let break_lbl_stmt = mkEmptyStmt () in
- break_lbl_stmt.labels <- [break_label];
- break_lbl_stmt.sid <- Cil_const.Sid.next ();
- break_lbl_stmt
- in
- let mk_continue () =
- let continue_label = fresh_label () in
- let continue_lbl_stmt = mkEmptyStmt () in
- continue_lbl_stmt.labels <- [continue_label] ;
- continue_lbl_stmt.sid <- Cil_const.Sid.next ();
- continue_lbl_stmt
- in
- let current_continue = ref (mk_continue ()) in
- let new_stmts = ref [sloop] in
- for i=0 to number-1 do
- new_stmts:=!current_continue::!new_stmts;
- let switch_label_action = if i = number-1 then Move else Ignore in
- let new_block, new_switch_cases =
- copy_block
- (Option.get self#current_kf)
- switch_label_action
- ((Some break_lbl_stmt),(Some !current_continue))
- block
- in
- cases <- new_switch_cases @ cases;
- current_continue := mk_continue ();
- update_loop_current (Option.get self#current_kf) !current_continue new_block;
- (match new_block.blocals with
- [] -> new_stmts:= new_block.bstmts @ !new_stmts;
- | _ -> (* keep the block in order to preserve locals decl *)
- new_stmts:= mkStmt (Block new_block) :: !new_stmts);
- done;
- let new_stmt = match !new_stmts with
- | [ s ] -> s
- | l ->
- List.iter (update_loop_entry (Option.get self#current_kf) !current_continue) l;
- let l = if is_referenced !current_continue l then !current_continue :: l else l in
- let new_stmts = l @ [break_lbl_stmt] in
- let new_block = mkBlock new_stmts in
- let snew = mkStmt (Block new_block) in
- (* Move the labels in front of the original loop at the top of the
- new code *)
- Cil_datatype.Stmt.Hashtbl.add moved_labels sloop snew;
- snew.labels <- sloop.labels;
- sloop.labels <- [];
- snew;
+ | Loop _ ->
+ let infos = extract_from_pragmas global_find_init s in
+ let number = Option.value ~default:times infos.unroll_number in
+ let total_unrolling = infos.total_unroll in
+ let is_ignored_unrolling = not force && infos.ignore_unroll in
+ let f sloop =
+ Kernel.debug ~dkey
+ "Unrolling loop stmt %d (%d times) inside function %a@."
+ sloop.sid number Kernel_function.pretty (Option.get self#current_kf);
+ file_has_unrolled_loop <- true ;
+ has_unrolled_loop <- true ;
+ match sloop.skind with
+ | Loop(_,block,loc,_,_) ->
+ (* Note: loop annotations are kept into the remaining loops,
+ but are not transformed into statement contracts inside the
+ unrolled parts. *)
+ (* Note: a goto from outside a loop to inside that loop will still
+ goes into the remaining loop. *)
+ (* TODO: transforms loop annotations into statement contracts
+ inside the unrolled parts. *)
+ CurrentLoc.set loc;
+ let break_lbl_stmt =
+ let break_label = fresh_label () in
+ let break_lbl_stmt = mkEmptyStmt () in
+ break_lbl_stmt.labels <- [break_label];
+ break_lbl_stmt.sid <- Cil_const.Sid.next ();
+ break_lbl_stmt
+ in
+ let mk_continue () =
+ let continue_label = fresh_label () in
+ let continue_lbl_stmt = mkEmptyStmt () in
+ continue_lbl_stmt.labels <- [continue_label] ;
+ continue_lbl_stmt.sid <- Cil_const.Sid.next ();
+ continue_lbl_stmt
+ in
+ let current_continue = ref (mk_continue ()) in
+ let new_stmts = ref [sloop] in
+ for i=0 to number-1 do
+ new_stmts:=!current_continue::!new_stmts;
+ let switch_label_action = if i = number-1 then Move else Ignore in
+ let new_block, new_switch_cases =
+ copy_block
+ (Option.get self#current_kf)
+ switch_label_action
+ ((Some break_lbl_stmt),(Some !current_continue))
+ block
+ in
+ cases <- new_switch_cases @ cases;
+ current_continue := mk_continue ();
+ update_loop_current (Option.get self#current_kf) !current_continue new_block;
+ (match new_block.blocals with
+ [] -> new_stmts:= new_block.bstmts @ !new_stmts;
+ | _ -> (* keep the block in order to preserve locals decl *)
+ new_stmts:= mkStmt (Block new_block) :: !new_stmts);
+ done;
+ let new_stmt = match !new_stmts with
+ | [ s ] -> s
+ | l ->
+ List.iter (update_loop_entry (Option.get self#current_kf) !current_continue) l;
+ let l = if is_referenced !current_continue l then !current_continue :: l else l in
+ let new_stmts = l @ [break_lbl_stmt] in
+ let new_block = mkBlock new_stmts in
+ let snew = mkStmt (Block new_block) in
+ (* Move the labels in front of the original loop at the top of the
+ new code *)
+ Cil_datatype.Stmt.Hashtbl.add moved_labels sloop snew;
+ snew.labels <- sloop.labels;
+ sloop.labels <- [];
+ snew;
+ in
+ new_stmt
+ | _ -> assert false
in
- new_stmt
- | _ -> assert false
- in
- let g sloop new_stmts = (* Adds "loop invariant \false;" to the remaining
- loop when "completely" unrolled. *)
- (* Note: since a goto from outside the loop to inside the loop
- still goes into the remaining loop...*)
- match total_unrolling with
+ let g sloop new_stmts = (* Adds "loop invariant \false;" to the remaining
+ loop when "completely" unrolled. *)
+ (* Note: since a goto from outside the loop to inside the loop
+ still goes into the remaining loop...*)
+ match total_unrolling with
| None -> new_stmts
| Some emitter ->
let annot =
@@ -687,48 +687,48 @@ class do_it global_find_init ((force:bool),(times:int)) = object(self)
(AInvariant ([],true,Logic_const.(toplevel_predicate pfalse)))
in
Annotations.add_code_annot
- emitter ~kf:(Option.get self#current_kf) sloop annot;
+ emitter ~kf:(Option.get self#current_kf) sloop annot;
new_stmts
- in
- let h sloop new_stmts = (* To indicate that the unrolling has been done *)
- let specs = Unroll_specs [(Logic_const.term (TConst (LStr "done"))
- (Ctype Cil.charPtrType)) ;
- Logic_const.tinteger number
- ] in
- let annot =
- Logic_const.new_code_annotation (APragma (Loop_pragma specs))
in
- Annotations.add_code_annot
- Emitter.end_user ~kf:(Option.get self#current_kf) sloop annot;
- new_stmts
- in
- let fgh sloop = h sloop (g sloop (f sloop)) in
- let fgh =
- if (number > 0) && not is_ignored_unrolling then fgh else (fun s -> s)
- in
- ChangeDoChildrenPost (s, fgh)
+ let h sloop new_stmts = (* To indicate that the unrolling has been done *)
+ let specs = Unroll_specs [(Logic_const.term (TConst (LStr "done"))
+ (Ctype Cil.charPtrType)) ;
+ Logic_const.tinteger number
+ ] in
+ let annot =
+ Logic_const.new_code_annotation (APragma (Loop_pragma specs))
+ in
+ Annotations.add_code_annot
+ Emitter.end_user ~kf:(Option.get self#current_kf) sloop annot;
+ new_stmts
+ in
+ let fgh sloop = h sloop (g sloop (f sloop)) in
+ let fgh =
+ if (number > 0) && not is_ignored_unrolling then fgh else (fun s -> s)
+ in
+ ChangeDoChildrenPost (s, fgh)
- | _ -> DoChildren
+ | _ -> DoChildren
end
(* Performs unrolling transformation without using -ulevel option.
Do not forget to apply [transformations_closure] afterwards. *)
let apply_transformation ?(force=true) nb file =
(* [nb] default number of unrolling used when there is no UNROLL loop pragma.
- When [nb] is negative, no unrolling is done; all UNROLL loop pragmas
+ When [nb] is negative, no unrolling is done; all UNROLL loop pragmas
are ignored. *)
if nb >= 0 then
let global_find_init vi =
try (Globals.Vars.find vi).init with Not_found -> None
in
let visitor = new do_it global_find_init (force, nb) in
- Kernel.debug ~dkey "Using -ulevel %d option and UNROLL loop pragmas@." nb;
- visitFramacFileSameGlobals (visitor:>Visitor.frama_c_visitor) file;
- if !ast_has_changed then Ast.mark_as_changed ()
- else begin
- Kernel.debug ~dkey
- "No unrolling is done; all UNROLL loop pragmas are ignored@."
- end
+ Kernel.debug ~dkey "Using -ulevel %d option and UNROLL loop pragmas@." nb;
+ visitFramacFileSameGlobals (visitor:>Visitor.frama_c_visitor) file;
+ if !ast_has_changed then Ast.mark_as_changed ()
+ else begin
+ Kernel.debug ~dkey
+ "No unrolling is done; all UNROLL loop pragmas are ignored@."
+ end
(* Performs and closes all syntactic transformations *)
let compute file =
@@ -739,8 +739,8 @@ let compute file =
let unroll_transform =
File.register_code_transformation_category "loop unrolling"
-let () =
- File.add_code_transformation_after_cleanup
+let () =
+ File.add_code_transformation_after_cleanup
~deps:[(module Kernel.UnrollingLevel:Parameter_sig.S);
(module Kernel.UnrollingForce:Parameter_sig.S)]
unroll_transform compute
diff --git a/src/kernel_internals/typing/unroll_loops.mli b/src/kernel_internals/typing/unroll_loops.mli
index 679216123be753b90eb20a61960e6ec54661a6ed..11606a6c49588268e2a54c1f60ff6ff75eb00676 100644
--- a/src/kernel_internals/typing/unroll_loops.mli
+++ b/src/kernel_internals/typing/unroll_loops.mli
@@ -20,7 +20,7 @@
(* *)
(**************************************************************************)
-(** Syntactic loop unrolling.
+(** Syntactic loop unrolling.
Uses code transformation hook mechanism (after-cleanup phase)
of {!File} and exports nothing.
diff --git a/src/kernel_services/abstract_interp/abstract_interp.ml b/src/kernel_services/abstract_interp/abstract_interp.ml
index e7bbbb5bf8cb8aa68dc26b0c57ce254a0749e53a..39c921270e66b23599b959d556415c9c4fc14357 100644
--- a/src/kernel_services/abstract_interp/abstract_interp.ml
+++ b/src/kernel_services/abstract_interp/abstract_interp.ml
@@ -40,7 +40,7 @@ module Comp = struct
type t = Lt | Gt | Le | Ge | Eq | Ne
type result = truth = True | False | Unknown
-
+
let inv = function
| Gt -> Le
| Lt -> Ge
@@ -286,11 +286,11 @@ module Make_Lattice_Base (V:Lattice_Value):(Lattice_Base with type l = V.t) = st
fun e1 e2 ->
if e1==e2 then 0 else
match e1,e2 with
- | Top,_ -> 1
- | _, Top -> -1
- | Bottom, _ -> -1
- | _, Bottom -> 1
- | Value e1,Value e2 -> V.compare e1 e2
+ | Top,_ -> 1
+ | _, Top -> -1
+ | Bottom, _ -> -1
+ | _, Bottom -> 1
+ | Value e1,Value e2 -> V.compare e1 e2
let equal v1 v2 = match v1, v2 with
| Top, Top | Bottom, Bottom -> true
@@ -308,10 +308,10 @@ module Make_Lattice_Base (V:Lattice_Value):(Lattice_Base with type l = V.t) = st
(** This is exact *)
let meet b1 b2 =
if b1 == b2 then b1 else
- match b1,b2 with
- | Bottom, _ | _, Bottom -> Bottom
- | Top , v | v, Top -> v
- | Value v1, Value v2 -> if (V.compare v1 v2)=0 then b1 else Bottom
+ match b1,b2 with
+ | Bottom, _ | _, Bottom -> Bottom
+ | Top , v | v, Top -> v
+ | Value v1, Value v2 -> if (V.compare v1 v2)=0 then b1 else Bottom
(** This is exact *)
let narrow = meet
@@ -331,19 +331,19 @@ module Make_Lattice_Base (V:Lattice_Value):(Lattice_Base with type l = V.t) = st
let transform f = fun t1 t2 ->
match t1,t2 with
- | Bottom, _ | _, Bottom -> Bottom
- | Top, _ | _, Top -> Top
- | Value v1, Value v2 -> Value (f v1 v2)
+ | Bottom, _ | _, Bottom -> Bottom
+ | Top, _ | _, Top -> Top
+ | Value v1, Value v2 -> Value (f v1 v2)
let pretty fmt t =
match t with
- | Top -> Format.fprintf fmt "Top"
- | Bottom -> Format.fprintf fmt "Bottom"
- | Value v -> Format.fprintf fmt "{%a}" V.pretty v
+ | Top -> Format.fprintf fmt "Top"
+ | Bottom -> Format.fprintf fmt "Bottom"
+ | Value v -> Format.fprintf fmt "{%a}" V.pretty v
let is_included t1 t2 =
let b = (t1 == t2) ||
- (equal (meet t1 t2) t1)
+ (equal (meet t1 t2) t1)
in
(* Format.printf
"[Lattice]%a is included in %a: %b @\n"
@@ -353,23 +353,23 @@ module Make_Lattice_Base (V:Lattice_Value):(Lattice_Base with type l = V.t) = st
let intersects t1 t2 = not (equal (meet t1 t2) Bottom)
include
- (Datatype.Make
- (struct
- type t = base (*= Top | Bottom | Value of l*)
- let name = V.name ^ " lattice_base"
- let structural_descr = Structural_descr.t_sum [| [| V.packed_descr |] |]
- let reprs = Top :: Bottom :: List.map (fun v -> Value v) V.reprs
- let equal = equal
- let compare = compare
- let hash = hash
- let rehash = Datatype.identity
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let pretty = pretty
- let varname = Datatype.undefined
- let mem_project = Datatype.never_any_project
- end) :
- Datatype.S with type t := t)
+ (Datatype.Make
+ (struct
+ type t = base (*= Top | Bottom | Value of l*)
+ let name = V.name ^ " lattice_base"
+ let structural_descr = Structural_descr.t_sum [| [| V.packed_descr |] |]
+ let reprs = Top :: Bottom :: List.map (fun v -> Value v) V.reprs
+ let equal = equal
+ let compare = compare
+ let hash = hash
+ let rehash = Datatype.identity
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let pretty = pretty
+ let varname = Datatype.undefined
+ let mem_project = Datatype.never_any_project
+ end) :
+ Datatype.S with type t := t)
let () = Type.set_ml_name ty None
end
@@ -388,15 +388,15 @@ module Int = struct
(** execute [f] on [inf], [inf + step], ... *)
let fold f ~inf ~sup ~step acc =
-(* Format.printf "Int.fold: inf:%a sup:%a step:%a@\n"
- pretty inf pretty sup pretty step; *)
+ (* Format.printf "Int.fold: inf:%a sup:%a step:%a@\n"
+ pretty inf pretty sup pretty step; *)
let nb_loop = e_div (sub sup inf) step in
let rec fold_incr ~counter ~inf acc =
if equal counter onethousand then
Lattice_messages.emit_costly msg_emitter
"enumerating %a integers" pretty nb_loop;
if le inf sup then begin
- (* Format.printf "Int.fold: %a@\n" pretty inf; *)
+ (* Format.printf "Int.fold: %a@\n" pretty inf; *)
fold_incr ~counter:(succ counter) ~inf:(add step inf) (f inf acc)
end else acc
in
@@ -547,8 +547,8 @@ struct
let cardinal_zero_or_one v = match v with
| Bottom -> true
| Product (t1, t2) ->
- (L1.cardinal_zero_or_one t1) &&
- (L2.cardinal_zero_or_one t2)
+ (L1.cardinal_zero_or_one t1) &&
+ (L2.cardinal_zero_or_one t2)
let compare =
if L1.compare == Datatype.undefined || L2.compare == Datatype.undefined then (
@@ -560,12 +560,12 @@ struct
else fun x x' ->
if x == x' then 0 else
match x,x' with
- | Bottom, Bottom -> 0
- | Bottom, Product _ -> 1
- | Product _,Bottom -> -1
- | (Product (a,b)), (Product (a',b')) ->
- let c = L1.compare a a' in
- if c = 0 then L2.compare b b' else c
+ | Bottom, Bottom -> 0
+ | Bottom, Product _ -> 1
+ | Product _,Bottom -> -1
+ | (Product (a,b)), (Product (a',b')) ->
+ let c = L1.compare a a' in
+ if c = 0 then L2.compare b b' else c
let equal x x' =
if x == x' then true else
@@ -574,19 +574,19 @@ struct
| Bottom, Product _ -> false
| Product _,Bottom -> false
| (Product (a,b)), (Product (a',b')) ->
- L1.equal a a' && L2.equal b b'
+ L1.equal a a' && L2.equal b b'
let top = Product(L1.top,L2.top)
let bottom = Bottom
let fst x = match x with
- Bottom -> L1.bottom
- | Product(x1,_) -> x1
+ Bottom -> L1.bottom
+ | Product(x1,_) -> x1
let snd x = match x with
- Bottom -> L2.bottom
- | Product(_,x2) -> x2
+ Bottom -> L2.bottom
+ | Product(_,x2) -> x2
let condition_to_be_bottom x1 x2 =
let c1 = (L1.equal x1 L1.bottom) in
@@ -610,29 +610,29 @@ struct
match x1,x2 with
| Bottom, v | v, Bottom -> v
| Product (l1,ll1), Product (l2,ll2) ->
- Product(L1.join l1 l2, L2.join ll1 ll2)
+ Product(L1.join l1 l2, L2.join ll1 ll2)
let link x1 x2 =
if x1 == x2 then x1 else
match x1,x2 with
| Bottom, v | v, Bottom -> v
| Product (l1,ll1), Product (l2,ll2) ->
- Product(L1.link l1 l2, L2.link ll1 ll2)
+ Product(L1.link l1 l2, L2.link ll1 ll2)
let narrow x1 x2 =
if x1 == x2 then x1 else
- match x1,x2 with
- | Bottom, _ | _, Bottom -> Bottom
- | Product (l1,ll1), Product (l2,ll2) ->
+ match x1,x2 with
+ | Bottom, _ | _, Bottom -> Bottom
+ | Product (l1,ll1), Product (l2,ll2) ->
let l1 = L1.narrow l1 l2 in
let l2 = L2.narrow ll1 ll2 in
inject l1 l2
let meet x1 x2 =
if x1 == x2 then x1 else
- match x1,x2 with
- | Bottom, _ | _, Bottom -> Bottom
- | Product (l1,ll1), Product (l2,ll2) ->
+ match x1,x2 with
+ | Bottom, _ | _, Bottom -> Bottom
+ | Product (l1,ll1), Product (l2,ll2) ->
let l1 = L1.meet l1 l2 in
let l2 = L2.meet ll1 ll2 in
inject l1 l2
@@ -640,15 +640,15 @@ struct
let pretty fmt x =
match x with
Bottom ->
- Format.fprintf fmt "BotProd"
+ Format.fprintf fmt "BotProd"
| Product(l1,l2) ->
- Format.fprintf fmt "(%a,%a)" L1.pretty l1 L2.pretty l2
+ Format.fprintf fmt "(%a,%a)" L1.pretty l1 L2.pretty l2
let intersects x1 x2 =
match x1,x2 with
| Bottom, _ | _, Bottom -> false
| Product (l1,ll1), Product (l2,ll2) ->
- (L1.intersects l1 l2) && (L2.intersects ll1 ll2)
+ (L1.intersects l1 l2) && (L2.intersects ll1 ll2)
let is_included x1 x2 =
(x1 == x2) ||
@@ -656,33 +656,33 @@ struct
| Bottom, _ -> true
| _, Bottom -> false
| Product (l1,ll1), Product (l2,ll2) ->
- (L1.is_included l1 l2) && (L2.is_included ll1 ll2)
+ (L1.is_included l1 l2) && (L2.is_included ll1 ll2)
include (Datatype.Make
- (struct
- type t = product (*= Product of t1*t2 | Bottom*)
- let name = "(" ^ L1.name ^ ", " ^ L2.name ^ ") lattice_product"
- let structural_descr =
- Structural_descr.t_sum [| [| L1.packed_descr; L2.packed_descr |] |]
- let reprs =
- Bottom ::
- List.fold_left
- (fun acc l1 ->
- List.fold_left
- (fun acc l2 -> Product(l1, l2) :: acc) acc L2.reprs)
- []
- L1.reprs
- let equal = equal
- let compare = compare
- let hash = hash
- let rehash = Datatype.identity
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let pretty = pretty
- let varname = Datatype.undefined
- let mem_project = Datatype.never_any_project
- end) :
- Datatype.S with type t := t)
+ (struct
+ type t = product (*= Product of t1*t2 | Bottom*)
+ let name = "(" ^ L1.name ^ ", " ^ L2.name ^ ") lattice_product"
+ let structural_descr =
+ Structural_descr.t_sum [| [| L1.packed_descr; L2.packed_descr |] |]
+ let reprs =
+ Bottom ::
+ List.fold_left
+ (fun acc l1 ->
+ List.fold_left
+ (fun acc l2 -> Product(l1, l2) :: acc) acc L2.reprs)
+ []
+ L1.reprs
+ let equal = equal
+ let compare = compare
+ let hash = hash
+ let rehash = Datatype.identity
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let pretty = pretty
+ let varname = Datatype.undefined
+ let mem_project = Datatype.never_any_project
+ end) :
+ Datatype.S with type t := t)
let () = Type.set_ml_name ty None
end
@@ -698,9 +698,9 @@ struct
let hash (v1, v2) = L1.hash v1 + 31 * L2.hash v2
- let cardinal_zero_or_one (t1, t2) =
- (L1.cardinal_zero_or_one t1) &&
- (L2.cardinal_zero_or_one t2)
+ let cardinal_zero_or_one (t1, t2) =
+ (L1.cardinal_zero_or_one t1) &&
+ (L2.cardinal_zero_or_one t2)
let compare =
if L1.compare == Datatype.undefined || L2.compare == Datatype.undefined then (
@@ -712,15 +712,15 @@ struct
else fun x x' ->
if x == x' then 0 else
match x,x' with
- | (a,b), (a',b') ->
- let c = L1.compare a a' in
- if c = 0 then L2.compare b b' else c
+ | (a,b), (a',b') ->
+ let c = L1.compare a a' in
+ if c = 0 then L2.compare b b' else c
let equal x x' =
if x == x' then true else
match x,x' with
| ( (a,b)), ( (a',b')) ->
- L1.equal a a' && L2.equal b b'
+ L1.equal a a' && L2.equal b b'
let top = (L1.top,L2.top)
@@ -746,41 +746,41 @@ struct
L1.meet l1 l2, L2.meet ll1 ll2
let pretty fmt (l1, l2) =
- Format.fprintf fmt "(%a,%a)" L1.pretty l1 L2.pretty l2
+ Format.fprintf fmt "(%a,%a)" L1.pretty l1 L2.pretty l2
let intersects (l1,ll1) (l2,ll2) =
- (L1.intersects l1 l2) && (L2.intersects ll1 ll2)
+ (L1.intersects l1 l2) && (L2.intersects ll1 ll2)
let is_included x1 x2 =
(x1 == x2) ||
match x1,x2 with
| (l1,ll1), (l2,ll2) ->
- (L1.is_included l1 l2) && (L2.is_included ll1 ll2)
+ (L1.is_included l1 l2) && (L2.is_included ll1 ll2)
include
(Datatype.Make
- (struct
- type uproduct = t
- type t = uproduct (*= t1*t2 *)
- let name = "(" ^ L1.name ^ ", " ^ L2.name ^ ") lattice_uproduct"
- let structural_descr =
- Structural_descr.t_sum [| [| L1.packed_descr; L2.packed_descr |] |]
- let reprs =
- List.fold_left
- (fun acc l1 ->
- List.fold_left
- (fun acc l2 -> (l1, l2) :: acc) acc L2.reprs)
- []
- L1.reprs
- let equal = equal
- let compare = compare
- let hash = hash
- let rehash = Datatype.identity
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let pretty = pretty
- let varname = Datatype.undefined
- let mem_project = Datatype.never_any_project
+ (struct
+ type uproduct = t
+ type t = uproduct (*= t1*t2 *)
+ let name = "(" ^ L1.name ^ ", " ^ L2.name ^ ") lattice_uproduct"
+ let structural_descr =
+ Structural_descr.t_sum [| [| L1.packed_descr; L2.packed_descr |] |]
+ let reprs =
+ List.fold_left
+ (fun acc l1 ->
+ List.fold_left
+ (fun acc l2 -> (l1, l2) :: acc) acc L2.reprs)
+ []
+ L1.reprs
+ let equal = equal
+ let compare = compare
+ let hash = hash
+ let rehash = Datatype.identity
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let pretty = pretty
+ let varname = Datatype.undefined
+ let mem_project = Datatype.never_any_project
end):
Datatype.S with type t := t)
let () = Type.set_ml_name ty None
@@ -789,7 +789,7 @@ end
module Make_Lattice_Sum (L1:AI_Lattice_with_cardinal_one) (L2:AI_Lattice_with_cardinal_one):
(Lattice_Sum with type t1 = L1.t and type t2 = L2.t)
- =
+=
struct
type t1 = L1.t
type t2 = L2.t
@@ -813,12 +813,12 @@ struct
let widen (wh1, wh2) t1 t2 =
match t1,t2 with
- | T1 x,T1 y ->
- T1 (L1.widen wh1 x y)
- | T2 x,T2 y ->
- T2 (L2.widen wh2 x y)
- | Top,Top | Bottom,Bottom -> t1
- | _,_ -> Top
+ | T1 x,T1 y ->
+ T1 (L1.widen wh1 x y)
+ | T2 x,T2 y ->
+ T2 (L2.widen wh2 x y)
+ | Top,Top | Bottom,Bottom -> t1
+ | _,_ -> Top
let compare =
if L1.compare == Datatype.undefined || L2.compare == Datatype.undefined then (
@@ -830,24 +830,24 @@ struct
else fun u v ->
if u == v then 0 else
match u,v with
- | Top,Top | Bottom,Bottom -> 0
- | Bottom,_ | _,Top -> 1
- | Top,_ |_,Bottom -> -1
- | T1 _ , T2 _ -> 1
- | T2 _ , T1 _ -> -1
- | T1 t1,T1 t1' -> L1.compare t1 t1'
- | T2 t1,T2 t1' -> L2.compare t1 t1'
+ | Top,Top | Bottom,Bottom -> 0
+ | Bottom,_ | _,Top -> 1
+ | Top,_ |_,Bottom -> -1
+ | T1 _ , T2 _ -> 1
+ | T2 _ , T1 _ -> -1
+ | T1 t1,T1 t1' -> L1.compare t1 t1'
+ | T2 t1,T2 t1' -> L2.compare t1 t1'
let equal u v =
if u == v then false
else
match u, v with
- | Top,Top | Bottom,Bottom -> true
- | Bottom,_ | _,Top | Top,_ |_,Bottom -> false
- | T1 _ , T2 _ -> false
- | T2 _ , T1 _ -> false
- | T1 t1,T1 t1' -> L1.equal t1 t1'
- | T2 t2,T2 t2' -> L2.equal t2 t2'
+ | Top,Top | Bottom,Bottom -> true
+ | Bottom,_ | _,Top | Top,_ |_,Bottom -> false
+ | T1 _ , T2 _ -> false
+ | T2 _ , T1 _ -> false
+ | T1 t1,T1 t1' -> L1.equal t1 t1'
+ | T2 t2,T2 t2' -> L2.equal t2 t2'
(** Forbid [L1 Bottom] *)
let inject_t1 x =
@@ -861,10 +861,10 @@ struct
let pretty fmt v =
match v with
- | T1 x -> L1.pretty fmt x
- | T2 x -> L2.pretty fmt x
- | Top -> Format.fprintf fmt "<TopSum>"
- | Bottom -> Format.fprintf fmt "<BottomSum>"
+ | T1 x -> L1.pretty fmt x
+ | T2 x -> L2.pretty fmt x
+ | Top -> Format.fprintf fmt "<TopSum>"
+ | Bottom -> Format.fprintf fmt "<BottomSum>"
let join u v =
if u == v then u else
@@ -873,9 +873,9 @@ struct
| T2 t1,T2 t2 -> T2 (L2.join t1 t2)
| Bottom,x| x,Bottom -> x
| _,_ ->
- (*Format.printf
- "Degenerating collision : %a <==> %a@\n" pretty u pretty v;*)
- top
+ (*Format.printf
+ "Degenerating collision : %a <==> %a@\n" pretty u pretty v;*)
+ top
let link u v =
if u == v then u else
@@ -884,13 +884,13 @@ struct
| T2 t1,T2 t2 -> T2 (L2.link t1 t2)
| Bottom,x| x,Bottom -> x
| _,_ ->
- (*Format.printf
- "Degenerating collision : %a <==> %a@\n" pretty u pretty v;*)
- top
+ (*Format.printf
+ "Degenerating collision : %a <==> %a@\n" pretty u pretty v;*)
+ top
let narrow u v =
if u == v then u else
- match u,v with
+ match u,v with
| T1 t1,T1 t2 -> inject_t1 (L1.narrow t1 t2)
| T2 t1,T2 t2 -> inject_t2 (L2.narrow t1 t2)
| (T1 _ | T2 _),Top -> u
@@ -901,7 +901,7 @@ struct
let meet u v =
if u == v then u else
- match u,v with
+ match u,v with
| T1 t1,T1 t2 -> inject_t1 (L1.meet t1 t2)
| T2 t1,T2 t2 -> inject_t2 (L2.meet t1 t2)
| (T1 _ | T2 _),Top -> u
@@ -913,45 +913,45 @@ struct
let intersects u v =
match u,v with
- | Bottom,_ | _,Bottom -> false
- | Top,_ |_,Top -> true
- | T1 _,T1 _ -> true
- | T2 _,T2 _ -> true
- | _,_ -> false
+ | Bottom,_ | _,Bottom -> false
+ | Top,_ |_,Top -> true
+ | T1 _,T1 _ -> true
+ | T2 _,T2 _ -> true
+ | _,_ -> false
let is_included u v =
(u == v) ||
let b = match u,v with
- | Bottom,_ | _,Top -> true
- | Top,_ | _,Bottom -> false
- | T1 t1,T1 t2 -> L1.is_included t1 t2
- | T2 t1,T2 t2 -> L2.is_included t1 t2
- | _,_ -> false
+ | Bottom,_ | _,Top -> true
+ | Top,_ | _,Bottom -> false
+ | T1 t1,T1 t2 -> L1.is_included t1 t2
+ | T2 t1,T2 t2 -> L2.is_included t1 t2
+ | _,_ -> false
in
(* Format.printf
- "[Lattice_Sum]%a is included in %a: %b @\n" pretty u pretty v b;*)
+ "[Lattice_Sum]%a is included in %a: %b @\n" pretty u pretty v b;*)
b
include Datatype.Make
- (struct
- type t = sum
- let name = "(" ^ L1.name ^ ", " ^ L2.name ^ ") lattice_sum"
- let structural_descr = Structural_descr.t_unknown
- let reprs =
- Top :: Bottom
- :: List.fold_left
- (fun acc t -> T2 t :: acc) (List.map (fun t -> T1 t) L1.reprs) L2.reprs
- let equal = equal
- let compare = compare
- let hash = hash
- let rehash = Datatype.undefined
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let pretty = pretty
- let varname = Datatype.undefined
- let mem_project = Datatype.never_any_project
- end)
+ (struct
+ type t = sum
+ let name = "(" ^ L1.name ^ ", " ^ L2.name ^ ") lattice_sum"
+ let structural_descr = Structural_descr.t_unknown
+ let reprs =
+ Top :: Bottom
+ :: List.fold_left
+ (fun acc t -> T2 t :: acc) (List.map (fun t -> T1 t) L1.reprs) L2.reprs
+ let equal = equal
+ let compare = compare
+ let hash = hash
+ let rehash = Datatype.undefined
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let pretty = pretty
+ let varname = Datatype.undefined
+ let mem_project = Datatype.never_any_project
+ end)
let () = Type.set_ml_name ty None
end
diff --git a/src/kernel_services/abstract_interp/abstract_interp.mli b/src/kernel_services/abstract_interp/abstract_interp.mli
index 68bcf7f7e40af8c77476cd0cfb5d74be1d4567e5..52bf00b595a4a3fda9d08e2c9c4b87499f6346b7 100644
--- a/src/kernel_services/abstract_interp/abstract_interp.mli
+++ b/src/kernel_services/abstract_interp/abstract_interp.mli
@@ -105,8 +105,8 @@ module Make_Lattice_Set
: Lattice_type.Lattice_Set with module O = Set
module Make_Hashconsed_Lattice_Set
- (V: Hptmap.Id_Datatype)
- (Set: Hptset.S with type elt = V.t)
+ (V: Hptmap.Id_Datatype)
+ (Set: Hptset.S with type elt = V.t)
: Lattice_type.Lattice_Set with module O = Set
(** See e.g. base.ml and locations.ml to see how this functor should be
applied. The [O] module passed as argument is the same as [O] in the
diff --git a/src/kernel_services/abstract_interp/fval.mli b/src/kernel_services/abstract_interp/fval.mli
index 233ce9ada22508f097f8079b7da4a13b08b9eefb..076bc427c0997fee5511136ca1f66a56b96fcde7 100644
--- a/src/kernel_services/abstract_interp/fval.mli
+++ b/src/kernel_services/abstract_interp/fval.mli
@@ -120,7 +120,7 @@ val subdiv_float_interval : kind -> t -> t * t
log10f(3, FE_TONEAREST) < log10f(3, FE_DOWNWARD).
Also, we have observed bugs in [powf], which is called when [kind=Float32].
- *)
+*)
val exp : kind -> t -> t
val log: kind -> t -> t
diff --git a/src/kernel_services/abstract_interp/int_Base.ml b/src/kernel_services/abstract_interp/int_Base.ml
index 7ac291fde721eb6e0c8a604afba98eb318edcd1b..52e646d6a110d5a76f5230e3bcdd335a06638c3e 100644
--- a/src/kernel_services/abstract_interp/int_Base.ml
+++ b/src/kernel_services/abstract_interp/int_Base.ml
@@ -44,22 +44,22 @@ let pretty fmt = function
| Value i -> Format.fprintf fmt "<%a>" Int.pretty i
include Datatype.Make
-(struct
- type t = i (*= Top | Value of Integer.t *)
- let name = "Int_Base.t"
- let structural_descr =
- Structural_descr.t_sum [| [| Datatype.Integer.packed_descr |] |]
- let reprs = Top :: List.map (fun v -> Value v) Datatype.Integer.reprs
- let equal = equal
- let compare = compare
- let hash = hash
- let rehash = Datatype.identity
- let copy = Extlib.id
- let internal_pretty_code = Datatype.undefined
- let pretty = pretty
- let varname = Datatype.undefined
- let mem_project = Datatype.never_any_project
- end)
+ (struct
+ type t = i (*= Top | Value of Integer.t *)
+ let name = "Int_Base.t"
+ let structural_descr =
+ Structural_descr.t_sum [| [| Datatype.Integer.packed_descr |] |]
+ let reprs = Top :: List.map (fun v -> Value v) Datatype.Integer.reprs
+ let equal = equal
+ let compare = compare
+ let hash = hash
+ let rehash = Datatype.identity
+ let copy = Extlib.id
+ let internal_pretty_code = Datatype.undefined
+ let pretty = pretty
+ let varname = Datatype.undefined
+ let mem_project = Datatype.never_any_project
+ end)
let minus_one = Value Int.minus_one
let one = Value Int.one
@@ -69,8 +69,8 @@ let top = Top
let is_top v = (v = Top)
let neg x =
match x with
- | Value v -> Value (Int.neg v)
- | Top -> x
+ | Value v -> Value (Int.neg v)
+ | Top -> x
let inject i = Value i
let project = function
diff --git a/src/kernel_services/abstract_interp/int_Base.mli b/src/kernel_services/abstract_interp/int_Base.mli
index 9686888a528b01634ba4176911fc38d5e7c89422..5f50799d528b9cb232b03493b608430a357de45a 100644
--- a/src/kernel_services/abstract_interp/int_Base.mli
+++ b/src/kernel_services/abstract_interp/int_Base.mli
@@ -37,7 +37,7 @@ val is_top: t -> bool
val inject: Integer.t -> t
val project: t -> Integer.t
- (** @raise Error_Top if the argument is {!Top}. *)
+(** @raise Error_Top if the argument is {!Top}. *)
val cardinal_zero_or_one: t -> bool
diff --git a/src/kernel_services/abstract_interp/int_Intervals_sig.mli b/src/kernel_services/abstract_interp/int_Intervals_sig.mli
index 55c2a3c13858cb9c56f1831fa6a6970d906d002b..48345f9795787fd6931a020593d0e3c44b21aa79 100644
--- a/src/kernel_services/abstract_interp/int_Intervals_sig.mli
+++ b/src/kernel_services/abstract_interp/int_Intervals_sig.mli
@@ -35,14 +35,14 @@ val inject_bounds: Int.t -> Int.t -> t
val inject_itv: itv -> t
val inject: itv list -> t
val from_ival_size: Ival.t -> Int_Base.t -> t
- (** Conversion from an ival, which represents the beginning of
- each interval. The size if taken from the [Int_Base.t] argument.
- If the result contains more than [-plevel] arguments, it is
- automatically over-approximated. *)
+(** Conversion from an ival, which represents the beginning of
+ each interval. The size if taken from the [Int_Base.t] argument.
+ If the result contains more than [-plevel] arguments, it is
+ automatically over-approximated. *)
val from_ival_size_under: Ival.t -> Int_Base.t -> t
- (** Same as [from_ival_size], except that the result is an under-approximation
- if the ival points to too many locations *)
+(** Same as [from_ival_size], except that the result is an under-approximation
+ if the ival points to too many locations *)
val project_set: t -> itv list
(** May raise [Error_Top].
@@ -58,12 +58,12 @@ val iter: (itv -> unit) -> t -> unit
(** May raise [Error_Top] *)
val pretty_typ: Cil_types.typ option -> t Pretty_utils.formatter
- (** Pretty-printer that supposes the intervals are subranges of
- a C type, and use the type to print nice offsets *)
+(** Pretty-printer that supposes the intervals are subranges of
+ a C type, and use the type to print nice offsets *)
val range_covers_whole_type: Cil_types.typ -> t -> bool
- (** Does the interval cover the entire range of bits that are valid
- for the given type. *)
+(** Does the interval cover the entire range of bits that are valid
+ for the given type. *)
(**/**)
diff --git a/src/kernel_services/abstract_interp/ival.ml b/src/kernel_services/abstract_interp/ival.ml
index eaa27972c9144ddff0ffbff7f871ed0f59b36fab..0b7ebc9b1d419be5c5ef65883ff585ed20a1bb31 100644
--- a/src/kernel_services/abstract_interp/ival.ml
+++ b/src/kernel_services/abstract_interp/ival.ml
@@ -28,9 +28,9 @@ let log_imprecision s = Lattice_messages.emit_imprecision emitter s
module type Type = sig
(* Binary abstract operations do not model precisely float/integer operations.
- It is the responsibility of the callers to have two operands of the same
- implicit type. The only exception is for [singleton_zero], which is the
- correct representation of [0.] *)
+ It is the responsibility of the callers to have two operands of the same
+ implicit type. The only exception is for [singleton_zero], which is the
+ correct representation of [0.] *)
type t = private
| Bottom
| Int of Int_val.t
@@ -922,7 +922,7 @@ let cast_float_to_int_inverse ~single_precision i =
[(int)((real)min-epsilon)] would return [min-1]. Hence, we can
simply return the float corresponding to [min] -- which can be
represented precisely given [exact_min] and [exact_max]. *)
- Int.to_float min
+ Int.to_float min
in
(* All operations are dual w.r.t. the min bound. *)
let maxf =
diff --git a/src/kernel_services/abstract_interp/ival.mli b/src/kernel_services/abstract_interp/ival.mli
index f9ddb2915d90ae1b3da1e99c85e5967101a49986..a141be77d054a4f4e01a54054fc2401746762b80 100644
--- a/src/kernel_services/abstract_interp/ival.mli
+++ b/src/kernel_services/abstract_interp/ival.mli
@@ -30,13 +30,13 @@ type t
(** {2 General guidelines of this module}
- - Functions suffixed by [_int] expect arguments that are integers. Hence,
- they will fail on an ival with constructor [Float]. Conversely, [_float]
- suffixed functions expect float arguments: the constructor [Float], or
- the singleton set [ [| Int.zero |] ], that can be tested by {!is_zero}.
+ - Functions suffixed by [_int] expect arguments that are integers. Hence,
+ they will fail on an ival with constructor [Float]. Conversely, [_float]
+ suffixed functions expect float arguments: the constructor [Float], or
+ the singleton set [ [| Int.zero |] ], that can be tested by {!is_zero}.
- - see the comment in {!Lattice_type} about over- and under-approximations,
- and exact operations.
+ - see the comment in {!Lattice_type} about over- and under-approximations,
+ and exact operations.
*)
module Widen_Hints = Datatype.Integer.Set
@@ -46,7 +46,7 @@ type numerical_widen_hint = Widen_Hints.t * Fc_float.Widen_Hints.t
include Datatype.S_with_collections with type t := t
include Lattice_type.Full_AI_Lattice_with_cardinality
with type t := t
- and type widen_hint = size_widen_hint * numerical_widen_hint
+ and type widen_hint = size_widen_hint * numerical_widen_hint
val is_bottom : t -> bool
val overlaps: partial:bool -> size:Integer.t -> t -> t -> bool
@@ -160,8 +160,8 @@ val is_singleton_int : t -> bool
exception Not_Singleton_Int
val project_int : t -> Integer.t
- (** @raise Not_Singleton_Int when the cardinal of the argument is not 1,
- or if it is not an integer. *)
+(** @raise Not_Singleton_Int when the cardinal of the argument is not 1,
+ or if it is not an integer. *)
val is_small_set: t -> bool
diff --git a/src/kernel_services/abstract_interp/lattice_messages.ml b/src/kernel_services/abstract_interp/lattice_messages.ml
index 8e481974c106e5b65ac92410bc0e77c696b56c57..e0aac6403eedf17c874f9323ec67a11f4f472553 100644
--- a/src/kernel_services/abstract_interp/lattice_messages.ml
+++ b/src/kernel_services/abstract_interp/lattice_messages.ml
@@ -40,13 +40,13 @@ let emit _emitter msg =
let register _name = ()
let emit_approximation emitter = Format.kfprintf (fun _fmt ->
- let str = Format.flush_str_formatter() in
- emit emitter (Approximation str)) Format.str_formatter
+ let str = Format.flush_str_formatter() in
+ emit emitter (Approximation str)) Format.str_formatter
;;
let emit_costly emitter = Format.kfprintf (fun _fmt ->
- let str = Format.flush_str_formatter() in
- emit emitter (Costly str)) Format.str_formatter
+ let str = Format.flush_str_formatter() in
+ emit emitter (Costly str)) Format.str_formatter
;;
let emit_imprecision emitter str =
diff --git a/src/kernel_services/abstract_interp/lattice_messages.mli b/src/kernel_services/abstract_interp/lattice_messages.mli
index 05c67036d3b7848d5a87b4d592597e433ee288c1..37813c13f5586a2b4b45fa9a91498f3a8da465dc 100644
--- a/src/kernel_services/abstract_interp/lattice_messages.mli
+++ b/src/kernel_services/abstract_interp/lattice_messages.mli
@@ -24,13 +24,13 @@
type t =
| Approximation of string
- (** Abstract transfer function that intentionally approximates its result *)
+ (** Abstract transfer function that intentionally approximates its result *)
| Imprecision of string
- (** Abstract transfer function not fully implemented *)
+ (** Abstract transfer function not fully implemented *)
| Costly of string
- (** Abstract operation will be costly *)
+ (** Abstract operation will be costly *)
| Unsoundness of string
- (** Unsound abstract operation *)
+ (** Unsound abstract operation *)
type emitter
diff --git a/src/kernel_services/abstract_interp/lattice_type.mli b/src/kernel_services/abstract_interp/lattice_type.mli
index 3c41400e758a92c15d78704ddb68e3d0b5f14501..aaf728d06d5cb8c502dafb84885b740f75af1b6d 100644
--- a/src/kernel_services/abstract_interp/lattice_type.mli
+++ b/src/kernel_services/abstract_interp/lattice_type.mli
@@ -58,22 +58,22 @@ end
(** {2 Over- and under-approximations}
- Nearly all abstract operations implemented in the lattices of Frama-C
- are *over-approximations*: the (abstract) operation assumes that its operands
- are already over-approximations, and returns a result that over-approximates
- (abstracts) the results that would have been given by the concrete operation
- on the concretization of the arguments.
+ Nearly all abstract operations implemented in the lattices of Frama-C
+ are *over-approximations*: the (abstract) operation assumes that its operands
+ are already over-approximations, and returns a result that over-approximates
+ (abstracts) the results that would have been given by the concrete operation
+ on the concretization of the arguments.
- Conversely, some functions, suffixed by [_under] assumes that their arguments
- are under-approximations, and returns a result that under-approximates the
- concrete operation. The functions [link] and [meet] in
- {With_Under_Approximation} are exceptions, that are not suffixed by [_under].
+ Conversely, some functions, suffixed by [_under] assumes that their arguments
+ are under-approximations, and returns a result that under-approximates the
+ concrete operation. The functions [link] and [meet] in
+ {With_Under_Approximation} are exceptions, that are not suffixed by [_under].
- Finally, some functions are *exact*, in the sense that they preserve the
- concretization of the concrete function. Hence, they implement
- over-approximations when given over-approximated arguments, and
- under-approximations when given under-approximated ones. This 'exact'
- property is usually mentioned in the comments for the function. *)
+ Finally, some functions are *exact*, in the sense that they preserve the
+ concretization of the concrete function. Hence, they implement
+ over-approximations when given over-approximated arguments, and
+ under-approximations when given under-approximated ones. This 'exact'
+ property is usually mentioned in the comments for the function. *)
module type With_Intersects = sig
@@ -91,22 +91,22 @@ module type With_Enumeration = sig
elements to enumerate. *)
val cardinal_less_than: t -> int -> int
-(** Raises {!Abstract_interp.Not_less_than} whenever the cardinal of the
- given lattice is strictly higher than the given integer. *)
+ (** Raises {!Abstract_interp.Not_less_than} whenever the cardinal of the
+ given lattice is strictly higher than the given integer. *)
end
module type With_Diff = sig
type t
val diff : t -> t -> t
- (** [diff t1 t2] is an over-approximation of [t1-t2]. [t2] must
- be an under-approximation or exact. *)
+ (** [diff t1 t2] is an over-approximation of [t1-t2]. [t2] must
+ be an under-approximation or exact. *)
end
module type With_Diff_One = sig
type t
val diff_if_one : t -> t -> t
- (** [diff_if_one t1 t2] is an over-approximation of [t1-t2].
- @return [t1] if [t2] is not a singleton. *)
+ (** [diff_if_one t1 t2] is an over-approximation of [t1-t2].
+ @return [t1] if [t2] is not a singleton. *)
end
module type With_Cardinal_One = sig
@@ -120,8 +120,8 @@ module type With_Widening = sig
type widen_hint (** hints for the widening *)
val widen: widen_hint -> t -> t -> t
- (** [widen h t1 t2] is an over-approximation of [join t1 t2].
- Assumes [is_included t1 t2] *)
+ (** [widen h t1 t2] is an over-approximation of [join t1 t2].
+ Assumes [is_included t1 t2] *)
end
@@ -217,8 +217,8 @@ module type Lattice_Set = sig
module O: Hptset
type t = private Set of O.t | Top
include AI_Lattice_with_cardinal_one
- with type t := t
- and type widen_hint = O.t
+ with type t := t
+ and type widen_hint = O.t
val inject_singleton: O.elt -> t
val inject: O.t -> t
val empty: t
diff --git a/src/kernel_services/abstract_interp/lmap.ml b/src/kernel_services/abstract_interp/lmap.ml
index b2223cda94798f4fd226b56f777c6bb8dfa9e94e..966c46722edc33bbcf3686f9ca0660f856896518 100644
--- a/src/kernel_services/abstract_interp/lmap.ml
+++ b/src/kernel_services/abstract_interp/lmap.ml
@@ -29,7 +29,7 @@ type 'a default_contents =
| Bottom
| Top of 'a
| Constant of 'a
- | Other
+ | Other
module Make_LOffset
(V: sig
@@ -417,13 +417,13 @@ struct
| Bottom ->
(fun s t ->
if s == t || is_empty s (*all bases present in t but not in s
- are implicitly bound to Bottom in s, hence the inclusion holds *)
+ are implicitly bound to Bottom in s, hence the inclusion holds *)
then PTrue
else PUnknown)
| Top _ ->
(fun s t ->
if s == t || is_empty t (*all bases present in s but not in t
- are implicitly bound to Top in t, hence the inclusion holds *)
+ are implicitly bound to Top in t, hence the inclusion holds *)
then PTrue
else PUnknown)
| _ -> (fun s t -> if s == t then PTrue else PUnknown)
@@ -502,7 +502,7 @@ struct
let top = vtop () in
`Value (Offsetmap.create_isotropic ~size top)
- (* may raise Error_Top in the case Top Top *)
+ (* may raise Error_Top in the case Top Top *)
let copy_offsetmap src_loc size m =
let treat_src k_src i_src acc =
let validity = Base.validity k_src in
diff --git a/src/kernel_services/abstract_interp/lmap.mli b/src/kernel_services/abstract_interp/lmap.mli
index 5a033415f2e5d01621544e2a409d6a7e4ce0ed76..a42a48db7f944f864e2ca25fbc4dfd7e421b8e4e 100644
--- a/src/kernel_services/abstract_interp/lmap.mli
+++ b/src/kernel_services/abstract_interp/lmap.mli
@@ -30,50 +30,50 @@ type 'a default_contents =
| Bottom
| Top of 'a
| Constant of 'a
- | Other
+ | Other
module Make_LOffset
- (V: sig
- include module type of Offsetmap_lattice_with_isotropy
- include Lattice_type.With_Top_Opt with type t := t
- end)
- (Offsetmap: module type of Offsetmap_sig
- with type v = V.t
- and type widen_hint = V.numerical_widen_hint)
- (Default_offsetmap: sig
- val name: string
- (** Used to create different datatypes each time the functor is applied *)
+ (V: sig
+ include module type of Offsetmap_lattice_with_isotropy
+ include Lattice_type.With_Top_Opt with type t := t
+ end)
+ (Offsetmap: module type of Offsetmap_sig
+ with type v = V.t
+ and type widen_hint = V.numerical_widen_hint)
+ (Default_offsetmap: sig
+ val name: string
+ (** Used to create different datatypes each time the functor is applied *)
- val default_offsetmap : Base.t -> Offsetmap.t Bottom.or_bottom
- (** Value returned when a map is queried, and the base is not present.
- [`Bottom] indicates that the base is never bound in such a map. *)
+ val default_offsetmap : Base.t -> Offsetmap.t Bottom.or_bottom
+ (** Value returned when a map is queried, and the base is not present.
+ [`Bottom] indicates that the base is never bound in such a map. *)
- val default_contents: V.t default_contents
- (** This function is used to optimize functions that add keys in a map,
- in particular when maintaining canonicity w.r.t. default contents.
- It describes the contents [c] of the offsetmap
- resulting from [default_offsetmap b]. The possible values are:
- - [Bottom] means that [c] is [V.bottom] everywhere, and furthermore
- that [V.bottom] has an empty concretization. We deduce from this
- fact that unmapped keys do not contribute to a join, and that
- [join c v] is never [c] as soon as [v] is not itself [v].
- - [Top] means that [c] is [V.top] everywhere. Thus unmapped keys
- have a default value more general than the one in a map where the
- key is bound.
- - [`Constant v] means that [c] is an offsetmap with a single interval
- containing [v] everywhere. [v] must be isotropic (in the sense
- of {!V.is_isotropic}).
- - [`Other] means that [default_offsetmap] returns something arbitrary.
+ val default_contents: V.t default_contents
+ (** This function is used to optimize functions that add keys in a map,
+ in particular when maintaining canonicity w.r.t. default contents.
+ It describes the contents [c] of the offsetmap
+ resulting from [default_offsetmap b]. The possible values are:
+ - [Bottom] means that [c] is [V.bottom] everywhere, and furthermore
+ that [V.bottom] has an empty concretization. We deduce from this
+ fact that unmapped keys do not contribute to a join, and that
+ [join c v] is never [c] as soon as [v] is not itself [v].
+ - [Top] means that [c] is [V.top] everywhere. Thus unmapped keys
+ have a default value more general than the one in a map where the
+ key is bound.
+ - [`Constant v] means that [c] is an offsetmap with a single interval
+ containing [v] everywhere. [v] must be isotropic (in the sense
+ of {!V.is_isotropic}).
+ - [`Other] means that [default_offsetmap] returns something arbitrary.
- This function is only used on keys that change values. Thus it is
- safe to have [default_offsetmap] return something that do not
- match [default_contents] on constant keys.
- *)
- end):
+ This function is only used on keys that change values. Thus it is
+ safe to have [default_offsetmap] return something that do not
+ match [default_contents] on constant keys.
+ *)
+ end):
module type of Lmap_sig
- with type v = V.t
- and type widen_hint_base = V.numerical_widen_hint
- and type offsetmap = Offsetmap.t
+ with type v = V.t
+ and type widen_hint_base = V.numerical_widen_hint
+ and type offsetmap = Offsetmap.t
(*
Local Variables:
diff --git a/src/kernel_services/abstract_interp/lmap_bitwise.ml b/src/kernel_services/abstract_interp/lmap_bitwise.ml
index f20740592041af45826e0c553643a770af0f27a5..db99b69cf59bca3f676a515ea99789ee00662941 100644
--- a/src/kernel_services/abstract_interp/lmap_bitwise.ml
+++ b/src/kernel_services/abstract_interp/lmap_bitwise.ml
@@ -38,8 +38,8 @@ module type Location_map_bitwise = sig
module LOffset :
module type of Offsetmap_bitwise_sig
- with type v = v
- and type intervals = Int_Intervals.t
+ with type v = v
+ and type intervals = Int_Intervals.t
val is_empty : t -> bool
val is_bottom : t -> bool
@@ -128,7 +128,7 @@ struct
let to_bottom = LOffset.create ~size V.bottom in
let range = Int_Intervals.inject_bounds ib ie in
match LOffset.add_binding_intervals
- ~validity ~exact:true range V.default to_bottom
+ ~validity ~exact:true range V.default to_bottom
with
| `Bottom -> assert false
| `Value m -> m
@@ -231,8 +231,8 @@ struct
type t = lmap
let reprs = Top :: List.map (fun b -> Map b) LBase.reprs
let structural_descr =
- Structural_descr.t_sum [| [| LBase.packed_descr |] |]
- let name = LOffset.name ^ " lmap_bitwise"
+ Structural_descr.t_sum [| [| LBase.packed_descr |] |]
+ let name = LOffset.name ^ " lmap_bitwise"
let hash = hash
let equal = equal
let compare = compare
@@ -242,21 +242,21 @@ struct
let copy = Datatype.undefined
let varname = Datatype.undefined
let mem_project = Datatype.never_any_project
- end)
+ end)
let fold f m acc =
LBase.fold
(fun k offsetmap acc ->
- LOffset.fold
- (fun itvs v acc ->
- let z = Zone.inject k itvs in
- f z v acc)
- offsetmap
- acc)
+ LOffset.fold
+ (fun itvs v acc ->
+ let z = Zone.inject k itvs in
+ f z v acc)
+ offsetmap
+ acc)
m
acc
- let fold_base f m acc = LBase.fold f m acc
+ let fold_base f m acc = LBase.fold f m acc
let fold_fuse_same f m acc =
let f' b offs acc =
@@ -266,152 +266,152 @@ struct
in
fold_base f' m acc
- let add_binding ~exact m (loc:Zone.t) v =
- let aux_base_offset base offs m =
- let validity = Base.validity base in
- try
- let offsm = find_or_default base m in
- match LOffset.add_binding_intervals ~validity ~exact offs v offsm with
- | `Bottom -> m
- | `Value new_offsetmap -> LBase.add base new_offsetmap m
- with Invalid_base -> m
- in
- match loc, m with
- | Zone.Top (Base.SetLattice.Top, _),_|_,Top -> Top
- | _, Bottom -> Bottom
- | _, Map m -> Map (Zone.fold_topset_ok aux_base_offset loc m)
-
- let add_binding_loc ~exact m loc v =
- let aux_base_offset base offs m =
- let validity = Base.validity base in
- try
- let offsm = find_or_default base m in
- let new_offsetmap =
- LOffset.add_binding_ival ~validity ~exact offs ~size:loc.size v offsm
- in
- match new_offsetmap with
- | `Bottom -> m
- | `Value new_offsetmap -> LBase.add base new_offsetmap m
- with Invalid_base -> m
- in
- match loc.loc, m with
- | Location_Bits.Top (Base.SetLattice.Top, _),_|_,Top -> Top
- | _, Bottom -> Bottom
- | _, Map m ->
- Map (Location_Bits.fold_topset_ok aux_base_offset loc.loc m)
-
- let add_base b offsm = function
- | Bottom | Top as m -> m
- | Map m -> Map (LBase.add b offsm m)
-
- let remove_base b = function
- | Bottom | Top as m -> m
- | Map m -> Map (LBase.remove b m)
-
- let join_on_map =
- (* [join t Empty] is [t] if unbound bases are bound to [bottom] by default*)
- if V.(equal default bottom)
- then
- LBase.join
- ~cache:(Hptmap_sig.PersistentCache "lmap_bitwise.join")
- ~decide:(fun _ v1 v2 -> LOffset.join v1 v2)
- ~symmetric:true ~idempotent:true
- else
- let decide =
- let get b = function Some v -> v | None -> default_offsetmap b in
- fun b v1 v2 -> LOffset.join (get b v1) (get b v2)
- in
- LBase.generic_join
- ~cache:(Hptmap_sig.PersistentCache "lmap_bitwise.join")
- ~symmetric:true ~idempotent:true ~decide
-
-
- let join m1 m2 =
- let result = match m1, m2 with
- | Top, _ | _, Top -> Top
- | Bottom, m | m, Bottom -> m
- | Map m1, Map m2 -> Map (join_on_map m1 m2)
- in
- (*Format.printf "JoinBitWise: m1=%a@\nm2=%a@\nRESULT=%a@\n"
- pretty m1
- pretty m2
- pretty result;*)
- result
-
- let map f = function
- | Top -> Top
- | Bottom -> Bottom
- | Map m -> Map (LBase.map (fun m -> LOffset.map f m) m)
-
- let map2 ~cache ~symmetric ~idempotent ~empty_neutral fv f =
- let aux = LOffset.map2 cache fv f in
- let decide b om1 om2 = match om1, om2 with
- | None, None -> assert false (* decide is never called in this case *)
- | Some m1, None -> aux m1 (default_offsetmap b)
- | None, Some m2 -> aux (default_offsetmap b) m2
- | Some m1, Some m2 -> aux m1 m2
- in
- if empty_neutral
- then LBase.join ~symmetric ~idempotent ~cache ~decide:(fun _ m1 m2 -> aux m1 m2)
- else LBase.generic_join ~symmetric ~idempotent ~cache ~decide
-
- let is_included_map =
- let name = Format.asprintf "Lmap_bitwise(%s).is_included" V.name in
- let decide_fst b offs1 = LOffset.is_included offs1 (default_offsetmap b) in
- let decide_snd b offs2 = LOffset.is_included (default_offsetmap b) offs2 in
- let decide_both _ offs1 offs2 = LOffset.is_included offs1 offs2 in
- LBase.binary_predicate (Hptmap_sig.PersistentCache name) LBase.UniversalPredicate
- ~decide_fast:LBase.decide_fast_inclusion
- ~decide_fst ~decide_snd ~decide_both
-
- let is_included m1 m2 =
- match m1, m2 with
+ let add_binding ~exact m (loc:Zone.t) v =
+ let aux_base_offset base offs m =
+ let validity = Base.validity base in
+ try
+ let offsm = find_or_default base m in
+ match LOffset.add_binding_intervals ~validity ~exact offs v offsm with
+ | `Bottom -> m
+ | `Value new_offsetmap -> LBase.add base new_offsetmap m
+ with Invalid_base -> m
+ in
+ match loc, m with
+ | Zone.Top (Base.SetLattice.Top, _),_|_,Top -> Top
+ | _, Bottom -> Bottom
+ | _, Map m -> Map (Zone.fold_topset_ok aux_base_offset loc m)
+
+ let add_binding_loc ~exact m loc v =
+ let aux_base_offset base offs m =
+ let validity = Base.validity base in
+ try
+ let offsm = find_or_default base m in
+ let new_offsetmap =
+ LOffset.add_binding_ival ~validity ~exact offs ~size:loc.size v offsm
+ in
+ match new_offsetmap with
+ | `Bottom -> m
+ | `Value new_offsetmap -> LBase.add base new_offsetmap m
+ with Invalid_base -> m
+ in
+ match loc.loc, m with
+ | Location_Bits.Top (Base.SetLattice.Top, _),_|_,Top -> Top
+ | _, Bottom -> Bottom
+ | _, Map m ->
+ Map (Location_Bits.fold_topset_ok aux_base_offset loc.loc m)
+
+ let add_base b offsm = function
+ | Bottom | Top as m -> m
+ | Map m -> Map (LBase.add b offsm m)
+
+ let remove_base b = function
+ | Bottom | Top as m -> m
+ | Map m -> Map (LBase.remove b m)
+
+ let join_on_map =
+ (* [join t Empty] is [t] if unbound bases are bound to [bottom] by default*)
+ if V.(equal default bottom)
+ then
+ LBase.join
+ ~cache:(Hptmap_sig.PersistentCache "lmap_bitwise.join")
+ ~decide:(fun _ v1 v2 -> LOffset.join v1 v2)
+ ~symmetric:true ~idempotent:true
+ else
+ let decide =
+ let get b = function Some v -> v | None -> default_offsetmap b in
+ fun b v1 v2 -> LOffset.join (get b v1) (get b v2)
+ in
+ LBase.generic_join
+ ~cache:(Hptmap_sig.PersistentCache "lmap_bitwise.join")
+ ~symmetric:true ~idempotent:true ~decide
+
+
+ let join m1 m2 =
+ let result = match m1, m2 with
+ | Top, _ | _, Top -> Top
+ | Bottom, m | m, Bottom -> m
+ | Map m1, Map m2 -> Map (join_on_map m1 m2)
+ in
+ (*Format.printf "JoinBitWise: m1=%a@\nm2=%a@\nRESULT=%a@\n"
+ pretty m1
+ pretty m2
+ pretty result;*)
+ result
+
+ let map f = function
+ | Top -> Top
+ | Bottom -> Bottom
+ | Map m -> Map (LBase.map (fun m -> LOffset.map f m) m)
+
+ let map2 ~cache ~symmetric ~idempotent ~empty_neutral fv f =
+ let aux = LOffset.map2 cache fv f in
+ let decide b om1 om2 = match om1, om2 with
+ | None, None -> assert false (* decide is never called in this case *)
+ | Some m1, None -> aux m1 (default_offsetmap b)
+ | None, Some m2 -> aux (default_offsetmap b) m2
+ | Some m1, Some m2 -> aux m1 m2
+ in
+ if empty_neutral
+ then LBase.join ~symmetric ~idempotent ~cache ~decide:(fun _ m1 m2 -> aux m1 m2)
+ else LBase.generic_join ~symmetric ~idempotent ~cache ~decide
+
+ let is_included_map =
+ let name = Format.asprintf "Lmap_bitwise(%s).is_included" V.name in
+ let decide_fst b offs1 = LOffset.is_included offs1 (default_offsetmap b) in
+ let decide_snd b offs2 = LOffset.is_included (default_offsetmap b) offs2 in
+ let decide_both _ offs1 offs2 = LOffset.is_included offs1 offs2 in
+ LBase.binary_predicate (Hptmap_sig.PersistentCache name) LBase.UniversalPredicate
+ ~decide_fast:LBase.decide_fast_inclusion
+ ~decide_fst ~decide_snd ~decide_both
+
+ let is_included m1 m2 =
+ match m1, m2 with
| _, Top -> true
| Top ,_ -> false
| Bottom, _ -> true
| _, Bottom -> false
| Map m1, Map m2 -> is_included_map m1 m2
- let filter_base f m =
- match m with
- | Top -> Top
- | Bottom -> Bottom
- | Map m ->
- let result =
- LBase.fold (fun k v acc -> if f k then LBase.add k v acc else acc)
- m
- LBase.empty
- in
- Map result
-
- let find m loc =
- match loc, m with
- | Zone.Top _, _ | _, Top -> V.top
- | _, Bottom -> V.bottom
- | Zone.Map _, Map m ->
- let treat_offset base itvs acc =
- let validity = Base.validity base in
- if validity = Base.Invalid then acc
- else
- let offsetmap = find_or_default base m in
- let v = LOffset.find_iset ~validity itvs offsetmap in
- V.join acc v
- in
- Zone.fold_i treat_offset loc V.bottom
-
- let fold_join_zone ~both ~conv ~empty_map ~join ~empty =
- let cache = Hptmap_sig.PersistentCache "Lmap_bitwise.fold_on_zone" in
- let empty_left _ = empty (* zone over which to fold is empty *) in
- let empty_right z = empty_map z in
- let both b itvs map_b = conv b (both itvs map_b) in
- let fmap =
- Zone.fold2_join_heterogeneous
- ~cache ~empty_left ~empty_right ~both ~join ~empty
- in
- fun z m -> fmap z (LBase.shape m)
-
-
- let shape = LBase.shape
+ let filter_base f m =
+ match m with
+ | Top -> Top
+ | Bottom -> Bottom
+ | Map m ->
+ let result =
+ LBase.fold (fun k v acc -> if f k then LBase.add k v acc else acc)
+ m
+ LBase.empty
+ in
+ Map result
+
+ let find m loc =
+ match loc, m with
+ | Zone.Top _, _ | _, Top -> V.top
+ | _, Bottom -> V.bottom
+ | Zone.Map _, Map m ->
+ let treat_offset base itvs acc =
+ let validity = Base.validity base in
+ if validity = Base.Invalid then acc
+ else
+ let offsetmap = find_or_default base m in
+ let v = LOffset.find_iset ~validity itvs offsetmap in
+ V.join acc v
+ in
+ Zone.fold_i treat_offset loc V.bottom
+
+ let fold_join_zone ~both ~conv ~empty_map ~join ~empty =
+ let cache = Hptmap_sig.PersistentCache "Lmap_bitwise.fold_on_zone" in
+ let empty_left _ = empty (* zone over which to fold is empty *) in
+ let empty_right z = empty_map z in
+ let both b itvs map_b = conv b (both itvs map_b) in
+ let fmap =
+ Zone.fold2_join_heterogeneous
+ ~cache ~empty_left ~empty_right ~both ~join ~empty
+ in
+ fun z m -> fmap z (LBase.shape m)
+
+
+ let shape = LBase.shape
end
diff --git a/src/kernel_services/abstract_interp/lmap_bitwise.mli b/src/kernel_services/abstract_interp/lmap_bitwise.mli
index edb5e6c71f0d153aea940ab4edc7e26deca2ef25..e915b02833a2bde603384ad62c4344774cb8d7f1 100644
--- a/src/kernel_services/abstract_interp/lmap_bitwise.mli
+++ b/src/kernel_services/abstract_interp/lmap_bitwise.mli
@@ -41,8 +41,8 @@ module type Location_map_bitwise = sig
module LOffset :
module type of Offsetmap_bitwise_sig
- with type v = v
- and type intervals = Int_Intervals.t
+ with type v = v
+ and type intervals = Int_Intervals.t
val is_empty : t -> bool
val is_bottom : t -> bool
@@ -76,19 +76,19 @@ module type Location_map_bitwise = sig
of type [map] to force their user to handle the cases Top and Bottom
explicitly. *)
val fold: (Zone.t -> v -> 'a -> 'a) -> map -> 'a -> 'a
- (** [fold f m] folds a function [f] on the bindings in [m]. Contiguous
- bits with the same value are merged into a single zone. Different bases
- are presented in different zones. *)
+ (** [fold f m] folds a function [f] on the bindings in [m]. Contiguous
+ bits with the same value are merged into a single zone. Different bases
+ are presented in different zones. *)
val fold_base : (Base.t -> LOffset.t -> 'a -> 'a) -> map -> 'a -> 'a
val fold_fuse_same : (Zone.t -> v -> 'a -> 'a) -> map -> 'a -> 'a
- (** Same behavior as [fold], except if two non-contiguous ranges [r1] and
- [r2] of a given base are mapped to the same value.
- [fold] will call its argument [f] on each range successively
- (hence, in our example, on [r1] and [r2] separately).
- Conversely, [fold_fuse_same] will call [f] directly on [r1 U r2],
- U being the join on sets of intervals. *)
+ (** Same behavior as [fold], except if two non-contiguous ranges [r1] and
+ [r2] of a given base are mapped to the same value.
+ [fold] will call its argument [f] on each range successively
+ (hence, in our example, on [r1] and [r2] separately).
+ Conversely, [fold_fuse_same] will call [f] directly on [r1 U r2],
+ U being the join on sets of intervals. *)
val fold_join_zone:
both:(Int_Intervals.t -> LOffset.t -> 'a) ->
diff --git a/src/kernel_services/abstract_interp/locations.ml b/src/kernel_services/abstract_interp/locations.ml
index 442b8d59bc652f8e903e810104b36a7dd8f74640..5550f60fd514fdeb04883b74b20e29ef5f2430f1 100644
--- a/src/kernel_services/abstract_interp/locations.ml
+++ b/src/kernel_services/abstract_interp/locations.ml
@@ -34,7 +34,7 @@ module Initial_Values = struct
[Base.null,Ival.top_float];
[Base.null,Ival.top_single_precision_float];
[Base.null,Ival.float_zeros];
- ]
+ ]
end
(* Store the information that the location has at most cardinal 1, ignoring
@@ -79,10 +79,10 @@ module Location_Bytes = struct
end
include MapSetLattice
- (* Invariant :
- [Top (s, _) must always contain NULL, _and_ at least another base.
- Top ({Null}, _) is replaced by Top_int]. See inject_top_origin_internal
- below. *)
+ (* Invariant :
+ [Top (s, _) must always contain NULL, _and_ at least another base.
+ Top ({Null}, _) is replaced by Top_int]. See inject_top_origin_internal
+ below. *)
let find_or_bottom = MapLattice.find_or_bottom
let is_bottom = equal bottom
@@ -96,10 +96,10 @@ module Location_Bytes = struct
let inject_ival i = inject Base.null i
- let inject_float f =
- inject_ival
+ let inject_float f =
+ inject_ival
(Ival.inject_float
- (Fval.inject_singleton f))
+ (Fval.inject_singleton f))
(** Check that those values correspond to {!Initial_Values} above. *)
let singleton_zero = inject_ival Ival.zero
@@ -235,7 +235,7 @@ module Location_Bytes = struct
track_garbled_mix (Top(Base.SetLattice.top, origin))
(* This internal function builds a garbled mix, but does *not* track its
- creation. This is useful for functions that transform existing GMs. *)
+ creation. This is useful for functions that transform existing GMs. *)
let inject_top_origin_internal o b =
if Base.Hptset.(equal b empty || equal b Base.null_set) then
top_int
@@ -259,128 +259,128 @@ module Location_Bytes = struct
let narrow m1 m2 = normalize_top (narrow m1 m2)
let meet m1 m2 = normalize_top (meet m1 m2)
- let topify_with_origin o v =
- match v with
- | Top (s,a) ->
- Top (s, Origin.join a o)
- | v when is_zero v -> v
- | Map _ ->
- if equal v bottom then v
- else
- match get_keys v with
- | Base.SetLattice.Top -> top_with_origin o
- | Base.SetLattice.Set b ->
- track_garbled_mix (inject_top_origin_internal o b)
-
- let topify_with_origin_kind ok v =
- let o = Origin.current ok in
- topify_with_origin o v
-
- let get_bases = get_keys
-
- let is_relationable m =
- try
- let b,_ = find_lonely_binding m in
- match Base.validity b with
- | Base.Empty | Base.Known _ | Base.Unknown _ | Base.Invalid -> true
- | Base.Variable { Base.weak } -> not weak
- with Not_found -> false
-
- let topify_merge_origin v =
- topify_with_origin_kind Origin.K_Merge v
-
- let topify_misaligned_read_origin v =
- topify_with_origin_kind Origin.K_Misalign_read v
-
- let topify_arith_origin v =
- topify_with_origin_kind Origin.K_Arith v
-
- let topify_leaf_origin v =
- topify_with_origin_kind Origin.K_Leaf v
-
- let may_reach base loc =
- if Base.is_null base then true
- else
- match loc with
- | Top (Base.SetLattice.Top, _) -> true
- | Top (Base.SetLattice.Set s,_) ->
- Base.Hptset.mem base s
- | Map m -> try
- ignore (M.find base m);
- true
- with Not_found -> false
-
- let contains_addresses_of_locals is_local l =
- match l with
- | Top (Base.SetLattice.Top,_) -> true
- | Top (Base.SetLattice.Set s, _) ->
- Base.SetLattice.O.exists is_local s
- | Map m ->
- M.exists (fun b _ -> is_local b) m
-
- let remove_escaping_locals is_local v =
- let non_local b = not (is_local b) in
- match v with
- | Top (Base.SetLattice.Top,_) -> true, v
- | Top (Base.SetLattice.Set garble, orig) ->
- let nonlocals = Base.Hptset.filter non_local garble in
- if Base.Hptset.equal garble nonlocals then
- false, v
- else
- true, inject_top_origin_internal orig nonlocals
- | Map m ->
- let nonlocals = M.filter non_local m in
- if M.equal nonlocals m then
- false, v
- else
- true, Map nonlocals
-
- let contains_addresses_of_any_locals =
- let f base _offsets = Base.is_any_formal_or_local base in
- let projection _base = Ival.top in
- let cached_f =
- cached_fold
- ~cache_name:"loc_top_any_locals"
- ~temporary:false
- ~f
- ~projection
- ~joiner:(||)
- ~empty:false
- in
- fun loc ->
- try
- cached_f loc
- with Error_Top ->
- assert (match loc with
- | Top (Base.SetLattice.Top,_) -> true
- | Top (Base.SetLattice.Set _top_param,_orig) ->
- false
- | Map _ -> false);
- true
-
- let replace_base substitution v =
- let substitute replace make acc =
- let modified, set' = replace substitution acc in
- modified, if modified then make set' else v
- in
- match v with
- | Top (Base.SetLattice.Top, _) -> false, v
- | Top (Base.SetLattice.Set set, origin) ->
- substitute Base.Hptset.replace (inject_top_origin_internal origin) set
- | Map map ->
- let decide _key = Ival.join in
- substitute (M.replace_key ~decide) (fun m -> Map m) map
-
- let overlaps ~partial ~size mm1 mm2 =
- match mm1, mm2 with
- | Top _, _ | _, Top _ -> intersects mm1 mm2
- | Map m1, Map m2 ->
- M.symmetric_binary_predicate
- Hptmap_sig.NoCache M.ExistentialPredicate
- ~decide_fast:(fun _ _ -> M.PUnknown)
- ~decide_one:(fun _ _ -> false)
- ~decide_both:(fun _ x y -> Ival.overlaps ~partial ~size x y)
- m1 m2
+ let topify_with_origin o v =
+ match v with
+ | Top (s,a) ->
+ Top (s, Origin.join a o)
+ | v when is_zero v -> v
+ | Map _ ->
+ if equal v bottom then v
+ else
+ match get_keys v with
+ | Base.SetLattice.Top -> top_with_origin o
+ | Base.SetLattice.Set b ->
+ track_garbled_mix (inject_top_origin_internal o b)
+
+ let topify_with_origin_kind ok v =
+ let o = Origin.current ok in
+ topify_with_origin o v
+
+ let get_bases = get_keys
+
+ let is_relationable m =
+ try
+ let b,_ = find_lonely_binding m in
+ match Base.validity b with
+ | Base.Empty | Base.Known _ | Base.Unknown _ | Base.Invalid -> true
+ | Base.Variable { Base.weak } -> not weak
+ with Not_found -> false
+
+ let topify_merge_origin v =
+ topify_with_origin_kind Origin.K_Merge v
+
+ let topify_misaligned_read_origin v =
+ topify_with_origin_kind Origin.K_Misalign_read v
+
+ let topify_arith_origin v =
+ topify_with_origin_kind Origin.K_Arith v
+
+ let topify_leaf_origin v =
+ topify_with_origin_kind Origin.K_Leaf v
+
+ let may_reach base loc =
+ if Base.is_null base then true
+ else
+ match loc with
+ | Top (Base.SetLattice.Top, _) -> true
+ | Top (Base.SetLattice.Set s,_) ->
+ Base.Hptset.mem base s
+ | Map m -> try
+ ignore (M.find base m);
+ true
+ with Not_found -> false
+
+ let contains_addresses_of_locals is_local l =
+ match l with
+ | Top (Base.SetLattice.Top,_) -> true
+ | Top (Base.SetLattice.Set s, _) ->
+ Base.SetLattice.O.exists is_local s
+ | Map m ->
+ M.exists (fun b _ -> is_local b) m
+
+ let remove_escaping_locals is_local v =
+ let non_local b = not (is_local b) in
+ match v with
+ | Top (Base.SetLattice.Top,_) -> true, v
+ | Top (Base.SetLattice.Set garble, orig) ->
+ let nonlocals = Base.Hptset.filter non_local garble in
+ if Base.Hptset.equal garble nonlocals then
+ false, v
+ else
+ true, inject_top_origin_internal orig nonlocals
+ | Map m ->
+ let nonlocals = M.filter non_local m in
+ if M.equal nonlocals m then
+ false, v
+ else
+ true, Map nonlocals
+
+ let contains_addresses_of_any_locals =
+ let f base _offsets = Base.is_any_formal_or_local base in
+ let projection _base = Ival.top in
+ let cached_f =
+ cached_fold
+ ~cache_name:"loc_top_any_locals"
+ ~temporary:false
+ ~f
+ ~projection
+ ~joiner:(||)
+ ~empty:false
+ in
+ fun loc ->
+ try
+ cached_f loc
+ with Error_Top ->
+ assert (match loc with
+ | Top (Base.SetLattice.Top,_) -> true
+ | Top (Base.SetLattice.Set _top_param,_orig) ->
+ false
+ | Map _ -> false);
+ true
+
+ let replace_base substitution v =
+ let substitute replace make acc =
+ let modified, set' = replace substitution acc in
+ modified, if modified then make set' else v
+ in
+ match v with
+ | Top (Base.SetLattice.Top, _) -> false, v
+ | Top (Base.SetLattice.Set set, origin) ->
+ substitute Base.Hptset.replace (inject_top_origin_internal origin) set
+ | Map map ->
+ let decide _key = Ival.join in
+ substitute (M.replace_key ~decide) (fun m -> Map m) map
+
+ let overlaps ~partial ~size mm1 mm2 =
+ match mm1, mm2 with
+ | Top _, _ | _, Top _ -> intersects mm1 mm2
+ | Map m1, Map m2 ->
+ M.symmetric_binary_predicate
+ Hptmap_sig.NoCache M.ExistentialPredicate
+ ~decide_fast:(fun _ _ -> M.PUnknown)
+ ~decide_one:(fun _ _ -> false)
+ ~decide_both:(fun _ x y -> Ival.overlaps ~partial ~size x y)
+ m1 m2
type size_widen_hint = Ival.size_widen_hint
type numerical_widen_hint = Base.t -> Ival.numerical_widen_hint
@@ -441,64 +441,64 @@ module Zone = struct
let pretty fmt m =
match m with
| Top (Base.SetLattice.Top,a) ->
- Format.fprintf fmt "ANYTHING(origin:%a)"
- Origin.pretty a
+ Format.fprintf fmt "ANYTHING(origin:%a)"
+ Origin.pretty a
| Top (s,a) ->
- Format.fprintf fmt "Unknown(%a, origin:%a)"
- Base.SetLattice.pretty s
- Origin.pretty a
+ Format.fprintf fmt "Unknown(%a, origin:%a)"
+ Base.SetLattice.pretty s
+ Origin.pretty a
| Map _ when equal m bottom ->
- Format.fprintf fmt "\\nothing"
+ Format.fprintf fmt "\\nothing"
| Map off ->
- let print_binding fmt (k, v) =
- Format.fprintf fmt "@[<h>%a%a@]"
- Base.pretty k
- (Int_Intervals.pretty_typ (Base.typeof k)) v
- in
- Pretty_utils.pp_iter ~pre:"" ~suf:"" ~sep:";@,@ "
- (fun f -> M.iter (fun k v -> f (k, v))) print_binding fmt off
+ let print_binding fmt (k, v) =
+ Format.fprintf fmt "@[<h>%a%a@]"
+ Base.pretty k
+ (Int_Intervals.pretty_typ (Base.typeof k)) v
+ in
+ Pretty_utils.pp_iter ~pre:"" ~suf:"" ~sep:";@,@ "
+ (fun f -> M.iter (fun k v -> f (k, v))) print_binding fmt off
let valid_intersects = intersects
- let mem_base b = function
- | Top (top_param, _) ->
- Base.SetLattice.mem b top_param
- | Map m -> M.mem b m
-
- let shape = M.shape
-
- let fold2_join_heterogeneous ~cache ~empty_left ~empty_right ~both ~join ~empty =
- let f_top =
- (* Build a zone corresponding to the garbled mix. Do not add NULL, we
- are reasoning on zones. Inefficient if empty_right does not use
- its argument, though... *)
- let build_z set =
- let aux b z = M.add b Int_Intervals.top z in
- Map (Base.Hptset.fold aux set M.empty)
- in
- let empty_right set = empty_right (build_z set) in
- let both base v = both base Int_Intervals.top v in
- Base.SetLattice.O.fold2_join_heterogeneous
- ~cache ~empty_left ~empty_right ~both ~join ~empty
- in
- let f_map =
- let empty_right m = empty_right (Map m) in
- let both base itvs v = both base itvs v in
- M.fold2_join_heterogeneous
- ~cache ~empty_left ~empty_right ~both ~join ~empty
- in
- fun z ->
- match z with
- | Top (Base.SetLattice.Top, _) -> raise Error_Top
- | Top (Base.SetLattice.Set s, _) -> f_top s
- | Map mm -> f_map mm
+ let mem_base b = function
+ | Top (top_param, _) ->
+ Base.SetLattice.mem b top_param
+ | Map m -> M.mem b m
+
+ let shape = M.shape
+
+ let fold2_join_heterogeneous ~cache ~empty_left ~empty_right ~both ~join ~empty =
+ let f_top =
+ (* Build a zone corresponding to the garbled mix. Do not add NULL, we
+ are reasoning on zones. Inefficient if empty_right does not use
+ its argument, though... *)
+ let build_z set =
+ let aux b z = M.add b Int_Intervals.top z in
+ Map (Base.Hptset.fold aux set M.empty)
+ in
+ let empty_right set = empty_right (build_z set) in
+ let both base v = both base Int_Intervals.top v in
+ Base.SetLattice.O.fold2_join_heterogeneous
+ ~cache ~empty_left ~empty_right ~both ~join ~empty
+ in
+ let f_map =
+ let empty_right m = empty_right (Map m) in
+ let both base itvs v = both base itvs v in
+ M.fold2_join_heterogeneous
+ ~cache ~empty_left ~empty_right ~both ~join ~empty
+ in
+ fun z ->
+ match z with
+ | Top (Base.SetLattice.Top, _) -> raise Error_Top
+ | Top (Base.SetLattice.Set s, _) -> f_top s
+ | Map mm -> f_map mm
end
type location =
- { loc : Location_Bits.t;
- size : Int_Base.t }
+ { loc : Location_Bits.t;
+ size : Int_Base.t }
type access = Read | Write | No_access
@@ -518,36 +518,36 @@ exception Found_two
let valid_cardinal_zero_or_one ~for_writing {loc=loc;size=size} =
Location_Bits.equal Location_Bits.bottom loc ||
- let found_one =
- let already = ref false in
- function () ->
- if !already then raise Found_two;
- already := true
- in
- try
+ let found_one =
+ let already = ref false in
+ function () ->
+ if !already then raise Found_two;
+ already := true
+ in
+ try
match loc, size with
- | Location_Bits.Top _, _ -> false
- | _, Int_Base.Top -> false
- | Location_Bits.Map m, Int_Base.Value size ->
- Location_Bits.M.iter
- (fun base offsets ->
- if Base.is_weak base then raise Found_two;
- let access =
- if for_writing then Base.Write size else Base.Read size
- in
- let valid_offsets =
- Ival.narrow offsets (Base.valid_offset access base)
- in
- if Ival.cardinal_zero_or_one valid_offsets
- then begin
- if not (Ival.is_bottom valid_offsets)
- then found_one ()
- end
- else raise Found_two
- ) m;
- true
- with
- | Abstract_interp.Error_Top | Found_two -> false
+ | Location_Bits.Top _, _ -> false
+ | _, Int_Base.Top -> false
+ | Location_Bits.Map m, Int_Base.Value size ->
+ Location_Bits.M.iter
+ (fun base offsets ->
+ if Base.is_weak base then raise Found_two;
+ let access =
+ if for_writing then Base.Write size else Base.Read size
+ in
+ let valid_offsets =
+ Ival.narrow offsets (Base.valid_offset access base)
+ in
+ if Ival.cardinal_zero_or_one valid_offsets
+ then begin
+ if not (Ival.is_bottom valid_offsets)
+ then found_one ()
+ end
+ else raise Found_two
+ ) m;
+ true
+ with
+ | Abstract_interp.Error_Top | Found_two -> false
let loc_bytes_to_loc_bits x =
@@ -607,7 +607,7 @@ let is_bottom_loc l = Location_Bits.(equal l.loc bottom)
let cardinal_zero_or_one { loc = loc ; size = size } =
Location_Bits.cardinal_zero_or_one loc &&
- Int_Base.cardinal_zero_or_one size
+ Int_Base.cardinal_zero_or_one size
let loc_equal { loc = loc1 ; size = size1 } { loc = loc2 ; size = size2 } =
Int_Base.equal size1 size2 &&
@@ -630,29 +630,29 @@ let pretty_loc = pretty
let pretty_english ~prefix fmt { loc = m ; size = size } =
match m with
| Location_Bits.Top (Base.SetLattice.Top,a) ->
- Format.fprintf fmt "somewhere unknown (origin:%a)"
- Origin.pretty a
+ Format.fprintf fmt "somewhere unknown (origin:%a)"
+ Origin.pretty a
| Location_Bits.Top (s,a) ->
- Format.fprintf fmt "somewhere in %a (origin:%a)"
- Base.SetLattice.pretty s
- Origin.pretty a
+ Format.fprintf fmt "somewhere in %a (origin:%a)"
+ Base.SetLattice.pretty s
+ Origin.pretty a
| Location_Bits.Map _ when Location_Bits.(equal m bottom) ->
- Format.fprintf fmt "nowhere"
+ Format.fprintf fmt "nowhere"
| Location_Bits.Map off ->
- let print_binding fmt (k, v) =
- ( match Ival.is_zero v, Base.validity k, size with
- true, Base.Known (_,s1), Int_Base.Value s2 when
- Int.equal (Int.succ s1) s2 ->
- Format.fprintf fmt "@[<h>%a@]" Base.pretty k
+ let print_binding fmt (k, v) =
+ ( match Ival.is_zero v, Base.validity k, size with
+ true, Base.Known (_,s1), Int_Base.Value s2 when
+ Int.equal (Int.succ s1) s2 ->
+ Format.fprintf fmt "@[<h>%a@]" Base.pretty k
| _ ->
- Format.fprintf fmt "@[<h>%a with offsets %a@]"
- Base.pretty k
- Ival.pretty v)
- in
- Pretty_utils.pp_iter
- ~pre:(if prefix then format_of_string "in " else "") ~suf:"" ~sep:";@,@ "
- (fun f -> Location_Bits.M.iter (fun k v -> f (k, v)))
- print_binding fmt off
+ Format.fprintf fmt "@[<h>%a with offsets %a@]"
+ Base.pretty k
+ Ival.pretty v)
+ in
+ Pretty_utils.pp_iter
+ ~pre:(if prefix then format_of_string "in " else "") ~suf:"" ~sep:";@,@ "
+ (fun f -> Location_Bits.M.iter (fun k v -> f (k, v)))
+ print_binding fmt off
(* Case [Top (Top, _)] must be handled by caller. *)
let enumerate_valid_bits_under_over under_over access {loc; size} =
@@ -683,7 +683,7 @@ let enumerate_valid_bits access loc =
enumerate_valid_bits_under_over interval_from_ival_over access loc
;;
-let enumerate_valid_bits_under access loc =
+let enumerate_valid_bits_under access loc =
match loc.size with
| Int_Base.Top -> Zone.bottom
| Int_Base.Value _ ->
@@ -708,12 +708,12 @@ let valid_part access ?(bitfield=true) {loc = loc; size = size } =
in
let locbits =
match loc with
- | Location_Bits.Top (Base.SetLattice.Top, _) -> loc
- | Location_Bits.Top (Base.SetLattice.Set _, _) ->
- Location_Bits.(Map (fold_topset_ok compute_loc loc M.empty))
- | Location_Bits.Map m ->
- Location_Bits.Map
- (Location_Bits.M.fold compute_loc m Location_Bits.M.empty)
+ | Location_Bits.Top (Base.SetLattice.Top, _) -> loc
+ | Location_Bits.Top (Base.SetLattice.Set _, _) ->
+ Location_Bits.(Map (fold_topset_ok compute_loc loc M.empty))
+ | Location_Bits.Map m ->
+ Location_Bits.Map
+ (Location_Bits.M.fold compute_loc m Location_Bits.M.empty)
in
make_loc locbits size
@@ -739,7 +739,7 @@ let enumerate_bits_under loc =
let zone_of_varinfo var = enumerate_bits (loc_of_varinfo var)
(** [invalid_part l] is an over-approximation of the invalid part
- of the location [l] *)
+ of the location [l] *)
let invalid_part l = l (* TODO (but rarely useful) *)
let overlaps ~partial l1 l2 =
@@ -750,28 +750,28 @@ let overlaps ~partial l1 l2 =
module Location =
Datatype.Make
- (struct
- include Datatype.Serializable_undefined
- type t = location
- let structural_descr =
- Structural_descr.t_record
- [| Location_Bits.packed_descr; Int_Base.packed_descr |]
- let reprs =
- List.fold_left
- (fun acc l ->
- List.fold_left
- (fun acc n -> { loc = l; size = n } :: acc)
- acc
- Int_Base.reprs)
- []
- Location_Bits.reprs
- let name = "Locations.Location"
- let mem_project = Datatype.never_any_project
- let equal = loc_equal
- let compare = loc_compare
- let hash = loc_hash
- let pretty = pretty_loc
- end)
+ (struct
+ include Datatype.Serializable_undefined
+ type t = location
+ let structural_descr =
+ Structural_descr.t_record
+ [| Location_Bits.packed_descr; Int_Base.packed_descr |]
+ let reprs =
+ List.fold_left
+ (fun acc l ->
+ List.fold_left
+ (fun acc n -> { loc = l; size = n } :: acc)
+ acc
+ Int_Base.reprs)
+ []
+ Location_Bits.reprs
+ let name = "Locations.Location"
+ let mem_project = Datatype.never_any_project
+ let equal = loc_equal
+ let compare = loc_compare
+ let hash = loc_hash
+ let pretty = pretty_loc
+ end)
(*
Local Variables:
diff --git a/src/kernel_services/abstract_interp/locations.mli b/src/kernel_services/abstract_interp/locations.mli
index 4bea9a7b4e218c9c6ff972577fbfdf18904a6ae4..51f85f4e6e738bf39b14ca72e840de64e2b54421 100644
--- a/src/kernel_services/abstract_interp/locations.mli
+++ b/src/kernel_services/abstract_interp/locations.mli
@@ -42,7 +42,7 @@ module Location_Bytes : sig
type t = private
| Top of Base.SetLattice.t * Origin.t
- (** Garbled mix of the addresses in the set *)
+ (** Garbled mix of the addresses in the set *)
| Map of M.t (** Precise set of addresses+offsets *)
type size_widen_hint = Ival.size_widen_hint
@@ -58,9 +58,9 @@ module Location_Bytes : sig
include Datatype.S_with_collections with type t := t
val singleton_zero : t
- (** the set containing only the value for to the C expression [0] *)
+ (** the set containing only the value for to the C expression [0] *)
val singleton_one : t
- (** the set containing only the value [1] *)
+ (** the set containing only the value [1] *)
val zero_or_one : t
val is_zero : t -> bool
@@ -84,12 +84,12 @@ module Location_Bytes : sig
bases, the offsets bound to these bases are joined. *)
val diff : t -> t -> t
- (** Over-approximation of difference. [arg2] needs to be exact or an
- under_approximation. *)
+ (** Over-approximation of difference. [arg2] needs to be exact or an
+ under_approximation. *)
val diff_if_one : t -> t -> t
- (** Over-approximation of difference. [arg2] can be an
- over-approximation. *)
+ (** Over-approximation of difference. [arg2] can be an
+ over-approximation. *)
val shift : Ival.t -> t -> t
val shift_under : Ival.t -> t -> t
@@ -112,31 +112,31 @@ module Location_Bytes : sig
val topify_with_origin: Origin.t -> t -> t
val topify_with_origin_kind: Origin.kind -> t -> t
val inject_top_origin : Origin.t -> Base.Hptset.t -> t
- (** [inject_top_origin origin p] creates a top with origin [origin]
- and additional information [param] *)
+ (** [inject_top_origin origin p] creates a top with origin [origin]
+ and additional information [param] *)
val top_with_origin: Origin.t -> t
- (** Completely imprecise value. Use only as last resort. *)
+ (** Completely imprecise value. Use only as last resort. *)
(* {2 Iterators} *)
val fold_bases : (Base.t -> 'a -> 'a) -> t -> 'a -> 'a
- (** Fold on all the bases of the location, including [Top bases].
- @raise Error_Top in the case [Top Top]. *)
+ (** Fold on all the bases of the location, including [Top bases].
+ @raise Error_Top in the case [Top Top]. *)
val fold_i : (Base.t -> Ival.t -> 'a -> 'a) -> t -> 'a -> 'a
- (** Fold with offsets.
- @raise Error_Top in the cases [Top Top], [Top bases]. *)
+ (** Fold with offsets.
+ @raise Error_Top in the cases [Top Top], [Top bases]. *)
val fold_topset_ok: (Base.t -> Ival.t -> 'a -> 'a) -> t -> 'a -> 'a
- (** Fold with offsets, including in the case [Top bases]. In this case,
- [Ival.top] is supplied to the iterator.
- @raise Error_Top in the case [Top Top]. *)
+ (** Fold with offsets, including in the case [Top bases]. In this case,
+ [Ival.top] is supplied to the iterator.
+ @raise Error_Top in the case [Top Top]. *)
val fold_enum : (t -> 'a -> 'a) -> t -> 'a -> 'a
- (** [fold_enum f loc acc] enumerates the locations in [acc], and passes
- them to [f]. Make sure to call {!cardinal_less_than} before calling
- this function, as all possible combinations of bases/offsets are
- presented to [f]. Raises {!Error_Top} if [loc] is [Top _] or if
- one offset cannot be enumerated. *)
+ (** [fold_enum f loc acc] enumerates the locations in [acc], and passes
+ them to [f]. Make sure to call {!cardinal_less_than} before calling
+ this function, as all possible combinations of bases/offsets are
+ presented to [f]. Raises {!Error_Top} if [loc] is [Top _] or if
+ one offset cannot be enumerated. *)
val cached_fold:
cache_name:string ->
@@ -177,16 +177,16 @@ module Location_Bytes : sig
val split : Base.t -> t -> Ival.t * t
val get_bases : t -> Base.SetLattice.t
- (** Returns the bases the location may point to. Never fails, but
- may return [Base.SetLattice.Top]. *)
+ (** Returns the bases the location may point to. Never fails, but
+ may return [Base.SetLattice.Top]. *)
(** {2 Local variables inside locations} *)
val contains_addresses_of_locals : (M.key -> bool) -> t -> bool
- (** [contains_addresses_of_locals is_local loc] returns [true]
- if [loc] contains the address of a variable for which
- [is_local] returns [true] *)
+ (** [contains_addresses_of_locals is_local loc] returns [true]
+ if [loc] contains the address of a variable for which
+ [is_local] returns [true] *)
val remove_escaping_locals : (M.key -> bool) -> t -> bool * t
(** [remove_escaping_locals is_local v] removes from [v] the information
@@ -194,8 +194,8 @@ module Location_Bytes : sig
returned boolean indicates that [v] contained some locals. *)
val contains_addresses_of_any_locals : t -> bool
- (** [contains_addresses_of_any_locals loc] returns [true] iff [loc] contains
- the address of a local variable or of a formal variable. *)
+ (** [contains_addresses_of_any_locals loc] returns [true] iff [loc] contains
+ the address of a local variable or of a formal variable. *)
(** {2 Misc} *)
@@ -204,20 +204,20 @@ module Location_Bytes : sig
val is_relationable: t -> bool
val may_reach : Base.t -> t -> bool
- (** [may_reach base loc] is true if [base] might be accessed from [loc]. *)
+ (** [may_reach base loc] is true if [base] might be accessed from [loc]. *)
val get_garbled_mix: unit -> t list
- (** All the garbled mix that have been created so far, sorted by "temporal"
- order of emission. *)
+ (** All the garbled mix that have been created so far, sorted by "temporal"
+ order of emission. *)
val clear_garbled_mix: unit -> unit
- (** Clear the information on created garbled mix. *)
+ (** Clear the information on created garbled mix. *)
val do_track_garbled_mix: bool -> unit
val track_garbled_mix: t -> t
-(**/**)
+ (**/**)
val pretty_debug: t Pretty_utils.formatter
val clear_caches: unit -> unit
end
@@ -252,36 +252,36 @@ module Zone : sig
val find: Base.t -> t -> Int_Intervals.t
val mem_base : Base.t -> t -> bool
- (** [mem_base b m] returns [true] if [b] is associated to something
- or topified in [t], and [false] otherwise.
+ (** [mem_base b m] returns [true] if [b] is associated to something
+ or topified in [t], and [false] otherwise.
- @since Carbon-20101201 *)
+ @since Carbon-20101201 *)
val intersects : t -> t -> bool
-(** Assuming that [z1] and [z2] only contain valid bases,
- [valid_intersects z1 z2] returns true iff [z1] and [z2] have a valid
- intersection. *)
+ (** Assuming that [z1] and [z2] only contain valid bases,
+ [valid_intersects z1 z2] returns true iff [z1] and [z2] have a valid
+ intersection. *)
val valid_intersects : t -> t -> bool
(** {3 Folding} *)
val filter_base : (Base.t -> bool) -> t -> t
- (** [filter_base] can't raise Error_Top since it filters bases of [Top
- bases]. Note: the filter may give an over-approximation (in the case
- [Top Top]). *)
+ (** [filter_base] can't raise Error_Top since it filters bases of [Top
+ bases]. Note: the filter may give an over-approximation (in the case
+ [Top Top]). *)
val fold_bases : (Base.t -> 'a -> 'a) -> t -> 'a -> 'a
- (** [fold_bases] folds also bases of [Top bases].
- @raise Error_Top in the case [Top Top]. *)
+ (** [fold_bases] folds also bases of [Top bases].
+ @raise Error_Top in the case [Top Top]. *)
val fold_i : (Base.t -> Int_Intervals.t -> 'a -> 'a) -> t -> 'a -> 'a
- (** [fold_i f l acc] folds [l] by base.
- @raise Error_Top in the cases [Top Top], [Top bases]. *)
+ (** [fold_i f l acc] folds [l] by base.
+ @raise Error_Top in the cases [Top Top], [Top bases]. *)
val fold_topset_ok : (Base.t -> Int_Intervals.t -> 'a -> 'a) -> t -> 'a -> 'a
- (** [fold_i f l acc] folds [l] by base.
- @raise Error_Top in the case [Top Top]. *)
+ (** [fold_i f l acc] folds [l] by base.
+ @raise Error_Top in the case [Top Top]. *)
val cached_fold :
cache_name:string ->
@@ -304,7 +304,7 @@ module Zone : sig
(** {3 Misc} *)
val shape: map_t -> Int_Intervals.t Hptmap.Shape(Base.Base).t
-(**/**)
+ (**/**)
val clear_caches: unit -> unit
end
@@ -389,7 +389,7 @@ val enumerate_valid_bits : access -> location -> Zone.t
val enumerate_valid_bits_under : access -> location -> Zone.t
val zone_of_varinfo : varinfo -> Zone.t
- (** @since Carbon-20101201 *)
+(** @since Carbon-20101201 *)
val loc_of_varinfo : varinfo -> location
val loc_of_base : Base.t -> location
diff --git a/src/kernel_services/abstract_interp/map_lattice.ml b/src/kernel_services/abstract_interp/map_lattice.ml
index 1725256a484b75b2d0342d7f943f62a93537c472..658b8f209e2475992c484cc3ff0a4fa893610e8b 100644
--- a/src/kernel_services/abstract_interp/map_lattice.ml
+++ b/src/kernel_services/abstract_interp/map_lattice.ml
@@ -463,22 +463,22 @@ module Make_MapSet_Lattice
let pretty fmt = function
| Top (t, a) ->
- Format.fprintf fmt "@[<hov 2>{{ mix of %a.@ Origin: %a}}@]"
- KSet.pretty t Origin.pretty a
+ Format.fprintf fmt "@[<hov 2>{{ mix of %a.@ Origin: %a}}@]"
+ KSet.pretty t Origin.pretty a
| Map m ->
- Pretty_utils.pp_iter
- ~pre:"@[<hv 3>{{ "
- ~suf:" }}@]"
- ~sep:";@ "
- (fun pp map -> KVMap.iter (fun k v -> pp (k, v)) map)
- (fun fmt (k, v) ->
- Format.fprintf fmt "%a -> %a" Key.pretty k Value.pretty v)
- fmt m
+ Pretty_utils.pp_iter
+ ~pre:"@[<hv 3>{{ "
+ ~suf:" }}@]"
+ ~sep:";@ "
+ (fun pp map -> KVMap.iter (fun k v -> pp (k, v)) map)
+ (fun fmt (k, v) ->
+ Format.fprintf fmt "%a -> %a" Key.pretty k Value.pretty v)
+ fmt m
let pretty_debug fmt = function
| Top (t, a) ->
- Format.fprintf fmt "@[<hov 2>{{ mix of %a.@ Origin: %a}}@]"
- KSet.pretty t Origin.pretty a
+ Format.fprintf fmt "@[<hov 2>{{ mix of %a.@ Origin: %a}}@]"
+ KSet.pretty t Origin.pretty a
| Map m -> KVMap.pretty_debug fmt m
diff --git a/src/kernel_services/abstract_interp/map_lattice.mli b/src/kernel_services/abstract_interp/map_lattice.mli
index 426cb9fa180e1d6c8f0d87d6256bf9642c079fd1..d8f2ff90849d95b5c7c5a0fdcf7d8222727b0d98 100644
--- a/src/kernel_services/abstract_interp/map_lattice.mli
+++ b/src/kernel_services/abstract_interp/map_lattice.mli
@@ -206,4 +206,3 @@ module Make_MapSet_Lattice
and type v := Value.t
end
-
diff --git a/src/kernel_services/abstract_interp/offsetmap.ml b/src/kernel_services/abstract_interp/offsetmap.ml
index d68922acec8b41944225c7516d83c23d13f82635..d57b792f32faa0b48413ad3f59833bc31b5c3694 100644
--- a/src/kernel_services/abstract_interp/offsetmap.ml
+++ b/src/kernel_services/abstract_interp/offsetmap.ml
@@ -52,37 +52,37 @@ let msg_emitter = Lattice_messages.register "Offsetmap"
is the lower index of the interval at the top of the tree. ( *Not* of the
leftmost interval, which is the smallest binding.) *)
type 'a offsetmap =
-| Empty
+ | Empty
-| Node of
- Integer.t *
+ | Node of
+ Integer.t *
(** Relative, upper index of the interval. Thus the interval has length
[max+1]. The relative lower index of the interval is always zero by
definition. *)
- Integer.t * 'a offsetmap *
+ Integer.t * 'a offsetmap *
(** subtree on the left: the offset [offl] of its root (relative to 0),
and the tree [subl]. If [subl] is not empty, it maps at least one
interval, and [offl] is strictly negative. If [subl] is empty,
then [offl] is zero. *)
- Integer.t * 'a offsetmap
- (** subtree on the right: the offset [offr] of its root (relative to 0),
- and the tree [subr]. [offr] is greater than [max+1] by definition,
- and equal to it if [subr] is empty. ([offr] may also be equal to
- [max+1] with a non-empty [subr], when the interval at the root of
- [subr] starts exactly at [max+1].) *) *
- Rel.t * Integer.t * 'a
- (** rem * size * value, ie. the value, its size [size] and its alignment
- [rem] relative to the start of the interval. [size] can be:
- - strictly more than [max+1], in which case the value is truncated
- - equal to [max+1]:
- * if [rem] is zero, the value is stored exactly once in the interval
- * otherwise, two truncated instances of the value are stored
- consecutively.
- - strictly less than [max+1]: the value is stored more than once,
- and implicitly repeats itself to fill the entire interval. *) *
- int
- (** tag: hash-consing id of the node, plus an additional boolean.
- Not related to the contents of the tree. *)
+ Integer.t * 'a offsetmap
+ (** subtree on the right: the offset [offr] of its root (relative to 0),
+ and the tree [subr]. [offr] is greater than [max+1] by definition,
+ and equal to it if [subr] is empty. ([offr] may also be equal to
+ [max+1] with a non-empty [subr], when the interval at the root of
+ [subr] starts exactly at [max+1].) *) *
+ Rel.t * Integer.t * 'a
+ (** rem * size * value, ie. the value, its size [size] and its alignment
+ [rem] relative to the start of the interval. [size] can be:
+ - strictly more than [max+1], in which case the value is truncated
+ - equal to [max+1]:
+ * if [rem] is zero, the value is stored exactly once in the interval
+ * otherwise, two truncated instances of the value are stored
+ consecutively.
+ - strictly less than [max+1]: the value is stored more than once,
+ and implicitly repeats itself to fill the entire interval. *) *
+ int
+ (** tag: hash-consing id of the node, plus an additional boolean.
+ Not related to the contents of the tree. *)
(* In a node, the alignment of the value is relative to the start of the
@@ -124,7 +124,7 @@ module Make (V : module type of Offsetmap_lattice_with_isotropy) = struct
| Empty, Node _ -> -1
| Node _, Empty -> 1
| Node (_, _, _, _, _, _, _, _, h1), Node (_, _, _, _, _, _, _, _, h2) ->
- Datatype.Int.compare h1 h2
+ Datatype.Int.compare h1 h2
(* Does not depend on keys. Exported here for convenience for the users *)
let size_from_validity = function
@@ -134,131 +134,131 @@ module Make (V : module type of Offsetmap_lattice_with_isotropy) = struct
| Base.Unknown (_, _, m) -> `Value (Int.succ m)
| Base.Variable { Base.max_allocable } -> `Value (Int.succ max_allocable)
- (** Pretty printing *)
-
- let pretty_offset_aux s curr_off ppf tree =
- if tree == Empty
- then Format.fprintf ppf "@[empty at %a@]" pretty_int curr_off
- else
- let rec pretty_offset s curr_off ppf tree =
- match tree with
- | Empty -> ()
- | Node (max, offl, subl, offr, subr, rem, modu, v, _) ->
- pretty_offset "" (curr_off +~ offl) ppf subl;
- Format.fprintf ppf "@[%s[%a..%a] -> (%a, %a, %a);@]@ "
- s
- pretty_int curr_off
- pretty_int (max +~ curr_off)
- Rel.pretty rem
- pretty_int modu
- V.pretty v;
- pretty_offset "" (curr_off +~ offr) ppf subr;
- in pretty_offset s curr_off ppf tree
- ;;
-
- let _pretty_offset fmt (off, t) =
- Format.fprintf fmt "@[<v><off: %a>@ %a@]"
- pretty_int off (pretty_offset_aux "r" off) t;
- ;;
-
- let pretty fmt t =
- Format.fprintf fmt "@[<v>%a@]" (pretty_offset_aux "r" Integer.zero) t;
- ;;
-
- let pretty_debug_offset fmt (curr_off, tree) =
- let rec aux_pdebug fmt (curr_off, tree) =
- match tree with
- | Empty -> Format.fprintf fmt "empty"
- | Node (max, offl, subl, offr, subr, rem, modu, v, tag) ->
- Format.fprintf fmt "@[<h 2>@[[%a..%a]@ (%a, %a,@ %a){%d,%x}@]@\n@[<h 2>-- \
- %a -->@\n%a@]@\n@[<h 2>-- %a -->@\n%a@]@]"
- pretty_int curr_off
- pretty_int (curr_off +~ max)
- Rel.pretty rem
- pretty_int modu
- V.pretty v
- tag
- (Extlib.address_of_value tree)
- pretty_int offl
- aux_pdebug (curr_off +~ offl, subl)
- pretty_int offr
- aux_pdebug (curr_off +~ offr, subr)
+ (** Pretty printing *)
+
+ let pretty_offset_aux s curr_off ppf tree =
+ if tree == Empty
+ then Format.fprintf ppf "@[empty at %a@]" pretty_int curr_off
+ else
+ let rec pretty_offset s curr_off ppf tree =
+ match tree with
+ | Empty -> ()
+ | Node (max, offl, subl, offr, subr, rem, modu, v, _) ->
+ pretty_offset "" (curr_off +~ offl) ppf subl;
+ Format.fprintf ppf "@[%s[%a..%a] -> (%a, %a, %a);@]@ "
+ s
+ pretty_int curr_off
+ pretty_int (max +~ curr_off)
+ Rel.pretty rem
+ pretty_int modu
+ V.pretty v;
+ pretty_offset "" (curr_off +~ offr) ppf subr;
+ in pretty_offset s curr_off ppf tree
+ ;;
+
+ let _pretty_offset fmt (off, t) =
+ Format.fprintf fmt "@[<v><off: %a>@ %a@]"
+ pretty_int off (pretty_offset_aux "r" off) t;
+ ;;
+
+ let pretty fmt t =
+ Format.fprintf fmt "@[<v>%a@]" (pretty_offset_aux "r" Integer.zero) t;
+ ;;
+
+ let pretty_debug_offset fmt (curr_off, tree) =
+ let rec aux_pdebug fmt (curr_off, tree) =
+ match tree with
+ | Empty -> Format.fprintf fmt "empty"
+ | Node (max, offl, subl, offr, subr, rem, modu, v, tag) ->
+ Format.fprintf fmt "@[<h 2>@[[%a..%a]@ (%a, %a,@ %a){%d,%x}@]@\n@[<h 2>-- \
+ %a -->@\n%a@]@\n@[<h 2>-- %a -->@\n%a@]@]"
+ pretty_int curr_off
+ pretty_int (curr_off +~ max)
+ Rel.pretty rem
+ pretty_int modu
+ V.pretty v
+ tag
+ (Extlib.address_of_value tree)
+ pretty_int offl
+ aux_pdebug (curr_off +~ offl, subl)
+ pretty_int offr
+ aux_pdebug (curr_off +~ offr, subr)
in
- aux_pdebug fmt (curr_off, tree);
- Format.fprintf fmt "@\n";
- ;;
-
- let pretty_debug fmt m = pretty_debug_offset fmt (Integer.zero, m);;
-
-
- include
- (struct
-
- (* This function is almost injective. Can we do better, eg. by mapping Empty
- to 0 and skipping this value for all nodes? And it is worth it? *)
- let hash = function
- | Empty -> 311
- | Node(_,_,_,_,_,_,_,_,tag) -> tag
-
- let rehash_ref = ref (fun _ -> assert false)
- module D = Datatype.Make
- (struct
- type t = V.t offsetmap
- let name = Printf.sprintf "Offsetmap(%s)" V.name
- let reprs = [ Empty ]
- open Structural_descr
- let r = Recursive.create ()
- let structural_descr =
- let p_bint = Datatype.Integer.packed_descr in
- t_sum
- [| [| p_bint;
- p_bint;
- recursive_pack r;
- p_bint;
- recursive_pack r;
- p_bint;
- p_bint;
- V.packed_descr;
- p_int |] |]
- let () = Recursive.update r structural_descr
- let equal = equal
- let hash = hash
- let compare = compare
- let rehash x = !rehash_ref x
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let pretty = pretty
- let varname = Datatype.undefined
- let mem_project = Datatype.never_any_project
- end)
- include D
-
- (* Basic operations on nodes *)
- let m_empty = Empty (* Empty is not exported, and we cannot make it private.
- Instead, we use m_empty to track the places where we
- create something empty *)
- let is_empty t = t == Empty
-
- let equal_internal t1 t2 =
- match t1, t2 with
- | Empty, Empty -> true
- | Node _, Empty | Empty, Node _ -> false
- | Node (max1, offl1, subl1, offr1, subr1, rem1, modu1, v1, _),
+ aux_pdebug fmt (curr_off, tree);
+ Format.fprintf fmt "@\n";
+ ;;
+
+ let pretty_debug fmt m = pretty_debug_offset fmt (Integer.zero, m);;
+
+
+ include
+ (struct
+
+ (* This function is almost injective. Can we do better, eg. by mapping Empty
+ to 0 and skipping this value for all nodes? And it is worth it? *)
+ let hash = function
+ | Empty -> 311
+ | Node(_,_,_,_,_,_,_,_,tag) -> tag
+
+ let rehash_ref = ref (fun _ -> assert false)
+ module D = Datatype.Make
+ (struct
+ type t = V.t offsetmap
+ let name = Printf.sprintf "Offsetmap(%s)" V.name
+ let reprs = [ Empty ]
+ open Structural_descr
+ let r = Recursive.create ()
+ let structural_descr =
+ let p_bint = Datatype.Integer.packed_descr in
+ t_sum
+ [| [| p_bint;
+ p_bint;
+ recursive_pack r;
+ p_bint;
+ recursive_pack r;
+ p_bint;
+ p_bint;
+ V.packed_descr;
+ p_int |] |]
+ let () = Recursive.update r structural_descr
+ let equal = equal
+ let hash = hash
+ let compare = compare
+ let rehash x = !rehash_ref x
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let pretty = pretty
+ let varname = Datatype.undefined
+ let mem_project = Datatype.never_any_project
+ end)
+ include D
+
+ (* Basic operations on nodes *)
+ let m_empty = Empty (* Empty is not exported, and we cannot make it private.
+ Instead, we use m_empty to track the places where we
+ create something empty *)
+ let is_empty t = t == Empty
+
+ let equal_internal t1 t2 =
+ match t1, t2 with
+ | Empty, Empty -> true
+ | Node _, Empty | Empty, Node _ -> false
+ | Node (max1, offl1, subl1, offr1, subr1, rem1, modu1, v1, _),
Node (max2, offl2, subl2, offr2, subr2, rem2, modu2, v2, _)
->
subl1 == subl2 &&
- subr1 == subr2 &&
- offl1 =~ offl2 &&
- offr1 =~ offr2 &&
- V.equal v1 v2 &&
- max1 =~ max2 &&
- Rel.equal rem1 rem2 &&
- modu1 =~ modu2
-
- let hash_internal t =
- match t with
- Empty -> 97
- | Node (max, offl, subl, offr, subr, rem, modu, v, _) ->
+ subr1 == subr2 &&
+ offl1 =~ offl2 &&
+ offr1 =~ offr2 &&
+ V.equal v1 v2 &&
+ max1 =~ max2 &&
+ Rel.equal rem1 rem2 &&
+ modu1 =~ modu2
+
+ let hash_internal t =
+ match t with
+ Empty -> 97
+ | Node (max, offl, subl, offr, subr, rem, modu, v, _) ->
let h = Integer.hash max in
let h = 31 * h + Integer.hash offl in
let h = 31 * h + hash subl in
@@ -269,78 +269,78 @@ module Make (V : module type of Offsetmap_lattice_with_isotropy) = struct
let h = 31 * h + V.hash v in
h
- module NewoHashconsTbl =
- State_builder.Hashconsing_tbl
- (struct
- include D
- let hash_internal = hash_internal
- let equal_internal = equal_internal
- let initial_values = []
- end)
- (struct
- let name = name
- let dependencies = [ Ast.self ]
- let size = 137
- end)
- let () = Ast.add_monotonic_state NewoHashconsTbl.self
-
- let counter = ref 0
-
- let singleton_tag t =
- match t with
- Empty -> min_int
- | Node(_, _, _, _, _, _, _, _, tag) ->
- tag land min_int
-
- let nNode cur offl subl offr subr f g v =
- if debug then assert (Integer.ge cur Integer.zero);
- let current_counter = !counter in
- let tag =
- if V.cardinal_zero_or_one v
- then (singleton_tag subl) land (singleton_tag subr)
- else 0
- in
- let tag = tag lor current_counter in
- let tentative_new_node = Node(cur, offl, subl, offr, subr, f, g, v,tag) in
- let hashed_node = NewoHashconsTbl.merge tentative_new_node in
- if hashed_node == tentative_new_node
- then begin
- if current_counter = max_int
- then Kernel.fatal "Offsetmap(%s): internal maximum exceeded" V.name;
- counter := Stdlib.succ current_counter;
- end;
- hashed_node
-
- let rehash_node x = match x with
- | Empty -> Empty
- | Node _ ->
- NewoHashconsTbl.merge x
-
- let () = rehash_ref := rehash_node
-
- end :
- sig
- include Datatype.S with type t = V.t offsetmap
-
- val m_empty : t
- val hash: t -> int
- val nNode :
- Integer.t ->
- Integer.t -> t ->
- Integer.t -> t ->
- Rel.t -> Integer.t -> V.t ->
- t
- val is_empty : t -> bool
- val singleton_tag : t -> int
- end)
-
- module Cacheable = struct
- type t = Integer.t * V.t offsetmap
- let hash (i, t: t) = Integer.hash i + 37 * hash t
- let equal (i1, t1: t) (i2, t2: t) = t1 == t2 && i1 =~ i2
- let sentinel = Integer.minus_one, m_empty
- end
- let clear_caches_ref = ref []
+ module NewoHashconsTbl =
+ State_builder.Hashconsing_tbl
+ (struct
+ include D
+ let hash_internal = hash_internal
+ let equal_internal = equal_internal
+ let initial_values = []
+ end)
+ (struct
+ let name = name
+ let dependencies = [ Ast.self ]
+ let size = 137
+ end)
+ let () = Ast.add_monotonic_state NewoHashconsTbl.self
+
+ let counter = ref 0
+
+ let singleton_tag t =
+ match t with
+ Empty -> min_int
+ | Node(_, _, _, _, _, _, _, _, tag) ->
+ tag land min_int
+
+ let nNode cur offl subl offr subr f g v =
+ if debug then assert (Integer.ge cur Integer.zero);
+ let current_counter = !counter in
+ let tag =
+ if V.cardinal_zero_or_one v
+ then (singleton_tag subl) land (singleton_tag subr)
+ else 0
+ in
+ let tag = tag lor current_counter in
+ let tentative_new_node = Node(cur, offl, subl, offr, subr, f, g, v,tag) in
+ let hashed_node = NewoHashconsTbl.merge tentative_new_node in
+ if hashed_node == tentative_new_node
+ then begin
+ if current_counter = max_int
+ then Kernel.fatal "Offsetmap(%s): internal maximum exceeded" V.name;
+ counter := Stdlib.succ current_counter;
+ end;
+ hashed_node
+
+ let rehash_node x = match x with
+ | Empty -> Empty
+ | Node _ ->
+ NewoHashconsTbl.merge x
+
+ let () = rehash_ref := rehash_node
+
+ end :
+ sig
+ include Datatype.S with type t = V.t offsetmap
+
+ val m_empty : t
+ val hash: t -> int
+ val nNode :
+ Integer.t ->
+ Integer.t -> t ->
+ Integer.t -> t ->
+ Rel.t -> Integer.t -> V.t ->
+ t
+ val is_empty : t -> bool
+ val singleton_tag : t -> int
+ end)
+
+ module Cacheable = struct
+ type t = Integer.t * V.t offsetmap
+ let hash (i, t: t) = Integer.hash i + 37 * hash t
+ let equal (i1, t1: t) (i2, t2: t) = t1 == t2 && i1 =~ i2
+ let sentinel = Integer.minus_one, m_empty
+ end
+ let clear_caches_ref = ref []
let get_vv node =
@@ -352,13 +352,13 @@ module Make (V : module type of Offsetmap_lattice_with_isotropy) = struct
let _get_v = function
| Empty -> assert false
| Node (_, _, _, _, _, _, _, v, _) ->
- v
+ v
;;
let get_max = function
| Empty -> assert false
| Node (max, _, _, _, _, _, _, _, _) ->
- max
+ max
;;
(* [is_above] provides a static ordering between two adjacent intervals. This
@@ -370,7 +370,7 @@ module Make (V : module type of Offsetmap_lattice_with_isotropy) = struct
- the interval containing 0, if any, is put at the top;
- otherwise, the interval containing the multiple of the largest power of 2
is put at the top.
- This ordering of adjacent intervals is an invariant of the offsetmaps. *)
+ This ordering of adjacent intervals is an invariant of the offsetmaps. *)
let is_above min1 max1 min2 max2 =
if min1 <=~ Integer.zero && max1 >=~ Integer.zero then true
else if min2 <=~ Integer.zero && max2 >=~ Integer.zero then false
@@ -395,454 +395,424 @@ module Make (V : module type of Offsetmap_lattice_with_isotropy) = struct
let rec aux ppf = function
| End -> printf "@ E@."
| Right (o, Node(max, _, _, _, _subr, _, _, _, _),z ) ->
- fprintf ppf "@[<h 2> [%a,%a] R@\n%a@]"
- pretty_int o
- pretty_int (o +~ max)
- aux z
+ fprintf ppf "@[<h 2> [%a,%a] R@\n%a@]"
+ pretty_int o
+ pretty_int (o +~ max)
+ aux z
| Left (o, Node(max, _, _, _, _subr, _, _, _, _),z ) ->
- fprintf ppf "@[<h 2> [%a,%a] L@\n%a@]"
- pretty_int o
- pretty_int (o +~ max)
- aux z
+ fprintf ppf "@[<h 2> [%a,%a] L@\n%a@]"
+ pretty_int o
+ pretty_int (o +~ max)
+ aux z
| Right (_, Empty, _) | Left (_, Empty, _) -> assert false
in aux ppf z;
printf "[/Zipper]---@.@.";
;;
- (** Returns an absolute position and an associated new tree *)
- let rec rezip zipper curr_off node =
- match zipper with
- | End -> curr_off, node
- | Right (offset, Node(max, offl, subl, _offr, _subr, rem, modu, v, _), z)
- ->
- rezip z offset
- (nNode max offl subl (curr_off -~ offset) node rem modu v)
- | Left (offset, Node(max, _offl, _subl, offr, subr, rem, modu, v, _), z)
- ->
- rezip z offset
- (nNode max (curr_off -~ offset) node offr subr rem modu v)
- | Right (_, Empty, _) | Left (_, Empty, _) -> assert false
- ;;
-
- (** Returns an absolute position, a node and a zipper *)
- let rec leftmost_child curr_off zipper node =
- match node with
- | Empty -> raise Empty_tree
- | Node (_, _, Empty, _, _, _, _, _, _) -> curr_off, node, zipper
- | Node (_, offl, subl, _, _, _, _, _, _) ->
- let new_offset = curr_off +~ offl in
- leftmost_child new_offset (Left (curr_off, node, zipper)) subl
- ;;
-
- (** Returns an absolute position, a node and a zipper *)
- let rec rightmost_child curr_off zipper node =
- match node with
- | Empty -> raise Empty_tree
- | Node (_, _, _, _, Empty, _, _, _, _) -> curr_off, node, zipper
- | Node (_, _offl, _subl, offr, subr, _, _, _, _) ->
- let new_offset = curr_off +~ offr in
- rightmost_child new_offset (Right (curr_off, node, zipper)) subr
- ;;
-
- (** Move to the right of the current node.
- Uses a zipper for that.
+ (** Returns an absolute position and an associated new tree *)
+ let rec rezip zipper curr_off node =
+ match zipper with
+ | End -> curr_off, node
+ | Right (offset, Node(max, offl, subl, _offr, _subr, rem, modu, v, _), z)
+ ->
+ rezip z offset
+ (nNode max offl subl (curr_off -~ offset) node rem modu v)
+ | Left (offset, Node(max, _offl, _subl, offr, subr, rem, modu, v, _), z)
+ ->
+ rezip z offset
+ (nNode max (curr_off -~ offset) node offr subr rem modu v)
+ | Right (_, Empty, _) | Left (_, Empty, _) -> assert false
+ ;;
+
+ (** Returns an absolute position, a node and a zipper *)
+ let rec leftmost_child curr_off zipper node =
+ match node with
+ | Empty -> raise Empty_tree
+ | Node (_, _, Empty, _, _, _, _, _, _) -> curr_off, node, zipper
+ | Node (_, offl, subl, _, _, _, _, _, _) ->
+ let new_offset = curr_off +~ offl in
+ leftmost_child new_offset (Left (curr_off, node, zipper)) subl
+ ;;
+
+ (** Returns an absolute position, a node and a zipper *)
+ let rec rightmost_child curr_off zipper node =
+ match node with
+ | Empty -> raise Empty_tree
+ | Node (_, _, _, _, Empty, _, _, _, _) -> curr_off, node, zipper
+ | Node (_, _offl, _subl, offr, subr, _, _, _, _) ->
+ let new_offset = curr_off +~ offr in
+ rightmost_child new_offset (Right (curr_off, node, zipper)) subr
+ ;;
+
+ (** Move to the right of the current node.
+ Uses a zipper for that.
*)
- let move_right curr_off node zipper =
- match node with
- | Node (_, _, _, offr, ((Node _ ) as subr), _, _, _, _) ->
- let new_offset = curr_off +~ offr in
- leftmost_child new_offset (Right (curr_off, node, zipper)) subr
- | Node (_, _, _, _, Empty, _, _, _, _) ->
- begin
- let rec unzip_until_left zipper =
- match zipper with
- | End -> raise End_reached
- | Right (_, _, z) -> unzip_until_left z
- | Left (offset, tree, z) -> offset, tree, z
- in unzip_until_left zipper
- end
- | Empty -> assert false
+ let move_right curr_off node zipper =
+ match node with
+ | Node (_, _, _, offr, ((Node _ ) as subr), _, _, _, _) ->
+ let new_offset = curr_off +~ offr in
+ leftmost_child new_offset (Right (curr_off, node, zipper)) subr
+ | Node (_, _, _, _, Empty, _, _, _, _) ->
+ begin
+ let rec unzip_until_left zipper =
+ match zipper with
+ | End -> raise End_reached
+ | Right (_, _, z) -> unzip_until_left z
+ | Left (offset, tree, z) -> offset, tree, z
+ in unzip_until_left zipper
+ end
+ | Empty -> assert false
+ ;;
+
+ type imp_zipper = {
+ mutable offset: Integer.t;
+ mutable node: t;
+ mutable zipper: zipper;
+ };;
+
+ let imp_move_right imp_z =
+ let o, n, z = move_right imp_z.offset imp_z.node imp_z.zipper in
+ imp_z.offset <- o;
+ imp_z.node <- n;
+ imp_z.zipper <- z;
;;
- type imp_zipper = {
- mutable offset: Integer.t;
- mutable node: t;
- mutable zipper: zipper;
- };;
-
- let imp_move_right imp_z =
- let o, n, z = move_right imp_z.offset imp_z.node imp_z.zipper in
- imp_z.offset <- o;
- imp_z.node <- n;
- imp_z.zipper <- z;
- ;;
-
- (* Minimum and maximum bit bounds in the offsetmap (inclusively), assuming
- that [m] starts at [curr_off]. Usually not required, as we use [validity]
- arguments, that give the size of the offsetmap. Beware that this function
- must not be called on empty offsetmaps. *)
- let bounds_offset curr_off m =
- let rec min curr_off = function
- | Empty -> curr_off (* This bit is bound, unless [m] itself is empty *)
- | Node (_, offl, subl, _, _, _, _, _, _) -> min (curr_off +~ offl) subl
- and max curr_off = function
- | Empty -> pred curr_off (* [curr_off] is not bound, [curr_off-1] is. *)
- | Node (_, _, _, offr, subr, _, _, _, _) -> max (curr_off +~ offr) subr
- in
- assert (m != Empty);
- (min curr_off m, max curr_off m)
-
- let _bounds m = bounds_offset Int.zero m
-
- (** Folding and iterating from the leftmost node to the rightmost one
- If t = n0 fold f t i = f n2 (f n0 (f n1 i))
- / \ iter f t = f n1; fn0; f n2;
- n1 n2
+ (* Minimum and maximum bit bounds in the offsetmap (inclusively), assuming
+ that [m] starts at [curr_off]. Usually not required, as we use [validity]
+ arguments, that give the size of the offsetmap. Beware that this function
+ must not be called on empty offsetmaps. *)
+ let bounds_offset curr_off m =
+ let rec min curr_off = function
+ | Empty -> curr_off (* This bit is bound, unless [m] itself is empty *)
+ | Node (_, offl, subl, _, _, _, _, _, _) -> min (curr_off +~ offl) subl
+ and max curr_off = function
+ | Empty -> pred curr_off (* [curr_off] is not bound, [curr_off-1] is. *)
+ | Node (_, _, _, offr, subr, _, _, _, _) -> max (curr_off +~ offr) subr
+ in
+ assert (m != Empty);
+ (min curr_off m, max curr_off m)
+
+ let _bounds m = bounds_offset Int.zero m
+
+ (** Folding and iterating from the leftmost node to the rightmost one
+ If t = n0 fold f t i = f n2 (f n0 (f n1 i))
+ / \ iter f t = f n1; fn0; f n2;
+ n1 n2
*)
- let fold_offset f o t acc =
- if t = Empty then
- acc
- else
- let o, n, z = leftmost_child o End t in
- let rec aux_fold o t z pre =
- match t with
- | Empty -> pre
- | Node (max, _, _, _, _, r, m, v, _) ->
- let abs_max = max +~ o in
- let now = f (o, abs_max) (v, m, r) pre in
- match move_right o t z with
- | no, nt, nz -> aux_fold no nt nz now
- | exception End_reached -> now
- in
- aux_fold o n z acc
- ;;
-
- let fold f t = fold_offset f Integer.zero t
+ let fold_offset f o t acc =
+ if t = Empty then
+ acc
+ else
+ let o, n, z = leftmost_child o End t in
+ let rec aux_fold o t z pre =
+ match t with
+ | Empty -> pre
+ | Node (max, _, _, _, _, r, m, v, _) ->
+ let abs_max = max +~ o in
+ let now = f (o, abs_max) (v, m, r) pre in
+ match move_right o t z with
+ | no, nt, nz -> aux_fold no nt nz now
+ | exception End_reached -> now
+ in
+ aux_fold o n z acc
+ ;;
+
+ let fold f t = fold_offset f Integer.zero t
+ ;;
+
+ let iter_offset f o t =
+ if t <> Empty then
+ let o, n, z = leftmost_child o End t in
+ let rec aux_iter o t z =
+ match t with
+ | Empty -> ()
+ | Node (max, _, _, _, _, r, m, v, _) ->
+ let abs_max = max +~ o in
+ f (o, abs_max) (v, m, r);
+ match move_right o t z with
+ | no, nt, nz -> aux_iter no nt nz
+ | exception End_reached -> ()
+ in
+ aux_iter o n z
+ ;;
+
+ let iter f t = iter_offset f Integer.zero t
+ ;;
+
+ (* Same as iter, but does not compute offsets (hence more efficient). *)
+ let rec iter_on_values f t =
+ match t with
+ | Empty -> ()
+ | Node (_, _, left, _, right, _, _, v, _) ->
+ iter_on_values f left;
+ f v;
+ iter_on_values f right
+ ;;
+
+ let rec fold_on_values f t acc =
+ match t with
+ | Empty -> acc
+ | Node (_, _, left, _, right, _, _, v, _) ->
+ fold_on_values f right (f v ((fold_on_values f left acc)))
;;
- let iter_offset f o t =
- if t <> Empty then
- let o, n, z = leftmost_child o End t in
- let rec aux_iter o t z =
- match t with
- | Empty -> ()
- | Node (max, _, _, _, _, r, m, v, _) ->
- let abs_max = max +~ o in
- f (o, abs_max) (v, m, r);
- match move_right o t z with
- | no, nt, nz -> aux_iter no nt nz
- | exception End_reached -> ()
- in
- aux_iter o n z
- ;;
-
- let iter f t = iter_offset f Integer.zero t
- ;;
-
- (* Same as iter, but does not compute offsets (hence more efficient). *)
- let rec iter_on_values f t =
- match t with
- | Empty -> ()
- | Node (_, _, left, _, right, _, _, v, _) ->
- iter_on_values f left;
- f v;
- iter_on_values f right
-;;
-
- let rec fold_on_values f t acc =
- match t with
- | Empty -> acc
- | Node (_, _, left, _, right, _, _, v, _) ->
- fold_on_values f right (f v ((fold_on_values f left acc)))
- ;;
-
- (* Two adjacent nodes can be merged into one when:
- - they contains the same value of the same size (thus repeated with the
- same modulo) and the same alignment wrt the offset of the left node
- (thus the alignment of the value in the right node must be converted
- wrt the left offset).
- - and the offset of the right node is aligned with the repeated value:
- the separation does not cut the value, and can safely be removed.
- Otherwise, a separation that cuts a value can only be removed if the
- concretization of the value is a singleton, ensuring that the two parts
- of the value are always consistent. *)
- let are_mergeable_nodes ~left_offset ~left ~right_offset ~right =
- let lrem, lmodu, lv = left
- and rrem, rmodu, rv = right in
- V.equal lv rv && lmodu =~ rmodu &&
- let new_rrem =
- realign ~offset:right_offset ~new_offset:left_offset rrem rmodu
- in
- Rel.equal new_rrem lrem &&
- (Rel.is_zero rrem || V.cardinal_zero_or_one lv)
-
- (** Smart constructor for nodes:
- it glues the node being allocated to potential candidates if needed
- (i.e. leftmost node of right subtree and rightmost node of left subtree),
+ (* Two adjacent nodes can be merged into one when:
+ - they contains the same value of the same size (thus repeated with the
+ same modulo) and the same alignment wrt the offset of the left node
+ (thus the alignment of the value in the right node must be converted
+ wrt the left offset).
+ - and the offset of the right node is aligned with the repeated value:
+ the separation does not cut the value, and can safely be removed.
+ Otherwise, a separation that cuts a value can only be removed if the
+ concretization of the value is a singleton, ensuring that the two parts
+ of the value are always consistent. *)
+ let are_mergeable_nodes ~left_offset ~left ~right_offset ~right =
+ let lrem, lmodu, lv = left
+ and rrem, rmodu, rv = right in
+ V.equal lv rv && lmodu =~ rmodu &&
+ let new_rrem =
+ realign ~offset:right_offset ~new_offset:left_offset rrem rmodu
+ in
+ Rel.equal new_rrem lrem &&
+ (Rel.is_zero rrem || V.cardinal_zero_or_one lv)
+
+ (** Smart constructor for nodes:
+ it glues the node being allocated to potential candidates if needed
+ (i.e. leftmost node of right subtree and rightmost node of left subtree),
*)
- let make_node curr_off max offl subl offr subr rem modu v =
- let rem, modu =
- if V.is_isotropic v
- then Rel.zero, Integer.one
- else rem, modu
- in
- let curr_vv = (rem, modu, v) in
- let max, offr, subr =
- try
- let offset, nr, zr = leftmost_child (curr_off +~ offr) End subr in
- match nr with
- | Node (nmax, _, nsubl , noffr, nsubr, nrem, nmodu, nv, _) ->
- assert (is_empty nsubl);
- let right = nrem, nmodu, nv in
- if are_mergeable_nodes
- ~left_offset:curr_off ~left:curr_vv ~right_offset:offset ~right
- then
- begin
- let curr_offr, new_subr = rezip zr (offset +~ noffr) nsubr in
- let new_max = succ (max +~ nmax) in
- let new_offr = curr_offr -~ curr_off
- in
- new_max, new_offr, new_subr
- end
- else max, offr, subr
- | Empty -> assert false
- with Empty_tree -> max, offr, subr
- in
- if debug then assert (Integer.ge max Integer.zero);
- let curr_off, max, rem, offl, subl, offr =
- try
- let offset, nl, zl =
- rightmost_child (curr_off +~ offl) End subl in
- match nl with
- | Node (nmax, noffl, nsubl , _, noffr, nrem, nmodu, nv, _) ->
- assert (is_empty noffr);
- let left = nrem, nmodu, nv in
- if are_mergeable_nodes
- ~left_offset:offset ~left ~right_offset:curr_off ~right:curr_vv
- then (
- let new_curr_offl, new_subl = rezip zl (offset +~ noffl) nsubl in
- let succ_nmax = succ nmax in
- let lmax = max +~ succ_nmax in
- let new_offl = new_curr_offl -~ offset in
- let new_offr = offr +~ succ_nmax in
- let new_coff = curr_off -~ succ_nmax in
- let rem = realign ~offset:curr_off ~new_offset:offset rem modu in
- (*assert (new_coff =~ offset);*)
- new_coff, lmax, rem, new_offl, new_subl, new_offr)
- else curr_off, max, rem, offl, subl, offr
- |Empty -> assert false
- with Empty_tree -> curr_off, max, rem, offl, subl, offr
- in
- curr_off, nNode max offl subl offr subr rem modu v
- ;;
-
- (* Creates the tree representing the interval [O..span], bound to [v] *)
- let interval_aux span rem modu v =
- let rem, modu =
- if V.is_isotropic v
- then Rel.zero, Integer.one
- else rem, modu
- in
- nNode span Integer.zero m_empty (succ span) m_empty rem modu v
-
- (* creates a fresh tree that binds [0..size-1] to the isotropic value [v].
- if [size] if 0, returns [Empty]. *)
- let isotropic_interval size v =
- if Int.(equal size zero) then Empty
- else
- nNode (pred size) Integer.zero m_empty size m_empty Rel.zero Integer.one v
-
- (** Smart add node:
- Adds a node to the current tree and merges (new) consecutive intervals
- containing the same values
- The node is [min..max] rem, modu, v and
- the tree to which it is added is rooted at offset curr_off
- Hypothesis: the tree is in canonical form w.r.t having no
- mergeable intervals.
+ let make_node curr_off max offl subl offr subr rem modu v =
+ let rem, modu =
+ if V.is_isotropic v
+ then Rel.zero, Integer.one
+ else rem, modu
+ in
+ let curr_vv = (rem, modu, v) in
+ let max, offr, subr =
+ try
+ let offset, nr, zr = leftmost_child (curr_off +~ offr) End subr in
+ match nr with
+ | Node (nmax, _, nsubl , noffr, nsubr, nrem, nmodu, nv, _) ->
+ assert (is_empty nsubl);
+ let right = nrem, nmodu, nv in
+ if are_mergeable_nodes
+ ~left_offset:curr_off ~left:curr_vv ~right_offset:offset ~right
+ then
+ begin
+ let curr_offr, new_subr = rezip zr (offset +~ noffr) nsubr in
+ let new_max = succ (max +~ nmax) in
+ let new_offr = curr_offr -~ curr_off
+ in
+ new_max, new_offr, new_subr
+ end
+ else max, offr, subr
+ | Empty -> assert false
+ with Empty_tree -> max, offr, subr
+ in
+ if debug then assert (Integer.ge max Integer.zero);
+ let curr_off, max, rem, offl, subl, offr =
+ try
+ let offset, nl, zl =
+ rightmost_child (curr_off +~ offl) End subl in
+ match nl with
+ | Node (nmax, noffl, nsubl , _, noffr, nrem, nmodu, nv, _) ->
+ assert (is_empty noffr);
+ let left = nrem, nmodu, nv in
+ if are_mergeable_nodes
+ ~left_offset:offset ~left ~right_offset:curr_off ~right:curr_vv
+ then (
+ let new_curr_offl, new_subl = rezip zl (offset +~ noffl) nsubl in
+ let succ_nmax = succ nmax in
+ let lmax = max +~ succ_nmax in
+ let new_offl = new_curr_offl -~ offset in
+ let new_offr = offr +~ succ_nmax in
+ let new_coff = curr_off -~ succ_nmax in
+ let rem = realign ~offset:curr_off ~new_offset:offset rem modu in
+ (*assert (new_coff =~ offset);*)
+ new_coff, lmax, rem, new_offl, new_subl, new_offr)
+ else curr_off, max, rem, offl, subl, offr
+ |Empty -> assert false
+ with Empty_tree -> curr_off, max, rem, offl, subl, offr
+ in
+ curr_off, nNode max offl subl offr subr rem modu v
+ ;;
+
+ (* Creates the tree representing the interval [O..span], bound to [v] *)
+ let interval_aux span rem modu v =
+ let rem, modu =
+ if V.is_isotropic v
+ then Rel.zero, Integer.one
+ else rem, modu
+ in
+ nNode span Integer.zero m_empty (succ span) m_empty rem modu v
+
+ (* creates a fresh tree that binds [0..size-1] to the isotropic value [v].
+ if [size] if 0, returns [Empty]. *)
+ let isotropic_interval size v =
+ if Int.(equal size zero) then Empty
+ else
+ nNode (pred size) Integer.zero m_empty size m_empty Rel.zero Integer.one v
+
+ (** Smart add node:
+ Adds a node to the current tree and merges (new) consecutive intervals
+ containing the same values
+ The node is [min..max] rem, modu, v and
+ the tree to which it is added is rooted at offset curr_off
+ Hypothesis: the tree is in canonical form w.r.t having no
+ mergeable intervals.
*)
- let add_node ~min ~max rem modu v curr_off tree =
- if debug then assert (min <=~ max);
- let rec aux_add curr_off tree =
- match tree with
- | Empty -> min, interval_aux (max -~ min) rem modu v
- | Node (nmax, noffl, nsubl, noffr, nsubr, nrem, nmodu, nv, _) ->
- let abs_min = curr_off
- and abs_max = nmax +~ curr_off in
- if max <~ abs_min then
- begin
- if is_above min max abs_min abs_max then
- let new_offr = abs_min -~ min in
- (*Format.printf "add to the left above@."; *)
- make_node min (max -~ min) Integer.zero m_empty
- new_offr tree rem modu v
- else
- begin
- (* Format.printf "L@ co:%a@ t:%a@ [%a...%a]@.@."
- pretty_int curr_off
- (pretty_offset curr_off) tree
- pretty_int min pretty_int max
- ; *)
- let new_curr_offl, new_node =
- aux_add (curr_off +~ noffl) nsubl
- in
- let new_offl = new_curr_offl -~ curr_off in
- make_node
- curr_off nmax new_offl new_node noffr nsubr nrem nmodu nv
- end
- end
- else
- begin
- if is_above min max abs_min abs_max then
- begin
- let new_offl = abs_min -~ min in
- let new_max = max -~ min in
- make_node
- min new_max new_offl tree (succ new_max) m_empty rem modu v
- end
- else
- begin
- (* Format.printf "add to the right Not ABOVE@."; *)
- let new_curr_offr, new_node =
- aux_add (curr_off +~ noffr) nsubr
- in
- let new_offr = new_curr_offr -~ abs_min in
- make_node abs_min nmax noffl nsubl new_offr new_node nrem
- nmodu nv
- end
- end
-
- in aux_add curr_off tree
- ;;
-
- (* Bind the interval [min..max] to [v], and append it to the zero-rooted
- map [t]. [rem] and [modu] are inferred by considering that [min..max] binds
- a single value (unless [v] is isotropic) *)
- let append_basic_itv ~min ~max ~v m =
- if V.is_isotropic v then
- snd (add_node ~min ~max Rel.zero Integer.one v Integer.zero(*co*) m)
- else
- let size = Integer.length min max in
- let v = V.anisotropic_cast ~size v in
- snd (add_node ~min ~max Rel.zero size v Integer.zero(*co*) m)
-
- (** Checks that [tree] is sanely built *)
- let rec check_aux curr_off tree =
- match tree with
- | Empty -> ()
- | Node (max, offl, subl, offr, subr, rem, modu, _v, _) ->
- assert (Rel.check ~rem ~modu);
- assert (not (is_empty subl) || Integer.is_zero offl);
- assert (not (is_empty subr) || offr =~ succ max);
- let abs_min = curr_off
- and abs_max = curr_off +~ max in
- let aux offset tree =
- match tree with
- | Empty -> ()
- | Node (nmax, _, _, _, _, _, _, _, _) ->
- let nabs_min = curr_off +~ offset in
- let nabs_max = nmax +~ nabs_min in
- assert (is_above abs_min abs_max nabs_min nabs_max)
- in aux offl subl; aux offr subr;
- check_aux (curr_off +~ offl) subl;
- check_aux (curr_off +~ offr) subr;
- ;;
-
- let _check curr_off tree =
- try check_aux curr_off tree
- with Assert_failure _ as e ->
- Kernel.error "INVALID@.%a@." _pretty_offset (curr_off, tree);
- raise e
-
-
- (** Inclusion functions *)
-
- (* Auxiliary function for inclusion: check that, between [mabs_min] and
- [mabs_max], the values (r1, m1, v1) and (r2, m2, v2), respectively
- bound between (amin1, amax1) and (amin2, amax2), are included. *)
- let is_included_nodes_values (amin1 : Integer.t) (amax1 : Integer.t) r1 m1 v1 amin2 amax2 r2 m2 v2 mabs_min mabs_max =
- if V.is_isotropic v1 || V.is_isotropic v2 then
- V.is_included v1 v2
- else
- let max_test =
- if amax1 <~ amax2
- then (succ mabs_max) %~ m1 =~ r1
- else true
- in
- let ok_min = amin1 =~ amin2 || mabs_min %~ m1 =~ r1
- and ok_max = amax1 =~ amax2 || max_test
- in
- if r1 =~ r2 && m1 =~ m2 && ok_min && ok_max
- then V.is_included v1 v2
- else false
-
- (* Functional for inclusion test. For this function, the equality
- [bounds o1 t1 = bounds o2 t2] does not need to hold. We test the inclusion
- for the range that is common to both trees. *)
- let is_included_aux_cache cache (o1, t1) (o2, t2) =
- match t1, t2 with
- | Empty, _ | _, Empty ->
- true (* no common range. By definition, the inclusion holds *)
- | Node (max1, offl1, subl1, offr1, subr1, r1rel, m1, v1, _),
- Node (max2, offl2, subl2, offr2, subr2, r2rel, m2, v2, _) ->
- let amin1 = o1 in
- let amax1 = max1 +~ o1 in
- let amin2 = o2 in
- let amax2 = max2 +~ o2 in
- let ol1 = o1 +~ offl1 in
- let ol2 = o2 +~ offl2 in
- let or1 = o1 +~ offr1 in
- let or2 = o2 +~ offr2 in
- let r1 = (Rel.add_abs o1 r1rel) %~ m1 in
- let r2 = (Rel.add_abs o2 r2rel) %~ m2 in
- if amax1 <~ amin2 then
- cache (o1, t1) (ol2, subl2) &&
- cache (or1, subr1) (o2, t2)
- else if amin1 >~ amax2 then
- cache (o1, t1) (or2, subr2) &&
- cache (ol1, subl1) (o2, t2)
- else begin (* this node of t2 covers part of the interval of t1 we are
- focused on *)
- if amin1 =~ amin2 then
- let mabs_min = amin1 in
- begin
- (if amax1 =~ amax2 then begin
- (if (r1 =~ r2 && m1 =~ m2) ||
- V.is_isotropic v1 || V.is_isotropic v2
- then V.is_included v1 v2
- else false)
- &&
- cache (or1, subr1) (or2, subr2)
+ let add_node ~min ~max rem modu v curr_off tree =
+ if debug then assert (min <=~ max);
+ let rec aux_add curr_off tree =
+ match tree with
+ | Empty -> min, interval_aux (max -~ min) rem modu v
+ | Node (nmax, noffl, nsubl, noffr, nsubr, nrem, nmodu, nv, _) ->
+ let abs_min = curr_off
+ and abs_max = nmax +~ curr_off in
+ if max <~ abs_min then
+ begin
+ if is_above min max abs_min abs_max then
+ let new_offr = abs_min -~ min in
+ (*Format.printf "add to the left above@."; *)
+ make_node min (max -~ min) Integer.zero m_empty
+ new_offr tree rem modu v
+ else
+ begin
+ (* Format.printf "L@ co:%a@ t:%a@ [%a...%a]@.@."
+ pretty_int curr_off
+ (pretty_offset curr_off) tree
+ pretty_int min pretty_int max
+ ; *)
+ let new_curr_offl, new_node =
+ aux_add (curr_off +~ noffl) nsubl
+ in
+ let new_offl = new_curr_offl -~ curr_off in
+ make_node
+ curr_off nmax new_offl new_node noffr nsubr nrem nmodu nv
end
- else if amax1 >~ amax2 then begin
- is_included_nodes_values
- amin1 amax1 r1 m1 v1
- amin2 amax2 r2 m2 v2 mabs_min amax2
+ end
+ else
+ begin
+ if is_above min max abs_min abs_max then
+ begin
+ let new_offl = abs_min -~ min in
+ let new_max = max -~ min in
+ make_node
+ min new_max new_offl tree (succ new_max) m_empty rem modu v
+ end
+ else
+ begin
+ (* Format.printf "add to the right Not ABOVE@."; *)
+ let new_curr_offr, new_node =
+ aux_add (curr_off +~ noffr) nsubr
+ in
+ let new_offr = new_curr_offr -~ abs_min in
+ make_node abs_min nmax noffl nsubl new_offr new_node nrem
+ nmodu nv
+ end
+ end
+
+ in aux_add curr_off tree
+ ;;
+
+ (* Bind the interval [min..max] to [v], and append it to the zero-rooted
+ map [t]. [rem] and [modu] are inferred by considering that [min..max] binds
+ a single value (unless [v] is isotropic) *)
+ let append_basic_itv ~min ~max ~v m =
+ if V.is_isotropic v then
+ snd (add_node ~min ~max Rel.zero Integer.one v Integer.zero(*co*) m)
+ else
+ let size = Integer.length min max in
+ let v = V.anisotropic_cast ~size v in
+ snd (add_node ~min ~max Rel.zero size v Integer.zero(*co*) m)
+
+ (** Checks that [tree] is sanely built *)
+ let rec check_aux curr_off tree =
+ match tree with
+ | Empty -> ()
+ | Node (max, offl, subl, offr, subr, rem, modu, _v, _) ->
+ assert (Rel.check ~rem ~modu);
+ assert (not (is_empty subl) || Integer.is_zero offl);
+ assert (not (is_empty subr) || offr =~ succ max);
+ let abs_min = curr_off
+ and abs_max = curr_off +~ max in
+ let aux offset tree =
+ match tree with
+ | Empty -> ()
+ | Node (nmax, _, _, _, _, _, _, _, _) ->
+ let nabs_min = curr_off +~ offset in
+ let nabs_max = nmax +~ nabs_min in
+ assert (is_above abs_min abs_max nabs_min nabs_max)
+ in aux offl subl; aux offr subr;
+ check_aux (curr_off +~ offl) subl;
+ check_aux (curr_off +~ offr) subr;
+ ;;
+
+ let _check curr_off tree =
+ try check_aux curr_off tree
+ with Assert_failure _ as e ->
+ Kernel.error "INVALID@.%a@." _pretty_offset (curr_off, tree);
+ raise e
+
+
+ (** Inclusion functions *)
+
+ (* Auxiliary function for inclusion: check that, between [mabs_min] and
+ [mabs_max], the values (r1, m1, v1) and (r2, m2, v2), respectively
+ bound between (amin1, amax1) and (amin2, amax2), are included. *)
+ let is_included_nodes_values (amin1 : Integer.t) (amax1 : Integer.t) r1 m1 v1 amin2 amax2 r2 m2 v2 mabs_min mabs_max =
+ if V.is_isotropic v1 || V.is_isotropic v2 then
+ V.is_included v1 v2
+ else
+ let max_test =
+ if amax1 <~ amax2
+ then (succ mabs_max) %~ m1 =~ r1
+ else true
+ in
+ let ok_min = amin1 =~ amin2 || mabs_min %~ m1 =~ r1
+ and ok_max = amax1 =~ amax2 || max_test
+ in
+ if r1 =~ r2 && m1 =~ m2 && ok_min && ok_max
+ then V.is_included v1 v2
+ else false
+
+ (* Functional for inclusion test. For this function, the equality
+ [bounds o1 t1 = bounds o2 t2] does not need to hold. We test the inclusion
+ for the range that is common to both trees. *)
+ let is_included_aux_cache cache (o1, t1) (o2, t2) =
+ match t1, t2 with
+ | Empty, _ | _, Empty ->
+ true (* no common range. By definition, the inclusion holds *)
+ | Node (max1, offl1, subl1, offr1, subr1, r1rel, m1, v1, _),
+ Node (max2, offl2, subl2, offr2, subr2, r2rel, m2, v2, _) ->
+ let amin1 = o1 in
+ let amax1 = max1 +~ o1 in
+ let amin2 = o2 in
+ let amax2 = max2 +~ o2 in
+ let ol1 = o1 +~ offl1 in
+ let ol2 = o2 +~ offl2 in
+ let or1 = o1 +~ offr1 in
+ let or2 = o2 +~ offr2 in
+ let r1 = (Rel.add_abs o1 r1rel) %~ m1 in
+ let r2 = (Rel.add_abs o2 r2rel) %~ m2 in
+ if amax1 <~ amin2 then
+ cache (o1, t1) (ol2, subl2) &&
+ cache (or1, subr1) (o2, t2)
+ else if amin1 >~ amax2 then
+ cache (o1, t1) (or2, subr2) &&
+ cache (ol1, subl1) (o2, t2)
+ else begin (* this node of t2 covers part of the interval of t1 we are
+ focused on *)
+ if amin1 =~ amin2 then
+ let mabs_min = amin1 in
+ begin
+ (if amax1 =~ amax2 then begin
+ (if (r1 =~ r2 && m1 =~ m2) ||
+ V.is_isotropic v1 || V.is_isotropic v2
+ then V.is_included v1 v2
+ else false)
&&
- cache (o1, t1) (or2, subr2)
+ cache (or1, subr1) (or2, subr2)
end
- else
- begin (* amax1 <~ amax2 *)
- is_included_nodes_values
- amin1 amax1 r1 m1 v1
- amin2 amax2 r2 m2 v2 mabs_min amax1
- &&
- cache (or1, subr1) (o2, t2)
- end
- ) &&
- cache (ol1, subl1) (ol2, subl2)
- end
- else
- (* treat the common interval and the right parts of the trees.
- The common interval starts at [mabs_min] and goes up to
- [min amax1 amax2]. *)
- let treat_current_right_nodes mabs_min =
- if amax1 =~ amax2 then begin
- is_included_nodes_values
- amin1 amax1 r1 m1 v1
- amin2 amax2 r2 m2 v2 mabs_min amax1
- &&
- cache (or1, subr1) (or2, subr2)
- end
else if amax1 >~ amax2 then begin
is_included_nodes_values
amin1 amax1 r1 m1 v1
@@ -857,202 +827,232 @@ module Make (V : module type of Offsetmap_lattice_with_isotropy) = struct
amin2 amax2 r2 m2 v2 mabs_min amax1
&&
cache (or1, subr1) (o2, t2)
- end;
- in
- (* Find the beginning of the common part of the two intervals (ie.
- [mabs_min] above, which is by definition [max amin1 amin2]), and
- treat this interval and the right trees. Then, check the inclusion
- of the subtree that starts just before [mabs_min] with the
- entire other tree. *)
- if amin1 >~ amin2 then begin
- treat_current_right_nodes amin1 &&
- cache (ol1, subl1) (o2, t2)
- end
- else begin (* amin1 <~ amin2 *)
- treat_current_right_nodes amin2 &&
- cache (o1, t1) (ol2, subl2)
- end
- end
- ;;
-
- module IsIncludedCache = Binary_cache.Binary_Predicate(Cacheable)(Cacheable)
- let () = clear_caches_ref := IsIncludedCache.clear :: !clear_caches_ref;;
-
- let rec is_included_aux t1 t2 =
- Cacheable.equal t1 t2 ||
- is_included_aux_cache (IsIncludedCache.merge is_included_aux) t1 t2
-
- let is_included t1 t2 =
- is_included_aux (Integer.zero, t1) (Integer.zero, t2)
- ;;
-
- (** Joins two trees with no overlapping intervals. *)
-
- let rec union t1_curr_off t1 t2_curr_off t2 =
- (* Format.printf "Union t1:%a t2:%a@."
- (pretty_offset t1_curr_off) t1
- (pretty_offset t2_curr_off) t2;
- *)
- match t1, t2 with
- | Empty, Empty ->
- assert (t1_curr_off =~ t2_curr_off);
- t1_curr_off, t1
- | Empty, Node _ -> t2_curr_off, t2
- | Node _, Empty -> t1_curr_off, t1
- | Node (lmax, loffl, lsubl, loffr, lsubr, lrem, lmodu, lv, _),
- Node (rmax, roffl, rsubl, roffr, rsubr, rrem, rmodu, rv, _) ->
- let labs_min = t1_curr_off
- and labs_max = lmax +~ t1_curr_off
- and rabs_min = t2_curr_off
- and rabs_max = rmax +~ t2_curr_off
- in
- if is_above labs_min labs_max rabs_min rabs_max
- then
- (* t2 is on the right of t1 *)
- let new_curr_offr, new_subr =
- union (t1_curr_off +~ loffr) lsubr t2_curr_off t2
- in
- make_node t1_curr_off lmax loffl lsubl
- (new_curr_offr -~ t1_curr_off) new_subr lrem lmodu lv
- else
- begin
- (* t1 is on the left of t2 *)
- (* assert (is_above rabs_min rabs_max labs_min labs_max); *)
- let new_curr_offl, new_subl =
- union t1_curr_off t1 (t2_curr_off +~ roffl) rsubl
- in
- make_node t2_curr_off rmax
- (new_curr_offl -~ t2_curr_off) new_subl roffr rsubr
- rrem rmodu rv
- end
- ;;
-
- (** Merge two trees that span the same range. This function is a functional:
- [cache] must be used for recursive calls on subtrees.
- [f_aux] is the function that merges the intervals point-wise. *)
- let merge cache f_aux (o1, t1) (o2, t2) =
- if debug then (* the two trees must span the exact same range. *)
- assert ((t1 == Empty && t2 == Empty && o1 =~ o2) ||
- let ib1, ie1 = bounds_offset o1 t1 in
- let ib2, ie2 = bounds_offset o2 t2 in
- ib1 =~ ib2 && ie1 =~ ie2);
- match t1, t2 with
- | Empty, Empty -> o1, t1
- | Node _, Empty -> assert false
- | Empty, Node _ -> assert false
- | Node (max1, offl1, subl1, offr1, subr1, rem1, modu1, v1, _),
- Node (max2, offl2, subl2, offr2, subr2, rem2, modu2, v2, _) ->
- let abs_min1 = o1
- and abs_max1 = max1 +~ o1
- and abs_min2 = o2
- and abs_max2 = max2 +~ o2
- in
- if debug then assert (abs_min2 <=~ abs_max1 && abs_min1 <=~ abs_max2);
- (* here n1 \inter n2 <> \emptyset, given the invariants on offsetmaps
- shape and the fact that both trees cover the same range.
- - compute the intersection interval: middle_abs_min, middle_abs_max
- - recompute the alignment of the values wrt middle_abs_min
- (named middle_rem1 and middle_rem2)
- - add the rest of the nodes to their left/right subtree
- depending on the size of the node
- - add the new node in the merged left subtree
- and plug the merged right tree in
- *)
- let (curr_offl, left_t), middle_abs_min, middle_rem1, middle_rem2 =
- let abs_offl1 = o1 +~ offl1
- and abs_offl2 = o2 +~ offl2 in
- if abs_min1 =~ abs_min2 then
- cache (abs_offl1, subl1) (abs_offl2, subl2), abs_min1, rem1, rem2
- else if abs_min1 <~ abs_min2 then
- let new_offl1, new_subl1 =
- add_node ~min:abs_min1 ~max:(pred abs_min2)
- rem1 modu1 v1 abs_offl1 subl1
- in
- let new_rem1 = realign ~offset:o1 ~new_offset:o2 rem1 modu1 in
- cache (new_offl1, new_subl1) (abs_offl2, subl2),
- abs_min2, new_rem1, rem2
- else
- begin (* abs_min1 >~ abs_min2 *)
- let new_offl2, new_subl2 =
- add_node ~min:abs_min2 ~max:(pred abs_min1) rem2 modu2
- v2 abs_offl2 subl2
- in
- let new_rem2 = realign ~offset:o2 ~new_offset:o1 rem2 modu2 in
- cache (abs_offl1, subl1) (new_offl2, new_subl2),
- abs_min1, rem1, new_rem2
- end
- in
- let (curr_offr, right_t), middle_abs_max =
- let abs_offr1 = o1 +~ offr1
- and abs_offr2 = o2 +~ offr2 in
- if abs_max1 =~ abs_max2 then
- cache (abs_offr1, subr1) (abs_offr2, subr2), abs_max1
- else if abs_max1 <~ abs_max2 then
- let min = succ abs_max1 in
- let rem2 = realign ~offset:o2 ~new_offset:min rem2 modu2 in
- let new_offr2, new_subr2 =
- add_node ~min ~max:abs_max2 rem2 modu2 v2 abs_offr2 subr2
- in
- cache (abs_offr1, subr1) (new_offr2, new_subr2), abs_max1
- else
- begin (* abs_max1 >~ abs_max2 *)
- let min = succ abs_max2 in
- let rem1 = Rel.e_rem (Rel.add (Rel.sub_abs o1 min) rem1) modu1 in
- let new_offr1, new_subr1 =
- add_node ~min ~max:abs_max1 rem1 modu1 v1 abs_offr1 subr1
- in
- cache (new_offr1, new_subr1) (abs_offr2, subr2), abs_max2
- end
- in
- let rem, modu, v =
- f_aux middle_abs_min
- middle_abs_max middle_rem1 modu1 v1 middle_rem2 modu2 v2
- in
- let curr_offl, left_t =
- add_node ~min:middle_abs_min ~max:middle_abs_max
- rem modu v curr_offl left_t
- in union curr_offl left_t curr_offr right_t
- ;;
-
- let rec map_on_values_aux f curr_off t =
- match t with
- | Empty -> curr_off, t
- | Node (max, offl, subl, offr, subr, rem, modu, v, _) ->
- let v' = f v in
- let offl', l' = map_on_values_aux f (curr_off +~ offl) subl in
- let offr', r' = map_on_values_aux f (curr_off +~ offr) subr in
- if l' == subl && r' == subr && V.equal v v'
- then curr_off, t
- else
- make_node
- curr_off max (offl' -~ curr_off) l' (offr' -~ curr_off) r' rem modu v'
- ;;
-
- let map_on_values f t = snd (map_on_values_aux f Int.zero t);;
-
- let extract_bits ~start ~stop ~modu v =
- assert (start <=~ stop && stop <=~ modu);
- let start,stop =
- if Cil.theMachine.Cil.theMachine.Cil_types.little_endian then
- start,stop
- else
- let mmodu = pred modu in
- mmodu -~ stop, mmodu -~ start
- in
- V.extract_bits ~start ~stop ~size:modu v
- ;;
-
- let merge_bits ~topify ~conflate_bottom ~offset ~length ~value ~total_length acc =
- assert (length +~ offset <=~ total_length);
- let offset =
- if Cil.theMachine.Cil.theMachine.Cil_types.little_endian then
- offset
- else
- Int.sub (Int.sub total_length offset) length
- in
- let value = V.shift_bits ~topify ~size:length ~offset value in
- V.merge_distinct_bits ~topify ~conflate_bottom value acc
- ;;
+ end
+ ) &&
+ cache (ol1, subl1) (ol2, subl2)
+ end
+ else
+ (* treat the common interval and the right parts of the trees.
+ The common interval starts at [mabs_min] and goes up to
+ [min amax1 amax2]. *)
+ let treat_current_right_nodes mabs_min =
+ if amax1 =~ amax2 then begin
+ is_included_nodes_values
+ amin1 amax1 r1 m1 v1
+ amin2 amax2 r2 m2 v2 mabs_min amax1
+ &&
+ cache (or1, subr1) (or2, subr2)
+ end
+ else if amax1 >~ amax2 then begin
+ is_included_nodes_values
+ amin1 amax1 r1 m1 v1
+ amin2 amax2 r2 m2 v2 mabs_min amax2
+ &&
+ cache (o1, t1) (or2, subr2)
+ end
+ else
+ begin (* amax1 <~ amax2 *)
+ is_included_nodes_values
+ amin1 amax1 r1 m1 v1
+ amin2 amax2 r2 m2 v2 mabs_min amax1
+ &&
+ cache (or1, subr1) (o2, t2)
+ end;
+ in
+ (* Find the beginning of the common part of the two intervals (ie.
+ [mabs_min] above, which is by definition [max amin1 amin2]), and
+ treat this interval and the right trees. Then, check the inclusion
+ of the subtree that starts just before [mabs_min] with the
+ entire other tree. *)
+ if amin1 >~ amin2 then begin
+ treat_current_right_nodes amin1 &&
+ cache (ol1, subl1) (o2, t2)
+ end
+ else begin (* amin1 <~ amin2 *)
+ treat_current_right_nodes amin2 &&
+ cache (o1, t1) (ol2, subl2)
+ end
+ end
+ ;;
+
+ module IsIncludedCache = Binary_cache.Binary_Predicate(Cacheable)(Cacheable)
+ let () = clear_caches_ref := IsIncludedCache.clear :: !clear_caches_ref;;
+
+ let rec is_included_aux t1 t2 =
+ Cacheable.equal t1 t2 ||
+ is_included_aux_cache (IsIncludedCache.merge is_included_aux) t1 t2
+
+ let is_included t1 t2 =
+ is_included_aux (Integer.zero, t1) (Integer.zero, t2)
+ ;;
+
+ (** Joins two trees with no overlapping intervals. *)
+
+ let rec union t1_curr_off t1 t2_curr_off t2 =
+ (* Format.printf "Union t1:%a t2:%a@."
+ (pretty_offset t1_curr_off) t1
+ (pretty_offset t2_curr_off) t2;
+ *)
+ match t1, t2 with
+ | Empty, Empty ->
+ assert (t1_curr_off =~ t2_curr_off);
+ t1_curr_off, t1
+ | Empty, Node _ -> t2_curr_off, t2
+ | Node _, Empty -> t1_curr_off, t1
+ | Node (lmax, loffl, lsubl, loffr, lsubr, lrem, lmodu, lv, _),
+ Node (rmax, roffl, rsubl, roffr, rsubr, rrem, rmodu, rv, _) ->
+ let labs_min = t1_curr_off
+ and labs_max = lmax +~ t1_curr_off
+ and rabs_min = t2_curr_off
+ and rabs_max = rmax +~ t2_curr_off
+ in
+ if is_above labs_min labs_max rabs_min rabs_max
+ then
+ (* t2 is on the right of t1 *)
+ let new_curr_offr, new_subr =
+ union (t1_curr_off +~ loffr) lsubr t2_curr_off t2
+ in
+ make_node t1_curr_off lmax loffl lsubl
+ (new_curr_offr -~ t1_curr_off) new_subr lrem lmodu lv
+ else
+ begin
+ (* t1 is on the left of t2 *)
+ (* assert (is_above rabs_min rabs_max labs_min labs_max); *)
+ let new_curr_offl, new_subl =
+ union t1_curr_off t1 (t2_curr_off +~ roffl) rsubl
+ in
+ make_node t2_curr_off rmax
+ (new_curr_offl -~ t2_curr_off) new_subl roffr rsubr
+ rrem rmodu rv
+ end
+ ;;
+
+ (** Merge two trees that span the same range. This function is a functional:
+ [cache] must be used for recursive calls on subtrees.
+ [f_aux] is the function that merges the intervals point-wise. *)
+ let merge cache f_aux (o1, t1) (o2, t2) =
+ if debug then (* the two trees must span the exact same range. *)
+ assert ((t1 == Empty && t2 == Empty && o1 =~ o2) ||
+ let ib1, ie1 = bounds_offset o1 t1 in
+ let ib2, ie2 = bounds_offset o2 t2 in
+ ib1 =~ ib2 && ie1 =~ ie2);
+ match t1, t2 with
+ | Empty, Empty -> o1, t1
+ | Node _, Empty -> assert false
+ | Empty, Node _ -> assert false
+ | Node (max1, offl1, subl1, offr1, subr1, rem1, modu1, v1, _),
+ Node (max2, offl2, subl2, offr2, subr2, rem2, modu2, v2, _) ->
+ let abs_min1 = o1
+ and abs_max1 = max1 +~ o1
+ and abs_min2 = o2
+ and abs_max2 = max2 +~ o2
+ in
+ if debug then assert (abs_min2 <=~ abs_max1 && abs_min1 <=~ abs_max2);
+ (* here n1 \inter n2 <> \emptyset, given the invariants on offsetmaps
+ shape and the fact that both trees cover the same range.
+ - compute the intersection interval: middle_abs_min, middle_abs_max
+ - recompute the alignment of the values wrt middle_abs_min
+ (named middle_rem1 and middle_rem2)
+ - add the rest of the nodes to their left/right subtree
+ depending on the size of the node
+ - add the new node in the merged left subtree
+ and plug the merged right tree in
+ *)
+ let (curr_offl, left_t), middle_abs_min, middle_rem1, middle_rem2 =
+ let abs_offl1 = o1 +~ offl1
+ and abs_offl2 = o2 +~ offl2 in
+ if abs_min1 =~ abs_min2 then
+ cache (abs_offl1, subl1) (abs_offl2, subl2), abs_min1, rem1, rem2
+ else if abs_min1 <~ abs_min2 then
+ let new_offl1, new_subl1 =
+ add_node ~min:abs_min1 ~max:(pred abs_min2)
+ rem1 modu1 v1 abs_offl1 subl1
+ in
+ let new_rem1 = realign ~offset:o1 ~new_offset:o2 rem1 modu1 in
+ cache (new_offl1, new_subl1) (abs_offl2, subl2),
+ abs_min2, new_rem1, rem2
+ else
+ begin (* abs_min1 >~ abs_min2 *)
+ let new_offl2, new_subl2 =
+ add_node ~min:abs_min2 ~max:(pred abs_min1) rem2 modu2
+ v2 abs_offl2 subl2
+ in
+ let new_rem2 = realign ~offset:o2 ~new_offset:o1 rem2 modu2 in
+ cache (abs_offl1, subl1) (new_offl2, new_subl2),
+ abs_min1, rem1, new_rem2
+ end
+ in
+ let (curr_offr, right_t), middle_abs_max =
+ let abs_offr1 = o1 +~ offr1
+ and abs_offr2 = o2 +~ offr2 in
+ if abs_max1 =~ abs_max2 then
+ cache (abs_offr1, subr1) (abs_offr2, subr2), abs_max1
+ else if abs_max1 <~ abs_max2 then
+ let min = succ abs_max1 in
+ let rem2 = realign ~offset:o2 ~new_offset:min rem2 modu2 in
+ let new_offr2, new_subr2 =
+ add_node ~min ~max:abs_max2 rem2 modu2 v2 abs_offr2 subr2
+ in
+ cache (abs_offr1, subr1) (new_offr2, new_subr2), abs_max1
+ else
+ begin (* abs_max1 >~ abs_max2 *)
+ let min = succ abs_max2 in
+ let rem1 = Rel.e_rem (Rel.add (Rel.sub_abs o1 min) rem1) modu1 in
+ let new_offr1, new_subr1 =
+ add_node ~min ~max:abs_max1 rem1 modu1 v1 abs_offr1 subr1
+ in
+ cache (new_offr1, new_subr1) (abs_offr2, subr2), abs_max2
+ end
+ in
+ let rem, modu, v =
+ f_aux middle_abs_min
+ middle_abs_max middle_rem1 modu1 v1 middle_rem2 modu2 v2
+ in
+ let curr_offl, left_t =
+ add_node ~min:middle_abs_min ~max:middle_abs_max
+ rem modu v curr_offl left_t
+ in union curr_offl left_t curr_offr right_t
+ ;;
+
+ let rec map_on_values_aux f curr_off t =
+ match t with
+ | Empty -> curr_off, t
+ | Node (max, offl, subl, offr, subr, rem, modu, v, _) ->
+ let v' = f v in
+ let offl', l' = map_on_values_aux f (curr_off +~ offl) subl in
+ let offr', r' = map_on_values_aux f (curr_off +~ offr) subr in
+ if l' == subl && r' == subr && V.equal v v'
+ then curr_off, t
+ else
+ make_node
+ curr_off max (offl' -~ curr_off) l' (offr' -~ curr_off) r' rem modu v'
+ ;;
+
+ let map_on_values f t = snd (map_on_values_aux f Int.zero t);;
+
+ let extract_bits ~start ~stop ~modu v =
+ assert (start <=~ stop && stop <=~ modu);
+ let start,stop =
+ if Cil.theMachine.Cil.theMachine.Cil_types.little_endian then
+ start,stop
+ else
+ let mmodu = pred modu in
+ mmodu -~ stop, mmodu -~ start
+ in
+ V.extract_bits ~start ~stop ~size:modu v
+ ;;
+
+ let merge_bits ~topify ~conflate_bottom ~offset ~length ~value ~total_length acc =
+ assert (length +~ offset <=~ total_length);
+ let offset =
+ if Cil.theMachine.Cil.theMachine.Cil_types.little_endian then
+ offset
+ else
+ Int.sub (Int.sub total_length offset) length
+ in
+ let value = V.shift_bits ~topify ~size:length ~offset value in
+ V.merge_distinct_bits ~topify ~conflate_bottom value acc
+ ;;
(*
[offset] is the offset where the read has begun (ie the global read start).
@@ -1060,776 +1060,776 @@ module Make (V : module type of Offsetmap_lattice_with_isotropy) = struct
[curr_off] and [(rem, modu, v)] refer to the current node to be read.
[acc] is the current state of accumulated reads.
*)
- let extract_bits_and_stitch ~topify ~conflate_bottom ~offset ~size curr_off (rem, modu, v) max acc =
- let rem = (Rel.add_abs curr_off rem) %~ modu in
- let r =
- let abs_max = curr_off +~ max in
- (* last bit to be read,
- be it in the current node or one of its successors *)
- let max_bit = pred (offset +~ size) in
- (* for this function, [min >= offset && min >= curr_off] holds *)
- let extract_single_step min acc =
- assert (not (V.is_isotropic v));
- let interval_offset = min -~ offset in
- let start = (min -~ rem) %~ modu in
- let modu_end = if rem =~ Integer.zero then pred modu else pred rem in
- (* where do we stop reading ?
- either at the end of the current slice (round_up_to_r min) or
- at the end of the interval (abs_max)
- *)
- let read_end =
- Integer.min
- (Integer.min (Integer.round_up_to_r ~min ~r:modu_end ~modu) abs_max)
- max_bit
- in
- let stop = (read_end -~ rem) %~ modu in
-(* Format.printf "Single step: interval offset %a length %a \
- start %a stop %a total length %a offset %a max bit %a\
- @\n current offset %a Rem %a modu %a V %a@."
- pretty_int interval_offset pretty_int (Integer.length start stop)
- pretty_int start pretty_int stop pretty_int size
- pretty_int offset pretty_int max_bit
- pretty_int curr_off pretty_int rem pretty_int modu V.pretty v ; *)
- (* we ignore the 'inform' information here (and everywhere else in
- this module, since we do not propagate it), because it is mostly
- redundant with the 'origin' information in garbled mix *)
- let _inform, read_bits = extract_bits ~topify ~start ~stop ~modu v in
- (* Format.printf "After single step: read bits %a@." V.pretty read_bits; *)
- let result =
- merge_bits ~topify ~conflate_bottom
- ~offset:interval_offset ~length:(Integer.length start stop)
- ~value:read_bits ~total_length:size acc
- in
- (* Format.printf "After merge_bits: result %a@." V.pretty result; *)
- read_end, result
- in
- let start = Integer.max offset curr_off
- and stop = Integer.min max_bit abs_max in
- if V.is_isotropic v then
- let offset = start -~ offset in
- merge_bits ~topify ~conflate_bottom
- ~offset ~length:(Integer.length start stop)
- ~value:v ~total_length:size acc
- else
- let start_point = ref start in
- let acc = ref acc in
- while !start_point <=~ stop do
- let read_end, result = extract_single_step !start_point !acc in
- acc := result;
- start_point := succ read_end;
- done;
- !acc;
- in
- (* Format.printf "extract_bits_and_stitch istart@ %a@ size %a\
- coff %a abs_max -- val %a@\n acc %a res %a@."
- pretty_int offset pretty_int size pretty_int curr_off
- (\* pretty_int (curr_off +~ (get_max node)) *\)
- V.pretty v V.pretty acc V.pretty r; *)
- r
- ;;
-
-
- (** Auxiliary function to join 2 trees with {!merge} above. The merge on two
- values is done by [merge_v]. Since this function can be [V.widen], the
- left/right order of arguments must be preserved. When [merge_v] is
- narrow, it is important that [extract_bits_and_stitch] be canonical
- enough -- or that {!V.narrow} handles differences in representations
- soundly. *)
- let f_aux_merge_generic merge_v abs_min abs_max rem1 modu1 v1 rem2 modu2 v2 =
- if Rel.equal rem1 rem2 && modu1 =~ modu2
- then
- rem1, modu1, V.anisotropic_cast modu1 (merge_v modu1 v1 v2)
- (* Format.printf "f_aux_merge: [%a, %a]@.(%a %a %a)@.(%a %a %a)@."
- pretty_int abs_min pretty_int abs_max pretty_int rem1 pretty_int
- modu1 V.pretty v1 pretty_int rem2 pretty_int modu2 V.pretty v2 ; *)
- else
- let topify = Origin.K_Merge in
- let offset = abs_min in
- let size = Integer.length abs_min abs_max in
- let v1_fit = modu1 =~ size && Rel.is_zero rem1
- and v2_fit = modu2 =~ size && Rel.is_zero rem2 in
- let v1', v2' =
- if (V.is_isotropic v1 || v1_fit) && (V.is_isotropic v2 || v2_fit)
- then v1, v2
- else
- let reinterpret_bits x =
- extract_bits_and_stitch ~topify ~conflate_bottom:false
- ~offset ~size offset x abs_max V.merge_neutral_element
- in
- reinterpret_bits (rem1, modu1, v1),
- reinterpret_bits (rem2, modu2, v2)
- in
- (* The values were already aligned with the offset or have been
- reinterpreted, so the alignment is always zero here. *)
- let rem = Rel.zero in
-(* Format.printf "1: (%a, %a, %a);@.2: (%a, %a, %a);@.[%a--%a] -> %a/%a@."
- pretty_int rem1 pretty_int modu1 V.pretty v1
- pretty_int rem2 pretty_int modu2 V.pretty v2
- pretty_int abs_min pretty_int abs_max
- V.pretty v1' V.pretty v2'; *)
- rem, size, merge_v size v1' v2'
- ;;
-
- (* similar to [f_aux_merge_generic], but we perform a reinterpretation in
- all cases. This is to ensure that [V.narrow] can be applied soundly. *)
- let f_aux_merge_narrow merge_v abs_min abs_max rem1 modu1 v1 rem2 modu2 v2 =
- let topify = Origin.K_Merge in
- let offset = abs_min in
- let size = Integer.length abs_min abs_max in
- let v1' =
- extract_bits_and_stitch ~topify ~conflate_bottom:false
- ~offset ~size offset (rem1, modu1, v1) abs_max V.merge_neutral_element
- in
- let v2' =
- extract_bits_and_stitch ~topify ~conflate_bottom:false
- ~offset ~size offset (rem2, modu2, v2) abs_max V.merge_neutral_element
- in
- Rel.zero, size, (merge_v size v1' v2': v)
- ;;
-
-
- (** More efficient version of {!f_aux_merge_generic}, specialized for
- join-like functions. When one of the values is isotropic, we do not
- concretize the other one with {!extract_stitch_and_bits}. Instead,
- we implicitly "extend" the isotropic value to the full range,
- and merge on the whole range. This does not work with narrow, because
- [narrow {0} {1,2}] on the first bit is {0}, but the intersection
- of the two sets is bottom. *)
- let f_aux_merge_join merge_v abs_min abs_max rem1 modu1 v1 rem2 modu2 v2 =
- let joined size v1 v2 = V.anisotropic_cast size (merge_v size v1 v2) in
- if V.is_isotropic v2 then
- rem1, modu1, joined modu1 v1 v2
- else if V.is_isotropic v1 then
- rem2, modu2, joined modu2 v1 v2
- else
- f_aux_merge_generic merge_v abs_min abs_max rem1 modu1 v1 rem2 modu2 v2
- ;;
-
-
- module JoinCache = Binary_cache.Symmetric_Binary(Cacheable)(Cacheable)
- let () = clear_caches_ref := JoinCache.clear :: !clear_caches_ref;;
-
- (** Joining two trees that cover the same range *)
- let join t1 t2 =
- let f_join = f_aux_merge_join (fun _size v1 v2 -> V.join v1 v2) in
- let rec aux_cache t1 t2 =
- if Cacheable.equal t1 t2 then t1
- else JoinCache.merge (merge aux_cache f_join) t1 t2
- in
- let _, r = aux_cache (Integer.zero, t1) (Integer.zero, t2) in
- r
- ;;
-
- module Make_Narrow(X: sig
- include Lattice_type.With_Top with type t := V.t
- include Lattice_type.With_Narrow with type t := V.t
- end) =
- struct
-
- module NarrowCache = Binary_cache.Symmetric_Binary(Cacheable)(Cacheable)
- module NarrowReinterpretCache =
- Binary_cache.Symmetric_Binary(Cacheable)(Cacheable)
- let () = clear_caches_ref :=
- NarrowReinterpretCache.clear :: NarrowCache.clear :: !clear_caches_ref;;
-
- let is_top = function
- | Node (_, _, Empty, _, Empty, _ , _, v, _) -> V.equal v X.top
- | _ -> false
-
- (** Narrowing two trees that cover the same range *)
- let narrow t1 t2 =
- let f_join = f_aux_merge_generic (fun _size v1 v2 -> X.narrow v1 v2) in
- let rec aux_cache t1 t2 =
- if Cacheable.equal t1 t2 || is_top (snd t2) then t1
- else if is_top (snd t1) then t2
- else NarrowCache.merge (merge aux_cache f_join) t1 t2
- in
- let _, r = aux_cache (Integer.zero, t1) (Integer.zero, t2) in
- r
- ;;
-
- let narrow_reinterpret t1 t2 =
- let f_join = f_aux_merge_narrow (fun _size v1 v2 -> X.narrow v1 v2) in
- let rec aux_cache t1 t2 =
- if Cacheable.equal t1 t2 || is_top (snd t2) then t1
- else if is_top (snd t1) then t2
- else NarrowReinterpretCache.merge (merge aux_cache f_join) t1 t2
- in
- let _, r = aux_cache (Integer.zero, t1) (Integer.zero, t2) in
- r
- ;;
-
- end
-
- let widen wh t1 t2 =
- (* Due to the way f_aux_merge is designed, we can obtain intervals on which
- the two bindings do not verify [is_included v1 v2]. The widening
- operations require this, so we correct the arguments here. *)
- let widen size v1 v2 =
- let v2 = if not (V.is_included v1 v2) then V.join v1 v2 else v2 in
- V.widen (size,wh) v1 v2
- in
- let f_widen = f_aux_merge_join widen in
- let rec aux t1 t2 =
- if Cacheable.equal t1 t2 then t1
- else merge aux f_widen t1 t2
- in
- let _, r = aux (Integer.zero, t1) (Integer.zero, t2) in
- r
- ;;
-
-
- type map2_decide =
- ReturnLeft | ReturnRight | ReturnConstant of V.t | Recurse
-
- let map2_on_values_offset cache decide (f: V.t -> V.t -> V.t) =
- let merge_cache =
- match cache with
- | Hptmap_sig.PersistentCache _ | Hptmap_sig.TemporaryCache _ ->
- let module Map2Cache =
- Binary_cache.Arity_Two(Cacheable)(Cacheable)(Cacheable)
- in
- (match cache with
- | Hptmap_sig.PersistentCache _ ->
- clear_caches_ref := Map2Cache.clear :: !clear_caches_ref
- | _ -> ());
- Map2Cache.merge
- | Hptmap_sig.NoCache -> fun f x y -> f x y
- in
- let f' _abs_min _abs_max _rem1 _modu1 v1 _rem2 _modu2 v2 =
- Rel.zero, Int.one, f v1 v2
- in
- (* See the invariants a the top of {!merge}: [bounds o1 n1 = bounds o2 n2]
- holds *)
- let rec aux (o1, n1 as t1) (_o2, n2 as t2) =
- match decide n1 n2 with
- | Recurse ->
- merge_cache (merge aux f') t1 t2
- | ReturnLeft -> t1
- | ReturnRight -> t2
- | ReturnConstant v ->
- if n1 == Empty then begin
- (o1, n1) (* [n2 == Empty] and [o1 =~ o2] hold. *)
- end else begin
- (* build an interval mapped to [v], of the same width as t1 and t2 *)
- let ib1, ie1 = bounds_offset o1 n1 in
- ib1, interval_aux (ie1 -~ ib1) Rel.zero Int.one v
- end
- in
- aux
-
- let map2_on_values cache decide (f: V.t -> V.t -> V.t) =
- let map2_on_values_cached = map2_on_values_offset cache decide f in
- fun t1 t2 -> snd (map2_on_values_cached (Int.zero, t1) (Int.zero, t2))
-
-
- (* Given an integer i,
- find the interval the ith bit belongs to (thus its node)
- Returns: the zipper to navigate from the root to the node found,
- and the node itself
- *)
- exception Bit_Not_found (* TODO: not clear it does not leak outside *)
- let find_bit_offset i zipper offset tree =
- let rec aux_find tree curr_off z =
- match tree with
- | Empty -> raise Bit_Not_found
- | Node (max, offl, subl, offr, subr, _, _modu, _v, _) ->
- let abs_max = curr_off +~ max in
- if (i >=~ curr_off) && (i <=~ abs_max)
- then (z, curr_off, tree)
- else if i <~ curr_off
- then
- aux_find subl (curr_off +~ offl) (Left(curr_off, tree, z))
- else begin
- assert (i >~ abs_max);
- aux_find subr (curr_off +~ offr) (Right(curr_off, tree, z))
- end
- in
- aux_find tree offset zipper
- ;;
-
- let find_bit i tree = find_bit_offset i End Integer.zero tree
- ;;
-
-
- (* First and last bits are included in the interval. The returned value
- is at the very least isotropic, possibly topified. *)
- let find_imprecise_between (first_bit, last_bit) tree =
- let rec aux tree_offset tree =
- match tree with
- | Empty -> V.bottom
- | Node (max, offl, subl, offr, subr, _rem, _m, v, _) ->
- let abs_max = max +~ tree_offset in
- let subl_value =
- if first_bit <~ tree_offset then
- let subl_abs_offset = tree_offset +~ offl in
- aux subl_abs_offset subl
- else V.bottom
- in
- let subr_value =
- if last_bit >~ abs_max then
- let subr_abs_offset = tree_offset +~ offr in
- aux subr_abs_offset subr
- else V.bottom
- in
- let current_node_value =
- if last_bit <~ tree_offset || first_bit >~ abs_max
- then V.bottom
- else
- if V.is_isotropic v
- then v
- else
- let origin = Origin.(current K_Misalign_read) in
- V.topify_with_origin origin v
- in
- V.join subl_value (V.join subr_value current_node_value)
- in
- aux Integer.zero tree
-
- (* Reads the interval [start, start + size - 1] in the offsetmap [tree].
- Assumes that the interval fits into the offsetmap, and that the offsetmap
- is rooted at offset 0.
- [read_value] and [read_nodes] are used to read the offsetmap:
- - [read_value v size] is used if the read matches exactly a value [v] of
- size [size].
- - otherwise, [read_nodes ~offset node zipper ~start ~size] is called, with
- [node] the node in which the read starts, [offset] the offset of [node],
- and [zipper] a zipper to navigate from the root of [node].
- When the read belongs to a series of periodic reads, [since_and_period]
- should be the first offset and the period of the reads. This function then
- returns the last offset of the node being read if the series of reads can
- skip the rest of the node: it means that all other reads within the node
- will give a value that has already been read in the series. Otherwise, the
- function returns None. *)
- let read_itv ?since_and_period ~start ~size tree ~read_value ~read_nodes =
- let zipper, cur_off, root = find_bit start tree in
- match root with
- | Empty -> assert false
- | Node (max, _, _, _, _subr, rrel, m, v, _) ->
- let r = (Rel.add_abs cur_off rrel) %~ m in
- let read_ending = pred (start +~ size) in
- let node_ending = cur_off +~ max in
- let isotropic = V.is_isotropic v in
- let read_fit_in_node = read_ending <=~ node_ending in
- let value =
- if read_fit_in_node && (isotropic || (m =~ size && start %~ m =~ r))
- then read_value v size
- else read_nodes ~offset:cur_off root zipper ~start ~size
- in
- (* Could a series of periodic reads jump ahead in the offsetmap (for
- performance issue)? *)
- let read_ahead = match since_and_period with
- | None -> None
- | Some (since, period) ->
- (* If the next read reaches the next node, we cannot optimize *)
- if (read_ending +~ size) >~ node_ending
- then None
- (* If the value of the node is isotropic, or if the size of the
- repeated value divides the period, then all reads in this node
- are equivalent: jump to the next node. *)
- else if isotropic || (Int.is_zero (period %~ m))
- then Some node_ending
- else
- let since = Int.max since cur_off in
- (* The value in the node is repeated every [m] bits, and we have
- read every [period] bits. Once we have read [lcm period m] bits,
- we will have read all possible combinations. *)
- if start -~ since >= Int.ppcm period m
- then Some node_ending
- else None
- in
- read_ahead, value
-
- (* Reads only one interval by calling [read_itv]. Ignores the argument and
- result dedicated to periodic reads. *)
- let read_one_itv ~start ~size tree ~read_value ~read_nodes =
- snd (read_itv ~start ~size tree ~read_value ~read_nodes)
-
- (* Performs a series of periodic reads, starting at [min], ending at [max], and
- whose period is [period]. [size] is the size of each read. [read_value] and
- [read_nodes] are used to read the offsetmap (see read_itv for details).
- [join] is used to merge the result of each read, starting with [acc]. *)
- let read_series_itv ~min ~max ~period ~size tree ~read_value ~read_nodes ~join acc =
- let r = min %~ period in
- let since_and_period = min, period in
- let rec read_series start acc =
- let read_ahead, v =
- read_itv ~since_and_period ~start ~size tree ~read_value ~read_nodes
- in
- let acc = join v acc in
- (* Compute the offset of the next read. By default, add the [period] to the
- current [start], unless we can jump to the end of the current node. *)
- let next = match read_ahead with
- | None -> start +~ period
- | Some read_ahead ->
- (* [read_ahead] is the last offset of the node that has been read.
- The next reads within the node are unnecessary, so we could
- theoretically start at [succ read_ahead] (after re-alignement on
- [period]). However, the last read that starts on this node
- may overlap with the next node, and must be performed. So
- we rewind by [pred size] bits, then round up to the next periodic
- index that must be read. *)
- let min_next = (succ read_ahead) -~ (pred size) in
- Integer.round_up_to_r ~min:min_next ~r ~modu:period
- in
- (* Do not read past [max]. *)
- if next <=~ max
- then read_series next acc
- else acc
- in
- read_series min acc
-
- (* Reads [tree] at each offset of [offsets]. [size] is the size of each read.
- [read_value] and [read_nodes] perform the reads; [join] merges the result
- of each read, starting with [acc]. *)
- let read ~offsets ~size tree ~read_value ~read_nodes ~join acc =
- match offsets with
- | Tr_offset.Interval (min, max, period) ->
- read_series_itv
- ~min ~max ~period ~size tree ~read_value ~read_nodes ~join acc
- | Tr_offset.Set s ->
- List.fold_left
- (fun acc start ->
- let t = read_one_itv ~start ~size tree ~read_value ~read_nodes in
- join acc t)
- acc s
- | Tr_offset.Overlap(min, max, _origin) ->
- let v = find_imprecise_between (min, max) tree in
- read_value v size
- | Tr_offset.Invalid -> acc
-
- (* Transforms a function reading one node into a function reading successive
- nodes. The resulting function can be supplied to the [read_itv] function.
- It reads the interval [start, start + size - 1], which is supposed to start
- in the node [node]. [offset] is the offset of [node] in the offsetmap, and
- [zipper] is a zipper to navigate from the root of [node]. It is used to
- read the next nodes of the offsetmap if needed. The function [read_one_node]
- performs the read of each node. *)
- let read_successive_nodes ~read_one_node acc =
- fun ~offset node zipper ~start ~size ->
- let read_end = pred (start +~ size) in
- let rec read_nodes offset node zipper acc =
- let node_end = offset +~ (get_max node) in
- let t = read_one_node ~offset node ~start ~size acc in
- if node_end >=~ read_end
- then t
- else
- let offset, node, zipper = move_right offset node zipper in
- read_nodes offset node zipper t
- in
- read_nodes offset node zipper acc
-
- (* Finds the value associated to some offsets represented as an ival. *)
- let find ~validity ?(conflate_bottom=true) ~offsets ~size tree =
- let offsets = Tr_offset.trim_by_validity offsets size validity in
- let topify = Origin.K_Misalign_read in
- let read_one_node ~offset node ~start ~size acc =
- extract_bits_and_stitch ~topify ~conflate_bottom
- ~offset:start ~size
- offset (get_vv node) (get_max node)
- acc
- in
- let neutral = V.merge_neutral_element in
- let read_nodes = read_successive_nodes ~read_one_node neutral in
- let read_value v _size = v in
- let join = V.join in
- read ~offsets ~size tree ~read_value ~read_nodes ~join V.bottom
-
- (* Copies the node [node] at the end of the offsetmap [acc], as part of the
- larger copy of the interval [start..start+size-1] from the englobing
- offsetmap of [node]. [offset] is the offset of [node] in this offsetmap.
- As the new offsetmap represents the interval [0..size-1], the offsets are
- shifted by [start]. *)
- let copy_one_node ~offset node ~start ~size acc =
- match node with
- | Empty -> assert false
- | Node (max, _, _, _, _subr, rem, modu, v, _) ->
- (* The current copy starts at [offset], unless the overall copy starts in
- the middle of the node. The new start is then shifted by [start]. *)
- let min = (Integer.max offset start) -~ start in
- (* Same kind of reasoning for the end of the current copy. *)
- let node_end = offset +~ max in
- let read_end = pred (start +~ size) in
- let max = (Integer.min read_end node_end) -~ start in
- (* For the first node, if the read starts in the middle of the node,
- realign the value wrt the offset of the read (but not wrt the offset of
- the node in the new offsetmap). *)
- let new_rem =
- if offset <~ start
- then realign ~offset:offset ~new_offset:start rem modu
- else rem
- in
- let o, t = add_node ~min ~max new_rem modu v Integer.zero acc in
- assert (o =~ Integer.zero);
- t
-
- let copy_slice ~validity ~offsets ~size tree =
- let offsets = Tr_offset.trim_by_validity offsets size validity in
- if Int.(equal size zero) then `Value Empty
- else match offsets with
- | Tr_offset.Invalid -> `Bottom
- | _ ->
- let read_one_node = copy_one_node in
- let neutral = m_empty in
- let read_nodes = read_successive_nodes ~read_one_node neutral in
- let read_value v size = interval_aux (pred size) Rel.zero size v in
- let init = isotropic_interval size V.bottom in
- let t = read ~offsets ~size tree ~read_value ~read_nodes ~join init in
- `Value t
-
- (* Keep the part of the tree strictly under (i.e. strictly on the left) of a
- given offset. *)
- let rec keep_below ~offset curr_off tree =
- match tree with
- | Empty -> offset, tree
- | Node (max, offl, subl, offr, subr, rem, m, v, _) ->
- let new_offl = offl +~ curr_off in
- if offset <~ curr_off then
- keep_below offset new_offl subl
- else if offset =~ curr_off then
- new_offl, subl
- else
- let sup = curr_off +~ max in
- if offset >~ sup then
- let new_offr, new_subr = keep_below offset (curr_off +~ offr) subr in
- curr_off,
- nNode max offl subl (new_offr -~ curr_off) new_subr rem m v
- else
- let new_max = pred (offset -~ curr_off) in
- add_node
- ~min:curr_off ~max:(new_max +~ curr_off)
- rem m v
- (curr_off +~ offl ) subl
- ;;
-
- (* Keep the part of the tree strictly above (e.g. strictly on the right) of a
- given offset. *)
- let rec keep_above ~offset curr_off tree =
- match tree with
- | Empty -> (succ offset), tree
- | Node (max, offl, subl, offr, subr, rem, m, v, _) ->
- let new_offr = offr +~ curr_off in
- let abs_max = curr_off +~ max in
- if offset >~ abs_max then
- (* This node should be forgotten,
- let's look at the right subtree
- *)
- keep_above offset new_offr subr
- else if offset =~ abs_max then
- (* we are at the limit,
- the right subtree is the answer
- *)
- new_offr, subr
+ let extract_bits_and_stitch ~topify ~conflate_bottom ~offset ~size curr_off (rem, modu, v) max acc =
+ let rem = (Rel.add_abs curr_off rem) %~ modu in
+ let r =
+ let abs_max = curr_off +~ max in
+ (* last bit to be read,
+ be it in the current node or one of its successors *)
+ let max_bit = pred (offset +~ size) in
+ (* for this function, [min >= offset && min >= curr_off] holds *)
+ let extract_single_step min acc =
+ assert (not (V.is_isotropic v));
+ let interval_offset = min -~ offset in
+ let start = (min -~ rem) %~ modu in
+ let modu_end = if rem =~ Integer.zero then pred modu else pred rem in
+ (* where do we stop reading ?
+ either at the end of the current slice (round_up_to_r min) or
+ at the end of the interval (abs_max)
+ *)
+ let read_end =
+ Integer.min
+ (Integer.min (Integer.round_up_to_r ~min ~r:modu_end ~modu) abs_max)
+ max_bit
+ in
+ let stop = (read_end -~ rem) %~ modu in
+ (* Format.printf "Single step: interval offset %a length %a \
+ start %a stop %a total length %a offset %a max bit %a\
+ @\n current offset %a Rem %a modu %a V %a@."
+ pretty_int interval_offset pretty_int (Integer.length start stop)
+ pretty_int start pretty_int stop pretty_int size
+ pretty_int offset pretty_int max_bit
+ pretty_int curr_off pretty_int rem pretty_int modu V.pretty v ; *)
+ (* we ignore the 'inform' information here (and everywhere else in
+ this module, since we do not propagate it), because it is mostly
+ redundant with the 'origin' information in garbled mix *)
+ let _inform, read_bits = extract_bits ~topify ~start ~stop ~modu v in
+ (* Format.printf "After single step: read bits %a@." V.pretty read_bits; *)
+ let result =
+ merge_bits ~topify ~conflate_bottom
+ ~offset:interval_offset ~length:(Integer.length start stop)
+ ~value:read_bits ~total_length:size acc
+ in
+ (* Format.printf "After merge_bits: result %a@." V.pretty result; *)
+ read_end, result
+ in
+ let start = Integer.max offset curr_off
+ and stop = Integer.min max_bit abs_max in
+ if V.is_isotropic v then
+ let offset = start -~ offset in
+ merge_bits ~topify ~conflate_bottom
+ ~offset ~length:(Integer.length start stop)
+ ~value:v ~total_length:size acc
+ else
+ let start_point = ref start in
+ let acc = ref acc in
+ while !start_point <=~ stop do
+ let read_end, result = extract_single_step !start_point !acc in
+ acc := result;
+ start_point := succ read_end;
+ done;
+ !acc;
+ in
+ (* Format.printf "extract_bits_and_stitch istart@ %a@ size %a\
+ coff %a abs_max -- val %a@\n acc %a res %a@."
+ pretty_int offset pretty_int size pretty_int curr_off
+ (\* pretty_int (curr_off +~ (get_max node)) *\)
+ V.pretty v V.pretty acc V.pretty r; *)
+ r
+ ;;
+
+
+ (** Auxiliary function to join 2 trees with {!merge} above. The merge on two
+ values is done by [merge_v]. Since this function can be [V.widen], the
+ left/right order of arguments must be preserved. When [merge_v] is
+ narrow, it is important that [extract_bits_and_stitch] be canonical
+ enough -- or that {!V.narrow} handles differences in representations
+ soundly. *)
+ let f_aux_merge_generic merge_v abs_min abs_max rem1 modu1 v1 rem2 modu2 v2 =
+ if Rel.equal rem1 rem2 && modu1 =~ modu2
+ then
+ rem1, modu1, V.anisotropic_cast modu1 (merge_v modu1 v1 v2)
+ (* Format.printf "f_aux_merge: [%a, %a]@.(%a %a %a)@.(%a %a %a)@."
+ pretty_int abs_min pretty_int abs_max pretty_int rem1 pretty_int
+ modu1 V.pretty v1 pretty_int rem2 pretty_int modu2 V.pretty v2 ; *)
+ else
+ let topify = Origin.K_Merge in
+ let offset = abs_min in
+ let size = Integer.length abs_min abs_max in
+ let v1_fit = modu1 =~ size && Rel.is_zero rem1
+ and v2_fit = modu2 =~ size && Rel.is_zero rem2 in
+ let v1', v2' =
+ if (V.is_isotropic v1 || v1_fit) && (V.is_isotropic v2 || v2_fit)
+ then v1, v2
else
- if offset <~ curr_off then
- (* we want to keep this node and part of its left subtree *)
- let new_offl, new_subl =
- keep_above offset (curr_off +~ offl) subl
- in
- curr_off,
- nNode max (new_offl -~ curr_off) new_subl offr subr rem m v
- else
- (* the cut happens somewhere in this node it should be cut
- accordingly and reinjected into its right subtree *)
- let min = succ offset in
- let new_reml = realign ~offset:curr_off ~new_offset:min rem m in
- add_node ~min ~max:abs_max new_reml m v new_offr subr
-;;
-
-let update_itv_with_rem ~exact ~offset ~abs_max ~size ~rem v curr_off tree =
- if Int.(equal size zero) then curr_off, tree else
- let off1, t1 = keep_above abs_max curr_off tree in
- let off2, t2 = keep_below offset curr_off tree in
- if exact then
- let off_add, t_add =
- add_node ~min:offset ~max:abs_max rem size v off1 t1
- in
- union off2 t2 off_add t_add
- else
- let v_is_isotropic = V.is_isotropic v in
- let z, o, t = find_bit_offset offset End curr_off tree in
- let left_tree = ref t2 in
- let left_offset = ref off2 in
- let impz = { node = t; offset = o; zipper = z; } in
- while impz.offset <=~ abs_max do
- match impz.node with
- | Empty -> assert false
- | Node (max, _offl, _subl, _offr, _subr, r_node, m_node, v_node, _) ->
- let new_offset = Integer.max offset impz.offset in
- let rem = realign ~offset ~new_offset rem size in
- let r_node = realign ~offset:impz.offset ~new_offset r_node m_node in
- let new_r, new_m, new_v =
- let joined_value = V.join v_node v in
- if v_is_isotropic || (Rel.equal rem r_node && m_node =~ size)
- then r_node, m_node, V.anisotropic_cast ~size:m_node joined_value
- else if V.is_isotropic v_node
- then rem, size, V.anisotropic_cast ~size joined_value
- else
- let origin = Origin.(current K_Merge) in
- let new_value = V.topify_with_origin origin joined_value in
- let new_rem = Rel.zero and new_modu = Integer.one in
- new_rem, new_modu, new_value
- in
- let node_abs_max = impz.offset +~ max in
- let end_reached, write_max =
- if node_abs_max >=~ abs_max
- then true, abs_max
- else false, node_abs_max
- in
- let new_left_offset, new_left_tree =
- add_node
- ~min:new_offset ~max:write_max
- new_r new_m new_v !left_offset !left_tree
- in
- left_tree := new_left_tree;
- left_offset := new_left_offset;
- if not end_reached then imp_move_right impz
- else impz.offset <- succ abs_max
- done;
- union !left_offset !left_tree off1 t1
- ;;
-
- let update_itv = update_itv_with_rem ~rem:Rel.zero;;
-
- (* This should be in Int_Intervals, but is currently needed here.
- Returns an interval with reversed bounds when the intersection is empty. *)
- let clip_by_validity = function
- | Base.Empty | Base.Invalid ->
- (fun _-> Int.one, Int.zero (* reversed interval -> no intersection*))
- | Base.Known (min, max)
- | Base.Unknown (min, _, max) ->
- (fun (min', max') -> Integer.max min min', Integer.min max max')
- | Base.Variable variable_v ->
- (fun (min', max') -> Integer.max Int.zero min',
- Integer.min variable_v.Base.max_alloc max')
-
-(** This function does a weak update of the entire [offsm], by adding the
- topification of [v]. The parameter [validity] is respected, and so is the
- current size of [offsm]: each interval already present in [offsm] and valid
- is overwritten. Interval already present but not valid are bound to
- [V.bottom]. *)
-(* TODO: the convention to write bottom on non-valid locations is strange,
- and only useful for the NULL base in Lmap.ml. It would be simpler an more
- elegant to keep the existing value on non-valid ranges instead. This
- function should also be written as a call to fold_between *)
- let update_imprecise_everywhere ~validity o v offsm =
- let v = V.topify_with_origin o v in
- if Base.Validity.equal validity Base.Invalid then
- `Bottom
- else
- let clip = clip_by_validity validity in
- let r = fold
- (fun (min, max as itv) (bound_v, _, _) acc ->
- let new_v = V.join (V.topify_with_origin o bound_v) v in
- let new_min, new_max = clip itv in
- if new_min <=~ new_max then (* [min..max] and validity intersect *)
- let acc =
- if min <~ new_min (* Before validity *)
- then append_basic_itv ~min ~max:(pred new_min) ~v:V.bottom acc
- else acc
+ let reinterpret_bits x =
+ extract_bits_and_stitch ~topify ~conflate_bottom:false
+ ~offset ~size offset x abs_max V.merge_neutral_element
in
- let acc = append_basic_itv ~min:new_min ~max:new_max ~v:new_v acc in
- let acc =
- if new_max <~ max (* After validity *)
- then append_basic_itv ~min:(succ new_max) ~max ~v:V.bottom acc
- else acc
- in acc
+ reinterpret_bits (rem1, modu1, v1),
+ reinterpret_bits (rem2, modu2, v2)
+ in
+ (* The values were already aligned with the offset or have been
+ reinterpreted, so the alignment is always zero here. *)
+ let rem = Rel.zero in
+ (* Format.printf "1: (%a, %a, %a);@.2: (%a, %a, %a);@.[%a--%a] -> %a/%a@."
+ pretty_int rem1 pretty_int modu1 V.pretty v1
+ pretty_int rem2 pretty_int modu2 V.pretty v2
+ pretty_int abs_min pretty_int abs_max
+ V.pretty v1' V.pretty v2'; *)
+ rem, size, merge_v size v1' v2'
+ ;;
+
+ (* similar to [f_aux_merge_generic], but we perform a reinterpretation in
+ all cases. This is to ensure that [V.narrow] can be applied soundly. *)
+ let f_aux_merge_narrow merge_v abs_min abs_max rem1 modu1 v1 rem2 modu2 v2 =
+ let topify = Origin.K_Merge in
+ let offset = abs_min in
+ let size = Integer.length abs_min abs_max in
+ let v1' =
+ extract_bits_and_stitch ~topify ~conflate_bottom:false
+ ~offset ~size offset (rem1, modu1, v1) abs_max V.merge_neutral_element
+ in
+ let v2' =
+ extract_bits_and_stitch ~topify ~conflate_bottom:false
+ ~offset ~size offset (rem2, modu2, v2) abs_max V.merge_neutral_element
+ in
+ Rel.zero, size, (merge_v size v1' v2': v)
+ ;;
+
+
+ (** More efficient version of {!f_aux_merge_generic}, specialized for
+ join-like functions. When one of the values is isotropic, we do not
+ concretize the other one with {!extract_stitch_and_bits}. Instead,
+ we implicitly "extend" the isotropic value to the full range,
+ and merge on the whole range. This does not work with narrow, because
+ [narrow {0} {1,2}] on the first bit is {0}, but the intersection
+ of the two sets is bottom. *)
+ let f_aux_merge_join merge_v abs_min abs_max rem1 modu1 v1 rem2 modu2 v2 =
+ let joined size v1 v2 = V.anisotropic_cast size (merge_v size v1 v2) in
+ if V.is_isotropic v2 then
+ rem1, modu1, joined modu1 v1 v2
+ else if V.is_isotropic v1 then
+ rem2, modu2, joined modu2 v1 v2
+ else
+ f_aux_merge_generic merge_v abs_min abs_max rem1 modu1 v1 rem2 modu2 v2
+ ;;
+
+
+ module JoinCache = Binary_cache.Symmetric_Binary(Cacheable)(Cacheable)
+ let () = clear_caches_ref := JoinCache.clear :: !clear_caches_ref;;
+
+ (** Joining two trees that cover the same range *)
+ let join t1 t2 =
+ let f_join = f_aux_merge_join (fun _size v1 v2 -> V.join v1 v2) in
+ let rec aux_cache t1 t2 =
+ if Cacheable.equal t1 t2 then t1
+ else JoinCache.merge (merge aux_cache f_join) t1 t2
+ in
+ let _, r = aux_cache (Integer.zero, t1) (Integer.zero, t2) in
+ r
+ ;;
+
+ module Make_Narrow(X: sig
+ include Lattice_type.With_Top with type t := V.t
+ include Lattice_type.With_Narrow with type t := V.t
+ end) =
+ struct
+
+ module NarrowCache = Binary_cache.Symmetric_Binary(Cacheable)(Cacheable)
+ module NarrowReinterpretCache =
+ Binary_cache.Symmetric_Binary(Cacheable)(Cacheable)
+ let () = clear_caches_ref :=
+ NarrowReinterpretCache.clear :: NarrowCache.clear :: !clear_caches_ref;;
+
+ let is_top = function
+ | Node (_, _, Empty, _, Empty, _ , _, v, _) -> V.equal v X.top
+ | _ -> false
+
+ (** Narrowing two trees that cover the same range *)
+ let narrow t1 t2 =
+ let f_join = f_aux_merge_generic (fun _size v1 v2 -> X.narrow v1 v2) in
+ let rec aux_cache t1 t2 =
+ if Cacheable.equal t1 t2 || is_top (snd t2) then t1
+ else if is_top (snd t1) then t2
+ else NarrowCache.merge (merge aux_cache f_join) t1 t2
+ in
+ let _, r = aux_cache (Integer.zero, t1) (Integer.zero, t2) in
+ r
+ ;;
+
+ let narrow_reinterpret t1 t2 =
+ let f_join = f_aux_merge_narrow (fun _size v1 v2 -> X.narrow v1 v2) in
+ let rec aux_cache t1 t2 =
+ if Cacheable.equal t1 t2 || is_top (snd t2) then t1
+ else if is_top (snd t1) then t2
+ else NarrowReinterpretCache.merge (merge aux_cache f_join) t1 t2
+ in
+ let _, r = aux_cache (Integer.zero, t1) (Integer.zero, t2) in
+ r
+ ;;
+
+ end
+
+ let widen wh t1 t2 =
+ (* Due to the way f_aux_merge is designed, we can obtain intervals on which
+ the two bindings do not verify [is_included v1 v2]. The widening
+ operations require this, so we correct the arguments here. *)
+ let widen size v1 v2 =
+ let v2 = if not (V.is_included v1 v2) then V.join v1 v2 else v2 in
+ V.widen (size,wh) v1 v2
+ in
+ let f_widen = f_aux_merge_join widen in
+ let rec aux t1 t2 =
+ if Cacheable.equal t1 t2 then t1
+ else merge aux f_widen t1 t2
+ in
+ let _, r = aux (Integer.zero, t1) (Integer.zero, t2) in
+ r
+ ;;
+
+
+ type map2_decide =
+ ReturnLeft | ReturnRight | ReturnConstant of V.t | Recurse
+
+ let map2_on_values_offset cache decide (f: V.t -> V.t -> V.t) =
+ let merge_cache =
+ match cache with
+ | Hptmap_sig.PersistentCache _ | Hptmap_sig.TemporaryCache _ ->
+ let module Map2Cache =
+ Binary_cache.Arity_Two(Cacheable)(Cacheable)(Cacheable)
+ in
+ (match cache with
+ | Hptmap_sig.PersistentCache _ ->
+ clear_caches_ref := Map2Cache.clear :: !clear_caches_ref
+ | _ -> ());
+ Map2Cache.merge
+ | Hptmap_sig.NoCache -> fun f x y -> f x y
+ in
+ let f' _abs_min _abs_max _rem1 _modu1 v1 _rem2 _modu2 v2 =
+ Rel.zero, Int.one, f v1 v2
+ in
+ (* See the invariants a the top of {!merge}: [bounds o1 n1 = bounds o2 n2]
+ holds *)
+ let rec aux (o1, n1 as t1) (_o2, n2 as t2) =
+ match decide n1 n2 with
+ | Recurse ->
+ merge_cache (merge aux f') t1 t2
+ | ReturnLeft -> t1
+ | ReturnRight -> t2
+ | ReturnConstant v ->
+ if n1 == Empty then begin
+ (o1, n1) (* [n2 == Empty] and [o1 =~ o2] hold. *)
+ end else begin
+ (* build an interval mapped to [v], of the same width as t1 and t2 *)
+ let ib1, ie1 = bounds_offset o1 n1 in
+ ib1, interval_aux (ie1 -~ ib1) Rel.zero Int.one v
+ end
+ in
+ aux
+
+ let map2_on_values cache decide (f: V.t -> V.t -> V.t) =
+ let map2_on_values_cached = map2_on_values_offset cache decide f in
+ fun t1 t2 -> snd (map2_on_values_cached (Int.zero, t1) (Int.zero, t2))
+
+
+ (* Given an integer i,
+ find the interval the ith bit belongs to (thus its node)
+ Returns: the zipper to navigate from the root to the node found,
+ and the node itself
+ *)
+ exception Bit_Not_found (* TODO: not clear it does not leak outside *)
+ let find_bit_offset i zipper offset tree =
+ let rec aux_find tree curr_off z =
+ match tree with
+ | Empty -> raise Bit_Not_found
+ | Node (max, offl, subl, offr, subr, _, _modu, _v, _) ->
+ let abs_max = curr_off +~ max in
+ if (i >=~ curr_off) && (i <=~ abs_max)
+ then (z, curr_off, tree)
+ else if i <~ curr_off
+ then
+ aux_find subl (curr_off +~ offl) (Left(curr_off, tree, z))
+ else begin
+ assert (i >~ abs_max);
+ aux_find subr (curr_off +~ offr) (Right(curr_off, tree, z))
+ end
+ in
+ aux_find tree offset zipper
+ ;;
+
+ let find_bit i tree = find_bit_offset i End Integer.zero tree
+ ;;
+
+
+ (* First and last bits are included in the interval. The returned value
+ is at the very least isotropic, possibly topified. *)
+ let find_imprecise_between (first_bit, last_bit) tree =
+ let rec aux tree_offset tree =
+ match tree with
+ | Empty -> V.bottom
+ | Node (max, offl, subl, offr, subr, _rem, _m, v, _) ->
+ let abs_max = max +~ tree_offset in
+ let subl_value =
+ if first_bit <~ tree_offset then
+ let subl_abs_offset = tree_offset +~ offl in
+ aux subl_abs_offset subl
+ else V.bottom
+ in
+ let subr_value =
+ if last_bit >~ abs_max then
+ let subr_abs_offset = tree_offset +~ offr in
+ aux subr_abs_offset subr
+ else V.bottom
+ in
+ let current_node_value =
+ if last_bit <~ tree_offset || first_bit >~ abs_max
+ then V.bottom
+ else
+ if V.is_isotropic v
+ then v
+ else
+ let origin = Origin.(current K_Misalign_read) in
+ V.topify_with_origin origin v
+ in
+ V.join subl_value (V.join subr_value current_node_value)
+ in
+ aux Integer.zero tree
+
+ (* Reads the interval [start, start + size - 1] in the offsetmap [tree].
+ Assumes that the interval fits into the offsetmap, and that the offsetmap
+ is rooted at offset 0.
+ [read_value] and [read_nodes] are used to read the offsetmap:
+ - [read_value v size] is used if the read matches exactly a value [v] of
+ size [size].
+ - otherwise, [read_nodes ~offset node zipper ~start ~size] is called, with
+ [node] the node in which the read starts, [offset] the offset of [node],
+ and [zipper] a zipper to navigate from the root of [node].
+ When the read belongs to a series of periodic reads, [since_and_period]
+ should be the first offset and the period of the reads. This function then
+ returns the last offset of the node being read if the series of reads can
+ skip the rest of the node: it means that all other reads within the node
+ will give a value that has already been read in the series. Otherwise, the
+ function returns None. *)
+ let read_itv ?since_and_period ~start ~size tree ~read_value ~read_nodes =
+ let zipper, cur_off, root = find_bit start tree in
+ match root with
+ | Empty -> assert false
+ | Node (max, _, _, _, _subr, rrel, m, v, _) ->
+ let r = (Rel.add_abs cur_off rrel) %~ m in
+ let read_ending = pred (start +~ size) in
+ let node_ending = cur_off +~ max in
+ let isotropic = V.is_isotropic v in
+ let read_fit_in_node = read_ending <=~ node_ending in
+ let value =
+ if read_fit_in_node && (isotropic || (m =~ size && start %~ m =~ r))
+ then read_value v size
+ else read_nodes ~offset:cur_off root zipper ~start ~size
+ in
+ (* Could a series of periodic reads jump ahead in the offsetmap (for
+ performance issue)? *)
+ let read_ahead = match since_and_period with
+ | None -> None
+ | Some (since, period) ->
+ (* If the next read reaches the next node, we cannot optimize *)
+ if (read_ending +~ size) >~ node_ending
+ then None
+ (* If the value of the node is isotropic, or if the size of the
+ repeated value divides the period, then all reads in this node
+ are equivalent: jump to the next node. *)
+ else if isotropic || (Int.is_zero (period %~ m))
+ then Some node_ending
+ else
+ let since = Int.max since cur_off in
+ (* The value in the node is repeated every [m] bits, and we have
+ read every [period] bits. Once we have read [lcm period m] bits,
+ we will have read all possible combinations. *)
+ if start -~ since >= Int.ppcm period m
+ then Some node_ending
+ else None
+ in
+ read_ahead, value
+
+ (* Reads only one interval by calling [read_itv]. Ignores the argument and
+ result dedicated to periodic reads. *)
+ let read_one_itv ~start ~size tree ~read_value ~read_nodes =
+ snd (read_itv ~start ~size tree ~read_value ~read_nodes)
+
+ (* Performs a series of periodic reads, starting at [min], ending at [max], and
+ whose period is [period]. [size] is the size of each read. [read_value] and
+ [read_nodes] are used to read the offsetmap (see read_itv for details).
+ [join] is used to merge the result of each read, starting with [acc]. *)
+ let read_series_itv ~min ~max ~period ~size tree ~read_value ~read_nodes ~join acc =
+ let r = min %~ period in
+ let since_and_period = min, period in
+ let rec read_series start acc =
+ let read_ahead, v =
+ read_itv ~since_and_period ~start ~size tree ~read_value ~read_nodes
+ in
+ let acc = join v acc in
+ (* Compute the offset of the next read. By default, add the [period] to the
+ current [start], unless we can jump to the end of the current node. *)
+ let next = match read_ahead with
+ | None -> start +~ period
+ | Some read_ahead ->
+ (* [read_ahead] is the last offset of the node that has been read.
+ The next reads within the node are unnecessary, so we could
+ theoretically start at [succ read_ahead] (after re-alignement on
+ [period]). However, the last read that starts on this node
+ may overlap with the next node, and must be performed. So
+ we rewind by [pred size] bits, then round up to the next periodic
+ index that must be read. *)
+ let min_next = (succ read_ahead) -~ (pred size) in
+ Integer.round_up_to_r ~min:min_next ~r ~modu:period
+ in
+ (* Do not read past [max]. *)
+ if next <=~ max
+ then read_series next acc
+ else acc
+ in
+ read_series min acc
+
+ (* Reads [tree] at each offset of [offsets]. [size] is the size of each read.
+ [read_value] and [read_nodes] perform the reads; [join] merges the result
+ of each read, starting with [acc]. *)
+ let read ~offsets ~size tree ~read_value ~read_nodes ~join acc =
+ match offsets with
+ | Tr_offset.Interval (min, max, period) ->
+ read_series_itv
+ ~min ~max ~period ~size tree ~read_value ~read_nodes ~join acc
+ | Tr_offset.Set s ->
+ List.fold_left
+ (fun acc start ->
+ let t = read_one_itv ~start ~size tree ~read_value ~read_nodes in
+ join acc t)
+ acc s
+ | Tr_offset.Overlap(min, max, _origin) ->
+ let v = find_imprecise_between (min, max) tree in
+ read_value v size
+ | Tr_offset.Invalid -> acc
+
+ (* Transforms a function reading one node into a function reading successive
+ nodes. The resulting function can be supplied to the [read_itv] function.
+ It reads the interval [start, start + size - 1], which is supposed to start
+ in the node [node]. [offset] is the offset of [node] in the offsetmap, and
+ [zipper] is a zipper to navigate from the root of [node]. It is used to
+ read the next nodes of the offsetmap if needed. The function [read_one_node]
+ performs the read of each node. *)
+ let read_successive_nodes ~read_one_node acc =
+ fun ~offset node zipper ~start ~size ->
+ let read_end = pred (start +~ size) in
+ let rec read_nodes offset node zipper acc =
+ let node_end = offset +~ (get_max node) in
+ let t = read_one_node ~offset node ~start ~size acc in
+ if node_end >=~ read_end
+ then t
+ else
+ let offset, node, zipper = move_right offset node zipper in
+ read_nodes offset node zipper t
+ in
+ read_nodes offset node zipper acc
+
+ (* Finds the value associated to some offsets represented as an ival. *)
+ let find ~validity ?(conflate_bottom=true) ~offsets ~size tree =
+ let offsets = Tr_offset.trim_by_validity offsets size validity in
+ let topify = Origin.K_Misalign_read in
+ let read_one_node ~offset node ~start ~size acc =
+ extract_bits_and_stitch ~topify ~conflate_bottom
+ ~offset:start ~size
+ offset (get_vv node) (get_max node)
+ acc
+ in
+ let neutral = V.merge_neutral_element in
+ let read_nodes = read_successive_nodes ~read_one_node neutral in
+ let read_value v _size = v in
+ let join = V.join in
+ read ~offsets ~size tree ~read_value ~read_nodes ~join V.bottom
+
+ (* Copies the node [node] at the end of the offsetmap [acc], as part of the
+ larger copy of the interval [start..start+size-1] from the englobing
+ offsetmap of [node]. [offset] is the offset of [node] in this offsetmap.
+ As the new offsetmap represents the interval [0..size-1], the offsets are
+ shifted by [start]. *)
+ let copy_one_node ~offset node ~start ~size acc =
+ match node with
+ | Empty -> assert false
+ | Node (max, _, _, _, _subr, rem, modu, v, _) ->
+ (* The current copy starts at [offset], unless the overall copy starts in
+ the middle of the node. The new start is then shifted by [start]. *)
+ let min = (Integer.max offset start) -~ start in
+ (* Same kind of reasoning for the end of the current copy. *)
+ let node_end = offset +~ max in
+ let read_end = pred (start +~ size) in
+ let max = (Integer.min read_end node_end) -~ start in
+ (* For the first node, if the read starts in the middle of the node,
+ realign the value wrt the offset of the read (but not wrt the offset of
+ the node in the new offsetmap). *)
+ let new_rem =
+ if offset <~ start
+ then realign ~offset:offset ~new_offset:start rem modu
+ else rem
+ in
+ let o, t = add_node ~min ~max new_rem modu v Integer.zero acc in
+ assert (o =~ Integer.zero);
+ t
+
+ let copy_slice ~validity ~offsets ~size tree =
+ let offsets = Tr_offset.trim_by_validity offsets size validity in
+ if Int.(equal size zero) then `Value Empty
+ else match offsets with
+ | Tr_offset.Invalid -> `Bottom
+ | _ ->
+ let read_one_node = copy_one_node in
+ let neutral = m_empty in
+ let read_nodes = read_successive_nodes ~read_one_node neutral in
+ let read_value v size = interval_aux (pred size) Rel.zero size v in
+ let init = isotropic_interval size V.bottom in
+ let t = read ~offsets ~size tree ~read_value ~read_nodes ~join init in
+ `Value t
+
+ (* Keep the part of the tree strictly under (i.e. strictly on the left) of a
+ given offset. *)
+ let rec keep_below ~offset curr_off tree =
+ match tree with
+ | Empty -> offset, tree
+ | Node (max, offl, subl, offr, subr, rem, m, v, _) ->
+ let new_offl = offl +~ curr_off in
+ if offset <~ curr_off then
+ keep_below offset new_offl subl
+ else if offset =~ curr_off then
+ new_offl, subl
+ else
+ let sup = curr_off +~ max in
+ if offset >~ sup then
+ let new_offr, new_subr = keep_below offset (curr_off +~ offr) subr in
+ curr_off,
+ nNode max offl subl (new_offr -~ curr_off) new_subr rem m v
else
- append_basic_itv ~min ~max ~v:V.bottom acc
- ) offsm m_empty
- in
- `Value r
- ;;
-
-
- (** Update a set of intervals in a given rangemap all offsets starting from
- mn ending in mx must be updated with value v, every period *)
- let update_itvs ~exact ~mn ~mx ~period ~size v curr_off tree =
- assert(mx >=~ mn);
- let r = mn %~ period in
- let rec aux_update mn mx curr_off tree =
- match tree with
- | Empty -> curr_off, tree
- | Node (max, offl, subl, offr, subr, r_node, m_node, v_node, _) ->
- let abs_offl = offl +~ curr_off in
- let abs_offr = offr +~ curr_off in
-
- let new_offl, new_subl, undone_left =
- let last_read_max_offset = curr_off -~ size in
- if pred (mn +~ size) <~ curr_off then
- let new_mx = Integer.round_down_to_r
- ~max:last_read_max_offset ~r ~modu:period
- in
- let new_mx, undone =
- if new_mx >=~ mx
- then mx, None
- else new_mx, Some (new_mx +~ period)
- in
- let o, t = aux_update mn new_mx abs_offl subl in
- o, t, undone
- else abs_offl, subl, Some mn
-
- and new_offr, new_subr, undone_right =
- let abs_max = curr_off +~ max in
- let first_read_min_offset = succ abs_max in
- if mx >~ abs_max then
- let new_mn = Integer.round_up_to_r
- ~min:first_read_min_offset ~r ~modu:period
- in
- let new_mn, undone =
- if new_mn <=~ mn
- then mn, None
- else new_mn, Some (new_mn -~ period)
+ let new_max = pred (offset -~ curr_off) in
+ add_node
+ ~min:curr_off ~max:(new_max +~ curr_off)
+ rem m v
+ (curr_off +~ offl ) subl
+ ;;
+
+ (* Keep the part of the tree strictly above (e.g. strictly on the right) of a
+ given offset. *)
+ let rec keep_above ~offset curr_off tree =
+ match tree with
+ | Empty -> (succ offset), tree
+ | Node (max, offl, subl, offr, subr, rem, m, v, _) ->
+ let new_offr = offr +~ curr_off in
+ let abs_max = curr_off +~ max in
+ if offset >~ abs_max then
+ (* This node should be forgotten,
+ let's look at the right subtree
+ *)
+ keep_above offset new_offr subr
+ else if offset =~ abs_max then
+ (* we are at the limit,
+ the right subtree is the answer
+ *)
+ new_offr, subr
+ else
+ if offset <~ curr_off then
+ (* we want to keep this node and part of its left subtree *)
+ let new_offl, new_subl =
+ keep_above offset (curr_off +~ offl) subl
+ in
+ curr_off,
+ nNode max (new_offl -~ curr_off) new_subl offr subr rem m v
+ else
+ (* the cut happens somewhere in this node it should be cut
+ accordingly and reinjected into its right subtree *)
+ let min = succ offset in
+ let new_reml = realign ~offset:curr_off ~new_offset:min rem m in
+ add_node ~min ~max:abs_max new_reml m v new_offr subr
+ ;;
+
+ let update_itv_with_rem ~exact ~offset ~abs_max ~size ~rem v curr_off tree =
+ if Int.(equal size zero) then curr_off, tree else
+ let off1, t1 = keep_above abs_max curr_off tree in
+ let off2, t2 = keep_below offset curr_off tree in
+ if exact then
+ let off_add, t_add =
+ add_node ~min:offset ~max:abs_max rem size v off1 t1
+ in
+ union off2 t2 off_add t_add
+ else
+ let v_is_isotropic = V.is_isotropic v in
+ let z, o, t = find_bit_offset offset End curr_off tree in
+ let left_tree = ref t2 in
+ let left_offset = ref off2 in
+ let impz = { node = t; offset = o; zipper = z; } in
+ while impz.offset <=~ abs_max do
+ match impz.node with
+ | Empty -> assert false
+ | Node (max, _offl, _subl, _offr, _subr, r_node, m_node, v_node, _) ->
+ let new_offset = Integer.max offset impz.offset in
+ let rem = realign ~offset ~new_offset rem size in
+ let r_node = realign ~offset:impz.offset ~new_offset r_node m_node in
+ let new_r, new_m, new_v =
+ let joined_value = V.join v_node v in
+ if v_is_isotropic || (Rel.equal rem r_node && m_node =~ size)
+ then r_node, m_node, V.anisotropic_cast ~size:m_node joined_value
+ else if V.is_isotropic v_node
+ then rem, size, V.anisotropic_cast ~size joined_value
+ else
+ let origin = Origin.(current K_Merge) in
+ let new_value = V.topify_with_origin origin joined_value in
+ let new_rem = Rel.zero and new_modu = Integer.one in
+ new_rem, new_modu, new_value
+ in
+ let node_abs_max = impz.offset +~ max in
+ let end_reached, write_max =
+ if node_abs_max >=~ abs_max
+ then true, abs_max
+ else false, node_abs_max
+ in
+ let new_left_offset, new_left_tree =
+ add_node
+ ~min:new_offset ~max:write_max
+ new_r new_m new_v !left_offset !left_tree
+ in
+ left_tree := new_left_tree;
+ left_offset := new_left_offset;
+ if not end_reached then imp_move_right impz
+ else impz.offset <- succ abs_max
+ done;
+ union !left_offset !left_tree off1 t1
+ ;;
+
+ let update_itv = update_itv_with_rem ~rem:Rel.zero;;
+
+ (* This should be in Int_Intervals, but is currently needed here.
+ Returns an interval with reversed bounds when the intersection is empty. *)
+ let clip_by_validity = function
+ | Base.Empty | Base.Invalid ->
+ (fun _-> Int.one, Int.zero (* reversed interval -> no intersection*))
+ | Base.Known (min, max)
+ | Base.Unknown (min, _, max) ->
+ (fun (min', max') -> Integer.max min min', Integer.min max max')
+ | Base.Variable variable_v ->
+ (fun (min', max') -> Integer.max Int.zero min',
+ Integer.min variable_v.Base.max_alloc max')
+
+ (** This function does a weak update of the entire [offsm], by adding the
+ topification of [v]. The parameter [validity] is respected, and so is the
+ current size of [offsm]: each interval already present in [offsm] and valid
+ is overwritten. Interval already present but not valid are bound to
+ [V.bottom]. *)
+ (* TODO: the convention to write bottom on non-valid locations is strange,
+ and only useful for the NULL base in Lmap.ml. It would be simpler an more
+ elegant to keep the existing value on non-valid ranges instead. This
+ function should also be written as a call to fold_between *)
+ let update_imprecise_everywhere ~validity o v offsm =
+ let v = V.topify_with_origin o v in
+ if Base.Validity.equal validity Base.Invalid then
+ `Bottom
+ else
+ let clip = clip_by_validity validity in
+ let r = fold
+ (fun (min, max as itv) (bound_v, _, _) acc ->
+ let new_v = V.join (V.topify_with_origin o bound_v) v in
+ let new_min, new_max = clip itv in
+ if new_min <=~ new_max then (* [min..max] and validity intersect *)
+ let acc =
+ if min <~ new_min (* Before validity *)
+ then append_basic_itv ~min ~max:(pred new_min) ~v:V.bottom acc
+ else acc
in
- let o, t = aux_update new_mn mx abs_offr subr in
- o, t, undone
- else abs_offr, subr, Some mx
-
- in
- let o, t =
- add_node
- ~min:curr_off ~max:(curr_off +~ max)
- r_node m_node v_node new_offl new_subl
- in
- let curr_off, tree = union o t new_offr new_subr in
- match undone_left, undone_right with
- | Some min, Some max ->
- begin
- let update = update_itv ~exact in
- if size =~ period
- then
- let abs_max = pred (size +~ max) in
- update ~offset:min ~abs_max ~size v curr_off tree
- else
- let offset = ref min in
- let o = ref curr_off in
- let t = ref tree in
- while !offset <=~ max do
- let abs_max = pred (size +~ !offset) in
- let o', t' =
- update ~offset:!offset ~abs_max ~size v !o !t
- in
- o := o';
- t := t';
- offset := !offset +~ period;
- done;
- !o, !t;
- end
- | Some _, None
- | None, Some _
- | None, None -> curr_off, tree
- in
- aux_update mn mx curr_off tree
- ;;
+ let acc = append_basic_itv ~min:new_min ~max:new_max ~v:new_v acc in
+ let acc =
+ if new_max <~ max (* After validity *)
+ then append_basic_itv ~min:(succ new_max) ~max ~v:V.bottom acc
+ else acc
+ in acc
+ else
+ append_basic_itv ~min ~max ~v:V.bottom acc
+ ) offsm m_empty
+ in
+ `Value r
+ ;;
- let imprecise_write_msg = ref "locations to update in array"
-exception Update_Result_is_bottom
+ (** Update a set of intervals in a given rangemap all offsets starting from
+ mn ending in mx must be updated with value v, every period *)
+ let update_itvs ~exact ~mn ~mx ~period ~size v curr_off tree =
+ assert(mx >=~ mn);
+ let r = mn %~ period in
+ let rec aux_update mn mx curr_off tree =
+ match tree with
+ | Empty -> curr_off, tree
+ | Node (max, offl, subl, offr, subr, r_node, m_node, v_node, _) ->
+ let abs_offl = offl +~ curr_off in
+ let abs_offr = offr +~ curr_off in
+
+ let new_offl, new_subl, undone_left =
+ let last_read_max_offset = curr_off -~ size in
+ if pred (mn +~ size) <~ curr_off then
+ let new_mx = Integer.round_down_to_r
+ ~max:last_read_max_offset ~r ~modu:period
+ in
+ let new_mx, undone =
+ if new_mx >=~ mx
+ then mx, None
+ else new_mx, Some (new_mx +~ period)
+ in
+ let o, t = aux_update mn new_mx abs_offl subl in
+ o, t, undone
+ else abs_offl, subl, Some mn
+
+ and new_offr, new_subr, undone_right =
+ let abs_max = curr_off +~ max in
+ let first_read_min_offset = succ abs_max in
+ if mx >~ abs_max then
+ let new_mn = Integer.round_up_to_r
+ ~min:first_read_min_offset ~r ~modu:period
+ in
+ let new_mn, undone =
+ if new_mn <=~ mn
+ then mn, None
+ else new_mn, Some (new_mn -~ period)
+ in
+ let o, t = aux_update new_mn mx abs_offr subr in
+ o, t, undone
+ else abs_offr, subr, Some mx
+
+ in
+ let o, t =
+ add_node
+ ~min:curr_off ~max:(curr_off +~ max)
+ r_node m_node v_node new_offl new_subl
+ in
+ let curr_off, tree = union o t new_offr new_subr in
+ match undone_left, undone_right with
+ | Some min, Some max ->
+ begin
+ let update = update_itv ~exact in
+ if size =~ period
+ then
+ let abs_max = pred (size +~ max) in
+ update ~offset:min ~abs_max ~size v curr_off tree
+ else
+ let offset = ref min in
+ let o = ref curr_off in
+ let t = ref tree in
+ while !offset <=~ max do
+ let abs_max = pred (size +~ !offset) in
+ let o', t' =
+ update ~offset:!offset ~abs_max ~size v !o !t
+ in
+ o := o';
+ t := t';
+ offset := !offset +~ period;
+ done;
+ !o, !t;
+ end
+ | Some _, None
+ | None, Some _
+ | None, None -> curr_off, tree
+ in
+ aux_update mn mx curr_off tree
+ ;;
+
+ let imprecise_write_msg = ref "locations to update in array"
-(* Returns [true] iff [update_aux_tr_offsets] will approximate the set
- of offsets written *)
-let update_aux_tr_offsets_approximates offsets size =
- match offsets with
+ exception Update_Result_is_bottom
+
+ (* Returns [true] iff [update_aux_tr_offsets] will approximate the set
+ of offsets written *)
+ let update_aux_tr_offsets_approximates offsets size =
+ match offsets with
| Tr_offset.Overlap _ -> false
| Tr_offset.Interval(mn, mx, period) ->
let number = succ ((mx -~ mn) /~ period) in
@@ -1839,19 +1839,19 @@ let update_aux_tr_offsets_approximates offsets size =
| Tr_offset.Set _
| Tr_offset.Invalid -> false
-(* Update [t] by writing [v] of size [size] every offsets. Make sure that this
- function over-approximates the set of location written
- iff [update_aux_approximates] returns [true] *)
-let update_aux_tr_offsets ~exact ~offsets ~size v curr_off t =
- match offsets with
+ (* Update [t] by writing [v] of size [size] every offsets. Make sure that this
+ function over-approximates the set of location written
+ iff [update_aux_approximates] returns [true] *)
+ let update_aux_tr_offsets ~exact ~offsets ~size v curr_off t =
+ match offsets with
| Tr_offset.Overlap (mn, mx, origin) ->
- let origin = if origin = Origin.Unknown
- then Origin.(current K_Misalign_read)
- else origin
- in
- let v = V.topify_with_origin origin v in
- (* TODO: check *)
- update_itv ~exact ~offset:mn ~abs_max:mx ~size:Integer.one v curr_off t
+ let origin = if origin = Origin.Unknown
+ then Origin.(current K_Misalign_read)
+ else origin
+ in
+ let v = V.topify_with_origin origin v in
+ (* TODO: check *)
+ update_itv ~exact ~offset:mn ~abs_max:mx ~size:Integer.one v curr_off t
| Tr_offset.Interval(mn, mx, period) ->
let number = succ ((mx -~ mn) /~ period) in
@@ -1874,112 +1874,112 @@ let update_aux_tr_offsets ~exact ~offsets ~size v curr_off t =
let v' = V.topify_with_origin origin v in
if not (V.equal v v') then
Lattice_messages.emit_approximation msg_emitter
- "approximating value to write.";
+ "approximating value to write.";
v'
in
update_itv ~exact:false ~offset:mn ~abs_max ~size v curr_off t
end
| Tr_offset.Set s ->
- List.fold_left
- (fun (curr_off, m) offset ->
- update_itv ~exact ~offset ~size
- ~abs_max:(pred (offset +~ size)) v curr_off m
- ) (curr_off, t) s
+ List.fold_left
+ (fun (curr_off, m) offset ->
+ update_itv ~exact ~offset ~size
+ ~abs_max:(pred (offset +~ size)) v curr_off m
+ ) (curr_off, t) s
| Tr_offset.Invalid ->
raise Update_Result_is_bottom
-(* High-level update function (roughly of type [Ival.t -> v -> offsetmap ->
- offsetmap]. This function does not suppose that offsetmaps are zero-rooted.
- When too many locations must be updated, the result is approximated w.r.t
- the memory zones written. *)
-let update_aux ?origin ~validity ~exact ~offsets ~size v curr_off t =
- let v = V.anisotropic_cast ~size v in
- let reduced = Tr_offset.trim_by_validity ?origin offsets size validity in
- let exact = exact && not (Base.is_weak_validity validity) in
- update_aux_tr_offsets ~exact ~offsets:reduced ~size v curr_off t
-
-(* Same as update_aux, but on zero-rooted offsetmaps. *)
-let update ?origin ~validity ~exact ~offsets ~size v t =
- try
- let _curr_off, r =
- update_aux ?origin ~validity ~exact ~offsets ~size v Int.zero t
- in
- `Value r
- with Update_Result_is_bottom -> `Bottom
-
-(* High-level update function (roughly of type [Ival.t -> v -> offsetmap ->
- offsetmap]) that *under*-approximate the set of written locations, when
- there are too many of them. *)
-let update_under ~validity ~exact ~offsets ~size v t =
- let v = V.anisotropic_cast ~size v in
- let offsets = Tr_offset.trim_by_validity offsets size validity in
- if Base.is_weak_validity validity ||
- update_aux_tr_offsets_approximates offsets size
- then
- `Value t
- else
+ (* High-level update function (roughly of type [Ival.t -> v -> offsetmap ->
+ offsetmap]. This function does not suppose that offsetmaps are zero-rooted.
+ When too many locations must be updated, the result is approximated w.r.t
+ the memory zones written. *)
+ let update_aux ?origin ~validity ~exact ~offsets ~size v curr_off t =
+ let v = V.anisotropic_cast ~size v in
+ let reduced = Tr_offset.trim_by_validity ?origin offsets size validity in
+ let exact = exact && not (Base.is_weak_validity validity) in
+ update_aux_tr_offsets ~exact ~offsets:reduced ~size v curr_off t
+
+ (* Same as update_aux, but on zero-rooted offsetmaps. *)
+ let update ?origin ~validity ~exact ~offsets ~size v t =
try
- let _, t = update_aux_tr_offsets ~exact ~offsets ~size v Int.zero t in
- `Value t
+ let _curr_off, r =
+ update_aux ?origin ~validity ~exact ~offsets ~size v Int.zero t
+ in
+ `Value r
with Update_Result_is_bottom -> `Bottom
- let is_single_interval o =
- match o with
- | Node(_, _, Empty, _, Empty, _, _, _, _) -> true
- | _ -> false
-
- let single_interval_value o =
- match o with
- | Node(_, _, Empty, _, Empty, _, _, v, _) -> Some v
- | _ -> None
-
- let is_same_value o v =
- match o with
- | Empty -> true
- | Node(_, _, Empty, _, Empty, _, _, v', _) -> V.equal v v'
- | _ -> false
-
- let fold_between ?(direction=`LTR) ~entire (imin, imax) f t acc =
- let rec aux curr_off t acc = match t with
- | Empty -> acc
- | Node (max, offl, subl, offr, subr, rem, modu, v, _) ->
- let abs_max = max +~ curr_off in
- (* fold on the left subtree *)
- let acc_left acc =
- if imin <~ curr_off then (
- aux (offl +~ curr_off) subl acc)
- else acc
- in
- let acc_middle acc =
- if imax <~ curr_off || imin >~ abs_max
- then acc
- else
- if entire then
- (* Call f on the entire binding *)
- f (curr_off, abs_max) (v, modu, rem) acc
- else
- (* Cut the interval to [imin..imax] *)
- let lmin = Integer.max imin curr_off in
- let lmax = Integer.min imax abs_max in
- let lrem =
- Rel.e_rem (Rel.sub rem (Rel.sub_abs lmin curr_off)) modu
- in
- f (lmin, lmax) (v, modu, lrem) acc
- in
- (* fold on the right subtree *)
- let acc_right acc =
- if imax >~ abs_max
- then aux (offr +~ curr_off) subr acc
- else acc
- in
- match direction with
- | `LTR -> acc_right (acc_middle (acc_left acc))
- | `RTL -> acc_left (acc_middle (acc_right acc))
- in
- aux Integer.zero t acc
- ;;
+ (* High-level update function (roughly of type [Ival.t -> v -> offsetmap ->
+ offsetmap]) that *under*-approximate the set of written locations, when
+ there are too many of them. *)
+ let update_under ~validity ~exact ~offsets ~size v t =
+ let v = V.anisotropic_cast ~size v in
+ let offsets = Tr_offset.trim_by_validity offsets size validity in
+ if Base.is_weak_validity validity ||
+ update_aux_tr_offsets_approximates offsets size
+ then
+ `Value t
+ else
+ try
+ let _, t = update_aux_tr_offsets ~exact ~offsets ~size v Int.zero t in
+ `Value t
+ with Update_Result_is_bottom -> `Bottom
+
+ let is_single_interval o =
+ match o with
+ | Node(_, _, Empty, _, Empty, _, _, _, _) -> true
+ | _ -> false
+
+ let single_interval_value o =
+ match o with
+ | Node(_, _, Empty, _, Empty, _, _, v, _) -> Some v
+ | _ -> None
+
+ let is_same_value o v =
+ match o with
+ | Empty -> true
+ | Node(_, _, Empty, _, Empty, _, _, v', _) -> V.equal v v'
+ | _ -> false
+
+ let fold_between ?(direction=`LTR) ~entire (imin, imax) f t acc =
+ let rec aux curr_off t acc = match t with
+ | Empty -> acc
+ | Node (max, offl, subl, offr, subr, rem, modu, v, _) ->
+ let abs_max = max +~ curr_off in
+ (* fold on the left subtree *)
+ let acc_left acc =
+ if imin <~ curr_off then (
+ aux (offl +~ curr_off) subl acc)
+ else acc
+ in
+ let acc_middle acc =
+ if imax <~ curr_off || imin >~ abs_max
+ then acc
+ else
+ if entire then
+ (* Call f on the entire binding *)
+ f (curr_off, abs_max) (v, modu, rem) acc
+ else
+ (* Cut the interval to [imin..imax] *)
+ let lmin = Integer.max imin curr_off in
+ let lmax = Integer.min imax abs_max in
+ let lrem =
+ Rel.e_rem (Rel.sub rem (Rel.sub_abs lmin curr_off)) modu
+ in
+ f (lmin, lmax) (v, modu, lrem) acc
+ in
+ (* fold on the right subtree *)
+ let acc_right acc =
+ if imax >~ abs_max
+ then aux (offr +~ curr_off) subr acc
+ else acc
+ in
+ match direction with
+ | `LTR -> acc_right (acc_middle (acc_left acc))
+ | `RTL -> acc_left (acc_middle (acc_right acc))
+ in
+ aux Integer.zero t acc
+ ;;
(* weak validity should be handled caller *)
let paste_slice_itv ~exact from stop start_dest to_ =
@@ -2074,41 +2074,41 @@ let update_under ~validity ~exact ~offsets ~size v t =
let is_first = ref true in
let pretty_binding fmt (bk, ek) (v, modu, rel_offs) =
if not (skip_v v) then begin
- if !is_first then is_first:=false
- else Format.fprintf fmt "@\n";
- Format.fprintf fmt "@[" ;
- (* Print left-member and return misalign condition *)
- let force_misalign, printed_type =
- match typ with
+ if !is_first then is_first:=false
+ else Format.fprintf fmt "@\n";
+ Format.fprintf fmt "@[" ;
+ (* Print left-member and return misalign condition *)
+ let force_misalign, printed_type =
+ match typ with
| None ->
- Format.fprintf fmt "[rbits %a to %a]"
- pretty_int bk pretty_int ek ;
- (* misalign condition: *)
- (not (Rel.is_zero rel_offs) || (ek -~ bk <>~ pred modu))
- && not (V.is_isotropic v),
- None
+ Format.fprintf fmt "[rbits %a to %a]"
+ pretty_int bk pretty_int ek ;
+ (* misalign condition: *)
+ (not (Rel.is_zero rel_offs) || (ek -~ bk <>~ pred modu))
+ && not (V.is_isotropic v),
+ None
| Some typ ->
- (* returns misalign condition. *)
- Bit_utils.pretty_bits typ
- ~use_align:(not (V.is_isotropic v))
- ~align:rel_offs ~rh_size:modu ~start:bk ~stop:ek fmt
- in
- Format.fprintf fmt " %s@ @[<hv 1>%a@]" sep (pretty_v printed_type) v ;
- if force_misalign
- then
- if Rel.is_zero rel_offs && (Int.length bk ek) %~ modu =~ Integer.zero
+ (* returns misalign condition. *)
+ Bit_utils.pretty_bits typ
+ ~use_align:(not (V.is_isotropic v))
+ ~align:rel_offs ~rh_size:modu ~start:bk ~stop:ek fmt
+ in
+ Format.fprintf fmt " %s@ @[<hv 1>%a@]" sep (pretty_v printed_type) v ;
+ if force_misalign
then
- (if Int.length bk ek >~ modu then
- Format.fprintf fmt " repeated %%%a " pretty_int modu)
- else (
- let b_bits = Rel.e_rem (Rel.sub Rel.zero rel_offs) modu in
- let e_bits = Rel.add_abs (ek -~ bk) b_bits in
- Format.fprintf fmt "%s%%%a, bits %a to %a "
- (if e_bits >~ modu then " repeated " else "")
- pretty_int modu Rel.pretty b_bits pretty_int e_bits
- );
- Format.fprintf fmt "@]";
+ if Rel.is_zero rel_offs && (Int.length bk ek) %~ modu =~ Integer.zero
+ then
+ (if Int.length bk ek >~ modu then
+ Format.fprintf fmt " repeated %%%a " pretty_int modu)
+ else (
+ let b_bits = Rel.e_rem (Rel.sub Rel.zero rel_offs) modu in
+ let e_bits = Rel.add_abs (ek -~ bk) b_bits in
+ Format.fprintf fmt "%s%%%a, bits %a to %a "
+ (if e_bits >~ modu then " repeated " else "")
+ pretty_int modu Rel.pretty b_bits pretty_int e_bits
+ );
+ Format.fprintf fmt "@]";
end
in
if is_empty m then
@@ -2157,9 +2157,9 @@ let update_under ~validity ~exact ~offsets ~size v t =
let find_imprecise ~validity m =
match validity with
| Base.Known (min, max) | Base.Unknown (min, _, max) ->
- find_imprecise_between (min, max) m
+ find_imprecise_between (min, max) m
| Base.Variable variable_v ->
- find_imprecise_between (Int.zero, variable_v.Base.max_alloc) m
+ find_imprecise_between (Int.zero, variable_v.Base.max_alloc) m
| Base.Invalid | Base.Empty -> V.bottom
let find_imprecise_everywhere m =
@@ -2201,21 +2201,21 @@ end
module Int_Intervals_Map = struct
include Make(struct
- include Datatype.Bool
+ include Datatype.Bool
- let bottom = false
- let join = (||)
- let is_included b1 b2 = b2 || not b1
- let merge_neutral_element = bottom
+ let bottom = false
+ let join = (||)
+ let is_included b1 b2 = b2 || not b1
+ let merge_neutral_element = bottom
- let pretty_typ _ fmt v = pretty fmt v
+ let pretty_typ _ fmt v = pretty fmt v
- include FullyIsotropic
- end)
+ include FullyIsotropic
+ end)
include Make_Narrow(struct
- let top = true
- let narrow = (&&)
+ let top = true
+ let narrow = (&&)
end)
let () =
@@ -2234,13 +2234,13 @@ module Int_Intervals_Map = struct
(* true everywhere leads to true everywhere. false everywhere leads
to the other tree. *)
else match m1 with
- | Node (_, _, Empty, _, Empty, _ , _, b, _) ->
- if b then ReturnLeft else ReturnRight
- | _ ->
- match m2 with
| Node (_, _, Empty, _, Empty, _ , _, b, _) ->
- if b then ReturnRight else ReturnLeft
- | _ -> Recurse
+ if b then ReturnLeft else ReturnRight
+ | _ ->
+ match m2 with
+ | Node (_, _, Empty, _, Empty, _ , _, b, _) ->
+ if b then ReturnRight else ReturnLeft
+ | _ -> Recurse
in
let cache = Hptmap_sig.PersistentCache "Int_Intervals.join" in
map2_on_values_offset cache stop_join (||)
@@ -2251,13 +2251,13 @@ module Int_Intervals_Map = struct
(* false everywhere leads to false everywhere. true everywhere leads
to the other tree. *)
else match m1 with
- | Node (_, _, Empty, _, Empty, _ , _, b, _) ->
- if b then ReturnRight else ReturnLeft
- | _ ->
- match m2 with
| Node (_, _, Empty, _, Empty, _ , _, b, _) ->
- if b then ReturnLeft else ReturnRight
- | _ -> Recurse
+ if b then ReturnRight else ReturnLeft
+ | _ ->
+ match m2 with
+ | Node (_, _, Empty, _, Empty, _ , _, b, _) ->
+ if b then ReturnLeft else ReturnRight
+ | _ -> Recurse
in
let cache = Hptmap_sig.PersistentCache "Int_Intervals.narrow" in
map2_on_values_offset cache stop_narrow (&&)
@@ -2316,7 +2316,7 @@ module Int_Intervals_Map = struct
else if new_max >~ prev_max then
add_itv ~min:(succ prev_max) ~max:new_max false co m
else (* new_max <~ prev_max *)
- keep_below (succ new_max) co m
+ keep_below (succ new_max) co m
in
if new_min =~ prev_min then i
else if new_min <~ prev_min then
@@ -2325,7 +2325,7 @@ module Int_Intervals_Map = struct
keep_above (pred new_min) co m
- (* normalizes a non-empty offsetmap [m], by removing an eventual rightmost
+ (* normalizes a non-empty offsetmap [m], by removing an eventual rightmost
interval bound to false. Returns the new rightmost bit bound to [true].*)
let rec drop_righmost_false curr_off node =
match node with
@@ -2353,7 +2353,7 @@ module Int_Intervals_Map = struct
in
curr_off', node', rbit
- (* normalizes a non-empty offsetmap [m], by removing an eventual leftmost
+ (* normalizes a non-empty offsetmap [m], by removing an eventual leftmost
interval bound to false. Returns the new leftmost bit bound to [true].*)
let rec drop_leftmost_false curr_off node =
match node with
@@ -2386,13 +2386,13 @@ module Int_Intervals = struct
type itv = Int.t * Int.t
type intervals =
- | Top
- | Intervals of Int.t * Int_Intervals_Map.t * Int.t * Int.t
- (* The arguments of {!Intervals} are [curr_off, m, min, max] in this
- order. [min] and [max] are the the first and last bit bound to true
- in the map, which is supposed to be non-empty. All operations must
- maintain those two invariants. *)
- | Bottom
+ | Top
+ | Intervals of Int.t * Int_Intervals_Map.t * Int.t * Int.t
+ (* The arguments of {!Intervals} are [curr_off, m, min, max] in this
+ order. [min] and [max] are the the first and last bit bound to true
+ in the map, which is supposed to be non-empty. All operations must
+ maintain those two invariants. *)
+ | Bottom
let pretty_debug fmt t =
match t with
@@ -2404,67 +2404,67 @@ module Int_Intervals = struct
Int_Intervals_Map.pretty_debug_offset (curr_off, i)
include Datatype.Make(struct
- type t = intervals
- let name = "Int_Intervals.t"
-
- let pretty fmt t =
- match t with
- | Top -> Format.pp_print_string fmt "TopISet"
- | Bottom -> Format.pp_print_string fmt "BottomISet"
- | Intervals (curr_off, i, _, _) ->
- let first = ref true in
- Format.fprintf fmt "@[<hov >{";
- Int_Intervals_Map.iter_offset
- (fun (b, e) (v, _, _) ->
- if v then begin
- if !first then first := false else Format.pp_print_space fmt ();
- Format.fprintf fmt "[%a..%a]" Int.pretty b Int.pretty e
- end
- ) curr_off i;
- Format.fprintf fmt "}@]"
-
- let hash = function
- | Top -> 37
- | Bottom -> 73
- | Intervals (curr_off, i, _, _) ->
- (* Ignore min and max, which are redundant with curr_off + i *)
- Int.hash curr_off + 143 * Int_Intervals_Map.hash i
-
- let equal i1 i2 = match i1, i2 with
- | Top, Top | Bottom, Bottom -> true
- | Intervals (curr_off1, i1, _, _), Intervals (curr_off2, i2, _, _) ->
- curr_off1 =~ curr_off2 && Int_Intervals_Map.equal i1 i2
- | (Top | Bottom | Intervals _), _ -> false
-
- let compare i1 i2 = match i1, i2 with
- | Bottom, Bottom
- | Top, Top -> 0
- | Intervals (curr_off1, i1, _, _), Intervals (curr_off2, i2, _, _) ->
- let c = Int.compare curr_off1 curr_off2 in
- if c = 0 then Int_Intervals_Map.compare i1 i2
- else c
- | Bottom, (Intervals _ | Top)
- | Intervals _, Top -> -1
- | Intervals _, Bottom | Top, (Bottom | Intervals _) -> 1
-
- let reprs = [Bottom; Top]
- let rehash = Datatype.identity
- (* type intervals =
- Top | Intervals of Int.t * Int_Intervals_Map.t * Int.t * Int.t| Bottom *)
- let structural_descr =
- Structural_descr.t_sum
- [| [| Int.packed_descr; Int_Intervals_Map.packed_descr;
- Int.packed_descr; Int.packed_descr |] |]
-
- let mem_project = Datatype.never_any_project
- let varname _ = "i"
- let internal_pretty_code = Datatype.undefined
- let copy = Datatype.undefined
- end)
+ type t = intervals
+ let name = "Int_Intervals.t"
+
+ let pretty fmt t =
+ match t with
+ | Top -> Format.pp_print_string fmt "TopISet"
+ | Bottom -> Format.pp_print_string fmt "BottomISet"
+ | Intervals (curr_off, i, _, _) ->
+ let first = ref true in
+ Format.fprintf fmt "@[<hov >{";
+ Int_Intervals_Map.iter_offset
+ (fun (b, e) (v, _, _) ->
+ if v then begin
+ if !first then first := false else Format.pp_print_space fmt ();
+ Format.fprintf fmt "[%a..%a]" Int.pretty b Int.pretty e
+ end
+ ) curr_off i;
+ Format.fprintf fmt "}@]"
+
+ let hash = function
+ | Top -> 37
+ | Bottom -> 73
+ | Intervals (curr_off, i, _, _) ->
+ (* Ignore min and max, which are redundant with curr_off + i *)
+ Int.hash curr_off + 143 * Int_Intervals_Map.hash i
+
+ let equal i1 i2 = match i1, i2 with
+ | Top, Top | Bottom, Bottom -> true
+ | Intervals (curr_off1, i1, _, _), Intervals (curr_off2, i2, _, _) ->
+ curr_off1 =~ curr_off2 && Int_Intervals_Map.equal i1 i2
+ | (Top | Bottom | Intervals _), _ -> false
+
+ let compare i1 i2 = match i1, i2 with
+ | Bottom, Bottom
+ | Top, Top -> 0
+ | Intervals (curr_off1, i1, _, _), Intervals (curr_off2, i2, _, _) ->
+ let c = Int.compare curr_off1 curr_off2 in
+ if c = 0 then Int_Intervals_Map.compare i1 i2
+ else c
+ | Bottom, (Intervals _ | Top)
+ | Intervals _, Top -> -1
+ | Intervals _, Bottom | Top, (Bottom | Intervals _) -> 1
+
+ let reprs = [Bottom; Top]
+ let rehash = Datatype.identity
+ (* type intervals =
+ Top | Intervals of Int.t * Int_Intervals_Map.t * Int.t * Int.t| Bottom *)
+ let structural_descr =
+ Structural_descr.t_sum
+ [| [| Int.packed_descr; Int_Intervals_Map.packed_descr;
+ Int.packed_descr; Int.packed_descr |] |]
+
+ let mem_project = Datatype.never_any_project
+ let varname _ = "i"
+ let internal_pretty_code = Datatype.undefined
+ let copy = Datatype.undefined
+ end)
let top = Top
let bottom = Bottom
-
+
let is_top = function
| Top -> true
| _ -> false
@@ -2491,7 +2491,7 @@ module Int_Intervals = struct
| Intervals (co1, i1, min1, max1),
Intervals (co2, i2, min2, max2) ->
min1 >=~ min2 && max1 <=~ max2 &&
- Int_Intervals_Map.is_included_aux (co1, i1) (co2, i2)
+ Int_Intervals_Map.is_included_aux (co1, i1) (co2, i2)
| Intervals _, Bottom | Top, (Bottom | Intervals _) -> false
let join m1 m2 =
@@ -2506,7 +2506,7 @@ module Int_Intervals = struct
Int_Intervals_Map.enlarge_itv
co1 i1 ~prev_min:min1 ~new_min ~prev_max:max1 ~new_max
in
- let coi2' =
+ let coi2' =
Int_Intervals_Map.enlarge_itv
co2 i2 ~prev_min:min2 ~new_min ~prev_max:max2 ~new_max
in
@@ -2546,7 +2546,7 @@ module Int_Intervals = struct
Int_Intervals_Map.shrink_itv
co1 i1 ~prev_min:min1 ~new_min ~prev_max:max1 ~new_max
in
- let coi2' =
+ let coi2' =
Int_Intervals_Map.shrink_itv
co2 i2 ~prev_min:min2 ~new_min ~prev_max:max2 ~new_max
in
@@ -2690,17 +2690,17 @@ module Int_Intervals = struct
it for all intervals. *)
let aux_min_max min start_max =
if Int.(equal size zero) then Bottom else
- let max = pred (start_max +~ size) in
- let curr_off, ifalse = aux_create_interval ~min ~max false in
- let validity = Base.Known (min, max) in
- let curr_off', i =
- try
- Int_Intervals_Map.update_aux
- ~validity ~exact:true ~offsets:ival ~size true curr_off ifalse
- with Int_Intervals_Map.Update_Result_is_bottom ->
- assert false (* in bounds by construction *)
- in
- Intervals (curr_off', i, min, max)
+ let max = pred (start_max +~ size) in
+ let curr_off, ifalse = aux_create_interval ~min ~max false in
+ let validity = Base.Known (min, max) in
+ let curr_off', i =
+ try
+ Int_Intervals_Map.update_aux
+ ~validity ~exact:true ~offsets:ival ~size true curr_off ifalse
+ with Int_Intervals_Map.Update_Result_is_bottom ->
+ assert false (* in bounds by construction *)
+ in
+ Intervals (curr_off', i, min, max)
in
try
match Ival.min_and_max ival with
@@ -2757,14 +2757,14 @@ module Int_Intervals = struct
let min, max = Int_Intervals_Map.bounds_offset Int.zero map in
inject_bounds min max
-(* Although interval functions do not depend on the AST itself, there are
- numerous problems with not clearing the caches when the AST is reset.
- Hence, the weak hash table for boolean offsetmaps depends on Ast.self,
- and the caches are reset on an ast update. *)
+ (* Although interval functions do not depend on the AST itself, there are
+ numerous problems with not clearing the caches when the AST is reset.
+ Hence, the weak hash table for boolean offsetmaps depends on Ast.self,
+ and the caches are reset on an ast update. *)
let () = Ast.add_hook_on_update
- (fun () ->
- (* Kernel.debug ~dkey:dkey_caches "Clearing interval caches"; *)
- Int_Intervals_Map.clear_caches ())
+ (fun () ->
+ (* Kernel.debug ~dkey:dkey_caches "Clearing interval caches"; *)
+ Int_Intervals_Map.clear_caches ())
end
@@ -2774,17 +2774,17 @@ end
module Make_bitwise(V: sig
- include Lattice_type.Bounded_Join_Semi_Lattice
- include Lattice_type.With_Narrow with type t := t
- include Lattice_type.With_Top with type t := t
-end) = struct
+ include Lattice_type.Bounded_Join_Semi_Lattice
+ include Lattice_type.With_Narrow with type t := t
+ include Lattice_type.With_Top with type t := t
+ end) = struct
include Make(struct
- include V
- include FullyIsotropic
- let merge_neutral_element = bottom
- let pretty_typ _ fmt v = pretty fmt v
- end)
+ include V
+ include FullyIsotropic
+ let merge_neutral_element = bottom
+ let pretty_typ _ fmt v = pretty fmt v
+ end)
type intervals = Int_Intervals.intervals
@@ -2856,8 +2856,8 @@ end) = struct
fold sort_by_content m ();
(* Now sort the contents of h by increasing intervals *)
let m = V_Hashtbl.fold
- (fun v itvs acc -> MapIntervals.add (List.rev itvs) v acc)
- h MapIntervals.empty
+ (fun v itvs acc -> MapIntervals.add (List.rev itvs) v acc)
+ h MapIntervals.empty
in
(* Call f on those intervals *)
MapIntervals.fold
@@ -2904,16 +2904,16 @@ end) = struct
let fold_join_itvs_map_offset cache (type r) f join empty =
let module R = struct type t = r let sentinel = empty end in
let merge = match cache with
- | Hptmap_sig.PersistentCache _ | Hptmap_sig.TemporaryCache _ ->
- let module Cache =
- Binary_cache.Arity_Two(Cacheable)(Int_Intervals_Map.Cacheable)(R)
- in
- (match cache with
- | Hptmap_sig.PersistentCache _ ->
- clear_caches_ref := Cache.clear :: !clear_caches_ref
- | _ -> ());
- Cache.merge
- | Hptmap_sig.NoCache -> fun f x y -> f x y
+ | Hptmap_sig.PersistentCache _ | Hptmap_sig.TemporaryCache _ ->
+ let module Cache =
+ Binary_cache.Arity_Two(Cacheable)(Int_Intervals_Map.Cacheable)(R)
+ in
+ (match cache with
+ | Hptmap_sig.PersistentCache _ ->
+ clear_caches_ref := Cache.clear :: !clear_caches_ref
+ | _ -> ());
+ Cache.merge
+ | Hptmap_sig.NoCache -> fun f x y -> f x y
in
let rec aux cache (o1, t1) (o2, t2) =
match t1, t2 with
@@ -3006,11 +3006,11 @@ end) = struct
| Int_Intervals.Top ->
(* Find the range that is bound in [m], and use this as interval.
We would not return anything outside anyway. *)
- match Int_Intervals.bounds_as_itv m with
- | Int_Intervals.Bottom -> empty
- | Int_Intervals.Intervals (curr_off, itvs, _, _) ->
- aux_intervals (Int.zero, m) (curr_off, itvs)
- | Int_Intervals.Top -> assert false
+ match Int_Intervals.bounds_as_itv m with
+ | Int_Intervals.Bottom -> empty
+ | Int_Intervals.Intervals (curr_off, itvs, _, _) ->
+ aux_intervals (Int.zero, m) (curr_off, itvs)
+ | Int_Intervals.Top -> assert false
end
@@ -3019,73 +3019,73 @@ end
the warning about unused modules. *)
module Aux
- (V1 : module type of Offsetmap_lattice_with_isotropy)
- (V2 : module type of Offsetmap_lattice_with_isotropy)
+ (V1 : module type of Offsetmap_lattice_with_isotropy)
+ (V2 : module type of Offsetmap_lattice_with_isotropy)
= struct
module M1 = Make(V1)
module M2 = Make(V2)
- (* This function is there as a template for people wanting to write a fold-like
- iterator on two offsetmaps simultaneously. [bounds o1 t1 = bounds o2 t2]
- need not to hold; the function returns [empty] when the maps
- have no overlap. Currently, this functor is not exported. *)
- let _map_fold2 (type s) (type t) f join empty o1 (t1: s offsetmap) o2 (t2: t offsetmap) =
- let rec aux (o1, t1) (o2, t2) =
- match t1, t2 with
- | Empty, Empty -> empty
- | Empty, _ | _, Empty -> assert false
- | Node (max1, offl1, subl1, offr1, subr1, _, _, v1, _),
- Node (max2, offl2, subl2, offr2, subr2, _, _, v2, _) ->
- let amin1 = o1 in
- let amax1 = max1 +~ o1 in
- let amin2 = o2 in
- let amax2 = max2 +~ o2 in
- let ol1 = o1 +~ offl1 in
- let ol2 = o2 +~ offl2 in
- let or1 = o1 +~ offr1 in
- let or2 = o2 +~ offr2 in
- if amax1 <~ amin2 then begin
- join (aux (o1, t1) (ol2, subl2)) (aux (or1, subr1) (o2, t2))
- end else if amin1 >~ amax2 then begin
- join (aux (o1, t1) (or2, subr2)) (aux (ol1, subl1) (o2, t2))
- end else begin
- if amin1 =~ amin2 then begin
- let foo =
- if amax1 =~ amax2 then begin
- join (f amin1 amax1 v1 v2) (aux (or1, subr1) (or2, subr2))
- end
- else if amax1 >~ amax2 then begin
- join (f amin1 amax2 v1 v2) (aux (o1, t1) (or2, subr2))
- end
- else begin
- join (f amin1 amax1 v1 v2) (aux (or1, subr1) (o2, t2))
- end
- in
- join foo (aux (ol1, subl1) (ol2, subl2))
- end
- else
- let treat_right_nodes mabs_min =
- if amax1 =~ amax2 then begin
- join (f mabs_min amax1 v1 v2) (aux (or1, subr1) (or2, subr2))
- end
- else if amax1 >~ amax2 then begin
- join (f mabs_min amax2 v1 v2) (aux (o1, t1) (or2, subr2))
- end
- else begin
- join (f mabs_min amax1 v1 v2) (aux (or1, subr1) (o2, t2))
- end;
- in
- if amin1 >~ amin2 then begin
- join (treat_right_nodes amin1) (aux (ol1, subl1) (o2, t2))
- end
- else begin
- join (treat_right_nodes amin2) (aux (o1, t1) (ol2, subl2))
- end
- end
- in
- aux (o1, t1) (o2, t2)
- ;;
+ (* This function is there as a template for people wanting to write a fold-like
+ iterator on two offsetmaps simultaneously. [bounds o1 t1 = bounds o2 t2]
+ need not to hold; the function returns [empty] when the maps
+ have no overlap. Currently, this functor is not exported. *)
+ let _map_fold2 (type s) (type t) f join empty o1 (t1: s offsetmap) o2 (t2: t offsetmap) =
+ let rec aux (o1, t1) (o2, t2) =
+ match t1, t2 with
+ | Empty, Empty -> empty
+ | Empty, _ | _, Empty -> assert false
+ | Node (max1, offl1, subl1, offr1, subr1, _, _, v1, _),
+ Node (max2, offl2, subl2, offr2, subr2, _, _, v2, _) ->
+ let amin1 = o1 in
+ let amax1 = max1 +~ o1 in
+ let amin2 = o2 in
+ let amax2 = max2 +~ o2 in
+ let ol1 = o1 +~ offl1 in
+ let ol2 = o2 +~ offl2 in
+ let or1 = o1 +~ offr1 in
+ let or2 = o2 +~ offr2 in
+ if amax1 <~ amin2 then begin
+ join (aux (o1, t1) (ol2, subl2)) (aux (or1, subr1) (o2, t2))
+ end else if amin1 >~ amax2 then begin
+ join (aux (o1, t1) (or2, subr2)) (aux (ol1, subl1) (o2, t2))
+ end else begin
+ if amin1 =~ amin2 then begin
+ let foo =
+ if amax1 =~ amax2 then begin
+ join (f amin1 amax1 v1 v2) (aux (or1, subr1) (or2, subr2))
+ end
+ else if amax1 >~ amax2 then begin
+ join (f amin1 amax2 v1 v2) (aux (o1, t1) (or2, subr2))
+ end
+ else begin
+ join (f amin1 amax1 v1 v2) (aux (or1, subr1) (o2, t2))
+ end
+ in
+ join foo (aux (ol1, subl1) (ol2, subl2))
+ end
+ else
+ let treat_right_nodes mabs_min =
+ if amax1 =~ amax2 then begin
+ join (f mabs_min amax1 v1 v2) (aux (or1, subr1) (or2, subr2))
+ end
+ else if amax1 >~ amax2 then begin
+ join (f mabs_min amax2 v1 v2) (aux (o1, t1) (or2, subr2))
+ end
+ else begin
+ join (f mabs_min amax1 v1 v2) (aux (or1, subr1) (o2, t2))
+ end;
+ in
+ if amin1 >~ amin2 then begin
+ join (treat_right_nodes amin1) (aux (ol1, subl1) (o2, t2))
+ end
+ else begin
+ join (treat_right_nodes amin2) (aux (o1, t1) (ol2, subl2))
+ end
+ end
+ in
+ aux (o1, t1) (o2, t2)
+ ;;
end
diff --git a/src/kernel_services/abstract_interp/offsetmap.mli b/src/kernel_services/abstract_interp/offsetmap.mli
index 787f8efd859673937656ee12f359f493290bbc6b..5eed72abe2e0ea2ab6c07cd6f40604cff9cb982e 100644
--- a/src/kernel_services/abstract_interp/offsetmap.mli
+++ b/src/kernel_services/abstract_interp/offsetmap.mli
@@ -27,7 +27,7 @@
module Make (V : module type of Offsetmap_lattice_with_isotropy) :
module type of Offsetmap_sig
with type v = V.t
- and type widen_hint = V.numerical_widen_hint
+ and type widen_hint = V.numerical_widen_hint
(**/**)
(* Exported as Int_Intervals, do not use this module directly *)
@@ -38,13 +38,13 @@ module Int_Intervals: module type of Int_Intervals_sig
(** Maps from intervals to simple values. The documentation of the returned
maps is in module {!Offsetmap_bitwise_sig}. *)
module Make_bitwise(V: sig
- include Lattice_type.Bounded_Join_Semi_Lattice
- include Lattice_type.With_Narrow with type t := t
- include Lattice_type.With_Top with type t := t
-end) :
+ include Lattice_type.Bounded_Join_Semi_Lattice
+ include Lattice_type.With_Narrow with type t := t
+ include Lattice_type.With_Top with type t := t
+ end) :
module type of Offsetmap_bitwise_sig
- with type v = V.t
- and type intervals = Int_Intervals.t
+ with type v = V.t
+ and type intervals = Int_Intervals.t
(**/**)
diff --git a/src/kernel_services/abstract_interp/offsetmap_bitwise_sig.mli b/src/kernel_services/abstract_interp/offsetmap_bitwise_sig.mli
index 1d5b8039d5be60afe3586437234b5ff7ca2e0dad..e1320b02ceb4c44a4fd76ce7296ca1b54c369487 100644
--- a/src/kernel_services/abstract_interp/offsetmap_bitwise_sig.mli
+++ b/src/kernel_services/abstract_interp/offsetmap_bitwise_sig.mli
@@ -94,8 +94,8 @@ val size_from_validity:
val map : (v -> v) -> t -> t
type map2_decide =
- ReturnLeft | ReturnRight | ReturnConstant of v | Recurse
-(** See the documentation of type {!Offsetmap_sig.map2_decide} *)
+ ReturnLeft | ReturnRight | ReturnConstant of v | Recurse
+ (** See the documentation of type {!Offsetmap_sig.map2_decide} *)
val map2:
Hptmap_sig.cache_type -> (t -> t -> map2_decide) -> (v -> v -> v) -> t -> t -> t
diff --git a/src/kernel_services/abstract_interp/offsetmap_sig.mli b/src/kernel_services/abstract_interp/offsetmap_sig.mli
index c8f7a52238f2fbb8a45daa90e9304f70d818ebc4..ec5528d0a6da4f066c3a059aee7204b7638ddbc8 100644
--- a/src/kernel_services/abstract_interp/offsetmap_sig.mli
+++ b/src/kernel_services/abstract_interp/offsetmap_sig.mli
@@ -84,7 +84,7 @@ val iter:
- [offset] is the offset at which [v] starts in the interval;
it ranges over [0..size-1]. If [offset] is [0], [v] starts
at the beginning of the interval. Otherwise, it starts at [offset-size].
- *)
+*)
val fold:
((Int.t * Int.t) -> (v * Int.t * Rel.t) -> 'a -> 'a) ->
@@ -122,17 +122,17 @@ val map_on_values: (v -> v) -> t -> t
relative to the beginning of the interval is kept unchanged. *)
type map2_decide =
- ReturnLeft | ReturnRight | ReturnConstant of v | Recurse
-(** This type describes different possibilities to accelerate a simultaneous
- iteration on two offsetmaps. {!ReturnLeft} (resp. {!ReturnRight}) means
- 'return the left (resp. right) operand unchanged, and stop the recursive
- descent'. [ReturnConstant v] means 'return a constant offsetmap of the good
- size and that contains [v] everywhere'. It is always correct to return
- {!Recurse}, which will force the recursion until the maps have been fully
- decomposed.
-
- Typical usage include functions that verify [f v v = v], maps [m] such that
- [f m m' = m'], etc. *)
+ ReturnLeft | ReturnRight | ReturnConstant of v | Recurse
+ (** This type describes different possibilities to accelerate a simultaneous
+ iteration on two offsetmaps. {!ReturnLeft} (resp. {!ReturnRight}) means
+ 'return the left (resp. right) operand unchanged, and stop the recursive
+ descent'. [ReturnConstant v] means 'return a constant offsetmap of the good
+ size and that contains [v] everywhere'. It is always correct to return
+ {!Recurse}, which will force the recursion until the maps have been fully
+ decomposed.
+
+ Typical usage include functions that verify [f v v = v], maps [m] such that
+ [f m m' = m'], etc. *)
val map2_on_values:
Hptmap_sig.cache_type -> (t -> t -> map2_decide) -> (v -> v -> v) -> t -> t -> t
diff --git a/src/kernel_services/abstract_interp/origin.ml b/src/kernel_services/abstract_interp/origin.ml
index 5023728e3df5d9ace434f08103eebc82e9943ac2..5d4d7477abe978c081af6c76fe1caef016f9c60d 100644
--- a/src/kernel_services/abstract_interp/origin.ml
+++ b/src/kernel_services/abstract_interp/origin.ml
@@ -67,7 +67,7 @@ let compare o1 o2 = match o1, o2 with
| Leaf s1, Leaf s2
| Merge s1, Merge s2
| Arith s1, Arith s2 ->
- LocationLattice.compare s1 s2
+ LocationLattice.compare s1 s2
| Well, Well | Unknown, Unknown -> 0
@@ -76,14 +76,14 @@ let compare o1 o2 = match o1, o2 with
| Merge _, (Arith _ | Well | Unknown)
| Arith _, (Well | Unknown)
| Well, Unknown ->
- -1
+ -1
| Unknown, (Well | Arith _ | Merge _ | Leaf _ | Misalign_read _)
| Well, (Arith _ | Merge _ | Leaf _ | Misalign_read _)
| Arith _, (Merge _ | Leaf _ | Misalign_read _)
| Merge _, (Leaf _ | Misalign_read _)
| Leaf _, Misalign_read _
- -> 1
+ -> 1
let top = Unknown
let is_top x = equal top x
@@ -96,15 +96,15 @@ let pretty_source fmt = function
let pretty fmt o = match o with
| Unknown ->
- Format.fprintf fmt "Unknown"
+ Format.fprintf fmt "Unknown"
| Misalign_read o ->
- Format.fprintf fmt "Misaligned%a" pretty_source o
+ Format.fprintf fmt "Misaligned%a" pretty_source o
| Leaf o ->
- Format.fprintf fmt "Library function%a" pretty_source o
+ Format.fprintf fmt "Library function%a" pretty_source o
| Merge o ->
- Format.fprintf fmt "Merge%a" pretty_source o
+ Format.fprintf fmt "Merge%a" pretty_source o
| Arith o ->
- Format.fprintf fmt "Arithmetic%a" pretty_source o
+ Format.fprintf fmt "Arithmetic%a" pretty_source o
| Well -> Format.fprintf fmt "Well"
let pretty_as_reason fmt org =
@@ -139,7 +139,7 @@ include Datatype.Make
let pretty = pretty
let varname = Datatype.undefined
let mem_project = Datatype.never_any_project
- end)
+ end)
let bottom = Arith(LocationLattice.bottom)
@@ -152,17 +152,17 @@ let join o1 o2 =
| Unknown,_ | _, Unknown -> Unknown
| Well,_ | _ , Well -> Well
| Misalign_read o1, Misalign_read o2 ->
- Misalign_read(LocationLattice.join o1 o2)
+ Misalign_read(LocationLattice.join o1 o2)
| _, (Misalign_read _ as m) | (Misalign_read _ as m), _ -> m
| Leaf o1, Leaf o2 ->
- Leaf(LocationLattice.join o1 o2)
+ Leaf(LocationLattice.join o1 o2)
| (Leaf _ as m), _ | _, (Leaf _ as m) -> m
| Merge o1, Merge o2 ->
- Merge(LocationLattice.join o1 o2)
+ Merge(LocationLattice.join o1 o2)
| (Merge _ as m), _ | _, (Merge _ as m) -> m
| Arith o1, Arith o2 ->
- Arith(LocationLattice.join o1 o2)
- (* | (Arith _ as m), _ | _, (Arith _ as m) -> m *)
+ Arith(LocationLattice.join o1 o2)
+ (* | (Arith _ as m), _ | _, (Arith _ as m) -> m *)
in
(* Format.printf "Origin.join %a %a -> %a@." pretty o1 pretty o2 pretty result;
*)
@@ -175,35 +175,35 @@ let meet o1 o2 =
then o1
else
match o1, o2 with
- | Arith o1, Arith o2 ->
- Arith(LocationLattice.meet o1 o2)
- | (Arith _ as m), _ | _, (Arith _ as m) -> m
- | Merge o1, Merge o2 ->
- Merge(LocationLattice.meet o1 o2)
- | (Merge _ as m), _ | _, (Merge _ as m) -> m
- | Leaf o1, Leaf o2 ->
- Leaf(LocationLattice.meet o1 o2)
- | (Leaf _ as m), _ | _, (Leaf _ as m) -> m
- | Misalign_read o1, Misalign_read o2 ->
- Misalign_read(LocationLattice.meet o1 o2)
- | _, (Misalign_read _ as m) | (Misalign_read _ as m), _ -> m
- | Well, Well -> Well
- | Well,m | m, Well -> m
- | Unknown, Unknown -> Unknown
+ | Arith o1, Arith o2 ->
+ Arith(LocationLattice.meet o1 o2)
+ | (Arith _ as m), _ | _, (Arith _ as m) -> m
+ | Merge o1, Merge o2 ->
+ Merge(LocationLattice.meet o1 o2)
+ | (Merge _ as m), _ | _, (Merge _ as m) -> m
+ | Leaf o1, Leaf o2 ->
+ Leaf(LocationLattice.meet o1 o2)
+ | (Leaf _ as m), _ | _, (Leaf _ as m) -> m
+ | Misalign_read o1, Misalign_read o2 ->
+ Misalign_read(LocationLattice.meet o1 o2)
+ | _, (Misalign_read _ as m) | (Misalign_read _ as m), _ -> m
+ | Well, Well -> Well
+ | Well,m | m, Well -> m
+ | Unknown, Unknown -> Unknown
let narrow o1 o2 =
if o1 == o2
then o1
else
match o1, o2 with
- | Arith o1, Arith o2 -> Arith (LocationLattice.narrow o1 o2)
- | Merge o1, Merge o2 -> Merge (LocationLattice.narrow o1 o2)
- | Leaf o1, Leaf o2 -> Leaf (LocationLattice.narrow o1 o2)
- | Misalign_read o1, Misalign_read o2 ->
- Misalign_read (LocationLattice.narrow o1 o2)
- | Well, Well -> Well
- | Unknown, m | m, Unknown -> m
- | _, _ -> Unknown
+ | Arith o1, Arith o2 -> Arith (LocationLattice.narrow o1 o2)
+ | Merge o1, Merge o2 -> Merge (LocationLattice.narrow o1 o2)
+ | Leaf o1, Leaf o2 -> Leaf (LocationLattice.narrow o1 o2)
+ | Misalign_read o1, Misalign_read o2 ->
+ Misalign_read (LocationLattice.narrow o1 o2)
+ | Well, Well -> Well
+ | Unknown, m | m, Unknown -> m
+ | _, _ -> Unknown
let is_included o1 o2 =
(equal o1 (meet o1 o2))
diff --git a/src/kernel_services/abstract_interp/origin.mli b/src/kernel_services/abstract_interp/origin.mli
index be9dd49e267fac7b84c03f447eddc9c1537bc2ca..da6881f0f0f5ba0ea293c907720dbb6a37d7e14f 100644
--- a/src/kernel_services/abstract_interp/origin.mli
+++ b/src/kernel_services/abstract_interp/origin.mli
@@ -39,7 +39,7 @@ end
source locations where the operation took place. *)
type origin =
| Misalign_read of LocationLattice.t (** Read of not all the bits of a
- pointer, typically through a pointer cast *)
+ pointer, typically through a pointer cast *)
| Leaf of LocationLattice.t (** Result of a function without a body *)
| Merge of LocationLattice.t (** Join between two control-flows *)
| Arith of LocationLattice.t (** Arithmetic operation that cannot be
diff --git a/src/kernel_services/abstract_interp/tr_offset.mli b/src/kernel_services/abstract_interp/tr_offset.mli
index 17b3531b62120ec863f60a065a21463e2bff6b42..56981e38da1104e348bc42763a9702dd6c51ddf4 100644
--- a/src/kernel_services/abstract_interp/tr_offset.mli
+++ b/src/kernel_services/abstract_interp/tr_offset.mli
@@ -28,12 +28,12 @@ type t = private
| Invalid (** No location is valid *)
| Set of Integer.t list (** Limited number of locations *)
| Interval of (** min *) Integer.t *
- (** max *) Integer.t *
- (** modu *)Integer.t
+ (** max *) Integer.t *
+ (** modu *)Integer.t
| Overlap of (** min *) Integer.t *
- (** max *) Integer.t *
- Origin.t (** The location covers the entire range [min..max],
- but consecutive offsets overlap *)
+ (** max *) Integer.t *
+ Origin.t (** The location covers the entire range [min..max],
+ but consecutive offsets overlap *)
val pretty: t Pretty_utils.formatter
@@ -62,7 +62,7 @@ val trim_by_validity :
then we must emit an alarm. This translates to
[start_to<min_valid || stop_to > max_sure_valid]. This convention works
even when [min_valid..max_sure_valid] is not a real interval.
- *)
+*)
(*
Local Variables:
diff --git a/src/kernel_services/analysis/bit_utils.ml b/src/kernel_services/analysis/bit_utils.ml
index 05491e1df7a2c74275341269f94c4385630e1bbd..363dadb79a717b73087e07bcdbd6794f88243728 100644
--- a/src/kernel_services/analysis/bit_utils.ml
+++ b/src/kernel_services/analysis/bit_utils.ml
@@ -40,8 +40,8 @@ let max_byte_size () =
(** 8 * 2^(8 * sizeof( void * )) *)
let max_bit_size () =
Integer.mul
- (sizeofchar())
- (max_byte_size ())
+ (sizeofchar())
+ (max_byte_size ())
(** 2^(8 x sizeof( void * )) - 1 *)
let max_byte_address () = Integer.pred (max_byte_size())
@@ -60,8 +60,8 @@ let warn_if_zero ty r =
[Int_Base.top]. *)
let sizeof ty =
(match ty with
- | TVoid _ -> Kernel.warning ~current:true ~once:true "using size of 'void'"
- | _ -> ()) ;
+ | TVoid _ -> Kernel.warning ~current:true ~once:true "using size of 'void'"
+ | _ -> ()) ;
try Int_Base.inject (Integer.of_int (bitsSizeOf ty))
with SizeOfError _ ->
Int_Base.top
@@ -70,8 +70,8 @@ let sizeof ty =
[Int_Base.top]. *)
let osizeof ty =
(match ty with
- | TVoid _ -> Kernel.warning ~once:true ~current:true "using size of 'void'"
- | _ -> ()) ;
+ | TVoid _ -> Kernel.warning ~once:true ~current:true "using size of 'void'"
+ | _ -> ()) ;
try
Int_Base.inject (Integer.of_int (warn_if_zero ty (bitsSizeOf ty) / 8))
with SizeOfError _ -> Int_Base.top
@@ -106,9 +106,9 @@ let sizeof_lval lv =
match off with
| NoOffset | Index (_,NoOffset) -> sizeof typ
| Field (f,NoOffset) ->
- (match f.fbitfield with
- | None -> sizeof typ
- | Some i -> Int_Base.inject (Integer.of_int i))
+ (match f.fbitfield with
+ | None -> sizeof typ
+ | Some i -> Int_Base.inject (Integer.of_int i))
| Field (_,f) | Index(_,f) -> get_size f
in get_size (snd lv)
@@ -118,21 +118,21 @@ let sizeof_lval lv =
Never call it on a non pointer type. *)
let sizeof_pointed typ =
match unrollType typ with
- | TPtr (typ,_) -> sizeof typ
- | TArray(typ,_,_,_) -> sizeof typ
- | _ ->
- Kernel.fatal "TYPE IS: %a (unrolled as %a)"
- Printer.pp_typ typ
- Printer.pp_typ (unrollType typ)
+ | TPtr (typ,_) -> sizeof typ
+ | TArray(typ,_,_,_) -> sizeof typ
+ | _ ->
+ Kernel.fatal "TYPE IS: %a (unrolled as %a)"
+ Printer.pp_typ typ
+ Printer.pp_typ (unrollType typ)
(** Returns the size of the type pointed by a pointer type in bytes.
Never call it on a non pointer type. *)
let osizeof_pointed typ =
match unrollType typ with
- | TPtr (typ,_) -> osizeof typ
- | TArray(typ,_,_,_) -> osizeof typ
- | _ ->
- assert false (*
+ | TPtr (typ,_) -> osizeof typ
+ | TArray(typ,_,_,_) -> osizeof typ
+ | _ ->
+ assert false (*
Format.printf "TYPE IS: %a\n" Printer.pp_typ typ;
Int_Base.top*)
@@ -166,13 +166,13 @@ type ppenv = {
type bfinfo = Other | Bitfield of int64
type fieldpart =
| NamedField of string * bfinfo * typ * Integer.t * Integer.t * Integer.t
- (* name, parameters to pretty_bits_internal for the field *)
+ (* name, parameters to pretty_bits_internal for the field *)
| RawField of char * Integer.t * Integer.t
- (* parameters for raw_bits of the raw field *)
+ (* parameters for raw_bits of the raw field *)
type arraypart =
| ArrayPart of Integer.t * Integer.t * typ * Integer.t * Integer.t * Integer.t
- (* start index, stop index, typ of element , align , start, stop *)
+ (* start index, stop index, typ of element , align , start, stop *)
let rec pretty_bits_internal env bfinfo typ ~align ~start ~stop =
assert ( Integer.le Integer.zero align
@@ -215,41 +215,41 @@ let rec pretty_bits_internal env bfinfo typ ~align ~start ~stop =
Abstract_interp.Int.pretty stop;
false) else true);
match (unrollType typ) with
- | TInt (_ , _) | TPtr (_, _) | TEnum (_, _) | TFloat (_, _)
- | TVoid _ | TBuiltin_va_list _ | TNamed _ | TFun (_, _, _, _) as typ ->
- let size =
- match bfinfo with
- | Other -> begin
- try Integer.of_int (bitsSizeOf typ)
- with Cil.SizeOfError _ -> Integer.zero
- end
- | Bitfield i -> Integer.of_int64 i
- in
- (if Integer.is_zero start
- && Integer.equal size req_size then
- (** pretty print a full offset *)
- (if not env.use_align ||
- (Integer.equal start align && Integer.equal env.rh_size size)
- then update_types typ
- else (env.types <- Mixed;
- env.misaligned <- true ;
- Format.pp_print_char env.fmt '#'))
- else (
- env.types <- Mixed;
- raw_bits 'b' start stop)
- )
-
- | TComp (compinfo, _, _) as typ ->
- let size = Integer.of_int (try bitsSizeOf typ
+ | TInt (_ , _) | TPtr (_, _) | TEnum (_, _) | TFloat (_, _)
+ | TVoid _ | TBuiltin_va_list _ | TNamed _ | TFun (_, _, _, _) as typ ->
+ let size =
+ match bfinfo with
+ | Other -> begin
+ try Integer.of_int (bitsSizeOf typ)
+ with Cil.SizeOfError _ -> Integer.zero
+ end
+ | Bitfield i -> Integer.of_int64 i
+ in
+ (if Integer.is_zero start
+ && Integer.equal size req_size then
+ (** pretty print a full offset *)
+ (if not env.use_align ||
+ (Integer.equal start align && Integer.equal env.rh_size size)
+ then update_types typ
+ else (env.types <- Mixed;
+ env.misaligned <- true ;
+ Format.pp_print_char env.fmt '#'))
+ else (
+ env.types <- Mixed;
+ raw_bits 'b' start stop)
+ )
+
+ | TComp (compinfo, _, _) as typ ->
+ let size = Integer.of_int (try bitsSizeOf typ
with SizeOfError _ -> 0)
- in
- if (not env.use_align) && Integer.compare req_size size = 0
- then
- update_types typ (* do not print sub-fields if the size is exactly
- the right one and the alignment is not important *)
- else begin
- try
- let full_fields_to_print = List.fold_left
+ in
+ if (not env.use_align) && Integer.compare req_size size = 0
+ then
+ update_types typ (* do not print sub-fields if the size is exactly
+ the right one and the alignment is not important *)
+ else begin
+ try
+ let full_fields_to_print = List.fold_left
(fun acc field ->
let start_o,width_o = fieldBitsOffset field in
let start_o,width_o =
@@ -284,142 +284,142 @@ let rec pretty_bits_internal env bfinfo typ ~align ~start ~stop =
acc)
[]
(Option.value ~default:[] compinfo.cfields)
- in
- (** find non covered intervals in structs *)
- let non_covered,succ_last =
- if compinfo.cstruct then
- List.fold_left
- (fun ((s,last_field_offset) as acc) field ->
- let current_offset = Field (field,NoOffset) in
- let start_o,width_o = bitsOffset typ current_offset in
- let start_o,width_o =
- Integer.of_int start_o, Integer.of_int width_o
- in
- let succ_stop_o = Integer.add start_o width_o in
- if Integer.gt start_o stop then acc
- else if Integer.le succ_stop_o start then acc
- else if Integer.gt start_o last_field_offset then
- (* found a hole *)
- (RawField('c', last_field_offset,Integer.pred start_o)::s,
- succ_stop_o)
- else
- (s,succ_stop_o)
- )
- (full_fields_to_print,start)
- (Option.value ~default:[] compinfo.cfields)
- else full_fields_to_print, Integer.zero
- in
- let overflowing =
- if compinfo.cstruct && Integer.le succ_last stop
- then RawField('o',Integer.max start succ_last,stop)::non_covered
- else non_covered
- in
- let pretty_one_field = function
- | NamedField(name,bf,ftyp,align,start,stop) ->
- Format.fprintf env.fmt ".%s" name ;
- pretty_bits_internal env bf ftyp ~align ~start ~stop
- | RawField(c,start,stop) ->
- env.types <- Mixed;
- Format.pp_print_char env.fmt '.' ;
- raw_bits c start stop
- in
- let rec pretty_all_fields = function
- | [] -> ()
- | [f] -> pretty_one_field f
- | f::fs ->
- pretty_all_fields fs ;
- Format.pp_print_string env.fmt "; ";
- pretty_one_field f ;
- in
- match overflowing with
- | [] -> Format.pp_print_string env.fmt "{}"
- | [f] -> pretty_one_field f
- | fs ->
- Format.pp_print_char env.fmt '{' ;
- pretty_all_fields fs ;
- Format.pp_print_char env.fmt '}'
- with Cil.SizeOfError _ ->
- raw_bits '?' start stop
- end
-
- | TArray (typ, _, _, _) ->
- let size =
- try Integer.of_int (bitsSizeOf typ)
- with Cil.SizeOfError _ -> Integer.zero
- in
- if Integer.is_zero size then
- raw_bits 'z' start stop
- else
- let start_case,rem_start_size = Integer.e_div_rem start size in
- let stop_case,rem_stop_size = Integer.e_div_rem stop size in
- if Integer.equal start_case stop_case then (** part of one element *)
- let new_align =
- Integer.e_rem
- (Integer.sub align (Integer.mul start_case size))
- env.rh_size
- in
- Format.fprintf env.fmt "[%a]" Abstract_interp.Int.pretty start_case;
- pretty_bits_internal env Other typ
- ~align:new_align
- ~start:rem_start_size
- ~stop:rem_stop_size
- else if Integer.equal (Integer.e_rem start env.rh_size) align
- && (Integer.is_zero (Integer.e_rem size env.rh_size))
- then
- let pred_size = Integer.pred size in
- let start_full_case =
- if Integer.is_zero rem_start_size then start_case
- else Integer.succ start_case
- in
- let stop_full_case =
- if Integer.equal rem_stop_size pred_size then stop_case
- else Integer.pred stop_case
- in
- let first_part = if Integer.is_zero rem_start_size
- then []
- else [ArrayPart(start_case,start_case,
- typ,align,rem_start_size,pred_size)]
- in
- let middle_part =
- if Integer.lt stop_full_case start_full_case
- then []
- else [ArrayPart(start_full_case,stop_full_case,
- typ,align,Integer.zero,pred_size)]
- in
- let last_part =
- if Integer.equal rem_stop_size pred_size
- then []
- else [ArrayPart(stop_case,stop_case,
- typ,align,Integer.zero,rem_stop_size)]
- in
- let do_part = function
- | ArrayPart(start_index,stop_index,typ,align,start,stop) ->
- if Integer.equal start_index stop_index then
- Format.fprintf env.fmt "[%a]"
- Abstract_interp.Int.pretty start_index
- else
- Format.fprintf env.fmt "[%a..%a]"
- Abstract_interp.Int.pretty start_index
- Abstract_interp.Int.pretty stop_index ;
- pretty_bits_internal env Other typ ~align ~start ~stop
- in
- let rec do_all_parts = function
- | [] -> ()
- | [p] -> do_part p
- | p::ps ->
- do_part p ;
- Format.pp_print_string env.fmt "; " ;
- do_all_parts ps
- in
- match first_part @ middle_part @ last_part with
- | [] -> Format.pp_print_string env.fmt "{}"
- | [p] -> do_part p
- | ps ->
- Format.pp_print_char env.fmt '{' ;
- do_all_parts ps ;
- Format.pp_print_char env.fmt '}' ;
- else (env.types <- Mixed;
- raw_bits 'a' start stop)
+ in
+ (** find non covered intervals in structs *)
+ let non_covered,succ_last =
+ if compinfo.cstruct then
+ List.fold_left
+ (fun ((s,last_field_offset) as acc) field ->
+ let current_offset = Field (field,NoOffset) in
+ let start_o,width_o = bitsOffset typ current_offset in
+ let start_o,width_o =
+ Integer.of_int start_o, Integer.of_int width_o
+ in
+ let succ_stop_o = Integer.add start_o width_o in
+ if Integer.gt start_o stop then acc
+ else if Integer.le succ_stop_o start then acc
+ else if Integer.gt start_o last_field_offset then
+ (* found a hole *)
+ (RawField('c', last_field_offset,Integer.pred start_o)::s,
+ succ_stop_o)
+ else
+ (s,succ_stop_o)
+ )
+ (full_fields_to_print,start)
+ (Option.value ~default:[] compinfo.cfields)
+ else full_fields_to_print, Integer.zero
+ in
+ let overflowing =
+ if compinfo.cstruct && Integer.le succ_last stop
+ then RawField('o',Integer.max start succ_last,stop)::non_covered
+ else non_covered
+ in
+ let pretty_one_field = function
+ | NamedField(name,bf,ftyp,align,start,stop) ->
+ Format.fprintf env.fmt ".%s" name ;
+ pretty_bits_internal env bf ftyp ~align ~start ~stop
+ | RawField(c,start,stop) ->
+ env.types <- Mixed;
+ Format.pp_print_char env.fmt '.' ;
+ raw_bits c start stop
+ in
+ let rec pretty_all_fields = function
+ | [] -> ()
+ | [f] -> pretty_one_field f
+ | f::fs ->
+ pretty_all_fields fs ;
+ Format.pp_print_string env.fmt "; ";
+ pretty_one_field f ;
+ in
+ match overflowing with
+ | [] -> Format.pp_print_string env.fmt "{}"
+ | [f] -> pretty_one_field f
+ | fs ->
+ Format.pp_print_char env.fmt '{' ;
+ pretty_all_fields fs ;
+ Format.pp_print_char env.fmt '}'
+ with Cil.SizeOfError _ ->
+ raw_bits '?' start stop
+ end
+
+ | TArray (typ, _, _, _) ->
+ let size =
+ try Integer.of_int (bitsSizeOf typ)
+ with Cil.SizeOfError _ -> Integer.zero
+ in
+ if Integer.is_zero size then
+ raw_bits 'z' start stop
+ else
+ let start_case,rem_start_size = Integer.e_div_rem start size in
+ let stop_case,rem_stop_size = Integer.e_div_rem stop size in
+ if Integer.equal start_case stop_case then (** part of one element *)
+ let new_align =
+ Integer.e_rem
+ (Integer.sub align (Integer.mul start_case size))
+ env.rh_size
+ in
+ Format.fprintf env.fmt "[%a]" Abstract_interp.Int.pretty start_case;
+ pretty_bits_internal env Other typ
+ ~align:new_align
+ ~start:rem_start_size
+ ~stop:rem_stop_size
+ else if Integer.equal (Integer.e_rem start env.rh_size) align
+ && (Integer.is_zero (Integer.e_rem size env.rh_size))
+ then
+ let pred_size = Integer.pred size in
+ let start_full_case =
+ if Integer.is_zero rem_start_size then start_case
+ else Integer.succ start_case
+ in
+ let stop_full_case =
+ if Integer.equal rem_stop_size pred_size then stop_case
+ else Integer.pred stop_case
+ in
+ let first_part = if Integer.is_zero rem_start_size
+ then []
+ else [ArrayPart(start_case,start_case,
+ typ,align,rem_start_size,pred_size)]
+ in
+ let middle_part =
+ if Integer.lt stop_full_case start_full_case
+ then []
+ else [ArrayPart(start_full_case,stop_full_case,
+ typ,align,Integer.zero,pred_size)]
+ in
+ let last_part =
+ if Integer.equal rem_stop_size pred_size
+ then []
+ else [ArrayPart(stop_case,stop_case,
+ typ,align,Integer.zero,rem_stop_size)]
+ in
+ let do_part = function
+ | ArrayPart(start_index,stop_index,typ,align,start,stop) ->
+ if Integer.equal start_index stop_index then
+ Format.fprintf env.fmt "[%a]"
+ Abstract_interp.Int.pretty start_index
+ else
+ Format.fprintf env.fmt "[%a..%a]"
+ Abstract_interp.Int.pretty start_index
+ Abstract_interp.Int.pretty stop_index ;
+ pretty_bits_internal env Other typ ~align ~start ~stop
+ in
+ let rec do_all_parts = function
+ | [] -> ()
+ | [p] -> do_part p
+ | p::ps ->
+ do_part p ;
+ Format.pp_print_string env.fmt "; " ;
+ do_all_parts ps
+ in
+ match first_part @ middle_part @ last_part with
+ | [] -> Format.pp_print_string env.fmt "{}"
+ | [p] -> do_part p
+ | ps ->
+ Format.pp_print_char env.fmt '{' ;
+ do_all_parts ps ;
+ Format.pp_print_char env.fmt '}' ;
+ else (env.types <- Mixed;
+ raw_bits 'a' start stop)
let pretty_bits typ ~use_align ~align ~rh_size ~start ~stop fmt =
@@ -447,8 +447,8 @@ let pretty_bits typ ~use_align ~align ~rh_size ~start ~stop fmt =
pretty_bits_internal env Other typ ~align ~start ~stop ;
env.misaligned,
(match env.types with
- | Mixed | NoneYet -> None
- | SomeType t -> Some t)
+ | Mixed | NoneYet -> None
+ | SomeType t -> Some t)
(* -------------------------------------------------------------------------- *)
(* --- Mapping numeric offset -> symbolic one --- *)
@@ -457,9 +457,9 @@ let pretty_bits typ ~use_align ~align ~rh_size ~start ~stop fmt =
exception NoMatchingOffset
type offset_match =
-| MatchType of typ
-| MatchSize of Integer.t
-| MatchFirst
+ | MatchType of typ
+ | MatchSize of Integer.t
+ | MatchFirst
(* Comparison of the shape of two types. Attributes are completely ignored. *)
let rec equal_type_no_attribute t1 t2 =
@@ -470,23 +470,23 @@ let rec equal_type_no_attribute t1 t2 =
| TPtr (t1, _), TPtr (t2, _) -> equal_type_no_attribute t1 t2
| TArray (t1', s1, _, _), TArray (t2', s2, _, _) ->
equal_type_no_attribute t1' t2' &&
- (s1 == s2 || try Integer.equal (Cil.lenOfArray64 s1) (Cil.lenOfArray64 s2)
- with Cil.LenOfArray -> false)
+ (s1 == s2 || try Integer.equal (Cil.lenOfArray64 s1) (Cil.lenOfArray64 s2)
+ with Cil.LenOfArray -> false)
| TFun (r1, a1, v1, _), TFun (r2, a2, v2, _) ->
v1 = v2 && equal_type_no_attribute r1 r2 &&
(match a1, a2 with
- | None, _ | _, None -> true
- | Some l1, Some l2 ->
- try
- List.for_all2
- (fun (_, t1, _) (_, t2, _) -> equal_type_no_attribute t1 t2) l1 l2
- with Invalid_argument _ -> false)
+ | None, _ | _, None -> true
+ | Some l1, Some l2 ->
+ try
+ List.for_all2
+ (fun (_, t1, _) (_, t2, _) -> equal_type_no_attribute t1 t2) l1 l2
+ with Invalid_argument _ -> false)
| TNamed _, TNamed _ -> assert false
| TComp (c1, _, _), TComp (c2, _, _) -> c1.ckey = c2.ckey
| TEnum (e1, _), TEnum (e2, _) -> e1.ename = e2.ename
| TBuiltin_va_list _, TBuiltin_va_list _ -> true
| (TVoid _ | TInt _ | TFloat _ | TPtr _ | TArray _ | TFun _ | TNamed _ |
- TComp _ | TEnum _ | TBuiltin_va_list _), _ ->
+ TComp _ | TEnum _ | TBuiltin_va_list _), _ ->
false
(* We have found a possible matching offset of type [typ] for [om], do we stop
diff --git a/src/kernel_services/analysis/bit_utils.mli b/src/kernel_services/analysis/bit_utils.mli
index a9d28aad6d5c6940c7e87f12f64503ece03a465e..c3d0d592c6ff6e1a2bd10fea399c6c11446c9113 100644
--- a/src/kernel_services/analysis/bit_utils.mli
+++ b/src/kernel_services/analysis/bit_utils.mli
@@ -25,61 +25,61 @@
open Cil_types
val sizeofchar: unit -> Integer.t
- (** [sizeof(char)] in bits *)
+(** [sizeof(char)] in bits *)
val sizeofpointer: unit -> int
- (** [sizeof(char* )] in bits *)
+(** [sizeof(char* )] in bits *)
val sizeof: typ -> Int_Base.t
- (** [sizeof ty] is the size of [ty] in bits. This function may return
- [Int_Base.top]. *)
+(** [sizeof ty] is the size of [ty] in bits. This function may return
+ [Int_Base.top]. *)
val osizeof: typ -> Int_Base.t
- (** [osizeof ty] is the size of [ty] in bytes. This function may return
- [Int_Base.top]. *)
+(** [osizeof ty] is the size of [ty] in bytes. This function may return
+ [Int_Base.top]. *)
exception Neither_Int_Nor_Enum_Nor_Pointer
val is_signed_int_enum_pointer: typ -> bool
- (** [true] means that the type is signed.
- @raise Neither_Int_Nor_Enum_Nor_Pointer if the sign of the type is not
- meaningful. *)
+(** [true] means that the type is signed.
+ @raise Neither_Int_Nor_Enum_Nor_Pointer if the sign of the type is not
+ meaningful. *)
val signof_typeof_lval: lval -> bool
- (** @return the sign of type of the [lval]. [true] means that the type is
- signed. *)
+(** @return the sign of type of the [lval]. [true] means that the type is
+ signed. *)
val sizeof_vid: varinfo -> Int_Base.t
- (** @return the size of the type of the variable in bits. *)
+(** @return the size of the type of the variable in bits. *)
val sizeof_lval: lval -> Int_Base.t
- (** @return the size of the type of the left value in bits. *)
+(** @return the size of the type of the left value in bits. *)
val sizeof_pointed: typ -> Int_Base.t
- (** @return the size of the type pointed by a pointer or array type in bits.
- Never call it on a non pointer or non array type . *)
+(** @return the size of the type pointed by a pointer or array type in bits.
+ Never call it on a non pointer or non array type . *)
val osizeof_pointed: typ -> Int_Base.t
- (** @return the size of the type pointed by a pointer or array type in bytes.
- Never call it on a non pointer or array type. *)
+(** @return the size of the type pointed by a pointer or array type in bytes.
+ Never call it on a non pointer or array type. *)
val sizeof_pointed_lval: lval -> Int_Base.t
- (** @return the size of the type pointed by a pointer type of the [lval] in
- bits. Never call it on a non pointer type [lval]. *)
+(** @return the size of the type pointed by a pointer type of the [lval] in
+ bits. Never call it on a non pointer type [lval]. *)
val max_bit_address : unit -> Integer.t
- (** @return the maximal possible offset in bits of a memory base. *)
+(** @return the maximal possible offset in bits of a memory base. *)
val max_bit_size : unit -> Integer.t
- (** @return the maximal possible size in bits of a memory base. *)
+(** @return the maximal possible size in bits of a memory base. *)
val max_byte_address : unit -> Integer.t
- (** @return the maximal possible offset in bytes of a memory base.
- @since Aluminium-20160501 *)
+(** @return the maximal possible offset in bytes of a memory base.
+ @since Aluminium-20160501 *)
val max_byte_size : unit -> Integer.t
- (** @return the maximal possible size in bytes of a memory base.
- @since Aluminium-20160501 *)
+(** @return the maximal possible size in bytes of a memory base.
+ @since Aluminium-20160501 *)
(** {2 Pretty printing} *)
@@ -90,8 +90,8 @@ val pretty_bits:
rh_size:Integer.t ->
start:Integer.t ->
stop:Integer.t -> Format.formatter -> bool * typ option
- (** Pretty prints a range of bits in a type for the user.
- Tries to find field names and array indexes, whenever possible. *)
+(** Pretty prints a range of bits in a type for the user.
+ Tries to find field names and array indexes, whenever possible. *)
(** {2 Mapping from numeric offsets to symbolic ones.} *)
@@ -99,9 +99,9 @@ val pretty_bits:
(** We want to find a symbolic offset that corresponds to a numeric one, with
one additional criterion: *)
type offset_match =
-| MatchType of typ (** Offset that has this type (modulo attributes) *)
-| MatchSize of Integer.t (** Offset that has a type of this size *)
-| MatchFirst (** Return first symbolic offset that matches *)
+ | MatchType of typ (** Offset that has this type (modulo attributes) *)
+ | MatchSize of Integer.t (** Offset that has a type of this size *)
+ | MatchFirst (** Return first symbolic offset that matches *)
exception NoMatchingOffset
@@ -110,7 +110,7 @@ exception NoMatchingOffset
of [typ], or a type that is a sub-array of an array type in [typ].
Also returns a {!Cil_types.offset} [off] that corresponds to [offset].
(But we do not have the guarantee that [typeof(off) == typ], because of
- sub-arrays.)
+ sub-arrays.)
@raise NoMatchingOffset when no offset matches. *)
val find_offset:
typ -> offset:Integer.t -> offset_match -> Cil_types.offset * Cil_types.typ
diff --git a/src/kernel_services/analysis/dataflow2.ml b/src/kernel_services/analysis/dataflow2.ml
index 6d63d328f0356306643babf3c76023e0bb8f7862..cf8b56d4fd9918dac1fcc4d4ffa988fd26420f4c 100644
--- a/src/kernel_services/analysis/dataflow2.ml
+++ b/src/kernel_services/analysis/dataflow2.ml
@@ -37,8 +37,8 @@ type 't stmtaction =
SDefault (** The default action *)
| SDone (** Do not visit this statement or its successors *)
| SUse of 't (** Visit the instructions and successors of this statement
- as usual, but use the specified state instead of the
- one that was passed to doStmt *)
+ as usual, but use the specified state instead of the
+ one that was passed to doStmt *)
(* For if statements *)
type 't guardaction =
@@ -85,17 +85,17 @@ let current_kf = function
module type WORKLIST = sig
type t
-(** Create a worklist for function [kf], initially populated by the stmt list. *)
+ (** Create a worklist for function [kf], initially populated by the stmt list. *)
val create: Kernel_function.t -> stmt list -> t
-(** Add a statement to the worklist. If the statement is already
- there, it is not added a second time. *)
+ (** Add a statement to the worklist. If the statement is already
+ there, it is not added a second time. *)
val add: t -> stmt -> unit
-(** Remove a statement from the worklist. *)
+ (** Remove a statement from the worklist. *)
val clear: t -> stmt -> unit
-(** Tells whether a statement is in the worklist or not. *)
+ (** Tells whether a statement is in the worklist or not. *)
val mem : t -> stmt -> bool
@@ -128,9 +128,9 @@ module Worklist(MaybeReverse:MAYBE_REVERSE):WORKLIST = struct
type ordered_stmt = int
type connex_component = int
-
- type t =
- {
+
+ type t =
+ {
(** Priority queue implemented as a bit vector. Index 0 has the
highest priority.*)
bv: Bitvector.t;
@@ -174,28 +174,28 @@ module Worklist(MaybeReverse:MAYBE_REVERSE):WORKLIST = struct
;;
- let create kf stmts =
+ let create kf stmts =
let (order,unorder,connex) = Ordered_stmt.get_conversion_tables kf in
- let nb_stmts = Array.length unorder in
+ let nb_stmts = Array.length unorder in
let bv = Bitvector.create nb_stmts in
- let (min, ordereds) = List.fold_left (fun (cur_min,cur_list) stmt ->
- let ordered = MaybeReverse.maybe_rev_int (Ordered_stmt.to_ordered order stmt) nb_stmts in
- (min cur_min ordered, ordered::cur_list)) (0,[]) stmts
- in
+ let (min, ordereds) = List.fold_left (fun (cur_min,cur_list) stmt ->
+ let ordered = MaybeReverse.maybe_rev_int (Ordered_stmt.to_ordered order stmt) nb_stmts in
+ (min cur_min ordered, ordered::cur_list)) (0,[]) stmts
+ in
List.iter (fun ordered -> Bitvector.set bv ordered) ordereds;
let next = min in
let current_scc = connex.(next) in
let must_restart_cc = None in
{ bv; order; unorder; next; current_scc; connex; must_restart_cc }
- let add t stmt =
+ let add t stmt =
let i = ordered_from_stmt t stmt in
Bitvector.set t.bv i;
- if i < t.next
- then t.must_restart_cc <-
- match t.must_restart_cc with
- | None -> Some(i)
- | Some(j) -> Some(min i j)
+ if i < t.next
+ then t.must_restart_cc <-
+ match t.must_restart_cc with
+ | None -> Some(i)
+ | Some(j) -> Some(min i j)
;;
let clear t stmt =
@@ -203,7 +203,7 @@ module Worklist(MaybeReverse:MAYBE_REVERSE):WORKLIST = struct
Bitvector.clear t.bv i;
;;
- let mem t stmt =
+ let mem t stmt =
let i = ordered_from_stmt t stmt in
Bitvector.mem t.bv i;
;;
@@ -214,22 +214,22 @@ module Worklist(MaybeReverse:MAYBE_REVERSE):WORKLIST = struct
let pop_next t =
- let restart_from i =
+ let restart_from i =
(* We should restart in the same connex component. *)
assert((connex_of_ordered t i) == t.current_scc);
t.must_restart_cc <- None;
i
in
- let real_next =
+ let real_next =
try
let next_true = Bitvector.find_next_true t.bv t.next in
let next_true_scc = connex_of_ordered t next_true in
- if next_true_scc == t.current_scc
- then
+ if next_true_scc == t.current_scc
+ then
(* Continue in the same connex component. *)
- next_true
- else
+ next_true
+ else
(* We reached the end of the current connex component. The
trick is that OCamlgraph's topological ordering guarantee
that elements of the same connex component have
@@ -238,16 +238,16 @@ module Worklist(MaybeReverse:MAYBE_REVERSE):WORKLIST = struct
start over in the same connex component, or continue to
the next cc. *)
((* assert (next_true_scc < t.current_scc); *)
- match t.must_restart_cc with
- | None -> t.current_scc <- next_true_scc; next_true
- | Some(i) -> restart_from i)
- with Not_found ->
+ match t.must_restart_cc with
+ | None -> t.current_scc <- next_true_scc; next_true
+ | Some(i) -> restart_from i)
+ with Not_found ->
(* We found no further work, but it could be because the graph
ends with a non-trivial connex component (e.g. the function
ends with a loop). *)
(match t.must_restart_cc with
- | None -> raise Empty
- | Some(i) -> restart_from i)
+ | None -> raise Empty
+ | Some(i) -> restart_from i)
in
Bitvector.clear t.bv real_next;
t.next <- real_next + 1;
@@ -257,9 +257,9 @@ module Worklist(MaybeReverse:MAYBE_REVERSE):WORKLIST = struct
stmt
;;
- let fold f t init =
- Bitvector.fold_true (fun acc i ->
- f (stmt_from_ordered t i) acc) init t.bv
+ let fold f t init =
+ Bitvector.fold_true (fun acc i ->
+ f (stmt_from_ordered t i) acc) init t.bv
end
@@ -293,248 +293,248 @@ end
module Forwards(T : ForwardsTransfer) = struct
- (** We call this function when we have encountered a statement, with some
- * state. *)
- let reachedStatement worklist pred (s: stmt) (d: T.t) : unit =
- (** see if we know about it already *)
- let d = T.doEdge pred s d in
- let newdata: T.t option =
- try
- let old = T.StmtStartData.find s in
- match T.combinePredecessors s ~old:old d with
- None -> (* We are done here *)
- if T.debug then
- Kernel.debug "FF(%s): reached stmt %d with %a\n implies the old state %a\n"
- T.name s.sid T.pretty d T.pretty old;
- None
- | Some d' -> begin
- (* We have changed the data *)
- if T.debug then
- Kernel.debug "FF(%s): weaken data for block %d: %a\n"
- T.name s.sid T.pretty d';
- Some d'
- end
- with Not_found -> (* was bottom before *)
- let d' = T.computeFirstPredecessor s d in
+ (** We call this function when we have encountered a statement, with some
+ * state. *)
+ let reachedStatement worklist pred (s: stmt) (d: T.t) : unit =
+ (** see if we know about it already *)
+ let d = T.doEdge pred s d in
+ let newdata: T.t option =
+ try
+ let old = T.StmtStartData.find s in
+ match T.combinePredecessors s ~old:old d with
+ None -> (* We are done here *)
if T.debug then
- Kernel.debug "FF(%s): set data for block %d: %a\n"
- T.name s.sid T.pretty d';
- Some d'
- in
- match newdata with
- None -> ()
- | Some d' ->
- T.StmtStartData.replace s d';
- ForwardWorklist.add worklist s
-
- (** Process a statement *)
- let processStmt worklist (s: stmt) : unit =
- CurrentLoc.set (Cil_datatype.Stmt.loc s);
- if T.debug then
- Kernel.debug "FF(%s).stmt %d at %t@\n" T.name s.sid Cil.pp_thisloc;
-
- (* It must be the case that the block has some data *)
- let init: T.t =
- try T.copy (T.StmtStartData.find s)
- with Not_found ->
- Kernel.fatal ~current:true
- "FF(%s): processing block without data" T.name
- in
-
- (** See what the custom says *)
- match T.doStmt s init with
- | SDone -> ()
- | (SDefault | SUse _) as act -> begin
- let curr = match act with
- | SDefault -> init
- | SUse d -> d
- | SDone -> assert false
- and do_succs state =
- List.iter (fun s' -> reachedStatement worklist s s' state) s.succs
- in
+ Kernel.debug "FF(%s): reached stmt %d with %a\n implies the old state %a\n"
+ T.name s.sid T.pretty d T.pretty old;
+ None
+ | Some d' -> begin
+ (* We have changed the data *)
+ if T.debug then
+ Kernel.debug "FF(%s): weaken data for block %d: %a\n"
+ T.name s.sid T.pretty d';
+ Some d'
+ end
+ with Not_found -> (* was bottom before *)
+ let d' = T.computeFirstPredecessor s d in
+ if T.debug then
+ Kernel.debug "FF(%s): set data for block %d: %a\n"
+ T.name s.sid T.pretty d';
+ Some d'
+ in
+ match newdata with
+ None -> ()
+ | Some d' ->
+ T.StmtStartData.replace s d';
+ ForwardWorklist.add worklist s
+
+ (** Process a statement *)
+ let processStmt worklist (s: stmt) : unit =
+ CurrentLoc.set (Cil_datatype.Stmt.loc s);
+ if T.debug then
+ Kernel.debug "FF(%s).stmt %d at %t@\n" T.name s.sid Cil.pp_thisloc;
+
+ (* It must be the case that the block has some data *)
+ let init: T.t =
+ try T.copy (T.StmtStartData.find s)
+ with Not_found ->
+ Kernel.fatal ~current:true
+ "FF(%s): processing block without data" T.name
+ in
- CurrentLoc.set (Cil_datatype.Stmt.loc s);
- match s.skind with
- | Instr i ->
- CurrentLoc.set (Cil_datatype.Instr.loc i);
- let after = T.doInstr s i curr in
- do_succs after
-
- | UnspecifiedSequence _
- | Goto _ | Break _ | Continue _
- | TryExcept _ | TryFinally _
- | Loop _ | Return _ | Block _ -> do_succs curr
- | Throw _ | TryCatch _ ->
- Kernel.not_yet_implemented ~current:true
- "[dataflow] exception handling"
-
-
- | If (e, _, _, _) ->
- let thenGuard, elseGuard = T.doGuard s e curr in
- if thenGuard = GDefault && elseGuard = GDefault then
- (* this is the common case *)
- do_succs curr
- else begin
- let doBranch succ guard =
- match guard with
- GDefault -> reachedStatement worklist s succ curr
- | GUse d -> reachedStatement worklist s succ d
- | GUnreachable ->
- if T.debug then
- (Kernel.debug "FF(%s): Not exploring branch to %d\n"
- T.name succ.sid)
- in
- let thenSucc, elseSucc = Cil.separate_if_succs s in
- doBranch thenSucc thenGuard;
- doBranch elseSucc elseGuard;
- end
-
- | Switch (exp_sw, _, _, _) ->
- let cases, default = Cil.separate_switch_succs s in
- (* Auxiliary function that iterates on all the labels of
- the switch. The accumulator is the state after the
- evaluation of the label, and the default case *)
- let iter_all_labels f =
- List.fold_left
- (fun rem_state succ ->
- if rem_state = None then None
- else
- List.fold_left
- (fun rem_state label ->
- match rem_state with
- | None -> rem_state
- | Some state -> f succ label state
- ) rem_state succ.labels
- ) (Some curr) cases
- in
- (* Compute a successor of the switch, starting with the state
- [before], supposing we are considering the label [exp] *)
- let explore_succ before succ exp_case =
- let exp = match exp_case.enode with
- (* This helps when switch is used on boolean expressions. *)
- | Const (CInt64 (z,_,_))
- when Integer.equal z Integer.zero ->
- new_exp ~loc:exp_sw.eloc (UnOp(LNot,exp_sw,intType))
- | _ ->
- Cil.new_exp exp_case.eloc
- (BinOp (Eq, exp_sw, exp_case, Cil.intType))
- in
- let branch_case, branch_not_case = T.doGuard s exp before in
- (match branch_case with
- | GDefault -> reachedStatement worklist s succ before;
- | GUse d -> reachedStatement worklist s succ d;
- | GUnreachable ->
- if T.debug then
- Kernel.debug "FF(%s): Not exploring branch to %d\n"
- T.name succ.sid;
- );
- (* State corresponding to the negation of [exp], to
- be used for the remaining labels *)
- match branch_not_case with
- | GDefault -> Some before
- | GUse d -> Some d
- | GUnreachable -> None
- in
- (* Evaluate all of the labels one after the other, refining
- the state after each case *)
- let after = iter_all_labels
- (fun succ label before ->
- match label with
- | Label _ (* Label not related to the switch *)
- | Cil_types.Default _ -> (* The default case is handled at the end *)
- (Some before)
-
- | Case (exp_case, _) ->
- let after = explore_succ before succ exp_case in after
-
- ) in
- (* If [after] is different from [None], we must evaluate
- the default case, be it a default label, or the
- successor of the switch *)
- (match after with
- | None -> ()
- | Some state -> reachedStatement worklist s default state)
+ (** See what the custom says *)
+ match T.doStmt s init with
+ | SDone -> ()
+ | (SDefault | SUse _) as act -> begin
+ let curr = match act with
+ | SDefault -> init
+ | SUse d -> d
+ | SDone -> assert false
+ and do_succs state =
+ List.iter (fun s' -> reachedStatement worklist s s' state) s.succs
+ in
+
+ CurrentLoc.set (Cil_datatype.Stmt.loc s);
+ match s.skind with
+ | Instr i ->
+ CurrentLoc.set (Cil_datatype.Instr.loc i);
+ let after = T.doInstr s i curr in
+ do_succs after
+
+ | UnspecifiedSequence _
+ | Goto _ | Break _ | Continue _
+ | TryExcept _ | TryFinally _
+ | Loop _ | Return _ | Block _ -> do_succs curr
+ | Throw _ | TryCatch _ ->
+ Kernel.not_yet_implemented ~current:true
+ "[dataflow] exception handling"
+
+
+ | If (e, _, _, _) ->
+ let thenGuard, elseGuard = T.doGuard s e curr in
+ if thenGuard = GDefault && elseGuard = GDefault then
+ (* this is the common case *)
+ do_succs curr
+ else begin
+ let doBranch succ guard =
+ match guard with
+ GDefault -> reachedStatement worklist s succ curr
+ | GUse d -> reachedStatement worklist s succ d
+ | GUnreachable ->
+ if T.debug then
+ (Kernel.debug "FF(%s): Not exploring branch to %d\n"
+ T.name succ.sid)
+ in
+ let thenSucc, elseSucc = Cil.separate_if_succs s in
+ doBranch thenSucc thenGuard;
+ doBranch elseSucc elseGuard;
+ end
+
+ | Switch (exp_sw, _, _, _) ->
+ let cases, default = Cil.separate_switch_succs s in
+ (* Auxiliary function that iterates on all the labels of
+ the switch. The accumulator is the state after the
+ evaluation of the label, and the default case *)
+ let iter_all_labels f =
+ List.fold_left
+ (fun rem_state succ ->
+ if rem_state = None then None
+ else
+ List.fold_left
+ (fun rem_state label ->
+ match rem_state with
+ | None -> rem_state
+ | Some state -> f succ label state
+ ) rem_state succ.labels
+ ) (Some curr) cases
+ in
+ (* Compute a successor of the switch, starting with the state
+ [before], supposing we are considering the label [exp] *)
+ let explore_succ before succ exp_case =
+ let exp = match exp_case.enode with
+ (* This helps when switch is used on boolean expressions. *)
+ | Const (CInt64 (z,_,_))
+ when Integer.equal z Integer.zero ->
+ new_exp ~loc:exp_sw.eloc (UnOp(LNot,exp_sw,intType))
+ | _ ->
+ Cil.new_exp exp_case.eloc
+ (BinOp (Eq, exp_sw, exp_case, Cil.intType))
+ in
+ let branch_case, branch_not_case = T.doGuard s exp before in
+ (match branch_case with
+ | GDefault -> reachedStatement worklist s succ before;
+ | GUse d -> reachedStatement worklist s succ d;
+ | GUnreachable ->
+ if T.debug then
+ Kernel.debug "FF(%s): Not exploring branch to %d\n"
+ T.name succ.sid;
+ );
+ (* State corresponding to the negation of [exp], to
+ be used for the remaining labels *)
+ match branch_not_case with
+ | GDefault -> Some before
+ | GUse d -> Some d
+ | GUnreachable -> None
+ in
+ (* Evaluate all of the labels one after the other, refining
+ the state after each case *)
+ let after = iter_all_labels
+ (fun succ label before ->
+ match label with
+ | Label _ (* Label not related to the switch *)
+ | Cil_types.Default _ -> (* The default case is handled at the end *)
+ (Some before)
+
+ | Case (exp_case, _) ->
+ let after = explore_succ before succ exp_case in after
+
+ ) in
+ (* If [after] is different from [None], we must evaluate
+ the default case, be it a default label, or the
+ successor of the switch *)
+ (match after with
+ | None -> ()
+ | Some state -> reachedStatement worklist s default state)
end
- let init_worklist (sources: stmt list) =
- let kf = current_kf sources in
- let worklist = ForwardWorklist.create kf sources in
- List.iter (fun s -> ForwardWorklist.add worklist s) sources;
- worklist
-
- (** All initial stmts must have non-bottom data *)
- let check_initial_stmts (sources: stmt list) =
- List.iter
- (fun s ->
- if not (T.StmtStartData.mem s) then
- Kernel.fatal ~current:true
- "FF(%s): initial stmt %d does not have data"
- T.name s.sid)
- sources
-
- (** Compute the data flow using worklists and starting with the given
- sources. *)
- let compute_worklist (sources: stmt list) =
- check_initial_stmts sources;
- let worklist = init_worklist sources in
-
+ let init_worklist (sources: stmt list) =
+ let kf = current_kf sources in
+ let worklist = ForwardWorklist.create kf sources in
+ List.iter (fun s -> ForwardWorklist.add worklist s) sources;
+ worklist
+
+ (** All initial stmts must have non-bottom data *)
+ let check_initial_stmts (sources: stmt list) =
+ List.iter
+ (fun s ->
+ if not (T.StmtStartData.mem s) then
+ Kernel.fatal ~current:true
+ "FF(%s): initial stmt %d does not have data"
+ T.name s.sid)
+ sources
+
+ (** Compute the data flow using worklists and starting with the given
+ sources. *)
+ let compute_worklist (sources: stmt list) =
+ check_initial_stmts sources;
+ let worklist = init_worklist sources in
+
+ if T.debug then
+ (Kernel.debug "FF(%s): processing" T.name);
+ let rec fixedpoint () =
+ if T.debug && not (ForwardWorklist.is_empty worklist) then
+ (Kernel.debug "FF(%s): worklist= %a"
+ T.name
+ (Pretty_utils.pp_list (fun fmt s -> Format.fprintf fmt "%d" s.sid))
+ (List.rev
+ (ForwardWorklist.fold (fun s acc -> s :: acc) worklist [])));
+ let s = ForwardWorklist.pop_next worklist in
+ processStmt worklist s;
+ fixedpoint ()
+ in
+ try
+ fixedpoint ()
+ with ForwardWorklist.Empty ->
if T.debug then
- (Kernel.debug "FF(%s): processing" T.name);
- let rec fixedpoint () =
- if T.debug && not (ForwardWorklist.is_empty worklist) then
- (Kernel.debug "FF(%s): worklist= %a"
- T.name
- (Pretty_utils.pp_list (fun fmt s -> Format.fprintf fmt "%d" s.sid))
- (List.rev
- (ForwardWorklist.fold (fun s acc -> s :: acc) worklist [])));
- let s = ForwardWorklist.pop_next worklist in
- processStmt worklist s;
- fixedpoint ()
- in
- try
- fixedpoint ()
- with ForwardWorklist.Empty ->
- if T.debug then
- Kernel.debug "FF(%s): done" T.name
-
-
- (** Compute the dataflow for the given strategy. *)
- let compute_strategy (sources: stmt list) (strategy : Wto_statement.wto) =
- check_initial_stmts sources;
- let worklist = init_worklist sources in
- (* the reference "change" tracks whether something has been computed *)
- let rec process_wto change wto =
- List.iter (process_element change) wto
- and process_element change = function
- (* Some statement, process it and mark as changed if necessary *)
- | Wto.Node (stmt) ->
- if ForwardWorklist.mem worklist stmt then begin
- ForwardWorklist.clear worklist stmt;
- processStmt worklist stmt;
- change := true;
- end
- (* Component, iterate until it reached a fixpoint *)
- | Wto.Component (stmt, wto) ->
- let component_change = ref true in
- while !component_change do
- component_change := false;
- process_wto component_change (Wto.Node stmt :: wto);
- if !component_change then
- change := true
- done
- in
- process_wto (ref false) strategy
+ Kernel.debug "FF(%s): done" T.name
+
+
+ (** Compute the dataflow for the given strategy. *)
+ let compute_strategy (sources: stmt list) (strategy : Wto_statement.wto) =
+ check_initial_stmts sources;
+ let worklist = init_worklist sources in
+ (* the reference "change" tracks whether something has been computed *)
+ let rec process_wto change wto =
+ List.iter (process_element change) wto
+ and process_element change = function
+ (* Some statement, process it and mark as changed if necessary *)
+ | Wto.Node (stmt) ->
+ if ForwardWorklist.mem worklist stmt then begin
+ ForwardWorklist.clear worklist stmt;
+ processStmt worklist stmt;
+ change := true;
+ end
+ (* Component, iterate until it reached a fixpoint *)
+ | Wto.Component (stmt, wto) ->
+ let component_change = ref true in
+ while !component_change do
+ component_change := false;
+ process_wto component_change (Wto.Node stmt :: wto);
+ if !component_change then
+ change := true
+ done
+ in
+ process_wto (ref false) strategy
- (** Compute the dataflow for the default strategy. *)
- let compute (sources: stmt list) =
- let kf = current_kf sources in
- let strategy = Wto_statement.wto_of_kf kf in
- compute_strategy sources strategy
+ (** Compute the dataflow for the default strategy. *)
+ let compute (sources: stmt list) =
+ let kf = current_kf sources in
+ let strategy = Wto_statement.wto_of_kf kf in
+ compute_strategy sources strategy
- end
+end
(******************************************************************
@@ -563,113 +563,113 @@ end
module Backwards(T : BackwardsTransfer) =
struct
- let getStmtStartData (s: stmt) : T.t =
- try T.StmtStartData.find s
- with Not_found ->
- Kernel.fatal ~current:true
- "BF(%s): stmtStartData is not initialized for %d"
- T.name s.sid
+ let getStmtStartData (s: stmt) : T.t =
+ try T.StmtStartData.find s
+ with Not_found ->
+ Kernel.fatal ~current:true
+ "BF(%s): stmtStartData is not initialized for %d"
+ T.name s.sid
+
+ (** Process a statement and return true if the set of live return
+ * addresses on its entry has changed. *)
+ let processStmt (s: stmt) : bool =
+ if T.debug then
+ (Kernel.debug "FF(%s).stmt %d\n" T.name s.sid);
+
+
+ (* Find the state before the branch *)
+ CurrentLoc.set (Cil_datatype.Stmt.loc s);
+ let d: T.t =
+ match T.doStmt s with
+ Done d -> d
+ | (Default | Post _) as action -> begin
+ (* Compute the default state, by combining the successors *)
+ let res =
+ (* We restrict ourselves to the successors we are interested in.
+ If T.filterStmt is deterministic, this should not make the
+ list empty if s.succs is not empty, as we would not have
+ reached s otherwise *)
+ match List.filter (T.filterStmt s) s.succs with
+ | [] -> T.funcExitData
+ | fst :: rest ->
+ List.fold_left (fun acc succ ->
+ T.combineSuccessors acc (getStmtStartData succ))
+ (getStmtStartData fst)
+ rest
+ in
+ (* Now do the instructions *)
+ let res' =
+ match s.skind with
+ | Instr i ->
+ begin
+ CurrentLoc.set (Cil_datatype.Instr.loc i);
+ let action = T.doInstr s i res in
+ match action with
+ | Done s' -> s'
+ | Default -> res (* do nothing *)
+ | Post f -> f res
+ end
+ | _ -> res
+ in
+ match action with
+ Post f -> f res'
+ | _ -> res'
+ end
+ in
+
+ (* See if the state has changed. The only changes are that it may grow.*)
+ let s0 = getStmtStartData s in
- (** Process a statement and return true if the set of live return
- * addresses on its entry has changed. *)
- let processStmt (s: stmt) : bool =
+ match T.combineStmtStartData s ~old:s0 d with
+ None -> (* The old data is good enough *)
+ false
+
+ | Some d' ->
+ (* We have changed the data *)
if T.debug then
- (Kernel.debug "FF(%s).stmt %d\n" T.name s.sid);
-
-
- (* Find the state before the branch *)
- CurrentLoc.set (Cil_datatype.Stmt.loc s);
- let d: T.t =
- match T.doStmt s with
- Done d -> d
- | (Default | Post _) as action -> begin
- (* Compute the default state, by combining the successors *)
- let res =
- (* We restrict ourselves to the successors we are interested in.
- If T.filterStmt is deterministic, this should not make the
- list empty if s.succs is not empty, as we would not have
- reached s otherwise *)
- match List.filter (T.filterStmt s) s.succs with
- | [] -> T.funcExitData
- | fst :: rest ->
- List.fold_left (fun acc succ ->
- T.combineSuccessors acc (getStmtStartData succ))
- (getStmtStartData fst)
- rest
- in
- (* Now do the instructions *)
- let res' =
- match s.skind with
- | Instr i ->
- begin
- CurrentLoc.set (Cil_datatype.Instr.loc i);
- let action = T.doInstr s i res in
- match action with
- | Done s' -> s'
- | Default -> res (* do nothing *)
- | Post f -> f res
- end
- | _ -> res
- in
- match action with
- Post f -> f res'
- | _ -> res'
- end
- in
-
- (* See if the state has changed. The only changes are that it may grow.*)
- let s0 = getStmtStartData s in
-
- match T.combineStmtStartData s ~old:s0 d with
- None -> (* The old data is good enough *)
- false
-
- | Some d' ->
- (* We have changed the data *)
- if T.debug then
- Kernel.debug "BF(%s): set data for block %d: %a\n"
- T.name s.sid T.pretty d';
- T.StmtStartData.replace s d';
- true
-
- (** Compute the data flow. Must have the CFG initialized *)
- let compute (sinks: stmt list) =
- let kf = current_kf sinks in
- let worklist = BackwardWorklist.create kf sinks in
- List.iter (fun s -> BackwardWorklist.add worklist s) sinks;
- if T.debug && not (BackwardWorklist.is_empty worklist) then
- (Kernel.debug "\nBF(%s): processing\n"
- T.name);
- let rec fixedpoint () =
- if T.debug && not (BackwardWorklist.is_empty worklist) then
- (Kernel.debug "BF(%s): worklist= %a\n"
- T.name
- (Pretty_utils.pp_list (fun fmt s -> Format.fprintf fmt "%d " s.sid))
- (List.rev
- (BackwardWorklist.fold (fun s acc -> s :: acc) worklist [])));
- let s = BackwardWorklist.pop_next worklist in
- let changes = processStmt s in
- if changes then begin
- (* We must add all predecessors of block b, only if not already
- * in and if the filter accepts them. *)
- List.iter
- (fun p -> if T.filterStmt p s then BackwardWorklist.add worklist p)
- s.preds;
- end;
- fixedpoint ()
- in
- try
- fixedpoint ()
- with BackwardWorklist.Empty ->
- if T.debug then
- (Kernel.debug "BF(%s): done\n\n" T.name)
- end
+ Kernel.debug "BF(%s): set data for block %d: %a\n"
+ T.name s.sid T.pretty d';
+ T.StmtStartData.replace s d';
+ true
+
+ (** Compute the data flow. Must have the CFG initialized *)
+ let compute (sinks: stmt list) =
+ let kf = current_kf sinks in
+ let worklist = BackwardWorklist.create kf sinks in
+ List.iter (fun s -> BackwardWorklist.add worklist s) sinks;
+ if T.debug && not (BackwardWorklist.is_empty worklist) then
+ (Kernel.debug "\nBF(%s): processing\n"
+ T.name);
+ let rec fixedpoint () =
+ if T.debug && not (BackwardWorklist.is_empty worklist) then
+ (Kernel.debug "BF(%s): worklist= %a\n"
+ T.name
+ (Pretty_utils.pp_list (fun fmt s -> Format.fprintf fmt "%d " s.sid))
+ (List.rev
+ (BackwardWorklist.fold (fun s acc -> s :: acc) worklist [])));
+ let s = BackwardWorklist.pop_next worklist in
+ let changes = processStmt s in
+ if changes then begin
+ (* We must add all predecessors of block b, only if not already
+ * in and if the filter accepts them. *)
+ List.iter
+ (fun p -> if T.filterStmt p s then BackwardWorklist.add worklist p)
+ s.preds;
+ end;
+ fixedpoint ()
+ in
+ try
+ fixedpoint ()
+ with BackwardWorklist.Empty ->
+ if T.debug then
+ (Kernel.debug "BF(%s): done\n\n" T.name)
+end
(** Helper utility that finds all of the statements of a function.
- It also lists the return statements (including statements that
- fall through the end of a void function). Useful when you need an
- initial set of statements for BackwardsDataFlow.compute. *)
+ It also lists the return statements (including statements that
+ fall through the end of a void function). Useful when you need an
+ initial set of statements for BackwardsDataFlow.compute. *)
let sinkFinder sink_stmts all_stmts = object
inherit nopCilVisitor
@@ -677,7 +677,7 @@ let sinkFinder sink_stmts all_stmts = object
all_stmts := s ::(!all_stmts);
match s.succs with
[] -> (sink_stmts := s :: (!sink_stmts);
- DoChildren)
+ DoChildren)
| _ -> DoChildren
end
diff --git a/src/kernel_services/analysis/dataflow2.mli b/src/kernel_services/analysis/dataflow2.mli
index 46859572f75031f0232913b64d88eb23f5724c41..2cd338df92fc55f98179a6da2fb3b659776d8503 100644
--- a/src/kernel_services/analysis/dataflow2.mli
+++ b/src/kernel_services/analysis/dataflow2.mli
@@ -32,8 +32,8 @@ type 't stmtaction =
SDefault (** The default action *)
| SDone (** Do not visit this statement or its successors *)
| SUse of 't (** Visit the instructions and successors of this statement
- as usual, but use the specified state instead of the
- one that was passed to doStmt *)
+ as usual, but use the specified state instead of the
+ one that was passed to doStmt *)
(** For if statements *)
type 't guardaction =
@@ -84,7 +84,7 @@ module type ForwardsTransfer = sig
first time (i.e. no previous data is associated with it). The data [d]
is propagated to [s] from an unspecified preceding statement [s'].
The result of the call is stored as the new data for [s].
-
+
[computeFirstPredecessor] usually leaves [d] unchanged, but may
potentially change it. It is also possible to perform a side-effect,
for dataflows that store information out of the type [t]. *)
@@ -101,7 +101,7 @@ module type ForwardsTransfer = sig
The current location is updated before this function is called.
The argument of type [stmt] is the englobing statement. *)
- val doGuard: Cil_types.stmt -> Cil_types.exp -> t ->
+ val doGuard: Cil_types.stmt -> Cil_types.exp -> t ->
t guardaction * t guardaction
(** Generate the successors [act_th, act_el] to an [If] statement. [act_th]
(resp. [act_el]) corresponds to the case where the given expression
@@ -123,9 +123,9 @@ module type ForwardsTransfer = sig
Can default to identity if nothing special is required. *)
module StmtStartData: StmtStartData with type data = t
-(** For each statement id, the data at the start. Not found in the hash table
- means nothing is known about the state at this point. At the end of the
- analysis this means that the block is not reachable. *)
+ (** For each statement id, the data at the start. Not found in the hash table
+ means nothing is known about the state at this point. At the end of the
+ analysis this means that the block is not reachable. *)
end
@@ -155,7 +155,7 @@ module type BackwardsTransfer = sig
val name: string (** For debugging purposes, the name of the analysis *)
val debug: bool (** Whether to turn on debugging *)
- type t
+ type t
(** The type of the data we compute for each block start. In many
presentations of backwards data flow analysis we maintain the data at the
block end. This is not easy to do with JVML because a block has many
@@ -203,12 +203,12 @@ end
module Backwards(T : BackwardsTransfer) : sig
val compute: Cil_types.stmt list -> unit
-(** Fill in the T.stmtStartData, given a number of initial statements to start
- from (the sinks for the backwards data flow). All of the statements (not
- just the initial ones!) must have some entry in T.stmtStartData If you want
- to use bottom for the initial data, you should pass the complete list of
- statements to {!compute}, so that everything is visited. {!find_stmts} may
- be useful here. *)
+ (** Fill in the T.stmtStartData, given a number of initial statements to start
+ from (the sinks for the backwards data flow). All of the statements (not
+ just the initial ones!) must have some entry in T.stmtStartData If you want
+ to use bottom for the initial data, you should pass the complete list of
+ statements to {!compute}, so that everything is visited. {!find_stmts} may
+ be useful here. *)
end
val find_stmts: Cil_types.fundec -> (Cil_types.stmt list * Cil_types.stmt list)
diff --git a/src/kernel_services/analysis/dataflows.ml b/src/kernel_services/analysis/dataflows.ml
index f5eccfd6f9f7b02d87ed54e5eea20923369ce8d3..d6abaf94d53ab3a29ac3040d0cb57b158587d3e9 100644
--- a/src/kernel_services/analysis/dataflows.ml
+++ b/src/kernel_services/analysis/dataflows.ml
@@ -98,8 +98,8 @@ end
module Rapid_forward_worklist(Fenv:FUNCTION_ENV):CONSULTABLE_WORKLIST = struct
type t = { mutable changed: bool;
- mutable current_index: ordered_stmt; }
- ;;
+ mutable current_index: ordered_stmt; }
+ ;;
let w = { changed = false; current_index = Fenv.nb_stmts } ;;
let insert _ord = w.changed <- true ;;
@@ -108,11 +108,11 @@ module Rapid_forward_worklist(Fenv:FUNCTION_ENV):CONSULTABLE_WORKLIST = struct
then
if w.changed
then
- (w.changed <- false;
- w.current_index <- 0;
- Some 0)
+ (w.changed <- false;
+ w.current_index <- 0;
+ Some 0)
else
- None
+ None
else
(w.current_index <- w.current_index + 1;
Some w.current_index)
@@ -128,7 +128,7 @@ module Simple_forward_worklist(Fenv:FUNCTION_ENV):CONSULTABLE_WORKLIST = struct
(* The worklist, and the current index. *)
type t = { bv: Bitvector.t;
- mutable index: int };;
+ mutable index: int };;
let w =
let bv = Bitvector.create Fenv.nb_stmts in
@@ -140,17 +140,17 @@ module Simple_forward_worklist(Fenv:FUNCTION_ENV):CONSULTABLE_WORKLIST = struct
let extract () =
try let next = Bitvector.find_next_true w.bv w.index in
- Bitvector.clear w.bv next;
- w.index <- next;
- Some next
+ Bitvector.clear w.bv next;
+ w.index <- next;
+ Some next
with Not_found ->
- (* Try to start over. *)
- try let next = Bitvector.find_next_true w.bv 0 in
- Bitvector.clear w.bv next;
- w.index <- next;
- Some next
- (* Nothing to do left. *)
- with Not_found -> None
+ (* Try to start over. *)
+ try let next = Bitvector.find_next_true w.bv 0 in
+ Bitvector.clear w.bv next;
+ w.index <- next;
+ Some next
+ (* Nothing to do left. *)
+ with Not_found -> None
let in_worklist ord = Bitvector.mem w.bv ord
end
@@ -165,8 +165,8 @@ type direction = Forward | Backward;;
statements inside a scc are handled before starting over on that
scc. Iteration is done using the topological order of sccs. *)
module Connected_component_worklist
- (Dir:sig val direction:direction end)
- (Fenv:FUNCTION_ENV)
+ (Dir:sig val direction:direction end)
+ (Fenv:FUNCTION_ENV)
:CONSULTABLE_WORKLIST =
struct
@@ -218,31 +218,31 @@ struct
(* Next statement to be retrieved. *)
let next = ref first
- (* The current strongly connected component. Set it initially to
- the one of [next] so that extraction directly returns the
- initial [next]. *)
+ (* The current strongly connected component. Set it initially to
+ the one of [next] so that extraction directly returns the
+ initial [next]. *)
let current_scc = ref (Fenv.connected_component !next);;
Kernel.debug ~dkey:Kernel.dkey_dataflow_scc
"First statement %d, first scc %d" !next !current_scc;;
- (* We normally iterate using the ordered_stmt order. The only
- exception is when we have to restart iteration on the current
- strongly connected component. If this is the case,
- must_restart_cc is set to [Some(x)], where [x] is the first
- statement to be processed when we restart iterating on the
- current scc. *)
+ (* We normally iterate using the ordered_stmt order. The only
+ exception is when we have to restart iteration on the current
+ strongly connected component. If this is the case,
+ must_restart_cc is set to [Some(x)], where [x] is the first
+ statement to be processed when we restart iterating on the
+ current scc. *)
let must_restart_scc = ref None
let insert ord =
(* We always iterate in topological order or stay in same connected component order. *)
assert ((is_further ord !next)
- || (Fenv.connected_component ord) = !current_scc);
+ || (Fenv.connected_component ord) = !current_scc);
Workqueue.set ord;
if is_strictly_nearer ord !next
then must_restart_scc := match !must_restart_scc with
- | None -> Some ord
- | Some(x) -> Some(nearest ord x)
+ | None -> Some ord
+ | Some(x) -> Some(nearest ord x)
let extract () =
@@ -292,24 +292,24 @@ struct
let next_true_scc = Fenv.connected_component next_true in
if next_true_scc = !current_scc
then
- select_same_scc next_true
+ select_same_scc next_true
else
- (* We reached the end of the current connected
- component. The trick is that OCamlgraph's topological
- ordering guarantees that elements of the same connected
- component have contiguous indexes, so we know that we
- have reached the end of the current scc. Check if we
- should start over in the same scc, or continue to the
- next scc. *)
- match !must_restart_scc with
- | None -> select_new_scc next_true
- | Some(i) -> select_restart_scc i
+ (* We reached the end of the current connected
+ component. The trick is that OCamlgraph's topological
+ ordering guarantees that elements of the same connected
+ component have contiguous indexes, so we know that we
+ have reached the end of the current scc. Check if we
+ should start over in the same scc, or continue to the
+ next scc. *)
+ match !must_restart_scc with
+ | None -> select_new_scc next_true
+ | Some(i) -> select_restart_scc i
with Not_found ->
- (* We found no further statement with work to do, but the
- current scc may still contain some work. *)
- match !must_restart_scc with
- | None -> None
- | Some(i) -> select_restart_scc i
+ (* We found no further statement with work to do, but the
+ current scc may still contain some work. *)
+ match !must_restart_scc with
+ | None -> None
+ | Some(i) -> select_restart_scc i
;;
let in_worklist ord = Workqueue.mem ord
@@ -434,7 +434,7 @@ module Simple_backward(Fenv:FUNCTION_ENV)(P:BACKWARD_MONOTONE_PARAMETER) = struc
let rec loop acc = function
| i when i = Fenv.nb_stmts -> acc
| i -> let acc = f acc (Fenv.to_stmt i) after.(i)
- in loop acc (i+1)
+ in loop acc (i+1)
in loop init 0;;
let iter_on_result f =
@@ -445,7 +445,7 @@ module Simple_backward(Fenv:FUNCTION_ENV)(P:BACKWARD_MONOTONE_PARAMETER) = struc
let post_state stmt = after.(Fenv.to_ordered stmt)
let pre_state stmt = P.transfer_stmt stmt (post_state stmt)
-
+
end
(* Edge-based forward dataflow. It is edge-based because the transfer
function can differentiate the state after a statement between
@@ -477,31 +477,31 @@ module type FORWARD_MONOTONE_PARAMETER_GENERIC_STORAGE = sig
end
module Forward_monotone_generic_storage
- (Fenv:FUNCTION_ENV)
- (P:FORWARD_MONOTONE_PARAMETER_GENERIC_STORAGE)
- (W:CONSULTABLE_WORKLIST) =
+ (Fenv:FUNCTION_ENV)
+ (P:FORWARD_MONOTONE_PARAMETER_GENERIC_STORAGE)
+ (W:CONSULTABLE_WORKLIST) =
struct
List.iter (fun (stmt,state) ->
- let ord = Fenv.to_ordered stmt in
- P.set_before ord state;
- W.insert ord) P.init;;
+ let ord = Fenv.to_ordered stmt in
+ P.set_before ord state;
+ W.insert ord) P.init;;
let update_before (stmt, new_state) =
let ord = Fenv.to_ordered stmt in
CurrentLoc.set (Cil_datatype.Stmt.loc stmt);
let join =
(* If we know that we already have to recompute before.(ord), we
- can omit the inclusion testing, and only perform the join. The
- rationale is that querying the worklist is cheap, while
- inclusion testing can be costly. *)
+ can omit the inclusion testing, and only perform the join. The
+ rationale is that querying the worklist is cheap, while
+ inclusion testing can be costly. *)
if W.in_worklist ord
then P.join new_state (P.get_before ord)
else
- let (join, is_included) =
- P.join_and_is_included new_state (P.get_before ord)
- in
- if not is_included then W.insert ord;
- join
+ let (join, is_included) =
+ P.join_and_is_included new_state (P.get_before ord)
+ in
+ if not is_included then W.insert ord;
+ join
in
P.set_before ord join
;;
@@ -528,7 +528,7 @@ struct
let rec loop acc = function
| i when i = Fenv.nb_stmts -> acc
| i -> let acc = f acc (Fenv.to_stmt i) (P.get_before i)
- in loop acc (i+1)
+ in loop acc (i+1)
in loop init 0;;
let iter_on_result f =
@@ -571,9 +571,9 @@ module Simple_forward(Fenv:FUNCTION_ENV)(P:FORWARD_MONOTONE_PARAMETER) = struct
include P
let before = Array.make Fenv.nb_stmts P.bottom;;
List.iter (fun (stmt,state) ->
- let ord = Fenv.to_ordered stmt in
- before.(ord) <- state;
- W.insert ord) P.init;;
+ let ord = Fenv.to_ordered stmt in
+ before.(ord) <- state;
+ W.insert ord) P.init;;
let get_before ord = before.(ord);;
let set_before ord value = before.(ord) <- value;;
@@ -604,7 +604,7 @@ let transfer_switch_from_guard transfer_guard stmt state =
| Switch( cond, _, _, _) -> cond
| _ ->
Kernel.fatal ~current:true
- "transfer_switch_from_guard on a non-Switch statement."
+ "transfer_switch_from_guard on a non-Switch statement."
in
let cases, default = Cil.separate_switch_succs stmt in
@@ -619,20 +619,20 @@ let transfer_switch_from_guard transfer_guard stmt state =
(* We do nothing for Default, because we handle it last. *)
| Label _ | Default _ -> input_state
| Case (exp_case, _) ->
- let if_equivalent_cond =
- match exp_case.enode with
- (* This helps when switch is used on boolean expressions. *)
- | Const (CInt64 (z,_,_))
- when Integer.equal z Integer.zero ->
- Cil.new_exp ~loc:cond.eloc (UnOp(LNot,cond,Cil.intType))
- | _ -> Cil.new_exp exp_case.eloc
- (BinOp (Eq, cond, exp_case, Cil.intType))
- in
- let (true_state, false_state) =
- transfer_guard stmt if_equivalent_cond input_state
- in
- result := (succ, true_state)::!result;
- false_state
+ let if_equivalent_cond =
+ match exp_case.enode with
+ (* This helps when switch is used on boolean expressions. *)
+ | Const (CInt64 (z,_,_))
+ when Integer.equal z Integer.zero ->
+ Cil.new_exp ~loc:cond.eloc (UnOp(LNot,cond,Cil.intType))
+ | _ -> Cil.new_exp exp_case.eloc
+ (BinOp (Eq, cond, exp_case, Cil.intType))
+ in
+ let (true_state, false_state) =
+ transfer_guard stmt if_equivalent_cond input_state
+ in
+ result := (succ, true_state)::!result;
+ false_state
in
List.fold_left do_one_label input_state succ.labels
in
diff --git a/src/kernel_services/analysis/dataflows.mli b/src/kernel_services/analysis/dataflows.mli
index f3afd2f3d4bb375de5e025a2199049085cf8d9c5..e96672e84c2ab130a76ecbe36fe043a3659bdd94 100644
--- a/src/kernel_services/analysis/dataflows.mli
+++ b/src/kernel_services/analysis/dataflows.mli
@@ -54,7 +54,7 @@ open Cil_types;;
open Ordered_stmt;;
(** Environment relative to the function being processed, and function to
- create them from Kf. *)
+ create them from Kf. *)
module type FUNCTION_ENV = sig
val to_ordered: stmt -> ordered_stmt
val to_stmt: ordered_stmt -> stmt
@@ -97,8 +97,8 @@ end
(** {2 Backward dataflow} *)
(** Statement-based backward dataflow. Contrary to the forward dataflow,
- the transfer function cannot differentiate the state before a
- statement between different predecessors. *)
+ the transfer function cannot differentiate the state before a
+ statement between different predecessors. *)
module type BACKWARD_MONOTONE_PARAMETER = sig
include JOIN_SEMILATTICE
@@ -146,9 +146,9 @@ end
(** {2 Forward dataflow} *)
(** Edge-based forward dataflow. It is edge-based because the transfer
- function can differentiate the state after a statement between
- different successors. In particular, the state can be reduced
- according to the conditions in if statements. *)
+ function can differentiate the state after a statement between
+ different successors. In particular, the state can be reduced
+ according to the conditions in if statements. *)
module type FORWARD_MONOTONE_PARAMETER = sig
include JOIN_SEMILATTICE
@@ -191,7 +191,7 @@ module Simple_forward(Fenv:FUNCTION_ENV)(P:FORWARD_MONOTONE_PARAMETER) : sig
In this dataflow, the results are the pre-states of all the statements
reachable from the statements from [P.init]. *)
-
+
val fold_on_result: ('a -> stmt -> P.t -> 'a) -> 'a -> 'a
val iter_on_result: (stmt -> P.t -> unit) -> unit
@@ -200,7 +200,7 @@ module Simple_forward(Fenv:FUNCTION_ENV)(P:FORWARD_MONOTONE_PARAMETER) : sig
val before:P.t Ordered_stmt.ordered_stmt_array
(* TODO: Should disappear, together with Fenv? *)
(**/**)
-
+
end;;
(** {3 Helper functions for forward dataflow.} *)
diff --git a/src/kernel_services/analysis/dominators.ml b/src/kernel_services/analysis/dominators.ml
index e6645a768f3185b1b40984aa89dad65dd918454d..2c2662c7e951e99e4be5b0989c5d711534cb53ef 100644
--- a/src/kernel_services/analysis/dominators.ml
+++ b/src/kernel_services/analysis/dominators.ml
@@ -28,13 +28,13 @@
statically unreachable statements (that do not have idoms), are
mapped to None. *)
module Dom_tree = State_builder.Hashtbl
- (Cil_datatype.Stmt.Hashtbl)
- (Datatype.Option(Cil_datatype.Stmt))
- (struct
- let name = "Dominators.dom_tree"
- let dependencies = [ Ast.self ]
- let size = 197
- end)
+ (Cil_datatype.Stmt.Hashtbl)
+ (Datatype.Option(Cil_datatype.Stmt))
+ (struct
+ let name = "Dominators.dom_tree"
+ let dependencies = [ Ast.self ]
+ let size = 197
+ end)
;;
(** Compute dominator information for the statements in a function *)
@@ -73,75 +73,75 @@ end
module Compute(D:DIRECTION) = struct
-(* Computes the smallest common dominator between two statements. *)
-let nearest_common_ancestor find_domtree ord1 ord2 =
- Kernel.debug ~dkey:Kernel.dkey_dominators "computing common ancestor %d %d"
- (D.to_stmt ord1).sid (D.to_stmt ord2).sid;
- let finger1 = ref ord1 in
- let finger2 = ref ord2 in
- while (!finger1 != !finger2) do (
- while ( D.is_further_from_root !finger1 !finger2) do
- finger1 := (match find_domtree !finger1 with
- | None -> assert false
- | Some x -> x)
+ (* Computes the smallest common dominator between two statements. *)
+ let nearest_common_ancestor find_domtree ord1 ord2 =
+ Kernel.debug ~dkey:Kernel.dkey_dominators "computing common ancestor %d %d"
+ (D.to_stmt ord1).sid (D.to_stmt ord2).sid;
+ let finger1 = ref ord1 in
+ let finger2 = ref ord2 in
+ while (!finger1 != !finger2) do (
+ while ( D.is_further_from_root !finger1 !finger2) do
+ finger1 := (match find_domtree !finger1 with
+ | None -> assert false
+ | Some x -> x)
+ done;
+ while ( D.is_further_from_root !finger2 !finger1) do
+ finger2 := (match find_domtree !finger2 with
+ | None -> assert false
+ | Some x -> x)
+ done;)
done;
- while ( D.is_further_from_root !finger2 !finger1) do
- finger2 := (match find_domtree !finger2 with
- | None -> assert false
- | Some x -> x)
- done;)
- done;
- !finger1
-;;
-
-(* Note: None means either unprocessed, or that the statement has no
- predecessor or that all its ancestors are at None *)
-(* based on "A Simple, Fast Dominance Algorithm" by K.D. Cooper et al *)
-let domtree () =
- let domtree = Array.make D.nb_stmts None in
+ !finger1
+ ;;
- (* Initialize the dataflow: for each root, add itself to its own
- set of dominators. *)
- domtree.(D.root_stmt) <- Some D.root_stmt;
- let changed = ref true in
- while !changed do
- changed := false;
- D.iter (fun b ->
- let ordered_preds = D.preds b in
- let processed_preds =
- let was_processed p = match domtree.(p) with
- | None -> false
- | Some(_) -> true
- in
- List.filter was_processed ordered_preds
- in
- match processed_preds with
- | [] -> () (* No predecessor (e.g. unreachable stmt): leave it to None.*)
- | first::rest ->
- let find i = domtree.(i) in
- let new_idom =
- List.fold_left (nearest_common_ancestor find) first rest
- in
- (match domtree.(b) with
- | Some(old_idom) when old_idom == new_idom -> ()
- | _ -> (domtree.(b) <- Some(new_idom); changed := true))
- );
- done;
- (* The roots are not _immediate_ dominators of themselves, so revert
- that now that the dataflow has finished. *)
- domtree.(D.root_stmt) <- None;
- domtree
-;;
+ (* Note: None means either unprocessed, or that the statement has no
+ predecessor or that all its ancestors are at None *)
+ (* based on "A Simple, Fast Dominance Algorithm" by K.D. Cooper et al *)
+ let domtree () =
+ let domtree = Array.make D.nb_stmts None in
-let display domtree =
- Kernel.debug ~dkey:Kernel.dkey_dominators "Root is %d" (D.to_stmt 0).sid;
- Array.iteri (fun orig dest -> match dest with
- | Some(x) -> Kernel.debug ~dkey:Kernel.dkey_dominators "%s of %d is %d"
- D.name (D.to_stmt orig).sid (D.to_stmt x).sid
- | None -> Kernel.debug ~dkey:Kernel.dkey_dominators "no %s for %d"
- D.name (D.to_stmt orig).sid)
+ (* Initialize the dataflow: for each root, add itself to its own
+ set of dominators. *)
+ domtree.(D.root_stmt) <- Some D.root_stmt;
+ let changed = ref true in
+ while !changed do
+ changed := false;
+ D.iter (fun b ->
+ let ordered_preds = D.preds b in
+ let processed_preds =
+ let was_processed p = match domtree.(p) with
+ | None -> false
+ | Some(_) -> true
+ in
+ List.filter was_processed ordered_preds
+ in
+ match processed_preds with
+ | [] -> () (* No predecessor (e.g. unreachable stmt): leave it to None.*)
+ | first::rest ->
+ let find i = domtree.(i) in
+ let new_idom =
+ List.fold_left (nearest_common_ancestor find) first rest
+ in
+ (match domtree.(b) with
+ | Some(old_idom) when old_idom == new_idom -> ()
+ | _ -> (domtree.(b) <- Some(new_idom); changed := true))
+ );
+ done;
+ (* The roots are not _immediate_ dominators of themselves, so revert
+ that now that the dataflow has finished. *)
+ domtree.(D.root_stmt) <- None;
domtree
-;;
+ ;;
+
+ let display domtree =
+ Kernel.debug ~dkey:Kernel.dkey_dominators "Root is %d" (D.to_stmt 0).sid;
+ Array.iteri (fun orig dest -> match dest with
+ | Some(x) -> Kernel.debug ~dkey:Kernel.dkey_dominators "%s of %d is %d"
+ D.name (D.to_stmt orig).sid (D.to_stmt x).sid
+ | None -> Kernel.debug ~dkey:Kernel.dkey_dominators "no %s for %d"
+ D.name (D.to_stmt orig).sid)
+ domtree
+ ;;
end
@@ -158,8 +158,8 @@ let direction_dom kf =
(* Iterate on all statements, except the entry point. *)
let iter f =
for i = 0 to nb_stmts -1 do
- if i != root_stmt
- then f i
+ if i != root_stmt
+ then f i
done;;
let is_further_from_root p1 p2 = p1 > p2
let preds s = List.map to_ordered (to_stmt s).Cil_types.preds
@@ -172,12 +172,12 @@ let direction_dom kf =
(* Fill the project table with the dominators of a given function. *)
let store_dom domtree to_stmt =
Array.iteri( fun ord idom ->
- let idom = Option.map to_stmt idom in
- let stmt = to_stmt ord in
- Kernel.debug ~dkey:Kernel.dkey_dominators "storing dom for %d: %s"
- stmt.sid (match idom with None -> "self" | Some s ->string_of_int s.sid);
- Dom_tree.add stmt idom
- ) domtree
+ let idom = Option.map to_stmt idom in
+ let stmt = to_stmt ord in
+ Kernel.debug ~dkey:Kernel.dkey_dominators "storing dom for %d: %s"
+ stmt.sid (match idom with None -> "self" | Some s ->string_of_int s.sid);
+ Dom_tree.add stmt idom
+ ) domtree
let compute_dom kf =
let direction = direction_dom kf in
@@ -203,12 +203,12 @@ let compute_dom kf =
a. *)
(* TODO:
- For each statement, associate its immediate post-dominator (if it
- exists), and the list of sinks that dominates it
+ exists), and the list of sinks that dominates it
- Attempt to find the post-dominator by intersection only if the
- list of sinks of the points is the same. Otherwise, state that
- there is no immediate post-dominator, and that the point is
- dominated by the union of the lists of sinks of its successors.
+ list of sinks of the points is the same. Otherwise, state that
+ there is no immediate post-dominator, and that the point is
+ dominated by the union of the lists of sinks of its successors.
*)
let _compute_pdom kf =
let (stmt_to_ordered,ordered_to_stmt,_) =
@@ -221,8 +221,8 @@ let _compute_pdom kf =
let root_stmt = to_ordered (Kernel_function.find_return kf)
let iter f =
for i = nb_stmts -1 downto 0 do
- if i != root_stmt
- then f i
+ if i != root_stmt
+ then f i
done;;
let is_further_from_root p1 p2 = p1 < p2
let preds s = List.map to_ordered (to_stmt s).Cil_types.succs
diff --git a/src/kernel_services/analysis/logic_interp.ml b/src/kernel_services/analysis/logic_interp.ml
index 86b2ea230e3c4a446378a6fd74f602861b22f4b4..d5811d7526f997ac28515309340640eeca135cc2 100644
--- a/src/kernel_services/analysis/logic_interp.ml
+++ b/src/kernel_services/analysis/logic_interp.ml
@@ -32,38 +32,38 @@ let find_var kf kinstr ?label var =
try
let vi = Globals.Vars.find_from_astinfo var (VLocal kf) in
(match kinstr with
- | Kglobal -> vi (* don't refine search: the Kglobal here
- does not indicate the function contract, but merely
- the fact that we do not have any information about
- the targeted program point. Hence, no scope check
- can be performed or we might reject many legitimate
- terms and predicates.
- *)
- | Kstmt stmt ->
- let scope =
- match label with
- | None | Some "Here" | Some "Post" | Some "Old" -> stmt
- | Some "Pre" -> raise Not_found (* no local variable in scope. *)
- | Some "Init" -> raise Not_found (* no local variable in scope. *)
- | Some "LoopEntry" | Some "LoopCurrent" ->
- if not (Kernel_function.stmt_in_loop kf stmt) then
+ | Kglobal -> vi (* don't refine search: the Kglobal here
+ does not indicate the function contract, but merely
+ the fact that we do not have any information about
+ the targeted program point. Hence, no scope check
+ can be performed or we might reject many legitimate
+ terms and predicates.
+ *)
+ | Kstmt stmt ->
+ let scope =
+ match label with
+ | None | Some "Here" | Some "Post" | Some "Old" -> stmt
+ | Some "Pre" -> raise Not_found (* no local variable in scope. *)
+ | Some "Init" -> raise Not_found (* no local variable in scope. *)
+ | Some "LoopEntry" | Some "LoopCurrent" ->
+ if not (Kernel_function.stmt_in_loop kf stmt) then
+ Kernel.fatal
+ "Use of LoopEntry or LoopCurrent outside of a loop";
+ Kernel_function.find_enclosing_loop kf stmt
+ | Some l ->
+ (try let s = Kernel_function.find_label kf l in !s
+ with Not_found ->
Kernel.fatal
- "Use of LoopEntry or LoopCurrent outside of a loop";
- Kernel_function.find_enclosing_loop kf stmt
- | Some l ->
- (try let s = Kernel_function.find_label kf l in !s
- with Not_found ->
- Kernel.fatal
"Use of label %s that does not exist in function %a"
l Kernel_function.pretty kf)
- in
+ in
if Kernel_function.var_is_in_scope scope vi then vi
else raise Not_found)
with Not_found ->
- try
- Globals.Vars.find_from_astinfo var (VFormal kf)
- with Not_found ->
- Globals.Vars.find_from_astinfo var VGlobal
+ try
+ Globals.Vars.find_from_astinfo var (VFormal kf)
+ with Not_found ->
+ Globals.Vars.find_from_astinfo var VGlobal
in
cvar_to_lvar vi
@@ -73,10 +73,10 @@ let find_var kf kinstr ?label var =
(* It is theoretically possible to use a first-class module instead, but the
required signatures are not exported in Logic_typing. *)
module DefaultLT (X:
-sig
- val kf: Kernel_function.t
- val kinstr: Cil_types.kinstr
-end) =
+ sig
+ val kf: Kernel_function.t
+ val kinstr: Cil_types.kinstr
+ end) =
Logic_typing.Make
(struct
let anonCompFieldName = Cabs2cil.anonCompFieldName
@@ -84,8 +84,8 @@ end) =
let is_loop () =
match X.kinstr with
- | Kglobal -> false
- | Kstmt s -> Kernel_function.stmt_in_loop X.kf s
+ | Kglobal -> false
+ | Kstmt s -> Kernel_function.stmt_in_loop X.kf s
let find_macro _ = raise Not_found
@@ -132,14 +132,14 @@ end) =
let on_error f rollback x =
try f x with Error _ as exn -> rollback (); raise exn
- end)
+ end)
(** Set up the parser for the infamous 'C hack' needed to parse typedefs *)
let sync_typedefs () =
Logic_env.reset_typenames ();
Globals.Types.iter_types
(fun name _ ns ->
- if ns = Logic_typing.Typedef then Logic_env.add_typename name)
+ if ns = Logic_typing.Typedef then Logic_env.add_typename name)
let wrap f parsetree loc =
match parsetree with
@@ -149,9 +149,9 @@ let wrap f parsetree loc =
let code_annot kf stmt s =
sync_typedefs ();
let module LT = DefaultLT(struct
- let kf = kf
- let kinstr = Kstmt stmt
- end) in
+ let kf = kf
+ let kinstr = Kstmt stmt
+ end) in
let loc = Stmt.loc stmt in
let pa =
Option.bind
@@ -172,9 +172,9 @@ let default_term_env () =
let term kf ?(loc=Location.unknown) ?(env=default_term_env ()) s =
sync_typedefs ();
let module LT = DefaultLT(struct
- let kf = kf
- let kinstr = Kglobal
- end) in
+ let kf = kf
+ let kinstr = Kglobal
+ end) in
let pa_expr = Option.map snd (Logic_lexer.lexpr (fst loc, s)) in
let parse pa_expr = LT.term env pa_expr in
wrap parse pa_expr loc
@@ -187,9 +187,9 @@ let term_lval kf ?(loc=Location.unknown) ?(env=default_term_env ()) s =
let predicate kf ?(loc=Location.unknown) ?(env=default_term_env ()) s =
sync_typedefs ();
let module LT = DefaultLT(struct
- let kf = kf
- let kinstr = Kglobal
- end) in
+ let kf = kf
+ let kinstr = Kglobal
+ end) in
let pa_expr = Option.map snd (Logic_lexer.lexpr (fst loc, s)) in
let parse pa_expr = LT.predicate env pa_expr in
wrap parse pa_expr loc
@@ -199,10 +199,10 @@ let error_lval () = raise Db.Properties.Interp.No_conversion
let rec logic_type_to_typ = function
| Ctype typ -> typ
| Linteger -> TInt(ILongLong,[]) (*TODO: to have an unlimited integer type
- in the logic interpretation*)
+ in the logic interpretation*)
| Lreal -> TFloat(FDouble,[]) (* TODO: handle reals, not floats... *)
| Ltype({lt_name = name},[]) when name = Utf8_logic.boolean ->
- TInt(ILongLong,[])
+ TInt(ILongLong,[])
| Ltype({lt_name = "set"},[t]) -> logic_type_to_typ t
| Ltype _ | Lvar _ | Larrow _ -> error_lval ()
@@ -211,8 +211,8 @@ let rec logic_type_to_typ = function
let logic_var_to_var { lv_origin = lv } =
match lv with
- | None -> error_lval ()
- | Some lv -> lv
+ | None -> error_lval ()
+ | Some lv -> lv
let create_const_list loc kind low high =
let rec aux acc i =
@@ -224,14 +224,14 @@ let create_const_list loc kind low high =
let range low high =
let loc = fst low.eloc, snd high.eloc in
match (Cil.constFold true low).enode, (Cil.constFold true high).enode with
- Const(CInt64(low,kind,_)), Const(CInt64(high,_,_)) ->
- create_const_list loc kind low high
- | _ -> error_lval()
+ Const(CInt64(low,kind,_)), Const(CInt64(high,_,_)) ->
+ create_const_list loc kind low high
+ | _ -> error_lval()
let singleton f loc =
match f loc with
- [ l ] -> l
- | _ -> error_lval()
+ [ l ] -> l
+ | _ -> error_lval()
let rec loc_lval_to_lval ~result (lh, lo) =
Extlib.product
@@ -243,7 +243,7 @@ and loc_lhost_to_lhost ~result = function
| TVar lvar -> [Var (logic_var_to_var lvar)]
| TMem lterm -> List.map (fun x -> Mem x) (loc_to_exp ~result lterm)
| TResult _ ->
- ( match result with
+ ( match result with
None -> error_lval()
| Some v -> [Var v])
@@ -251,53 +251,53 @@ and loc_offset_to_offset ~result = function
| TNoOffset -> [NoOffset]
| TModel _ -> error_lval ()
| TField (fi, lo) ->
- List.map (fun x -> Field (fi,x)) (loc_offset_to_offset ~result lo)
+ List.map (fun x -> Field (fi,x)) (loc_offset_to_offset ~result lo)
| TIndex (lexp, lo) ->
- Extlib.product
- (fun x y -> Index(x,y))
- (loc_to_exp ~result lexp)
- (loc_offset_to_offset ~result lo)
+ Extlib.product
+ (fun x y -> Index(x,y))
+ (loc_to_exp ~result lexp)
+ (loc_offset_to_offset ~result lo)
and loc_to_exp ~result {term_node = lnode ; term_type = ltype; term_loc = loc} =
match lnode with
| TLval lv ->
- List.map (fun x -> new_exp ~loc (Lval x)) (loc_lval_to_lval ~result lv)
+ List.map (fun x -> new_exp ~loc (Lval x)) (loc_lval_to_lval ~result lv)
| TAddrOf lv ->
- List.map (fun x -> new_exp ~loc (AddrOf x)) (loc_lval_to_lval ~result lv)
+ List.map (fun x -> new_exp ~loc (AddrOf x)) (loc_lval_to_lval ~result lv)
| TStartOf lv ->
- List.map (fun x -> new_exp ~loc (StartOf x)) (loc_lval_to_lval ~result lv)
+ List.map (fun x -> new_exp ~loc (StartOf x)) (loc_lval_to_lval ~result lv)
| TSizeOfE lexp ->
- List.map (fun x -> new_exp ~loc (SizeOfE x)) (loc_to_exp ~result lexp)
+ List.map (fun x -> new_exp ~loc (SizeOfE x)) (loc_to_exp ~result lexp)
| TAlignOfE lexp ->
- List.map (fun x -> new_exp ~loc (AlignOfE x)) (loc_to_exp ~result lexp)
+ List.map (fun x -> new_exp ~loc (AlignOfE x)) (loc_to_exp ~result lexp)
| TUnOp (unop, lexp) ->
- List.map
- (fun x -> new_exp ~loc (UnOp (unop, x, logic_type_to_typ ltype)))
- (loc_to_exp ~result lexp)
+ List.map
+ (fun x -> new_exp ~loc (UnOp (unop, x, logic_type_to_typ ltype)))
+ (loc_to_exp ~result lexp)
| TBinOp (binop, lexp1, lexp2) ->
- Extlib.product
- (fun x y -> new_exp ~loc (BinOp (binop, x,y, logic_type_to_typ ltype)))
- (loc_to_exp ~result lexp1)
- (loc_to_exp ~result lexp2)
+ Extlib.product
+ (fun x y -> new_exp ~loc (BinOp (binop, x,y, logic_type_to_typ ltype)))
+ (loc_to_exp ~result lexp1)
+ (loc_to_exp ~result lexp2)
| TSizeOfStr string -> [new_exp ~loc (SizeOfStr string)]
- | TConst constant ->
+ | TConst constant ->
(* TODO: Very likely to fail on large integer and incorrect on reals not
representable as floats *)
[new_exp ~loc (Const (Logic_utils.lconstant_to_constant constant))]
| TCastE (typ, lexp) ->
- List.map
- (fun x -> new_exp ~loc (CastE (typ, x))) (loc_to_exp ~result lexp)
+ List.map
+ (fun x -> new_exp ~loc (CastE (typ, x))) (loc_to_exp ~result lexp)
| TAlignOf typ -> [new_exp ~loc (AlignOf typ)]
| TSizeOf typ -> [new_exp ~loc (SizeOf typ)]
| Trange (Some low, Some high) ->
- let low = singleton (loc_to_exp ~result) low in
- let high = singleton (loc_to_exp ~result) high in
- range low high
+ let low = singleton (loc_to_exp ~result) low in
+ let high = singleton (loc_to_exp ~result) high in
+ range low high
| Tunion l -> List.concat (List.map (loc_to_exp ~result) l)
| Tempty_set -> []
| Tinter _ | Tcomprehension _ -> error_lval()
| Tat ({term_node = TAddrOf (TVar _, TNoOffset)} as taddroflval, _) ->
- loc_to_exp ~result taddroflval
+ loc_to_exp ~result taddroflval
| TLogic_coerce(Linteger, t) when Logic_typing.is_integral_type t.term_type ->
loc_to_exp ~result t
| TLogic_coerce(Lreal, t) when Logic_typing.is_integral_type t.term_type ->
@@ -307,10 +307,10 @@ and loc_to_exp ~result {term_node = lnode ; term_type = ltype; term_loc = loc} =
| TLogic_coerce(Lreal, t) when Logic_typing.is_arithmetic_type t.term_type ->
loc_to_exp ~result t
| TLogic_coerce (set, t)
- when
- Logic_const.is_set_type set &&
- Logic_utils.is_same_type
- (Logic_typing.type_of_set_elem set) t.term_type ->
+ when
+ Logic_const.is_set_type set &&
+ Logic_utils.is_same_type
+ (Logic_typing.type_of_set_elem set) t.term_type ->
loc_to_exp ~result t
| Tnull -> [ Cil.mkCast (TPtr(TVoid [], [])) (Cil.zero ~loc) ]
@@ -335,10 +335,10 @@ let rec loc_to_lval ~result t =
| Tempty_set -> []
(* coercions to arithmetic types cannot be lval. We only have to consider
a coercion to set here.
- *)
+ *)
| TLogic_coerce(set, t) when
Logic_typing.is_set_type set &&
- Logic_utils.is_same_type
+ Logic_utils.is_same_type
(Logic_typing.type_of_set_elem set) t.term_type ->
loc_to_lval ~result t
| Tinter _ -> error_lval() (* TODO *)
@@ -348,31 +348,31 @@ let rec loc_to_lval ~result t =
| Tat _ | Toffset _ | Tbase_addr _ | Tblock_length _ | Tnull | Trange _
| TDataCons _ | TUpdate _ | Tlambda _
| Ttypeof _ | Ttype _ | Tlet _ | TLogic_coerce _ ->
- error_lval ()
+ error_lval ()
let loc_to_offset ~result loc =
let rec aux h =
function
- TLval(h',o) | TStartOf (h',o) ->
- (match h with None -> Some h', loc_offset_to_offset ~result o
- | Some h when Logic_utils.is_same_lhost h h' ->
- Some h, loc_offset_to_offset ~result o
- | Some _ -> error_lval()
- )
- | Tat ({ term_node = TLval(TResult _,_)} as lv, BuiltinLabel Post) ->
- aux h lv.term_node
- | Tunion locs -> List.fold_left
- (fun (b,l) x ->
- let (b,l') = aux b x.term_node in b, l @ l') (h,[]) locs
- | Tempty_set -> h,[]
- | Trange _ | TAddrOf _ | Tat _
- | TSizeOfE _ | TAlignOfE _ | TUnOp _ | TBinOp _ | TSizeOfStr _
- | TConst _ | TCastE _ | TAlignOf _ | TSizeOf _ | Tapp _ | Tif _
- | Toffset _ | Tbase_addr _ | Tblock_length _ | Tnull
- | TDataCons _ | TUpdate _ | Tlambda _
- | Ttypeof _ | Ttype _ | Tcomprehension _ | Tinter _ | Tlet _
- | TLogic_coerce _
- -> error_lval ()
+ TLval(h',o) | TStartOf (h',o) ->
+ (match h with None -> Some h', loc_offset_to_offset ~result o
+ | Some h when Logic_utils.is_same_lhost h h' ->
+ Some h, loc_offset_to_offset ~result o
+ | Some _ -> error_lval()
+ )
+ | Tat ({ term_node = TLval(TResult _,_)} as lv, BuiltinLabel Post) ->
+ aux h lv.term_node
+ | Tunion locs -> List.fold_left
+ (fun (b,l) x ->
+ let (b,l') = aux b x.term_node in b, l @ l') (h,[]) locs
+ | Tempty_set -> h,[]
+ | Trange _ | TAddrOf _ | Tat _
+ | TSizeOfE _ | TAlignOfE _ | TUnOp _ | TBinOp _ | TSizeOfStr _
+ | TConst _ | TCastE _ | TAlignOf _ | TSizeOf _ | Tapp _ | Tif _
+ | Toffset _ | Tbase_addr _ | Tblock_length _ | Tnull
+ | TDataCons _ | TUpdate _ | Tlambda _
+ | Ttypeof _ | Ttype _ | Tcomprehension _ | Tinter _ | Tlet _
+ | TLogic_coerce _
+ -> error_lval ()
in snd (aux None loc.term_node)
let term_lval_to_lval ~result = singleton (loc_lval_to_lval ~result)
@@ -390,28 +390,28 @@ let term_offset_to_offset ~result = singleton (loc_offset_to_offset ~result)
module To_zone : sig
type ctx = Db.Properties.Interp.To_zone.t_ctx =
- {state_opt:bool option;
- ki_opt:(stmt * bool) option;
- kf:Kernel_function.t}
+ {state_opt:bool option;
+ ki_opt:(stmt * bool) option;
+ kf:Kernel_function.t}
val mk_ctx_func_contrat: kernel_function -> state_opt:bool option -> ctx
(** [mk_ctx_func_contrat] to define an interpretation context related to
- [kernel_function] contracts.
+ [kernel_function] contracts.
The control point of the interpretation is defined as follows:
- pre-state if [state_opt=Some true]
- post-state if [state_opt=Some false]
- pre-state with possible reference to the post-state if
- [state_opt=None]. *)
+ [state_opt=None]. *)
- val mk_ctx_stmt_contrat:
+ val mk_ctx_stmt_contrat:
kernel_function -> stmt -> state_opt:bool option -> ctx
(** [mk_ctx_stmt_contrat] to define an interpretation context related to
- [stmt] contracts.
+ [stmt] contracts.
The control point of the interpretation is defined as follows:
- pre-state if [state_opt=Some true]
- post-state if [state_opt=Some false]
- pre-state with possible reference to the post-state if
- [state_opt=None]. *)
+ [state_opt=None]. *)
val mk_ctx_stmt_annot: kernel_function -> stmt -> ctx
(** [mk_ctx_stmt_annot] to define an interpretation context related to an
@@ -424,27 +424,27 @@ module To_zone : sig
exception NYI of string
val from_term: term -> ctx -> (zone_info * decl)
- (** Entry point to get zones
- needed to evaluate the [term] relative to the [ctx] of
- interpretation. *)
+ (** Entry point to get zones
+ needed to evaluate the [term] relative to the [ctx] of
+ interpretation. *)
val from_terms: term list -> ctx -> (zone_info * decl)
- (** Entry point to get zones
- needed to evaluate the list of [terms] relative to the [ctx] of
- interpretation. *)
+ (** Entry point to get zones
+ needed to evaluate the list of [terms] relative to the [ctx] of
+ interpretation. *)
val from_pred: predicate -> ctx -> (zone_info * decl)
- (** Entry point to get zones
- needed to evaluate the [predicate] relative to the [ctx] of
- interpretation. *)
+ (** Entry point to get zones
+ needed to evaluate the [predicate] relative to the [ctx] of
+ interpretation. *)
val from_preds: predicate list -> ctx -> (zone_info * decl)
- (** Entry point to get zones
- needed to evaluate the list of [predicates] relative to the [ctx] of
- interpretation. *)
+ (** Entry point to get zones
+ needed to evaluate the list of [predicates] relative to the [ctx] of
+ interpretation. *)
- val from_stmt_annot:
- code_annotation -> (stmt * kernel_function) ->
+ val from_stmt_annot:
+ code_annotation -> (stmt * kernel_function) ->
(zone_info * decl) * pragmas
(** Entry point to get zones needed to evaluate code annotations of this
[stmt]. *)
@@ -453,41 +453,41 @@ module To_zone : sig
(code_annotation -> bool) option ->
(stmt * kernel_function) -> (zone_info * decl) * pragmas
(** Entry point to get zones needed to evaluate code annotations of this
- [stmt]. *)
+ [stmt]. *)
val from_func_annots:
((stmt -> unit) -> kernel_function -> unit) ->
(code_annotation -> bool) option ->
kernel_function -> (zone_info * decl) * pragmas
(** Entry point to get zones needed to evaluate code annotations of this
- [kf]. *)
+ [kf]. *)
val code_annot_filter:
code_annotation ->
threat:bool -> user_assert:bool -> slicing_pragma:bool ->
loop_inv:bool -> loop_var:bool -> others:bool -> bool
(** To quickly build a annotation filter *)
- end
- =
+end
+=
struct
exception NYI of string
(* Reimport here the type definitions of Db.Properties.Interp. See
documentation there. *)
type ctx = Db.Properties.Interp.To_zone.t_ctx =
- {state_opt:bool option;
- ki_opt:(stmt * bool) option;
- kf:Kernel_function.t}
-
+ {state_opt:bool option;
+ ki_opt:(stmt * bool) option;
+ kf:Kernel_function.t}
+
type pragmas = Db.Properties.Interp.To_zone.t_pragmas =
- {ctrl: Stmt.Set.t ; stmt: Stmt.Set.t}
+ {ctrl: Stmt.Set.t ; stmt: Stmt.Set.t}
- type t = Db.Properties.Interp.To_zone.t
- = {before:bool ; ki:stmt ; zone:Locations.Zone.t}
+ type t = Db.Properties.Interp.To_zone.t
+ = {before:bool ; ki:stmt ; zone:Locations.Zone.t}
type zone_info = Db.Properties.Interp.To_zone.t_zone_info
type decl = Db.Properties.Interp.To_zone.t_decl =
- {var: Varinfo.Set.t ; lbl: Logic_label.Set.t}
+ {var: Varinfo.Set.t ; lbl: Logic_label.Set.t}
let mk_ctx_func_contrat kf ~state_opt =
{ state_opt = state_opt;
@@ -548,13 +548,13 @@ struct
let z =
Stmt.Hashtbl.fold
(fun ki (zone_true, zone_false) other_zones ->
- let add before zone others =
- if Locations.Zone.equal Locations.Zone.bottom zone then
- others
- else
- { before = before; ki = ki; zone = zone} :: others
- in
- add true zone_true (add false zone_false other_zones))
+ let add before zone others =
+ if Locations.Zone.equal Locations.Zone.bottom zone then
+ others
+ else
+ { before = before; ki = ki; zone = zone} :: others
+ in
+ add true zone_true (add false zone_false other_zones))
other_zones
[]
in
@@ -563,14 +563,14 @@ struct
Some z
in zones, {var = !locals; lbl = !labels}
in
- let res_pragmas = !pragmas in
- (* clear references for the next time when giving the result *)
- (* TODO: this is hideous and error-prone as some functions are
- recursive. See VP comment about a more functional setting *)
- locals := Varinfo.Set.empty ;
- labels := Logic_label.Set.empty ;
- pragmas := empty_pragmas;
- result, res_pragmas
+ let res_pragmas = !pragmas in
+ (* clear references for the next time when giving the result *)
+ (* TODO: this is hideous and error-prone as some functions are
+ recursive. See VP comment about a more functional setting *)
+ locals := Varinfo.Set.empty ;
+ labels := Logic_label.Set.empty ;
+ pragmas := empty_pragmas;
+ result, res_pragmas
let get_result () = fst (get_result_aux ())
@@ -581,10 +581,10 @@ struct
let extract_locals logicvars =
Logic_var.Set.fold
(fun lv cvars -> match lv.lv_origin with
- | None -> cvars
- | Some cvar ->
- if cvar.Cil_types.vglob then cvars
- else Varinfo.Set.add cvar cvars)
+ | None -> cvars
+ | Some cvar ->
+ if cvar.Cil_types.vglob then cvars
+ else Varinfo.Set.add cvar cvars)
logicvars
Varinfo.Set.empty
@@ -608,14 +608,14 @@ struct
let is_same_label absl l =
match absl, l with
- | AbsLabel_stmt s1, StmtLabel s2 -> Cil_datatype.Stmt.equal s1 !s2
- | AbsLabel_here, BuiltinLabel Here -> true
- | AbsLabel_pre, BuiltinLabel Pre -> true
- | AbsLabel_post, BuiltinLabel Post -> true
- | AbsLabel_init, BuiltinLabel Init -> true
- | AbsLabel_loop_entry, BuiltinLabel LoopEntry -> true
- | AbsLabel_loop_current, BuiltinLabel LoopCurrent -> true
- | _, (StmtLabel _ | FormalLabel _ | BuiltinLabel _) -> false
+ | AbsLabel_stmt s1, StmtLabel s2 -> Cil_datatype.Stmt.equal s1 !s2
+ | AbsLabel_here, BuiltinLabel Here -> true
+ | AbsLabel_pre, BuiltinLabel Pre -> true
+ | AbsLabel_post, BuiltinLabel Post -> true
+ | AbsLabel_init, BuiltinLabel Init -> true
+ | AbsLabel_loop_entry, BuiltinLabel LoopEntry -> true
+ | AbsLabel_loop_current, BuiltinLabel LoopCurrent -> true
+ | _, (StmtLabel _ | FormalLabel _ | BuiltinLabel _) -> false
class populate_zone before_opt ki_opt kf =
@@ -623,9 +623,9 @@ struct
- pre-state if [before_opt=Some true]
- post-state if [before_opt=Some false]
- pre-state with possible reference to the post-state if
- [before_opt=None] of a property relative to
+ [before_opt=None] of a property relative to
- the contract of function [kf] when [ki_opt=None]
- otherwise [ki_opt=Some(ki, code_annot)],
+ otherwise [ki_opt=Some(ki, code_annot)],
- the contract of the statement [ki] when [code_annot=false]
- the annotation of the statement [ki] when [code_annot=true] *)
object(self)
@@ -635,22 +635,22 @@ struct
method private get_ctrl_point () =
let get_fct_entry_point () =
(* TODO: to replace by true, None *)
- true,
- (try Some (Kernel_function.find_first_stmt kf)
- with Kernel_function.No_Statement ->
- (* raised when [kf] has no code. *)
- None)
+ true,
+ (try Some (Kernel_function.find_first_stmt kf)
+ with Kernel_function.No_Statement ->
+ (* raised when [kf] has no code. *)
+ None)
in
let get_ctrl_point dft =
let before = Option.value ~default:dft before_opt in
match ki_opt with
| None -> (* function contract *)
- if before then get_fct_entry_point ()
- else before, None
- (* statement contract *)
+ if before then get_fct_entry_point ()
+ else before, None
+ (* statement contract *)
| Some (ki,_) -> (* statement contract and code annotation *)
- before, Some ki
+ before, Some ki
in
let result = match current_label with
| AbsLabel_stmt stmt -> true, Some stmt
@@ -670,119 +670,119 @@ struct
method private change_label: 'a.abs_label -> 'a -> 'a visitAction =
fun label x ->
- let old_label = current_label in
- current_label <- label;
- ChangeDoChildrenPost
- (x,fun x -> current_label <- old_label; x)
+ let old_label = current_label in
+ current_label <- label;
+ ChangeDoChildrenPost
+ (x,fun x -> current_label <- old_label; x)
method private change_label_to_here: 'a.'a -> 'a visitAction =
fun x ->
- self#change_label AbsLabel_here x
+ self#change_label AbsLabel_here x
method private change_label_to_old: 'a.'a -> 'a visitAction =
fun x ->
- match ki_opt,before_opt with
- (* function contract *)
- | None,Some true ->
- failwith "The use of the label Old is forbidden inside clauses \
- related to the pre-state of function contracts."
- | None,None
- | None,Some false ->
- (* refers to the pre-state of the contract. *)
- self#change_label AbsLabel_pre x
- (* statement contract *)
- | Some (_ki,false),Some true ->
- failwith "The use of the label Old is forbidden inside clauses \
-related to the pre-state of statement contracts."
- | Some (ki,false),None
- | Some (ki,false),Some false ->
- (* refers to the pre-state of the contract. *)
- self#change_label (AbsLabel_stmt ki) x
- (* code annotation *)
- | Some (_ki,true),None
- | Some (_ki,true),Some _ ->
- (* refers to the pre-state of the function contract. *)
- self#change_label AbsLabel_pre x
+ match ki_opt,before_opt with
+ (* function contract *)
+ | None,Some true ->
+ failwith "The use of the label Old is forbidden inside clauses \
+ related to the pre-state of function contracts."
+ | None,None
+ | None,Some false ->
+ (* refers to the pre-state of the contract. *)
+ self#change_label AbsLabel_pre x
+ (* statement contract *)
+ | Some (_ki,false),Some true ->
+ failwith "The use of the label Old is forbidden inside clauses \
+ related to the pre-state of statement contracts."
+ | Some (ki,false),None
+ | Some (ki,false),Some false ->
+ (* refers to the pre-state of the contract. *)
+ self#change_label (AbsLabel_stmt ki) x
+ (* code annotation *)
+ | Some (_ki,true),None
+ | Some (_ki,true),Some _ ->
+ (* refers to the pre-state of the function contract. *)
+ self#change_label AbsLabel_pre x
method private change_label_to_post: 'a.'a -> 'a visitAction =
- fun x ->
- (* allowed when [before_opt=None] for function/statement contracts *)
- match ki_opt,before_opt with
- (* function contract *)
- | None,Some _ ->
- failwith "Function contract where the use of the label Post is \
- forbidden."
- | None,None ->
- (* refers to the post-state of the contract. *)
- self#change_label AbsLabel_post x
- (* statement contract *)
- | Some (_ki,false),Some _ ->
- failwith "Statement contract where the use of the label Post is \
-forbidden."
- | Some (_ki,false),None ->
- (* refers to the pre-state of the contract. *)
- self#change_label AbsLabel_post x
- (* code annotation *)
- | Some (_ki,true), _ ->
- failwith "The use of the label Post is forbidden inside code \
-annotations."
+ fun x ->
+ (* allowed when [before_opt=None] for function/statement contracts *)
+ match ki_opt,before_opt with
+ (* function contract *)
+ | None,Some _ ->
+ failwith "Function contract where the use of the label Post is \
+ forbidden."
+ | None,None ->
+ (* refers to the post-state of the contract. *)
+ self#change_label AbsLabel_post x
+ (* statement contract *)
+ | Some (_ki,false),Some _ ->
+ failwith "Statement contract where the use of the label Post is \
+ forbidden."
+ | Some (_ki,false),None ->
+ (* refers to the pre-state of the contract. *)
+ self#change_label AbsLabel_post x
+ (* code annotation *)
+ | Some (_ki,true), _ ->
+ failwith "The use of the label Post is forbidden inside code \
+ annotations."
method private change_label_to_pre: 'a.'a -> 'a visitAction =
fun x ->
- match ki_opt with
- (* function contract *)
- | None ->
- failwith "The use of the label Pre is forbidden inside function \
-contracts."
- (* statement contract *)
- (* code annotation *)
- | Some _ ->
- (* refers to the pre-state of the function contract. *)
- self#change_label AbsLabel_pre x
+ match ki_opt with
+ (* function contract *)
+ | None ->
+ failwith "The use of the label Pre is forbidden inside function \
+ contracts."
+ (* statement contract *)
+ (* code annotation *)
+ | Some _ ->
+ (* refers to the pre-state of the function contract. *)
+ self#change_label AbsLabel_pre x
method private change_label_aux: 'a. _ -> 'a -> 'a visitAction =
fun lbl x -> self#change_label lbl x
method private change_label_to_stmt: 'a.stmt -> 'a -> 'a visitAction =
fun stmt x ->
- match ki_opt with
- (* function contract *)
- | None ->
- failwith "the use of C labels is forbidden inside clauses related \
-to function contracts."
- (* statement contract *)
- (* code annotation *)
- | Some _ ->
- (* refers to the state at the C label of the statement [stmt]. *)
- self#change_label (AbsLabel_stmt stmt) x
+ match ki_opt with
+ (* function contract *)
+ | None ->
+ failwith "the use of C labels is forbidden inside clauses related \
+ to function contracts."
+ (* statement contract *)
+ (* code annotation *)
+ | Some _ ->
+ (* refers to the state at the C label of the statement [stmt]. *)
+ self#change_label (AbsLabel_stmt stmt) x
method! vpredicate_node p =
- let fail () =
- raise (NYI (Pretty_utils.sfprintf
- "[logic_interp] %a" Printer.pp_predicate_node p))
- in
- match p with
- | Pat (_, BuiltinLabel Old) -> self#change_label_to_old p
- | Pat (_, BuiltinLabel Here) -> self#change_label_to_here p
- | Pat (_, BuiltinLabel Pre) -> self#change_label_to_pre p
- | Pat (_, BuiltinLabel Post) -> self#change_label_to_post p
- | Pat (_, BuiltinLabel Init) ->
- self#change_label_aux AbsLabel_init p
- | Pat (_, BuiltinLabel LoopCurrent) ->
- self#change_label_aux AbsLabel_loop_current p
- | Pat (_, BuiltinLabel LoopEntry) ->
- self#change_label_aux AbsLabel_loop_entry p
- | Pat (_, FormalLabel s) ->
- failwith ("unknown logic label" ^ s)
- | Pat (_, StmtLabel st) -> self#change_label_to_stmt !st p
- | Pfalse | Ptrue | Prel _ | Pand _ | Por _ | Pxor _ | Pimplies _
- | Piff _ | Pnot _ | Pif _ | Plet _ | Pforall _ | Pexists _
- | Papp (_, [], _) (* No label, thus cannot access memory *)
- | Pseparated _ (* need only to preserve the values of each pointer *)
- -> DoChildren
-
- | Pinitialized (lbl, t) | Pdangling (lbl, t) ->
+ let fail () =
+ raise (NYI (Pretty_utils.sfprintf
+ "[logic_interp] %a" Printer.pp_predicate_node p))
+ in
+ match p with
+ | Pat (_, BuiltinLabel Old) -> self#change_label_to_old p
+ | Pat (_, BuiltinLabel Here) -> self#change_label_to_here p
+ | Pat (_, BuiltinLabel Pre) -> self#change_label_to_pre p
+ | Pat (_, BuiltinLabel Post) -> self#change_label_to_post p
+ | Pat (_, BuiltinLabel Init) ->
+ self#change_label_aux AbsLabel_init p
+ | Pat (_, BuiltinLabel LoopCurrent) ->
+ self#change_label_aux AbsLabel_loop_current p
+ | Pat (_, BuiltinLabel LoopEntry) ->
+ self#change_label_aux AbsLabel_loop_entry p
+ | Pat (_, FormalLabel s) ->
+ failwith ("unknown logic label" ^ s)
+ | Pat (_, StmtLabel st) -> self#change_label_to_stmt !st p
+ | Pfalse | Ptrue | Prel _ | Pand _ | Por _ | Pxor _ | Pimplies _
+ | Piff _ | Pnot _ | Pif _ | Plet _ | Pforall _ | Pexists _
+ | Papp (_, [], _) (* No label, thus cannot access memory *)
+ | Pseparated _ (* need only to preserve the values of each pointer *)
+ -> DoChildren
+
+ | Pinitialized (lbl, t) | Pdangling (lbl, t) ->
(* Dependencies of [\initialized(p)] or [\dangling(p)] are the
dependencies of [*p]. *)
if is_same_label current_label lbl then (
@@ -794,17 +794,17 @@ to function contracts."
)
else fail ()
- | Pvalid_read (_lbl, _) | Pvalid (_lbl, _) ->
+ | Pvalid_read (_lbl, _) | Pvalid (_lbl, _) ->
(* Does not take dynamic allocation into account, but then
Value does not either. [lbl] can be ignored because they are
taken into account by the functions [from_...] below *)
DoChildren
- | Pobject_pointer _ | Pvalid_function _ ->
+ | Pobject_pointer _ | Pvalid_function _ ->
DoChildren
- | Papp _ | Pallocable _ | Pfreeable _ | Pfresh _
- -> fail ()
+ | Papp _ | Pallocable _ | Pfreeable _ | Pfresh _
+ -> fail ()
method private do_term_lval t =
let current_before, current_stmt = self#get_ctrl_point () in
@@ -824,232 +824,232 @@ to function contracts."
method! vterm t =
match t.term_node with
- | TAddrOf _ | TLval (TMem _,_)
- | TLval(TVar {lv_origin = Some _},_) | TStartOf _ ->
- self#do_term_lval t;
- SkipChildren
- | Tat (_, BuiltinLabel Old) -> self#change_label_to_old t
- | Tat (_, BuiltinLabel Here) -> self#change_label_to_here t
- | Tat (_, BuiltinLabel Pre) -> self#change_label_to_pre t
- | Tat (_, BuiltinLabel Post) -> self#change_label_to_post t
- | Tat (_, BuiltinLabel Init) ->
- self#change_label_aux AbsLabel_init t
- | Tat (_, BuiltinLabel LoopCurrent) ->
- self#change_label_aux AbsLabel_loop_current t
- | Tat (_, BuiltinLabel LoopEntry) ->
- self#change_label_aux AbsLabel_loop_entry t
- | Tat (_, StmtLabel st) -> self#change_label_to_stmt !st t
- | Tat (_, FormalLabel s) ->
- failwith ("unknown logic label" ^ s)
- | TSizeOf _ | TSizeOfE _ | TSizeOfStr _ | TAlignOf _ | TAlignOfE _ ->
- (* These are static constructors, there are no dependencies here *)
- SkipChildren
- | _ -> DoChildren
+ | TAddrOf _ | TLval (TMem _,_)
+ | TLval(TVar {lv_origin = Some _},_) | TStartOf _ ->
+ self#do_term_lval t;
+ SkipChildren
+ | Tat (_, BuiltinLabel Old) -> self#change_label_to_old t
+ | Tat (_, BuiltinLabel Here) -> self#change_label_to_here t
+ | Tat (_, BuiltinLabel Pre) -> self#change_label_to_pre t
+ | Tat (_, BuiltinLabel Post) -> self#change_label_to_post t
+ | Tat (_, BuiltinLabel Init) ->
+ self#change_label_aux AbsLabel_init t
+ | Tat (_, BuiltinLabel LoopCurrent) ->
+ self#change_label_aux AbsLabel_loop_current t
+ | Tat (_, BuiltinLabel LoopEntry) ->
+ self#change_label_aux AbsLabel_loop_entry t
+ | Tat (_, StmtLabel st) -> self#change_label_to_stmt !st t
+ | Tat (_, FormalLabel s) ->
+ failwith ("unknown logic label" ^ s)
+ | TSizeOf _ | TSizeOfE _ | TSizeOfStr _ | TAlignOf _ | TAlignOfE _ ->
+ (* These are static constructors, there are no dependencies here *)
+ SkipChildren
+ | _ -> DoChildren
end
- (** Entry point to get the list of [ki] * [Locations.Zone.t]
- needed to evaluate the [term]
- relative to the [ctx] of interpretation. *)
- let from_term term ctx =
- (* [VP 2011-01-28] TODO: factorize from_terms and from_term, and use
- a more functional setting. *)
+ (** Entry point to get the list of [ki] * [Locations.Zone.t]
+ needed to evaluate the [term]
+ relative to the [ctx] of interpretation. *)
+ let from_term term ctx =
+ (* [VP 2011-01-28] TODO: factorize from_terms and from_term, and use
+ a more functional setting. *)
+ (try
+ ignore(Visitor.visitFramacTerm
+ (new populate_zone ctx.state_opt ctx.ki_opt ctx.kf) term)
+ with NYI msg ->
+ add_top_zone msg) ;
+ locals := Varinfo.Set.union (extract_locals_from_term term) !locals;
+ labels := Logic_label.Set.union (extract_labels_from_term term) !labels;
+ get_result ()
+
+ (** Entry point to get the list of [ki] * [Locations.Zone.t]
+ needed to evaluate the list of [terms]
+ relative to the [ctx] of interpretation. *)
+ let from_terms terms ctx =
+ let f x =
(try
ignore(Visitor.visitFramacTerm
- (new populate_zone ctx.state_opt ctx.ki_opt ctx.kf) term)
- with NYI msg ->
- add_top_zone msg) ;
- locals := Varinfo.Set.union (extract_locals_from_term term) !locals;
- labels := Logic_label.Set.union (extract_labels_from_term term) !labels;
- get_result ()
-
- (** Entry point to get the list of [ki] * [Locations.Zone.t]
- needed to evaluate the list of [terms]
- relative to the [ctx] of interpretation. *)
- let from_terms terms ctx =
- let f x =
- (try
- ignore(Visitor.visitFramacTerm
- (new populate_zone ctx.state_opt ctx.ki_opt ctx.kf) x)
- with NYI msg ->
- add_top_zone msg) ;
- locals := Varinfo.Set.union (extract_locals_from_term x) !locals;
- labels := Logic_label.Set.union (extract_labels_from_term x) !labels
- in
- List.iter f terms;
- get_result ()
-
- (** Entry point to get the list of [ki] * [Locations.Zone.t]
- needed to evaluate the [pred]
- relative to the [ctx] of interpretation. *)
- let from_pred pred ctx =
- (try
- ignore(Visitor.visitFramacPredicate
- (new populate_zone ctx.state_opt ctx.ki_opt ctx.kf) pred)
- with NYI msg ->
- add_top_zone msg) ;
+ (new populate_zone ctx.state_opt ctx.ki_opt ctx.kf) x)
+ with NYI msg ->
+ add_top_zone msg) ;
+ locals := Varinfo.Set.union (extract_locals_from_term x) !locals;
+ labels := Logic_label.Set.union (extract_labels_from_term x) !labels
+ in
+ List.iter f terms;
+ get_result ()
+
+ (** Entry point to get the list of [ki] * [Locations.Zone.t]
+ needed to evaluate the [pred]
+ relative to the [ctx] of interpretation. *)
+ let from_pred pred ctx =
+ (try
+ ignore(Visitor.visitFramacPredicate
+ (new populate_zone ctx.state_opt ctx.ki_opt ctx.kf) pred)
+ with NYI msg ->
+ add_top_zone msg) ;
+ locals := Varinfo.Set.union (extract_locals_from_pred pred) !locals;
+ labels := Logic_label.Set.union (extract_labels_from_pred pred) !labels;
+ get_result ()
+
+ (** Entry point to get the list of [ki] * [Locations.Zone.t]
+ needed to evaluate the list of [preds]
+ relative to the [ctx] of interpretation. *)
+ let from_preds preds ctx =
+ let f pred =
+ (try
+ ignore(Visitor.visitFramacPredicate
+ (new populate_zone ctx.state_opt ctx.ki_opt ctx.kf) pred)
+ with NYI msg ->
+ add_top_zone msg) ;
locals := Varinfo.Set.union (extract_locals_from_pred pred) !locals;
- labels := Logic_label.Set.union (extract_labels_from_pred pred) !labels;
- get_result ()
-
- (** Entry point to get the list of [ki] * [Locations.Zone.t]
- needed to evaluate the list of [preds]
- relative to the [ctx] of interpretation. *)
- let from_preds preds ctx =
- let f pred =
- (try
- ignore(Visitor.visitFramacPredicate
- (new populate_zone ctx.state_opt ctx.ki_opt ctx.kf) pred)
- with NYI msg ->
- add_top_zone msg) ;
- locals := Varinfo.Set.union (extract_locals_from_pred pred) !locals;
- labels := Logic_label.Set.union (extract_labels_from_pred pred) !labels
- in
- List.iter f preds;
- get_result ()
-
- (** Used by annotations entry points. *)
- let get_zone_from_annot a (ki,kf) loop_body_opt =
- let get_zone_from_term k x =
- (try
- ignore
- (Visitor.visitFramacTerm
- (new populate_zone (Some true) (Some (k, true)) kf) x)
- with NYI msg ->
- add_top_zone msg) ;
- (* to select the declaration of the variables *)
- locals := Varinfo.Set.union (extract_locals_from_term x) !locals;
- (* to select the labels of the annotation *)
- labels := Logic_label.Set.union (extract_labels_from_term x) !labels
- and get_zone_from_pred k x =
- (try
- ignore
- (Visitor.visitFramacPredicate
- (new populate_zone (Some true) (Some (k,true)) kf) x)
- with NYI msg ->
- add_top_zone msg) ;
- (* to select the declaration of the variables *)
- locals := Varinfo.Set.union (extract_locals_from_pred x) !locals;
- (* to select the labels of the annotation *)
- labels := Logic_label.Set.union (extract_labels_from_pred x) !labels
+ labels := Logic_label.Set.union (extract_labels_from_pred pred) !labels
+ in
+ List.iter f preds;
+ get_result ()
+
+ (** Used by annotations entry points. *)
+ let get_zone_from_annot a (ki,kf) loop_body_opt =
+ let get_zone_from_term k x =
+ (try
+ ignore
+ (Visitor.visitFramacTerm
+ (new populate_zone (Some true) (Some (k, true)) kf) x)
+ with NYI msg ->
+ add_top_zone msg) ;
+ (* to select the declaration of the variables *)
+ locals := Varinfo.Set.union (extract_locals_from_term x) !locals;
+ (* to select the labels of the annotation *)
+ labels := Logic_label.Set.union (extract_labels_from_term x) !labels
+ and get_zone_from_pred k x =
+ (try
+ ignore
+ (Visitor.visitFramacPredicate
+ (new populate_zone (Some true) (Some (k,true)) kf) x)
+ with NYI msg ->
+ add_top_zone msg) ;
+ (* to select the declaration of the variables *)
+ locals := Varinfo.Set.union (extract_locals_from_pred x) !locals;
+ (* to select the labels of the annotation *)
+ labels := Logic_label.Set.union (extract_labels_from_pred x) !labels
+ in
+ match a.annot_content with
+ | APragma (Slice_pragma (SPexpr term) | Impact_pragma (IPexpr term)) ->
+ (* to preserve the interpretation of the pragma *)
+ get_zone_from_term ki term;
+ (* to select the reachability of the pragma *)
+ pragmas :=
+ { !pragmas with ctrl = Stmt.Set.add ki !pragmas.ctrl }
+ | APragma (Slice_pragma SPctrl) ->
+ (* to select the reachability of the pragma *)
+ pragmas :=
+ { !pragmas with ctrl = Stmt.Set.add ki !pragmas.ctrl }
+ | APragma (Slice_pragma SPstmt | Impact_pragma IPstmt) ->
+ (* to preserve the effect of the statement *)
+ pragmas :=
+ { !pragmas with stmt = Stmt.Set.add ki !pragmas.stmt}
+ | AAssert (_behav,pred) ->
+ (* to preserve the interpretation of the assertion *)
+ get_zone_from_pred ki pred.tp_statement;
+ | AInvariant (_behav,true,pred) -> (* loop invariant *)
+ (* WARNING this is obsolete *)
+ (* [JS 2010/09/02] TODO: so what is the right way to do? *)
+ (* to preserve the interpretation of the loop invariant *)
+ get_zone_from_pred (Option.get loop_body_opt) pred.tp_statement;
+ | AInvariant (_behav,false,pred) -> (* code invariant *)
+ (* to preserve the interpretation of the code invariant *)
+ get_zone_from_pred ki pred.tp_statement;
+ | AVariant (term,_) ->
+ (* to preserve the interpretation of the variant *)
+ get_zone_from_term (Option.get loop_body_opt) term;
+ | APragma (Loop_pragma (Unroll_specs terms))
+ | APragma (Loop_pragma (Widen_hints terms))
+ | APragma (Loop_pragma (Widen_variables terms)) ->
+ (* to select the declaration of the variables *)
+ List.iter
+ (fun term ->
+ locals := Varinfo.Set.union (extract_locals_from_term term) !locals;
+ labels := Logic_label.Set.union (extract_labels_from_term term) !labels)
+ terms
+ | AAllocation (_,FreeAllocAny) -> ();
+ | AAllocation (_,FreeAlloc(f,a)) ->
+ let get_zone x =
+ get_zone_from_term (Option.get loop_body_opt) x.it_content
in
- match a.annot_content with
- | APragma (Slice_pragma (SPexpr term) | Impact_pragma (IPexpr term)) ->
- (* to preserve the interpretation of the pragma *)
- get_zone_from_term ki term;
- (* to select the reachability of the pragma *)
- pragmas :=
- { !pragmas with ctrl = Stmt.Set.add ki !pragmas.ctrl }
- | APragma (Slice_pragma SPctrl) ->
- (* to select the reachability of the pragma *)
- pragmas :=
- { !pragmas with ctrl = Stmt.Set.add ki !pragmas.ctrl }
- | APragma (Slice_pragma SPstmt | Impact_pragma IPstmt) ->
- (* to preserve the effect of the statement *)
- pragmas :=
- { !pragmas with stmt = Stmt.Set.add ki !pragmas.stmt}
- | AAssert (_behav,pred) ->
- (* to preserve the interpretation of the assertion *)
- get_zone_from_pred ki pred.tp_statement;
- | AInvariant (_behav,true,pred) -> (* loop invariant *)
- (* WARNING this is obsolete *)
- (* [JS 2010/09/02] TODO: so what is the right way to do? *)
- (* to preserve the interpretation of the loop invariant *)
- get_zone_from_pred (Option.get loop_body_opt) pred.tp_statement;
- | AInvariant (_behav,false,pred) -> (* code invariant *)
- (* to preserve the interpretation of the code invariant *)
- get_zone_from_pred ki pred.tp_statement;
- | AVariant (term,_) ->
- (* to preserve the interpretation of the variant *)
- get_zone_from_term (Option.get loop_body_opt) term;
- | APragma (Loop_pragma (Unroll_specs terms))
- | APragma (Loop_pragma (Widen_hints terms))
- | APragma (Loop_pragma (Widen_variables terms)) ->
- (* to select the declaration of the variables *)
- List.iter
- (fun term ->
- locals := Varinfo.Set.union (extract_locals_from_term term) !locals;
- labels := Logic_label.Set.union (extract_labels_from_term term) !labels)
- terms
- | AAllocation (_,FreeAllocAny) -> ();
- | AAllocation (_,FreeAlloc(f,a)) ->
- let get_zone x =
- get_zone_from_term (Option.get loop_body_opt) x.it_content
- in
- List.iter get_zone f ;
- List.iter get_zone a
- | AAssigns (_, WritesAny) -> ()
- | AAssigns (_, Writes l) -> (* loop assigns *)
- let get_zone x =
- get_zone_from_term (Option.get loop_body_opt) x.it_content
- in
- List.iter
- (fun (zone,deps) ->
- get_zone zone;
- match deps with
- FromAny -> ()
- | From l -> List.iter get_zone l)
- l
- | AStmtSpec _ -> (* TODO *)
- raise (NYI "[logic_interp] statement contract")
- | AExtended _ -> raise (NYI "[logic_interp] extension")
- (** Used by annotations entry points. *)
- let get_from_stmt_annots code_annot_filter ((ki, _kf) as stmt) =
- Option.iter
- (fun caf ->
- let loop_body_opt = match ki.skind with
- | Loop(_, { bstmts = body :: _ }, _, _, _) -> Some body
- | _ -> None
- in
- Annotations.iter_code_annot
- (fun _ a ->
- if caf a then get_zone_from_annot a stmt loop_body_opt)
- ki)
- code_annot_filter
-
- (** Used by annotations entry points. *)
- let from_ki_annot annot ((ki, _kf) as stmt) =
- let real_ki = match ki.skind with
- Loop(_,{bstmts = loop_entry::_},_,_,_) -> Some loop_entry
- | _ -> None
+ List.iter get_zone f ;
+ List.iter get_zone a
+ | AAssigns (_, WritesAny) -> ()
+ | AAssigns (_, Writes l) -> (* loop assigns *)
+ let get_zone x =
+ get_zone_from_term (Option.get loop_body_opt) x.it_content
in
- get_zone_from_annot annot stmt real_ki
-
- (** Entry point to get the list of [ki] * [Locations.Zone.t]
- needed to evaluate the code annotations related to this [stmt]. *)
- let from_stmt_annot annot stmt =
- from_ki_annot annot stmt;
- get_annot_result ()
-
- (** Entry point to get the list of [ki] * [Locations.Zone.t]
- needed to evaluate the code annotations related to this [stmt]. *)
- let from_stmt_annots code_annot_filter stmt =
- get_from_stmt_annots code_annot_filter stmt ;
- get_annot_result ()
-
- (** Entry point to get the list of [ki] * [Locations.Zone.t]
- needed to evaluate the code annotations related to this [kf]. *)
- let from_func_annots iter_on_kf_stmt code_annot_filter kf =
- let from_stmt_annots ki =
- get_from_stmt_annots code_annot_filter (ki, kf)
- in iter_on_kf_stmt from_stmt_annots kf;
- get_annot_result ()
-
- (** To quickly build a annotation filter *)
- let code_annot_filter annot ~threat ~user_assert ~slicing_pragma ~loop_inv ~loop_var ~others =
- match annot.annot_content with
- | APragma (Slice_pragma _) -> slicing_pragma
- | AAssert _ ->
- (match Alarms.find annot with
- | None -> user_assert
- | Some _a -> threat)
- | AVariant _ -> loop_var
- | AInvariant(_behav,true,_pred) -> loop_inv
- | AInvariant(_,false,_) -> others
- | AAllocation _ -> others
- | AAssigns _ -> others
- | APragma (Loop_pragma _)| APragma (Impact_pragma _) -> others
- | AStmtSpec _ | AExtended _ (* TODO *) -> false
- end
+ List.iter
+ (fun (zone,deps) ->
+ get_zone zone;
+ match deps with
+ FromAny -> ()
+ | From l -> List.iter get_zone l)
+ l
+ | AStmtSpec _ -> (* TODO *)
+ raise (NYI "[logic_interp] statement contract")
+ | AExtended _ -> raise (NYI "[logic_interp] extension")
+ (** Used by annotations entry points. *)
+ let get_from_stmt_annots code_annot_filter ((ki, _kf) as stmt) =
+ Option.iter
+ (fun caf ->
+ let loop_body_opt = match ki.skind with
+ | Loop(_, { bstmts = body :: _ }, _, _, _) -> Some body
+ | _ -> None
+ in
+ Annotations.iter_code_annot
+ (fun _ a ->
+ if caf a then get_zone_from_annot a stmt loop_body_opt)
+ ki)
+ code_annot_filter
+
+ (** Used by annotations entry points. *)
+ let from_ki_annot annot ((ki, _kf) as stmt) =
+ let real_ki = match ki.skind with
+ Loop(_,{bstmts = loop_entry::_},_,_,_) -> Some loop_entry
+ | _ -> None
+ in
+ get_zone_from_annot annot stmt real_ki
+
+ (** Entry point to get the list of [ki] * [Locations.Zone.t]
+ needed to evaluate the code annotations related to this [stmt]. *)
+ let from_stmt_annot annot stmt =
+ from_ki_annot annot stmt;
+ get_annot_result ()
+
+ (** Entry point to get the list of [ki] * [Locations.Zone.t]
+ needed to evaluate the code annotations related to this [stmt]. *)
+ let from_stmt_annots code_annot_filter stmt =
+ get_from_stmt_annots code_annot_filter stmt ;
+ get_annot_result ()
+
+ (** Entry point to get the list of [ki] * [Locations.Zone.t]
+ needed to evaluate the code annotations related to this [kf]. *)
+ let from_func_annots iter_on_kf_stmt code_annot_filter kf =
+ let from_stmt_annots ki =
+ get_from_stmt_annots code_annot_filter (ki, kf)
+ in iter_on_kf_stmt from_stmt_annots kf;
+ get_annot_result ()
+
+ (** To quickly build a annotation filter *)
+ let code_annot_filter annot ~threat ~user_assert ~slicing_pragma ~loop_inv ~loop_var ~others =
+ match annot.annot_content with
+ | APragma (Slice_pragma _) -> slicing_pragma
+ | AAssert _ ->
+ (match Alarms.find annot with
+ | None -> user_assert
+ | Some _a -> threat)
+ | AVariant _ -> loop_var
+ | AInvariant(_behav,true,_pred) -> loop_inv
+ | AInvariant(_,false,_) -> others
+ | AAllocation _ -> others
+ | AAssigns _ -> others
+ | APragma (Loop_pragma _)| APragma (Impact_pragma _) -> others
+ | AStmtSpec _ | AExtended _ (* TODO *) -> false
+end
exception Prune
@@ -1057,17 +1057,17 @@ let to_result_from_pred p =
let visitor = object (_self)
inherit Visitor.frama_c_inplace
- method! vterm_lhost t =
- match t with
- | TResult _ -> raise Prune
- | _ -> DoChildren
+ method! vterm_lhost t =
+ match t with
+ | TResult _ -> raise Prune
+ | _ -> DoChildren
end
in
(try
ignore(Visitor.visitFramacPredicate visitor p);
false
- with Prune ->
+ with Prune ->
true)
@@ -1088,9 +1088,9 @@ let () =
Db.Properties.Interp.loc_to_exp := loc_to_exp;
Db.Properties.Interp.To_zone.code_annot_filter := To_zone.code_annot_filter;
- Db.Properties.Interp.To_zone.mk_ctx_func_contrat :=
+ Db.Properties.Interp.To_zone.mk_ctx_func_contrat :=
To_zone.mk_ctx_func_contrat;
- Db.Properties.Interp.To_zone.mk_ctx_stmt_contrat :=
+ Db.Properties.Interp.To_zone.mk_ctx_stmt_contrat :=
To_zone.mk_ctx_stmt_contrat;
Db.Properties.Interp.To_zone.mk_ctx_stmt_annot := To_zone.mk_ctx_stmt_annot;
diff --git a/src/kernel_services/analysis/loop.ml b/src/kernel_services/analysis/loop.ml
index 9c2bc17726a1c5d3ba16fc40549a1c7ac5cf669e..1cda692e3bb2d69f4c17f0a9ae2a32ff6fbb18bf 100644
--- a/src/kernel_services/analysis/loop.ml
+++ b/src/kernel_services/analysis/loop.ml
@@ -27,10 +27,10 @@ module Natural_Loops =
Kernel_function.Make_Table
(Stmt.Map.Make(Datatype.List(Stmt)))
(struct
- let name = "natural_loops"
- let size = 97
- let dependencies = [ Ast.self ]
- end)
+ let name = "natural_loops"
+ let size = 97
+ let dependencies = [ Ast.self ]
+ end)
let pretty_natural_loops fmt loops =
Stmt.Map.iter
@@ -46,21 +46,21 @@ let findNaturalLoops (f: fundec) =
let loops =
List.fold_left
(fun acc b ->
- (* Iterate over all successors, and see if they are among the
- dominators for this block. Such a successor [s] is a natural loop,
- and [b -> s] is a back-edge. *)
- List.fold_left
- (fun acc s ->
- if Dominators.dominates s b then
- let cur =
- try Stmt.Map.find s acc
- with Not_found -> []
- in
- Stmt.Map.add s (b :: cur) acc
- else
- acc)
- acc
- b.succs)
+ (* Iterate over all successors, and see if they are among the
+ dominators for this block. Such a successor [s] is a natural loop,
+ and [b -> s] is a back-edge. *)
+ List.fold_left
+ (fun acc s ->
+ if Dominators.dominates s b then
+ let cur =
+ try Stmt.Map.find s acc
+ with Not_found -> []
+ in
+ Stmt.Map.add s (b :: cur) acc
+ else
+ acc)
+ acc
+ b.succs)
Stmt.Map.empty
f.sallstmts
in
@@ -74,17 +74,17 @@ let get_naturals kf =
(fun kf ->
match kf.fundec with
| Declaration _ ->
- Stmt.Map.empty
+ Stmt.Map.empty
| Definition (cilfundec,_) ->
- Kernel.debug ~dkey:Kernel.dkey_loops
- "Compute natural loops for '%a'"
- Kernel_function.pretty kf;
- let naturals = findNaturalLoops cilfundec in
- Kernel.debug ~dkey:Kernel.dkey_loops
- "Done computing natural loops for '%a':@.%a"
- Kernel_function.pretty kf
- pretty_natural_loops naturals;
- naturals
+ Kernel.debug ~dkey:Kernel.dkey_loops
+ "Compute natural loops for '%a'"
+ Kernel_function.pretty kf;
+ let naturals = findNaturalLoops cilfundec in
+ Kernel.debug ~dkey:Kernel.dkey_loops
+ "Done computing natural loops for '%a':@.%a"
+ Kernel_function.pretty kf
+ pretty_natural_loops naturals;
+ naturals
)
kf
in
@@ -130,10 +130,10 @@ module Non_Natural_Loops =
Kernel_function.Make_Table
(Stmt.Set)
(struct
- let name = "Loop.non_natural_loops"
- let size = 37
- let dependencies = [ Ast.self ]
- end)
+ let name = "Loop.non_natural_loops"
+ let size = 37
+ let dependencies = [ Ast.self ]
+ end)
let get_non_naturals = Non_Natural_Loops.memo get_non_naturals
let is_non_natural kf s = Stmt.Set.mem s (get_non_naturals kf)
diff --git a/src/kernel_services/analysis/ordered_stmt.ml b/src/kernel_services/analysis/ordered_stmt.ml
index d041f7aa94dc2e8c982ed90d2d3c77e891091d8f..c843ecffca2faf0d9fdd780e92666093d6b33f6b 100644
--- a/src/kernel_services/analysis/ordered_stmt.ml
+++ b/src/kernel_services/analysis/ordered_stmt.ml
@@ -45,12 +45,12 @@ module Connex_components = struct
end
module Ordered_stmt = Kernel_function.Make_Table
- (Datatype.Triple(Order)(Unorder)(Connex_components))
- (struct
- let name = "Dataflow2.Ordered_stmt"
- let dependencies = [ Ast.self ]
- let size = 17
- end)
+ (Datatype.Triple(Order)(Unorder)(Connex_components))
+ (struct
+ let name = "Dataflow2.Ordered_stmt"
+ let dependencies = [ Ast.self ]
+ let size = 17
+ end)
;;
(* Skeleton for an OCamlGraph topological sort *)
@@ -94,7 +94,7 @@ let get_ordered_stmt kf =
let (_nb_scc,f_scc) = Connex.scc kf in
let sccs = Array.make nb_stmts (-1) in
Array.iteri (fun ordered stmt ->
- sccs.(ordered) <- f_scc stmt) ordered_to_stmt;
+ sccs.(ordered) <- f_scc stmt) ordered_to_stmt;
(stmt_to_ordered, ordered_to_stmt, sccs);;
type ordered_stmt = int;;
diff --git a/src/kernel_services/analysis/service_graph.ml b/src/kernel_services/analysis/service_graph.ml
index a6e7216d5a042f05564f8bf5824243d6c93e585e..219c5125d6919b262b20c2ec0958e372b9a8ac9f 100644
--- a/src/kernel_services/analysis/service_graph.ml
+++ b/src/kernel_services/analysis/service_graph.ml
@@ -39,26 +39,26 @@ module type S = sig
val entry_point: unit -> Service_graph.V.t option
module TP: Graph.Graphviz.GraphWithDotAttrs
with type t = Service_graph.t
- and type V.t = node vertex
- and type E.t = Service_graph.E.t
+ and type V.t = node vertex
+ and type E.t = Service_graph.E.t
end
module Make
- (G: sig
- type t
- module V: sig
- include Graph.Sig.COMPARABLE
- val id: t -> int
- val name: t -> string
- val attributes: t -> Graph.Graphviz.DotAttributes.vertex list
- val entry_point: unit -> t option
- end
- val iter_vertex : (V.t -> unit) -> t -> unit
- val iter_succ : (V.t -> unit) -> t -> V.t -> unit
- val iter_pred : (V.t -> unit) -> t -> V.t -> unit
- val fold_pred : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a
- val datatype_name: string
- end) =
+ (G: sig
+ type t
+ module V: sig
+ include Graph.Sig.COMPARABLE
+ val id: t -> int
+ val name: t -> string
+ val attributes: t -> Graph.Graphviz.DotAttributes.vertex list
+ val entry_point: unit -> t option
+ end
+ val iter_vertex : (V.t -> unit) -> t -> unit
+ val iter_succ : (V.t -> unit) -> t -> V.t -> unit
+ val iter_pred : (V.t -> unit) -> t -> V.t -> unit
+ val fold_pred : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a
+ val datatype_name: string
+ end) =
struct
type graph = G.t
@@ -92,7 +92,7 @@ struct
let name = G.datatype_name ^ " Service_graph.Service_graph.t"
let reprs = [ M.create () ]
let mem_project = Datatype.never_any_project
- end)
+ end)
let () = Type.set_ml_name Datatype.ty None
let add_labeled_edge g src l dst =
if mem_edge g src dst then begin
@@ -186,8 +186,8 @@ struct
{ node = node; is_root = false; root = root }
in
(match G.V.entry_point () with
- | Some e when G.V.equal node e -> entry_point_ref := Some v
- | None | Some _ -> ());
+ | Some e when G.V.equal node e -> entry_point_ref := Some v
+ | None | Some _ -> ());
let s = match incomming_s with
| Fresh_if_unchanged | Unknown_cycle | Final _ -> In_service v.root
| To_be_confirmed root -> Maybe_fresh root
@@ -202,14 +202,14 @@ struct
let service =
G.fold_pred
(fun node' acc ->
- try
- let _, s' = Vertices.find node' in
- merge_service acc s'
- with Not_found ->
- (* cycle *)
- match acc with
- | Fresh_if_unchanged | Unknown_cycle -> Unknown_cycle
- | To_be_confirmed v | Final v -> To_be_confirmed v)
+ try
+ let _, s' = Vertices.find node' in
+ merge_service acc s'
+ with Not_found ->
+ (* cycle *)
+ match acc with
+ | Fresh_if_unchanged | Unknown_cycle -> Unknown_cycle
+ | To_be_confirmed v | Final v -> To_be_confirmed v)
g
node
Fresh_if_unchanged
@@ -230,11 +230,11 @@ struct
try
G.iter_pred
(fun node' ->
- try
- let v', _ = Vertices.find node' in
- if not (Vertex.equal root v'.root) then raise Exit
- with Not_found ->
- assert false)
+ try
+ let v', _ = Vertices.find node' in
+ if not (Vertex.equal root v'.root) then raise Exit
+ with Not_found ->
+ assert false)
g
node
(* old status is confirmed: nothing to do *)
@@ -256,32 +256,32 @@ struct
let visited = HVertex.create 7 in
G.iter_vertex
(fun node ->
- let v = find node in
- HVertex.reset visited;
- G.iter_succ
- (fun node' ->
- let succ = find node' in
- if not (HVertex.mem visited succ.node) then begin
- HVertex.add visited succ.node ();
- Service_graph.add_labeled_edge callg v Inter_functions succ;
- let src_root = v.root in
- let dst_root = succ.root in
- if not (Vertex.equal src_root dst_root) then begin
- Service_graph.add_labeled_edge
- callg
- src_root
- Inter_services
- dst_root
- (* JS: no need of a 'service_to_function' edge since
- it is not possible to have an edge starting from a
- no-root vertex and going to another service.
-
- no need of a 'function_to_service' edge too since the only
- possible edges between two services go to a root. *)
- end
- end)
- g
- node)
+ let v = find node in
+ HVertex.reset visited;
+ G.iter_succ
+ (fun node' ->
+ let succ = find node' in
+ if not (HVertex.mem visited succ.node) then begin
+ HVertex.add visited succ.node ();
+ Service_graph.add_labeled_edge callg v Inter_functions succ;
+ let src_root = v.root in
+ let dst_root = succ.root in
+ if not (Vertex.equal src_root dst_root) then begin
+ Service_graph.add_labeled_edge
+ callg
+ src_root
+ Inter_services
+ dst_root
+ (* JS: no need of a 'service_to_function' edge since
+ it is not possible to have an edge starting from a
+ no-root vertex and going to another service.
+
+ no need of a 'function_to_service' edge too since the only
+ possible edges between two services go to a root. *)
+ end
+ end)
+ g
+ node)
g
let compute g initial_roots =
@@ -326,7 +326,7 @@ struct
let sr = root_id (Service_graph.E.src e) in
[ `Color (Extlib.number_to_color sr) ]
in
- if !inter_services_ref then
+ if !inter_services_ref then
color e
else
match Service_graph.E.label e with
diff --git a/src/kernel_services/analysis/service_graph.mli b/src/kernel_services/analysis/service_graph.mli
index da9a8ddd5cf3eaf5fe167e1acf551911df382354..ee7b9e719d3dc64b4e85f929c0b187086b05507b 100644
--- a/src/kernel_services/analysis/service_graph.mli
+++ b/src/kernel_services/analysis/service_graph.mli
@@ -28,7 +28,7 @@ val frama_c_display: bool -> unit
@since Oxygen-20120901 *)
type 'a vertex = private
- { node: 'a; mutable is_root: bool; mutable root: 'a vertex }
+ { node: 'a; mutable is_root: bool; mutable root: 'a vertex }
type edge = private Inter_services | Inter_functions | Both
@@ -54,33 +54,33 @@ module type S = sig
module TP: Graph.Graphviz.GraphWithDotAttrs
with type t = Service_graph.t
- and type V.t = node vertex
- and type E.t = Service_graph.E.t
-(** @since Beryllium-20090902 *)
+ and type V.t = node vertex
+ and type E.t = Service_graph.E.t
+ (** @since Beryllium-20090902 *)
end
(** Generic functor implementing the services algorithm according to a graph
implementation. *)
module Make
- (G: sig
- type t
- module V: sig
- (** @modify Oxygen-20120901 require [compare] *)
- include Graph.Sig.COMPARABLE
- val id: t -> int
+ (G: sig
+ type t
+ module V: sig
+ (** @modify Oxygen-20120901 require [compare] *)
+ include Graph.Sig.COMPARABLE
+ val id: t -> int
(** assume [id >= 0] and unique for each vertices of the graph *)
- val name: t -> string
- val attributes: t -> Graph.Graphviz.DotAttributes.vertex list
- val entry_point: unit -> t option
- (** @modify Nitrogen-20111001 return an option*)
- end
- val iter_vertex : (V.t -> unit) -> t -> unit
- val iter_succ : (V.t -> unit) -> t -> V.t -> unit
- val iter_pred : (V.t -> unit) -> t -> V.t -> unit
- val fold_pred : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a
- val datatype_name: string
- end) :
+ val name: t -> string
+ val attributes: t -> Graph.Graphviz.DotAttributes.vertex list
+ val entry_point: unit -> t option
+ (** @modify Nitrogen-20111001 return an option*)
+ end
+ val iter_vertex : (V.t -> unit) -> t -> unit
+ val iter_succ : (V.t -> unit) -> t -> V.t -> unit
+ val iter_pred : (V.t -> unit) -> t -> V.t -> unit
+ val fold_pred : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a
+ val datatype_name: string
+ end) :
S with type node = G.V.t and type graph = G.t
(*
diff --git a/src/kernel_services/analysis/stmts_graph.ml b/src/kernel_services/analysis/stmts_graph.ml
index b8a2dc0ba13ef3557a2545c9417a52b555f4b030..5da2cedbb7e069301532f7060b61e6f413b4d236 100644
--- a/src/kernel_services/analysis/stmts_graph.ml
+++ b/src/kernel_services/analysis/stmts_graph.ml
@@ -33,13 +33,13 @@ struct
module HV = Hashtbl.Make(Stmt)
module HptmapStmtBool = Hptmap.Make
- (Cil_datatype.Stmt_Id)
- (struct include Datatype.Bool let pretty_debug = pretty end)
- (Hptmap.Comp_unused)
- (struct let v = [ [] ] end)
- (struct let l = [ Ast.self ] end)
- (* Clear the (non-project compliant) internal caches each time the ast
- changes, which includes every time we switch project. *)
+ (Cil_datatype.Stmt_Id)
+ (struct include Datatype.Bool let pretty_debug = pretty end)
+ (Hptmap.Comp_unused)
+ (struct let v = [ [] ] end)
+ (struct let l = [ Ast.self ] end)
+ (* Clear the (non-project compliant) internal caches each time the ast
+ changes, which includes every time we switch project. *)
let () = Ast.add_hook_on_update (fun _ -> HptmapStmtBool.clear_caches ())
(* this a cache containing the path tests already computed *)
@@ -58,27 +58,27 @@ struct
let check_path_using_filter filterfunc pc v1 v2 =
let assoc = find_assoc_with_default pc v1 in
try HptmapStmtBool.find v2 assoc
- with Not_found ->
+ with Not_found ->
(* the path is not in cache; we check it with Dijkstra *)
let visited = HV.create 97 in
let q = Queue.create () in
let rec loop () =
- if Queue.is_empty q then begin
+ if Queue.is_empty q then begin
add_to_cache pc v1 v2 false;
- false
- end else begin
- let v = Queue.pop q in
+ false
+ end else begin
+ let v = Queue.pop q in
add_to_cache pc v1 v true;
- if Stmt.equal v v2 then
- true
- else begin
- if not (HV.mem visited v) then begin
- HV.add visited v ();
- List.iter (fun v' -> if filterfunc v' then Queue.add v' q) v.succs
- end;
- loop ()
- end
- end
+ if Stmt.equal v v2 then
+ true
+ else begin
+ if not (HV.mem visited v) then begin
+ HV.add visited v ();
+ List.iter (fun v' -> if filterfunc v' then Queue.add v' q) v.succs
+ end;
+ loop ()
+ end
+ end
in
Queue.add v1 q;
loop ()
@@ -107,7 +107,7 @@ module StmtCanReachCache =
let name = "Eval_funs.StmtCanReachCache"
let size = 17
let dependencies = [ Ast.self ]
- end)
+ end)
let stmt_can_reach = StmtCanReachCache.memo stmt_can_reach
@@ -146,7 +146,7 @@ module TP = struct
| Break _ -> Format.sprintf "BREAK <%d>" s.sid
| Continue _ -> Format.sprintf "CONTINUE <%d>" s.sid
| If(e,_,_,_) ->
- Format.asprintf "IF <%d>\n%a" s.sid Printer.pp_exp e
+ Format.asprintf "IF <%d>\n%a" s.sid Printer.pp_exp e
| Switch _ -> Format.sprintf "SWITCH <%d>" s.sid
| Loop _ -> Format.sprintf "WHILE(1) <%d>" s.sid
| Block _ -> Format.sprintf "BLOCK <%d>" s.sid
@@ -213,19 +213,19 @@ module StmtsGraphTbl=
let name = "Stmts_Graph.StmtsGraphTbl"
let reprs = [ SG.create () ]
let mem_project = Datatype.never_any_project
- end))
+ end))
(struct
let name = "StmtsGraphTbl"
let size = 17
let dependencies = [ Ast.self ]
- end)
+ end)
let get_graph kf =
StmtsGraphTbl.memo
(fun kf -> match kf.fundec with
- | Definition (f,_) ->
- compute_stmtgraph_func f
- | Declaration _ -> assert false)
+ | Definition (f,_) ->
+ compute_stmtgraph_func f
+ | Declaration _ -> assert false)
kf
@@ -260,7 +260,7 @@ module StmtStmts =
let name = "Stmts_graph.StmtStmts"
let size = 142
let dependencies = [ Ast.self ]
- end)
+ end)
let rec get_block_stmts blk =
let add stmts s = Stmt.Set.union (get_stmt_stmts s) stmts in
@@ -272,20 +272,20 @@ and get_stmt_stmts s =
| Instr _ | Return _ | Throw _ -> Stmt.Set.singleton s
| Continue _ | Break _ | Goto _ -> Stmt.Set.singleton s
| Block b | Switch (_, b, _, _) | Loop (_, b, _, _, _) ->
- Stmt.Set.add s (get_block_stmts b)
+ Stmt.Set.add s (get_block_stmts b)
| UnspecifiedSequence seq ->
- let b = Cil.block_from_unspecified_sequence seq in
- Stmt.Set.add s (get_block_stmts b)
+ let b = Cil.block_from_unspecified_sequence seq in
+ Stmt.Set.add s (get_block_stmts b)
| If (_, b1, b2, _) ->
- let stmts =
- Stmt.Set.union (get_block_stmts b1)(get_block_stmts b2)
- in Stmt.Set.add s stmts
+ let stmts =
+ Stmt.Set.union (get_block_stmts b1)(get_block_stmts b2)
+ in Stmt.Set.add s stmts
| TryCatch(t,c,_) ->
- List.fold_left
+ List.fold_left
(fun acc (_,b) -> Stmt.Set.union acc (get_block_stmts b))
(get_block_stmts t) c
| TryExcept (_, _, _, _) | TryFinally (_, _, _) ->
- Kernel.not_yet_implemented ~current:true "exception handling"
+ Kernel.not_yet_implemented ~current:true "exception handling"
in
StmtStmts.memo compute_stmt_stmts s
@@ -306,19 +306,19 @@ type waysout = { normal : EdgesDatatype.t ;
continues : EdgesDatatype.t ;
returns : EdgesDatatype.t ;
gotos : EdgesDatatype.t ;
-}
+ }
let empty_waysout = { normal = []; breaks = []; continues = [];
returns = []; gotos = [] }
module WaysOutDatatype =
Datatype.Make
(struct
- include Datatype.Undefined (* TODO: unmarshal ? *)
- type t = waysout
- let reprs = [ empty_waysout ]
- let name = "WaysOut"
- let mem_project = Datatype.never_any_project
- end)
+ include Datatype.Undefined (* TODO: unmarshal ? *)
+ type t = waysout
+ let reprs = [ empty_waysout ]
+ let name = "WaysOut"
+ let mem_project = Datatype.never_any_project
+ end)
module StmtWaysOut =
Cil_state_builder.Stmt_hashtbl (WaysOutDatatype)
@@ -326,35 +326,35 @@ module StmtWaysOut =
let name = "Stmts_graphs.StmtWaysOut"
let size = 142
let dependencies = [ StmtStmts.self ]
- end)
+ end)
let compute_stmts_out_edges stmts =
let do_s s waysout =
(* if [s] has a successor [s'] which is not in [stmt] statements,
- * add [s,s'] *)
+ * add [s,s'] *)
let add s acc =
let do_succ acc s' =
if Stmt.Set.mem s' stmts then acc
else (s, s')::acc
in List.fold_left do_succ acc s.succs
in match s.skind with
- | Continue _ -> { waysout with continues = add s waysout.continues }
- | Break _ -> { waysout with breaks = add s waysout.breaks }
- | Return _ -> { waysout with returns = add s waysout.returns }
- | Goto _ ->
- begin
- match s.succs with
- | { skind = Return _ }::[] ->
- { waysout with returns = add s waysout.returns }
- | _ -> { waysout with gotos = add s waysout.gotos }
- end
- | _ -> { waysout with normal = add s waysout.normal }
+ | Continue _ -> { waysout with continues = add s waysout.continues }
+ | Break _ -> { waysout with breaks = add s waysout.breaks }
+ | Return _ -> { waysout with returns = add s waysout.returns }
+ | Goto _ ->
+ begin
+ match s.succs with
+ | { skind = Return _ }::[] ->
+ { waysout with returns = add s waysout.returns }
+ | _ -> { waysout with gotos = add s waysout.gotos }
+ end
+ | _ -> { waysout with normal = add s waysout.normal }
in
- Stmt.Set.fold do_s stmts empty_waysout
+ Stmt.Set.fold do_s stmts empty_waysout
let merge_waysout waysout =
- waysout.normal @ waysout.breaks @ waysout.continues @
- waysout.returns @ waysout.gotos
+ waysout.normal @ waysout.breaks @ waysout.continues @
+ waysout.returns @ waysout.gotos
let select_waysout termination_kind waysout =
match termination_kind with
@@ -386,7 +386,7 @@ let get_all_block_out_edges blk =
let get_block_out_edges termination_kind blk =
let waysout = compute_block_out_edges blk in
- select_waysout termination_kind waysout
+ select_waysout termination_kind waysout
let get_all_stmt_last_stmts s =
List.map fst (get_all_stmt_out_edges s)
@@ -408,7 +408,7 @@ module StmtWaysIn =
let name = "Stmts_graphs.StmtWaysIn"
let size = 142
let dependencies = [ StmtStmts.self ]
- end)
+ end)
let compute_stmts_in_edges stmts =
let add s acc =
@@ -421,7 +421,7 @@ let compute_stmt_entry_stmts stmt =
compute_stmts_in_edges (get_stmt_stmts stmt)
let get_stmt_in_edges s =
- StmtWaysIn.memo compute_stmt_entry_stmts s
+ StmtWaysIn.memo compute_stmt_entry_stmts s
let get_block_in_edges blk =
compute_stmts_in_edges (get_block_stmts blk)
diff --git a/src/kernel_services/analysis/stmts_graph.mli b/src/kernel_services/analysis/stmts_graph.mli
index 88f0b81d8391a57797e3ae37deefbd6dc03878be..844b9597063553dc70db7d2e4a996ae2292a94a6 100644
--- a/src/kernel_services/analysis/stmts_graph.mli
+++ b/src/kernel_services/analysis/stmts_graph.mli
@@ -26,24 +26,24 @@ open Cil_types
open Cil_datatype
val stmt_can_reach: kernel_function -> stmt -> stmt -> bool
- (** [stmt_can_reach kf s1 s2] is [true] iff the control flow can reach
- [s2] starting at [s1] in function [kf]. *)
+(** [stmt_can_reach kf s1 s2] is [true] iff the control flow can reach
+ [s2] starting at [s1] in function [kf]. *)
val stmt_can_reach_filtered : (stmt -> bool) -> stmt -> stmt -> bool
- (** Just like [stmt_can_reach] but uses a function to filter the nodes of the
- graph it operates on.
- Note that the output of the filter function must be functionally dependent
- on its input *)
+(** Just like [stmt_can_reach] but uses a function to filter the nodes of the
+ graph it operates on.
+ Note that the output of the filter function must be functionally dependent
+ on its input *)
val stmt_is_in_cycle : stmt -> bool
- (** [stmt_is_in_cycle s] is [true] iff [s] is reachable through a non trivial path
- * starting at [s]. *)
+(** [stmt_is_in_cycle s] is [true] iff [s] is reachable through a non trivial path
+ * starting at [s]. *)
val stmt_is_in_cycle_filtered : (stmt -> bool) -> stmt -> bool
- (** Just like [stmt_is_in_cycle] but uses a function to filter the nodes of
- the graph it operates on.
- Note that the output of the filter function must be functionally dependent
- on its input *)
+(** Just like [stmt_is_in_cycle] but uses a function to filter the nodes of
+ the graph it operates on.
+ Note that the output of the filter function must be functionally dependent
+ on its input *)
(** [reachable_stmts kf stmt] returns the transitive closure of the successors
of [stmt] in [kf]. The result is cached for later calls.
@@ -71,17 +71,17 @@ val get_stmt_last_stmts : termination_kind option -> stmt -> stmt list
val get_block_last_stmts : termination_kind option -> block -> stmt list
(** Find the entry edges that go inside [s] statements,
-* meaning that if the pair [(s1,s2)] is in the returned information,
-* [s2] is a successor of [s1] and [s2] is in [s] statements, but [s1] is not.
-* @since Nitrogen-20111001
-**)
+ * meaning that if the pair [(s1,s2)] is in the returned information,
+ * [s2] is a successor of [s1] and [s2] is in [s] statements, but [s1] is not.
+ * @since Nitrogen-20111001
+ **)
val get_stmt_in_edges : stmt -> (stmt * stmt) list
val get_block_in_edges : block -> (stmt * stmt) list
(** Like [get_stmt_in_edges] but for edges going out of [s] statements.
-* Similar to [get_all_stmt_last_stmts] but gives the edge information
-* instead of just the first statement.
-* @since Nitrogen-20111001
+ * Similar to [get_all_stmt_last_stmts] but gives the edge information
+ * instead of just the first statement.
+ * @since Nitrogen-20111001
*)
val get_all_stmt_out_edges : stmt -> (stmt * stmt) list
val get_all_block_out_edges : block -> (stmt * stmt) list
@@ -89,9 +89,9 @@ val get_all_block_out_edges : block -> (stmt * stmt) list
(** Split the loop predecessors into:
- the entry point : coming from outside the loop
- the back edges.
- Notice that there might be nothing in the entry point when the loop is the
- first statement.
- @raise Invalid_argument if the statement is not a loop. *)
+ Notice that there might be nothing in the entry point when the loop is the
+ first statement.
+ @raise Invalid_argument if the statement is not a loop. *)
val loop_preds : stmt -> stmt list * stmt list
(*
diff --git a/src/kernel_services/analysis/undefined_sequence.ml b/src/kernel_services/analysis/undefined_sequence.ml
index bb498af5f2bfa4e21bbb46fb6040e80f678ba04f..049492f80f2a0a74e44a9aa8f104e3da2ce55d12 100644
--- a/src/kernel_services/analysis/undefined_sequence.ml
+++ b/src/kernel_services/analysis/undefined_sequence.ml
@@ -32,7 +32,7 @@ let check_sequences file =
| NoOffset,_ | _, NoOffset -> true
| Field (f1,offs1), Field(f2,offs2) ->
(* it's probably a bit overkill to check if any of the field is in
- an union, as the types of offs1 and offs2 are very probably
+ an union, as the types of offs1 and offs2 are very probably
identical, but I don't have a Coq proof of that fact at the moment. *)
(not f1.fcomp.cstruct || not f2.fcomp.cstruct) ||
(f1.fname = f2.fname &&
@@ -116,14 +116,14 @@ let check_sequences file =
let warn,_,_ =
List.fold_left
(fun ((warn,writes,reads) as res) (_,m,w,r,_) ->
- (* the accumulator contains the lists of written
+ (* the accumulator contains the lists of written
and read locations from the previous statements.
We check for overlapping between the following pairs:
- w vs writes
- r vs writes (modulo temporaries m as explained above).
- reads vs w (id. )
- As soon as we have identified a potential overlap, we
- output the whole unspecified sequence.
+ As soon as we have identified a potential overlap, we
+ output the whole unspecified sequence.
*)
if warn then res else begin
let new_writes = w @ writes in
diff --git a/src/kernel_services/analysis/wto_statement.ml b/src/kernel_services/analysis/wto_statement.ml
index 8b0a78f9e921b6db95ef2332c78875785e56dcbc..62c5222e5288b5bb5b33ae20237042f3e1113766 100644
--- a/src/kernel_services/analysis/wto_statement.ml
+++ b/src/kernel_services/analysis/wto_statement.ml
@@ -30,10 +30,10 @@ type wto = stmt Wto.partition
(* ********************************************************************** *)
module Scheduler = Wto.Make
- (struct
- include Cil_datatype.Stmt
- let pretty fmt s = Format.pp_print_int fmt s.sid
- end)
+ (struct
+ include Cil_datatype.Stmt
+ let pretty fmt s = Format.pp_print_int fmt s.sid
+ end)
let build_wto kf =
let init = Kernel_function.find_first_stmt kf
@@ -50,13 +50,13 @@ let build_wto kf =
module WTO =
Datatype.Make
(struct
- include Datatype.Serializable_undefined
- type t = wto
- let name = "Wto_statement.WTO"
- let pretty = Scheduler.pretty_partition
- let copy w = w
- let reprs = [List.map (fun s -> Wto.Node s) Cil_datatype.Stmt.reprs]
- end)
+ include Datatype.Serializable_undefined
+ type t = wto
+ let name = "Wto_statement.WTO"
+ let pretty = Scheduler.pretty_partition
+ let copy w = w
+ let reprs = [List.map (fun s -> Wto.Node s) Cil_datatype.Stmt.reprs]
+ end)
module WTOState =
Kernel_function.Make_Table
@@ -65,7 +65,7 @@ module WTOState =
let size = 97
let name = "Wto_statement.WTOState"
let dependencies = [Ast.self]
- end)
+ end)
(** Returns the wto of a kernel function *)
let wto_of_kf = WTOState.memo build_wto;;
@@ -88,7 +88,7 @@ module WTOIndex =
Pretty_utils.pp_list ~sep:","
(fun fmt stmt -> Format.pp_print_int fmt stmt.sid)
let copy w = w
- end)
+ end)
module StmtTable = Cil_datatype.Stmt.Hashtbl
@@ -99,7 +99,7 @@ module WTOIndexState =
let size = 97
let name = "Wto_statement.WTOIndexState"
let dependencies = [Ast.self]
- end)
+ end)
let build_wto_index_table kf =
let table = StmtTable.create 17 in
@@ -115,7 +115,7 @@ let build_wto_index_table kf =
iter_wto [] (wto_of_kf kf);
table
-let get_wto_index_table =
+let get_wto_index_table =
WTOIndexState.memo build_wto_index_table
let wto_index_of_stmt stmt =
@@ -140,4 +140,3 @@ let wto_index_diff index1 index2 =
let wto_index_diff_of_stmt stmt1 stmt2 =
wto_index_diff (wto_index_of_stmt stmt1) (wto_index_of_stmt stmt2)
-
diff --git a/src/kernel_services/analysis/wto_statement.mli b/src/kernel_services/analysis/wto_statement.mli
index 9893ca9dda9e43b7b60ee48a3fb26d2f13ff2028..289b0767af14c56a9c257c9d136035ea3ac0725c 100644
--- a/src/kernel_services/analysis/wto_statement.mli
+++ b/src/kernel_services/analysis/wto_statement.mli
@@ -35,7 +35,7 @@ module WTO : Datatype.S with type t = wto
val wto_of_kf : kernel_function -> wto
-(** the position of a statement in a wto given as the list of
+(** the position of a statement in a wto given as the list of
component heads *)
type wto_index = stmt list
diff --git a/src/kernel_services/ast_data/annotations.ml b/src/kernel_services/ast_data/annotations.ml
index 90690303633e5645a68168a2d13dcf4a7c9cab9c..1346e1315fa366e2a2f69c0ee95c16669f530f95 100644
--- a/src/kernel_services/ast_data/annotations.ml
+++ b/src/kernel_services/ast_data/annotations.ml
@@ -152,8 +152,8 @@ let () =
Ast.add_linked_state code_annot_state;
Code_annots.add_hook_on_remove
(fun e stmt l ->
- let kf = find_englobing_kf stmt in
- List.iter (fun a -> clear_linked_to_annot kf stmt e a) !l)
+ let kf = find_englobing_kf stmt in
+ List.iter (fun a -> clear_linked_to_annot kf stmt e a) !l)
(**************************************************************************)
(** {2 Getting annotations} *)
@@ -1407,9 +1407,9 @@ let insert_global_in_ast annot =
Cil_datatype.Logic_info.Set.is_empty logic_vars
then List.rev acc @ glob :: g :: l
else begin
- let deps = remove_declared_global c_vars logic_vars g in
- insert_after deps (g :: acc) l
- end
+ let deps = remove_declared_global c_vars logic_vars g in
+ insert_after deps (g :: acc) l
+ end
in
let globs = insert_after deps [] file.globals in
file.globals <- globs
@@ -1614,9 +1614,9 @@ let remove_extended e kf ext =
let set_spec spec _tbl =
List.iter
(fun b ->
- b.b_extended <- Extlib.filter_out ((==) ext) b.b_extended;
- Property_status.remove
- (Property.(ip_of_extended (ELContract kf) ext)))
+ b.b_extended <- Extlib.filter_out ((==) ext) b.b_extended;
+ Property_status.remove
+ (Property.(ip_of_extended (ELContract kf) ext)))
spec.spec_behavior
in
remove_in_funspec e kf set_spec
diff --git a/src/kernel_services/ast_data/annotations.mli b/src/kernel_services/ast_data/annotations.mli
index 007bd100f3cf5b7a1158735f943b6b50aa15800f..e6d833753d3d903000ff216d7254cfd996ece02d 100644
--- a/src/kernel_services/ast_data/annotations.mli
+++ b/src/kernel_services/ast_data/annotations.mli
@@ -21,7 +21,7 @@
(**************************************************************************)
(** Annotations in the AST.
- The AST should be computed before calling functions of this module.
+ The AST should be computed before calling functions of this module.
@modify Oxygen-20120901 fully rewritten.
@plugin development guide *)
@@ -35,22 +35,22 @@ open Cil_types
(** {3 Code annotations} *)
(**************************************************************************)
-val code_annot:
- ?emitter:Emitter.t ->
- ?filter:(code_annotation -> bool) ->
- stmt ->
+val code_annot:
+ ?emitter:Emitter.t ->
+ ?filter:(code_annotation -> bool) ->
+ stmt ->
code_annotation list
(** Get all the code annotations attached to the given statement.
If [emitter] (resp. [filter]) is specified, return only the annotations that
has been generated by this [emitter] (resp. that satisfies the given
predicate). *)
-val code_annot_emitter:
- ?filter:(Emitter.t -> code_annotation -> bool) ->
- stmt ->
+val code_annot_emitter:
+ ?filter:(Emitter.t -> code_annotation -> bool) ->
+ stmt ->
(code_annotation * Emitter.t) list
(** Same as {!code_annot}, but also returns the emitter who emitted the
- annotation.
+ annotation.
@since Fluorine-20130401 *)
(**************************************************************************)
@@ -58,14 +58,14 @@ val code_annot_emitter:
(**************************************************************************)
exception No_funspec of Emitter.t
-val funspec:
+val funspec:
?emitter:Emitter.t -> ?populate:bool -> kernel_function -> funspec
(** Get the contract associated to the given function.
If [emitter] is specified, return only the annotations that
has been generated by this [emitter]. If [populate] is set to [true]
(default is [true]), then the default contract of function declaration is
- generated.
- @raise No_funspec whenever the given function has no specification *)
+ generated.
+ @raise No_funspec whenever the given function has no specification *)
val has_funspec: kernel_function -> bool
(** @return [true] iff the function has a non-empty specification.
@@ -74,33 +74,33 @@ val has_funspec: kernel_function -> bool
val behaviors:
?emitter:Emitter.t -> ?populate:bool -> kernel_function -> funbehavior list
(** Get the behaviors clause of the contract associated to the given function.
- Meaning of [emitter] and [populate] is similar to {!funspec}.
+ Meaning of [emitter] and [populate] is similar to {!funspec}.
@raise No_funspec whenever the given function has no specification *)
val decreases:
?emitter:Emitter.t -> ?populate:bool -> kernel_function -> variant option
(** If any, get the decrease clause of the contract associated to the given
- function. Meaning of [emitter] and [populate] is similar to {!funspec}.
+ function. Meaning of [emitter] and [populate] is similar to {!funspec}.
@raise No_funspec whenever the given function has no specification *)
val terminates:
- ?emitter:Emitter.t -> ?populate:bool -> kernel_function ->
+ ?emitter:Emitter.t -> ?populate:bool -> kernel_function ->
identified_predicate option
(** If any, get the terminates clause of the contract associated to the given
- function. Meaning of [emitter] and [populate] is similar to {!funspec}.
+ function. Meaning of [emitter] and [populate] is similar to {!funspec}.
@raise No_funspec whenever the given function has no specification *)
val complete:
?emitter:Emitter.t -> ?populate:bool -> kernel_function -> string list list
(** Get the complete behaviors clause of the contract associated to the given
- function. Meaning of [emitter] and [populate] is similar to {!funspec}.
+ function. Meaning of [emitter] and [populate] is similar to {!funspec}.
@raise No_funspec whenever the given function has no specification *)
val disjoint:
?emitter:Emitter.t -> ?populate:bool -> kernel_function -> string list list
(** If any, get the disjoint behavior clause of the contract associated to the
given function. Meaning of [emitter] and [populate] is similar to
- {!funspec}.
+ {!funspec}.
@raise No_funspec whenever the given function has no specification *)
(**************************************************************************)
@@ -117,11 +117,11 @@ val model_fields: ?emitter:Emitter.t -> typ -> model_info list
(** {2 Iterating over annotations} *)
(**************************************************************************)
-val iter_code_annot:
+val iter_code_annot:
(Emitter.t -> code_annotation -> unit) -> stmt -> unit
(** Iter on each code annotation attached to the given statement. *)
-val fold_code_annot:
+val fold_code_annot:
(Emitter.t -> code_annotation -> 'a -> 'a) -> stmt -> 'a -> 'a
(** Fold on each code annotation attached to the given statement. *)
@@ -133,7 +133,7 @@ val iter_all_code_annot:
to the location of the statements and by emitter. Note that the
sorted version is less efficient than the unsorted iteration.
@modify Sodium-20150201: iteration is sorted
- *)
+*)
val fold_all_code_annot:
?sorted:bool ->
@@ -141,75 +141,75 @@ val fold_all_code_annot:
(** Fold on each code annotation of the program. See above for
the meaning of the [sorted] argument.
@modify Sodium-20150201 sorted fold
- *)
+*)
-val iter_global:
+val iter_global:
(Emitter.t -> global_annotation -> unit) -> unit
(** Iter on each global annotation of the program. *)
-val fold_global:
+val fold_global:
(Emitter.t -> global_annotation -> 'a -> 'a) -> 'a -> 'a
(** Fold on each global annotation of the program. *)
val iter_requires:
- (Emitter.t -> identified_predicate -> unit) ->
+ (Emitter.t -> identified_predicate -> unit) ->
kernel_function -> string -> unit
- (** Iter on the requires of the corresponding behavior.
- @since Fluorine-20130401 *)
+(** Iter on the requires of the corresponding behavior.
+ @since Fluorine-20130401 *)
val fold_requires:
- (Emitter.t -> identified_predicate -> 'a -> 'a) ->
+ (Emitter.t -> identified_predicate -> 'a -> 'a) ->
kernel_function -> string -> 'a -> 'a
- (** Fold on the requires of the corresponding behavior. *)
+(** Fold on the requires of the corresponding behavior. *)
val iter_assumes:
- (Emitter.t -> identified_predicate -> unit) ->
+ (Emitter.t -> identified_predicate -> unit) ->
kernel_function -> string -> unit
- (** Iter on the assumes of the corresponding behavior.
- @since Fluorine-20130401 *)
+(** Iter on the assumes of the corresponding behavior.
+ @since Fluorine-20130401 *)
val fold_assumes:
- (Emitter.t -> identified_predicate -> 'a -> 'a) ->
+ (Emitter.t -> identified_predicate -> 'a -> 'a) ->
kernel_function -> string -> 'a -> 'a
- (** Fold on the assumes of the corresponding behavior. *)
+(** Fold on the assumes of the corresponding behavior. *)
val iter_ensures:
- (Emitter.t -> (termination_kind * identified_predicate) -> unit) ->
+ (Emitter.t -> (termination_kind * identified_predicate) -> unit) ->
kernel_function -> string -> unit
- (** Iter on the ensures of the corresponding behavior.
- @since Fluorine-20130401 *)
+(** Iter on the ensures of the corresponding behavior.
+ @since Fluorine-20130401 *)
val fold_ensures:
- (Emitter.t -> (termination_kind * identified_predicate) -> 'a -> 'a) ->
+ (Emitter.t -> (termination_kind * identified_predicate) -> 'a -> 'a) ->
kernel_function -> string -> 'a -> 'a
- (** Fold on the ensures of the corresponding behavior. *)
+(** Fold on the ensures of the corresponding behavior. *)
val iter_assigns:
- (Emitter.t -> assigns -> unit) ->
+ (Emitter.t -> assigns -> unit) ->
kernel_function -> string -> unit
- (** Iter on the assigns of the corresponding behavior.
- @since Fluorine-20130401 *)
+(** Iter on the assigns of the corresponding behavior.
+ @since Fluorine-20130401 *)
val fold_assigns:
- (Emitter.t -> assigns -> 'a -> 'a) ->
+ (Emitter.t -> assigns -> 'a -> 'a) ->
kernel_function -> string -> 'a -> 'a
- (** Fold on the assigns of the corresponding behavior. *)
+(** Fold on the assigns of the corresponding behavior. *)
val iter_allocates:
- (Emitter.t -> allocation -> unit) ->
+ (Emitter.t -> allocation -> unit) ->
kernel_function -> string -> unit
- (** Iter on the allocates of the corresponding behavior.
- @since Fluorine-20130401 *)
+(** Iter on the allocates of the corresponding behavior.
+ @since Fluorine-20130401 *)
val fold_allocates:
- (Emitter.t -> allocation -> 'a -> 'a) ->
+ (Emitter.t -> allocation -> 'a -> 'a) ->
kernel_function -> string -> 'a -> 'a
- (** Fold on the allocates of the corresponding behavior. *)
+(** Fold on the allocates of the corresponding behavior. *)
val iter_extended:
(Emitter.t -> acsl_extension -> unit) ->
kernel_function -> string -> unit
- (** @since Sodium-20150201 *)
+(** @since Sodium-20150201 *)
val fold_extended:
(Emitter.t -> acsl_extension -> 'a -> 'a) ->
@@ -217,48 +217,48 @@ val fold_extended:
val iter_behaviors:
(Emitter.t -> funbehavior -> unit) -> kernel_function -> unit
- (** Iter on the behaviors of the given kernel function.
- @since Fluorine-20130401 *)
+(** Iter on the behaviors of the given kernel function.
+ @since Fluorine-20130401 *)
val fold_behaviors:
(Emitter.t -> funbehavior -> 'a -> 'a) -> kernel_function -> 'a -> 'a
- (** Fold on the behaviors of the given kernel function. *)
+(** Fold on the behaviors of the given kernel function. *)
val iter_complete:
(Emitter.t -> string list -> unit) -> kernel_function -> unit
- (** Iter on the complete clauses of the given kernel function.
- @since Fluorine-20130401 *)
+(** Iter on the complete clauses of the given kernel function.
+ @since Fluorine-20130401 *)
val fold_complete:
(Emitter.t -> string list -> 'a -> 'a) -> kernel_function -> 'a -> 'a
- (** Fold on the complete clauses of the given kernel function. *)
+(** Fold on the complete clauses of the given kernel function. *)
val iter_disjoint:
(Emitter.t -> string list -> unit) -> kernel_function -> unit
- (** Iter on the disjoint clauses of the given kernel function.
- @since Fluorine-20130401 *)
+(** Iter on the disjoint clauses of the given kernel function.
+ @since Fluorine-20130401 *)
val fold_disjoint:
(Emitter.t -> string list -> 'a -> 'a) -> kernel_function -> 'a -> 'a
- (** Fold on the disjoint clauses of the given kernel function. *)
+(** Fold on the disjoint clauses of the given kernel function. *)
val iter_terminates:
(Emitter.t -> identified_predicate -> unit) -> kernel_function -> unit
- (** apply f to the terminates predicate if any.
- @since Fluorine-20130401 *)
+(** apply f to the terminates predicate if any.
+ @since Fluorine-20130401 *)
val fold_terminates:
(Emitter.t -> identified_predicate -> 'a -> 'a) -> kernel_function -> 'a -> 'a
- (** apply f to the terminates predicate if any. *)
+(** apply f to the terminates predicate if any. *)
val iter_decreases:
(Emitter.t -> variant -> unit) -> kernel_function -> unit
- (** apply f to the decreases term if any.
- @since Fluorine-20130401 *)
+(** apply f to the decreases term if any.
+ @since Fluorine-20130401 *)
val fold_decreases:
(Emitter.t -> variant -> 'a -> 'a) -> kernel_function -> 'a -> 'a
- (** apply f to the decreases term if any. *)
+(** apply f to the decreases term if any. *)
(**************************************************************************)
(** {2 Adding annotations} *)
@@ -285,12 +285,12 @@ val add_code_annot:
Attempting to register a second one will result in a fatal error.
@modify 22.0-Titanium: add keep_empty argument
- *)
+*)
val add_assert:
Emitter.t -> ?kf:kernel_function -> stmt -> predicate -> unit
(** Add an assertion attached to the given statement. If [kf] is
- provided, the function runs faster.
+ provided, the function runs faster.
@plugin development guide *)
val add_check:
@@ -310,7 +310,7 @@ val add_global: Emitter.t -> global_annotation -> unit
type 'a contract_component_addition =
Emitter.t ->
- kernel_function -> ?stmt:stmt -> ?active:string list -> 'a -> unit
+ kernel_function -> ?stmt:stmt -> ?active:string list -> 'a -> unit
(** type for functions adding a part of a contract (either for global function
or for a given [stmt]). In the latter case [active] may be used to state the
list of enclosing behavior(s) for which the contract is supposed to hold.
@@ -318,18 +318,18 @@ type 'a contract_component_addition =
always hold.
@since Aluminium-20160501
- *)
+*)
type 'a behavior_component_addition =
Emitter.t ->
- kernel_function -> ?stmt:stmt -> ?active:string list ->
- ?behavior:string -> 'a -> unit
+ kernel_function -> ?stmt:stmt -> ?active:string list ->
+ ?behavior:string -> 'a -> unit
(** type for functions adding a part of a [behavior] inside a contract. The
contract is found in a similar way as for {!contract_component_addition}
functions. Similarly, [active] has the same meaning as for
{!contract_component_addition}.
- Default for [behavior] is {!Cil.default_behavior_name}.
+ Default for [behavior] is {!Cil.default_behavior_name}.
@since Aluminium-20160501
*)
@@ -344,7 +344,7 @@ val add_spec: ?register_children:bool -> spec contract_component_addition
val add_behaviors:
?register_children:bool -> funbehavior list contract_component_addition
-(** Add new behaviors into the given contract.
+(** Add new behaviors into the given contract.
if [register_children] is [true] (the default), inner clauses of the
behavior will also be registered by the function.
@@ -352,15 +352,15 @@ val add_behaviors:
*)
val add_decreases: Emitter.t -> kernel_function -> variant -> unit
-(** Add a decrease clause into the contract of the given function.
- No decrease clause must previously be attached to this function.
+(** Add a decrease clause into the contract of the given function.
+ No decrease clause must previously be attached to this function.
@modify Aluminium-20160501 restructuration of annotations management
*)
val add_terminates: identified_predicate contract_component_addition
-(** Add a terminates clause into a contract.
- No terminates clause must previously be attached to this contract.
+(** Add a terminates clause into a contract.
+ No terminates clause must previously be attached to this contract.
@modify Aluminium-20160501 restructuration of annotations management
*)
@@ -374,7 +374,7 @@ val add_complete: string list contract_component_addition
is either an unknown behavior or {!Cil.default_behavior_name}.
@modify Aluminium-20160501 restructuration of annotations management
- *)
+*)
val add_disjoint: string list contract_component_addition
(** Add a new disjoint behaviors clause into the contract of the given
@@ -385,26 +385,26 @@ val add_disjoint: string list contract_component_addition
is either an unknown behavior or {!Cil.default_behavior_name}.
@modify Aluminium-20160501 restructuration of annotations management
- *)
+*)
val add_requires: identified_predicate list behavior_component_addition
-(** Add new requires clauses into the given behavior.
+(** Add new requires clauses into the given behavior.
@modify Aluminium-20160501 restructuration of annotations management
*)
val add_assumes: identified_predicate list behavior_component_addition
(** Add new assumes clauses into the given behavior.
-
+
Does nothing but emitting a warning if an attempt is
made to add assumes clauses to the default behavior.
@modify Aluminium-20160501 restructuration of annotations management
- *)
+*)
val add_ensures:
(termination_kind * identified_predicate) list behavior_component_addition
-(** Add new ensures clauses into the given behavior.
+(** Add new ensures clauses into the given behavior.
@modify Aluminium-20160501 restructuration of annotations management
*)
@@ -416,7 +416,7 @@ val add_assigns:
If [keep_empty] is [true] and the assigns clause were empty, then
the assigns clause remains empty. (That corresponds to the ACSL semantics of
an assigns clause: if no assigns is specified, that is equivalent to assigns
- everything.)
+ everything.)
@modify Aluminium-20160501 restructuration of annotations management
*)
@@ -426,7 +426,7 @@ val add_allocates:
(** Add new allocates into the given behavior.
See {!Annotations.add_assigns} for the signification of [keep_empty]
@modify 22.0-Titanium add keep_empty argument
- *)
+*)
val add_extended: acsl_extension behavior_component_addition
(** @since Sodium-20150201 *)
@@ -435,11 +435,11 @@ val add_extended: acsl_extension behavior_component_addition
(** {2 Removing annotations} *)
(**************************************************************************)
-val remove_code_annot:
+val remove_code_annot:
Emitter.t -> ?kf:kernel_function -> stmt -> code_annotation -> unit
(** Remove a code annotation attached to a statement. The provided emitter must
- be the one that emits this annotation. Do nothing if the annotation does not
- exist, or if the emitter is not ok. *)
+ be the one that emits this annotation. Do nothing if the annotation does not
+ exist, or if the emitter is not ok. *)
val remove_global: Emitter.t -> global_annotation -> unit
(** Remove a global annotation. The provided emitter must be the one that emits
@@ -448,7 +448,7 @@ val remove_global: Emitter.t -> global_annotation -> unit
logic functions/predicates declared in the given annotation are not used
elsewhere.
*)
-
+
val remove_behavior:
?force:bool -> Emitter.t -> kernel_function -> funbehavior -> unit
(** Remove a behavior attached to a function. The provided emitter must be the
@@ -458,12 +458,12 @@ val remove_behavior:
complete/disjoint clause. If [force] is [true], it is the responsibility
of the user to ensure that complete/disjoint clauses refer to existing
behaviors.
- *)
+*)
val remove_behavior_components:
Emitter.t -> kernel_function -> funbehavior -> unit
- (** remove all the component of a behavior, but keeps the name (so as to
- avoid issues with disjoint/complete clauses). *)
+(** remove all the component of a behavior, but keeps the name (so as to
+ avoid issues with disjoint/complete clauses). *)
val remove_decreases: Emitter.t -> kernel_function -> unit
(** Remove the decreases clause attached to a function. The provided emitter
@@ -485,34 +485,34 @@ val remove_disjoint: Emitter.t -> kernel_function -> string list -> unit
emitter must be the one that emits this annotation. Do nothing if the
annotation does not exist, or if the emitter is not ok. *)
-val remove_requires:
+val remove_requires:
Emitter.t -> kernel_function -> identified_predicate -> unit
- (** Remove a requires clause from the spec of the given function. Do nothing
- if the predicate does not exist or
- was not emitted by the given emitter. *)
+(** Remove a requires clause from the spec of the given function. Do nothing
+ if the predicate does not exist or
+ was not emitted by the given emitter. *)
-val remove_assumes:
+val remove_assumes:
Emitter.t -> kernel_function -> identified_predicate -> unit
- (** Remove an assumes clause from the spec of the given function. Do nothing
- if the predicate does not exist or was not emitted
- by the given emitter. *)
+(** Remove an assumes clause from the spec of the given function. Do nothing
+ if the predicate does not exist or was not emitted
+ by the given emitter. *)
val remove_ensures:
Emitter.t -> kernel_function ->
(termination_kind * identified_predicate) -> unit
- (** Remove a post-condition from the spec of the given function. Do nothing
- if the post-cond does not exist or was not emitted
- by the given emitter. *)
+(** Remove a post-condition from the spec of the given function. Do nothing
+ if the post-cond does not exist or was not emitted
+ by the given emitter. *)
val remove_allocates:
Emitter.t -> kernel_function -> allocation -> unit
- (** Remove the corresponding allocation clause. Do nothing if the clause
- does not exist or was not emitted by the given emitter. *)
+(** Remove the corresponding allocation clause. Do nothing if the clause
+ does not exist or was not emitted by the given emitter. *)
val remove_assigns:
Emitter.t -> kernel_function -> assigns -> unit
- (** Remove the corresponding assigns clause. Do nothing if the clause
- does not exist or was not emitted by the given emitter. *)
+(** Remove the corresponding assigns clause. Do nothing if the clause
+ does not exist or was not emitted by the given emitter. *)
val remove_extended: Emitter.t -> kernel_function -> acsl_extension -> unit
(** @since Sodium-20150201 *)
@@ -529,7 +529,7 @@ val emitter_of_code_annot: code_annotation -> stmt -> Emitter.t
(** @return the emitter which generated the given code_annotation,
assumed to be registered at the given statement.
@raise Not_found if the code annotation does not exist, or if it is
- registered at another statement.
+ registered at another statement.
@since Magnesium-20151001
*)
@@ -575,9 +575,9 @@ val global_state: State.t
val populate_spec_ref: (kernel_function -> funspec -> bool) ref
val unsafe_add_global: Emitter.t -> global_annotation -> unit
-val register_funspec:
+val register_funspec:
?emitter:Emitter.t -> ?force:bool -> kernel_function -> unit
-val remove_alarm_ref:
+val remove_alarm_ref:
(Emitter.Usable_emitter.t -> stmt -> code_annotation -> unit) ref
(*
diff --git a/src/kernel_services/ast_data/ast.ml b/src/kernel_services/ast_data/ast.ml
index c56f5472689fc986e096c9bb644e84e500ee0890..5aa9b619cb9f84dc9e19c859ebf3c6212c41b600 100644
--- a/src/kernel_services/ast_data/ast.ml
+++ b/src/kernel_services/ast_data/ast.ml
@@ -28,25 +28,25 @@ include
State_builder.Option_ref
(Cil_datatype.File)
(struct
- let name = "AST"
-
- let dependencies =
- [ Cil.selfMachine;
- Kernel.SimplifyCfg.self;
- Kernel.KeepSwitch.self;
- Kernel.Constfold.self;
- Kernel.ReadAnnot.self;
- Kernel.PreprocessAnnot.self;
- Kernel.Files.self;
- Kernel.UnrollingLevel.self;
- Kernel.Keep_unused_specified_functions.self;
- Kernel.Keep_unused_types.self;
- Cil.selfFormalsDecl ]
- end)
+ let name = "AST"
+
+ let dependencies =
+ [ Cil.selfMachine;
+ Kernel.SimplifyCfg.self;
+ Kernel.KeepSwitch.self;
+ Kernel.Constfold.self;
+ Kernel.ReadAnnot.self;
+ Kernel.PreprocessAnnot.self;
+ Kernel.Files.self;
+ Kernel.UnrollingLevel.self;
+ Kernel.Keep_unused_specified_functions.self;
+ Kernel.Keep_unused_types.self;
+ Cil.selfFormalsDecl ]
+ end)
let mark_as_computed () = mark_as_computed () (* eta-expansion required *)
-let linked_states =
+let linked_states =
ref
[ Logic_env.Logic_info.self;
Logic_env.Logic_type_info.self;
@@ -100,7 +100,7 @@ let set_default_initialization f = default_initialization := f
module Computing =
State_builder.False_ref(
- struct let name = "Ast.computing" let dependencies = [] end)
+ struct let name = "Ast.computing" let dependencies = [] end)
let force_compute () =
if Computing.get () then
@@ -142,13 +142,13 @@ module UntypedFiles = struct
else raise NoUntypedAst
include State_builder.Option_ref
- (Initial_datatype.List(Cil_datatype.Cabs_file))
- (struct
- let name = "Untyped AST"
- let dependencies = (* the others delayed until file.ml *)
- [ Cil.selfMachine;
- self (* can't be computed without the AST *) ]
- end)
+ (Initial_datatype.List(Cil_datatype.Cabs_file))
+ (struct
+ let name = "Untyped AST"
+ let dependencies = (* the others delayed until file.ml *)
+ [ Cil.selfMachine;
+ self (* can't be computed without the AST *) ]
+ end)
let get () = memo (fun () -> compute_untyped (); get ())
@@ -162,7 +162,7 @@ module LastDecl =
let name = "Ast.LastDecl"
let dependencies = [ self ]
let size = 47
- end)
+ end)
let compute_last_def_decl () =
(* Only meaningful when we have definitely computed the AST. *)
@@ -170,9 +170,9 @@ let compute_last_def_decl () =
let globs = (get ()).globals in
let update_one_global g =
match g with
- | GVarDecl(v,_) | GFunDecl(_,v,_) | GVar (v,_,_) | GFun ({svar=v},_) ->
- LastDecl.replace v g
- | _ -> ()
+ | GVarDecl(v,_) | GFunDecl(_,v,_) | GVar (v,_,_) | GFun ({svar=v},_) ->
+ LastDecl.replace v g
+ | _ -> ()
in
List.iter update_one_global globs;
LastDecl.mark_as_computed ()
@@ -203,9 +203,9 @@ let is_def_or_last_decl g =
false
in
match g with
- | GVarDecl(v,_) | GFunDecl (_,v,_) -> is_eq v
- | GVar _ | GFun _ -> true
- | _ -> false
+ | GVarDecl(v,_) | GFunDecl (_,v,_) -> is_eq v
+ | GVar _ | GFun _ -> true
+ | _ -> false
let clear_last_decl () =
let selection = State_selection.Static.with_dependencies LastDecl.self in
diff --git a/src/kernel_services/ast_data/ast.mli b/src/kernel_services/ast_data/ast.mli
index fcb527b68cc1a6865571ebb281260057a0aa8aca..67887245e8041136efa4137b2fe75278d3995b43 100644
--- a/src/kernel_services/ast_data/ast.mli
+++ b/src/kernel_services/ast_data/ast.mli
@@ -23,64 +23,64 @@
(** Access to the CIL AST which must be used from Frama-C. *)
exception Bad_Initialization of string
- (** May be raised by function {!get} below. *)
+(** May be raised by function {!get} below. *)
exception NoUntypedAst
- (** Might be raised by {!UntypedFiles.get} below
- @since Nitrogen-20111001
- *)
+(** Might be raised by {!UntypedFiles.get} below
+ @since Nitrogen-20111001
+*)
module UntypedFiles: sig
val get: unit -> Cabs.file list
- (** The list of untyped AST that have been parsed.
- @raise Bad_Initialization if neither {!File.init_from_c_files}
- nor {!File.init_project_from_cil_file} nor {!File.init_from_cmdline}
- was called before.
- @raise NoUntypedAst if no untyped AST is available. This is in
- particular the case for projects obtained by code transformation from
- original C files.
- @modify Nitrogen-20111001 raise NoUntypedAst
- *)
+ (** The list of untyped AST that have been parsed.
+ @raise Bad_Initialization if neither {!File.init_from_c_files}
+ nor {!File.init_project_from_cil_file} nor {!File.init_from_cmdline}
+ was called before.
+ @raise NoUntypedAst if no untyped AST is available. This is in
+ particular the case for projects obtained by code transformation from
+ original C files.
+ @modify Nitrogen-20111001 raise NoUntypedAst
+ *)
val set: Cabs.file list -> unit
- (** Should not be used by casual users. *)
+ (** Should not be used by casual users. *)
val self: State.t
end
val get: unit -> Cil_types.file
- (** Get the cil file representation.
- One of the initialization function of module {!File} has to be called
- before using this function.
- @raise Bad_Initialization if neither {!File.init_from_c_files}
- nor {!File.init_project_from_cil_file} nor {!File.init_from_cmdline} was
- called before.
- @plugin development guide *)
+(** Get the cil file representation.
+ One of the initialization function of module {!File} has to be called
+ before using this function.
+ @raise Bad_Initialization if neither {!File.init_from_c_files}
+ nor {!File.init_project_from_cil_file} nor {!File.init_from_cmdline} was
+ called before.
+ @plugin development guide *)
val compute: unit -> unit
- (** Enforce the computation of the AST.
- @raise Bad_Initialization if neither {!File.init_from_c_files}
- nor {!File.init_project_from_cil_file} nor {!File.init_from_cmdline} was
- called before. *)
+(** Enforce the computation of the AST.
+ @raise Bad_Initialization if neither {!File.init_from_c_files}
+ nor {!File.init_project_from_cil_file} nor {!File.init_from_cmdline} was
+ called before. *)
val is_computed: unit -> bool
- (** @return true if the AST has been computed. *)
+(** @return true if the AST has been computed. *)
val mark_as_changed: unit -> unit
- (** call this function whenever you've made some changes in place
- inside the AST
- @since Oxygen-20120901
- @plugin development guide
- *)
+(** call this function whenever you've made some changes in place
+ inside the AST
+ @since Oxygen-20120901
+ @plugin development guide
+*)
val mark_as_grown: unit -> unit
- (** call this function whenever you have added something to the AST,
- without modifying the existing nodes
- @since Oxygen-20120901
- @plugin development guide
- *)
+(** call this function whenever you have added something to the AST,
+ without modifying the existing nodes
+ @since Oxygen-20120901
+ @plugin development guide
+*)
val add_monotonic_state: State.t -> unit
(** indicates that the given state (which must depend on Ast.self) is robust
@@ -90,14 +90,14 @@ val add_monotonic_state: State.t -> unit
itself will.
@since Oxygen-20120901
@plugin development guide
- *)
+*)
val self: State.t
- (** The state kind associated to the cil AST.
- @plugin development guide *)
+(** The state kind associated to the cil AST.
+ @plugin development guide *)
val apply_after_computed: (Cil_types.file -> unit) -> unit
-(** Apply the given hook just after building the AST.
+(** Apply the given hook just after building the AST.
@since Oxygen-20120901 *)
@@ -108,33 +108,33 @@ val apply_after_computed: (Cil_types.file -> unit) -> unit
(*****************************************************************************)
val is_def_or_last_decl: Cil_types.global -> bool
- (** [true] if the global is the last one in the AST to introduce a given
- variable. Used by visitor and printer to relate funspec with appropriate
- global, and the GUI to remove redundant declarations of globals.
+(** [true] if the global is the last one in the AST to introduce a given
+ variable. Used by visitor and printer to relate funspec with appropriate
+ global, and the GUI to remove redundant declarations of globals.
- Complexity: O(nb of globals) for the first call, then O(1).
+ Complexity: O(nb of globals) for the first call, then O(1).
- @since Oxygen-20120901
- *)
+ @since Oxygen-20120901
+*)
val def_or_last_decl: Cil_types.varinfo -> Cil_types.global
- (** [def_or_last_decl v] returns the global [g] declaring or defining
- [g] such that [is_def_or_last_decl g] is true.
+(** [def_or_last_decl v] returns the global [g] declaring or defining
+ [g] such that [is_def_or_last_decl g] is true.
- [v] must be a global variable declared in the AST.
+ [v] must be a global variable declared in the AST.
- @since Aluminium-20160501
- *)
+ @since Aluminium-20160501
+*)
val clear_last_decl : unit -> unit
- (** reset the mapping between a varinfo and the last global introducing it.
- @since Oxygen-20120901
- *)
+(** reset the mapping between a varinfo and the last global introducing it.
+ @since Oxygen-20120901
+*)
val set_file: Cil_types.file -> unit
val set_default_initialization: (unit -> unit) -> unit
val mark_as_computed: unit -> unit
- (** @since Beryllium-20090901 *)
+(** @since Beryllium-20090901 *)
val add_hook_on_update: (unit -> unit) -> unit
(** Apply the given hook each time the reference to the AST is updated,
diff --git a/src/kernel_services/ast_data/kernel_function.ml b/src/kernel_services/ast_data/kernel_function.ml
index 96dba0c015c3be70a3fcdea052b91091dd2e7e96..ad0e151a01e4452bb4f95dec1795dd89c582a436 100644
--- a/src/kernel_services/ast_data/kernel_function.ml
+++ b/src/kernel_services/ast_data/kernel_function.ml
@@ -117,9 +117,9 @@ module Kf =
State_builder.Option_ref
(Datatype.Int.Hashtbl.Make(Datatype.Triple(Kf)(Stmt)(Datatype.List(Block))))
(struct
- let name = "Kernel_function.Kf"
- let dependencies = [ Ast.self ]
- end)
+ let name = "Kernel_function.Kf"
+ let dependencies = [ Ast.self ]
+ end)
let self = Kf.self
@@ -139,22 +139,22 @@ let compute () =
opened_blocks <- b :: opened_blocks;
Cil.ChangeDoChildrenPost
(b,fun b -> opened_blocks <- List.tl opened_blocks; b)
- method! vstmt s =
- Datatype.Int.Hashtbl.add h s.sid (self#kf, s, opened_blocks);
- Cil.DoChildren
- method! vglob g =
- begin match g with
- | GFun (fd, _) ->
- (try
+ method! vstmt s =
+ Datatype.Int.Hashtbl.add h s.sid (self#kf, s, opened_blocks);
+ Cil.DoChildren
+ method! vglob g =
+ begin match g with
+ | GFun (fd, _) ->
+ (try
let kf = Globals.Functions.get fd.svar in
- current_kf <- Some kf;
+ current_kf <- Some kf;
with Not_found ->
Kernel.fatal "No kernel function for function %a"
Cil_datatype.Varinfo.pretty fd.svar)
- | _ ->
- ()
- end;
- Cil.DoChildren
+ | _ ->
+ ()
+ end;
+ Cil.DoChildren
end
in
Cil.visitCilFile (visitor :> Cil.cilVisitor) p;
@@ -212,7 +212,7 @@ let find_enclosing_block s =
let () = Globals.find_enclosing_block:= find_enclosing_block
let find_all_enclosing_blocks s =
- let table = compute () in
+ let table = compute () in
let (_,_,b) = Datatype.Int.Hashtbl.find table s.sid in b
let find_stmt_in_block b s =
@@ -312,13 +312,13 @@ let stmt_in_loop kf stmt =
val is_in_loop = Stack.create ()
method! vstmt s =
match s.skind with
- | Loop _ ->
- Stack.push true is_in_loop;
- if Cil_datatype.Stmt.equal s stmt then raise (Res.Found true);
- Cil.DoChildrenPost (fun s -> ignore (Stack.pop is_in_loop); s)
- | _ when Cil_datatype.Stmt.equal s stmt ->
- raise (Res.Found (Stack.top is_in_loop))
- | _ -> Cil.DoChildren
+ | Loop _ ->
+ Stack.push true is_in_loop;
+ if Cil_datatype.Stmt.equal s stmt then raise (Res.Found true);
+ Cil.DoChildrenPost (fun s -> ignore (Stack.pop is_in_loop); s)
+ | _ when Cil_datatype.Stmt.equal s stmt ->
+ raise (Res.Found (Stack.top is_in_loop))
+ | _ -> Cil.DoChildren
initializer Stack.push false is_in_loop
end
in
@@ -327,8 +327,8 @@ let stmt_in_loop kf stmt =
(Cil.visitCilFunction vis (get_definition kf));
false
with
- | Res.Found f -> f
- | No_Definition -> false (* Not the good kf obviously. *)
+ | Res.Found f -> f
+ | No_Definition -> false (* Not the good kf obviously. *)
let find_enclosing_loop kf stmt =
let module Res = struct exception Found of Cil_types.stmt end in
@@ -337,25 +337,25 @@ let find_enclosing_loop kf stmt =
val loops = Stack.create ()
method! vstmt s =
match s.skind with
- | Loop _ ->
- Stack.push s loops;
- Cil.DoChildrenPost (fun s -> ignore (Stack.pop loops); s)
- | _ when Cil_datatype.Stmt.equal s stmt ->
- raise (Res.Found (Stack.top loops))
- | _ -> Cil.DoChildren
+ | Loop _ ->
+ Stack.push s loops;
+ Cil.DoChildrenPost (fun s -> ignore (Stack.pop loops); s)
+ | _ when Cil_datatype.Stmt.equal s stmt ->
+ raise (Res.Found (Stack.top loops))
+ | _ -> Cil.DoChildren
end
in
try
(match stmt.skind with
- | Loop _ -> stmt
- | _ ->
- ignore
- (Cil.visitCilFunction vis (get_definition kf));
- raise Not_found)
+ | Loop _ -> stmt
+ | _ ->
+ ignore
+ (Cil.visitCilFunction vis (get_definition kf));
+ raise Not_found)
with
- | No_Definition -> raise Not_found (* Not the good kf obviously. *)
- | Stack.Empty -> raise Not_found (* statement outside of a loop *)
- | Res.Found s -> s
+ | No_Definition -> raise Not_found (* Not the good kf obviously. *)
+ | Stack.Empty -> raise Not_found (* statement outside of a loop *)
+ | Res.Found s -> s
exception Got_return of stmt
exception No_Statement
@@ -447,8 +447,8 @@ let find_label kf label =
let get_called fct = match fct.enode with
| Lval (Var vkf, NoOffset) ->
- (try Some (Globals.Functions.get vkf)
- with Not_found -> None)
+ (try Some (Globals.Functions.get vkf)
+ with Not_found -> None)
| _ -> None
(* ************************************************************************* *)
@@ -462,13 +462,13 @@ module KfCallers =
(struct
let name = "Kernel_function.KfCallers"
let dependencies = [ Ast.self ]
- end)
+ end)
let called_kernel_function fct =
match fct.enode with
- | Lval (Var vinfo,NoOffset) ->
- (try Some(Globals.Functions.get vinfo) with Not_found -> None)
- | _ -> None
+ | Lval (Var vinfo,NoOffset) ->
+ (try Some(Globals.Functions.get vinfo) with Not_found -> None)
+ | _ -> None
class callsite_visitor hmap = object (self)
inherit Cil.nopCilVisitor
@@ -478,8 +478,8 @@ class callsite_visitor hmap = object (self)
(* Go into functions *)
method! vglob = function
| GFun(fd,_) ->
- current_kf <- Some(Globals.Functions.get fd.svar) ;
- Cil.DoChildren
+ current_kf <- Some(Globals.Functions.get fd.svar) ;
+ Cil.DoChildren
| _ -> Cil.SkipChildren
(* Inspect stmt calls *)
@@ -489,12 +489,12 @@ class callsite_visitor hmap = object (self)
CallSites.replace hmap callee ((self#kf,stmt)::sites)
in
match stmt.skind with
- | Instr(Call(_,fct,_,_)) ->
- Option.iter add_call (called_kernel_function fct); Cil.SkipChildren
- | Instr (Local_init (_, ConsInit(f,_,_),_)) ->
- add_call (Globals.Functions.get f); Cil.SkipChildren
- | Instr _ -> Cil.SkipChildren
- | _ -> Cil.DoChildren
+ | Instr(Call(_,fct,_,_)) ->
+ Option.iter add_call (called_kernel_function fct); Cil.SkipChildren
+ | Instr (Local_init (_, ConsInit(f,_,_),_)) ->
+ add_call (Globals.Functions.get f); Cil.SkipChildren
+ | Instr _ -> Cil.SkipChildren
+ | _ -> Cil.DoChildren
(* Skip many other things ... *)
method! vexpr _ = Cil.SkipChildren
@@ -600,8 +600,8 @@ let get_formal_position v kf =
Extlib.find_index (fun vv -> v.vid = vv.vid) (get_formals kf)
let is_local v kf = match kf.fundec with
- | Definition(fd, _) -> Ast_info.Function.is_local v fd
- | Declaration _ -> false
+ | Definition(fd, _) -> Ast_info.Function.is_local v fd
+ | Declaration _ -> false
let is_formal_or_local v kf =
(not v.vglob) && (is_formal v kf || is_local v kf)
@@ -614,9 +614,9 @@ module Make_Table = State_builder.Hashtbl(Cil_datatype.Kf.Hashtbl)
module Hptset = struct
include Hptset.Make
- (Cil_datatype.Kf)
- (struct let v = [ [ ] ] end)
- (struct let l = [ Ast.self ] end)
+ (Cil_datatype.Kf)
+ (struct let v = [ [ ] ] end)
+ (struct let l = [ Ast.self ] end)
let () = Ast.add_monotonic_state self
let () = Ast.add_hook_on_update clear_caches
end
@@ -640,33 +640,33 @@ module Get_global =
let name = "Kernel_function.get_global"
let size = 8
let dependencies = [ Globals.Functions.self ]
- end)
+ end)
let compute_get_global () =
Cil.iterGlobals
(Ast.get ())
(function
- | GFun({ svar = vi }, _) | GFunDecl(_, vi, _) as g
- when Ast.is_def_or_last_decl g ->
- let kf =
- try Globals.Functions.get vi
- with Not_found ->
- Kernel.fatal
- "[Kernel_function.compute_get_global] unknown function %a"
- Cil_datatype.Varinfo.pretty vi
- in
- Get_global.replace kf g
- | _ -> ())
+ | GFun({ svar = vi }, _) | GFunDecl(_, vi, _) as g
+ when Ast.is_def_or_last_decl g ->
+ let kf =
+ try Globals.Functions.get vi
+ with Not_found ->
+ Kernel.fatal
+ "[Kernel_function.compute_get_global] unknown function %a"
+ Cil_datatype.Varinfo.pretty vi
+ in
+ Get_global.replace kf g
+ | _ -> ())
let get_global =
Get_global.memo
(fun kf ->
- compute_get_global ();
- try Get_global.find kf
- with Not_found ->
- Kernel.fatal
- "[Kernel_function.get_global] unknown function %a"
- pretty kf)
+ compute_get_global ();
+ try Get_global.find kf
+ with Not_found ->
+ Kernel.fatal
+ "[Kernel_function.get_global] unknown function %a"
+ pretty kf)
(*
Local Variables:
diff --git a/src/kernel_services/ast_data/kernel_function.mli b/src/kernel_services/ast_data/kernel_function.mli
index 5f1adcaf860d3cb16ed02c8faed226990cbf81f6..343664261bf4492e901de86280f3f8a772c0a4ab 100644
--- a/src/kernel_services/ast_data/kernel_function.mli
+++ b/src/kernel_services/ast_data/kernel_function.mli
@@ -34,9 +34,9 @@ open Cil_types
(* ************************************************************************* *)
include Datatype.S_with_collections with type t = kernel_function
- and module Set = Cil_datatype.Kf.Set
- and module Map = Cil_datatype.Kf.Map
- and module Hashtbl = Cil_datatype.Kf.Hashtbl
+ and module Set = Cil_datatype.Kf.Set
+ and module Map = Cil_datatype.Kf.Map
+ and module Hashtbl = Cil_datatype.Kf.Hashtbl
val id: t -> int
val auxiliary_kf_stmt_state: State.t
@@ -47,30 +47,30 @@ val auxiliary_kf_stmt_state: State.t
exception No_Statement
val find_first_stmt : t -> stmt
- (** Find the first statement in a kernel function.
- @raise No_Statement if there is no first statement for the given
- function. *)
+(** Find the first statement in a kernel function.
+ @raise No_Statement if there is no first statement for the given
+ function. *)
val find_return : t -> stmt
- (** Find the return statement of a kernel function.
- @raise No_Statement is the kernel function is only a prototype.
- @modify Nitrogen-20111001 may raise No_Statement*)
+(** Find the return statement of a kernel function.
+ @raise No_Statement is the kernel function is only a prototype.
+ @modify Nitrogen-20111001 may raise No_Statement*)
val find_label : t -> string -> stmt ref
- (** Find a given label in a kernel function.
- @raise Not_found if the label does not exist in the given function. *)
+(** Find a given label in a kernel function.
+ @raise Not_found if the label does not exist in the given function. *)
val find_all_labels: t -> Datatype.String.Set.t
- (** returns all labels present in a given function.
- @since Chlorine-20180501
- *)
+(** returns all labels present in a given function.
+ @since Chlorine-20180501
+*)
val clear_sid_info: unit -> unit
(** removes any information related to statements in kernel functions.
({i.e.} the table used by the function below).
- Must be called when the Ast has silently changed
- (e.g. with an in-place visitor) before calling one of
- the functions below
+ (e.g. with an in-place visitor) before calling one of
+ the functions below
- Use with caution, as it is very expensive to re-populate the table. *)
val find_defining_kf: varinfo -> t option
@@ -79,34 +79,34 @@ val find_defining_kf: varinfo -> t option
@since Chlorine-20180501 *)
val find_from_sid : int -> stmt * t
- (** @return the stmt and its kernel function from its identifier.
- Complexity: the first call to this function is linear in the size of
- the cil file.
- @raise Not_found if there is no statement with such an identifier. *)
+(** @return the stmt and its kernel function from its identifier.
+ Complexity: the first call to this function is linear in the size of
+ the cil file.
+ @raise Not_found if there is no statement with such an identifier. *)
val find_englobing_kf : stmt -> t
- (** @return the function to which the statement belongs. Same
- complexity as [find_from_sid]
- @raise Not_found if the given statement is not correctly registered *)
+(** @return the function to which the statement belongs. Same
+ complexity as [find_from_sid]
+ @raise Not_found if the given statement is not correctly registered *)
val find_enclosing_block: stmt -> block
- (** @return the innermost block to which the given statement belongs. *)
+(** @return the innermost block to which the given statement belongs. *)
val find_all_enclosing_blocks: stmt -> block list
- (** same as above, but returns all enclosing blocks, starting with the
- innermost one. *)
+(** same as above, but returns all enclosing blocks, starting with the
+ innermost one. *)
val blocks_closed_by_edge: stmt -> stmt -> block list
- (** [blocks_closed_by_edge s1 s2] returns the (possibly empty)
- list of blocks that are closed when going from [s1] to [s2].
- @raise Invalid_argument if [s2] is not a successor of [s1] in the cfg.
- @since Carbon-20101201 *)
+(** [blocks_closed_by_edge s1 s2] returns the (possibly empty)
+ list of blocks that are closed when going from [s1] to [s2].
+ @raise Invalid_argument if [s2] is not a successor of [s1] in the cfg.
+ @since Carbon-20101201 *)
val blocks_opened_by_edge: stmt -> stmt -> block list
- (** [blocks_opened_by_edge s1 s2] returns the (possibly empty)
- list of blocks that are opened when going from [s1] to [s2].
- @raise Invalid_argument if [s2] is not a successor of [s1] in the cfg.
- @since Magnesium-20151001 *)
+(** [blocks_opened_by_edge s1 s2] returns the (possibly empty)
+ list of blocks that are opened when going from [s1] to [s2].
+ @raise Invalid_argument if [s2] is not a successor of [s1] in the cfg.
+ @since Magnesium-20151001 *)
val common_block: stmt -> stmt -> block
(** [common_block s1 s2] returns the innermost block that contains
@@ -117,23 +117,23 @@ val common_block: stmt -> stmt -> block
*)
val stmt_in_loop: t -> stmt -> bool
- (** [stmt_in_loop kf stmt] is [true] iff [stmt] strictly
- occurs in a loop of [kf].
- @since Oxygen-20120901 *)
+(** [stmt_in_loop kf stmt] is [true] iff [stmt] strictly
+ occurs in a loop of [kf].
+ @since Oxygen-20120901 *)
val find_enclosing_loop: t -> stmt -> stmt
- (** [find_enclosing_loop kf stmt] returns the statement corresponding
- to the innermost loop containing [stmt] in [kf]. If [stmt] itself is
- a loop, returns [stmt]
- @raise Not_found if [stmt] is not part of a loop of [kf]
- @since Oxygen-20120901 *)
+(** [find_enclosing_loop kf stmt] returns the statement corresponding
+ to the innermost loop containing [stmt] in [kf]. If [stmt] itself is
+ a loop, returns [stmt]
+ @raise Not_found if [stmt] is not part of a loop of [kf]
+ @since Oxygen-20120901 *)
val find_syntactic_callsites : t -> (t * stmt) list
- (** [callsites f] collect the statements where [f] is called. Same
- complexity as [find_from_sid].
- @return a list of [f',s] where function [f'] calls [f] at statement
- [stmt].
- @since Carbon-20110201 *)
+(** [callsites f] collect the statements where [f] is called. Same
+ complexity as [find_from_sid].
+ @return a list of [f',s] where function [f'] calls [f] at statement
+ [stmt].
+ @since Carbon-20110201 *)
val local_definition: t -> varinfo -> stmt
(** [local_definition f v] returns the statement initializing the (defined)
@@ -143,21 +143,21 @@ val local_definition: t -> varinfo -> stmt
*)
val var_is_in_scope: stmt -> varinfo -> bool
- (** [var_is_in_scope kf stmt vi] returns [true] iff the local variable [vi]
- is syntactically visible from statement [stmt] in function [kf]. Note
- that on the contrary to {!Globals.Syntactic_search.find_in_scope}, the
- variable is searched according to its [vid], not its [vorig_name].
+(** [var_is_in_scope kf stmt vi] returns [true] iff the local variable [vi]
+ is syntactically visible from statement [stmt] in function [kf]. Note
+ that on the contrary to {!Globals.Syntactic_search.find_in_scope}, the
+ variable is searched according to its [vid], not its [vorig_name].
- @since 19.0-Potassium *)
+ @since 19.0-Potassium *)
val find_enclosing_stmt_in_block: block -> stmt -> stmt
- (** [find_enclosing_stmt_in_block b s] returns the statements [s']
- inside [b.bstmts] that contains [s]. It might be [s] itself, but also
- an inner block (recursively) containing [s].
+(** [find_enclosing_stmt_in_block b s] returns the statements [s']
+ inside [b.bstmts] that contains [s]. It might be [s] itself, but also
+ an inner block (recursively) containing [s].
- @raise AbortFatal if [b] is not equal to [find_enclosing_block s]
- @since 19.0-Potassium
- *)
+ @raise AbortFatal if [b] is not equal to [find_enclosing_block s]
+ @since 19.0-Potassium
+*)
val is_between: block -> stmt -> stmt -> stmt -> bool
(** [is_between b s1 s2 s3] returns [true] if the statement [s2] appears
@@ -191,14 +191,14 @@ val is_main: t -> bool
val returns_void : t -> bool
val is_first_stmt: t -> stmt -> bool
- (** @return true iff the statement is the first statement of the given
- function.
- @since 21.0-Scandium *)
+(** @return true iff the statement is the first statement of the given
+ function.
+ @since 21.0-Scandium *)
val is_return_stmt: t -> stmt -> bool
- (** @return true iff the statement is the return statement of the given
- function.
- @since 21.0-Scandium *)
+(** @return true iff the statement is the return statement of the given
+ function.
+ @since 21.0-Scandium *)
(* ************************************************************************* *)
(** {2 Getters} *)
@@ -225,21 +225,21 @@ val get_statics : t -> varinfo list
exception No_Definition
val get_definition : t -> fundec
- (** @raise No_Definition if the given function is not a definition.
- @plugin development guide *)
+(** @raise No_Definition if the given function is not a definition.
+ @plugin development guide *)
val has_definition : t -> bool
- (** @return [true] iff the given kernel function has a defintion.
- @since 21.0-Scandium *)
+(** @return [true] iff the given kernel function has a defintion.
+ @since 21.0-Scandium *)
(* ************************************************************************* *)
(** {2 Membership of variables} *)
(* ************************************************************************* *)
val is_formal: varinfo -> t -> bool
- (** @return [true] if the given varinfo is a formal parameter of the given
- function. If possible, use this function instead of
- {!Ast_info.Function.is_formal}. *)
+(** @return [true] if the given varinfo is a formal parameter of the given
+ function. If possible, use this function instead of
+ {!Ast_info.Function.is_formal}. *)
val get_formal_position: varinfo -> t -> int
(** [get_formal_position v kf] is the position of [v] as parameter of [kf].
@@ -251,14 +251,14 @@ val is_local : varinfo -> t -> bool
{!Ast_info.Function.is_local}. *)
val is_formal_or_local: varinfo -> t -> bool
- (** @return [true] if the given varinfo is a formal parameter or a local
- variable of the given function.
- If possible, use this function instead of
- {!Ast_info.Function.is_formal_or_local}. *)
+(** @return [true] if the given varinfo is a formal parameter or a local
+ variable of the given function.
+ If possible, use this function instead of
+ {!Ast_info.Function.is_formal_or_local}. *)
val get_called : exp -> t option
- (** Returns the static call to function [expr], if any.
- [None] means a dynamic call through function pointer. *)
+(** Returns the static call to function [expr], if any.
+ [None] means a dynamic call through function pointer. *)
(* ************************************************************************* *)
(** {2 Collections} *)
@@ -272,7 +272,7 @@ module Make_Table(Data: Datatype.S)(Info: State_builder.Info_with_size):
(** Set of kernel functions. *)
module Hptset : Hptset.S
with type elt = kernel_function
- and type 'a shape = 'a Hptmap.Shape(Cil_datatype.Kf).t
+ and type 'a shape = 'a Hptmap.Shape(Cil_datatype.Kf).t
(* ************************************************************************* *)
@@ -282,8 +282,8 @@ module Hptset : Hptset.S
(* ************************************************************************* *)
val register_stmt: t -> stmt -> block list -> unit
- (** Register a new statement in a kernel function, with the list of
- blocks that contain the statement (innermost first). *)
+(** Register a new statement in a kernel function, with the list of
+ blocks that contain the statement (innermost first). *)
val self: State.t
diff --git a/src/kernel_services/ast_data/property_status.mli b/src/kernel_services/ast_data/property_status.mli
index 36413851400aea90599327dd59c5083e4525937c..a9be088d3d3a338eac08e35ce996d03c9f9704e7 100644
--- a/src/kernel_services/ast_data/property_status.mli
+++ b/src/kernel_services/ast_data/property_status.mli
@@ -25,9 +25,9 @@
@plugin development guide *)
(* ************************************************************************ *)
-(** {2 Local status}
+(** {2 Local status}
- A local status (shortly, a status) of a property is a status directly set
+ A local status (shortly, a status) of a property is a status directly set
by an emitter. Thus a property may have several distinct status according to
who attempts the verification. *)
(* ************************************************************************ *)
@@ -40,23 +40,23 @@
point [s] and implicitly depends on an execution path from the program
entry point to [s]. It also depends on an explicit set of hypotheses [H]
indicating when emitting the property (see function {!emit}). *)
-type emitted_status =
+type emitted_status =
| True (** for each execution path [ep] from the program entry point to [s],
- the formula (/\_{h in H} h) ==> P(ep) is true *)
+ the formula (/\_{h in H} h) ==> P(ep) is true *)
| False_if_reachable (** for each execution path [ep] from the program entry
- point to [s], the formula (/\_{h in H} h) ==> P(ep)
- is false *)
+ point to [s], the formula (/\_{h in H} h) ==> P(ep)
+ is false *)
| False_and_reachable (** it exists an execution path [ep] from the program
- entry point to [s] such that the formula (/\_{h in
- H} h) ==> P(ep) is false *)
+ entry point to [s] such that the formula (/\_{h in
+ H} h) ==> P(ep) is false *)
| Dont_know (** any other case *)
module Emitted_status: Datatype.S with type t = emitted_status
exception Inconsistent_emitted_status of emitted_status * emitted_status
-val emit:
- Emitter.t -> hyps:Property.t list -> Property.t -> ?distinct:bool ->
+val emit:
+ Emitter.t -> hyps:Property.t list -> Property.t -> ?distinct:bool ->
emitted_status -> unit
(** [emit e ~hyps p s] indicates that the status of [p] is [s], is emitted by
[e], and is based on the list of hypothesis [hyps]. If [e] previously
@@ -86,7 +86,7 @@ val logical_consequence: Emitter.t -> Property.t -> Property.t list -> unit
val legal_dependency_cycle: Emitter.t -> Property.Set.t -> unit
(** The given properties may define a legal dependency cycle for the given
- emitter.
+ emitter.
@since Oxygen-20120901 *)
val self: State.t
@@ -97,22 +97,22 @@ val self: State.t
(* ************************************************************************ *)
type emitter_with_properties = private
- { emitter: Emitter.Usable_emitter.t;
- mutable properties: Property.t list;
- logical_consequence: bool (** Is the emitted status automatically
- inferred? *) }
+ { emitter: Emitter.Usable_emitter.t;
+ mutable properties: Property.t list;
+ logical_consequence: bool (** Is the emitted status automatically
+ inferred? *) }
type inconsistent = private
- { valid: emitter_with_properties list;
- invalid: emitter_with_properties list }
+ { valid: emitter_with_properties list;
+ invalid: emitter_with_properties list }
(** Type of the local status of a property. *)
type status = private
| Never_tried (** Nobody tries to verify the property *)
- | Best of
+ | Best of
emitted_status (** The know more precise status *)
- * emitter_with_properties list (** who attempt the verification
- under which hypotheses *)
+ * emitter_with_properties list (** who attempt the verification
+ under which hypotheses *)
| Inconsistent of inconsistent (** someone locally says the property is valid
and someone else says it is invalid: only
the consolidated status may conclude. *)
@@ -145,39 +145,39 @@ module Consolidation: sig
(** who do the job and, for each of them, who find which issues. *)
type pending =
- Property.Set.t Emitter.Usable_emitter.Map.t Emitter.Usable_emitter.Map.t
+ Property.Set.t Emitter.Usable_emitter.Map.t Emitter.Usable_emitter.Map.t
type consolidated_status = private
| Never_tried
- (** Nobody tries to verify the property.
- The argument is for internal use only *)
+ (** Nobody tries to verify the property.
+ The argument is for internal use only *)
- | Considered_valid
+ | Considered_valid
(** Nobody succeeds to verify the property, but it is expected to be
- verified by another way (manual review, ...) *)
+ verified by another way (manual review, ...) *)
| Valid of Emitter.Usable_emitter.Set.t
(** The verification of this property is fully done. No work to
- do anymore for this property. The argument is the emitters who did the
- job. *)
-
+ do anymore for this property. The argument is the emitters who did the
+ job. *)
+
| Valid_under_hyp of pending
(** The verification of this property is locally done, but it remains
- properties to verify in order to close the
- work. *)
+ properties to verify in order to close the
+ work. *)
| Unknown of pending
(** The verification of this property is not finished: the property itself
- remains to verify and it may also remain other pending properties.
- NB: the pendings contains the property itself. *)
+ remains to verify and it may also remain other pending properties.
+ NB: the pendings contains the property itself. *)
| Invalid of Emitter.Usable_emitter.Set.t
(** The verification of this property is fully done. All its hypotheses have
- been verified, but it is false: that is a true bug. *)
+ been verified, but it is false: that is a true bug. *)
| Invalid_under_hyp of pending
(** This property is locally false, but it remains properties to verify in
- order to be sure that is a bug. *)
+ order to be sure that is a bug. *)
| Invalid_but_dead of pending
(** This property is locally false, but there is other bugs in hypotheses *)
@@ -186,13 +186,13 @@ module Consolidation: sig
(** This property is locally true, but there is bugs in hypotheses *)
| Unknown_but_dead of pending
- (** This property is locally unknown, but there is other bugs in
- hypotheses *)
+ (** This property is locally unknown, but there is other bugs in
+ hypotheses *)
| Inconsistent of string
- (** Inconsistency detected when computing the consolidated status.
- The string explains what is the issue for the end-user. *)
-
+ (** Inconsistency detected when computing the consolidated status.
+ The string explains what is the issue for the end-user. *)
+
include Datatype.S with type t = consolidated_status
val get: Property.t -> t
@@ -202,11 +202,11 @@ end
(** Lighter version than Consolidation *)
module Feedback: sig
-
+
(** Same constructor than Consolidation.t, without argument. *)
type t =
| Never_tried
- | Considered_valid
+ | Considered_valid
| Valid
| Valid_under_hyp
| Unknown
@@ -223,7 +223,7 @@ module Feedback: sig
val pretty: Format.formatter -> t -> unit
end
-
+
(** See the consolidated status of a property in a graph, which all its
dependencies and their consolidated status. *)
module Consolidation_graph: sig
@@ -231,7 +231,7 @@ module Consolidation_graph: sig
val get: Property.t -> t
val dump: t -> Format.formatter -> unit
end
-
+
(* ************************************************************************* *)
(** {2 Iteration over the registered properties} *)
(* ************************************************************************* *)
diff --git a/src/kernel_services/ast_queries/cil_datatype.mli b/src/kernel_services/ast_queries/cil_datatype.mli
index 4fcde6cd57f4d59aea15e154862cb753808deea7..64e81bacc3559c4d1febf21b0dd54a7b994556cb 100644
--- a/src/kernel_services/ast_queries/cil_datatype.mli
+++ b/src/kernel_services/ast_queries/cil_datatype.mli
@@ -33,12 +33,12 @@ open Datatype
(** Auxiliary module for datatypes that can be pretty-printed. For those that
do not have this signature, module {!Printer} must be used. *)
module type S_with_pretty = sig
- include S
+ include S
(**/**)
val pretty_ref: (Format.formatter -> t -> unit) ref
end
module type S_with_collections_pretty = sig
- include S_with_collections
+ include S_with_collections
(**/**)
val pretty_ref: (Format.formatter -> t -> unit) ref
end
@@ -65,16 +65,16 @@ module Location: sig
include S_with_collections_pretty with type t = location
val unknown: t
val pretty_long : t Pretty_utils.formatter
- (** Pretty the location under the form [file <f>, line <l>], without
- the full-path to the file. The default pretty-printer [pretty] echoes
- [<dir/f>:<l>] *)
+ (** Pretty the location under the form [file <f>, line <l>], without
+ the full-path to the file. The default pretty-printer [pretty] echoes
+ [<dir/f>:<l>] *)
val pretty_line: t Pretty_utils.formatter
(** Pretty-print both location start and end, including file, line and
character offset.
@since 22.0-Titanium
- *)
+ *)
val pretty_debug: t Pretty_utils.formatter
(** Prints only the line of the location *)
@@ -86,13 +86,13 @@ module Location: sig
but no absolute character offsets.
@since 23.0-Vanadium
- *)
+ *)
val compare_start_semantic : location -> location -> int
(** Equality using [compare_start_semantic].
@since 22.0-Titanium
- *)
+ *)
val equal_start_semantic : location -> location -> bool
end
@@ -125,7 +125,7 @@ module Enumitem: S_with_collections_pretty with type t = enumitem
module Wide_string: S_with_collections with type t = int64 list
(**
- @since Oxygen-20120901
+ @since Oxygen-20120901
*)
module Constant: S_with_collections_pretty with type t = constant
@@ -159,24 +159,24 @@ end
module Kinstr: sig
include S_with_collections with type t = kinstr
val kinstr_of_opt_stmt: stmt option -> kinstr
- (** @since Nitrogen-20111001. *)
+ (** @since Nitrogen-20111001. *)
val loc: t -> location
end
module Label: S_with_collections_pretty with type t = label
-(** Note that the equality is based on eid (for sub-expressions).
+(** Note that the equality is based on eid (for sub-expressions).
For structural equality, use {!LvalStructEq} *)
module Lval: S_with_collections_pretty with type t = lval
(**
- @since Oxygen-20120901
+ @since Oxygen-20120901
*)
module LvalStructEq: S_with_collections with type t = lval
-(** Same remark as for Lval.
- For structural equality, use {!OffsetStructEq}. *)
+(** Same remark as for Lval.
+ For structural equality, use {!OffsetStructEq}. *)
module Offset: S_with_collections_pretty with type t = offset
(** @since Oxygen-20120901 *)
@@ -187,13 +187,13 @@ module Stmt: sig
include S_with_collections_pretty with type t = stmt
module Hptset: sig
include Hptset.S with type elt = stmt
- and type 'a shape = 'a Hptmap.Shape(Stmt_Id).t
+ and type 'a shape = 'a Hptmap.Shape(Stmt_Id).t
val self: State.t
end
val loc: t -> location
val pretty_sid: Format.formatter -> t -> unit
- (** Pretty print the sid of the statement
- @since Nitrogen-20111001 *)
+ (** Pretty print the sid of the statement
+ @since Nitrogen-20111001 *)
end
module Attribute: S_with_collections_pretty with type t = attribute
@@ -204,17 +204,17 @@ module Attributes: S_with_collections with type t = attributes
module Typ: sig
include S_with_collections_pretty with type t = typ
val toplevel_attr: t -> attributes
- (** returns the attributes associated to the toplevel type, without adding
- attributes from compinfo, enuminfo or typeinfo. Use {!Cil.typeAttrs}
- to retrieve the complete set of attributes. *)
+ (** returns the attributes associated to the toplevel type, without adding
+ attributes from compinfo, enuminfo or typeinfo. Use {!Cil.typeAttrs}
+ to retrieve the complete set of attributes. *)
end
(** Types, with comparison over struct done by name and no unrolling. *)
module TypByName: S_with_collections_pretty with type t = typ
(** Types, with comparison over struct done by key and no unrolling
- @since Fluorine-20130401
- *)
+ @since Fluorine-20130401
+*)
module TypNoUnroll: S_with_collections_pretty with type t = typ
@@ -227,7 +227,7 @@ module Varinfo: sig
include S_with_collections_pretty with type t = varinfo
module Hptset: sig
include Hptset.S with type elt = varinfo
- and type 'a shape = 'a Hptmap.Shape(Varinfo_Id).t
+ and type 'a shape = 'a Hptmap.Shape(Varinfo_Id).t
val self: State.t
end
val dummy: t
@@ -282,9 +282,9 @@ module Logic_info: S_with_collections_pretty with type t = logic_info
(** Logic_info with structural comparison:
- name of the symbol
- type of arguments
- Note that polymorphism is ignored, in the sense that two symbols with
- the same name and profile except for the name of their type variables
- will compare unequal.
+ Note that polymorphism is ignored, in the sense that two symbols with
+ the same name and profile except for the name of their type variables
+ will compare unequal.
@since 20.0-Calcium
*)
@@ -316,7 +316,7 @@ module Logic_real: S_with_collections_pretty with type t = logic_real
module Predicate: S_with_pretty with type t = predicate
module Toplevel_predicate: S_with_pretty with type t = toplevel_predicate
-module Identified_predicate:
+module Identified_predicate:
S_with_collections_pretty with type t = identified_predicate
(** @since Neon-20140301 *)
diff --git a/src/kernel_services/ast_queries/cil_state_builder.mli b/src/kernel_services/ast_queries/cil_state_builder.mli
index b9d86cfce9d0573430a712c610f790bacf80b39c..d7c7fec74a989e413c40aa22d053a5b378e33156 100644
--- a/src/kernel_services/ast_queries/cil_state_builder.mli
+++ b/src/kernel_services/ast_queries/cil_state_builder.mli
@@ -35,7 +35,7 @@ module Stmt_hashtbl(Data:Datatype.S)(Info: State_builder.Info_with_size) :
module Varinfo_hashtbl(Data:Datatype.S)(Info: State_builder.Info_with_size) :
State_builder.Hashtbl with type key = Cil_types.varinfo
- and type data = Data.t
+ and type data = Data.t
module Exp_hashtbl(Data:Datatype.S)(Info: State_builder.Info_with_size) :
State_builder.Hashtbl with type key = Cil_types.exp
diff --git a/src/kernel_services/ast_queries/logic_const.mli b/src/kernel_services/ast_queries/logic_const.mli
index 59e164be484dd788a2a3e4543fc069926d475279..db448d2e6dee8acee4a803d9e5d82c6fc2bad78a 100644
--- a/src/kernel_services/ast_queries/logic_const.mli
+++ b/src/kernel_services/ast_queries/logic_const.mli
@@ -60,7 +60,7 @@ val toplevel_predicate: ?kind:predicate_kind -> predicate -> toplevel_predicate
(** creates a new identified predicate with a fresh id.
@modify 22.0-Titanium add [only_check] optional parameter
- *)
+*)
val new_predicate: ?kind:predicate_kind -> predicate -> identified_predicate
(** creates a new acsl_extension with a fresh id.
@@ -124,7 +124,7 @@ val pold: ?loc:location -> predicate -> predicate
(** application of predicate*)
val papp:
?loc:location ->
- logic_info * logic_label list * term list ->
+ logic_info * logic_label list * term list ->
predicate
(** && *)
@@ -145,15 +145,15 @@ val pands: predicate list -> predicate
val pors: predicate list -> predicate
(** local binding *)
-val plet:
+val plet:
?loc:location -> logic_info -> predicate -> predicate
(** ==> *)
-val pimplies :
+val pimplies :
?loc:location -> predicate * predicate -> predicate
(** ? : *)
-val pif:
+val pif:
?loc:location -> term * predicate * predicate -> predicate
(** <==> *)
@@ -299,7 +299,7 @@ val boolean_type: logic_type
val term : ?loc:Location.t -> term_node -> logic_type -> term
(** &
- @deprecated Neon-20130301 {!Logic_utils.mk_AddrOf} is easier to use.*)
+ @deprecated Neon-20130301 {!Logic_utils.mk_AddrOf} is easier to use.*)
val taddrof: ?loc:Location.t -> term_lval -> logic_type -> term
(** [..] of integers *)
@@ -311,7 +311,7 @@ val tinteger: ?loc:Location.t -> int -> term
(** integer constant *)
val tinteger_s64: ?loc:Location.t -> int64 -> term
-(** integer constant
+(** integer constant
@since Oxygen-20120901 *)
val tint: ?loc:Location.t -> Integer.t -> term
@@ -327,7 +327,7 @@ val tstring: ?loc:Location.t -> string -> term
(** \at *)
val tat: ?loc:Location.t -> term * logic_label -> term
-(** \old
+(** \old
@since Nitrogen-20111001
*)
val told: ?loc:Location.t -> term -> term
@@ -347,7 +347,7 @@ val tlogic_coerce: ?loc:Location.t -> term -> logic_type -> term
(** [true] if the term is \result (potentially enclosed in \at)*)
val is_result: term -> bool
-(** [true] if the term is \exit_status (potentially enclosed in \at)
+(** [true] if the term is \exit_status (potentially enclosed in \at)
@since Nitrogen-20111001
*)
val is_exit_status: term -> bool
diff --git a/src/kernel_services/ast_transformations/clone.ml b/src/kernel_services/ast_transformations/clone.ml
index ca4bce836e3c4c40b54dd19511c658de0c394e6a..589047042ffc159ef2cf8a98871a144cb679121b 100644
--- a/src/kernel_services/ast_transformations/clone.ml
+++ b/src/kernel_services/ast_transformations/clone.ml
@@ -49,9 +49,9 @@ let clone_function_definition old_kf =
Visitor.visitFramacFunspec visitor old_funspec
in
(* Creates the kernel function for the clone function. *)
- let new_kf =
- (* NOTE: it would be better if the replace function would
- return the associated kernel function that is new here *)
+ let new_kf =
+ (* NOTE: it would be better if the replace function would
+ return the associated kernel function that is new here *)
Globals.Functions.replace_by_definition new_funspec new_fundec old_loc;
try Globals.Functions.get new_fundec.svar
with Not_found ->
@@ -66,25 +66,25 @@ let clone_defined_kernel_function old_kf =
let new_kf = clone_function_definition old_kf in
let new_fundec = Kernel_function.get_definition new_kf in
let new_loc = Kernel_function.get_location new_kf in
- let gfun = GFun (new_fundec, new_loc) in
+ let gfun = GFun (new_fundec, new_loc) in
let old_vi = Kernel_function.get_vi old_kf in
- let is_old_fundec fundec = Cil_datatype.Varinfo.equal fundec.svar old_vi in
+ let is_old_fundec fundec = Cil_datatype.Varinfo.equal fundec.svar old_vi in
let is_old_gfun = function
| GFun (fundec,_) -> is_old_fundec fundec
| _ -> false
- in
+ in
(* Scan the globals. Make sure this is tail recursive. *)
let rec loop (acc: global list) = function
| [] -> begin
- match f.globinit with
- | Some fundec when is_old_fundec fundec ->
- (* The clone function is the global initializer function.
- Adds it at the end of the list of globals. *)
- List.rev_append acc [gfun]
- | _ -> Kernel.fatal "kernel function not found for %s(%d)" old_vi.vname old_vi.vid
- end
- | g :: restg when is_old_gfun g -> List.rev_append acc (g:: gfun ::restg)
+ match f.globinit with
+ | Some fundec when is_old_fundec fundec ->
+ (* The clone function is the global initializer function.
+ Adds it at the end of the list of globals. *)
+ List.rev_append acc [gfun]
+ | _ -> Kernel.fatal "kernel function not found for %s(%d)" old_vi.vname old_vi.vid
+ end
+ | g :: restg when is_old_gfun g -> List.rev_append acc (g:: gfun ::restg)
| g :: restg -> loop (g::acc) restg
in
(* Updates the list of globals *)
diff --git a/src/kernel_services/ast_transformations/clone.mli b/src/kernel_services/ast_transformations/clone.mli
index 6a7dd4fcdd2776b2a63dd4307f8965e1610c979a..f9b8e203d3939584da8b27e4c8160ebd4e344ee2 100644
--- a/src/kernel_services/ast_transformations/clone.mli
+++ b/src/kernel_services/ast_transformations/clone.mli
@@ -24,7 +24,7 @@ open Cil_types
(** Experimental module *)
-(** Returns a clone of a kernel function and
+(** Returns a clone of a kernel function and
adds it into the AST next to the old one *)
val clone_defined_kernel_function: kernel_function -> kernel_function
diff --git a/src/kernel_services/cmdline_parameters/cmdline.ml b/src/kernel_services/cmdline_parameters/cmdline.ml
index aee2fb64e6cba33139387c964db365fd8df2bdd5..5b4b3fbd2bec146958196e04a69428fa79a4ce86 100644
--- a/src/kernel_services/cmdline_parameters/cmdline.ml
+++ b/src/kernel_services/cmdline_parameters/cmdline.ml
@@ -115,27 +115,27 @@ let request_crash_report =
Fc_config.version_and_codename
let protect = function
- | Sys.Break ->
- "User Interruption (Ctrl-C)"
- ^ if Kernel_debug_level.get () > 0 then "\n" ^ get_backtrace () else ""
+ | Sys.Break ->
+ "User Interruption (Ctrl-C)"
+ ^ if Kernel_debug_level.get () > 0 then "\n" ^ get_backtrace () else ""
| Sys_error s -> Printf.sprintf "System error: %s" s
| Unix.Unix_error(err, a, b) ->
- let error = Printf.sprintf "System error: %s" (Unix.error_message err) in
- (match a, b with
- | "", "" -> error
- | "", t | t, "" -> Printf.sprintf "%s (%s)" error t
- | f, x -> Printf.sprintf "%s (%s %S)" error f x)
+ let error = Printf.sprintf "System error: %s" (Unix.error_message err) in
+ (match a, b with
+ | "", "" -> error
+ | "", t | t, "" -> Printf.sprintf "%s (%s)" error t
+ | f, x -> Printf.sprintf "%s (%s %S)" error f x)
| Log.AbortError p ->
- Printf.sprintf "%s aborted: invalid user input.%s"
- (long_plugin_name p) (additional_info ())
+ Printf.sprintf "%s aborted: invalid user input.%s"
+ (long_plugin_name p) (additional_info ())
| Log.AbortFatal p ->
- let bt = get_backtrace () in
- Printf.sprintf
- "%s\n%s aborted: internal error.%s\n%s"
- bt
- (long_plugin_name p)
- (additional_info ())
- request_crash_report
+ let bt = get_backtrace () in
+ Printf.sprintf
+ "%s\n%s aborted: internal error.%s\n%s"
+ bt
+ (long_plugin_name p)
+ (additional_info ())
+ request_crash_report
| Log.FeatureRequest(s, p, m) ->
let name = long_plugin_name p in
let pp_oloc fmt = function
@@ -149,12 +149,12 @@ let protect = function
'[%s] %s'."
pp_oloc s name (additional_info ()) name m
| e ->
- let bt = get_backtrace () in
- Printf.sprintf
- "%s\nUnexpected error (%s).\n%s"
- bt
- (Printexc.to_string e)
- request_crash_report
+ let bt = get_backtrace () in
+ Printf.sprintf
+ "%s\nUnexpected error (%s).\n%s"
+ bt
+ (Printexc.to_string e)
+ request_crash_report
(* ************************************************************************* *)
(** {2 Exiting Frama-C} *)
@@ -241,14 +241,14 @@ let catch_toplevel_run ~f ~at_normal_exit ~on_error =
cleanup ();
with
| Exit ->
- bail_out ()
+ bail_out ()
| exn when catch_at_toplevel exn ->
- Kernel_log.feedback ~level:0 "%s" (protect exn);
- run_on_error exn;
- exit (exit_code exn)
+ Kernel_log.feedback ~level:0 "%s" (protect exn);
+ run_on_error exn;
+ exit (exit_code exn)
| exn ->
- run_on_error exn;
- raise exn
+ run_on_error exn;
+ raise exn
(* ************************************************************************* *)
(** {2 Generic parsing way} *)
@@ -310,21 +310,21 @@ let parse known_options_list then_expected options_list =
let setting = Hashtbl.find known_options option in
let use_arg = match setting with
| Unit f ->
- if explicit then raise_error option "does not accept any argument";
- f ();
- false
+ if explicit then raise_error option "does not accept any argument";
+ f ();
+ false
| Int f ->
- let n =
- try int_of_string arg
- with Failure _ ->
- raise_error option "requires an integer as argument"
- in
- f n;
- true
+ let n =
+ try int_of_string arg
+ with Failure _ ->
+ raise_error option "requires an integer as argument"
+ in
+ f n;
+ true
| String f ->
- check_string_argname ();
- f arg;
- true
+ check_string_argname ();
+ f arg;
+ true
in
unknown_options, use_arg && not explicit, true
with Not_found ->
@@ -334,37 +334,37 @@ let parse known_options_list then_expected options_list =
let rec go unknown_options nb_used = function
| [] -> unknown_options, nb_used, None
| [ "-then" | "-then-last" | "-then-replace" as then_name ]
- when then_expected ->
- Kernel_log.warning "ignoring last option `%s'." then_name;
- unknown_options, nb_used, None
+ when then_expected ->
+ Kernel_log.warning "ignoring last option `%s'." then_name;
+ unknown_options, nb_used, None
| [ "-then-on" ] when then_expected ->
- raise_error "-then-on" "requires a string as argument."
+ raise_error "-then-on" "requires a string as argument."
| [ option ] ->
- let unknown, use_arg, is_used =
- parse_one_option unknown_options option ""
- in
- assert (not use_arg);
- unknown, (if is_used then succ nb_used else nb_used), None
+ let unknown, use_arg, is_used =
+ parse_one_option unknown_options option ""
+ in
+ assert (not use_arg);
+ unknown, (if is_used then succ nb_used else nb_used), None
| "-then" :: then_options when then_expected ->
- unknown_options, nb_used, Some (then_options, Default)
+ unknown_options, nb_used, Some (then_options, Default)
| "-then-last" :: then_options when then_expected ->
- unknown_options, nb_used, Some (then_options, Last)
+ unknown_options, nb_used, Some (then_options, Last)
| "-then-replace" :: then_options when then_expected ->
- unknown_options, nb_used, Some (then_options, Replace)
+ unknown_options, nb_used, Some (then_options, Replace)
| "-then-on" :: project_name :: then_options when then_expected ->
- unknown_options, nb_used, Some (then_options, Name project_name)
+ unknown_options, nb_used, Some (then_options, Name project_name)
| "-permissive" :: next_options ->
permissive := true;
go unknown_options nb_used next_options
| option :: (arg :: next_options as arg_next) ->
- let unknown, use_arg, is_used =
- parse_one_option unknown_options option arg
- in
- let next = if use_arg then next_options else arg_next in
- go
- unknown
- (if is_used then succ nb_used else nb_used)
- next
+ let unknown, use_arg, is_used =
+ parse_one_option unknown_options option arg
+ in
+ let next = if use_arg then next_options else arg_next in
+ go
+ unknown
+ (if is_used then succ nb_used else nb_used)
+ next
in
try
let unknown_options, nb_used, then_options = go [] 0 options_list in
@@ -459,7 +459,7 @@ module Plugin: sig
val add_aliases:
orig:string -> string -> group:string -> ?visible:bool -> ?deprecated:bool
-> string list -> cmdline_option list
- val replace_option_setting:
+ val replace_option_setting:
string -> plugin:string -> group:string -> option_setting -> unit
val replace_option_help:
string -> plugin:string -> group:string -> string -> unit
@@ -591,9 +591,9 @@ end = struct
let options_in_group = find_group plugin group in
let rec replace = function
| [] ->
- Kernel_log.fatal
- "no option %s in plugin %s ((group of options %s)."
- option_name plugin group
+ Kernel_log.fatal
+ "no option %s in plugin %s ((group of options %s)."
+ option_name plugin group
| o :: _ when o.oname = option_name -> change o
| _ :: l -> replace l
in
@@ -644,11 +644,11 @@ struct
plugin name S.name;*)
let help = if help = "" then "undocumented" else help in
let o =
- { oname = name;
+ { oname = name;
argname = argname;
- ohelp = help;
- ext_help = ext_help;
- ovisible = visible;
+ ohelp = help;
+ ext_help = ext_help;
+ ovisible = visible;
setting = setting }
in
add_for_parsing o;
@@ -656,7 +656,7 @@ struct
let parse options_list =
Kernel_log.feedback ~dkey
- "parsing command line options of stage %S."
+ "parsing command line options of stage %S."
S.name;
let options, nb_used, then_options =
parse
@@ -735,7 +735,7 @@ let run_after_setting_files = After_setting.extend
type stage = Early | Extending | Extended | Exiting | Loading | Configuring
-let add_option
+let add_option
name ~plugin ~group stage ?argname ~help ~visible ~ext_help setting =
if name <> "" then
let add = match stage with
@@ -861,13 +861,13 @@ let play_in_toplevel on_from_name nb_used play options =
| Default -> current, play_in_toplevel_one_shot nb_used play options
| Last ->
(match !last_project_created_by_copy () with
- | None -> Kernel_log.abort "no known last created project."
- | Some p -> play_on options p)
+ | None -> Kernel_log.abort "no known last created project."
+ | Some p -> play_on options p)
| Replace ->
(match !last_project_created_by_copy () with
- | None -> Kernel_log.abort "no known last created project."
- | Some p ->
- play_on (("-remove-projects=-@all,+" ^ current) :: options) p)
+ | None -> Kernel_log.abort "no known last created project."
+ | Some p ->
+ play_on (("-remove-projects=-@all,+" ^ current) :: options) p)
| Name p -> play_on options p
in
aux last_current then_opts
@@ -949,17 +949,17 @@ let low_print_option_help fmt print_invisible o =
let print_option_help fmt ~plugin ~group name =
let p = Plugin.find plugin in
- let options =
- try Hashtbl.find p.Plugin.groups group
- with Not_found ->
+ let options =
+ try Hashtbl.find p.Plugin.groups group
+ with Not_found ->
Kernel_log.fatal "[Cmdline.print_option_help] no group %s" group
in
(* linear search... *)
let rec find_then_print = function
| [] -> Kernel_log.fatal "[Cmdline.print_option_help] no option %s" name
- | o :: tl ->
- if o.oname = name then ignore (low_print_option_help fmt true o)
- else find_then_print tl
+ | o :: tl ->
+ if o.oname = name then ignore (low_print_option_help fmt true o)
+ else find_then_print tl
in
find_then_print !options
@@ -997,7 +997,7 @@ let plugin_help shortname =
let p = Plugin.find shortname in
if p.Plugin.name <> "" then begin
assert (p.Plugin.short <> "");
- Log.print_on_output
+ Log.print_on_output
(fun fmt ->
Format.fprintf fmt "@[%s:@ %s@]@\n@[%s:@ %s@]@\n"
"Plug-in name" p.Plugin.name
@@ -1022,15 +1022,15 @@ let plugin_help shortname =
match sort_groups p.Plugin.groups with
| [] -> ()
| g :: l ->
- let print_group newline (s, o) =
- if newline then Format.pp_print_newline fmt ();
- if s <> "" then
- Format.fprintf fmt "@[*** %s@]@\n@\n"
- (String.uppercase_ascii s);
- ignore (print_options !o)
- in
- print_group false g;
- List.iter (print_group true) l));
+ let print_group newline (s, o) =
+ if newline then Format.pp_print_newline fmt ();
+ if s <> "" then
+ Format.fprintf fmt "@[*** %s@]@\n@\n"
+ (String.uppercase_ascii s);
+ ignore (print_options !o)
+ in
+ print_group false g;
+ List.iter (print_group true) l));
raise Exit
let help () =
diff --git a/src/kernel_services/cmdline_parameters/cmdline.mli b/src/kernel_services/cmdline_parameters/cmdline.mli
index 6cacdae7d1c66d930d5b20da80e1936de308956a..8deba9ca6046a4fc38b43d1a0db814acfc42cc04 100644
--- a/src/kernel_services/cmdline_parameters/cmdline.mli
+++ b/src/kernel_services/cmdline_parameters/cmdline.mli
@@ -20,12 +20,12 @@
(* *)
(**************************************************************************)
-(** Command line parsing.
+(** Command line parsing.
@plugin development guide *)
(* ************************************************************************** *)
(** {2 Stage configurations}
-(* ************************************************************************** *)
+ (* ************************************************************************** *)
Frama-C uses several stages for parsing its command line.
Each of them may be customized. *)
@@ -50,57 +50,57 @@ type stage =
set may be modified to take into account cmdline options.
Just after this stage, Frama-C will run the plug-in mains.
@plugin development guide *)
- (** The different stages, from the first to be executed to the last one.
- @since Beryllium-20090601-beta1 *)
+(** The different stages, from the first to be executed to the last one.
+ @since Beryllium-20090601-beta1 *)
val run_after_early_stage: (unit -> unit) -> unit
- (** Register an action to be executed at the end of the early stage.
- @plugin development guide
- @since Beryllium-20090901 *)
+(** Register an action to be executed at the end of the early stage.
+ @plugin development guide
+ @since Beryllium-20090901 *)
val run_during_extending_stage: (unit -> unit) -> unit
- (** Register an action to be executed during the extending stage.
- @plugin development guide
- @since Beryllium-20090901 *)
+(** Register an action to be executed during the extending stage.
+ @plugin development guide
+ @since Beryllium-20090901 *)
val run_after_extended_stage: (unit -> unit) -> unit
- (** Register an action to be executed at the end of the extended stage.
- @plugin development guide
- @since Beryllium-20090901 *)
+(** Register an action to be executed at the end of the extended stage.
+ @plugin development guide
+ @since Beryllium-20090901 *)
type exit
- (** @since Beryllium-20090901 *)
+(** @since Beryllium-20090901 *)
val nop : exit
- (** @since Beryllium-20090901
- @plugin development guide *)
+(** @since Beryllium-20090901
+ @plugin development guide *)
exception Exit
- (** @since Beryllium-20090901
- @plugin development guide *)
+(** @since Beryllium-20090901
+ @plugin development guide *)
val run_after_exiting_stage: (unit -> exit) -> unit
- (** Register an action to be executed at the end of the exiting stage.
- The guarded action must finish by [exit n].
- @plugin development guide
- @since Beryllium-20090601-beta1 *)
+(** Register an action to be executed at the end of the exiting stage.
+ The guarded action must finish by [exit n].
+ @plugin development guide
+ @since Beryllium-20090601-beta1 *)
val run_after_loading_stage: (unit -> unit) -> unit
- (** Register an action to be executed at the end of the loading stage.
- @plugin development guide
- @since Beryllium-20090601-beta1 *)
+(** Register an action to be executed at the end of the loading stage.
+ @plugin development guide
+ @since Beryllium-20090601-beta1 *)
val is_going_to_load: unit -> unit
- (** To be call if one action is going to run after the loading stage.
- It is not necessary to call this function if the running action is set by
- an option put on the command line.
- @since Beryllium-20090601-beta1
- @plugin development guide *)
+(** To be call if one action is going to run after the loading stage.
+ It is not necessary to call this function if the running action is set by
+ an option put on the command line.
+ @since Beryllium-20090601-beta1
+ @plugin development guide *)
val run_after_configuring_stage: (unit -> unit) -> unit
- (** Register an action to be executed at the end of the configuring stage.
- @plugin development guide
- @since Beryllium-20090601-beta1 *)
+(** Register an action to be executed at the end of the configuring stage.
+ @plugin development guide
+ @since Beryllium-20090601-beta1 *)
val run_after_setting_files: (string list -> unit) -> unit
(** Register an action to be executed just after setting the files put on the
@@ -109,17 +109,17 @@ val run_after_setting_files: (string list -> unit) -> unit
@since Carbon-20101201 *)
val at_normal_exit: (unit -> unit) -> unit
- (** Register a hook executed whenever Frama-C exits without error (the exit
- code is 0).
- @since Boron-20100401 *)
+(** Register a hook executed whenever Frama-C exits without error (the exit
+ code is 0).
+ @since Boron-20100401 *)
val at_error_exit: (exn -> unit) -> unit
- (** Register a hook executed whenever Frama-C exits with error (the exit
- code is greater than 0). The argument of the hook is the exception at the
- origin of the error.
- @since Boron-20100401
- @modify Neon-20130301 add the exception as argument of the
- hook. *)
+(** Register a hook executed whenever Frama-C exits with error (the exit
+ code is greater than 0). The argument of the hook is the exception at the
+ origin of the error.
+ @since Boron-20100401
+ @modify Neon-20130301 add the exception as argument of the
+ hook. *)
(** Group of command line options.
@since Beryllium-20090901 *)
@@ -127,18 +127,18 @@ module Group : sig
type t (** @since Beryllium-20090901 *)
val default: t (** @since Beryllium-20090901 *)
val name: t -> string
- (** @since Beryllium-20090901 *)
+ (** @since Beryllium-20090901 *)
(**/**)
(** Kernel internals *)
val add: ?memo:bool -> plugin:string -> string -> t * bool
- (** Add a new group of options to the given plugin.
- If [memo] is [true], just return the already registered group if any.
- If [memo] is [false], cannot add twice a group with the same name.
- @return the group corresponding to the given name. Also return [true]
- iff the group has just been created.
- @since Beryllium-20090901 *)
+ (** Add a new group of options to the given plugin.
+ If [memo] is [true], just return the already registered group if any.
+ If [memo] is [false], cannot add twice a group with the same name.
+ @return the group corresponding to the given name. Also return [true]
+ iff the group has just been created.
+ @since Beryllium-20090901 *)
(**/**)
end
@@ -147,7 +147,7 @@ end
(* ************************************************************************** *)
(* ************************************************************************** *)
-(** From here: functions required by Kernel Internals only!
+(** From here: functions required by Kernel Internals only!
You should not use them! *)
(* ************************************************************************** *)
(* ************************************************************************** *)
@@ -157,8 +157,8 @@ end
(* ************************************************************************** *)
val protect: exn -> string
- (** Messages for exceptions raised by Frama-C
- @since Boron-20100401 *)
+(** Messages for exceptions raised by Frama-C
+ @since Boron-20100401 *)
val catch_at_toplevel: exn -> bool
(** @return true iff the given exception is caught by the Frama-C toplevel.
@@ -169,38 +169,38 @@ val catch_toplevel_run:
at_normal_exit:(unit -> unit) ->
on_error:(exn -> unit) ->
unit
- (** Run [f]. When done, either call [at_normal_exit] if running [f] was ok;
- or call [on_error] (and exits) in other cases.
- @modify Boron-20100401 additional arguments. They are now
- labelled
- @modify Neon-20140301 add the exception as argument of
- [on_error].
- @modify Magnesium-20151001 Removed argument [~quit]
- *)
+(** Run [f]. When done, either call [at_normal_exit] if running [f] was ok;
+ or call [on_error] (and exits) in other cases.
+ @modify Boron-20100401 additional arguments. They are now
+ labelled
+ @modify Neon-20140301 add the exception as argument of
+ [on_error].
+ @modify Magnesium-20151001 Removed argument [~quit]
+*)
val run_normal_exit_hook: unit -> unit
- (** Run all the hooks registered by {!at_normal_exit}.
- @since Boron-20100401 *)
+(** Run all the hooks registered by {!at_normal_exit}.
+ @since Boron-20100401 *)
val run_error_exit_hook: exn -> unit
- (** Run all the hooks registered by {!at_normal_exit}.
- @since Boron-20100401
- @modify Neon-20130301 add the exception as argument. *)
+(** Run all the hooks registered by {!at_normal_exit}.
+ @since Boron-20100401
+ @modify Neon-20130301 add the exception as argument. *)
val error_occurred: exn -> unit
- (** Remember that an error occurred.
- So {!run_error_exit_hook} will be called when Frama-C will exit.
- @since Boron-20100401
- @modify Neon-20130301 add the exception as argument,
- fix spelling. *)
+(** Remember that an error occurred.
+ So {!run_error_exit_hook} will be called when Frama-C will exit.
+ @since Boron-20100401
+ @modify Neon-20130301 add the exception as argument,
+ fix spelling. *)
val bail_out: unit -> 'a
- (** Stop Frama-C with exit 0.
- @since Boron-20100401 *)
+(** Stop Frama-C with exit 0.
+ @since Boron-20100401 *)
(* ************************************************************************** *)
(** {2 Special functions}
-(* ************************************************************************** *)
+ (* ************************************************************************** *)
These functions should not be used by a standard plug-in developer. *)
@@ -223,42 +223,42 @@ val parse_and_boot:
[on_from_name] *)
val nb_given_options: unit -> int
- (** Number of options provided by the user on the command line.
- Should not be called before the end of the command line parsing.
- @since Beryllium-20090601-beta1 *)
+(** Number of options provided by the user on the command line.
+ Should not be called before the end of the command line parsing.
+ @since Beryllium-20090601-beta1 *)
val use_cmdline_files: (Datatype.Filepath.t list -> unit) -> unit
- (** What to do with the list of files put on the command lines.
- @since Beryllium-20090601-beta1 *)
+(** What to do with the list of files put on the command lines.
+ @since Beryllium-20090601-beta1 *)
val help: unit -> exit
- (** Display the help of Frama-C
- @since Beryllium-20090601-beta1 *)
+(** Display the help of Frama-C
+ @since Beryllium-20090601-beta1 *)
val list_plugins: unit -> exit
- (** Display the list of installed plug-ins
- @since Magnesium-20151001 *)
+(** Display the list of installed plug-ins
+ @since Magnesium-20151001 *)
val explain_cmdline : unit -> exit
val plugin_help: string -> exit
- (** Display the help of the given plug-in (given by its shortname).
- @since Beryllium-20090601-beta1 *)
+(** Display the help of the given plug-in (given by its shortname).
+ @since Beryllium-20090601-beta1 *)
-val print_option_help:
+val print_option_help:
Format.formatter -> plugin:string -> group:Group.t -> string -> unit
(** Pretty print the help of the option (given by its plug-in, its group and its
name) in the provided formatter.
@since Oxygen-20120901 *)
val add_plugin: ?short:string -> string -> help:string -> unit
- (** [add_plugin ~short name ~help] adds a new plug-in recognized by the
- command line of Frama-C. If the shortname is not specified, then the name
- is used as the shortname. By convention, if the name and the shortname
- are equal to "", then the register "plug-in" is the Frama-C kernel
- itself.
- @raise Invalid_argument if the same shortname is registered twice
- @since Beryllium-20090601-beta1 *)
+(** [add_plugin ~short name ~help] adds a new plug-in recognized by the
+ command line of Frama-C. If the shortname is not specified, then the name
+ is used as the shortname. By convention, if the name and the shortname
+ are equal to "", then the register "plug-in" is the Frama-C kernel
+ itself.
+ @raise Invalid_argument if the same shortname is registered twice
+ @since Beryllium-20090601-beta1 *)
(** @since Beryllium-20090601-beta1 *)
type option_setting =
@@ -277,17 +277,17 @@ val add_option:
ext_help:(unit,Format.formatter,unit) format ->
option_setting ->
unit
- (** [add_option name ~plugin stage ~argname ~help setting]
- adds a new option of the given [name] recognized by the command line of
- Frama-C. If the [name] is the empty string, nothing is done.
- [plugin] is the shortname of the plug-in.
- [argname] is the name of the argument which can be used of the
- description [help]. Both of them are used by the help of the
- registered option. If [help] is [None], then the option is not shown
- in the help.
- @since Beryllium-20090601-beta1
- @modify Carbon-20101201
- @modify Oxygen-20120901 change type of ~help and add ~visible. *)
+(** [add_option name ~plugin stage ~argname ~help setting]
+ adds a new option of the given [name] recognized by the command line of
+ Frama-C. If the [name] is the empty string, nothing is done.
+ [plugin] is the shortname of the plug-in.
+ [argname] is the name of the argument which can be used of the
+ description [help]. Both of them are used by the help of the
+ registered option. If [help] is [None], then the option is not shown
+ in the help.
+ @since Beryllium-20090601-beta1
+ @modify Carbon-20101201
+ @modify Oxygen-20120901 change type of ~help and add ~visible. *)
val add_option_without_action:
string ->
@@ -321,9 +321,9 @@ val add_aliases:
@since Carbon-20110201
@modify 22.0-Titanium add [visible] and [deprecated] arguments. *)
-val replace_option_setting:
+val replace_option_setting:
string -> plugin:string -> group:Group.t -> option_setting -> unit
-(** Replace the previously registered option setting.
+(** Replace the previously registered option setting.
@since Sodium-20150201 *)
val replace_option_help:
@@ -333,7 +333,7 @@ val replace_option_help:
(* ************************************************************************** *)
(** {2 Special parameters}
-(* ************************************************************************** *)
+ (* ************************************************************************** *)
Frama-c parameters depending on the command line argument and set at the
very beginning of the Frama-C initialization.
@@ -363,40 +363,40 @@ module Kernel_verbose_level: Level
(** @since Fluorine-20130401 *)
val kernel_debug_atleast_ref: (int -> bool) ref
- (** @since Boron-20100401 *)
+(** @since Boron-20100401 *)
val kernel_verbose_atleast_ref: (int -> bool) ref
- (** @since Boron-20100401 *)
+(** @since Boron-20100401 *)
val journal_enable: bool
- (** @since Beryllium-20090601-beta1 *)
+(** @since Beryllium-20090601-beta1 *)
val journal_isset: bool
- (** -journal-enable/disable explicitly set on the command line.
- @since Boron-20100401 *)
+(** -journal-enable/disable explicitly set on the command line.
+ @since Boron-20100401 *)
val use_obj: bool
- (** @since Beryllium-20090601-beta1 *)
+(** @since Beryllium-20090601-beta1 *)
val use_type: bool
- (** @since Beryllium-20090601-beta1 *)
+(** @since Beryllium-20090601-beta1 *)
val quiet: bool
- (** Must not be used for something else that initializing values
- @since Beryllium-20090601-beta1 *)
+(** Must not be used for something else that initializing values
+ @since Beryllium-20090601-beta1 *)
val deterministic: bool
- (** Indicates that the plugins should strive to be as deterministic as
- possible in their outputs. Higher memory consumption or analysis time
- are acceptable, as reproducibility is more important.
- @since Aluminium-20160501 *)
+(** Indicates that the plugins should strive to be as deterministic as
+ possible in their outputs. Higher memory consumption or analysis time
+ are acceptable, as reproducibility is more important.
+ @since Aluminium-20160501 *)
val permissive: bool
- (** Downgrades some command-line errors to warnings, such as
- unknown option names and invalid values for some options
- (e.g. non-existent function names).
+(** Downgrades some command-line errors to warnings, such as
+ unknown option names and invalid values for some options
+ (e.g. non-existent function names).
- @since 22.0-Titanium *)
+ @since 22.0-Titanium *)
val last_project_created_by_copy: (unit -> string option) ref
diff --git a/src/kernel_services/cmdline_parameters/parameter_category.ml b/src/kernel_services/cmdline_parameters/parameter_category.ml
index dfced5b072b95c0b550126011ae0f93978ec30f8..ff4cec1e4f1822f76e5020000f9a9c08d46984c6 100644
--- a/src/kernel_services/cmdline_parameters/parameter_category.ml
+++ b/src/kernel_services/cmdline_parameters/parameter_category.ml
@@ -21,47 +21,47 @@
(**************************************************************************)
type 'a accessor =
- < fold:'acc. ('a -> 'acc -> 'acc) -> 'acc -> 'acc (* folder on elements *);
- mem:('a -> bool) (* mem *) >
+ < fold:'acc. ('a -> 'acc -> 'acc) -> 'acc -> 'acc (* folder on elements *);
+ mem:('a -> bool) (* mem *) >
-type 'a category =
- { name: string;
- ty: 'a Type.t;
- fold: 'b. ('a -> 'b -> 'b) -> 'b -> 'b;
- mem: 'a -> bool;
- mutable states: State.t list }
+type 'a category =
+ { name: string;
+ ty: 'a Type.t;
+ fold: 'b. ('a -> 'b -> 'b) -> 'b -> 'b;
+ mem: 'a -> bool;
+ mutable states: State.t list }
type 'a t = 'a category
-module Categories = struct
+module Categories = struct
module By_name = Type.String_tbl(struct type 'a t = 'a category end)
(* categories are indexed by [ty] and [name].
To be typable, the [ty] is encoded by its digest, which is a string *)
let tbl
- : By_name.t Datatype.String.Hashtbl.t
- = Datatype.String.Hashtbl.create 7
+ : By_name.t Datatype.String.Hashtbl.t
+ = Datatype.String.Hashtbl.create 7
let check c =
try
let internal = Datatype.String.Hashtbl.find tbl (Type.digest c.ty) in
- try
- ignore (By_name.find internal c.name c.ty);
- (* just a warning for compatibility purpose: E.g if the kernel creates a
- new standard category at release N, then plug-ins which already
- create this category at release N-1 would be warned, but still work
- as before. *)
- Cmdline.Kernel_log.warning "overriding category `%s' for type `%s'"
- c.name
- (Type.name c.ty)
+ try
+ ignore (By_name.find internal c.name c.ty);
+ (* just a warning for compatibility purpose: E.g if the kernel creates a
+ new standard category at release N, then plug-ins which already
+ create this category at release N-1 would be warned, but still work
+ as before. *)
+ Cmdline.Kernel_log.warning "overriding category `%s' for type `%s'"
+ c.name
+ (Type.name c.ty)
with
| By_name.Unbound_value _ -> ()
| By_name.Incompatible_type _ -> assert false
with Not_found ->
()
- let add c =
+ let add c =
check c;
let internal =
try Datatype.String.Hashtbl.find tbl (Type.digest c.ty)
@@ -72,12 +72,12 @@ module Categories = struct
end
let create name ty ~register states (accessor: 'a accessor) =
- let c =
- { name;
- ty;
- fold = (fun x acc -> accessor#fold x acc);
- mem = accessor#mem;
- states }
+ let c =
+ { name;
+ ty;
+ fold = (fun x acc -> accessor#fold x acc);
+ mem = accessor#mem;
+ states }
in
if register then Categories.add c else Categories.check c;
c
diff --git a/src/kernel_services/cmdline_parameters/parameter_category.mli b/src/kernel_services/cmdline_parameters/parameter_category.mli
index ff8abd7fc5ea12f444e91deb08ae9aedc39b7fba..6b5aa21bbd99b9b954488604f4c22800ae8c4d1f 100644
--- a/src/kernel_services/cmdline_parameters/parameter_category.mli
+++ b/src/kernel_services/cmdline_parameters/parameter_category.mli
@@ -28,8 +28,8 @@ type 'a t
(** [\tau t] is the type of a category for the type \tau. *)
type 'a accessor =
- < fold:'acc. ('a -> 'acc -> 'acc) -> 'acc -> 'acc (* fold on elements *);
- mem:('a -> bool) (* mem *) >
+ < fold:'acc. ('a -> 'acc -> 'acc) -> 'acc -> 'acc (* fold on elements *);
+ mem:('a -> bool) (* mem *) >
(** Type explaining how to manipulate the elements of the category. *)
val create:
diff --git a/src/kernel_services/cmdline_parameters/parameter_customize.mli b/src/kernel_services/cmdline_parameters/parameter_customize.mli
index 94eb9f8ef022eb6fb9ef58e32c40ee8b765a3669..9ee8de2f3428c9a1891a66bf36c518ddd241f978 100644
--- a/src/kernel_services/cmdline_parameters/parameter_customize.mli
+++ b/src/kernel_services/cmdline_parameters/parameter_customize.mli
@@ -24,7 +24,7 @@
You can apply the functions below just before applying one of the functors
provided by the functor {!Plugin.Register} and generating a new
- parameter.
+ parameter.
@plugin development guide *)
@@ -43,22 +43,22 @@ val do_not_projectify: unit -> unit
@since Beryllium-20090601-beta1 *)
val do_not_reset_on_copy: unit -> unit
- (** Prevents resetting the parameter to its default value when creating
- a project from a copy visitor.
- @since Neon-20140301 *)
+(** Prevents resetting the parameter to its default value when creating
+ a project from a copy visitor.
+ @since Neon-20140301 *)
val do_not_save: unit -> unit
(** Prevent serialization of the parameter.
@since Carbon-20110201 *)
val set_negative_option_name: string -> unit
- (** For boolean parameters, set the name of the negative
- option generating automatically from the positive one (the given option
- name). The default used value prefixes the given option name by "-no".
- Assume that the given string is a valid option name or empty.
- If it is empty, no negative option is created.
- @since Beryllium-20090601-beta1
- @plugin development guide *)
+(** For boolean parameters, set the name of the negative
+ option generating automatically from the positive one (the given option
+ name). The default used value prefixes the given option name by "-no".
+ Assume that the given string is a valid option name or empty.
+ If it is empty, no negative option is created.
+ @since Beryllium-20090601-beta1
+ @plugin development guide *)
val set_negative_option_help: string -> unit
(** For boolean parameters, set the help message of the negative
@@ -67,23 +67,23 @@ val set_negative_option_help: string -> unit
@since Beryllium-20090601-beta1 *)
val set_unset_option_name: string -> unit
- (** For string collection parameters, set the name of an option that
- will remove elements from the set. There is no default value: if
- the this function is not called (or if it is the empty string),
- it will only be possible to add elements from the command line.
- @since Fluorine-20130401 *)
+(** For string collection parameters, set the name of an option that
+ will remove elements from the set. There is no default value: if
+ the this function is not called (or if it is the empty string),
+ it will only be possible to add elements from the command line.
+ @since Fluorine-20130401 *)
val set_unset_option_help: string -> unit
- (** For string collection parameters, gives the help message for
- the corresponding unset option. Useless if [set_unset_option_name]
- has not been called before. No default.
- @since Fluorine-20130401 *)
+(** For string collection parameters, gives the help message for
+ the corresponding unset option. Useless if [set_unset_option_name]
+ has not been called before. No default.
+ @since Fluorine-20130401 *)
val set_optional_help: (unit, Format.formatter, unit) format -> unit
- (** Concatenate an additional description just after the default one.
- @since Beryllium-20090601-beta1
- @deprecated since Oxygen-20120901: directly use the help string
- instead. *)
+(** Concatenate an additional description just after the default one.
+ @since Beryllium-20090601-beta1
+ @deprecated since Oxygen-20120901: directly use the help string
+ instead. *)
val set_group: Cmdline.Group.t -> unit
(** Affect a group to the parameter.
@@ -138,7 +138,7 @@ val is_not_reconfigurable: unit -> unit
{!Cmdline.Configuring} stage are reconfigurable.
@since Nitrogen-20111001
@modify 22.0-Titanium [do_iterate] renamed to [is_reconfigurable]
- *)
+*)
val no_category: unit -> unit
(** Prevent a collection parameter to use categories and the extension '+', and
@@ -146,7 +146,7 @@ val no_category: unit -> unit
the parameter is a list of '-' prefixed options to an external tool, unless
you are willing to let users escape the initial '-' everytime.
@since Sodium-20150201
- *)
+*)
(* ************************************************************************* *)
(** {2 Function names} *)
@@ -167,11 +167,11 @@ val get_c_ified_functions:
understand.
@since Sodium-20150201
- *)
+*)
val add_function_name_transformation:
(string -> Cil_datatype.Kf.Set.t) -> unit
-(**
+(**
Adds a mangling operation to allow writing user-friendly function names
on command-line. See {!get_c_ified_functions} for more information.
@since Sodium-20150201
diff --git a/src/kernel_services/cmdline_parameters/parameter_state.ml b/src/kernel_services/cmdline_parameters/parameter_state.ml
index c7c05928ff1b048200c5a81bdcbd9224aec4b5b0..ef573c3064fe0d8bea3c63b3039249ee5b3e363f 100644
--- a/src/kernel_services/cmdline_parameters/parameter_state.ml
+++ b/src/kernel_services/cmdline_parameters/parameter_state.ml
@@ -74,13 +74,13 @@ let extend_no_reset_selection is_set s =
(* ************************************************************************* *)
module Make
- (P: sig val shortname: string end)
- (X: sig
- include Datatype.S
- val default: unit -> t
- val option_name: string
- val functor_name: string
- end) =
+ (P: sig val shortname: string end)
+ (X: sig
+ include Datatype.S
+ val default: unit -> t
+ val option_name: string
+ val functor_name: string
+ end) =
struct
let is_dynamic = true
@@ -95,18 +95,18 @@ struct
let () = match !Parameter_customize.cmdline_stage_ref with
| Cmdline.Early | Cmdline.Extending | Cmdline.Extended
| Cmdline.Exiting | Cmdline.Loading ->
- Parameter_customize.do_not_projectify ()
+ Parameter_customize.do_not_projectify ()
| Cmdline.Configuring ->
- ()
+ ()
(* quite an inlining of [State_builder.Ref]; but handle [projectify_ref] *)
module Option_state_builder
- (X:sig
- include Datatype.S
- val unique_name: string
- val pretty_name: string
- val default: unit -> t
- end) =
+ (X:sig
+ include Datatype.S
+ val unique_name: string
+ val pretty_name: string
+ val default: unit -> t
+ end) =
struct
type data = X.t
@@ -115,24 +115,24 @@ struct
let state = ref (create ())
include State_builder.Register
- (struct
- include Datatype.Ref(X)
- let descr = if must_save then descr else Descr.unmarshable
- end)
- (struct
- type t = data ref
- let get () = !state
- let create = if projectify then create else (* do an alias *) get
- let clear x = if projectify then x := X.default ()
- let set x =
- if projectify then state := x (* else there is already an alias *)
- let clear_some_projects = Datatype.never_any_project
- end)
- (struct
- let name = X.pretty_name
- let unique_name = X.unique_name
- let dependencies = []
- end)
+ (struct
+ include Datatype.Ref(X)
+ let descr = if must_save then descr else Descr.unmarshable
+ end)
+ (struct
+ type t = data ref
+ let get () = !state
+ let create = if projectify then create else (* do an alias *) get
+ let clear x = if projectify then x := X.default ()
+ let set x =
+ if projectify then state := x (* else there is already an alias *)
+ let clear_some_projects = Datatype.never_any_project
+ end)
+ (struct
+ let name = X.pretty_name
+ let unique_name = X.unique_name
+ let dependencies = []
+ end)
let set v = !state := v
let get () = !(!state)
@@ -149,13 +149,13 @@ struct
if X.option_name = "" then "Input C files" else X.option_name
let unique_name = option_name
let pretty_name = option_name
- end)
+ end)
module D = Datatype
include Internal_state
type t = Internal_state.data
- let () =
+ let () =
extend_selection false self;
if not reset_on_copy then extend_no_reset_selection false self
@@ -165,10 +165,10 @@ struct
Option_state_builder
(struct
include D.Bool
- let pretty_name = X.option_name ^ " is set"
- let unique_name = pretty_name
- let default () = false
- end)
+ let pretty_name = X.option_name ^ " is set"
+ let unique_name = pretty_name
+ let default () = false
+ end)
let () =
State_dependency_graph.add_dependencies ~from:Is_set.self [ self ];
extend_selection true Is_set.self;
@@ -181,9 +181,9 @@ struct
add_set_hook f;
add_hook_on_update
(fun x ->
- let old = get () in
- let new_ = !x in
- if not (X.equal old new_) then f old new_)
+ let old = get () in
+ let new_ = !x in
+ if not (X.equal old new_) then f old new_)
let gen_journalized name ty set =
let name =
@@ -232,7 +232,7 @@ struct
let journalized_force_set = gen_journalized "set" X.ty force_set
- let set x =
+ let set x =
Is_set.set true;
if not (X.equal x (Internal_state.get ())) then journalized_force_set x
diff --git a/src/kernel_services/cmdline_parameters/parameter_state.mli b/src/kernel_services/cmdline_parameters/parameter_state.mli
index 0401aad7f9c3943227191053ed1de88b1605eaec..84cd77407c8d57b096aee520860932d7904bee2e 100644
--- a/src/kernel_services/cmdline_parameters/parameter_state.mli
+++ b/src/kernel_services/cmdline_parameters/parameter_state.mli
@@ -29,16 +29,16 @@ val get_selection_context: ?is_set:bool -> unit -> State_selection.t
analysis. *)
val get_selection: ?is_set:bool -> unit -> State_selection.t
- (** Selection of all the settable parameters.
- [is_set] is [true] by default (for backward compatibility): in such a
- case, for each option, the extra internal state indicating whether it is
- set also belongs to the selection.
- @plugin development guide *)
+(** Selection of all the settable parameters.
+ [is_set] is [true] by default (for backward compatibility): in such a
+ case, for each option, the extra internal state indicating whether it is
+ set also belongs to the selection.
+ @plugin development guide *)
val get_reset_selection: ?is_set:bool -> unit -> State_selection.t
- (** Selection of resettable parameters in case of copy with a visitor.
- Not for casual user.
- @since Neon-20140301 *)
+(** Selection of resettable parameters in case of copy with a visitor.
+ Not for casual user.
+ @since Neon-20140301 *)
(**/**)
@@ -47,13 +47,13 @@ val get_reset_selection: ?is_set:bool -> unit -> State_selection.t
(* ************************************************************************* *)
module Make
- (P: sig val shortname: string end)
- (X:sig
- include Datatype.S
- val default: unit -> t
- val option_name: string
- val functor_name: string
- end):
+ (P: sig val shortname: string end)
+ (X:sig
+ include Datatype.S
+ val default: unit -> t
+ val option_name: string
+ val functor_name: string
+ end):
sig
include Parameter_sig.S_no_parameter with type t = X.t
module Is_set: State_builder.S
@@ -61,7 +61,7 @@ sig
val stage: Cmdline.stage
val is_visible: bool
val is_dynamic: bool
- val register_dynamic:
+ val register_dynamic:
string -> 'arg Type.t -> 'ret Type.t -> ('arg -> 'ret) -> 'arg -> 'ret
val gen_journalized: string -> 'arg Type.t -> ('arg -> unit) -> 'arg -> unit
end
diff --git a/src/kernel_services/cmdline_parameters/typed_parameter.ml b/src/kernel_services/cmdline_parameters/typed_parameter.ml
index 9221f8263acb233f2ed62d4ca68f215292acce96..c5aa2669794438698ffbff0b3798edd3bf9c6ade 100644
--- a/src/kernel_services/cmdline_parameters/typed_parameter.ml
+++ b/src/kernel_services/cmdline_parameters/typed_parameter.ml
@@ -20,26 +20,26 @@
(* *)
(**************************************************************************)
-type ('a, 'b) gen_accessor =
- { get: unit -> 'a;
- set: 'a -> unit;
- add_set_hook: ('b -> 'b -> unit) -> unit;
- add_update_hook: ('b -> 'b -> unit) -> unit }
+type ('a, 'b) gen_accessor =
+ { get: unit -> 'a;
+ set: 'a -> unit;
+ add_set_hook: ('b -> 'b -> unit) -> unit;
+ add_update_hook: ('b -> 'b -> unit) -> unit }
type 'a accessor = ('a, 'a) gen_accessor
-type typed_accessor =
+type typed_accessor =
| Bool of bool accessor * string option (** the negative option, if any *)
| Int of int accessor * (unit -> int * int) (** getting range *)
| String of string accessor * (unit -> string list) (** possible values *)
-type parameter =
- { name: string;
- help: string;
- accessor: typed_accessor;
- visible: bool;
- reconfigurable: bool;
- is_set: unit -> bool }
+type parameter =
+ { name: string;
+ help: string;
+ accessor: typed_accessor;
+ visible: bool;
+ reconfigurable: bool;
+ is_set: unit -> bool }
include
Datatype.Make_with_collections
@@ -48,16 +48,16 @@ include
let name = "Parameter.t"
let rehash = Datatype.identity
let structural_descr = Structural_descr.t_unknown
- let reprs =
+ let reprs =
[ { name = "bool_opt";
help = "dummy bool option";
- accessor =
- Bool
- ({ get = (fun () -> false);
- set = (fun _ -> ());
- add_set_hook = (fun _ -> ());
- add_update_hook = (fun _ -> ()) },
- None);
+ accessor =
+ Bool
+ ({ get = (fun () -> false);
+ set = (fun _ -> ());
+ add_set_hook = (fun _ -> ());
+ add_update_hook = (fun _ -> ()) },
+ None);
visible = false ;
reconfigurable = false ;
is_set = fun () -> false }
@@ -68,13 +68,13 @@ include
let copy x = x (* The representation of the parameter is immutable *)
let pretty fmt x = Format.pp_print_string fmt x.name
let internal_pretty_code = Datatype.undefined
- let varname _ = assert false
- (* unused if internal_pretty_code undefined *)
+ let varname _ = assert false
+ (* unused if internal_pretty_code undefined *)
let mem_project = Datatype.never_any_project
- end)
+ end)
let parameters = Datatype.String.Hashtbl.create 97
-
+
let create ~name ~help ~accessor ~visible ~reconfigurable ~is_set =
let p = { name; help; accessor; visible; reconfigurable; is_set } in
(* parameter name unicity already checks in [Plugin]. *)
@@ -90,7 +90,7 @@ let pretty_value fmt p = match p.accessor with
| String(a, _) -> Format.fprintf fmt "%s" (a.get ())
let get_value p = Format.asprintf "%a" pretty_value p
-
+
(*
Local Variables:
compile-command: "make -C ../../.."
diff --git a/src/kernel_services/cmdline_parameters/typed_parameter.mli b/src/kernel_services/cmdline_parameters/typed_parameter.mli
index 0be0df53744d56a9ecff6f77846b22de93e68d5f..565f030a23b9957a462fdc2a50c7c0cd76f40973 100644
--- a/src/kernel_services/cmdline_parameters/typed_parameter.mli
+++ b/src/kernel_services/cmdline_parameters/typed_parameter.mli
@@ -25,11 +25,11 @@
developer, you certainly prefer to use the API of {!Plugin} instead.
@since Nitrogen-20111001 *)
-type ('a, 'b) gen_accessor =
- { get: unit -> 'a;
- set: 'a -> unit;
- add_set_hook: ('b -> 'b -> unit) -> unit;
- add_update_hook: ('b -> 'b -> unit) -> unit }
+type ('a, 'b) gen_accessor =
+ { get: unit -> 'a;
+ set: 'a -> unit;
+ add_set_hook: ('b -> 'b -> unit) -> unit;
+ add_update_hook: ('b -> 'b -> unit) -> unit }
type 'a accessor = ('a, 'a) gen_accessor
@@ -39,15 +39,15 @@ type typed_accessor =
| String of string accessor * (unit -> string list) (** possible values *)
type parameter = private
- { name: string; (** Name of the option corresponding to the parameter.
- It is exactly the state name of the option (see
- {!State.get_name}). *)
- help: string; (** Help message *)
- accessor: typed_accessor; (** How to get and set the value of the
- parameter *)
- visible: bool; (** Is visible to the user, e.g. in the command-line help *)
- reconfigurable: bool; (** Can be reconfigured, e.g. in the GUI *)
- is_set: unit -> bool (** Is this option really set? *) }
+ { name: string; (** Name of the option corresponding to the parameter.
+ It is exactly the state name of the option (see
+ {!State.get_name}). *)
+ help: string; (** Help message *)
+ accessor: typed_accessor; (** How to get and set the value of the
+ parameter *)
+ visible: bool; (** Is visible to the user, e.g. in the command-line help *)
+ reconfigurable: bool; (** Can be reconfigured, e.g. in the GUI *)
+ is_set: unit -> bool (** Is this option really set? *) }
include Datatype.S_with_collections with type t = parameter
@@ -59,9 +59,9 @@ val get_value: t -> string
(**/**)
(** Not for casual users. Use API of {!Plugin} instead. *)
-val create:
- name:string ->
- help:string ->
+val create:
+ name:string ->
+ help:string ->
accessor:typed_accessor ->
visible:bool ->
reconfigurable:bool ->
diff --git a/src/kernel_services/parsetree/cabshelper.ml b/src/kernel_services/parsetree/cabshelper.ml
index 98bfca99fad1154402b5b27145a88793feab1e91..6ceeedb4f04e8a71592880ba5ac3cd10a2f01561 100644
--- a/src/kernel_services/parsetree/cabshelper.ml
+++ b/src/kernel_services/parsetree/cabshelper.ml
@@ -45,82 +45,82 @@ open Cabs
let nextident = ref 0
let getident () =
- nextident := !nextident + 1;
- !nextident
+ nextident := !nextident + 1;
+ !nextident
let cabslu = Cil_datatype.Location.unknown
module Comments =
- struct
- module MapDest = struct
- include Datatype.List(Datatype.Pair(Cil_datatype.Position)(Datatype.String))
- let fast_equal (_:t) (_:t) = false
- end
- module MyTable =
- Rangemap.Make
- (Cil_datatype.Position)
- (MapDest)
- module MyState =
- State_builder.Ref
- (MyTable)
- (struct
- let name = "Cabshelper.Comments"
- let dependencies = [ ]
- (* depends from File.self and Ast.self which add
- the dependency themselves. *)
- let default () = MyTable.empty
- end)
- let self = MyState.self
- let () = Cil.dependency_on_ast self
+struct
+ module MapDest = struct
+ include Datatype.List(Datatype.Pair(Cil_datatype.Position)(Datatype.String))
+ let fast_equal (_:t) (_:t) = false
+ end
+ module MyTable =
+ Rangemap.Make
+ (Cil_datatype.Position)
+ (MapDest)
+ module MyState =
+ State_builder.Ref
+ (MyTable)
+ (struct
+ let name = "Cabshelper.Comments"
+ let dependencies = [ ]
+ (* depends from File.self and Ast.self which add
+ the dependency themselves. *)
+ let default () = MyTable.empty
+ end)
+ let self = MyState.self
+ let () = Cil.dependency_on_ast self
- (* What matters is the beginning of the comment. *)
- let add (first,last) comment =
- let state = MyState.get () in
- let acc = try MyTable.find first state with Not_found -> [] in
- MyState.set ((MyTable.add first ((last,comment)::acc)) state)
+ (* What matters is the beginning of the comment. *)
+ let add (first,last) comment =
+ let state = MyState.get () in
+ let acc = try MyTable.find first state with Not_found -> [] in
+ MyState.set ((MyTable.add first ((last,comment)::acc)) state)
- let get (first,last) =
- let open Cil_datatype in
- Kernel.debug ~dkey:Kernel.dkey_comments
- "Searching for comments between positions %a and %a@."
- Position.pretty first
- Position.pretty last;
- if Position.equal first Position.unknown ||
- Position.equal last Position.unknown
- then begin
- Kernel.debug ~dkey:Kernel.dkey_comments "skipping dummy position@.";
- []
- end else
- let r = MyTable.fold_range
- (fun pos ->
- match Cil_datatype.Position.compare first pos with
- | n when n > 0 -> Rangemap.Below
- | 0 -> Rangemap.Match
- | _ ->
- if Cil_datatype.Position.compare pos last <= 0 then
- Rangemap.Match
- else
- Rangemap.Above)
- (fun _ comments acc -> acc @ List.rev_map snd comments)
- (MyState.get ())
- []
- in
- Kernel.debug ~dkey:Kernel.dkey_comments "%d results@." (List.length r);
- r
-
- let iter f =
- MyTable.iter
- (fun first comments ->
- List.iter (fun (last,comment) -> f (first,last) comment) comments)
- (MyState.get())
+ let get (first,last) =
+ let open Cil_datatype in
+ Kernel.debug ~dkey:Kernel.dkey_comments
+ "Searching for comments between positions %a and %a@."
+ Position.pretty first
+ Position.pretty last;
+ if Position.equal first Position.unknown ||
+ Position.equal last Position.unknown
+ then begin
+ Kernel.debug ~dkey:Kernel.dkey_comments "skipping dummy position@.";
+ []
+ end else
+ let r = MyTable.fold_range
+ (fun pos ->
+ match Cil_datatype.Position.compare first pos with
+ | n when n > 0 -> Rangemap.Below
+ | 0 -> Rangemap.Match
+ | _ ->
+ if Cil_datatype.Position.compare pos last <= 0 then
+ Rangemap.Match
+ else
+ Rangemap.Above)
+ (fun _ comments acc -> acc @ List.rev_map snd comments)
+ (MyState.get ())
+ []
+ in
+ Kernel.debug ~dkey:Kernel.dkey_comments "%d results@." (List.length r);
+ r
+
+ let iter f =
+ MyTable.iter
+ (fun first comments ->
+ List.iter (fun (last,comment) -> f (first,last) comment) comments)
+ (MyState.get())
+
+ let fold f acc =
+ MyTable.fold
+ (fun first comments acc ->
+ List.fold_left
+ (fun acc (last,comment) -> f (first,last) comment acc) acc comments)
+ (MyState.get()) acc
- let fold f acc =
- MyTable.fold
- (fun first comments acc ->
- List.fold_left
- (fun acc (last,comment) -> f (first,last) comment acc) acc comments)
- (MyState.get()) acc
-
end
(*********** HELPER FUNCTIONS **********)
@@ -162,34 +162,34 @@ let get_definitionloc (d : definition) : cabsloc =
| CUSTOM (_,_,l) -> l
let get_statementloc (s : statement) : cabsloc =
-begin
- match s.stmt_node with
- | NOP(loc) -> loc
- | COMPUTATION(_,loc) -> loc
- | BLOCK(_,loc,_) -> loc
- | SEQUENCE(_,_,loc) -> loc
- | IF(_,_,_,loc) -> loc
- | WHILE(_,_,_,loc) -> loc
- | DOWHILE(_,_,_,loc) -> loc
- | FOR(_,_,_,_,_,loc) -> loc
- | BREAK(loc) -> loc
- | CONTINUE(loc) -> loc
- | RETURN(_,loc) -> loc
- | SWITCH(_,_,loc) -> loc
- | CASE(_,_,loc) -> loc
- | CASERANGE(_,_,_,loc) -> loc
- | DEFAULT(_,loc) -> loc
- | LABEL(_,_,loc) -> loc
- | GOTO(_,loc) -> loc
- | COMPGOTO (_, loc) -> loc
- | DEFINITION d -> get_definitionloc d
- | ASM(_,_,_,loc) -> loc
- | TRY_EXCEPT(_, _, _, loc) -> loc
- | TRY_FINALLY(_, _, loc) -> loc
- | (CODE_SPEC (_,l) |CODE_ANNOT (_,l)) -> l
- | THROW(_,l) -> l
- | TRY_CATCH(_,_,l) -> l
-end
+ begin
+ match s.stmt_node with
+ | NOP(loc) -> loc
+ | COMPUTATION(_,loc) -> loc
+ | BLOCK(_,loc,_) -> loc
+ | SEQUENCE(_,_,loc) -> loc
+ | IF(_,_,_,loc) -> loc
+ | WHILE(_,_,_,loc) -> loc
+ | DOWHILE(_,_,_,loc) -> loc
+ | FOR(_,_,_,_,_,loc) -> loc
+ | BREAK(loc) -> loc
+ | CONTINUE(loc) -> loc
+ | RETURN(_,loc) -> loc
+ | SWITCH(_,_,loc) -> loc
+ | CASE(_,_,loc) -> loc
+ | CASERANGE(_,_,_,loc) -> loc
+ | DEFAULT(_,loc) -> loc
+ | LABEL(_,_,loc) -> loc
+ | GOTO(_,loc) -> loc
+ | COMPGOTO (_, loc) -> loc
+ | DEFINITION d -> get_definitionloc d
+ | ASM(_,_,_,loc) -> loc
+ | TRY_EXCEPT(_, _, _, loc) -> loc
+ | TRY_FINALLY(_, _, loc) -> loc
+ | (CODE_SPEC (_,l) |CODE_ANNOT (_,l)) -> l
+ | THROW(_,l) -> l
+ | TRY_CATCH(_,_,l) -> l
+ end
let explodeStringToInts (s: string) : int64 list =
@@ -202,7 +202,7 @@ let explodeStringToInts (s: string) : int64 list =
let valueOfDigit chr =
let int_value =
match chr with
- '0'..'9' -> (Char.code chr) - (Char.code '0')
+ '0'..'9' -> (Char.code chr) - (Char.code '0')
| 'a'..'z' -> (Char.code chr) - (Char.code 'a') + 10
| 'A'..'Z' -> (Char.code chr) - (Char.code 'A') + 10
| _ -> Kernel.fatal "not a digit"
@@ -238,9 +238,9 @@ let mk_asm_templates =
| [] when res = [] && Buffer.length buf = 0 -> [""]
| [] when Buffer.length buf = 0 -> List.rev res
| [] ->
- let res = List.rev @@ Buffer.contents buf :: res in
- Buffer.clear buf;
- res
+ let res = List.rev @@ Buffer.contents buf :: res in
+ Buffer.clear buf;
+ res
| str :: tail -> tail |> outer @@ inner res str 0
and inner res template i =
if i < String.length template then
@@ -250,15 +250,15 @@ let mk_asm_templates =
if i < String.length template - 1 then
match String.get template @@ i + 1 with
| '\t' ->
- Buffer.add_char buf '\t';
- let res = Buffer.contents buf :: res in
- Buffer.clear buf;
- inner res template @@ i + 2
+ Buffer.add_char buf '\t';
+ let res = Buffer.contents buf :: res in
+ Buffer.clear buf;
+ inner res template @@ i + 2
| c ->
- let res = Buffer.contents buf :: res in
- Buffer.clear buf;
- Buffer.add_char buf c;
- inner res template @@ i + 2
+ let res = Buffer.contents buf :: res in
+ Buffer.clear buf;
+ Buffer.add_char buf c;
+ inner res template @@ i + 2
else
let res = Buffer.contents buf :: res in
Buffer.clear buf;
diff --git a/src/kernel_services/parsetree/cabshelper.mli b/src/kernel_services/parsetree/cabshelper.mli
index 458c01febc4a9f2eb6b482b78cd1d48e7dda3ab8..cd3aaa56962b668e8dd4c7c6e6049afe9c1476b1 100644
--- a/src/kernel_services/parsetree/cabshelper.mli
+++ b/src/kernel_services/parsetree/cabshelper.mli
@@ -53,7 +53,7 @@ module Comments: sig
val self: State.t
(* adds a comment at a given location. *)
val add: Cabs.cabsloc -> string -> unit
- (* gets all the comment located between the two positions. *)
+ (* gets all the comment located between the two positions. *)
val get: Cabs.cabsloc -> string list
(* iter over all registered comments. *)
val iter: (Cabs.cabsloc -> string -> unit) -> unit
diff --git a/src/kernel_services/parsetree/logic_ptree.mli b/src/kernel_services/parsetree/logic_ptree.mli
index e3c35f61facb2f144660b9b35cdf876f42cece9d..7d991ee30f09194f5fbacbbcae2644cf6557852b 100644
--- a/src/kernel_services/parsetree/logic_ptree.mli
+++ b/src/kernel_services/parsetree/logic_ptree.mli
@@ -79,7 +79,7 @@ type lexpr = {
(* PL is for Parsed Logic *)
(** kind of expression. *)
and path_elt =
- (** construct inside a functional update. *)
+ (** construct inside a functional update. *)
| PLpathField of string
| PLpathIndex of lexpr
@@ -87,10 +87,10 @@ and update_term =
| PLupdateTerm of lexpr
| PLupdateCont of ((path_elt list) * update_term) list
and lexpr_node =
- (* both terms and predicates *)
+ (* both terms and predicates *)
| PLvar of string (** a variable *)
| PLapp of string * string list * lexpr list (** an application. *)
- (* terms *)
+ (* terms *)
| PLlambda of quantifiers * lexpr (** a lambda abstraction. *)
| PLlet of string * lexpr * lexpr (** local binding. *)
| PLconstant of constant (** a constant. *)
@@ -108,12 +108,12 @@ and lexpr_node =
| PLsizeof of logic_type (** sizeof a type. *)
| PLsizeofE of lexpr (** sizeof the type of an expression. *)
| PLupdate of lexpr * (path_elt list) * update_term
- (** functional update of the field of a structure. *)
+ (** functional update of the field of a structure. *)
| PLinitIndex of (lexpr * lexpr) list (** array constructor. *)
| PLinitField of (string * lexpr) list (** struct/union constructor. *)
| PLtypeof of lexpr (** type tag for an expression. *)
| PLtype of logic_type (** type tag for a C type. *)
- (* predicates *)
+ (* predicates *)
| PLfalse (** false (either as a term or a predicate. *)
| PLtrue (** true (either as a term or a predicate. *)
| PLrel of lexpr * relation * lexpr (** comparison operator. *)
@@ -129,7 +129,7 @@ and lexpr_node =
| PLbase_addr of string option * lexpr (** base address of a pointer. *)
| PLoffset of string option * lexpr (** base address of a pointer. *)
| PLblock_length of string option * lexpr (** length of the block pointed to by an
- expression. *)
+ expression. *)
| PLvalid of string option * lexpr (** pointer is valid. *)
| PLvalid_read of string option * lexpr (** pointer is valid for reading. *)
| PLobject_pointer of string option * lexpr (** object pointer can be created. *)
@@ -142,24 +142,24 @@ and lexpr_node =
dangling *)
| PLfresh of (string * string) option * lexpr * lexpr (** expression points to a newly allocated block. *)
| PLseparated of lexpr list
- (** separation predicate. *)
+ (** separation predicate. *)
| PLnamed of string * lexpr (** named expression. *)
- (* tsets *)
+ (* tsets *)
| PLcomprehension of lexpr * quantifiers * lexpr option
- (** set of expression defined in comprehension
- ({t \{ e | integer i; P(i)\}})*)
+ (** set of expression defined in comprehension
+ ({t \{ e | integer i; P(i)\}})*)
| PLset of lexpr list
- (** sets of elements. *)
+ (** sets of elements. *)
| PLunion of lexpr list
- (** union of sets. *)
+ (** union of sets. *)
| PLinter of lexpr list
- (** intersection of sets. *)
+ (** intersection of sets. *)
| PLempty
- (** empty set. *)
+ (** empty set. *)
| PLlist of lexpr list
- (** list of elements. *)
+ (** list of elements. *)
| PLrepeat of lexpr * lexpr
- (** repeat a list of elements a number of times. *)
+ (** repeat a list of elements a number of times. *)
type toplevel_predicate =
{ tp_kind: Cil_types.predicate_kind; tp_statement: lexpr }
@@ -177,12 +177,12 @@ type type_annot = {inv_name: string;
type model_annot = {model_for_type: logic_type;
model_type : logic_type;
model_name: string; (** name of the model field. *)
- }
+ }
(** Concrete type definition. *)
type typedef =
| TDsum of (string * logic_type list) list
- (** sum type, list of constructors *)
+ (** sum type, list of constructors *)
| TDsyn of logic_type (** synonym of an existing type *)
(** global declarations. *)
@@ -193,61 +193,61 @@ type decl = {
and decl_node =
| LDlogic_def of
string * string list * string list *
- logic_type * (logic_type * string) list * lexpr
- (** [LDlogic_def(name,labels,type_params,
- return_type, parameters, definition)]
- represents the definition of a logic function [name] whose
- return type is [return_type] and arguments are [parameters].
- Its label arguments are [labels]. Polymorphic functions have
- their type parameters in [type_params]. [definition] is the
- body of the defined function.*)
+ logic_type * (logic_type * string) list * lexpr
+ (** [LDlogic_def(name,labels,type_params,
+ return_type, parameters, definition)]
+ represents the definition of a logic function [name] whose
+ return type is [return_type] and arguments are [parameters].
+ Its label arguments are [labels]. Polymorphic functions have
+ their type parameters in [type_params]. [definition] is the
+ body of the defined function.*)
| LDlogic_reads of
string * string list * string list *
- logic_type * (logic_type * string) list * lexpr list option
- (** [LDlogic_reads(name,labels,type_params,
- return_type, parameters, reads_tsets)] represents the declaration
- of logic function. It has the same
- arguments as [LDlogic_def], except that the definition is
- abstracted to a set of read accesses in [read_tsets].
- *)
+ logic_type * (logic_type * string) list * lexpr list option
+ (** [LDlogic_reads(name,labels,type_params,
+ return_type, parameters, reads_tsets)] represents the declaration
+ of logic function. It has the same
+ arguments as [LDlogic_def], except that the definition is
+ abstracted to a set of read accesses in [read_tsets].
+ *)
| LDtype of string * string list * typedef option
- (** new logic type and its parameters, optionally followed by
- its definition. *)
+ (** new logic type and its parameters, optionally followed by
+ its definition. *)
| LDpredicate_reads of
string * string list * string list *
- (logic_type * string) list * lexpr list option
- (** [LDpredicate_reads(name,labels,type_params,
- parameters, reads_tsets)]
- represents the declaration of a new predicate. It is similar to
- [LDlogic_reads] except that it has no [return_type].
- *)
+ (logic_type * string) list * lexpr list option
+ (** [LDpredicate_reads(name,labels,type_params,
+ parameters, reads_tsets)]
+ represents the declaration of a new predicate. It is similar to
+ [LDlogic_reads] except that it has no [return_type].
+ *)
| LDpredicate_def of string * string list * string list *
- (logic_type * string) list * lexpr
- (** [LDpredicate_def(name,labels,type_params, parameters, def)]
- represents the definition of a new predicate. It is similar to
- [LDlogic_def] except that it has no [return_type].
+ (logic_type * string) list * lexpr
+ (** [LDpredicate_def(name,labels,type_params, parameters, def)]
+ represents the definition of a new predicate. It is similar to
+ [LDlogic_def] except that it has no [return_type].
- *)
+ *)
| LDinductive_def of string * string list * string list *
- (logic_type * string) list * (string * string list * string list * lexpr) list
- (** [LDinductive_def(name,labels,type_params, parameters, indcases)]
- represents an inductive definition of a new predicate.
- *)
+ (logic_type * string) list * (string * string list * string list * lexpr) list
+ (** [LDinductive_def(name,labels,type_params, parameters, indcases)]
+ represents an inductive definition of a new predicate.
+ *)
| LDlemma of string * string list * string list * toplevel_predicate
- (** LDlemma(name,labels,type_params,property) represents axioms and
- lemmas. Axioms and admit lemmas are fusionned.
- [labels] is the list of label arguments and
- [type_params] the list of type parameters.
- Last, [property] is the statement of the lemma.
- *)
+ (** LDlemma(name,labels,type_params,property) represents axioms and
+ lemmas. Axioms and admit lemmas are fusionned.
+ [labels] is the list of label arguments and
+ [type_params] the list of type parameters.
+ Last, [property] is the statement of the lemma.
+ *)
| LDaxiomatic of string * decl list
- (** [LDaxiomatic(id,decls)]
- represents a block of axiomatic definitions.*)
+ (** [LDaxiomatic(id,decls)]
+ represents a block of axiomatic definitions.*)
| LDinvariant of string * lexpr (** global invariant. *)
| LDtype_annot of type_annot (** type invariant. *)
| LDmodel_annot of model_annot (** model field. *)
| LDvolatile of lexpr list * (string option * string option)
- (** volatile clause read/write. *)
+ (** volatile clause read/write. *)
| LDextended of global_extension (** extended global annotation. *)
@@ -262,14 +262,14 @@ and from = (lexpr * deps)
and assigns =
| WritesAny (** Nothing specified. Anything can be written. *)
| Writes of from list
- (** list of locations that can be written. Empty list means \nothing. *)
+ (** list of locations that can be written. Empty list means \nothing. *)
-(** allocates and frees.
+(** allocates and frees.
@since Oxygen-20120901 *)
and allocation =
| FreeAlloc of lexpr list * lexpr list (** tsets. Empty list means \nothing. *)
- | FreeAllocAny (** Nothing specified. Semantics depends on where it
- is written. *)
+ | FreeAllocAny (** Nothing specified. Semantics depends on where it
+ is written. *)
(** variant of a loop or a recursive function. *)
and variant = lexpr * string option
@@ -315,7 +315,7 @@ type spec = {
mutable spec_disjoint_behaviors: string list list;
(** list of disjoint behaviors.
- It is possible to have more than one set of disjoint behaviors *)
+ It is possible to have more than one set of disjoint behaviors *)
}
(** Pragmas for the value analysis plugin of Frama-C. *)
@@ -374,10 +374,10 @@ type code_annot =
| APragma of pragma (** pragma. *)
| AExtended of string list * bool * extension
- (** extension in a code or loop (when boolean flag is true) annotation.
- @since Silicon-20161101
- @modify 18.0-Argon
- *)
+ (** extension in a code or loop (when boolean flag is true) annotation.
+ @since Silicon-20161101
+ @modify 18.0-Argon
+ *)
(** custom trees *)
@@ -392,7 +392,7 @@ type annot =
| Aspec (* the real spec is parsed afterwards.
See cparser.mly (grammar rules involving SPEC) for
more details.
- *) (** function specification. *)
+ *) (** function specification. *)
| Acode_annot of location * code_annot (** code annotation. *)
| Aloop_annot of location * code_annot list (** loop annotation. *)
| Aattribute_annot of location * string (** attribute annotation. *)
@@ -404,7 +404,7 @@ type ext_decl =
| Ext_macro of bool * string * lexpr (* lexpr contains a location *)
| Ext_include of bool * string * location
-type ext_function =
+type ext_function =
| Ext_spec of spec * location (* function spec *)
| Ext_stmt of string list * annot * location (* loop/code annotation. *)
| Ext_glob of ext_decl
diff --git a/src/kernel_services/plugin_entry_points/db.ml b/src/kernel_services/plugin_entry_points/db.ml
index 3cad7ef4576845f79aea542c9a061d4360a4a94e..298ad6fe8eed25d5da9f1c0a0b0d8d56141dd2cf 100644
--- a/src/kernel_services/plugin_entry_points/db.ml
+++ b/src/kernel_services/plugin_entry_points/db.ml
@@ -34,7 +34,7 @@ let register how_to_journalize r f =
| Journalize (name, ty) -> r := Journal.register ("!Db." ^ name) ty f
| Journalization_not_required -> r := f
| Journalization_must_not_happen name ->
- r := Journal.never_write ("!Db." ^ name) f
+ r := Journal.never_write ("!Db." ^ name) f
let register_compute name deps r f =
let name = "!Db." ^ name in
@@ -126,7 +126,7 @@ end
(** State_builder.of operational inputs
- over-approximation of zones whose input values are read by each function,
- State_builder.of sure outputs
+ State_builder.of sure outputs
- under-approximation of zones written by each function. *)
module Operational_inputs = struct
type t = Inout_type.t
@@ -136,7 +136,7 @@ module Operational_inputs = struct
let display = mk_fun "Operational_inputs.display"
let get_internal = mk_fun "Operational_inputs.get_internal"
let get_internal_precise = ref (fun ?stmt:_ _ ->
- failwith ("Db.Operational_inputs.get_internal_precise not implemented"))
+ failwith ("Db.Operational_inputs.get_internal_precise not implemented"))
let get_external = mk_fun "Operational_inputs.get_external"
module Record_Inout_Callbacks =
@@ -194,7 +194,7 @@ module Value = struct
let name = "Db.Value.fun_args"
let dependencies =
[ Ast.self; Kernel.LibEntry.self; Kernel.MainFunction.self]
- end)
+ end)
let () = Ast.add_monotonic_state FunArgs.self
@@ -206,7 +206,7 @@ module Value = struct
let fun_set_args =
let module L = Datatype.List(Cvalue.V) in
Journal.register "(failwith \"Function cannot be journalized: \
- Db.Value.fun_set_args\" : _ -> unit)"
+ Db.Value.fun_set_args\" : _ -> unit)"
(Datatype.func L.ty Datatype.unit)
(fun l ->
if
@@ -231,14 +231,14 @@ module Value = struct
State_builder.Option_ref
(Cvalue.Model)
(struct
- let name = "Db.Value.Vglobals"
- let dependencies = [Ast.self]
- end)
+ let name = "Db.Value.Vglobals"
+ let dependencies = [Ast.self]
+ end)
(* This function is *not* journalized *)
let globals_set_initial_state =
Journal.register "(failwith \"Function cannot be journalized: \
- Db.Value.globals_set_initial_state\" : _ -> unit)"
+ Db.Value.globals_set_initial_state\" : _ -> unit)"
(Datatype.func Cvalue.Model.ty Datatype.unit)
(fun state ->
if not (Option.equal Cvalue.Model.equal
@@ -255,14 +255,14 @@ module Value = struct
"Db.Value.globals_use_default_initial_state"
(Datatype.func Datatype.unit Datatype.unit)
(fun () -> if VGlobals.get_option () <> None then
- (!initial_state_changed (); VGlobals.clear ()))
+ (!initial_state_changed (); VGlobals.clear ()))
let initial_state_only_globals = mk_fun "Value.initial_state_only_globals"
let globals_state () =
match VGlobals.get_option () with
- | Some v -> v
- | None -> !initial_state_only_globals ()
+ | Some v -> v
+ | None -> !initial_state_only_globals ()
let globals_use_supplied_state () = not (VGlobals.get_option () = None)
@@ -286,27 +286,27 @@ module Value = struct
let name = "Db.Value.Table_By_Callstack"
let size = size
let dependencies = dependencies
- end)
+ end)
module Table =
Cil_state_builder.Stmt_hashtbl(Cvalue.Model)
(struct
let name = "Db.Value.Table"
let size = size
let dependencies = [ Table_By_Callstack.self ]
- end)
+ end)
(* Clear Value's various caches each time [Db.Value.is_computed] is updated,
including when it is set, reset, or during project change. Some operations
of Value depend on -ilevel, -plevel, etc, so clearing those caches when
Value ends ensures that those options will have an effect between two runs
of Value. *)
let () = Table_By_Callstack.add_hook_on_update
- (fun _ ->
- Cvalue.V_Offsetmap.clear_caches ();
- Cvalue.Model.clear_caches ();
- Locations.Location_Bytes.clear_caches ();
- Locations.Zone.clear_caches ();
- Function_Froms.Memory.clear_caches ();
- )
+ (fun _ ->
+ Cvalue.V_Offsetmap.clear_caches ();
+ Cvalue.Model.clear_caches ();
+ Locations.Location_Bytes.clear_caches ();
+ Locations.Zone.clear_caches ();
+ Function_Froms.Memory.clear_caches ();
+ )
module AfterTable_By_Callstack =
@@ -315,7 +315,7 @@ module Value = struct
let name = "Db.Value.AfterTable_By_Callstack"
let size = size
let dependencies = [ Table_By_Callstack.self ]
- end)
+ end)
module AfterTable =
Cil_state_builder.Stmt_hashtbl(Cvalue.Model)
(struct
@@ -339,19 +339,19 @@ module Value = struct
Cil_state_builder.Stmt_hashtbl
(Datatype.Int)
(struct
- let name = "Db.Value.Conditions_table"
- let size = 101
- let dependencies = only_self
- end)
+ let name = "Db.Value.Conditions_table"
+ let size = 101
+ let dependencies = only_self
+ end)
let merge_conditions h =
Cil_datatype.Stmt.Hashtbl.iter
(fun stmt v ->
- try
- let old = Conditions_table.find stmt in
- Conditions_table.replace stmt (old lor v)
- with Not_found ->
- Conditions_table.add stmt v)
+ try
+ let old = Conditions_table.find stmt in
+ Conditions_table.replace stmt (old lor v)
+ with Not_found ->
+ Conditions_table.add stmt v)
h
let mask_then = 1
@@ -369,7 +369,7 @@ module Value = struct
(struct
let name = "Db.Value.RecursiveCallsFound"
let dependencies = only_self
- end)
+ end)
let ignored_recursive_call kf =
RecursiveCallsFound.mem kf
@@ -381,19 +381,19 @@ module Value = struct
State_builder.Hashtbl(Kernel_function.Hashtbl)
(States_by_callstack)
(struct
- let name = "Db.Value.Called_Functions_By_Callstack"
- let size = 11
- let dependencies = only_self
- end)
+ let name = "Db.Value.Called_Functions_By_Callstack"
+ let size = 11
+ let dependencies = only_self
+ end)
module Called_Functions_Memo =
State_builder.Hashtbl(Kernel_function.Hashtbl)
(Cvalue.Model)
(struct
- let name = "Db.Value.Called_Functions_Memo"
- let size = 11
- let dependencies = [ Called_Functions_By_Callstack.self ]
- end)
+ let name = "Db.Value.Called_Functions_Memo"
+ let size = 11
+ let dependencies = [ Called_Functions_By_Callstack.self ]
+ end)
(*
let pretty_table () =
@@ -418,29 +418,29 @@ module Value = struct
module Record_Value_Callbacks =
Hook.Build
(struct
- type t = (kernel_function * kinstr) list * (state Stmt.Hashtbl.t) Lazy.t
- end)
+ type t = (kernel_function * kinstr) list * (state Stmt.Hashtbl.t) Lazy.t
+ end)
module Record_Value_Callbacks_New =
Hook.Build
(struct
- type t =
- (kernel_function * kinstr) list *
- ((state Stmt.Hashtbl.t) Lazy.t * (state Stmt.Hashtbl.t) Lazy.t)
- Value_types.callback_result
- end)
+ type t =
+ (kernel_function * kinstr) list *
+ ((state Stmt.Hashtbl.t) Lazy.t * (state Stmt.Hashtbl.t) Lazy.t)
+ Value_types.callback_result
+ end)
module Record_Value_After_Callbacks =
Hook.Build
(struct
- type t = (kernel_function * kinstr) list * (state Stmt.Hashtbl.t) Lazy.t
- end)
+ type t = (kernel_function * kinstr) list * (state Stmt.Hashtbl.t) Lazy.t
+ end)
module Record_Value_Superposition_Callbacks =
Hook.Build
(struct
- type t = (kernel_function * kinstr) list * (state list Stmt.Hashtbl.t) Lazy.t
- end)
+ type t = (kernel_function * kinstr) list * (state list Stmt.Hashtbl.t) Lazy.t
+ end)
module Call_Value_Callbacks =
Hook.Build
@@ -450,7 +450,7 @@ module Value = struct
Hook.Build(struct
type t = [`Builtin of Value_types.call_froms | `Spec of funspec
| `Def | `Memexec]
- * state * (kernel_function * kinstr) list end)
+ * state * (kernel_function * kinstr) list end)
;;
@@ -475,8 +475,8 @@ module Value = struct
try
let by_callstack = find stmt in
begin try
- let o = Callstack.Hashtbl.find by_callstack callstack in
- Callstack.Hashtbl.replace by_callstack callstack(Cvalue.Model.join o v)
+ let o = Callstack.Hashtbl.find by_callstack callstack in
+ Callstack.Hashtbl.replace by_callstack callstack(Cvalue.Model.join o v)
with Not_found ->
Callstack.Hashtbl.add by_callstack callstack v
end;
@@ -555,17 +555,17 @@ module Value = struct
| None -> Cvalue.Model.bottom
| Some h ->
Value_types.Callstack.Hashtbl.fold (fun _cs state acc ->
- Cvalue.Model.join acc state
- ) h Cvalue.Model.bottom
+ Cvalue.Model.join acc state
+ ) h Cvalue.Model.bottom
in
add s state;
state
let noassert_get_state ?(after=false) k =
match k with
- | Kglobal -> globals_state ()
- | Kstmt s ->
- noassert_get_stmt_state ~after s
+ | Kglobal -> globals_state ()
+ | Kstmt s ->
+ noassert_get_stmt_state ~after s
let get_stmt_state ?(after=false) s =
assert (is_computed ()); (* this assertion fails during value analysis *)
@@ -579,7 +579,7 @@ module Value = struct
assert (is_computed ()); (* this assertion fails during value analysis *)
try
Some (if after then AfterTable_By_Callstack.find stmt else
- Table_By_Callstack.find stmt)
+ Table_By_Callstack.find stmt)
with Not_found -> None
let fold_stmt_state_callstack f acc ~after stmt =
@@ -608,8 +608,8 @@ module Value = struct
try
Value_types.Callstack.Hashtbl.iter
(fun _cs state ->
- if Cvalue.Model.is_reachable state
- then raise Is_reachable) h;
+ if Cvalue.Model.is_reachable state
+ then raise Is_reachable) h;
false
with Is_reachable -> true
@@ -658,10 +658,10 @@ module Value = struct
let call_to_kernel_function call_stmt = match call_stmt.skind with
| Instr (Call (_, fexp, _, _)) ->
- let _, called_functions =
- !expr_to_kernel_function ?with_alarms:None ~deps:None
- (Kstmt call_stmt) fexp
- in called_functions
+ let _, called_functions =
+ !expr_to_kernel_function ?with_alarms:None ~deps:None
+ (Kstmt call_stmt) fexp
+ in called_functions
| Instr(Local_init(_, ConsInit(f,_,_),_)) ->
Kernel_function.Hptset.singleton (Globals.Functions.get f)
| _ -> raise Not_a_call
@@ -688,9 +688,9 @@ module Value = struct
module Logic = struct
let eval_predicate =
ref (fun ~pre:_ ~here:_ _ ->
- raise
- (Extlib.Unregistered_function
- "Function 'Value.Logic.eval_predicate' not registered yet"))
+ raise
+ (Extlib.Unregistered_function
+ "Function 'Value.Logic.eval_predicate' not registered yet"))
end
@@ -745,11 +745,11 @@ module From = struct
Hook.Build
(struct
type t =
- (Kernel_function.t Stack.t) *
- Function_Froms.Memory.t Stmt.Hashtbl.t *
- (Kernel_function.t * Function_Froms.Memory.t) list
- Stmt.Hashtbl.t
- end)
+ (Kernel_function.t Stack.t) *
+ Function_Froms.Memory.t Stmt.Hashtbl.t *
+ (Kernel_function.t * Function_Froms.Memory.t) list
+ Stmt.Hashtbl.t
+ end)
module Callwise = struct
let iter = mk_fun "From.Callwise.iter"
@@ -765,7 +765,7 @@ module Pdg = struct
type t = PdgTypes.Pdg.t
type t_nodes_and_undef =
- ((PdgTypes.Node.t * Locations.Zone.t option) list * Locations.Zone.t option)
+ ((PdgTypes.Node.t * Locations.Zone.t option) list * Locations.Zone.t option)
exception Top = PdgTypes.Pdg.Top
exception Bottom = PdgTypes.Pdg.Bottom
@@ -777,7 +777,7 @@ module Pdg = struct
let from_same_fun pdg1 pdg2 =
let kf1 = PdgTypes.Pdg.get_kf pdg1 in
let kf2 = PdgTypes.Pdg.get_kf pdg2 in
- Kernel_function.equal kf1 kf2
+ Kernel_function.equal kf1 kf2
let node_key = mk_fun "Pdg.node_key"
@@ -848,9 +848,9 @@ module Properties = struct
module Interp = struct
- exception No_conversion
+ exception No_conversion
- (** Interpretation and conversions of of formulas *)
+ (** Interpretation and conversions of of formulas *)
let code_annot = mk_fun "Properties.Interp.code_annot"
let term_lval = mk_fun "Properties.Interp.term_lval"
let term = mk_fun "Properties.Interp.term"
@@ -872,9 +872,9 @@ module Properties = struct
(** The signature of the mli is copy pasted here because of
http://caml.inria.fr/mantis/view.php?id=7313 *)
type t_ctx =
- {state_opt:bool option;
- ki_opt:(stmt * bool) option;
- kf:Kernel_function.t}
+ {state_opt:bool option;
+ ki_opt:(stmt * bool) option;
+ kf:Kernel_function.t}
val mk_ctx_func_contrat:
(kernel_function -> state_opt:bool option -> t_ctx) ref
@@ -951,20 +951,20 @@ module Properties = struct
end
= struct
type t_ctx =
- { state_opt: bool option;
- ki_opt: (stmt * bool) option;
- kf:Kernel_function.t }
+ { state_opt: bool option;
+ ki_opt: (stmt * bool) option;
+ kf:Kernel_function.t }
let mk_ctx_func_contrat = mk_fun "Interp.To_zone.mk_ctx_func_contrat"
let mk_ctx_stmt_contrat = mk_fun "Interp.To_zone.mk_ctx_stmt_contrat"
let mk_ctx_stmt_annot = mk_fun "Interp.To_zone.mk_ctx_stmt_annot"
type t = {before:bool ; ki:stmt ; zone:Locations.Zone.t}
type t_zone_info = (t list) option
type t_decl =
- { var: Varinfo.Set.t;
- lbl: Logic_label.Set.t }
+ { var: Varinfo.Set.t;
+ lbl: Logic_label.Set.t }
type t_pragmas =
- { ctrl: Stmt.Set.t;
- stmt: Stmt.Set.t }
+ { ctrl: Stmt.Set.t;
+ stmt: Stmt.Set.t }
let from_term = mk_fun "Interp.To_zone.from_term"
let from_terms= mk_fun "Interp.To_zone.from_terms"
let from_pred = mk_fun "Interp.To_zone.from_pred"
@@ -983,8 +983,8 @@ module Properties = struct
let add_assert emitter kf kinstr prop =
Kernel.deprecated "Db.Properties.add_assert" ~now:"ACSL_importer plug-in"
(fun () ->
- let interp_prop = !Interp.code_annot kf kinstr prop in
- Annotations.add_code_annot emitter kinstr interp_prop)
+ let interp_prop = !Interp.code_annot kf kinstr prop in
+ Annotations.add_code_annot emitter kinstr interp_prop)
()
end
@@ -1002,7 +1002,7 @@ end
module RteGen = struct
type status_accessor =
- string * (kernel_function -> bool -> unit) * (kernel_function -> bool)
+ string * (kernel_function -> bool -> unit) * (kernel_function -> bool)
let compute = mk_fun "RteGen.compute"
let annotate_kf = mk_fun "RteGen.annotate_kf"
let self = ref State.dummy
@@ -1042,8 +1042,8 @@ end
module Postdominators = struct
let compute = mk_fun "Postdominators.compute"
let is_postdominator
- : (kernel_function -> opening:stmt -> closing:stmt -> bool) ref
- = mk_fun "Postdominators.is_postdominator"
+ : (kernel_function -> opening:stmt -> closing:stmt -> bool) ref
+ = mk_fun "Postdominators.is_postdominator"
let stmt_postdominators = mk_fun "Postdominators.stmt_postdominators"
let display = mk_fun "Postdominators.display"
let print_dot = mk_fun "Postdominators.print_dot"
@@ -1052,8 +1052,8 @@ end
module PostdominatorsValue = struct
let compute = mk_fun "PostdominatorsValue.compute"
let is_postdominator
- : (kernel_function -> opening:stmt -> closing:stmt -> bool) ref
- = mk_fun "PostdominatorsValue.is_postdominator"
+ : (kernel_function -> opening:stmt -> closing:stmt -> bool) ref
+ = mk_fun "PostdominatorsValue.is_postdominator"
let stmt_postdominators = mk_fun "PostdominatorsValue.stmt_postdominators"
let display = mk_fun "PostdominatorsValue.display"
let print_dot = mk_fun "PostdominatorsValue.print_dot"
diff --git a/src/kernel_services/plugin_entry_points/db.mli b/src/kernel_services/plugin_entry_points/db.mli
index c12c38ce188ba445a909d6179d8291f2285932fa..168250349bbe570b9e89a48b79d3e39f75dbc131 100644
--- a/src/kernel_services/plugin_entry_points/db.mli
+++ b/src/kernel_services/plugin_entry_points/db.mli
@@ -43,7 +43,7 @@
- {!Loop}: (natural) loops
- {!Visitor}: frama-c visitors
- {!Kernel}: general parameters of Frama-C (mostly set from the command
- line)
+ line)
*)
open Cil_types
@@ -57,25 +57,25 @@ open Cil_datatype
@since Beryllium-20090601-beta1 *)
type 'a how_to_journalize =
| Journalize of string * 'a Type.t
- (** Journalize the value with the given name and type. *)
+ (** Journalize the value with the given name and type. *)
| Journalization_not_required
- (** Journalization of this value is not required
- (usually because it has no effect on the Frama-C global state). *)
+ (** Journalization of this value is not required
+ (usually because it has no effect on the Frama-C global state). *)
| Journalization_must_not_happen of string
- (** Journalization of this value should not happen
- (usually because it is a low-level function: this function is always
- called from a journalized function).
- The string is the function name which is used for displaying suitable
- error message. *)
+ (** Journalization of this value should not happen
+ (usually because it is a low-level function: this function is always
+ called from a journalized function).
+ The string is the function name which is used for displaying suitable
+ error message. *)
val register: 'a how_to_journalize -> 'a ref -> 'a -> unit
- (** Plugins must register values with this function. *)
+(** Plugins must register values with this function. *)
val register_compute:
string ->
State.t list ->
(unit -> unit) ref -> (unit -> unit) -> State.t
- (** @modify Boron-20100401 now return the state of the computation. *)
+(** @modify Boron-20100401 now return the state of the computation. *)
val register_guarded_compute:
string ->
@@ -88,17 +88,17 @@ val register_guarded_compute:
module Main: sig
val extend : (unit -> unit) -> unit
- (** Register a function to be called by the Frama-C main entry point.
- @plugin development guide *)
+ (** Register a function to be called by the Frama-C main entry point.
+ @plugin development guide *)
val play: (unit -> unit) ref
- (** Run all the Frama-C analyses. This function should be called only by
- toplevels.
- @since Beryllium-20090901 *)
+ (** Run all the Frama-C analyses. This function should be called only by
+ toplevels.
+ @since Beryllium-20090901 *)
(**/**)
val apply: unit -> unit
- (** Not for casual user. *)
+ (** Not for casual user. *)
(**/**)
end
@@ -106,9 +106,9 @@ end
module Toplevel: sig
val run: ((unit -> unit) -> unit) ref
- (** Run a Frama-C toplevel playing the game given in argument (in
- particular, applying the argument runs the analyses).
- @since Beryllium-20090901 *)
+ (** Run a Frama-C toplevel playing the game given in argument (in
+ particular, applying the argument runs the analyses).
+ @since Beryllium-20090901 *)
end
@@ -121,48 +121,48 @@ end
module Value : sig
type state = Cvalue.Model.t
- (** Internal state of the value analysis. *)
+ (** Internal state of the value analysis. *)
type t = Cvalue.V.t
- (** Internal representation of a value. *)
+ (** Internal representation of a value. *)
exception Aborted
val emitter: Emitter.t ref
- (** Emitter used by Value to emit statuses *)
+ (** Emitter used by Value to emit statuses *)
val self : State.t
- (** Internal state of the value analysis from projects viewpoint.
- @plugin development guide *)
+ (** Internal state of the value analysis from projects viewpoint.
+ @plugin development guide *)
val mark_as_computed: unit -> unit
- (** Indicate that the value analysis has been done already. *)
+ (** Indicate that the value analysis has been done already. *)
val compute : (unit -> unit) ref
- (** Compute the value analysis using the entry point of the current
- project. You may set it with {!Globals.set_entry_point}.
- @raise Globals.No_such_entry_point if the entry point is incorrect
- @raise Db.Value.Incorrect_number_of_arguments if some arguments are
- specified for the entry point using {!Db.Value.fun_set_args}, and
- an incorrect number of them is given.
- @plugin development guide *)
+ (** Compute the value analysis using the entry point of the current
+ project. You may set it with {!Globals.set_entry_point}.
+ @raise Globals.No_such_entry_point if the entry point is incorrect
+ @raise Db.Value.Incorrect_number_of_arguments if some arguments are
+ specified for the entry point using {!Db.Value.fun_set_args}, and
+ an incorrect number of them is given.
+ @plugin development guide *)
val is_computed: unit -> bool
- (** Return [true] iff the value analysis has been done.
- @plugin development guide *)
+ (** Return [true] iff the value analysis has been done.
+ @plugin development guide *)
module Table_By_Callstack:
State_builder.Hashtbl with type key = stmt
- and type data = state Value_types.Callstack.Hashtbl.t
- (** Table containing the results of the value analysis, ie.
- the state before the evaluation of each reachable statement. *)
+ and type data = state Value_types.Callstack.Hashtbl.t
+ (** Table containing the results of the value analysis, ie.
+ the state before the evaluation of each reachable statement. *)
module AfterTable_By_Callstack:
State_builder.Hashtbl with type key = stmt
- and type data = state Value_types.Callstack.Hashtbl.t
- (** Table containing the state of the value analysis after the evaluation
- of each reachable and evaluable statement. Filled only if
- [Value_parameters.ResultsAfter] is set. *)
+ and type data = state Value_types.Callstack.Hashtbl.t
+ (** Table containing the state of the value analysis after the evaluation
+ of each reachable and evaluable statement. Filled only if
+ [Value_parameters.ResultsAfter] is set. *)
val ignored_recursive_call: kernel_function -> bool
(** This functions returns true if the value analysis found and ignored
@@ -274,7 +274,7 @@ module Value : sig
val find_lv_plus :
(Cvalue.Model.t -> Cil_types.exp ->
- (Cil_types.lval * Ival.t) list) ref
+ (Cil_types.lval * Ival.t) list) ref
(** returns the list of all decompositions of [expr] into the sum an lvalue
and an interval. *)
@@ -295,15 +295,15 @@ module Value : sig
exception Not_a_call
val call_to_kernel_function : stmt -> Kernel_function.Hptset.t
- (** Return the functions that can be called from this call.
- @raise Not_a_call if the statement is not a call. *)
+ (** Return the functions that can be called from this call.
+ @raise Not_a_call if the statement is not a call. *)
val valid_behaviors: (kernel_function -> state -> funbehavior list) ref
val add_formals_to_state: (state -> kernel_function -> exp list -> state) ref
- (** [add_formals_to_state state kf exps] evaluates [exps] in [state]
- and binds them to the formal arguments of [kf] in the resulting
- state *)
+ (** [add_formals_to_state state kf exps] evaluates [exps] in [state]
+ and binds them to the formal arguments of [kf] in the resulting
+ state *)
(** {3 Reachability} *)
@@ -317,14 +317,14 @@ module Value : sig
exception Void_Function
val find_return_loc : kernel_function -> Locations.location
- (** Return the location of the returned lvalue of the given function.
- @raise Void_Function if the function does not return any value. *)
+ (** Return the location of the returned lvalue of the given function.
+ @raise Void_Function if the function does not return any value. *)
val is_called: (kernel_function -> bool) ref
val callers: (kernel_function -> (kernel_function*stmt list) list) ref
- (** @return the list of callers with their call sites. Each function is
- present only once in the list. *)
+ (** @return the list of callers with their call sites. Each function is
+ present only once in the list. *)
(** {3 State before a kinstr} *)
@@ -341,15 +341,15 @@ module Value : sig
val lval_to_loc_with_deps :
(kinstr
-> ?with_alarms:CilE.warn_mode
- -> deps:Locations.Zone.t
- -> lval
- -> Locations.Zone.t * Locations.location) ref
+ -> deps:Locations.Zone.t
+ -> lval
+ -> Locations.Zone.t * Locations.location) ref
val lval_to_loc_with_deps_state :
(state
- -> deps:Locations.Zone.t
- -> lval
- -> Locations.Zone.t * Locations.location) ref
+ -> deps:Locations.Zone.t
+ -> lval
+ -> Locations.Zone.t * Locations.location) ref
val lval_to_loc_state :
(state -> lval -> Locations.location) ref
@@ -360,14 +360,14 @@ module Value : sig
val lval_to_offsetmap_state :
(state -> lval -> Cvalue.V_Offsetmap.t option) ref
- (** @since Carbon-20110201 *)
+ (** @since Carbon-20110201 *)
val lval_to_zone :
(kinstr -> ?with_alarms:CilE.warn_mode -> lval -> Locations.Zone.t) ref
val lval_to_zone_state :
(state -> lval -> Locations.Zone.t) ref
- (** Does not emit alarms. *)
+ (** Does not emit alarms. *)
val lval_to_zone_with_deps_state:
(state -> for_writing:bool -> deps:Locations.Zone.t option -> lval ->
@@ -411,8 +411,8 @@ module Value : sig
(** {3 Evaluation of logic terms and predicates} *)
module Logic : sig
- (** The APIs of this module are not stabilized yet, and are subject
- to change between Frama-C versions. *)
+ (** The APIs of this module are not stabilized yet, and are subject
+ to change between Frama-C versions. *)
val eval_predicate:
(pre:state -> here:state -> predicate ->
@@ -440,13 +440,13 @@ module Value : sig
Hook.Iter_hook with type param = callstack * (state Stmt.Hashtbl.t) Lazy.t
(**/**)
- (* Temporary API, do not use *)
+ (* Temporary API, do not use *)
module Record_Value_Callbacks_New: Hook.Iter_hook
with type param =
- callstack *
- ((state Stmt.Hashtbl.t) Lazy.t (* before states *) *
- (state Stmt.Hashtbl.t) Lazy.t) (* after states *)
- Value_types.callback_result
+ callstack *
+ ((state Stmt.Hashtbl.t) Lazy.t (* before states *) *
+ (state Stmt.Hashtbl.t) Lazy.t) (* after states *)
+ Value_types.callback_result
(**/**)
val no_results: (fundec -> bool) ref
@@ -466,8 +466,8 @@ module Value : sig
@since Aluminium-20160501 *)
module Call_Type_Value_Callbacks:
Hook.Iter_hook with type param =
- [`Builtin of Value_types.call_froms | `Spec of funspec | `Def | `Memexec]
- * state * callstack
+ [`Builtin of Value_types.call_froms | `Spec of funspec | `Def | `Memexec]
+ * state * callstack
(** Actions to perform whenever a statement is handled. *)
@@ -492,8 +492,8 @@ module Value : sig
(** {3 Internal use only} *)
val noassert_get_state : ?after:bool -> kinstr -> state
- (** To be used during the value analysis itself (instead of
- {!get_state}). [after] is false by default. *)
+ (** To be used during the value analysis itself (instead of
+ {!get_state}). [after] is false by default. *)
val recursive_call_occurred: kernel_function -> unit
@@ -508,10 +508,10 @@ module Value : sig
val memoize : (kernel_function -> unit) ref
-(* val compute_call :
- (kernel_function -> call_kinstr:kinstr -> state -> (exp*t) list
- -> Cvalue.V_Offsetmap.t option (** returned value of [kernel_function] *) * state) ref
-*)
+ (* val compute_call :
+ (kernel_function -> call_kinstr:kinstr -> state -> (exp*t) list
+ -> Cvalue.V_Offsetmap.t option (** returned value of [kernel_function] *) * state) ref
+ *)
val merge_initial_state : callstack -> state -> unit
(** Store an additional possible initial state for the given callstack as
well as its values for actuals. *)
@@ -526,7 +526,7 @@ module From : sig
(** exception raised by [find_deps_no_transitivity_*] if the given expression
is not an lvalue.
@since Aluminium-20160501
- *)
+ *)
exception Not_lval
val compute_all : (unit -> unit) ref
@@ -535,9 +535,9 @@ module From : sig
val compute : (kernel_function -> unit) ref
val is_computed: (kernel_function -> bool) ref
- (** Check whether the from analysis has been performed for the given
- function.
- @return true iff the analysis has been performed *)
+ (** Check whether the from analysis has been performed for the given
+ function.
+ @return true iff the analysis has been performed *)
val get : (kernel_function -> Function_Froms.t) ref
val access : (Locations.Zone.t -> Function_Froms.Memory.t
@@ -561,12 +561,12 @@ module From : sig
(** {3 Callback} *)
- module Record_From_Callbacks:
- Hook.Iter_hook with type param =
- Kernel_function.t Stack.t *
- Function_Froms.Memory.t Stmt.Hashtbl.t *
- (Kernel_function.t * Function_Froms.Memory.t) list
- Stmt.Hashtbl.t
+ module Record_From_Callbacks:
+ Hook.Iter_hook with type param =
+ Kernel_function.t Stack.t *
+ Function_Froms.Memory.t Stmt.Hashtbl.t *
+ (Kernel_function.t * Function_Froms.Memory.t) list
+ Stmt.Hashtbl.t
(** {3 Access to callwise-stored data} *)
@@ -614,56 +614,56 @@ module Properties : sig
(** Exception raised by the functions below when their given argument
cannot be interpreted in the C world.
@since Aluminium-20160501
- *)
+ *)
exception No_conversion
val term_lval_to_lval:
(result: Cil_types.varinfo option -> term_lval -> Cil_types.lval) ref
- (** @raise No_conversion if the argument is not a left value.
- @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg
- *)
+ (** @raise No_conversion if the argument is not a left value.
+ @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg
+ *)
val term_to_lval:
(result: Cil_types.varinfo option -> term -> Cil_types.lval) ref
- (** @raise No_conversion if the argument is not a left value.
- @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg
- *)
+ (** @raise No_conversion if the argument is not a left value.
+ @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg
+ *)
val term_to_exp:
(result: Cil_types.varinfo option -> term -> Cil_types.exp) ref
- (** @raise No_conversion if the argument is not a valid expression.
- @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg
- *)
+ (** @raise No_conversion if the argument is not a valid expression.
+ @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg
+ *)
val loc_to_exp:
(result: Cil_types.varinfo option -> term -> Cil_types.exp list) ref
- (** @return a list of C expressions.
- @raise No_conversion if the argument is not a valid set of
- expressions.
- @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg
- *)
+ (** @return a list of C expressions.
+ @raise No_conversion if the argument is not a valid set of
+ expressions.
+ @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg
+ *)
val loc_to_lval:
(result: Cil_types.varinfo option -> term -> Cil_types.lval list) ref
- (** @return a list of C locations.
- @raise No_conversion if the argument is not a valid set of
- left values.
- @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg
- *)
+ (** @return a list of C locations.
+ @raise No_conversion if the argument is not a valid set of
+ left values.
+ @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg
+ *)
val term_offset_to_offset:
(result: Cil_types.varinfo option -> term_offset -> offset) ref
- (** @raise No_conversion if the argument is not a valid offset.
- @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg
- *)
+ (** @raise No_conversion if the argument is not a valid offset.
+ @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg
+ *)
val loc_to_offset:
(result: Cil_types.varinfo option -> term -> Cil_types.offset list) ref
- (** @return a list of C offset provided the term denotes locations who
- have all the same base address.
- @raise No_conversion if the given term does not match the precondition
- @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg
- *)
+ (** @return a list of C offset provided the term denotes locations who
+ have all the same base address.
+ @raise No_conversion if the given term does not match the precondition
+ @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg
+ *)
(** {3 From logic terms to Locations.location} *)
@@ -671,104 +671,104 @@ module Properties : sig
val loc_to_loc:
(result: Cil_types.varinfo option -> Value.state -> term ->
Locations.location) ref
- (** @raise No_conversion if the translation fails.
- @modify Aluminium-20160501 raises a custom exn instead of generic
- Invalid_arg
- *)
+ (** @raise No_conversion if the translation fails.
+ @modify Aluminium-20160501 raises a custom exn instead of generic
+ Invalid_arg
+ *)
val loc_to_loc_under_over:
(result: Cil_types.varinfo option -> Value.state -> term ->
Locations.location * Locations.location * Locations.Zone.t) ref
- (** Same as {!loc_to_loc}, except that we return simultaneously an
- under-approximation of the term (first location), and an
- over-approximation (second location). The under-approximation
- is particularly useful when evaluating Tsets. The zone returned is an
- over-approximation of locations that have been read during evaluation.
- Warning: This API is not stabilized, and may change in
- the future.
- @raise No_conversion if the translation fails.
- @modify Aluminium-20160501 raises a custom exn instead of generic
- Invalid_arg
- *)
+ (** Same as {!loc_to_loc}, except that we return simultaneously an
+ under-approximation of the term (first location), and an
+ over-approximation (second location). The under-approximation
+ is particularly useful when evaluating Tsets. The zone returned is an
+ over-approximation of locations that have been read during evaluation.
+ Warning: This API is not stabilized, and may change in
+ the future.
+ @raise No_conversion if the translation fails.
+ @modify Aluminium-20160501 raises a custom exn instead of generic
+ Invalid_arg
+ *)
(** {3 From logic terms to Zone.t} *)
module To_zone : sig
type t_ctx =
- {state_opt:bool option;
- ki_opt:(stmt * bool) option;
- kf:Kernel_function.t}
+ {state_opt:bool option;
+ ki_opt:(stmt * bool) option;
+ kf:Kernel_function.t}
val mk_ctx_func_contrat:
(kernel_function -> state_opt:bool option -> t_ctx) ref
- (** To build an interpretation context relative to function
- contracts. *)
+ (** To build an interpretation context relative to function
+ contracts. *)
val mk_ctx_stmt_contrat:
(kernel_function -> stmt -> state_opt:bool option -> t_ctx) ref
- (** To build an interpretation context relative to statement
- contracts. *)
+ (** To build an interpretation context relative to statement
+ contracts. *)
val mk_ctx_stmt_annot:
(kernel_function -> stmt -> t_ctx) ref
- (** To build an interpretation context relative to statement
- annotations. *)
+ (** To build an interpretation context relative to statement
+ annotations. *)
type t = {before:bool ; ki:stmt ; zone:Locations.Zone.t}
type t_zone_info = (t list) option
- (** list of zones at some program points.
- * None means that the computation has failed. *)
+ (** list of zones at some program points.
+ * None means that the computation has failed. *)
type t_decl = {var: Varinfo.Set.t ; (* related to vars of the annot *)
lbl: Logic_label.Set.t} (* related to labels of the annot *)
type t_pragmas =
- {ctrl: Stmt.Set.t ; (* related to //@ slice pragma ctrl/expr *)
- stmt: Stmt.Set.t} (* related to statement assign and
- //@ slice pragma stmt *)
+ {ctrl: Stmt.Set.t ; (* related to //@ slice pragma ctrl/expr *)
+ stmt: Stmt.Set.t} (* related to statement assign and
+ //@ slice pragma stmt *)
val from_term: (term -> t_ctx -> t_zone_info * t_decl) ref
- (** Entry point to get zones needed to evaluate the [term] relative to
- the [ctx] of interpretation. *)
+ (** Entry point to get zones needed to evaluate the [term] relative to
+ the [ctx] of interpretation. *)
val from_terms: (term list -> t_ctx -> t_zone_info * t_decl) ref
- (** Entry point to get zones needed to evaluate the list of [terms]
- relative to the [ctx] of interpretation. *)
+ (** Entry point to get zones needed to evaluate the list of [terms]
+ relative to the [ctx] of interpretation. *)
val from_pred: (predicate -> t_ctx -> t_zone_info * t_decl) ref
- (** Entry point to get zones needed to evaluate the [predicate]
- relative to the [ctx] of interpretation. *)
+ (** Entry point to get zones needed to evaluate the [predicate]
+ relative to the [ctx] of interpretation. *)
val from_preds: (predicate list -> t_ctx -> t_zone_info * t_decl) ref
- (** Entry point to get zones needed to evaluate the list of
- [predicates] relative to the [ctx] of interpretation. *)
+ (** Entry point to get zones needed to evaluate the list of
+ [predicates] relative to the [ctx] of interpretation. *)
val from_zone: (identified_term -> t_ctx -> t_zone_info * t_decl) ref
- (** Entry point to get zones needed to evaluate the [zone] relative to
- the [ctx] of interpretation. *)
+ (** Entry point to get zones needed to evaluate the [zone] relative to
+ the [ctx] of interpretation. *)
val from_stmt_annot:
(code_annotation -> stmt * kernel_function
- -> (t_zone_info * t_decl) * t_pragmas) ref
- (** Entry point to get zones needed to evaluate an annotation on the
- given stmt. *)
+ -> (t_zone_info * t_decl) * t_pragmas) ref
+ (** Entry point to get zones needed to evaluate an annotation on the
+ given stmt. *)
val from_stmt_annots:
((code_annotation -> bool) option ->
- stmt * kernel_function -> (t_zone_info * t_decl) * t_pragmas) ref
- (** Entry point to get zones needed to evaluate annotations of this
- [stmt]. *)
+ stmt * kernel_function -> (t_zone_info * t_decl) * t_pragmas) ref
+ (** Entry point to get zones needed to evaluate annotations of this
+ [stmt]. *)
val from_func_annots:
(((stmt -> unit) -> kernel_function -> unit) ->
- (code_annotation -> bool) option ->
- kernel_function -> (t_zone_info * t_decl) * t_pragmas) ref
- (** Entry point to get zones
- needed to evaluate annotations of this [kf]. *)
+ (code_annotation -> bool) option ->
+ kernel_function -> (t_zone_info * t_decl) * t_pragmas) ref
+ (** Entry point to get zones
+ needed to evaluate annotations of this [kf]. *)
val code_annot_filter:
(code_annotation ->
- threat:bool -> user_assert:bool -> slicing_pragma:bool ->
- loop_inv:bool -> loop_var:bool -> others:bool -> bool) ref
+ threat:bool -> user_assert:bool -> slicing_pragma:bool ->
+ loop_inv:bool -> loop_var:bool -> others:bool -> bool) ref
(** To quickly build an annotation filter *)
end
@@ -785,12 +785,12 @@ module Properties : sig
(** {3 Assertions} *)
val add_assert: Emitter.t -> kernel_function -> stmt -> string -> unit
- (** @deprecated since Oxygen-20120901
- Ask for {ACSL_importer plug-in} if you need such functionality.
- @modify Boron-20100401 takes as additional argument the
- computation which adds the assert.
- @modify Oxygen-20120901 replaces the State.t list by an Emitter.t
- *)
+ (** @deprecated since Oxygen-20120901
+ Ask for {ACSL_importer plug-in} if you need such functionality.
+ @modify Boron-20100401 takes as additional argument the
+ computation which adds the assert.
+ @modify Oxygen-20120901 replaces the State.t list by an Emitter.t
+ *)
end
@@ -819,8 +819,8 @@ module PostdominatorsTypes: sig
val display: (unit -> unit) ref
val print_dot : (string -> kernel_function -> unit) ref
- (** Print a representation of the postdominators in a dot file
- whose name is [basename.function_name.dot]. *)
+ (** Print a representation of the postdominators in a dot file
+ whose name is [basename.function_name.dot]. *)
end
end
@@ -851,12 +851,12 @@ module RteGen : sig
val self: State.t ref
type status_accessor =
- string (* name *)
- * (kernel_function -> bool -> unit) (* for each kf and each kind of
- annotation, set/unset the fact
- that there has been generated *)
- * (kernel_function -> bool) (* is this kind of annotation generated in
- kf? *)
+ string (* name *)
+ * (kernel_function -> bool -> unit) (* for each kf and each kind of
+ annotation, set/unset the fact
+ that there has been generated *)
+ * (kernel_function -> bool) (* is this kind of annotation generated in
+ kf? *)
val get_all_status : (unit -> status_accessor list) ref
val get_divMod_status : (unit -> status_accessor) ref
val get_initialized_status: (unit -> status_accessor) ref
@@ -879,13 +879,13 @@ end
module Security : sig
val run_whole_analysis: (unit -> unit) ref
- (** Run all the security analysis. *)
+ (** Run all the security analysis. *)
val run_ai_analysis: (unit -> unit) ref
- (** Only run the analysis by abstract interpretation. *)
+ (** Only run the analysis by abstract interpretation. *)
val run_slicing_analysis: (unit -> Project.t) ref
- (** Only run the security slicing pre-analysis. *)
+ (** Only run the security slicing pre-analysis. *)
val self: State.t ref
@@ -896,32 +896,32 @@ end
module Pdg : sig
exception Bottom
- (** Raised by most function when the PDG is Bottom because we can hardly do
- nothing with it. It happens when the function is unreachable because we
- have no information about it. *)
+ (** Raised by most function when the PDG is Bottom because we can hardly do
+ nothing with it. It happens when the function is unreachable because we
+ have no information about it. *)
exception Top
- (** Raised by most function when the PDG is Top because we can hardly do
- nothing with it. It happens when we didn't manage to compute it, for
- instance for a variadic function. *)
+ (** Raised by most function when the PDG is Top because we can hardly do
+ nothing with it. It happens when we didn't manage to compute it, for
+ instance for a variadic function. *)
type t = PdgTypes.Pdg.t
- (** PDG type *)
+ (** PDG type *)
type t_nodes_and_undef =
- ((PdgTypes.Node.t * Locations.Zone.t option) list * Locations.Zone.t option)
- (** type for the return value of many [find_xxx] functions when the
- answer can be a list of [(node, z_part)] and an [undef zone].
- For each node, [z_part] can specify which part of the node
- is used in terms of zone ([None] means all).
- *)
+ ((PdgTypes.Node.t * Locations.Zone.t option) list * Locations.Zone.t option)
+ (** type for the return value of many [find_xxx] functions when the
+ answer can be a list of [(node, z_part)] and an [undef zone].
+ For each node, [z_part] can specify which part of the node
+ is used in terms of zone ([None] means all).
+ *)
val self : State.t ref
(** {3 Getters} *)
val get : (kernel_function -> t) ref
- (** Get the PDG of a function. Build it if it doesn't exist yet. *)
+ (** Get the PDG of a function. Build it if it doesn't exist yet. *)
val node_key : (PdgTypes.Node.t -> PdgIndex.Key.t) ref
@@ -930,166 +930,166 @@ module Pdg : sig
(** {3 Finding PDG nodes} *)
val find_decl_var_node : (t -> Cil_types.varinfo -> PdgTypes.Node.t) ref
- (** Get the node corresponding the declaration of a local variable or a
- formal parameter.
- @raise Not_found if the variable is not declared in this function.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Get the node corresponding the declaration of a local variable or a
+ formal parameter.
+ @raise Not_found if the variable is not declared in this function.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val find_ret_output_node : (t -> PdgTypes.Node.t) ref
- (** Get the node corresponding return stmt.
- @raise Not_found if the output state in unreachable
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Get the node corresponding return stmt.
+ @raise Not_found if the output state in unreachable
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val find_output_nodes :
(t -> PdgIndex.Signature.out_key -> t_nodes_and_undef) ref
- (** Get the nodes corresponding to a call output key in the called pdg.
- @raise Not_found if the output state in unreachable
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Get the nodes corresponding to a call output key in the called pdg.
+ @raise Not_found if the output state in unreachable
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val find_input_node : (t -> int -> PdgTypes.Node.t) ref
- (** Get the node corresponding to a given input (parameter).
- @raise Not_found if the number is not an input number.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Get the node corresponding to a given input (parameter).
+ @raise Not_found if the number is not an input number.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val find_all_inputs_nodes : (t -> PdgTypes.Node.t list) ref
- (** Get the nodes corresponding to all inputs.
- {!node_key} can be used to know their numbers.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Get the nodes corresponding to all inputs.
+ {!node_key} can be used to know their numbers.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val find_stmt_node : (t -> Cil_types.stmt -> PdgTypes.Node.t) ref
- (** Get the node corresponding to the statement.
- It shouldn't be a call statement.
- See also {!find_simple_stmt_nodes} or {!find_call_stmts}.
- @raise Not_found if the given statement is unreachable.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top.
- @raise PdgIndex.CallStatement if the given stmt is a function
- call. *)
+ (** Get the node corresponding to the statement.
+ It shouldn't be a call statement.
+ See also {!find_simple_stmt_nodes} or {!find_call_stmts}.
+ @raise Not_found if the given statement is unreachable.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top.
+ @raise PdgIndex.CallStatement if the given stmt is a function
+ call. *)
val find_simple_stmt_nodes : (t -> Cil_types.stmt -> PdgTypes.Node.t list) ref
- (** Get the nodes corresponding to the statement.
- It is usually composed of only one node (see {!find_stmt_node}),
- except for call statement.
- Be careful that for block statements, it only returns a node
- corresponding to the elementary stmt
- (see {!find_stmt_and_blocks_nodes} for more)
- @raise Not_found if the given statement is unreachable.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Get the nodes corresponding to the statement.
+ It is usually composed of only one node (see {!find_stmt_node}),
+ except for call statement.
+ Be careful that for block statements, it only returns a node
+ corresponding to the elementary stmt
+ (see {!find_stmt_and_blocks_nodes} for more)
+ @raise Not_found if the given statement is unreachable.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val find_label_node : (t -> Cil_types.stmt -> Cil_types.label -> PdgTypes.Node.t) ref
- (** Get the node corresponding to the label.
- @raise Not_found if the given label is not in the PDG.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Get the node corresponding to the label.
+ @raise Not_found if the given label is not in the PDG.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val find_stmt_and_blocks_nodes : (t -> Cil_types.stmt -> PdgTypes.Node.t list) ref
- (** Get the nodes corresponding to the statement like
- * {!find_simple_stmt_nodes} but also add the nodes of the enclosed
- * statements if [stmt] contains blocks.
- @raise Not_found if the given statement is unreachable.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Get the nodes corresponding to the statement like
+ * {!find_simple_stmt_nodes} but also add the nodes of the enclosed
+ * statements if [stmt] contains blocks.
+ @raise Not_found if the given statement is unreachable.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val find_top_input_node : (t -> PdgTypes.Node.t) ref
- (** @raise Not_found if there is no top input in the PDG.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** @raise Not_found if there is no top input in the PDG.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val find_entry_point_node : (t -> PdgTypes.Node.t) ref
- (** Find the node that represent the entry point of the function, i.e. the
- higher level block.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Find the node that represent the entry point of the function, i.e. the
+ higher level block.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val find_location_nodes_at_stmt :
(t -> Cil_types.stmt -> before:bool -> Locations.Zone.t
-> t_nodes_and_undef) ref
- (** Find the nodes that define the value of the location at the given
- program point. Also return a zone that might be undefined at that
- point.
- @raise Not_found if the given statement is unreachable.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Find the nodes that define the value of the location at the given
+ program point. Also return a zone that might be undefined at that
+ point.
+ @raise Not_found if the given statement is unreachable.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val find_location_nodes_at_end :
(t -> Locations.Zone.t -> t_nodes_and_undef) ref
- (** Same than {!find_location_nodes_at_stmt} for the program point located
- at the end of the function.
- @raise Not_found if the output state is unreachable.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Same than {!find_location_nodes_at_stmt} for the program point located
+ at the end of the function.
+ @raise Not_found if the output state is unreachable.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val find_location_nodes_at_begin :
(t -> Locations.Zone.t -> t_nodes_and_undef) ref
- (** Same than {!find_location_nodes_at_stmt} for the program point located
- at the beginning of the function.
- Notice that it can only find formal argument nodes.
- The remaining zone (implicit input) is returned as undef.
- @raise Not_found if the output state is unreachable.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Same than {!find_location_nodes_at_stmt} for the program point located
+ at the beginning of the function.
+ Notice that it can only find formal argument nodes.
+ The remaining zone (implicit input) is returned as undef.
+ @raise Not_found if the output state is unreachable.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val find_call_stmts:
(kernel_function -> caller:kernel_function -> Cil_types.stmt list) ref
- (** Find the call statements to the function (can maybe be somewhere
- else).
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Find the call statements to the function (can maybe be somewhere
+ else).
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val find_call_ctrl_node : (t -> Cil_types.stmt -> PdgTypes.Node.t) ref
- (** @raise Not_found if the call is unreachable.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** @raise Not_found if the call is unreachable.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val find_call_input_node : (t -> Cil_types.stmt -> int -> PdgTypes.Node.t) ref
- (** @raise Not_found if the call is unreachable or has no such input.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** @raise Not_found if the call is unreachable or has no such input.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val find_call_output_node : (t -> Cil_types.stmt -> PdgTypes.Node.t) ref
- (** @raise Not_found if the call is unreachable or has no output node.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** @raise Not_found if the call is unreachable or has no output node.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val find_code_annot_nodes :
(t -> Cil_types.stmt -> Cil_types.code_annotation ->
- PdgTypes.Node.t list * PdgTypes.Node.t list * (t_nodes_and_undef option)) ref
- (** The result is composed of three parts :
- - the first part of the result are the control dependencies nodes
- of the annotation,
- - the second part is the list of declaration nodes of the variables
- used in the annotation;
- - the third part is similar to [find_location_nodes_at_stmt] result
- but for all the locations needed by the annotation.
- When the third part is globally [None],
- it means that we were not able to compute this information.
+ PdgTypes.Node.t list * PdgTypes.Node.t list * (t_nodes_and_undef option)) ref
+ (** The result is composed of three parts :
+ - the first part of the result are the control dependencies nodes
+ of the annotation,
+ - the second part is the list of declaration nodes of the variables
+ used in the annotation;
+ - the third part is similar to [find_location_nodes_at_stmt] result
+ but for all the locations needed by the annotation.
+ When the third part is globally [None],
+ it means that we were not able to compute this information.
@raise Not_found if the statement is unreachable.
@raise Bottom if given PDG is bottom.
@raise Top if the given pdg is top. *)
val find_fun_precond_nodes :
(t -> Cil_types.predicate -> PdgTypes.Node.t list * (t_nodes_and_undef option)) ref
- (** Similar to [find_code_annot_nodes] (no control dependencies nodes) *)
+ (** Similar to [find_code_annot_nodes] (no control dependencies nodes) *)
val find_fun_postcond_nodes :
(t -> Cil_types.predicate -> PdgTypes.Node.t list * (t_nodes_and_undef option)) ref
- (** Similar to [find_fun_precond_nodes] *)
+ (** Similar to [find_fun_precond_nodes] *)
val find_fun_variant_nodes :
(t -> Cil_types.term -> (PdgTypes.Node.t list * t_nodes_and_undef option)) ref
- (** Similar to [find_fun_precond_nodes] *)
+ (** Similar to [find_fun_precond_nodes] *)
(** {3 Propagation}
See also [Pdg.mli] for more function that cannot be here because
they use polymorphic types.
- **)
+ **)
val find_call_out_nodes_to_select :
(t -> PdgTypes.NodeSet.t -> t -> Cil_types.stmt -> PdgTypes.Node.t list) ref
@@ -1101,114 +1101,114 @@ module Pdg : sig
val find_in_nodes_to_select_for_this_call :
(t -> PdgTypes.NodeSet.t -> Cil_types.stmt -> t -> PdgTypes.Node.t list) ref
- (** [find_in_nodes_to_select_for_this_call
- pdg_caller caller_selected_nodes call_stmt pdg_called]
- @return the called input nodes such that the corresponding nodes
- in the caller intersect [caller_selected_nodes]
- @raise Not_found if the statement is unreachable.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** [find_in_nodes_to_select_for_this_call
+ pdg_caller caller_selected_nodes call_stmt pdg_called]
+ @return the called input nodes such that the corresponding nodes
+ in the caller intersect [caller_selected_nodes]
+ @raise Not_found if the statement is unreachable.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
(** {3 Dependencies} *)
val direct_dpds : (t -> PdgTypes.Node.t -> PdgTypes.Node.t list) ref
- (** Get the nodes to which the given node directly depend on.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Get the nodes to which the given node directly depend on.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val direct_ctrl_dpds : (t -> PdgTypes.Node.t -> PdgTypes.Node.t list) ref
- (** Similar to {!direct_dpds}, but for control dependencies only.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Similar to {!direct_dpds}, but for control dependencies only.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val direct_data_dpds : (t -> PdgTypes.Node.t -> PdgTypes.Node.t list) ref
- (** Similar to {!direct_dpds}, but for data dependencies only.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Similar to {!direct_dpds}, but for data dependencies only.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val direct_addr_dpds : (t -> PdgTypes.Node.t -> PdgTypes.Node.t list) ref
- (** Similar to {!direct_dpds}, but for address dependencies only.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Similar to {!direct_dpds}, but for address dependencies only.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val all_dpds : (t -> PdgTypes.Node.t list -> PdgTypes.Node.t list) ref
- (** Transitive closure of {!direct_dpds} for all the given nodes.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Transitive closure of {!direct_dpds} for all the given nodes.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val all_data_dpds : (t -> PdgTypes.Node.t list -> PdgTypes.Node.t list) ref
- (** Gives the data dependencies of the given nodes, and recursively, all
- the dependencies of those nodes (regardless to their kind).
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Gives the data dependencies of the given nodes, and recursively, all
+ the dependencies of those nodes (regardless to their kind).
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val all_ctrl_dpds : (t -> PdgTypes.Node.t list -> PdgTypes.Node.t list) ref
- (** Similar to {!all_data_dpds} for control dependencies.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Similar to {!all_data_dpds} for control dependencies.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val all_addr_dpds : (t -> PdgTypes.Node.t list -> PdgTypes.Node.t list) ref
- (** Similar to {!all_data_dpds} for address dependencies.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Similar to {!all_data_dpds} for address dependencies.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val direct_uses : (t -> PdgTypes.Node.t -> PdgTypes.Node.t list) ref
- (** build a list of all the nodes that have direct dependencies on the
- given node.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** build a list of all the nodes that have direct dependencies on the
+ given node.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val direct_ctrl_uses : (t -> PdgTypes.Node.t -> PdgTypes.Node.t list) ref
- (** Similar to {!direct_uses}, but for control dependencies only.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Similar to {!direct_uses}, but for control dependencies only.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val direct_data_uses : (t -> PdgTypes.Node.t -> PdgTypes.Node.t list) ref
- (** Similar to {!direct_uses}, but for data dependencies only.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Similar to {!direct_uses}, but for data dependencies only.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val direct_addr_uses : (t -> PdgTypes.Node.t -> PdgTypes.Node.t list) ref
- (** Similar to {!direct_uses}, but for address dependencies only.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** Similar to {!direct_uses}, but for address dependencies only.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val all_uses : (t -> PdgTypes.Node.t list -> PdgTypes.Node.t list) ref
- (** build a list of all the nodes that have dependencies (even indirect) on
- the given nodes.
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** build a list of all the nodes that have dependencies (even indirect) on
+ the given nodes.
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val custom_related_nodes :
((PdgTypes.Node.t -> PdgTypes.Node.t list) -> PdgTypes.Node.t list -> PdgTypes.Node.t list) ref
- (** [custom_related_nodes get_dpds node_list] build a list, starting from
- the node in [node_list], and recursively add the nodes given by the
- function [get_dpds]. For this function to work well, it is important
- that [get_dpds n] returns a subset of the nodes directly related to
- [n], ie a subset of [direct_uses] U [direct_dpds].
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** [custom_related_nodes get_dpds node_list] build a list, starting from
+ the node in [node_list], and recursively add the nodes given by the
+ function [get_dpds]. For this function to work well, it is important
+ that [get_dpds n] returns a subset of the nodes directly related to
+ [n], ie a subset of [direct_uses] U [direct_dpds].
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
val iter_nodes : ((PdgTypes.Node.t -> unit) -> t -> unit) ref
- (** apply a given function to all the PDG nodes
- @raise Bottom if given PDG is bottom.
- @raise Top if the given pdg is top. *)
+ (** apply a given function to all the PDG nodes
+ @raise Bottom if given PDG is bottom.
+ @raise Top if the given pdg is top. *)
(** {3 Pretty printing} *)
val extract : (t -> string -> unit) ref
- (** Pretty print pdg into a dot file.
- @see <../pdg/index.html> PDG internal documentation. *)
+ (** Pretty print pdg into a dot file.
+ @see <../pdg/index.html> PDG internal documentation. *)
val pretty_node : (bool -> Format.formatter -> PdgTypes.Node.t -> unit) ref
- (** Pretty print information on a node : with [short=true], only the id
- of the node is printed.. *)
+ (** Pretty print information on a node : with [short=true], only the id
+ of the node is printed.. *)
val pretty_key : (Format.formatter -> PdgIndex.Key.t -> unit) ref
- (** Pretty print information on a node key *)
+ (** Pretty print information on a node key *)
val pretty : (?bw:bool -> Format.formatter -> t -> unit) ref
- (** For debugging... Pretty print pdg information.
+ (** For debugging... Pretty print pdg information.
Print codependencies rather than dependencies if [bw=true]. *)
end
@@ -1226,10 +1226,10 @@ module type INOUTKF = sig
val compute : (kernel_function -> unit) ref
val get_internal : (kernel_function -> t) ref
- (** Inputs/Outputs with local and formal variables *)
+ (** Inputs/Outputs with local and formal variables *)
val get_external : (kernel_function -> t) ref
- (** Inputs/Outputs without either local or formal variables *)
+ (** Inputs/Outputs without either local or formal variables *)
(** {3 Pretty printing} *)
@@ -1258,7 +1258,7 @@ module Inputs : sig
val self_with_formals: State.t ref
val get_with_formals : (kernel_function -> t) ref
- (** Inputs with formals and without local variables *)
+ (** Inputs with formals and without local variables *)
val display_with_formals: (Format.formatter -> kernel_function -> unit) ref
@@ -1275,21 +1275,21 @@ end
(** State_builder.of operational inputs.
That is:
- over-approximation of zones whose input values are read by each function,
- State_builder.of sure outputs
+ State_builder.of sure outputs
- under-approximation of zones written by each function.
- @see <../inout/Context.html> internal documentation. *)
+ @see <../inout/Context.html> internal documentation. *)
module Operational_inputs : sig
include INOUTKF with type t = Inout_type.t
val get_internal_precise: (?stmt:stmt -> kernel_function -> Inout_type.t) ref
- (** More precise version of [get_internal] function. If [stmt] is
- specified, and is a possible call to the given kernel_function,
- returns the operational inputs for this call. *)
+ (** More precise version of [get_internal] function. If [stmt] is
+ specified, and is a possible call to the given kernel_function,
+ returns the operational inputs for this call. *)
-(**/**)
- (* Internal use *)
+ (**/**)
+ (* Internal use *)
module Record_Inout_Callbacks:
Hook.Iter_hook with type param = Value_types.callstack * Inout_type.t
-(**/**)
+ (**/**)
end
@@ -1344,11 +1344,11 @@ val cancel : unit -> unit
Illustrative example, where [...] is the debounced time:
{[
- job data : |<-------------------------------------------------->|<daemon removed>
- yields : x x x x x x x x xxx xxx
- trigger : |.......... |.......... |.......... |.........
- delayed : !
- notes : (1) (2) (3)
+ job data : |<-------------------------------------------------->|<daemon removed>
+ yields : x x x x x x x x xxx xxx
+ trigger : |.......... |.......... |.......... |.........
+ delayed : !
+ notes : (1) (2) (3)
]}
+ First yield, normal trigger.
diff --git a/src/kernel_services/plugin_entry_points/emitter.ml b/src/kernel_services/plugin_entry_points/emitter.ml
index db76eb65cbf86def4d90b53ee4ec8e9c93a7e6a9..d44861ba06cd48b63905c295e0fa67284b34b33c 100644
--- a/src/kernel_services/plugin_entry_points/emitter.ml
+++ b/src/kernel_services/plugin_entry_points/emitter.ml
@@ -30,10 +30,10 @@
type kind = Property_status | Alarm | Code_annot | Funspec | Global_annot
type emitter =
- { name: string;
- kinds: kind list;
- tuning_parameters: Typed_parameter.t list;
- correctness_parameters: Typed_parameter.t list }
+ { name: string;
+ kinds: kind list;
+ tuning_parameters: Typed_parameter.t list;
+ correctness_parameters: Typed_parameter.t list }
module D =
Datatype.Make_with_collections
@@ -42,13 +42,13 @@ module D =
let name = "Emitter.t"
let rehash = Datatype.identity
let structural_descr = Structural_descr.t_unknown
- let reprs =
- [ { name = "";
- kinds = [];
- tuning_parameters = [];
+ let reprs =
+ [ { name = "";
+ kinds = [];
+ tuning_parameters = [];
correctness_parameters = [] } ]
(* does not use (==) in order to prevent unmarshalling issue + in order
- to be able to compare emitters coming from Usable_emitter.get *)
+ to be able to compare emitters coming from Usable_emitter.get *)
let equal x y = Datatype.String.equal x.name y.name
let compare x y = Datatype.String.compare x.name y.name
let hash x = Datatype.String.hash x.name
@@ -56,62 +56,62 @@ module D =
let pretty fmt x = Format.pp_print_string fmt x.name
let internal_pretty_code = Datatype.undefined
let varname _ = assert false (* unused while [internal_pretty_code]
- unimplemented *)
+ unimplemented *)
let mem_project = Datatype.never_any_project
- end)
+ end)
type usable_emitter =
- { u_id: int;
- u_name: string;
- u_kinds: kind list;
- mutable used: bool;
- mutable version: int;
- (* maps below associate the parameter to its value (as a string) at the
- time of using. *)
- tuning_values: string Datatype.String.Map.t;
- correctness_values: string Datatype.String.Map.t }
+ { u_id: int;
+ u_name: string;
+ u_kinds: kind list;
+ mutable used: bool;
+ mutable version: int;
+ (* maps below associate the parameter to its value (as a string) at the
+ time of using. *)
+ tuning_values: string Datatype.String.Map.t;
+ correctness_values: string Datatype.String.Map.t }
let has_several_versions_ref = Extlib.mk_fun "Emitter.has_several_versions"
module Usable_emitter = struct
include Datatype.Make_with_collections
- (struct
- type t = usable_emitter
- let name = "Emitter.Usable_emitter.t"
- let rehash = Datatype.identity
- let structural_descr = Structural_descr.t_abstract
- let reprs =
- let p = Datatype.String.Map.empty in
- [ { u_id = -1;
- u_name = "";
- u_kinds = [ Property_status ];
- used = false;
- version = -1;
- tuning_values = p;
- correctness_values = p } ]
- let equal = ( == )
- let compare x y = if x == y then 0 else Datatype.Int.compare x.u_id y.u_id
- let hash x = Datatype.Int.hash x.u_id
- let copy x = x (* strings are immutable here *)
- let pretty fmt x =
- let name = x.u_name in
- if !has_several_versions_ref name then
- Format.fprintf fmt "%s (v%d)" name x.version
- else
- Format.pp_print_string fmt name
- let internal_pretty_code = Datatype.undefined
- let varname _ = assert false (* unused while [internal_pretty_code]
- unimplemented *)
- let mem_project = Datatype.never_any_project
- end)
+ (struct
+ type t = usable_emitter
+ let name = "Emitter.Usable_emitter.t"
+ let rehash = Datatype.identity
+ let structural_descr = Structural_descr.t_abstract
+ let reprs =
+ let p = Datatype.String.Map.empty in
+ [ { u_id = -1;
+ u_name = "";
+ u_kinds = [ Property_status ];
+ used = false;
+ version = -1;
+ tuning_values = p;
+ correctness_values = p } ]
+ let equal = ( == )
+ let compare x y = if x == y then 0 else Datatype.Int.compare x.u_id y.u_id
+ let hash x = Datatype.Int.hash x.u_id
+ let copy x = x (* strings are immutable here *)
+ let pretty fmt x =
+ let name = x.u_name in
+ if !has_several_versions_ref name then
+ Format.fprintf fmt "%s (v%d)" name x.version
+ else
+ Format.pp_print_string fmt name
+ let internal_pretty_code = Datatype.undefined
+ let varname _ = assert false (* unused while [internal_pretty_code]
+ unimplemented *)
+ let mem_project = Datatype.never_any_project
+ end)
let get e =
let get_params map =
Datatype.String.Map.fold
- (fun s _ acc -> Typed_parameter.get s :: acc)
- map
- []
+ (fun s _ acc -> Typed_parameter.get s :: acc)
+ map
+ []
in
{ name = e.u_name;
kinds = e.u_kinds;
@@ -121,10 +121,10 @@ module Usable_emitter = struct
let get_name e = e.u_name
let get_unique_name e = Format.asprintf "%a" pretty e
- let correctness_parameters e =
+ let correctness_parameters e =
Datatype.String.Map.fold (fun p _ acc -> p :: acc) e.correctness_values []
- let tuning_parameters e =
+ let tuning_parameters e =
Datatype.String.Map.fold (fun p _ acc -> p :: acc) e.tuning_values []
let pretty_parameter fmt ~tuning e s =
@@ -140,11 +140,11 @@ end
let names: unit Datatype.String.Hashtbl.t = Datatype.String.Hashtbl.create 7
-let create name kinds ~correctness ~tuning =
+let create name kinds ~correctness ~tuning =
if Datatype.String.Hashtbl.mem names name then
Kernel.fatal "emitter %s already exists with the same parameters" name;
let e =
- { name = name;
+ { name = name;
kinds = kinds;
correctness_parameters = correctness;
tuning_parameters = tuning }
@@ -156,24 +156,24 @@ let dummy = create "dummy" [] ~correctness:[] ~tuning:[]
let get_name e = e.name
-let correctness_parameters e =
+let correctness_parameters e =
List.map (fun p -> p.Typed_parameter.name) e.correctness_parameters
-let tuning_parameters e =
+let tuning_parameters e =
List.map (fun p -> p.Typed_parameter.name) e.tuning_parameters
-let end_user =
+let end_user =
create
- "End-User"
+ "End-User"
[ Property_status; Code_annot; Funspec; Global_annot ]
- ~correctness:[]
+ ~correctness:[]
~tuning:[]
-let kernel =
+let kernel =
create
- "Frama-C kernel"
- [ Property_status; Funspec ]
- ~correctness:[]
+ "Frama-C kernel"
+ [ Property_status; Funspec ]
+ ~correctness:[]
~tuning:[]
let orphan =
@@ -187,32 +187,32 @@ let orphan =
(** {2 State of all known emitters} *)
(**************************************************************************)
-module Usable_id =
+module Usable_id =
State_builder.SharedCounter(struct let name = "Emitter.Usable_id" end)
(* For each emitter, the info required to be able to get the right usable
emitter. *)
-module Usable_emitters_of_emitter =
+module Usable_emitters_of_emitter =
State_builder.Hashtbl
(Datatype.String.Hashtbl)
(Datatype.Pair
- (Datatype.Ref(Usable_emitter)) (* current usable emitter with the
- current parameter values *)
+ (Datatype.Ref(Usable_emitter)) (* current usable emitter with the
+ current parameter values *)
(Datatype.Ref(Usable_emitter.Set))) (* existing usable emitters with
- the old parameter values *)
- (struct
- let name = "Emitter.Usable_emitters_of_emitter"
- let size = 7
+ the old parameter values *)
+ (struct
+ let name = "Emitter.Usable_emitters_of_emitter"
+ let size = 7
let dependencies = [ Usable_id.self ]
- end)
+ end)
let self = Usable_emitters_of_emitter.self
let has_several_versions name =
- try
+ try
let _, set = Usable_emitters_of_emitter.find name in
Usable_emitter.Set.cardinal !set > 1
- with Not_found ->
+ with Not_found ->
Kernel.fatal "Unknown emitter %s" name
let () = has_several_versions_ref := has_several_versions
@@ -228,20 +228,20 @@ let distinct_parameters get_them tuning e =
try
let _, set = Usable_emitters_of_emitter.find name in
Usable_emitter.Set.fold
- (fun e' acc ->
- List.fold_left2
- (fun acc s1 s2 ->
- if get e s1 = get e' s2 then acc
- else Datatype.String.Set.add s1 acc)
- acc
- values
- (get_them e))
+ (fun e' acc ->
+ List.fold_left2
+ (fun acc s1 s2 ->
+ if get e s1 = get e' s2 then acc
+ else Datatype.String.Set.add s1 acc)
+ acc
+ values
+ (get_them e))
!set
Datatype.String.Set.empty
with Not_found ->
Kernel.fatal "Unknown emitter %s" name
-let distinct_tuning_parameters =
+let distinct_tuning_parameters =
distinct_parameters Usable_emitter.tuning_parameters true
let distinct_correctness_parameters =
@@ -252,7 +252,7 @@ let distinct_correctness_parameters =
(**************************************************************************)
(* set the value of a parameter of an emitter *)
-let update_usable_emitter tuning ~used usable_e param_name value =
+let update_usable_emitter tuning ~used usable_e param_name value =
let id = Usable_id.next () in
let name = usable_e.u_name in
let kinds = usable_e.u_kinds in
@@ -279,48 +279,48 @@ exception Found of Usable_emitter.t
let update_parameter tuning usable_e p =
let param_name = p.Typed_parameter.name in
let value = Typed_parameter.get_value p in
- try
+ try
let _, set = Usable_emitters_of_emitter.find usable_e.u_name in
try
Usable_emitter.Set.iter
(fun e ->
- let map = if tuning then e.tuning_values else e.correctness_values in
- let exists =
- try
- Datatype.String.equal
- value
- (Datatype.String.Map.find param_name map)
- with Not_found ->
- false
- in
- if exists then raise (Found e))
+ let map = if tuning then e.tuning_values else e.correctness_values in
+ let exists =
+ try
+ Datatype.String.equal
+ value
+ (Datatype.String.Map.find param_name map)
+ with Not_found ->
+ false
+ in
+ if exists then raise (Found e))
!set;
(* we are setting the value of a parameter, but we are not sure yet that
the corresponding usable emitter will be used *)
- let e =
- update_usable_emitter tuning ~used:false usable_e param_name value
+ let e =
+ update_usable_emitter tuning ~used:false usable_e param_name value
in
set := Usable_emitter.Set.add e !set;
e
- with Found e ->
- (* we already create an usable emitter with this value for this
- parameter *)
+ with Found e ->
+ (* we already create an usable emitter with this value for this
+ parameter *)
e
- with Not_found ->
+ with Not_found ->
(* we are creating the first usable emitter of the given name:
it is going to be used *)
update_usable_emitter tuning ~used:true usable_e param_name value
let kinds: (kind, State.t list) Hashtbl.t = Hashtbl.create 7
-let iter_on_kinds f l =
+let iter_on_kinds f l =
List.iter
(fun k ->
- try
- let states = Hashtbl.find kinds k in
- f states
- with Not_found ->
- ())
+ try
+ let states = Hashtbl.find kinds k in
+ f states
+ with Not_found ->
+ ())
l
let correctness_states: unit State.Hashtbl.t = State.Hashtbl.create 7
@@ -340,9 +340,9 @@ let register_correctness_parameter name emitter_name kinds =
emitter_name
name
-let parameter_hooks
- : (unit -> unit) Datatype.String.Hashtbl.t Typed_parameter.Hashtbl.t
- = Typed_parameter.Hashtbl.create 97
+let parameter_hooks
+ : (unit -> unit) Datatype.String.Hashtbl.t Typed_parameter.Hashtbl.t
+ = Typed_parameter.Hashtbl.create 97
let register_tuning_parameter name p =
let update () =
@@ -351,22 +351,22 @@ let register_tuning_parameter name p =
let c = !current in
let v = c.version in
let new_e = update_parameter true c p in
- if c.used then new_e.version <- v + 1
+ if c.used then new_e.version <- v + 1
else begin
set := Usable_emitter.Set.remove c !set;
new_e.version <- v
end;
current := new_e
with Not_found ->
- (* in multi-sessions mode (e.g. save/load), the emitters could exist in
- the previous session but not in the current one. In this case, there
- is nothing to do.
-
- Additionally, even if it still exists, it could be not yet restored
- since the project library does not ensure that it restores the table
- of emitters before the states of parameters. In such a case, it is
- also possible to do nothing since the right table in the right state
- is going to be restored. *)
+ (* in multi-sessions mode (e.g. save/load), the emitters could exist in
+ the previous session but not in the current one. In this case, there
+ is nothing to do.
+
+ Additionally, even if it still exists, it could be not yet restored
+ since the project library does not ensure that it restores the table
+ of emitters before the states of parameters. In such a case, it is
+ also possible to do nothing since the right table in the right state
+ is going to be restored. *)
()
in
try
@@ -374,77 +374,77 @@ let register_tuning_parameter name p =
Datatype.String.Hashtbl.replace tbl name update
with Not_found ->
Kernel.fatal
- "[Emitter] no hook table for parameter %s"
+ "[Emitter] no hook table for parameter %s"
p.Typed_parameter.name
-let () =
+let () =
Cmdline.run_after_extended_stage
(fun () ->
- State_selection.Static.iter
- (fun s ->
- let tbl = Datatype.String.Hashtbl.create 7 in
- let p = Typed_parameter.get (State.get_name s) in
- Typed_parameter.Hashtbl.add parameter_hooks p tbl;
- let update () = Datatype.String.Hashtbl.iter (fun _ f -> f ()) tbl in
- match p.Typed_parameter.accessor with
- | Typed_parameter.Bool(a, _) ->
- a.Typed_parameter.add_set_hook (fun _ _ -> update ())
- | Typed_parameter.Int(a, _) ->
- a.Typed_parameter.add_set_hook (fun _ _ -> update ())
- | Typed_parameter.String(a, _) ->
- a.Typed_parameter.add_set_hook (fun _ _ -> update ()))
- (* [JS 2012/02/07] should be limited to
- [Option_functor.get_selection_context], but it is not possible while
- each plug-in (including Wp) is not projectified *)
- (* (Option_functor.get_selection_context ~is_set:false ()))*)
- (Parameter_state.get_selection ~is_set:false ()))
+ State_selection.Static.iter
+ (fun s ->
+ let tbl = Datatype.String.Hashtbl.create 7 in
+ let p = Typed_parameter.get (State.get_name s) in
+ Typed_parameter.Hashtbl.add parameter_hooks p tbl;
+ let update () = Datatype.String.Hashtbl.iter (fun _ f -> f ()) tbl in
+ match p.Typed_parameter.accessor with
+ | Typed_parameter.Bool(a, _) ->
+ a.Typed_parameter.add_set_hook (fun _ _ -> update ())
+ | Typed_parameter.Int(a, _) ->
+ a.Typed_parameter.add_set_hook (fun _ _ -> update ())
+ | Typed_parameter.String(a, _) ->
+ a.Typed_parameter.add_set_hook (fun _ _ -> update ()))
+ (* [JS 2012/02/07] should be limited to
+ [Option_functor.get_selection_context], but it is not possible while
+ each plug-in (including Wp) is not projectified *)
+ (* (Option_functor.get_selection_context ~is_set:false ()))*)
+ (Parameter_state.get_selection ~is_set:false ()))
let update_table tbl =
(* remove old stuff *)
Usable_emitters_of_emitter.iter
(fun _ (_, all_usable_e) ->
- Usable_emitter.Set.iter
- (fun e ->
- (* remove dependencies corresponding to old correctness parameters *)
- Datatype.String.Map.iter
- (fun p _ ->
- try
- iter_on_kinds
- (State_dependency_graph.remove_dependencies
- ~from:(State.get p))
- e.u_kinds
- with State.Unknown ->
- (* In multi-sessions mode (e.g. save/load), the state for this
- parameter may not exist if the plug-in which defines it is
- not here anymore. Nothing special to do since the
- dependencies have already been removed by the load mechanism
- when states are missing (fix bug #2181). *)
- ())
- e.correctness_values;
- (* remove hooks corresponding to old tuning parameters *)
- Typed_parameter.Hashtbl.iter
- (fun _ tbl -> Datatype.String.Hashtbl.clear tbl)
- parameter_hooks)
- !all_usable_e);
+ Usable_emitter.Set.iter
+ (fun e ->
+ (* remove dependencies corresponding to old correctness parameters *)
+ Datatype.String.Map.iter
+ (fun p _ ->
+ try
+ iter_on_kinds
+ (State_dependency_graph.remove_dependencies
+ ~from:(State.get p))
+ e.u_kinds
+ with State.Unknown ->
+ (* In multi-sessions mode (e.g. save/load), the state for this
+ parameter may not exist if the plug-in which defines it is
+ not here anymore. Nothing special to do since the
+ dependencies have already been removed by the load mechanism
+ when states are missing (fix bug #2181). *)
+ ())
+ e.correctness_values;
+ (* remove hooks corresponding to old tuning parameters *)
+ Typed_parameter.Hashtbl.iter
+ (fun _ tbl -> Datatype.String.Hashtbl.clear tbl)
+ parameter_hooks)
+ !all_usable_e);
(* register new stuff *)
Datatype.String.Hashtbl.iter
(fun e_name (_, all_usable_e) ->
- Usable_emitter.Set.iter
- (fun e ->
- Datatype.String.Map.iter
- (fun p _ -> register_correctness_parameter p e.u_name e.u_kinds)
- e.correctness_values;
- Datatype.String.Map.iter
- (fun p _ ->
- try
- let ty_p = Typed_parameter.get p in
- register_tuning_parameter e_name ty_p
- with Not_found ->
- (* the parameter could not exist anymore in multi-sessions mode
- (e.g. save/load): just ignore it in that case *)
- ())
- e.tuning_values)
- !all_usable_e)
+ Usable_emitter.Set.iter
+ (fun e ->
+ Datatype.String.Map.iter
+ (fun p _ -> register_correctness_parameter p e.u_name e.u_kinds)
+ e.correctness_values;
+ Datatype.String.Map.iter
+ (fun p _ ->
+ try
+ let ty_p = Typed_parameter.get p in
+ register_tuning_parameter e_name ty_p
+ with Not_found ->
+ (* the parameter could not exist anymore in multi-sessions mode
+ (e.g. save/load): just ignore it in that case *)
+ ())
+ e.tuning_values)
+ !all_usable_e)
tbl
let () = Usable_emitters_of_emitter.add_hook_on_update update_table
@@ -461,8 +461,8 @@ let register_parameter tuning usable_e p =
let create_usable_emitter e =
let id = Usable_id.next () in
- let usable_e =
- { u_id = id;
+ let usable_e =
+ { u_id = id;
u_name = e.name;
u_kinds = e.kinds;
used = true;
@@ -470,25 +470,25 @@ let create_usable_emitter e =
tuning_values = Datatype.String.Map.empty;
correctness_values = Datatype.String.Map.empty }
in
- let usable_e =
+ let usable_e =
List.fold_left (register_parameter true) usable_e e.tuning_parameters
in
let usable_e =
List.fold_left (register_parameter false) usable_e e.correctness_parameters
- in
+ in
usable_e.version <- 1;
usable_e
-let get e =
+let get e =
let name = e.name in
- try
+ try
let current, _ = Usable_emitters_of_emitter.find name in
let c = !current in
c.used <- true;
c
with Not_found ->
let usable_e = create_usable_emitter e in
- Usable_emitters_of_emitter.add
+ Usable_emitters_of_emitter.add
name
(ref usable_e, ref (Usable_emitter.Set.singleton usable_e));
usable_e
@@ -496,15 +496,15 @@ let get e =
module ED = D (* for debugging *)
module Make_table
- (H: Datatype.Hashtbl)
- (E: sig
- include Datatype.S_with_collections
- val local_clear: H.key -> 'a Hashtbl.t -> unit
- val usable_get: t -> Usable_emitter.t
- val get: t -> emitter
- end)
- (D: Datatype.S)
- (Info: sig include State_builder.Info_with_size val kinds: kind list end) =
+ (H: Datatype.Hashtbl)
+ (E: sig
+ include Datatype.S_with_collections
+ val local_clear: H.key -> 'a Hashtbl.t -> unit
+ val usable_get: t -> Usable_emitter.t
+ val get: t -> emitter
+ end)
+ (D: Datatype.S)
+ (Info: sig include State_builder.Info_with_size val kinds: kind list end) =
struct
module Remove_hooks = Hook.Build(struct type t = E.t * H.key * D.t end)
@@ -520,15 +520,15 @@ struct
(* [KNOWN LIMITATION] only works iff the selection contains the parameter'
state. In particular, that does not work if one writes something like
- let selection =
- State_selection.only_dependencies Kernel.MainFunction.self
+ let selection =
+ State_selection.only_dependencies Kernel.MainFunction.self
in
Project.clear ~selection () *)
let must_local_clear sel =
- try
+ try
State.Hashtbl.iter
- (fun s () -> if State_selection.mem sel s then raise Exit)
- correctness_states;
+ (fun s () -> if State_selection.mem sel s then raise Exit)
+ correctness_states;
true
with Exit ->
false
@@ -544,71 +544,71 @@ struct
(* standard projectified hashtbl, but an ad-hoc function 'clear' *)
include State_builder.Register
- (H_datatype)
- (struct
- type t = Tbl.t H.t
- let create = create
- let clear tbl =
- let sel = Project.get_current_selection () in
- (* Kernel.feedback "SELECT: %a" State_selection.pretty sel;*)
- if must_clear_all sel then begin
- (* someone explicitly requires to fully reset the table *)
- Kernel.debug ~dkey:Kernel.dkey_emitter_clear "FULL CLEAR of %s in %a"
- Info.name Project.pretty (Project.current ());
- H.clear tbl
- end else
- (* AST is unchanged *)
- if must_local_clear sel then begin
- (* one have to clear the table, but we have to keep the keys *)
- Kernel.debug ~dkey:Kernel.dkey_emitter_clear "LOCAL CLEAR of %s in %a"
- Info.name Project.pretty (Project.current ());
- H.iter
- (fun k h ->
- if not (Remove_hooks.is_empty ()) then
- E.Hashtbl.iter (fun e x -> apply_hooks_on_remove e k x) h;
- E.local_clear k h)
- tbl;
- end else begin
- (* we have to clear only the bindings corresponding to the selected
- correctness parameters *)
- let to_be_removed = ref [] in
- H.iter
- (fun k h ->
- E.Hashtbl.iter
- (fun e x ->
- let is_param_selected =
- List.exists
- (fun p -> State_selection.mem sel (State.get p))
- (Usable_emitter.correctness_parameters (E.usable_get e))
- in
- if is_param_selected then
- to_be_removed := (k, e, x) :: !to_be_removed)
- h)
- tbl;
- List.iter
- (fun (k, e, x) ->
- try
- let h = H.find tbl k in
- Kernel.debug ~dkey:Kernel.dkey_emitter_clear
- "CLEARING binding %a of %s in %a"
- ED.pretty (E.get e)
- Info.name
- Project.pretty (Project.current ());
- E.Hashtbl.remove h e;
- apply_hooks_on_remove e k x
- with Not_found ->
- assert false)
- !to_be_removed
- end
- let get () = !state
- let set x = state := x
- let clear_some_projects _f _h = false
- end)
- (struct
- include Info
- let unique_name = name
- let dependencies = self :: dependencies
- end)
+ (H_datatype)
+ (struct
+ type t = Tbl.t H.t
+ let create = create
+ let clear tbl =
+ let sel = Project.get_current_selection () in
+ (* Kernel.feedback "SELECT: %a" State_selection.pretty sel;*)
+ if must_clear_all sel then begin
+ (* someone explicitly requires to fully reset the table *)
+ Kernel.debug ~dkey:Kernel.dkey_emitter_clear "FULL CLEAR of %s in %a"
+ Info.name Project.pretty (Project.current ());
+ H.clear tbl
+ end else
+ (* AST is unchanged *)
+ if must_local_clear sel then begin
+ (* one have to clear the table, but we have to keep the keys *)
+ Kernel.debug ~dkey:Kernel.dkey_emitter_clear "LOCAL CLEAR of %s in %a"
+ Info.name Project.pretty (Project.current ());
+ H.iter
+ (fun k h ->
+ if not (Remove_hooks.is_empty ()) then
+ E.Hashtbl.iter (fun e x -> apply_hooks_on_remove e k x) h;
+ E.local_clear k h)
+ tbl;
+ end else begin
+ (* we have to clear only the bindings corresponding to the selected
+ correctness parameters *)
+ let to_be_removed = ref [] in
+ H.iter
+ (fun k h ->
+ E.Hashtbl.iter
+ (fun e x ->
+ let is_param_selected =
+ List.exists
+ (fun p -> State_selection.mem sel (State.get p))
+ (Usable_emitter.correctness_parameters (E.usable_get e))
+ in
+ if is_param_selected then
+ to_be_removed := (k, e, x) :: !to_be_removed)
+ h)
+ tbl;
+ List.iter
+ (fun (k, e, x) ->
+ try
+ let h = H.find tbl k in
+ Kernel.debug ~dkey:Kernel.dkey_emitter_clear
+ "CLEARING binding %a of %s in %a"
+ ED.pretty (E.get e)
+ Info.name
+ Project.pretty (Project.current ());
+ E.Hashtbl.remove h e;
+ apply_hooks_on_remove e k x
+ with Not_found ->
+ assert false)
+ !to_be_removed
+ end
+ let get () = !state
+ let set x = state := x
+ let clear_some_projects _f _h = false
+ end)
+ (struct
+ include Info
+ let unique_name = name
+ let dependencies = self :: dependencies
+ end)
let add_kind k =
try
@@ -622,13 +622,13 @@ struct
List.iter add_kind Info.kinds;
let get_dependencies () =
State_dependency_graph.G.fold_pred
- (fun s acc -> s :: acc)
- State_dependency_graph.graph
- self
- []
+ (fun s acc -> s :: acc)
+ State_dependency_graph.graph
+ self
+ []
in
Cmdline.run_after_early_stage
- (fun () -> static_dependencies := get_dependencies ())
+ (fun () -> static_dependencies := get_dependencies ())
let add key v = H.add !state key v
let find key = H.find !state key
@@ -637,14 +637,14 @@ struct
let fold f acc = H.fold f !state acc
let iter_sorted ~cmp f = H.iter_sorted ~cmp f !state
let fold_sorted ~cmp f acc = H.fold_sorted ~cmp f !state acc
- let remove key =
+ let remove key =
if not (Remove_hooks.is_empty ()) then begin
try
- let tbl = find key in
- E.Hashtbl.iter (fun e v -> apply_hooks_on_remove e key v) tbl;
+ let tbl = find key in
+ E.Hashtbl.iter (fun e v -> apply_hooks_on_remove e key v) tbl;
with Not_found ->
- ()
- end;
+ ()
+ end;
H.remove !state key;
end
diff --git a/src/kernel_services/plugin_entry_points/emitter.mli b/src/kernel_services/plugin_entry_points/emitter.mli
index 2540b0e092e482d6e6b91bd77b8aa158797cd1de..4121d8287f27f6d1f02389f97facb63ae3570094 100644
--- a/src/kernel_services/plugin_entry_points/emitter.mli
+++ b/src/kernel_services/plugin_entry_points/emitter.mli
@@ -35,10 +35,10 @@ type kind = Property_status | Alarm | Code_annot | Funspec | Global_annot
include Datatype.S_with_collections with type t = emitter
-val create:
- string ->
- kind list ->
- correctness:Typed_parameter.t list ->
+val create:
+ string ->
+ kind list ->
+ correctness:Typed_parameter.t list ->
tuning:Typed_parameter.t list -> t
(** [Emitter.create name kind ~correctness ~tuning] creates a new emitter with
the given name. The given parameters are the ones which impact the generated
@@ -48,7 +48,7 @@ val create:
element when its value changes (for instance, a "dont_know" status may
become valid or invalid, but a valid status cannot become invalid).
The given name must be unique.
- @raise Invalid_argument if an emitter with the given name already exist
+ @raise Invalid_argument if an emitter with the given name already exist
@plugin development guide *)
val get_name: t -> string
@@ -67,18 +67,18 @@ val kernel: t
@since Oxygen-20120901 *)
val orphan: t
- (** special emitter for adopting annotations that were generated by an
- emitter that is no longer available (in particular, annotations loaded
- from a state that was generated from a different set of plug-ins than
- in current session). Should not be used outside of the kernel.
- @since 22.0-Titanium
- *)
+(** special emitter for adopting annotations that were generated by an
+ emitter that is no longer available (in particular, annotations loaded
+ from a state that was generated from a different set of plug-ins than
+ in current session). Should not be used outside of the kernel.
+ @since 22.0-Titanium
+*)
(** Usable emitters are the ones which can really emit something. *)
module Usable_emitter: sig
include Datatype.S_with_collections
val get: t -> emitter
- (** Get the emitter from an usable emitter. Not so efficient.
+ (** Get the emitter from an usable emitter. Not so efficient.
@since Oxygen-20120901 *)
val get_name: t -> string
@@ -86,8 +86,8 @@ module Usable_emitter: sig
val correctness_parameters: t -> string list
val tuning_parameters: t -> string list
val pretty_parameter: Format.formatter -> tuning:bool -> t -> string -> unit
-(** Pretty print the parameter (given by its name) with its value.
- @raise Not_found if the parameter is not one of the given emitter *)
+ (** Pretty print the parameter (given by its name) with its value.
+ @raise Not_found if the parameter is not one of the given emitter *)
end
val distinct_tuning_parameters: Usable_emitter.t -> Datatype.String.Set.t
@@ -105,7 +105,7 @@ val distinct_correctness_parameters: Usable_emitter.t -> Datatype.String.Set.t
(* ********************************************************************** *)
val get: t -> Usable_emitter.t
-(** Get the emitter which is really able to emit something.
+(** Get the emitter which is really able to emit something.
This function must be called at the time of the emission. No action must
occur between the call to [get] and the emission (in particular no update
of any parameter of the emitter. *)
@@ -116,18 +116,18 @@ val dummy: t
(** Table indexing: key -> emitter (or equivalent data) -> value.
Quick access + handle cleaning in the right way (only remove relevant
- bindings when required.
+ bindings when required.
@since Oxygen-20120901 *)
module Make_table
- (H: Datatype.Hashtbl)
- (E: sig
- include Datatype.S_with_collections
- val local_clear: H.key -> 'a Hashtbl.t -> unit
- val usable_get: t -> Usable_emitter.t
- val get: t -> emitter
- end)
- (D: Datatype.S)
- (Info: sig include State_builder.Info_with_size val kinds: kind list end) :
+ (H: Datatype.Hashtbl)
+ (E: sig
+ include Datatype.S_with_collections
+ val local_clear: H.key -> 'a Hashtbl.t -> unit
+ val usable_get: t -> Usable_emitter.t
+ val get: t -> emitter
+ end)
+ (D: Datatype.S)
+ (Info: sig include State_builder.Info_with_size val kinds: kind list end) :
sig
type internal_tbl = D.t E.Hashtbl.t
val self: State.t
@@ -143,12 +143,12 @@ sig
(H.key -> internal_tbl -> 'a -> 'a) -> 'a -> 'a
val remove: H.key -> unit
val add_hook_on_remove: (E.t -> H.key -> D.t -> unit) -> unit
-(** Register a hook to be applied whenever a binding is removed from the table.
- @since Fluorine-20130401 *)
+ (** Register a hook to be applied whenever a binding is removed from the table.
+ @since Fluorine-20130401 *)
val apply_hooks_on_remove: E.t -> H.key -> D.t -> unit
-(** This function must be called on each binding which is removed from the
- table without directly calling the function {!remove}.
- @since Fluorine-20130401 *)
+ (** This function must be called on each binding which is removed from the
+ table without directly calling the function {!remove}.
+ @since Fluorine-20130401 *)
end
(*
diff --git a/src/kernel_services/plugin_entry_points/journal.ml b/src/kernel_services/plugin_entry_points/journal.ml
index 33407609cbe7e191bb1723f8d946db5c42c60eb5..630371b8ee7d0268a69d79bbe876263e99ffa37a 100644
--- a/src/kernel_services/plugin_entry_points/journal.ml
+++ b/src/kernel_services/plugin_entry_points/journal.ml
@@ -51,8 +51,8 @@ let started = ref false
module Sentences = struct
type t =
- { sentence: Format.formatter -> unit;
- raise_exn: bool }
+ { sentence: Format.formatter -> unit;
+ raise_exn: bool }
let sentences : t Queue.t = Queue.create ()
@@ -87,11 +87,11 @@ module Abstract_modules = struct
let () = Type.add_abstract_types := Hashtbl.replace tbl
let write fmt =
Hashtbl.iter
- (fun k v ->
- Format.fprintf fmt
- "@[<hv 2>let module %s=@;@[<hv 0>Type.Abstract\
-(struct let name = %S end) in@]@]@;"
- k v)
+ (fun k v ->
+ Format.fprintf fmt
+ "@[<hv 2>let module %s=@;@[<hv 0>Type.Abstract\
+ (struct let name = %S end) in@]@]@;"
+ k v)
tbl
let tbl_copy = ref (Hashtbl.create 7)
let save () = tbl_copy := Hashtbl.copy tbl
@@ -184,9 +184,9 @@ let get_filename =
(try
let n =
Str.search_backward
- (Str.regexp "_[0-9]+")
- name
- (String.length name - 1)
+ (Str.regexp "_[0-9]+")
+ name
+ (String.length name - 1)
in
filename := Str.string_before name n ^ suf
with Not_found ->
@@ -233,13 +233,13 @@ let () =
module Binding: sig
val add: 'a Type.t -> 'a -> string -> unit
- (** [add ty v var] binds the value [v] to the variable name [var]. Thus,
- [pp ty v] prints [var] and not use the standard pretty printer. Very
- useful to pretty print values with no associated pretty printer. *)
+ (** [add ty v var] binds the value [v] to the variable name [var]. Thus,
+ [pp ty v] prints [var] and not use the standard pretty printer. Very
+ useful to pretty print values with no associated pretty printer. *)
exception Name_already_exists of string
val add_once: 'a Type.t -> 'a -> string -> unit
- (** Same as function [add] above but raise the exception [Already_exists]
- if the binding previously exists *)
+ (** Same as function [add] above but raise the exception [Already_exists]
+ if the binding previously exists *)
val find: 'a Type.t -> 'a -> string
val iter: ('a Type.t -> 'a -> string -> unit) -> unit
end = struct
@@ -270,7 +270,7 @@ end = struct
let iter f = Type.Obj_tbl.iter bindings f (* eta-expansion required *)
(* predefined bindings *)
- let () =
+ let () =
add Datatype.formatter Format.std_formatter "Format.std_formatter";
add Datatype.formatter Format.err_formatter "Format.err_formatter"
@@ -289,8 +289,8 @@ module Reverse_binding = struct
let pretty fmt () =
iter
- (fun name ty v ->
- Format.fprintf fmt "%s --> %a@." name (Datatype.pretty ty) v)
+ (fun name ty v ->
+ Format.fprintf fmt "%s --> %a@." name (Datatype.pretty ty) v)
end
@@ -300,15 +300,15 @@ let never_write name f =
if Obj.tag (Obj.repr f) = Obj.closure_tag then
Obj.magic
(fun y ->
- if !started then Obj.magic f y
- else
- let msg =
- Format.asprintf
- "a call to the function %s has to be written in the journal, \
-but this function was never journalized."
- name
- in
- raise (Not_writable msg))
+ if !started then Obj.magic f y
+ else
+ let msg =
+ Format.asprintf
+ "a call to the function %s has to be written in the journal, \
+ but this function was never journalized."
+ name
+ in
+ raise (Not_writable msg))
else
invalid_arg ("[Journal.never_write] " ^ name ^ " is not a closure")
else
@@ -321,19 +321,19 @@ let pp (type t) (ty: t Type.t) fmt (x:t) =
let pp_error msg =
Format.fprintf fmt "@[<hov 2>(failwith @[<hov 2>\"%s:@ running the journal will fail.\"@])@;@]" msg
in
- let pp = Datatype.internal_pretty_code ty in
- if pp == Datatype.undefined then
- pp_error
- (Format.asprintf
- "no printer registered for value of type %s"
- (Type.name ty))
- else if pp == Datatype.pp_fail then
- pp_error
- (Format.asprintf
- "no code for pretty printer of type %s"
- (Type.name ty))
- else
- pp Type.Call fmt x
+ let pp = Datatype.internal_pretty_code ty in
+ if pp == Datatype.undefined then
+ pp_error
+ (Format.asprintf
+ "no printer registered for value of type %s"
+ (Type.name ty))
+ else if pp == Datatype.pp_fail then
+ pp_error
+ (Format.asprintf
+ "no code for pretty printer of type %s"
+ (Type.name ty))
+ else
+ pp Type.Call fmt x
let gen_binding =
let ids = Hashtbl.create 7 in
@@ -377,12 +377,12 @@ let print_sentence f_acc is_dyn comment ?value ty fmt =
let varname = Datatype.varname ty in
match varname == Datatype.undefined, value with
| true, _ | _, None ->
- "__" (* no binding nor value: ignore the result *)
+ "__" (* no binding nor value: ignore the result *)
| false, Some value ->
- (* bind to a fresh variable name *)
- let b = gen_binding (varname value) in
- Binding.add ty value b;
- b
+ (* bind to a fresh variable name *)
+ let b = gen_binding (varname value) in
+ Binding.add ty value b;
+ b
in
Format.fprintf fmt "%s" binding;
(* add the return type for dynamic application *)
@@ -418,54 +418,54 @@ let catch_exn f_acc is_dyn comment ret_ty exn =
in
Sentences.add print true
-let rec journalize_function: 't.
- (Format.formatter -> unit) -> 't Type.t -> bool ->
+let rec journalize_function: 't.
+ (Format.formatter -> unit) -> 't Type.t -> bool ->
(Format.formatter -> unit) option -> 't -> 't =
fun (type t) (type a) (type b) f_acc (ty: t Type.t) is_dyn comment (x:t)
- ->
- assert Cmdline.use_type;
- if Type.Function.is_instance_of ty then begin
- (* [ty] is a function type value:
- there exists [a] and [b] such than [t = a -> b] *)
- let ty: (a -> b) Type.t = Obj.magic (ty: t Type.t) in
- let f: a -> b = Obj.magic (x: t) in
- let (a: a Type.t), (b: b Type.t), opt_label =
- Type.Function.get_instance ty
- in
- let opt_arg = Type.Function.get_optional_argument ty in
- let f (y: a) : b =
- if !started then
- (* prevent journalisation if you're journalizing another function *)
- f y
- else begin
- try
- (* [started] prevents journalization of function call
- inside another one *)
- started := true;
- (* apply the closure [x] to its argument [y] *)
- let xy = f y in
- started := false;
- (* extend the continuation and continue *)
- let f_acc = extend_continuation f_acc (pp a) opt_label opt_arg y in
- journalize_function f_acc b is_dyn comment xy
- with
- | Not_writable name ->
- started := false;
- fatal
- "a call to the function %S cannot be written in the journal"
- name
- | exn as e ->
- let f_acc = extend_continuation f_acc (pp a) opt_label opt_arg y in
- catch_exn f_acc is_dyn comment b exn;
- started := false;
- raise e
- end in
- (* cast back the closure of type [a -> b] into [t] *)
- (Obj.magic (f: a -> b): t)
- end else begin
- if not !started then add_sentence f_acc is_dyn comment ~value:x ty;
- x
- end
+ ->
+ assert Cmdline.use_type;
+ if Type.Function.is_instance_of ty then begin
+ (* [ty] is a function type value:
+ there exists [a] and [b] such than [t = a -> b] *)
+ let ty: (a -> b) Type.t = Obj.magic (ty: t Type.t) in
+ let f: a -> b = Obj.magic (x: t) in
+ let (a: a Type.t), (b: b Type.t), opt_label =
+ Type.Function.get_instance ty
+ in
+ let opt_arg = Type.Function.get_optional_argument ty in
+ let f (y: a) : b =
+ if !started then
+ (* prevent journalisation if you're journalizing another function *)
+ f y
+ else begin
+ try
+ (* [started] prevents journalization of function call
+ inside another one *)
+ started := true;
+ (* apply the closure [x] to its argument [y] *)
+ let xy = f y in
+ started := false;
+ (* extend the continuation and continue *)
+ let f_acc = extend_continuation f_acc (pp a) opt_label opt_arg y in
+ journalize_function f_acc b is_dyn comment xy
+ with
+ | Not_writable name ->
+ started := false;
+ fatal
+ "a call to the function %S cannot be written in the journal"
+ name
+ | exn as e ->
+ let f_acc = extend_continuation f_acc (pp a) opt_label opt_arg y in
+ catch_exn f_acc is_dyn comment b exn;
+ started := false;
+ raise e
+ end in
+ (* cast back the closure of type [a -> b] into [t] *)
+ (Obj.magic (f: a -> b): t)
+ end else begin
+ if not !started then add_sentence f_acc is_dyn comment ~value:x ty;
+ x
+ end
let register s ty ?comment ?(is_dyn=false) x =
if Cmdline.journal_enable then begin
diff --git a/src/kernel_services/plugin_entry_points/journal.mli b/src/kernel_services/plugin_entry_points/journal.mli
index 8d7f8e2b87b4ce43bd352ca302f8c6c766c51e54..b3e63d7548ed5b293b0a28f1634136c94147504d 100644
--- a/src/kernel_services/plugin_entry_points/journal.mli
+++ b/src/kernel_services/plugin_entry_points/journal.mli
@@ -34,41 +34,41 @@ val register:
?is_dyn:bool ->
'a ->
'a
- (** [register name ty ~comment ~is_dyn v] journalizes the value [v]
- of type [ty] with the name [name]. [name] must exactly match the caml
- long name of the value (i.e. "List.iter" and not "iter" even though the
- module List is already opened). Journalisation of anonymous value is
- not possible.
+(** [register name ty ~comment ~is_dyn v] journalizes the value [v]
+ of type [ty] with the name [name]. [name] must exactly match the caml
+ long name of the value (i.e. "List.iter" and not "iter" even though the
+ module List is already opened). Journalisation of anonymous value is
+ not possible.
- If the [comment] argument is set, the given pretty printer will be
- applied in an OCaml comment when the function is journalized.
+ If the [comment] argument is set, the given pretty printer will be
+ applied in an OCaml comment when the function is journalized.
- Set [is_dyn] to [true] to journalize a dynamic function. *)
+ Set [is_dyn] to [true] to journalize a dynamic function. *)
val never_write: string -> 'a -> 'a
- (** [never_write name f] returns a closure [g] observationally equal to [f]
- except that trying to write a call to [g] in the journal is an error. If
- [f] is not a closure, then [never_write name f] raises
- [Invalid_argument]. *)
+(** [never_write name f] returns a closure [g] observationally equal to [f]
+ except that trying to write a call to [g] in the journal is an error. If
+ [f] is not a closure, then [never_write name f] raises
+ [Invalid_argument]. *)
val prevent: ('a -> 'b) -> 'a -> 'b
- (** [prevent f x] applies [x] to [f] without printing anything in the
- journal, even if [f] is journalized. *)
+(** [prevent f x] applies [x] to [f] without printing anything in the
+ journal, even if [f] is journalized. *)
module Binding: sig
val add: 'a Type.t -> 'a -> string -> unit
- (** [add ty v var] binds the value [v] to the variable name [var]. Thus,
- [pp ty v] prints [var] and not use the standard pretty printer. Very
- useful to pretty print values with no associated pretty printer. *)
+ (** [add ty v var] binds the value [v] to the variable name [var]. Thus,
+ [pp ty v] prints [var] and not use the standard pretty printer. Very
+ useful to pretty print values with no associated pretty printer. *)
exception Name_already_exists of string
val add_once: 'a Type.t -> 'a -> string -> unit
- (** Same as function [add] above but raise the exception [Already_exists]
- if the binding previously exists *)
+ (** Same as function [add] above but raise the exception [Already_exists]
+ if the binding previously exists *)
end
(* JS 2012/02/07: useful only for BM introspection testing ;-) *)
module Reverse_binding: sig
-
+
(* Raised by [find] *)
exception Unbound_value of string
exception Incompatible_type of string
@@ -84,31 +84,31 @@ end
(* ****************************************************************************)
val get_name: unit -> Datatype.Filepath.t
- (** @return the filename which the journal will be written into. *)
+(** @return the filename which the journal will be written into. *)
val set_name: string -> unit
- (** [set_name name] changes the filename into the journal is generated. *)
+(** [set_name name] changes the filename into the journal is generated. *)
val write: unit -> unit
- (** [write ()] writes the content of the journal into the file set by
- [set_name] (or in "frama_c_journal.ml" by default);
- without clearing the journal. *)
+(** [write ()] writes the content of the journal into the file set by
+ [set_name] (or in "frama_c_journal.ml" by default);
+ without clearing the journal. *)
val save: unit -> unit
- (** Save the current state of the journal for future restoration.
- @since Beryllium-20090901 *)
+(** Save the current state of the journal for future restoration.
+ @since Beryllium-20090901 *)
val restore: unit -> unit
- (** Restore a previously saved journal.
- @since Beryllium-20090901 *)
+(** Restore a previously saved journal.
+ @since Beryllium-20090901 *)
(* ****************************************************************************)
(** {2 Internal use only} *)
(* ****************************************************************************)
val keep_file: string -> unit
- (** This function has not to be used explicitly. Only offers functions
- retrieving when running a journal file. *)
+(** This function has not to be used explicitly. Only offers functions
+ retrieving when running a journal file. *)
val get_session_file: (string -> Datatype.Filepath.t) ref
diff --git a/src/kernel_services/visitors/cabsvisit.ml b/src/kernel_services/visitors/cabsvisit.ml
index 2237d0abe0a4a9b6e410c3f699d96613d437dc9d..1783feb0a22c113b7f41dc73a786a520562b507c 100644
--- a/src/kernel_services/visitors/cabsvisit.ml
+++ b/src/kernel_services/visitors/cabsvisit.ml
@@ -69,7 +69,7 @@ class type cabsVisitor = object
method vtypespec: typeSpecifier -> typeSpecifier visitAction
method vdecltype: decl_type -> decl_type visitAction
- (* For each declaration we call vname *)
+ (* For each declaration we call vname *)
method vname: nameKind -> specifier -> name -> name visitAction
method vspec: specifier -> specifier visitAction (* specifier *)
method vattr: attribute -> attribute list visitAction
@@ -112,45 +112,45 @@ let rec visitCabsTypeSpecifier (vis: cabsVisitor) (ts: typeSpecifier) =
and childrenTypeSpecifier vis ts =
let childrenFieldGroup input = match input with
| FIELD (s, nel) ->
- let s' = visitCabsSpecifier vis s in
- let doOneField ((n, eo) as input) =
- let n' = visitCabsName vis NField s' n in
- let eo' =
- match eo with
- None -> None
- | Some e -> let e' = visitCabsExpression vis e in
- if e' != e then Some e' else eo
- in
- if n' != n || eo' != eo then (n', eo') else input
- in
- let nel' = mapNoCopy doOneField nel in
- if s' != s || nel' != nel then FIELD (s', nel') else input
+ let s' = visitCabsSpecifier vis s in
+ let doOneField ((n, eo) as input) =
+ let n' = visitCabsName vis NField s' n in
+ let eo' =
+ match eo with
+ None -> None
+ | Some e -> let e' = visitCabsExpression vis e in
+ if e' != e then Some e' else eo
+ in
+ if n' != n || eo' != eo then (n', eo') else input
+ in
+ let nel' = mapNoCopy doOneField nel in
+ if s' != s || nel' != nel then FIELD (s', nel') else input
| TYPE_ANNOT _ -> input
in
match ts with
Tstruct (n, Some fg, extraAttrs) ->
- (*(trace "sm" (dprintf "visiting struct %s\n" n));*)
- let fg' = mapNoCopy childrenFieldGroup fg in
- if fg' != fg then Tstruct( n, Some fg', extraAttrs) else ts
+ (*(trace "sm" (dprintf "visiting struct %s\n" n));*)
+ let fg' = mapNoCopy childrenFieldGroup fg in
+ if fg' != fg then Tstruct( n, Some fg', extraAttrs) else ts
| Tunion (n, Some fg, extraAttrs) ->
- let fg' = mapNoCopy childrenFieldGroup fg in
- if fg' != fg then Tunion( n, Some fg', extraAttrs) else ts
+ let fg' = mapNoCopy childrenFieldGroup fg in
+ if fg' != fg then Tunion( n, Some fg', extraAttrs) else ts
| Tenum (n, Some ei, extraAttrs) ->
- let doOneEnumItem ((s, e, loc) as ei) =
- let e' = visitCabsExpression vis e in
- if e' != e then (s, e', loc) else ei
- in
- vis#vEnterScope ();
- let ei' = mapNoCopy doOneEnumItem ei in
- vis#vExitScope();
- if ei' != ei then Tenum( n, Some ei', extraAttrs) else ts
- | TtypeofE e ->
+ let doOneEnumItem ((s, e, loc) as ei) =
let e' = visitCabsExpression vis e in
- if e' != e then TtypeofE e' else ts
+ if e' != e then (s, e', loc) else ei
+ in
+ vis#vEnterScope ();
+ let ei' = mapNoCopy doOneEnumItem ei in
+ vis#vExitScope();
+ if ei' != ei then Tenum( n, Some ei', extraAttrs) else ts
+ | TtypeofE e ->
+ let e' = visitCabsExpression vis e in
+ if e' != e then TtypeofE e' else ts
| TtypeofT (s, dt) ->
- let s' = visitCabsSpecifier vis s in
- let dt' = visitCabsDeclType vis false dt in
- if s != s' || dt != dt' then TtypeofT (s', dt') else ts
+ let s' = visitCabsSpecifier vis s in
+ let dt' = visitCabsDeclType vis false dt in
+ if s != s' || dt != dt' then TtypeofT (s', dt') else ts
| ts -> ts
and childrenSpecElem (vis: cabsVisitor) (se: spec_elem) : spec_elem =
@@ -163,10 +163,10 @@ and childrenSpecElem (vis: cabsVisitor) (se: spec_elem) : spec_elem =
[a''] when a'' == a -> se
| [a''] -> SpecAttr a''
| _ -> Kernel.fatal "childrenSpecElem: visitCabsAttribute returned a list"
- end
+ end
| SpecType ts ->
- let ts' = visitCabsTypeSpecifier vis ts in
- if ts' != ts then SpecType ts' else se
+ let ts' = visitCabsTypeSpecifier vis ts in
+ if ts' != ts then SpecType ts' else se
and visitCabsSpecifier (vis: cabsVisitor) (s: specifier) : specifier =
doVisit vis vis#vspec childrenSpec s
@@ -179,31 +179,31 @@ and childrenDeclType isfundef vis dt =
match dt with
JUSTBASE -> dt
| PARENTYPE (prea, dt1, posta) ->
- let prea' = mapNoCopyList (visitCabsAttribute vis) prea in
- let dt1' = visitCabsDeclType vis isfundef dt1 in
- let posta'= mapNoCopyList (visitCabsAttribute vis) posta in
- if prea' != prea || dt1' != dt1 || posta' != posta then
- PARENTYPE (prea', dt1', posta') else dt
+ let prea' = mapNoCopyList (visitCabsAttribute vis) prea in
+ let dt1' = visitCabsDeclType vis isfundef dt1 in
+ let posta'= mapNoCopyList (visitCabsAttribute vis) posta in
+ if prea' != prea || dt1' != dt1 || posta' != posta then
+ PARENTYPE (prea', dt1', posta') else dt
| ARRAY (dt1, al, e) ->
- let dt1' = visitCabsDeclType vis isfundef dt1 in
- let al' = mapNoCopy (childrenAttribute vis) al in
- let e'= visitCabsExpression vis e in
- if dt1' != dt1 || al' != al || e' != e then ARRAY(dt1', al', e') else dt
+ let dt1' = visitCabsDeclType vis isfundef dt1 in
+ let al' = mapNoCopy (childrenAttribute vis) al in
+ let e'= visitCabsExpression vis e in
+ if dt1' != dt1 || al' != al || e' != e then ARRAY(dt1', al', e') else dt
| PTR (al, dt1) ->
- let al' = mapNoCopy (childrenAttribute vis) al in
- let dt1' = visitCabsDeclType vis isfundef dt1 in
- if al' != al || dt1' != dt1 then PTR(al', dt1') else dt
+ let al' = mapNoCopy (childrenAttribute vis) al in
+ let dt1' = visitCabsDeclType vis isfundef dt1 in
+ if al' != al || dt1' != dt1 then PTR(al', dt1') else dt
| PROTO (dt1, snl, gsnl, b) ->
- (* Do not propagate isfundef further *)
- let dt1' = visitCabsDeclType vis false dt1 in
- let _ = vis#vEnterScope () in
- let snl' = mapNoCopy (childrenSingleName vis NVar) snl in
- let gsnl' = mapNoCopy (childrenSingleName vis NVar) gsnl in
- (* Exit the scope only if not in a function definition *)
- let _ = if not isfundef then vis#vExitScope () in
- if dt1' != dt1 || snl' != snl || gsnl' != gsnl then
- PROTO(dt1', snl', gsnl' , b)
- else dt
+ (* Do not propagate isfundef further *)
+ let dt1' = visitCabsDeclType vis false dt1 in
+ let _ = vis#vEnterScope () in
+ let snl' = mapNoCopy (childrenSingleName vis NVar) snl in
+ let gsnl' = mapNoCopy (childrenSingleName vis NVar) gsnl in
+ (* Exit the scope only if not in a function definition *)
+ let _ = if not isfundef then vis#vExitScope () in
+ if dt1' != dt1 || snl' != snl || gsnl' != gsnl then
+ PROTO(dt1', snl', gsnl' , b)
+ else dt
and childrenNameGroup vis (kind: nameKind) ((s, nl) as input) =
@@ -212,7 +212,7 @@ and childrenNameGroup vis (kind: nameKind) ((s, nl) as input) =
if s' != s || nl' != nl then (s', nl') else input
and visitCabsName vis (k: nameKind) (s: specifier)
- (n: name) : name =
+ (n: name) : name =
doVisit vis (vis#vname k s) (childrenName s k) n
and childrenName (_s: specifier) (k: nameKind) vis (n: name) : name =
let (sn, dt, al, loc) = n in
@@ -237,29 +237,29 @@ and visitCabsDefinition vis (d: definition) : definition list =
and childrenDefinition vis d =
match d with
FUNDEF (spec,sn, b, l, lend) ->
- let sn' = childrenSingleName vis NFun sn in
- let b' = visitCabsBlock vis b in
- (* End the scope that was started by childrenFunctionName *)
- vis#vExitScope ();
- if sn' != sn || b' != b then FUNDEF (spec,sn', b', l, lend) else d
+ let sn' = childrenSingleName vis NFun sn in
+ let b' = visitCabsBlock vis b in
+ (* End the scope that was started by childrenFunctionName *)
+ vis#vExitScope ();
+ if sn' != sn || b' != b then FUNDEF (spec,sn', b', l, lend) else d
| DECDEF (spec,(s, inl), l) ->
- let s' = visitCabsSpecifier vis s in
- let inl' = mapNoCopy (childrenInitName vis s') inl in
- if s' != s || inl' != inl then DECDEF (spec,(s', inl'), l) else d
+ let s' = visitCabsSpecifier vis s in
+ let inl' = mapNoCopy (childrenInitName vis s') inl in
+ if s' != s || inl' != inl then DECDEF (spec,(s', inl'), l) else d
| TYPEDEF (ng, l) ->
- let ng' = childrenNameGroup vis NType ng in
- if ng' != ng then TYPEDEF (ng', l) else d
+ let ng' = childrenNameGroup vis NType ng in
+ if ng' != ng then TYPEDEF (ng', l) else d
| ONLYTYPEDEF (s, l) ->
- let s' = visitCabsSpecifier vis s in
- if s' != s then ONLYTYPEDEF (s', l) else d
+ let s' = visitCabsSpecifier vis s in
+ if s' != s then ONLYTYPEDEF (s', l) else d
| GLOBASM _ -> d
| PRAGMA (e, l) ->
- let e' = visitCabsExpression vis e in
- if e' != e then PRAGMA (e', l) else d
+ let e' = visitCabsExpression vis e in
+ if e' != e then PRAGMA (e', l) else d
| LINKAGE (n, l, dl) ->
- let dl' = mapNoCopyList (visitCabsDefinition vis) dl in
- if dl' != dl then LINKAGE (n, l, dl') else d
+ let dl' = mapNoCopyList (visitCabsDefinition vis) dl in
+ if dl' != dl then LINKAGE (n, l, dl') else d
| GLOBANNOT _ -> d
| CUSTOM _ -> d
@@ -280,117 +280,117 @@ and visitCabsStatement vis (s: statement) : statement list =
and childrenStatement vis s =
let ve e = visitCabsExpression vis e in
let vs l s = match visitCabsStatement vis s with
- [s'] -> s'
- | sl -> { s with stmt_node = BLOCK ({blabels = []; battrs = []; bstmts = sl }, l, l(*LRICEA*))}
+ [s'] -> s'
+ | sl -> { s with stmt_node = BLOCK ({blabels = []; battrs = []; bstmts = sl }, l, l(*LRICEA*))}
in
match s.stmt_node with
NOP _ -> s
| COMPUTATION (e, l) ->
- let e' = ve e in
- if e' != e then {s with stmt_node = COMPUTATION (e', l)} else s
+ let e' = ve e in
+ if e' != e then {s with stmt_node = COMPUTATION (e', l)} else s
| BLOCK (b, l, l') ->
- let b' = visitCabsBlock vis b in
- if b' != b then {s with stmt_node = BLOCK (b', l, l')} else s
+ let b' = visitCabsBlock vis b in
+ if b' != b then {s with stmt_node = BLOCK (b', l, l')} else s
| SEQUENCE (s1, s2, l) ->
- let s1' = vs l s1 in
- let s2' = vs l s2 in
- if s1' != s1 || s2' != s2 then {s with stmt_node = SEQUENCE (s1', s2', l)} else s
+ let s1' = vs l s1 in
+ let s2' = vs l s2 in
+ if s1' != s1 || s2' != s2 then {s with stmt_node = SEQUENCE (s1', s2', l)} else s
| IF (e, s1, s2, l) ->
- let e' = ve e in
- let s1' = vs l s1 in
- let s2' = vs l s2 in
- if e' != e || s1' != s1 || s2' != s2 then {s with stmt_node = IF (e', s1', s2', l)} else s
+ let e' = ve e in
+ let s1' = vs l s1 in
+ let s2' = vs l s2 in
+ if e' != e || s1' != s1 || s2' != s2 then {s with stmt_node = IF (e', s1', s2', l)} else s
| WHILE (a, e, s1, l) ->
- let e' = ve e in
- let s1' = vs l s1 in
- if e' != e || s1' != s1 then {s with stmt_node = WHILE (a, e', s1', l)} else s
+ let e' = ve e in
+ let s1' = vs l s1 in
+ if e' != e || s1' != s1 then {s with stmt_node = WHILE (a, e', s1', l)} else s
| DOWHILE (a, e, s1, l) ->
- let e' = ve e in
- let s1' = vs l s1 in
- if e' != e || s1' != s1 then {s with stmt_node = DOWHILE (a, e', s1', l)} else s
+ let e' = ve e in
+ let s1' = vs l s1 in
+ if e' != e || s1' != s1 then {s with stmt_node = DOWHILE (a, e', s1', l)} else s
| FOR (a, fc1, e2, e3, s4, l) ->
- let _ = vis#vEnterScope () in
- let fc1' =
- match fc1 with
- FC_EXP e1 ->
- let e1' = ve e1 in
- if e1' != e1 then FC_EXP e1' else fc1
- | FC_DECL d1 ->
- let d1' =
- match visitCabsDefinition vis d1 with
- [d1'] -> d1'
- | _ -> Kernel.fatal "visitCabs: for can have only one definition"
- in
- if d1' != d1 then FC_DECL d1' else fc1
- in
- let e2' = ve e2 in
- let e3' = ve e3 in
- let s4' = vs l s4 in
- let _ = vis#vExitScope () in
- if fc1' != fc1 || e2' != e2 || e3' != e3 || s4' != s4
- then {s with stmt_node = FOR (a, fc1', e2', e3', s4', l)} else s
+ let _ = vis#vEnterScope () in
+ let fc1' =
+ match fc1 with
+ FC_EXP e1 ->
+ let e1' = ve e1 in
+ if e1' != e1 then FC_EXP e1' else fc1
+ | FC_DECL d1 ->
+ let d1' =
+ match visitCabsDefinition vis d1 with
+ [d1'] -> d1'
+ | _ -> Kernel.fatal "visitCabs: for can have only one definition"
+ in
+ if d1' != d1 then FC_DECL d1' else fc1
+ in
+ let e2' = ve e2 in
+ let e3' = ve e3 in
+ let s4' = vs l s4 in
+ let _ = vis#vExitScope () in
+ if fc1' != fc1 || e2' != e2 || e3' != e3 || s4' != s4
+ then {s with stmt_node = FOR (a, fc1', e2', e3', s4', l)} else s
| BREAK _ | CONTINUE _ | GOTO _ -> s
| RETURN (e, l) ->
- let e' = ve e in
- if e' != e then {s with stmt_node = RETURN (e', l)} else s
+ let e' = ve e in
+ if e' != e then {s with stmt_node = RETURN (e', l)} else s
| SWITCH (e, s1, l) ->
- let e' = ve e in
- let s1' = vs l s1 in
- if e' != e || s1' != s1 then {s with stmt_node = SWITCH (e', s1', l)} else s
+ let e' = ve e in
+ let s1' = vs l s1 in
+ if e' != e || s1' != s1 then {s with stmt_node = SWITCH (e', s1', l)} else s
| CASE (e, s1, l) ->
- let e' = ve e in
- let s1' = vs l s1 in
- if e' != e || s1' != s1 then {s with stmt_node = CASE (e', s1', l)} else s
+ let e' = ve e in
+ let s1' = vs l s1 in
+ if e' != e || s1' != s1 then {s with stmt_node = CASE (e', s1', l)} else s
| CASERANGE (e1, e2, s3, l) ->
- let e1' = ve e1 in
- let e2' = ve e2 in
- let s3' = vs l s3 in
- if e1' != e1 || e2' != e2 || s3' != s3 then
- {s with stmt_node = CASERANGE (e1', e2', s3', l)} else s
+ let e1' = ve e1 in
+ let e2' = ve e2 in
+ let s3' = vs l s3 in
+ if e1' != e1 || e2' != e2 || s3' != s3 then
+ {s with stmt_node = CASERANGE (e1', e2', s3', l)} else s
| DEFAULT (s1, l) ->
- let s1' = vs l s1 in
- if s1' != s1 then {s with stmt_node = DEFAULT (s1', l)} else s
+ let s1' = vs l s1 in
+ if s1' != s1 then {s with stmt_node = DEFAULT (s1', l)} else s
| LABEL (n, s1, l) ->
- let s1' = vs l s1 in
- if s1' != s1 then {s with stmt_node = LABEL (n, s1', l)} else s
+ let s1' = vs l s1 in
+ if s1' != s1 then {s with stmt_node = LABEL (n, s1', l)} else s
| COMPGOTO (e, l) ->
- let e' = ve e in
- if e' != e then {s with stmt_node = COMPGOTO (e', l)} else s
+ let e' = ve e in
+ if e' != e then {s with stmt_node = COMPGOTO (e', l)} else s
| DEFINITION d -> begin
match visitCabsDefinition vis d with
- [d'] when d' == d -> s
- | [d'] -> {s with stmt_node = DEFINITION d' }
- | dl -> let l = get_definitionloc d in
- let dl' = List.map (fun d' -> {s with stmt_node = DEFINITION d'}) dl in
- {s with stmt_node = BLOCK ({blabels = []; battrs = []; bstmts = dl' }, l, l(*LRICEA*))}
+ [d'] when d' == d -> s
+ | [d'] -> {s with stmt_node = DEFINITION d' }
+ | dl -> let l = get_definitionloc d in
+ let dl' = List.map (fun d' -> {s with stmt_node = DEFINITION d'}) dl in
+ {s with stmt_node = BLOCK ({blabels = []; battrs = []; bstmts = dl' }, l, l(*LRICEA*))}
end
| ASM (sl, b, details, l) ->
- let childrenIdentStringExp ((i,s, e) as input) =
- let e' = ve e in
- if e' != e then (i,s, e') else input
- in
- let details' = match details with
+ let childrenIdentStringExp ((i,s, e) as input) =
+ let e' = ve e in
+ if e' != e then (i,s, e') else input
+ in
+ let details' = match details with
| None -> details
| Some { aoutputs = outl; ainputs = inl; aclobbers = clobs; alabels = labels } ->
- let outl' = mapNoCopy childrenIdentStringExp outl in
- let inl' = mapNoCopy childrenIdentStringExp inl in
- if outl' == outl && inl' == inl then
- details
- else
- Some { aoutputs = outl'; ainputs = inl'; aclobbers = clobs ; alabels = labels }
- in
- if details' != details then
- {s with stmt_node = ASM (sl, b, details', l)} else s
+ let outl' = mapNoCopy childrenIdentStringExp outl in
+ let inl' = mapNoCopy childrenIdentStringExp inl in
+ if outl' == outl && inl' == inl then
+ details
+ else
+ Some { aoutputs = outl'; ainputs = inl'; aclobbers = clobs ; alabels = labels }
+ in
+ if details' != details then
+ {s with stmt_node = ASM (sl, b, details', l)} else s
| TRY_FINALLY (b1, b2, l) ->
- let b1' = visitCabsBlock vis b1 in
- let b2' = visitCabsBlock vis b2 in
- if b1' != b1 || b2' != b2 then {s with stmt_node = TRY_FINALLY(b1', b2', l)} else s
+ let b1' = visitCabsBlock vis b1 in
+ let b2' = visitCabsBlock vis b2 in
+ if b1' != b1 || b2' != b2 then {s with stmt_node = TRY_FINALLY(b1', b2', l)} else s
| TRY_EXCEPT (b1, e, b2, l) ->
- let b1' = visitCabsBlock vis b1 in
- let e' = visitCabsExpression vis e in
- let b2' = visitCabsBlock vis b2 in
- if b1' != b1 || e' != e || b2' != b2 then
- {s with stmt_node = TRY_EXCEPT(b1', e', b2', l)} else s
+ let b1' = visitCabsBlock vis b1 in
+ let e' = visitCabsExpression vis e in
+ let b2' = visitCabsBlock vis b2 in
+ if b1' != b1 || e' != e || b2' != b2 then
+ {s with stmt_node = TRY_EXCEPT(b1', e', b2', l)} else s
| THROW (e,l) ->
let e' = optMapNoCopy (visitCabsExpression vis) e in
if e != e' then { s with stmt_node = THROW(e',l) } else s
@@ -414,72 +414,72 @@ and childrenExpression vis e =
match e.expr_node with
NOTHING | LABELADDR _ -> e
| UNARY (uo, e1) ->
- let e1' = ve e1 in
- if e1' != e1 then { e with expr_node = UNARY (uo, e1')} else e
+ let e1' = ve e1 in
+ if e1' != e1 then { e with expr_node = UNARY (uo, e1')} else e
| BINARY (bo, e1, e2) ->
- let e1' = ve e1 in
- let e2' = ve e2 in
- if e1' != e1 || e2' != e2 then
- { e with expr_node = BINARY (bo, e1', e2')} else e
+ let e1' = ve e1 in
+ let e2' = ve e2 in
+ if e1' != e1 || e2' != e2 then
+ { e with expr_node = BINARY (bo, e1', e2')} else e
| QUESTION (e1, e2, e3) ->
- let e1' = ve e1 in
- let e2' = ve e2 in
- let e3' = ve e3 in
- if e1' != e1 || e2' != e2 || e3' != e3 then
- { e with expr_node = QUESTION (e1', e2', e3')} else e
+ let e1' = ve e1 in
+ let e2' = ve e2 in
+ let e3' = ve e3 in
+ if e1' != e1 || e2' != e2 || e3' != e3 then
+ { e with expr_node = QUESTION (e1', e2', e3')} else e
| CAST ((s, dt), ie) ->
- let s' = visitCabsSpecifier vis s in
- let dt' = visitCabsDeclType vis false dt in
- let ie' = visitCabsInitExpression vis ie in
- if s' != s || dt' != dt || ie' != ie then
- { e with expr_node = CAST ((s', dt'), ie')} else e
+ let s' = visitCabsSpecifier vis s in
+ let dt' = visitCabsDeclType vis false dt in
+ let ie' = visitCabsInitExpression vis ie in
+ if s' != s || dt' != dt || ie' != ie then
+ { e with expr_node = CAST ((s', dt'), ie')} else e
| CALL (f, el, gl) ->
- let f' = ve f in
- let el' = mapNoCopy ve el in
- let gl' = mapNoCopy ve gl in
- if f' != f || el' != el then
- { e with expr_node = CALL (f', el',gl')} else e
+ let f' = ve f in
+ let el' = mapNoCopy ve el in
+ let gl' = mapNoCopy ve gl in
+ if f' != f || el' != el then
+ { e with expr_node = CALL (f', el',gl')} else e
| COMMA el ->
- let el' = mapNoCopy ve el in
- if el' != el then { e with expr_node = COMMA (el') } else e
+ let el' = mapNoCopy ve el in
+ if el' != el then { e with expr_node = COMMA (el') } else e
| CONSTANT _ -> e
| PAREN e1 ->
- let e1' = ve e1 in
- if e1' != e1 then { e with expr_node = PAREN (e1') } else e
+ let e1' = ve e1 in
+ if e1' != e1 then { e with expr_node = PAREN (e1') } else e
| VARIABLE s ->
- let s' = vis#vvar s in
- if s' != s then { e with expr_node = VARIABLE s' } else e
+ let s' = vis#vvar s in
+ if s' != s then { e with expr_node = VARIABLE s' } else e
| EXPR_SIZEOF (e1) ->
- let e1' = ve e1 in
- if e1' != e1 then { e with expr_node = EXPR_SIZEOF (e1') } else e
+ let e1' = ve e1 in
+ if e1' != e1 then { e with expr_node = EXPR_SIZEOF (e1') } else e
| TYPE_SIZEOF (s, dt) ->
- let s' = visitCabsSpecifier vis s in
- let dt' = visitCabsDeclType vis false dt in
- if s' != s || dt' != dt then
- { e with expr_node = TYPE_SIZEOF (s' ,dt') } else e
+ let s' = visitCabsSpecifier vis s in
+ let dt' = visitCabsDeclType vis false dt in
+ if s' != s || dt' != dt then
+ { e with expr_node = TYPE_SIZEOF (s' ,dt') } else e
| EXPR_ALIGNOF (e1) ->
- let e1' = ve e1 in
- if e1' != e1 then { e with expr_node = EXPR_ALIGNOF e1'} else e
+ let e1' = ve e1 in
+ if e1' != e1 then { e with expr_node = EXPR_ALIGNOF e1'} else e
| TYPE_ALIGNOF (s, dt) ->
- let s' = visitCabsSpecifier vis s in
- let dt' = visitCabsDeclType vis false dt in
- if s' != s || dt' != dt then
- { e with expr_node = TYPE_ALIGNOF (s' ,dt')}
- else e
+ let s' = visitCabsSpecifier vis s in
+ let dt' = visitCabsDeclType vis false dt in
+ if s' != s || dt' != dt then
+ { e with expr_node = TYPE_ALIGNOF (s' ,dt')}
+ else e
| INDEX (e1, e2) ->
- let e1' = ve e1 in
- let e2' = ve e2 in
- if e1' != e1 || e2' != e2 then { e with expr_node = INDEX (e1', e2') }
- else e
+ let e1' = ve e1 in
+ let e2' = ve e2 in
+ if e1' != e1 || e2' != e2 then { e with expr_node = INDEX (e1', e2') }
+ else e
| MEMBEROF (e1, n) ->
- let e1' = ve e1 in
- if e1' != e1 then { e with expr_node = MEMBEROF (e1', n)} else e
+ let e1' = ve e1 in
+ if e1' != e1 then { e with expr_node = MEMBEROF (e1', n)} else e
| MEMBEROFPTR (e1, n) ->
- let e1' = ve e1 in
- if e1' != e1 then { e with expr_node = MEMBEROFPTR (e1', n) } else e
+ let e1' = ve e1 in
+ if e1' != e1 then { e with expr_node = MEMBEROFPTR (e1', n) } else e
| GNU_BODY b ->
- let b' = visitCabsBlock vis b in
- if b' != b then { e with expr_node = GNU_BODY b' } else e
+ let b' = visitCabsBlock vis b in
+ if b' != b then { e with expr_node = GNU_BODY b' } else e
| EXPR_PATTERN _ -> e
and visitCabsInitExpression vis (ie: init_expression) : init_expression =
@@ -489,30 +489,30 @@ and childrenInitExpression vis ie =
match iw with
NEXT_INIT -> iw
| INFIELD_INIT (n, iw1) ->
- let iw1' = childrenInitWhat iw1 in
- if iw1' != iw1 then INFIELD_INIT (n, iw1') else iw
+ let iw1' = childrenInitWhat iw1 in
+ if iw1' != iw1 then INFIELD_INIT (n, iw1') else iw
| ATINDEX_INIT (e, iw1) ->
- let e' = visitCabsExpression vis e in
- let iw1' = childrenInitWhat iw1 in
- if e' != e || iw1' != iw1 then ATINDEX_INIT (e', iw1') else iw
+ let e' = visitCabsExpression vis e in
+ let iw1' = childrenInitWhat iw1 in
+ if e' != e || iw1' != iw1 then ATINDEX_INIT (e', iw1') else iw
| ATINDEXRANGE_INIT (e1, e2) ->
- let e1' = visitCabsExpression vis e1 in
- let e2' = visitCabsExpression vis e2 in
- if e1' != e1 || e2' != e2 then ATINDEXRANGE_INIT (e1', e2') else iw
+ let e1' = visitCabsExpression vis e1 in
+ let e2' = visitCabsExpression vis e2 in
+ if e1' != e1 || e2' != e2 then ATINDEXRANGE_INIT (e1', e2') else iw
in
match ie with
NO_INIT -> ie
| SINGLE_INIT e ->
- let e' = visitCabsExpression vis e in
- if e' != e then SINGLE_INIT e' else ie
+ let e' = visitCabsExpression vis e in
+ if e' != e then SINGLE_INIT e' else ie
| COMPOUND_INIT il ->
- let childrenOne ((iw, ie) as input) =
- let iw' = childrenInitWhat iw in
- let ie' = visitCabsInitExpression vis ie in
- if iw' != iw || ie' != ie then (iw', ie') else input
- in
- let il' = mapNoCopy childrenOne il in
- if il' != il then COMPOUND_INIT il' else ie
+ let childrenOne ((iw, ie) as input) =
+ let iw' = childrenInitWhat iw in
+ let ie' = visitCabsInitExpression vis ie in
+ if iw' != iw || ie' != ie then (iw', ie') else input
+ in
+ let il' = mapNoCopy childrenOne il in
+ if il' != il then COMPOUND_INIT il' else ie
and visitCabsAttribute vis (a: attribute) : attribute list =
@@ -527,10 +527,10 @@ and visitCabsAttributes vis (al: attribute list) : attribute list =
let visitCabsFile (vis: cabsVisitor) ((fname, f): file) : file =
(fname, mapNoCopyList (fun ((ghost,f) as glob) ->
- let f' = visitCabsDefinition vis f in
- match f' with
- [f'] when f == f' -> [glob]
- | _ -> List.map (fun f -> (ghost, f)) f'
- ) f)
+ let f' = visitCabsDefinition vis f in
+ match f' with
+ [f'] when f == f' -> [glob]
+ | _ -> List.map (fun f -> (ghost, f)) f'
+ ) f)
- (* end of file *)
+(* end of file *)
diff --git a/src/kernel_services/visitors/cabsvisit.mli b/src/kernel_services/visitors/cabsvisit.mli
index 4df5f481a41d9e39145b7f84aae16d7cde627b17..b2816d2ed75eb460bffc5fbb8b369bf4d229d439 100644
--- a/src/kernel_services/visitors/cabsvisit.mli
+++ b/src/kernel_services/visitors/cabsvisit.mli
@@ -48,7 +48,7 @@ open Cil
type nameKind =
NVar (** Variable or function prototype
- name *)
+ name *)
| NFun (** Function definition name *)
| NField (** The name of a field *)
| NType (** The name of a type *)
@@ -67,7 +67,7 @@ class type cabsVisitor = object
method vtypespec: Cabs.typeSpecifier -> Cabs.typeSpecifier visitAction
method vdecltype: Cabs.decl_type -> Cabs.decl_type visitAction
- (* For each declaration we call vname *)
+ (* For each declaration we call vname *)
method vname: nameKind -> Cabs.specifier -> Cabs.name -> Cabs.name visitAction
method vspec: Cabs.specifier -> Cabs.specifier visitAction (* specifier *)
method vattr: Cabs.attribute -> Cabs.attribute list visitAction
@@ -82,7 +82,7 @@ class nopCabsVisitor: cabsVisitor
val visitCabsTypeSpecifier: cabsVisitor ->
- Cabs.typeSpecifier -> Cabs.typeSpecifier
+ Cabs.typeSpecifier -> Cabs.typeSpecifier
val visitCabsSpecifier: cabsVisitor -> Cabs.specifier -> Cabs.specifier
(** Visits a decl_type. The bool argument is saying whether we are in a
@@ -94,9 +94,9 @@ val visitCabsBlock: cabsVisitor -> Cabs.block -> Cabs.block
val visitCabsStatement: cabsVisitor -> Cabs.statement -> Cabs.statement list
val visitCabsExpression: cabsVisitor -> Cabs.expression -> Cabs.expression
val visitCabsAttributes: cabsVisitor -> Cabs.attribute list
- -> Cabs.attribute list
+ -> Cabs.attribute list
val visitCabsName: cabsVisitor -> nameKind
- -> Cabs.specifier -> Cabs.name -> Cabs.name
+ -> Cabs.specifier -> Cabs.name -> Cabs.name
val visitCabsFile: cabsVisitor -> Cabs.file -> Cabs.file
diff --git a/src/libraries/datatype/datatype.ml b/src/libraries/datatype/datatype.ml
index 2ed442511ec751e1cf1ab471985351979b19a40f..442b2cfc97658dcb3230a6101648a85643e34edf 100644
--- a/src/libraries/datatype/datatype.ml
+++ b/src/libraries/datatype/datatype.ml
@@ -25,15 +25,15 @@
(* ********************************************************************** *)
type 'a t =
- { equal: 'a -> 'a -> bool;
- compare: 'a -> 'a -> int;
- hash: 'a -> int;
- copy: 'a -> 'a;
- internal_pretty_code: Type.precedence -> Format.formatter -> 'a -> unit;
- pretty_code: Format.formatter -> 'a -> unit;
- pretty: Format.formatter -> 'a -> unit;
- varname: 'a -> string;
- mem_project: (Project_skeleton.t -> bool) -> 'a -> bool }
+ { equal: 'a -> 'a -> bool;
+ compare: 'a -> 'a -> int;
+ hash: 'a -> int;
+ copy: 'a -> 'a;
+ internal_pretty_code: Type.precedence -> Format.formatter -> 'a -> unit;
+ pretty_code: Format.formatter -> 'a -> unit;
+ pretty: Format.formatter -> 'a -> unit;
+ varname: 'a -> string;
+ mem_project: (Project_skeleton.t -> bool) -> 'a -> bool }
type 'a info = 'a t
@@ -82,7 +82,7 @@ let equal ty = (internal_info "equal" ty).equal
let compare ty = (internal_info "compare" ty).compare
let hash ty = (internal_info "hash" ty).hash
let copy ty = (internal_info "copy" ty).copy
-let internal_pretty_code ty =
+let internal_pretty_code ty =
(internal_info "internal_pretty_code" ty).internal_pretty_code
let pretty_code ty = (internal_info "pretty_code" ty).pretty_code
let pretty ty = (internal_info "pretty" ty).pretty
@@ -151,32 +151,32 @@ let valid_varname s =
let check f fname tname fstr =
assert
(if f == undefined && Type.may_use_obj () then begin
- Format.printf "@[Preliminary datatype check failed.@\n\
-Value `%s' of type %s is required for building %s.@]@."
- fname tname fstr;
- false
- end else
- true)
+ Format.printf "@[Preliminary datatype check failed.@\n\
+ Value `%s' of type %s is required for building %s.@]@."
+ fname tname fstr;
+ false
+ end else
+ true)
module Build
- (T: sig
- type t
- val ty: t Type.t
- val reprs: t list
- val equal: t -> t -> bool
- val compare: t -> t -> int
- val hash: t -> int
- val rehash: t -> t
- val copy: t -> t
- val internal_pretty_code: Type.precedence -> Format.formatter -> t -> unit
- val pretty: Format.formatter -> t -> unit
- val varname: t -> string
- val mem_project: (Project_skeleton.t -> bool) -> t -> bool
- end) =
+ (T: sig
+ type t
+ val ty: t Type.t
+ val reprs: t list
+ val equal: t -> t -> bool
+ val compare: t -> t -> int
+ val hash: t -> int
+ val rehash: t -> t
+ val copy: t -> t
+ val internal_pretty_code: Type.precedence -> Format.formatter -> t -> unit
+ val pretty: Format.formatter -> t -> unit
+ val varname: t -> string
+ val mem_project: (Project_skeleton.t -> bool) -> t -> bool
+ end) =
struct
let name = Type.name T.ty
-(* let () = Format.printf "datatype %S@." name*)
+ (* let () = Format.printf "datatype %S@." name*)
let equal =
if T.equal == from_compare then (fun x y -> T.compare x y = 0)
@@ -233,16 +233,16 @@ struct
assert false
end
else
- if rehash == identity then d
- else
- if Type.may_use_obj () then begin
- if Descr.is_unmarshable d then begin
- check undefined "structural_descr" name "descriptor";
- assert false
- end;
- Descr.transform d rehash
- end else
- Descr.unmarshable
+ if rehash == identity then d
+ else
+ if Type.may_use_obj () then begin
+ if Descr.is_unmarshable d then begin
+ check undefined "structural_descr" name "descriptor";
+ assert false
+ end;
+ Descr.transform d rehash
+ end else
+ Descr.unmarshable
in
descr, Descr.pack descr
@@ -333,7 +333,7 @@ module type Polymorphic = sig
end
(* local argument of below functors: not visible from outside *)
-let poly_name_ref = ref ""
+let poly_name_ref = ref ""
(* ****************************************************************************)
(** {2 Polymorphic2 } *)
@@ -373,18 +373,18 @@ module Polymorphic2(P: Polymorphic2_input) = struct
(* cannot declare [name] locally in instantiate since it prevents OCaml
generalization *)
- let name = !poly_name_ref
+ let name = !poly_name_ref
let instantiate ty1 ty2 =
let res, first = instantiate ty1 ty2 in
if first && name <> "" then begin
- let ml_name =
- Format.asprintf
- "Datatype.%s %a %a"
- name
- (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt)
- ty1
- (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt)
- ty2
+ let ml_name =
+ Format.asprintf
+ "Datatype.%s %a %a"
+ name
+ (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt)
+ ty1
+ (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt)
+ ty2
in
Type.set_ml_name res (Some ml_name)
end;
@@ -401,46 +401,46 @@ module Polymorphic2(P: Polymorphic2_input) = struct
include T
include Build
- (struct
- include T
- let reprs = if Type.may_use_obj () then Type.reprs ty else []
- let build mk f1 f2 =
- if mk == undefined || f1 == undefined || f2 == undefined then
- undefined
- else
- mk f1 f2
- let compare = build P.mk_compare T1.compare T2.compare
- let equal = build P.mk_equal T1.equal T2.equal
- let hash = build P.mk_hash T1.hash T2.hash
- let rehash = identity
- let copy =
- let mk f1 f2 =
- if P.map == undefined then undefined
- else
- (* [JS 2011/05/31] No optimisation for the special case of identity,
- since we really want to perform a DEEP copy. *)
- (*if f1 == identity && f2 == identity then identity
- else*) P.map f1 f2
- in
- build mk T1.copy T2.copy
- let internal_pretty_code =
- let mk f1 f2 =
- if f1 == pp_fail || f2 == pp_fail then pp_fail
- else fun p fmt x -> P.mk_internal_pretty_code f1 f2 p fmt x
- in
- build mk T1.internal_pretty_code T2.internal_pretty_code
- let pretty = build P.mk_pretty T1.pretty T2.pretty
- let varname = build P.mk_varname T1.varname T2.varname
- let mem_project =
- let mk f1 f2 =
- if P.mk_mem_project == undefined then undefined
- else if f1 == never_any_project && f2 == never_any_project then
- never_any_project
+ (struct
+ include T
+ let reprs = if Type.may_use_obj () then Type.reprs ty else []
+ let build mk f1 f2 =
+ if mk == undefined || f1 == undefined || f2 == undefined then
+ undefined
else
- P.mk_mem_project f1 f2
- in
- build mk T1.mem_project T2.mem_project
- end)
+ mk f1 f2
+ let compare = build P.mk_compare T1.compare T2.compare
+ let equal = build P.mk_equal T1.equal T2.equal
+ let hash = build P.mk_hash T1.hash T2.hash
+ let rehash = identity
+ let copy =
+ let mk f1 f2 =
+ if P.map == undefined then undefined
+ else
+ (* [JS 2011/05/31] No optimisation for the special case of identity,
+ since we really want to perform a DEEP copy. *)
+ (*if f1 == identity && f2 == identity then identity
+ else*) P.map f1 f2
+ in
+ build mk T1.copy T2.copy
+ let internal_pretty_code =
+ let mk f1 f2 =
+ if f1 == pp_fail || f2 == pp_fail then pp_fail
+ else fun p fmt x -> P.mk_internal_pretty_code f1 f2 p fmt x
+ in
+ build mk T1.internal_pretty_code T2.internal_pretty_code
+ let pretty = build P.mk_pretty T1.pretty T2.pretty
+ let varname = build P.mk_varname T1.varname T2.varname
+ let mem_project =
+ let mk f1 f2 =
+ if P.mk_mem_project == undefined then undefined
+ else if f1 == never_any_project && f2 == never_any_project then
+ never_any_project
+ else
+ P.mk_mem_project f1 f2
+ in
+ build mk T1.mem_project T2.mem_project
+ end)
let descr, packed_descr =
mk_full_descr
@@ -462,58 +462,58 @@ module type Polymorphic3 = sig
end
module Polymorphic3
- (P: sig
- include Type.Polymorphic3_input
- val mk_equal:
- ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('c -> 'c -> bool) ->
- ('a, 'b, 'c) t -> ('a, 'b, 'c) t ->
- bool
- val mk_compare:
- ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('c -> 'c -> int) ->
- ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> int
- val mk_hash:
- ('a -> int) -> ('b -> int) -> ('c -> int) -> ('a, 'b, 'c) t -> int
- val map:
- ('a -> 'a) -> ('b -> 'b) -> ('c -> 'c) -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t
- val mk_internal_pretty_code:
- (Type.precedence -> Format.formatter -> 'a -> unit) ->
- (Type.precedence -> Format.formatter -> 'b -> unit) ->
- (Type.precedence -> Format.formatter -> 'c -> unit) ->
- Type.precedence -> Format.formatter -> ('a, 'b, 'c) t -> unit
- val mk_pretty:
- (Format.formatter -> 'a -> unit) ->
- (Format.formatter -> 'b -> unit) ->
- (Format.formatter -> 'c -> unit) ->
- Format.formatter -> ('a, 'b, 'c) t -> unit
- val mk_varname:
- ('a -> string) -> ('b -> string) -> ('c -> string) ->
- ('a, 'b, 'c) t -> string
- val mk_mem_project:
- ((Project_skeleton.t -> bool) -> 'a -> bool) ->
- ((Project_skeleton.t -> bool) -> 'b -> bool) ->
- ((Project_skeleton.t -> bool) -> 'c -> bool) ->
- (Project_skeleton.t -> bool) -> ('a, 'b, 'c) t -> bool
- end) =
+ (P: sig
+ include Type.Polymorphic3_input
+ val mk_equal:
+ ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('c -> 'c -> bool) ->
+ ('a, 'b, 'c) t -> ('a, 'b, 'c) t ->
+ bool
+ val mk_compare:
+ ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('c -> 'c -> int) ->
+ ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> int
+ val mk_hash:
+ ('a -> int) -> ('b -> int) -> ('c -> int) -> ('a, 'b, 'c) t -> int
+ val map:
+ ('a -> 'a) -> ('b -> 'b) -> ('c -> 'c) -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t
+ val mk_internal_pretty_code:
+ (Type.precedence -> Format.formatter -> 'a -> unit) ->
+ (Type.precedence -> Format.formatter -> 'b -> unit) ->
+ (Type.precedence -> Format.formatter -> 'c -> unit) ->
+ Type.precedence -> Format.formatter -> ('a, 'b, 'c) t -> unit
+ val mk_pretty:
+ (Format.formatter -> 'a -> unit) ->
+ (Format.formatter -> 'b -> unit) ->
+ (Format.formatter -> 'c -> unit) ->
+ Format.formatter -> ('a, 'b, 'c) t -> unit
+ val mk_varname:
+ ('a -> string) -> ('b -> string) -> ('c -> string) ->
+ ('a, 'b, 'c) t -> string
+ val mk_mem_project:
+ ((Project_skeleton.t -> bool) -> 'a -> bool) ->
+ ((Project_skeleton.t -> bool) -> 'b -> bool) ->
+ ((Project_skeleton.t -> bool) -> 'c -> bool) ->
+ (Project_skeleton.t -> bool) -> ('a, 'b, 'c) t -> bool
+ end) =
struct
include Type.Polymorphic3(P)
(* cannot declare [name] locally in instantiate since it prevents OCaml
generalization *)
- let name = !poly_name_ref
+ let name = !poly_name_ref
let instantiate ty1 ty2 ty3 =
let res, first = instantiate ty1 ty2 ty3 in
if first && name <> "" then begin
- let ml_name =
- Format.asprintf
- "Datatype.%s %a %a %a"
- name
- (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt)
- ty1
- (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt)
- ty2
- (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt)
- ty3
+ let ml_name =
+ Format.asprintf
+ "Datatype.%s %a %a %a"
+ name
+ (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt)
+ ty1
+ (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt)
+ ty2
+ (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt)
+ ty3
in
Type.set_ml_name res (Some ml_name)
end;
@@ -530,62 +530,62 @@ struct
include T
include Build
- (struct
- include T
- let reprs = if Type.may_use_obj () then Type.reprs ty else []
- let build mk f1 f2 f3 =
- if mk == undefined || f1 == undefined || f2 == undefined ||
- f3 == undefined
- then
- undefined
- else
- mk f1 f2 f3
- let compare = build P.mk_compare T1.compare T2.compare T3.compare
- let equal = build P.mk_equal T1.equal T2.equal T3.equal
- let hash = build P.mk_hash T1.hash T2.hash T3.hash
- let rehash = identity
- let copy =
- let mk f1 f2 f3 =
- if P.map == undefined then undefined
+ (struct
+ include T
+ let reprs = if Type.may_use_obj () then Type.reprs ty else []
+ let build mk f1 f2 f3 =
+ if mk == undefined || f1 == undefined || f2 == undefined ||
+ f3 == undefined
+ then
+ undefined
else
- (* [JS 2011/05/31] No optimisation for the special case of identity,
- since we really want to perform a DEEP copy. *)
- (*if f1 == identity && f2 == identity then identity
- else*) P.map f1 f2 f3
- in
- build mk T1.copy T2.copy T3.copy
- let internal_pretty_code =
- let mk f1 f2 f3 =
- if f1 == pp_fail || f2 == pp_fail || f3 == pp_fail then pp_fail
- else fun p fmt x -> P.mk_internal_pretty_code f1 f2 f3 p fmt x
- in
- build mk
- T1.internal_pretty_code
- T2.internal_pretty_code
- T3.internal_pretty_code
- let pretty = build P.mk_pretty T1.pretty T2.pretty T3.pretty
- let varname = build P.mk_varname T1.varname T2.varname T3.varname
- let mem_project =
- let mk f1 f2 f3 =
- if P.mk_mem_project == undefined then undefined
- else if f1 == never_any_project && f2 == never_any_project
- && f3 == never_any_project
- then
- never_any_project
- else
- P.mk_mem_project f1 f2 f3
- in
- build mk T1.mem_project T2.mem_project T3.mem_project
- end)
+ mk f1 f2 f3
+ let compare = build P.mk_compare T1.compare T2.compare T3.compare
+ let equal = build P.mk_equal T1.equal T2.equal T3.equal
+ let hash = build P.mk_hash T1.hash T2.hash T3.hash
+ let rehash = identity
+ let copy =
+ let mk f1 f2 f3 =
+ if P.map == undefined then undefined
+ else
+ (* [JS 2011/05/31] No optimisation for the special case of identity,
+ since we really want to perform a DEEP copy. *)
+ (*if f1 == identity && f2 == identity then identity
+ else*) P.map f1 f2 f3
+ in
+ build mk T1.copy T2.copy T3.copy
+ let internal_pretty_code =
+ let mk f1 f2 f3 =
+ if f1 == pp_fail || f2 == pp_fail || f3 == pp_fail then pp_fail
+ else fun p fmt x -> P.mk_internal_pretty_code f1 f2 f3 p fmt x
+ in
+ build mk
+ T1.internal_pretty_code
+ T2.internal_pretty_code
+ T3.internal_pretty_code
+ let pretty = build P.mk_pretty T1.pretty T2.pretty T3.pretty
+ let varname = build P.mk_varname T1.varname T2.varname T3.varname
+ let mem_project =
+ let mk f1 f2 f3 =
+ if P.mk_mem_project == undefined then undefined
+ else if f1 == never_any_project && f2 == never_any_project
+ && f3 == never_any_project
+ then
+ never_any_project
+ else
+ P.mk_mem_project f1 f2 f3
+ in
+ build mk T1.mem_project T2.mem_project T3.mem_project
+ end)
let descr, packed_descr =
mk_full_descr
(Descr.of_structural
ty
(P.structural_descr
- (Descr.str T1.descr)
- (Descr.str T2.descr)
- (Descr.str T3.descr)))
+ (Descr.str T1.descr)
+ (Descr.str T2.descr)
+ (Descr.str T3.descr)))
end
@@ -597,72 +597,72 @@ end
module type Polymorphic4 = sig
include Type.Polymorphic4
- module Make(T1:S)(T2:S)(T3:S)(T4:S)
+ module Make(T1:S)(T2:S)(T3:S)(T4:S)
: S with type t = (T1.t, T2.t, T3.t, T4.t) poly
end
module Polymorphic4
- (P: sig
- include Type.Polymorphic4_input
- val mk_equal:
- ('a -> 'a -> bool) -> ('b -> 'b -> bool) ->
- ('c -> 'c -> bool) -> ('d -> 'd -> bool) ->
- ('a, 'b, 'c, 'd) t -> ('a, 'b, 'c, 'd) t ->
- bool
- val mk_compare:
- ('a -> 'a -> int) -> ('b -> 'b -> int) ->
- ('c -> 'c -> int) -> ('d -> 'd -> int) ->
- ('a, 'b, 'c, 'd) t -> ('a, 'b, 'c, 'd) t -> int
- val mk_hash:
- ('a -> int) -> ('b -> int) -> ('c -> int) -> ('d -> int) ->
- ('a, 'b, 'c, 'd) t -> int
- val map:
- ('a -> 'a) -> ('b -> 'b) -> ('c -> 'c) -> ('d -> 'd) ->
- ('a, 'b, 'c, 'd) t -> ('a, 'b, 'c, 'd) t
- val mk_internal_pretty_code:
- (Type.precedence -> Format.formatter -> 'a -> unit) ->
- (Type.precedence -> Format.formatter -> 'b -> unit) ->
- (Type.precedence -> Format.formatter -> 'c -> unit) ->
- (Type.precedence -> Format.formatter -> 'd -> unit) ->
- Type.precedence -> Format.formatter -> ('a, 'b, 'c, 'd) t -> unit
- val mk_pretty:
- (Format.formatter -> 'a -> unit) ->
- (Format.formatter -> 'b -> unit) ->
- (Format.formatter -> 'c -> unit) ->
- (Format.formatter -> 'd -> unit) ->
- Format.formatter -> ('a, 'b, 'c, 'd) t -> unit
- val mk_varname:
- ('a -> string) -> ('b -> string) -> ('c -> string) -> ('d -> string) ->
- ('a, 'b, 'c, 'd) t -> string
- val mk_mem_project:
- ((Project_skeleton.t -> bool) -> 'a -> bool) ->
- ((Project_skeleton.t -> bool) -> 'b -> bool) ->
- ((Project_skeleton.t -> bool) -> 'c -> bool) ->
- ((Project_skeleton.t -> bool) -> 'd -> bool) ->
- (Project_skeleton.t -> bool) -> ('a, 'b, 'c, 'd) t -> bool
- end) =
+ (P: sig
+ include Type.Polymorphic4_input
+ val mk_equal:
+ ('a -> 'a -> bool) -> ('b -> 'b -> bool) ->
+ ('c -> 'c -> bool) -> ('d -> 'd -> bool) ->
+ ('a, 'b, 'c, 'd) t -> ('a, 'b, 'c, 'd) t ->
+ bool
+ val mk_compare:
+ ('a -> 'a -> int) -> ('b -> 'b -> int) ->
+ ('c -> 'c -> int) -> ('d -> 'd -> int) ->
+ ('a, 'b, 'c, 'd) t -> ('a, 'b, 'c, 'd) t -> int
+ val mk_hash:
+ ('a -> int) -> ('b -> int) -> ('c -> int) -> ('d -> int) ->
+ ('a, 'b, 'c, 'd) t -> int
+ val map:
+ ('a -> 'a) -> ('b -> 'b) -> ('c -> 'c) -> ('d -> 'd) ->
+ ('a, 'b, 'c, 'd) t -> ('a, 'b, 'c, 'd) t
+ val mk_internal_pretty_code:
+ (Type.precedence -> Format.formatter -> 'a -> unit) ->
+ (Type.precedence -> Format.formatter -> 'b -> unit) ->
+ (Type.precedence -> Format.formatter -> 'c -> unit) ->
+ (Type.precedence -> Format.formatter -> 'd -> unit) ->
+ Type.precedence -> Format.formatter -> ('a, 'b, 'c, 'd) t -> unit
+ val mk_pretty:
+ (Format.formatter -> 'a -> unit) ->
+ (Format.formatter -> 'b -> unit) ->
+ (Format.formatter -> 'c -> unit) ->
+ (Format.formatter -> 'd -> unit) ->
+ Format.formatter -> ('a, 'b, 'c, 'd) t -> unit
+ val mk_varname:
+ ('a -> string) -> ('b -> string) -> ('c -> string) -> ('d -> string) ->
+ ('a, 'b, 'c, 'd) t -> string
+ val mk_mem_project:
+ ((Project_skeleton.t -> bool) -> 'a -> bool) ->
+ ((Project_skeleton.t -> bool) -> 'b -> bool) ->
+ ((Project_skeleton.t -> bool) -> 'c -> bool) ->
+ ((Project_skeleton.t -> bool) -> 'd -> bool) ->
+ (Project_skeleton.t -> bool) -> ('a, 'b, 'c, 'd) t -> bool
+ end) =
struct
include Type.Polymorphic4(P)
(* cannot declare [name] locally in instantiate since it prevents OCaml
generalization *)
- let name = !poly_name_ref
+ let name = !poly_name_ref
let instantiate ty1 ty2 ty3 ty4 =
let res, first = instantiate ty1 ty2 ty3 ty4 in
if first && name <> "" then begin
- let ml_name =
- Format.asprintf
- "Datatype.%s %a %a %a %a"
- name
- (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt)
- ty1
- (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt)
- ty2
- (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt)
- ty3
- (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt)
- ty4
+ let ml_name =
+ Format.asprintf
+ "Datatype.%s %a %a %a %a"
+ name
+ (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt)
+ ty1
+ (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt)
+ ty2
+ (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt)
+ ty3
+ (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt)
+ ty4
in
Type.set_ml_name res (Some ml_name)
end;
@@ -679,67 +679,67 @@ struct
include T
include Build
- (struct
- include T
- let reprs = if Type.may_use_obj () then Type.reprs ty else []
- let build mk f1 f2 f3 f4 =
- if mk == undefined || f1 == undefined || f2 == undefined ||
- f3 == undefined || f4 == undefined
- then
- undefined
- else
- mk f1 f2 f3 f4
- let compare =
- build P.mk_compare T1.compare T2.compare T3.compare T4.compare
- let equal = build P.mk_equal T1.equal T2.equal T3.equal T4.equal
- let hash = build P.mk_hash T1.hash T2.hash T3.hash T4.hash
- let rehash = identity
- let copy =
- let mk f1 f2 f3 f4 =
- if P.map == undefined then undefined
- else
- (* [JS 2011/05/31] No optimisation for the special case of identity,
- since we really want to perform a DEEP copy. *)
- (*if f1 == identity && f2 == identity then identity
- else*) P.map f1 f2 f3 f4
- in
- build mk T1.copy T2.copy T3.copy T4.copy
- let internal_pretty_code =
- let mk f1 f2 f3 f4 =
- if f1 == pp_fail || f2 == pp_fail || f3 == pp_fail || f4 == pp_fail
- then pp_fail
- else fun p fmt x -> P.mk_internal_pretty_code f1 f2 f3 f4 p fmt x
- in
- build mk
- T1.internal_pretty_code
- T2.internal_pretty_code
- T3.internal_pretty_code
- T4.internal_pretty_code
- let pretty = build P.mk_pretty T1.pretty T2.pretty T3.pretty T4.pretty
- let varname =
- build P.mk_varname T1.varname T2.varname T3.varname T4.varname
- let mem_project =
- let mk f1 f2 f3 f4 =
- if P.mk_mem_project == undefined then undefined
- else if f1 == never_any_project && f2 == never_any_project
- && f3 == never_any_project && f4 == never_any_project
- then
- never_any_project
+ (struct
+ include T
+ let reprs = if Type.may_use_obj () then Type.reprs ty else []
+ let build mk f1 f2 f3 f4 =
+ if mk == undefined || f1 == undefined || f2 == undefined ||
+ f3 == undefined || f4 == undefined
+ then
+ undefined
else
- P.mk_mem_project f1 f2 f3 f4
- in
- build mk T1.mem_project T2.mem_project T3.mem_project T4.mem_project
- end)
+ mk f1 f2 f3 f4
+ let compare =
+ build P.mk_compare T1.compare T2.compare T3.compare T4.compare
+ let equal = build P.mk_equal T1.equal T2.equal T3.equal T4.equal
+ let hash = build P.mk_hash T1.hash T2.hash T3.hash T4.hash
+ let rehash = identity
+ let copy =
+ let mk f1 f2 f3 f4 =
+ if P.map == undefined then undefined
+ else
+ (* [JS 2011/05/31] No optimisation for the special case of identity,
+ since we really want to perform a DEEP copy. *)
+ (*if f1 == identity && f2 == identity then identity
+ else*) P.map f1 f2 f3 f4
+ in
+ build mk T1.copy T2.copy T3.copy T4.copy
+ let internal_pretty_code =
+ let mk f1 f2 f3 f4 =
+ if f1 == pp_fail || f2 == pp_fail || f3 == pp_fail || f4 == pp_fail
+ then pp_fail
+ else fun p fmt x -> P.mk_internal_pretty_code f1 f2 f3 f4 p fmt x
+ in
+ build mk
+ T1.internal_pretty_code
+ T2.internal_pretty_code
+ T3.internal_pretty_code
+ T4.internal_pretty_code
+ let pretty = build P.mk_pretty T1.pretty T2.pretty T3.pretty T4.pretty
+ let varname =
+ build P.mk_varname T1.varname T2.varname T3.varname T4.varname
+ let mem_project =
+ let mk f1 f2 f3 f4 =
+ if P.mk_mem_project == undefined then undefined
+ else if f1 == never_any_project && f2 == never_any_project
+ && f3 == never_any_project && f4 == never_any_project
+ then
+ never_any_project
+ else
+ P.mk_mem_project f1 f2 f3 f4
+ in
+ build mk T1.mem_project T2.mem_project T3.mem_project T4.mem_project
+ end)
let descr, packed_descr =
mk_full_descr
(Descr.of_structural
ty
(P.structural_descr
- (Descr.str T1.descr)
- (Descr.str T2.descr)
- (Descr.str T3.descr)
- (Descr.str T4.descr)))
+ (Descr.str T1.descr)
+ (Descr.str T2.descr)
+ (Descr.str T3.descr)
+ (Descr.str T4.descr)))
end
@@ -787,7 +787,7 @@ struct
let arg ty =
Type.par_ty_name
(fun ty ->
- Type.Function.is_instance_of ty || Poly_pair.is_instance_of ty)
+ Type.Function.is_instance_of ty || Poly_pair.is_instance_of ty)
ty
in
arg ty1 ^ " * " ^ arg ty2
@@ -797,11 +797,11 @@ and Poly_pair : sig
include Type.Polymorphic2 with type ('a,'b) poly = 'a * 'b
module Make(T1: S)(T2: S) : S with type t = (T1.t, T2.t) poly
end =
- struct
+struct
(* Split the functor argument in 2 modules such that OCaml is able to safely
evaluate the recursive modules *)
- include Polymorphic2(struct include Pair_arg include Pair_name end)
- end
+ include Polymorphic2(struct include Pair_arg include Pair_name end)
+end
[@@@ warning "+60"]
@@ -809,26 +809,26 @@ module Pair = Poly_pair.Make
let pair (type typ1) (type typ2) (ty1: typ1 Type.t) (ty2: typ2 Type.t) =
let module Make(X: sig type t val ty: t Type.t end) = struct
- type t = X.t
- let ty = X.ty
- let name = Type.name X.ty
- let descr = Descr.of_type X.ty
- let packed_descr = Descr.pack descr
- let reprs = Type.reprs X.ty
- let equal = equal X.ty
- let compare = compare X.ty
- let hash = hash X.ty
- let copy = copy X.ty
- let internal_pretty_code = internal_pretty_code X.ty
- let pretty_code = pretty_code X.ty
- let pretty = from_pretty_code
- let varname = varname ty
- let mem_project = mem_project X.ty
+ type t = X.t
+ let ty = X.ty
+ let name = Type.name X.ty
+ let descr = Descr.of_type X.ty
+ let packed_descr = Descr.pack descr
+ let reprs = Type.reprs X.ty
+ let equal = equal X.ty
+ let compare = compare X.ty
+ let hash = hash X.ty
+ let copy = copy X.ty
+ let internal_pretty_code = internal_pretty_code X.ty
+ let pretty_code = pretty_code X.ty
+ let pretty = from_pretty_code
+ let varname = varname ty
+ let mem_project = mem_project X.ty
end
in
let module L = Pair
- (Make(struct type t = typ1 let ty = ty1 end))
- (Make(struct type t = typ2 let ty = ty2 end))
+ (Make(struct type t = typ1 let ty = ty1 end))
+ (Make(struct type t = typ2 let ty = ty2 end))
in
L.ty
@@ -837,8 +837,8 @@ let pair (type typ1) (type typ2) (ty1: typ1 Type.t) (ty2: typ2 Type.t) =
(* ****************************************************************************)
module Function
- (T1: sig include Ty val label: (string * (unit -> t) option) option end)
- (T2: Ty) =
+ (T1: sig include Ty val label: (string * (unit -> t) option) option end)
+ (T2: Ty) =
struct
module T = struct
type t = T1.t -> T2.t
@@ -852,7 +852,7 @@ struct
let pretty = undefined
let varname _ = "f"
let mem_project = never_any_project
- let reprs =
+ let reprs =
if Type.may_use_obj () then Type.reprs ty else [ fun _ -> assert false ]
end
include T
@@ -861,8 +861,8 @@ end
let func (type typ1) (type typ2) ?label (ty1: typ1 Type.t) (ty2: typ2 Type.t) =
let module L = Function
- (struct type t = typ1 let ty = ty1 let label = label end)
- (struct type t = typ2 let ty = ty2 end)
+ (struct type t = typ1 let ty = ty1 let label = label end)
+ (struct type t = typ2 let ty = ty2 end)
in
L.ty
@@ -907,16 +907,16 @@ module Polymorphic_gen(P: Polymorphic_input) = struct
(* cannot declare [name] locally in instantiate since it prevents OCaml
generalization *)
- let name = !poly_name_ref
+ let name = !poly_name_ref
let instantiate ty =
let res, first = instantiate ty in
if first && name <> "" then begin
- let ml_name =
- Format.asprintf
- "Datatype.%s %a"
- name
- (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt)
- ty
+ let ml_name =
+ Format.asprintf
+ "Datatype.%s %a"
+ name
+ (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt)
+ ty
in
Type.set_ml_name res (Some ml_name)
end;
@@ -934,48 +934,48 @@ module Polymorphic_gen(P: Polymorphic_input) = struct
include T
include
Build
- (struct
- include T
- let build mk f =
- if mk == undefined || f == undefined then undefined else mk f
- let compare = build P.mk_compare X.compare
- let equal =
- if P.mk_equal == from_compare then
- if compare == undefined then undefined else from_compare
- else build P.mk_equal X.equal
- let hash = build P.mk_hash X.hash
- let copy =
- (* issue #36: do not use [build] here in order to be able to
- copy an empty datastructure even if the underlying function is
- undefined. The potential issue would be to not have the invariant
- that [copy] is [undefined] as soon as the underlying [copy] is;
- but the kernel does not rely on this behavior for that particular
- function (and hopefully it will not change in the future). *)
- if P.map == undefined then undefined
- else
- (* [JS 2011/05/31] No optimisation for the special case of
- identity, since we really want to perform a DEEP copy. *)
- (*if f == identity then identity else*)
- fun x -> P.map X.copy x
- let rehash = R.rehash
-
- let internal_pretty_code =
- let mk f =
- if f == pp_fail then pp_fail
- else fun p fmt x -> P.mk_internal_pretty_code f p fmt x
- in
- build mk X.internal_pretty_code
- let pretty = build P.mk_pretty X.pretty
- let varname = build P.mk_varname X.varname
- let mem_project =
- let mk f =
- if P.mk_mem_project == undefined then undefined
- else if f == never_any_project then never_any_project
- else fun p x -> P.mk_mem_project f p x
- in
- build mk X.mem_project
- let reprs = if Type.may_use_obj () then Type.reprs ty else []
- end)
+ (struct
+ include T
+ let build mk f =
+ if mk == undefined || f == undefined then undefined else mk f
+ let compare = build P.mk_compare X.compare
+ let equal =
+ if P.mk_equal == from_compare then
+ if compare == undefined then undefined else from_compare
+ else build P.mk_equal X.equal
+ let hash = build P.mk_hash X.hash
+ let copy =
+ (* issue #36: do not use [build] here in order to be able to
+ copy an empty datastructure even if the underlying function is
+ undefined. The potential issue would be to not have the invariant
+ that [copy] is [undefined] as soon as the underlying [copy] is;
+ but the kernel does not rely on this behavior for that particular
+ function (and hopefully it will not change in the future). *)
+ if P.map == undefined then undefined
+ else
+ (* [JS 2011/05/31] No optimisation for the special case of
+ identity, since we really want to perform a DEEP copy. *)
+ (*if f == identity then identity else*)
+ fun x -> P.map X.copy x
+ let rehash = R.rehash
+
+ let internal_pretty_code =
+ let mk f =
+ if f == pp_fail then pp_fail
+ else fun p fmt x -> P.mk_internal_pretty_code f p fmt x
+ in
+ build mk X.internal_pretty_code
+ let pretty = build P.mk_pretty X.pretty
+ let varname = build P.mk_varname X.varname
+ let mem_project =
+ let mk f =
+ if P.mk_mem_project == undefined then undefined
+ else if f == never_any_project then never_any_project
+ else fun p x -> P.mk_mem_project f p x
+ in
+ build mk X.mem_project
+ let reprs = if Type.may_use_obj () then Type.reprs ty else []
+ end)
let descr, packed_descr =
mk_full_descr
@@ -987,14 +987,14 @@ end
module Polymorphic(P: Polymorphic_input) = struct
include Polymorphic_gen(P)
- module Make(X: S) =
+ module Make(X: S) =
Make_gen
(X)
- (struct
- let rehash =
- if Descr.is_unmarshable X.descr then undefined
- else identity
- end)
+ (struct
+ let rehash =
+ if Descr.is_unmarshable X.descr then undefined
+ else identity
+ end)
end
(* ****************************************************************************)
@@ -1021,7 +1021,7 @@ module Poly_ref =
mk_internal_pretty_code (fun _ -> f) Type.Basic fmt x
let mk_varname = undefined
let mk_mem_project mem f x = mem f !x
- end)
+ end)
module Ref = Poly_ref.Make
@@ -1067,10 +1067,10 @@ module Poly_option =
let mk_compare f x y =
if x == y then 0
else match x, y with
- | None, None -> 0
- | None, Some _ -> 1
- | Some _, None -> -1
- | Some x, Some y -> f x y
+ | None, None -> 0
+ | None, Some _ -> 1
+ | Some _, None -> -1
+ | Some x, Some y -> f x y
let mk_hash f = function None -> 0 | Some x -> f x
let map f = function None -> None | Some x -> Some (f x)
let mk_internal_pretty_code f p fmt = function
@@ -1084,7 +1084,7 @@ module Poly_option =
mk_internal_pretty_code (fun _ -> f) Type.Basic fmt x
let mk_varname = undefined
let mk_mem_project mem f = function None -> false | Some x -> mem f x
- end)
+ end)
module Option = Poly_option.Make
@@ -1129,20 +1129,20 @@ module Poly_list =
let rec mk_compare f l1 l2 =
if l1 == l2 then 0
else match l1, l2 with
- | [], [] -> assert false
- | [], _ :: _ -> -1
- | _ :: _, [] -> 1
- | x1 :: q1, x2 :: q2 ->
- let n = f x1 x2 in
- if n = 0 then mk_compare f q1 q2 else n
+ | [], [] -> assert false
+ | [], _ :: _ -> -1
+ | _ :: _, [] -> 1
+ | x1 :: q1, x2 :: q2 ->
+ let n = f x1 x2 in
+ if n = 0 then mk_compare f q1 q2 else n
exception Too_long of int
(* Do not spend too much time hashing long lists... *)
let mk_hash f l =
try
- snd (List.fold_left
+ snd (List.fold_left
(fun (length,acc) d ->
- if length > 15 then raise (Too_long acc);
- length+1, 257 * acc + f d)
+ if length > 15 then raise (Too_long acc);
+ length+1, 257 * acc + f d)
(0,1) l)
with Too_long n -> n
let map = List.map
@@ -1150,19 +1150,19 @@ module Poly_list =
let pp fmt =
Format.fprintf fmt "@[<hv 2>[ %t ]@]"
(fun fmt ->
- let rec print fmt = function
- | [] -> ()
- | [ x ] -> Format.fprintf fmt "%a" (f Type.List) x
- | x :: l -> Format.fprintf fmt "%a;@;%a" (f Type.List) x print l
- in
- print fmt l)
+ let rec print fmt = function
+ | [] -> ()
+ | [ x ] -> Format.fprintf fmt "%a" (f Type.List) x
+ | x :: l -> Format.fprintf fmt "%a;@;%a" (f Type.List) x print l
+ in
+ print fmt l)
in
Type.par p Type.Basic fmt pp (* Never enclose lists in parentheses *)
let mk_pretty f fmt x =
mk_internal_pretty_code (fun _ -> f) Type.Basic fmt x
let mk_varname = undefined
let mk_mem_project mem f = List.exists (mem f)
- end)
+ end)
module Caml_list = List
module List = Poly_list.Make
@@ -1204,60 +1204,60 @@ module Poly_array =
let structural_descr = Structural_descr.t_array
exception Early_exit of int
let mk_equal f a1 a2 =
- let size = Array.length a1 in
- if Array.length a2 != size then false
- else try
- for i = 0 to size - 1 do
- if not (f a1.(i) a2.(i)) then raise (Early_exit 0)
- done;
- true
- with Early_exit _ -> false
+ let size = Array.length a1 in
+ if Array.length a2 != size then false
+ else try
+ for i = 0 to size - 1 do
+ if not (f a1.(i) a2.(i)) then raise (Early_exit 0)
+ done;
+ true
+ with Early_exit _ -> false
;;
let mk_compare f a1 a2 =
if a1 == a2 then 0
- else let size1 = Array.length a1 and size2 = Array.length a2 in
- if size1 < size2 then -1
- else if size2 > size1 then 1
- else try
- for i = 0 to size1 do
- let n = f a1.(i) a2.(i) in
- if n != 0 then raise (Early_exit n)
- done;
- 0
- with Early_exit n -> n
+ else let size1 = Array.length a1 and size2 = Array.length a2 in
+ if size1 < size2 then -1
+ else if size2 > size1 then 1
+ else try
+ for i = 0 to size1 do
+ let n = f a1.(i) a2.(i) in
+ if n != 0 then raise (Early_exit n)
+ done;
+ 0
+ with Early_exit n -> n
;;
(* Do not spend too much time hashing long arrays... *)
let mk_hash f a =
- let max = max 15 ((Array.length a) - 1) in
- let acc = ref 1 in
- for i = 0 to max do acc := 257 * !acc + f a.(i) done;
- !acc
+ let max = max 15 ((Array.length a) - 1) in
+ let acc = ref 1 in
+ for i = 0 to max do acc := 257 * !acc + f a.(i) done;
+ !acc
;;
let map = Array.map
let mk_internal_pretty_code f p fmt a =
let pp fmt =
Format.fprintf fmt "@[<hv 2>[| %t |]@]"
(fun fmt ->
- let length = Array.length a in
- match length with
- | 0 -> ()
- | _ -> (Format.fprintf fmt "%a" (f Type.List) a.(0);
- for i = 1 to (length - 1) do
- Format.fprintf fmt ";@;%a" (f Type.List) a.(i)
- done))
+ let length = Array.length a in
+ match length with
+ | 0 -> ()
+ | _ -> (Format.fprintf fmt "%a" (f Type.List) a.(0);
+ for i = 1 to (length - 1) do
+ Format.fprintf fmt ";@;%a" (f Type.List) a.(i)
+ done))
in
Type.par p Type.Basic fmt pp (* Never enclose arrays in parentheses *)
let mk_pretty f fmt x =
mk_internal_pretty_code (fun _ -> f) Type.Basic fmt x
let mk_varname = undefined
let mk_mem_project mem f a =
- try
- for i = 0 to (Array.length a - 1) do
- if mem f a.(i) then raise (Early_exit 0)
- done;
- false
- with Early_exit _ -> true
- end)
+ try
+ for i = 0 to (Array.length a - 1) do
+ if mem f a.(i) then raise (Early_exit 0)
+ done;
+ false
+ with Early_exit _ -> true
+ end)
module Array = Poly_array.Make
@@ -1310,7 +1310,7 @@ module Poly_queue =
let mk_mem_project mem f q =
try Queue.iter (fun x -> if mem f x then raise Exit) q; false
with Exit -> true
- end)
+ end)
module Queue = Poly_queue.Make
@@ -1344,71 +1344,71 @@ module type Functor_info = sig val module_name: string end
(* OCaml functors are generative *)
module Set
- (S: Set.S)(E: S with type t = S.elt)(Info: Functor_info) =
+ (S: Set.S)(E: S with type t = S.elt)(Info: Functor_info) =
struct
let () = check E.equal "equal" E.name Info.module_name
let () = check E.compare "compare" E.name Info.module_name
module P = Make
- (struct
- type t = S.t
- let name = Info.module_name ^ "(" ^ E.name ^ ")"
- let structural_descr =
- Structural_descr.t_set_unchanged_compares (Descr.str E.descr)
- open S
- let reprs = empty :: Caml_list.map (fun r -> singleton r) E.reprs
- let compare = S.compare
- let equal = S.equal
- let hash =
- if E.hash == undefined then undefined
- else (fun s -> S.fold (fun e h -> 67 * E.hash e + h) s 189)
- let rehash =
- if Descr.is_unmarshable E.descr then undefined
- else if Descr.is_abstract E.descr then identity
- else
- fun s -> (* The key changed, rebalance the tree *)
- S.fold S.add s S.empty
- let copy =
- (* [JS 2011/05/31] No optimisation for the special case of
- identity, since we really want to perform a DEEP copy. *)
-(* if E.copy == identity then identity
- else*) fun s -> S.fold (fun x -> S.add (E.copy x)) s S.empty
-
- let internal_pretty_code p_caller fmt s =
- if is_empty s then
- Format.fprintf fmt "%s.empty" Info.module_name
- else
- let pp fmt =
- if S.cardinal s = 1 then
- Format.fprintf fmt "@[<hv 2>%s.singleton@;%a@]"
- Info.module_name
- (E.internal_pretty_code Type.Call)
- (Caml_list.hd (S.elements s))
- else
- Format.fprintf fmt
- "@[<hv 2>List.fold_left@;\
-(fun acc s -> %s.add s acc)@;%s.empty@;%a@]"
- Info.module_name
- Info.module_name
- (let module L = List(E) in L.internal_pretty_code Type.Call)
- (S.elements s)
+ (struct
+ type t = S.t
+ let name = Info.module_name ^ "(" ^ E.name ^ ")"
+ let structural_descr =
+ Structural_descr.t_set_unchanged_compares (Descr.str E.descr)
+ open S
+ let reprs = empty :: Caml_list.map (fun r -> singleton r) E.reprs
+ let compare = S.compare
+ let equal = S.equal
+ let hash =
+ if E.hash == undefined then undefined
+ else (fun s -> S.fold (fun e h -> 67 * E.hash e + h) s 189)
+ let rehash =
+ if Descr.is_unmarshable E.descr then undefined
+ else if Descr.is_abstract E.descr then identity
+ else
+ fun s -> (* The key changed, rebalance the tree *)
+ S.fold S.add s S.empty
+ let copy =
+ (* [JS 2011/05/31] No optimisation for the special case of
+ identity, since we really want to perform a DEEP copy. *)
+ (* if E.copy == identity then identity
+ else*) fun s -> S.fold (fun x -> S.add (E.copy x)) s S.empty
+
+ let internal_pretty_code p_caller fmt s =
+ if is_empty s then
+ Format.fprintf fmt "%s.empty" Info.module_name
+ else
+ let pp fmt =
+ if S.cardinal s = 1 then
+ Format.fprintf fmt "@[<hv 2>%s.singleton@;%a@]"
+ Info.module_name
+ (E.internal_pretty_code Type.Call)
+ (Caml_list.hd (S.elements s))
+ else
+ Format.fprintf fmt
+ "@[<hv 2>List.fold_left@;\
+ (fun acc s -> %s.add s acc)@;%s.empty@;%a@]"
+ Info.module_name
+ Info.module_name
+ (let module L = List(E) in L.internal_pretty_code Type.Call)
+ (S.elements s)
+ in
+ Type.par p_caller Type.Call fmt pp
+
+ let pretty fmt s =
+ let pp_elt pp fmt v =
+ Format.fprintf fmt "@[%a@]" pp v
in
- Type.par p_caller Type.Call fmt pp
-
- let pretty fmt s =
- let pp_elt pp fmt v =
- Format.fprintf fmt "@[%a@]" pp v
- in
- Pretty_utils.pp_iter
- ~pre:"@[<hov 2>{@ " ~sep:";@ " ~suf:"@ }@]"
- S.iter (pp_elt E.pretty) fmt s
-
- let varname = undefined
- let mem_project p s =
- try S.iter (fun x -> if E.mem_project p x then raise Exit) s; false
- with Exit -> true
- end)
+ Pretty_utils.pp_iter
+ ~pre:"@[<hov 2>{@ " ~sep:";@ " ~suf:"@ }@]"
+ S.iter (pp_elt E.pretty) fmt s
+
+ let varname = undefined
+ let mem_project p s =
+ try S.iter (fun x -> if E.mem_project p x then raise Exit) s; false
+ with Exit -> true
+ end)
include S
let nearest_elt_le x = S.find_last (fun y -> y <= x)
@@ -1438,95 +1438,95 @@ end
(* ****************************************************************************)
module Map
- (M: Map.S)(Key: S with type t = M.key)(Info: Functor_info) =
+ (M: Map.S)(Key: S with type t = M.key)(Info: Functor_info) =
struct
let () = check Key.equal "equal" Key.name Info.module_name
let () = check Key.compare "compare" Key.name Info.module_name
module P_gen = Polymorphic_gen
- (struct
- type 'a t = 'a M.t
- let name ty =
- Info.module_name ^ "(" ^ Key.name ^ ", " ^ Type.name ty ^ ")"
- let structural_descr d =
- Structural_descr.t_map_unchanged_compares (Descr.str Key.descr) d
- let module_name = Info.module_name
- open M
- let reprs r =
- [ Caml_list.fold_left (fun m k -> add k r m) empty Key.reprs ]
- let mk_compare = M.compare
- let mk_equal = M.equal
- let mk_hash = undefined
- let map = M.map
- let mk_internal_pretty_code = undefined
- (*f_value p_caller fmt map =
- (* [JS 2011/04/01] untested code! *)
- let pp_empty fmt = Format.fprintf fmt "%s.empty" Info.module_name in
- if M.is_empty map then
- Type.par p_caller Type.Basic fmt pp_empty
- else
- let pp fmt =
- Format.fprintf
- fmt "@[<hv 2>@[<hv 2>let map =@;%t@;<1 -2>in@]" pp_empty;
- M.iter
- (fun k v ->
- Format.fprintf
- fmt
- "@[<hv 2>let map =@;%s.add@;@[<hv 2>map@;%a@;%a@]@;<1 -2>in@]"
- Info.module_name
- (Key.internal_pretty_code Type.Call) k
- (f_value Type.Call) v)
- map;
- Format.fprintf fmt "@[map@]@]"
- in
- Type.par p_caller Type.Call fmt pp*)
- let mk_pretty f_value fmt map =
- Format.fprintf fmt "@[{{ ";
- M.iter
- (fun k v ->
- Format.fprintf fmt "@[@[%a@] -> @[%a@]@];@ "
- Key.pretty k
- f_value v)
- map;
- Format.fprintf fmt " }}@]"
- let mk_varname _ =
- if Key.varname == undefined then undefined
- else fun _ -> Format.sprintf "%s_map" Key.name
- let mk_mem_project =
- if Key.mem_project == undefined then undefined
- else
- fun mem ->
- if mem == never_any_project && Key.mem_project == never_any_project
- then never_any_project
- else
- fun p m ->
- try
- M.iter
- (fun k v ->
- if Key.mem_project p k || mem p v then raise Exit)
- m;
- false
- with Exit ->
- true
- end)
+ (struct
+ type 'a t = 'a M.t
+ let name ty =
+ Info.module_name ^ "(" ^ Key.name ^ ", " ^ Type.name ty ^ ")"
+ let structural_descr d =
+ Structural_descr.t_map_unchanged_compares (Descr.str Key.descr) d
+ let module_name = Info.module_name
+ open M
+ let reprs r =
+ [ Caml_list.fold_left (fun m k -> add k r m) empty Key.reprs ]
+ let mk_compare = M.compare
+ let mk_equal = M.equal
+ let mk_hash = undefined
+ let map = M.map
+ let mk_internal_pretty_code = undefined
+ (*f_value p_caller fmt map =
+ (* [JS 2011/04/01] untested code! *)
+ let pp_empty fmt = Format.fprintf fmt "%s.empty" Info.module_name in
+ if M.is_empty map then
+ Type.par p_caller Type.Basic fmt pp_empty
+ else
+ let pp fmt =
+ Format.fprintf
+ fmt "@[<hv 2>@[<hv 2>let map =@;%t@;<1 -2>in@]" pp_empty;
+ M.iter
+ (fun k v ->
+ Format.fprintf
+ fmt
+ "@[<hv 2>let map =@;%s.add@;@[<hv 2>map@;%a@;%a@]@;<1 -2>in@]"
+ Info.module_name
+ (Key.internal_pretty_code Type.Call) k
+ (f_value Type.Call) v)
+ map;
+ Format.fprintf fmt "@[map@]@]"
+ in
+ Type.par p_caller Type.Call fmt pp*)
+ let mk_pretty f_value fmt map =
+ Format.fprintf fmt "@[{{ ";
+ M.iter
+ (fun k v ->
+ Format.fprintf fmt "@[@[%a@] -> @[%a@]@];@ "
+ Key.pretty k
+ f_value v)
+ map;
+ Format.fprintf fmt " }}@]"
+ let mk_varname _ =
+ if Key.varname == undefined then undefined
+ else fun _ -> Format.sprintf "%s_map" Key.name
+ let mk_mem_project =
+ if Key.mem_project == undefined then undefined
+ else
+ fun mem ->
+ if mem == never_any_project && Key.mem_project == never_any_project
+ then never_any_project
+ else
+ fun p m ->
+ try
+ M.iter
+ (fun k v ->
+ if Key.mem_project p k || mem p v then raise Exit)
+ m;
+ false
+ with Exit ->
+ true
+ end)
module P = struct
include P_gen
- module Make(X:S) =
+ module Make(X:S) =
Make_gen
- (X)
- (struct
- let rehash =
- if Descr.is_unmarshable Key.descr
- || Descr.is_unmarshable X.descr
- then undefined
- else
- if Descr.is_abstract Key.descr then identity
- else (* the key changed: rebuild the map *)
- fun m ->
- M.fold M.add m M.empty;
- end)
+ (X)
+ (struct
+ let rehash =
+ if Descr.is_unmarshable Key.descr
+ || Descr.is_unmarshable X.descr
+ then undefined
+ else
+ if Descr.is_abstract Key.descr then identity
+ else (* the key changed: rebuild the map *)
+ fun m ->
+ M.fold M.add m M.empty;
+ end)
end
@@ -1542,90 +1542,90 @@ end
(* OCaml functors are generative *)
module Hashtbl
- (H: Hashtbl_with_descr)(Key: S with type t = H.key)(Info : Functor_info) =
+ (H: Hashtbl_with_descr)(Key: S with type t = H.key)(Info : Functor_info) =
struct
let () = check Key.equal "equal" Key.name Info.module_name
let () = check Key.hash "hash" Key.name Info.module_name
module P_gen = Polymorphic_gen
- (struct
- type 'a t = 'a H.t
- let name ty =
- Info.module_name ^ "(" ^ Key.name ^ ", " ^ Type.name ty ^ ")"
- let module_name = Info.module_name
- let structural_descr = H.structural_descr
- let reprs x =
- [ let h = H.create 7 in
- Caml_list.iter (fun k -> H.add h k x) Key.reprs; h ]
- let mk_compare = undefined
- let mk_equal = from_compare
- let mk_hash = undefined
- let map f_value tbl =
- (* first mapping which reverses the binding order *)
- let h = H.create (H.length tbl) (* may be very memory-consuming *) in
- H.iter (fun k v -> H.add h k (f_value v)) tbl;
- (* copy which reverses again the binding order: so we get the right
- order *)
- let h2 = H.create (H.length tbl) (* may be very memory-consuming *) in
- H.iter (fun k v -> H.add h2 k v) h;
- h2
- let mk_internal_pretty_code = undefined
- let mk_pretty = from_pretty_code
- let mk_varname = undefined
- let mk_mem_project =
- if Key.mem_project == undefined then undefined
- else
- fun mem ->
- if mem == never_any_project && Key.mem_project == never_any_project
- then never_any_project
- else
- fun p m ->
- try
- H.iter
- (fun k v ->
- if Key.mem_project p k || mem p v then raise Exit)
- m;
- false
- with Exit ->
- true
- end)
+ (struct
+ type 'a t = 'a H.t
+ let name ty =
+ Info.module_name ^ "(" ^ Key.name ^ ", " ^ Type.name ty ^ ")"
+ let module_name = Info.module_name
+ let structural_descr = H.structural_descr
+ let reprs x =
+ [ let h = H.create 7 in
+ Caml_list.iter (fun k -> H.add h k x) Key.reprs; h ]
+ let mk_compare = undefined
+ let mk_equal = from_compare
+ let mk_hash = undefined
+ let map f_value tbl =
+ (* first mapping which reverses the binding order *)
+ let h = H.create (H.length tbl) (* may be very memory-consuming *) in
+ H.iter (fun k v -> H.add h k (f_value v)) tbl;
+ (* copy which reverses again the binding order: so we get the right
+ order *)
+ let h2 = H.create (H.length tbl) (* may be very memory-consuming *) in
+ H.iter (fun k v -> H.add h2 k v) h;
+ h2
+ let mk_internal_pretty_code = undefined
+ let mk_pretty = from_pretty_code
+ let mk_varname = undefined
+ let mk_mem_project =
+ if Key.mem_project == undefined then undefined
+ else
+ fun mem ->
+ if mem == never_any_project && Key.mem_project == never_any_project
+ then never_any_project
+ else
+ fun p m ->
+ try
+ H.iter
+ (fun k v ->
+ if Key.mem_project p k || mem p v then raise Exit)
+ m;
+ false
+ with Exit ->
+ true
+ end)
module P = struct
include P_gen
- module Make(X:S) =
+ module Make(X:S) =
Make_gen
- (X)
- (struct
- let rehash =
- if Descr.is_unmarshable Key.descr
- || Descr.is_unmarshable X.descr
- then undefined
- else
- if Descr.is_abstract Key.descr then identity
- else (* the key changed: rebuild the hashtbl *)
- fun h ->
- let h' = H.create (H.length h) in
- H.iter (H.add h') h;
- h'
- end)
-
+ (X)
+ (struct
+ let rehash =
+ if Descr.is_unmarshable Key.descr
+ || Descr.is_unmarshable X.descr
+ then undefined
+ else
+ if Descr.is_abstract Key.descr then identity
+ else (* the key changed: rebuild the hashtbl *)
+ fun h ->
+ let h' = H.create (H.length h) in
+ H.iter (H.add h') h;
+ h'
+ end)
+
end
include H
let make_type (type typ) (ty: typ Type.t) =
let module M =
- P.Make(struct
- type t = typ
- include Undefined
- let ty = ty
- let name = Type.name ty
- let descr = Descr.of_type ty
- let packed_descr = Descr.pack descr
- let reprs = Type.reprs ty
- let pretty_code = undefined
- end)
+ P.Make(struct
+ type t = typ
+ include Undefined
+ let ty = ty
+ let name = Type.name ty
+ let descr = Descr.of_type ty
+ let packed_descr = Descr.pack descr
+ let reprs = Type.reprs ty
+ let pretty_code = undefined
+ end)
in M.ty
module Key = Key
@@ -1648,12 +1648,12 @@ module Initial_caml_weak = Weak
module Weak(W: Sub_caml_weak_hashtbl)(D: S with type t = W.data) = struct
include Make
- (struct
- include Undefined
- type t = W.t
- let name = "Weak(" ^ D.name ^ ")"
- let reprs = let w = W.create 0 in Caml_list.iter (W.add w) D.reprs; [ w ]
- end)
+ (struct
+ include Undefined
+ type t = W.t
+ let name = "Weak(" ^ D.name ^ ")"
+ let reprs = let w = W.create 0 in Caml_list.iter (W.add w) D.reprs; [ w ]
+ end)
let () = Type.set_ml_name ty None;
end
@@ -1689,25 +1689,25 @@ module With_collections(X: S)(Info: Functor_info) = struct
module Hashtbl =
Hashtbl
(struct
- include FCHashtbl.Make(D)
+ include FCHashtbl.Make(D)
(* Override "sorted" iterators by using the datatype comparison
function if it has been supplied *)
let iter_sorted ?cmp = match cmp with
| None ->
- if D.compare == undefined then iter_sorted ?cmp:None
- else iter_sorted ~cmp:D.compare
+ if D.compare == undefined then iter_sorted ?cmp:None
+ else iter_sorted ~cmp:D.compare
| Some cmp -> iter_sorted ~cmp
- let fold_sorted ?cmp = match cmp with
+ let fold_sorted ?cmp = match cmp with
| None ->
- if D.compare == undefined then fold_sorted ?cmp:None
- else fold_sorted ~cmp:D.compare
+ if D.compare == undefined then fold_sorted ?cmp:None
+ else fold_sorted ~cmp:D.compare
| Some cmp -> fold_sorted ~cmp
let structural_descr =
Structural_descr.t_hashtbl_unchanged_hashs (Descr.str D.descr)
- end)
+ end)
(D)
(struct let module_name = Info.module_name ^ ".Hashtbl" end)
@@ -1723,38 +1723,38 @@ module Make_with_collections(X: Make_input) =
(* ****************************************************************************)
module Simple_type
- (X: sig
- type t
- val name: string
- val reprs: t list
- val pretty: Format.formatter -> t -> unit
- val copy: t -> t
- val varname: t -> string
- val compare: t -> t -> int
- val equal: t -> t -> bool
- end) =
+ (X: sig
+ type t
+ val name: string
+ val reprs: t list
+ val pretty: Format.formatter -> t -> unit
+ val copy: t -> t
+ val varname: t -> string
+ val compare: t -> t -> int
+ val equal: t -> t -> bool
+ end) =
struct
let module_name = "Datatype." ^ String.capitalize_ascii X.name
include With_collections
- (Make(struct
- type t = X.t
- let name = X.name
- let reprs = X.reprs
- let structural_descr = Structural_descr.t_abstract
- let equal = X.equal
- let compare = X.compare
- let hash = FCHashtbl.hash
- let rehash = identity
- let copy = X.copy
- let internal_pretty_code =
- if X.pretty == undefined then undefined else fun _ -> X.pretty
- let pretty = X.pretty
- let varname = X.varname
- let mem_project = never_any_project
- end))
- (struct let module_name = module_name end)
+ (Make(struct
+ type t = X.t
+ let name = X.name
+ let reprs = X.reprs
+ let structural_descr = Structural_descr.t_abstract
+ let equal = X.equal
+ let compare = X.compare
+ let hash = FCHashtbl.hash
+ let rehash = identity
+ let copy = X.copy
+ let internal_pretty_code =
+ if X.pretty == undefined then undefined else fun _ -> X.pretty
+ let pretty = X.pretty
+ let varname = X.varname
+ let mem_project = never_any_project
+ end))
+ (struct let module_name = module_name end)
let () = Type.set_ml_name ty (Some ("Datatype." ^ name))
@@ -1771,7 +1771,7 @@ module Unit =
let equal () () = true
let pretty fmt () = Format.fprintf fmt "()"
let varname = undefined
- end)
+ end)
let unit = Unit.ty
module Bool =
@@ -1785,21 +1785,21 @@ module Bool =
let equal : bool -> bool -> bool = (=)
let pretty fmt b = Format.fprintf fmt "%B" b
let varname _ = "b"
- end)
+ end)
let bool = Bool.ty
module Int = struct
include Simple_type
- (struct
- type t = int
- let name = "int"
- let reprs = [ 2 ]
- let copy = identity
- let compare : int -> int -> int = Stdlib.compare
- let equal : int -> int -> bool = (=)
- let pretty fmt n = Format.fprintf fmt "%d" n
- let varname _ = "n"
- end)
+ (struct
+ type t = int
+ let name = "int"
+ let reprs = [ 2 ]
+ let copy = identity
+ let compare : int -> int -> int = Stdlib.compare
+ let equal : int -> int -> bool = (=)
+ let pretty fmt n = Format.fprintf fmt "%d" n
+ let varname _ = "n"
+ end)
let compare : int -> int -> int = Stdlib.compare
end
let int = Int.ty
@@ -1815,7 +1815,7 @@ module Int32 =
let equal : int32 -> int32 -> bool = (=)
let pretty fmt n = Format.fprintf fmt "%ld" n
let varname _ = "n32"
- end)
+ end)
let int32 = Int32.ty
module Int64 =
@@ -1829,7 +1829,7 @@ module Int64 =
let equal : int64 -> int64 -> bool = (=)
let pretty fmt n = Format.fprintf fmt "%Ld" n
let varname _ = "n64"
- end)
+ end)
let int64 = Int64.ty
module Nativeint =
@@ -1843,7 +1843,7 @@ module Nativeint =
let equal : nativeint -> nativeint -> bool = (=)
let pretty fmt n = Format.fprintf fmt "%nd" n
let varname _ = "native_n"
- end)
+ end)
let nativeint = Nativeint.ty
module Float =
@@ -1857,7 +1857,7 @@ module Float =
let equal : float -> float -> bool = (=)
let pretty fmt f = Format.fprintf fmt "%f" f
let varname _ = "f"
- end)
+ end)
let float = Float.ty
module Char =
@@ -1871,7 +1871,7 @@ module Char =
let equal : char -> char -> bool = (=)
let pretty fmt c = Format.fprintf fmt "%c" c
let varname _ = "c"
- end)
+ end)
let char = Char.ty
module String =
@@ -1885,7 +1885,7 @@ module String =
let equal : string -> string -> bool = (=)
let pretty fmt s = Format.fprintf fmt "%S" s
let varname _ = "s"
- end)
+ end)
let string = String.ty
module Formatter =
@@ -1904,7 +1904,7 @@ module Formatter =
let pretty = undefined
let varname _ = "fmt"
let mem_project = never_any_project
- end)
+ end)
let formatter = Formatter.ty
module Integer =
@@ -1931,7 +1931,7 @@ module Integer =
let pretty = Integer.pretty ~hexa:false
let varname _ = "integer_n"
let mem_project = never_any_project
- end)
+ end)
let integer = Integer.ty
module Filepath = struct
@@ -1965,14 +1965,14 @@ module Triple_arg = struct
let reprs a b c = [ a, b, c ]
let structural_descr d1 d2 d3 =
Structural_descr.t_tuple
- [| Structural_descr.pack d1;
- Structural_descr.pack d2;
- Structural_descr.pack d3 |]
+ [| Structural_descr.pack d1;
+ Structural_descr.pack d2;
+ Structural_descr.pack d3 |]
let mk_equal f1 f2 f3 (x1,x2,x3) (y1,y2,y3) = f1 x1 y1 && f2 x2 y2 && f3 x3 y3
let mk_compare f1 f2 f3 (x1,x2,x3 as x) (y1,y2,y3 as y) =
- if x == y then 0
- else
- let n = f1 x1 y1 in
+ if x == y then 0
+ else
+ let n = f1 x1 y1 in
if n = 0 then let n = f2 x2 y2 in if n = 0 then f3 x3 y3 else n
else n
let mk_hash f1 f2 f3 (x1,x2,x3) = f1 x1 + 1351 * f2 x2 + 257 * f3 x3
@@ -1980,19 +1980,19 @@ module Triple_arg = struct
let mk_internal_pretty_code f1 f2 f3 p fmt (x1, x2, x3) =
let pp fmt =
Format.fprintf
- fmt "@[<hv 2>%a,@;%a,@;%a@]"
- (f1 Type.Tuple) x1
- (f2 Type.Tuple) x2
- (f3 Type.Tuple) x3
+ fmt "@[<hv 2>%a,@;%a,@;%a@]"
+ (f1 Type.Tuple) x1
+ (f2 Type.Tuple) x2
+ (f3 Type.Tuple) x3
in
Type.par p Type.Tuple fmt pp
let mk_pretty f1 f2 f3 fmt p =
Format.fprintf fmt "@[(%a)@]"
- (mk_internal_pretty_code
- (fun _ -> f1) (fun _ -> f2) (fun _ -> f3) Type.Basic)
+ (mk_internal_pretty_code
+ (fun _ -> f1) (fun _ -> f2) (fun _ -> f3) Type.Basic)
p
let mk_varname = undefined
- let mk_mem_project mem1 mem2 mem3 f (x1, x2, x3) =
+ let mk_mem_project mem1 mem2 mem3 f (x1, x2, x3) =
mem1 f x1 && mem2 f x2 && mem3 f x3
end
@@ -2001,16 +2001,16 @@ end
*)
[@@@ warning "-60"]
-module rec Triple_name: sig
- val name: 'a Type.t -> 'b Type.t -> 'c Type.t -> string
+module rec Triple_name: sig
+ val name: 'a Type.t -> 'b Type.t -> 'c Type.t -> string
end =
struct
let name ty1 ty2 ty3 =
let arg ty =
Type.par_ty_name
(fun ty ->
- Type.Function.is_instance_of ty || Poly_pair.is_instance_of ty
- || Poly_triple.is_instance_of ty)
+ Type.Function.is_instance_of ty || Poly_pair.is_instance_of ty
+ || Poly_triple.is_instance_of ty)
ty
in
arg ty1 ^ " * " ^ arg ty2 ^ " * " ^ arg ty3
@@ -2032,27 +2032,27 @@ let triple
(type typ1) (type typ2) (type typ3)
(ty1: typ1 Type.t) (ty2: typ2 Type.t) (ty3: typ3 Type.t) =
let module Make(X: sig type t val ty: t Type.t end) = struct
- type t = X.t
- let ty = X.ty
- let name = Type.name X.ty
- let descr = Descr.of_type X.ty
- let packed_descr = Descr.pack descr
- let reprs = Type.reprs X.ty
- let equal = equal X.ty
- let compare = compare X.ty
- let hash = hash X.ty
- let copy = copy X.ty
- let internal_pretty_code = internal_pretty_code X.ty
- let pretty_code = pretty_code X.ty
- let pretty = from_pretty_code
- let varname = varname ty
- let mem_project = mem_project X.ty
+ type t = X.t
+ let ty = X.ty
+ let name = Type.name X.ty
+ let descr = Descr.of_type X.ty
+ let packed_descr = Descr.pack descr
+ let reprs = Type.reprs X.ty
+ let equal = equal X.ty
+ let compare = compare X.ty
+ let hash = hash X.ty
+ let copy = copy X.ty
+ let internal_pretty_code = internal_pretty_code X.ty
+ let pretty_code = pretty_code X.ty
+ let pretty = from_pretty_code
+ let varname = varname ty
+ let mem_project = mem_project X.ty
end
in
let module L = Triple
- (Make(struct type t = typ1 let ty = ty1 end))
- (Make(struct type t = typ2 let ty = ty2 end))
- (Make(struct type t = typ3 let ty = ty3 end))
+ (Make(struct type t = typ1 let ty = ty1 end))
+ (Make(struct type t = typ2 let ty = ty2 end))
+ (Make(struct type t = typ3 let ty = ty3 end))
in
L.ty
@@ -2068,41 +2068,41 @@ module Quadruple_arg = struct
let reprs a b c d = [ a, b, c, d ]
let structural_descr d1 d2 d3 d4 =
Structural_descr.t_tuple
- [| Structural_descr.pack d1;
- Structural_descr.pack d2;
- Structural_descr.pack d3;
- Structural_descr.pack d4 |]
- let mk_equal f1 f2 f3 f4 (x1,x2,x3,x4) (y1,y2,y3,y4) =
+ [| Structural_descr.pack d1;
+ Structural_descr.pack d2;
+ Structural_descr.pack d3;
+ Structural_descr.pack d4 |]
+ let mk_equal f1 f2 f3 f4 (x1,x2,x3,x4) (y1,y2,y3,y4) =
f1 x1 y1 && f2 x2 y2 && f3 x3 y3 && f4 x4 y4
let mk_compare f1 f2 f3 f4 (x1,x2,x3,x4 as x) (y1,y2,y3,y4 as y) =
- if x == y then 0
- else
- let n = f1 x1 y1 in
- if n = 0 then
- let n = f2 x2 y2 in
- if n = 0 then let n = f3 x3 y3 in if n = 0 then f4 x4 y4 else n
- else n
+ if x == y then 0
+ else
+ let n = f1 x1 y1 in
+ if n = 0 then
+ let n = f2 x2 y2 in
+ if n = 0 then let n = f3 x3 y3 in if n = 0 then f4 x4 y4 else n
+ else n
else n
- let mk_hash f1 f2 f3 f4 (x1,x2,x3,x4) =
+ let mk_hash f1 f2 f3 f4 (x1,x2,x3,x4) =
f1 x1 + 1351 * f2 x2 + 257 * f3 x3 + 997 * f4 x4
let map f1 f2 f3 f4 (x1,x2,x3,x4) = f1 x1, f2 x2, f3 x3, f4 x4
let mk_internal_pretty_code f1 f2 f3 f4 p fmt (x1, x2, x3, x4) =
let pp fmt =
Format.fprintf
- fmt "@[<hv 2>%a,@;%a,@;%a,@;%a@]"
- (f1 Type.Tuple) x1
- (f2 Type.Tuple) x2
- (f3 Type.Tuple) x3
- (f4 Type.Tuple) x4
+ fmt "@[<hv 2>%a,@;%a,@;%a,@;%a@]"
+ (f1 Type.Tuple) x1
+ (f2 Type.Tuple) x2
+ (f3 Type.Tuple) x3
+ (f4 Type.Tuple) x4
in
Type.par p Type.Tuple fmt pp
let mk_pretty f1 f2 f3 f4 fmt p =
Format.fprintf fmt "@[(%a)@]"
- (mk_internal_pretty_code
- (fun _ -> f1) (fun _ -> f2) (fun _ -> f3) (fun _ -> f4) Type.Basic)
+ (mk_internal_pretty_code
+ (fun _ -> f1) (fun _ -> f2) (fun _ -> f3) (fun _ -> f4) Type.Basic)
p
let mk_varname = undefined
- let mk_mem_project mem1 mem2 mem3 mem4 f (x1, x2, x3, x4) =
+ let mk_mem_project mem1 mem2 mem3 mem4 f (x1, x2, x3, x4) =
mem1 f x1 && mem2 f x2 && mem3 f x3 && mem4 f x4
end
@@ -2111,16 +2111,16 @@ end
*)
[@@@ warning "-60"]
-module rec Quadruple_name: sig
- val name: 'a Type.t -> 'b Type.t -> 'c Type.t -> 'd Type.t -> string
+module rec Quadruple_name: sig
+ val name: 'a Type.t -> 'b Type.t -> 'c Type.t -> 'd Type.t -> string
end =
struct
let name ty1 ty2 ty3 ty4 =
let arg ty =
Type.par_ty_name
(fun ty ->
- Type.Function.is_instance_of ty || Poly_pair.is_instance_of ty
- || Poly_triple.is_instance_of ty || Poly_quadruple.is_instance_of ty)
+ Type.Function.is_instance_of ty || Poly_pair.is_instance_of ty
+ || Poly_triple.is_instance_of ty || Poly_quadruple.is_instance_of ty)
ty
in
arg ty1 ^ " * " ^ arg ty2 ^ " * " ^ arg ty3 ^ " * " ^ arg ty4
@@ -2131,12 +2131,12 @@ and Poly_quadruple : sig
module Make(T1: S)(T2: S)(T3:S)(T4:S) :
S with type t = (T1.t, T2.t, T3.t, T4.t) poly
end =
- struct
- (* Split the functor argument in 2 modules such that OCaml is able to safely
- evaluate the recursive modules *)
- include Polymorphic4
+struct
+ (* Split the functor argument in 2 modules such that OCaml is able to safely
+ evaluate the recursive modules *)
+ include Polymorphic4
(struct include Quadruple_arg include Quadruple_name end)
- end
+end
[@@@ warning "+60"]
@@ -2145,30 +2145,30 @@ module Quadruple = Poly_quadruple.Make
let quadruple
(type typ1) (type typ2) (type typ3) (type typ4)
(ty1: typ1 Type.t) (ty2: typ2 Type.t) (ty3: typ3 Type.t) (ty4: typ4 Type.t)
- =
+ =
let module Make(X: sig type t val ty: t Type.t end) = struct
- type t = X.t
- let ty = X.ty
- let name = Type.name X.ty
- let descr = Descr.of_type X.ty
- let packed_descr = Descr.pack descr
- let reprs = Type.reprs X.ty
- let equal = equal X.ty
- let compare = compare X.ty
- let hash = hash X.ty
- let copy = copy X.ty
- let internal_pretty_code = internal_pretty_code X.ty
- let pretty_code = pretty_code X.ty
- let pretty = from_pretty_code
- let varname = varname ty
- let mem_project = mem_project X.ty
+ type t = X.t
+ let ty = X.ty
+ let name = Type.name X.ty
+ let descr = Descr.of_type X.ty
+ let packed_descr = Descr.pack descr
+ let reprs = Type.reprs X.ty
+ let equal = equal X.ty
+ let compare = compare X.ty
+ let hash = hash X.ty
+ let copy = copy X.ty
+ let internal_pretty_code = internal_pretty_code X.ty
+ let pretty_code = pretty_code X.ty
+ let pretty = from_pretty_code
+ let varname = varname ty
+ let mem_project = mem_project X.ty
end
in
let module L = Quadruple
- (Make(struct type t = typ1 let ty = ty1 end))
- (Make(struct type t = typ2 let ty = ty2 end))
- (Make(struct type t = typ3 let ty = ty3 end))
- (Make(struct type t = typ4 let ty = ty4 end))
+ (Make(struct type t = typ1 let ty = ty1 end))
+ (Make(struct type t = typ2 let ty = ty2 end))
+ (Make(struct type t = typ3 let ty = ty3 end))
+ (Make(struct type t = typ4 let ty = ty4 end))
in
L.ty
diff --git a/src/libraries/datatype/datatype.mli b/src/libraries/datatype/datatype.mli
index d2e972ba30037d7a5bd5e1d58e93c29a03ef9695..073796a923ae65f06403a62e87c1e40dcfe9964f 100644
--- a/src/libraries/datatype/datatype.mli
+++ b/src/libraries/datatype/datatype.mli
@@ -32,15 +32,15 @@
(** Values associated to each datatype.
Some others are provided directly in module {!Type}. *)
type 'a t = private
- { equal: 'a -> 'a -> bool;
- compare: 'a -> 'a -> int;
- hash: 'a -> int;
- copy: 'a -> 'a;
- internal_pretty_code: Type.precedence -> Format.formatter -> 'a -> unit;
- pretty_code: Format.formatter -> 'a -> unit;
- pretty: Format.formatter -> 'a -> unit;
- varname: 'a -> string;
- mem_project: (Project_skeleton.t -> bool) -> 'a -> bool }
+ { equal: 'a -> 'a -> bool;
+ compare: 'a -> 'a -> int;
+ hash: 'a -> int;
+ copy: 'a -> 'a;
+ internal_pretty_code: Type.precedence -> Format.formatter -> 'a -> unit;
+ pretty_code: Format.formatter -> 'a -> unit;
+ pretty: Format.formatter -> 'a -> unit;
+ varname: 'a -> string;
+ mem_project: (Project_skeleton.t -> bool) -> 'a -> bool }
(** A type with its type value. *)
module type Ty = sig
@@ -90,8 +90,8 @@ module type S_no_copy = sig
for journalisation. *)
val mem_project: (Project_skeleton.t -> bool) -> t -> bool
-(** [mem_project f x] must return [true] iff there is a value [p] of type
- [Project.t] in [x] such that [f p] returns [true]. *)
+ (** [mem_project f x] must return [true] iff there is a value [p] of type
+ [Project.t] in [x] such that [f p] returns [true]. *)
end
@@ -99,7 +99,7 @@ end
module type S = sig
include S_no_copy
val copy: t -> t
-(** Deep copy: no possible sharing between [x] and [copy x]. *)
+ (** Deep copy: no possible sharing between [x] and [copy x]. *)
end
(* ********************************************************************** *)
@@ -123,12 +123,12 @@ val mem_project: 'a Type.t -> (Project_skeleton.t -> bool) -> 'a -> bool
(* ********************************************************************** *)
val undefined: 'a -> 'b
-(** Must be used if you don't want to implement a required function.
+(** Must be used if you don't want to implement a required function.
@plugin development guide *)
val identity: 'a -> 'a
(** Must be used if you want to implement a required function by [fun x ->
- x]. Only useful for implementing [rehash] and [copy].
+ x]. Only useful for implementing [rehash] and [copy].
@plugin development guide *)
val from_compare: 'a -> 'a -> bool
@@ -141,16 +141,16 @@ val from_pretty_code: Format.formatter -> 'a -> unit
val never_any_project: (Project_skeleton.t -> bool) -> 'a -> bool
(** Must be used for [mem_project] if values of your type does never contain
- any project.
+ any project.
@plugin development guide *)
val pp_fail: Type.precedence -> Format.formatter -> 'a -> unit
(** Must be used for [internal_pretty_code] if this pretty-printer must
- fail only when called.
+ fail only when called.
@plugin development guide *)
(** Sub-signature of {!S}.
- @plugin development guide *)
+ @plugin development guide *)
module type Undefined = sig
val structural_descr: Structural_descr.t
val equal: 'a -> 'a -> bool
@@ -171,13 +171,13 @@ end
let reprs = ...
let name = ...
let mem_project = ... (* Usually, Datatype.never_any_project *)
-(* define only useful functions for this datatype *)
+ (* define only useful functions for this datatype *)
end] *)
module Undefined: Undefined
(** Same as {!Undefined}, but the type is supposed to be marshallable by the
standard OCaml way (in particular, no hash-consing or projects inside
- the type).
+ the type).
@plugin development guide *)
module Serializable_undefined: Undefined
@@ -220,15 +220,15 @@ module type Make_input = sig
end
-(** Generic datatype builder.
+(** Generic datatype builder.
@plugin development guide *)
module Make(X: Make_input): S with type t = X.t
(** Additional info for building [Set], [Map] and [Hashtbl]. *)
module type Functor_info = sig
val module_name: string
-(** Must be a valid OCaml module name corresponding to the module name you are
- defining by applying the functor. *)
+ (** Must be a valid OCaml module name corresponding to the module name you are
+ defining by applying the functor. *)
end
(** A standard OCaml set signature extended with datatype operations. *)
@@ -248,8 +248,8 @@ module type Map = sig
(** Datatype for the keys of the map. *)
module Make(Data: S) : S with type t = Data.t t
-(** Build a datatype of the map according to the datatype of values in the
- map. *)
+ (** Build a datatype of the map according to the datatype of values in the
+ map. *)
end
@@ -271,8 +271,8 @@ module type Hashtbl = sig
(** Datatype for the keys of the hashtbl. *)
module Make(Data: S) : S with type t = Data.t t
-(** Build a datatype of the hashtbl according to the datatype of values in the
- hashtbl. *)
+ (** Build a datatype of the hashtbl according to the datatype of values in the
+ hashtbl. *)
end
@@ -337,7 +337,7 @@ val string: string Type.t
module Formatter: S with type t = Format.formatter
val formatter: Format.formatter Type.t
-
+
(* module Big_int: S_with_collections with type t = Integer.t *)
(* val big_int: Big_int.t Type.t *)
(** @deprecated use Integer instead. *)
@@ -364,28 +364,28 @@ end
module type Polymorphic = sig
include Type.Polymorphic
module Make(T: S) : S with type t = T.t poly
-(** Create a datatype for a monomorphic instance of the polymorphic type. *)
+ (** Create a datatype for a monomorphic instance of the polymorphic type. *)
end
(** Functor for polymorphic types with only 1 type variable.
@plugin development guide *)
module Polymorphic
- (P: sig
- include Type.Polymorphic_input
- val mk_equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
- val mk_compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
- val mk_hash: ('a -> int) -> 'a t -> int
- val map: ('a -> 'a) -> 'a t -> 'a t
- val mk_internal_pretty_code:
- (Type.precedence -> Format.formatter -> 'a -> unit) ->
- Type.precedence -> Format.formatter -> 'a t -> unit
- val mk_pretty:
- (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
- val mk_varname: ('a -> string) -> 'a t -> string
- val mk_mem_project:
- ((Project_skeleton.t -> bool) -> 'a -> bool) ->
- (Project_skeleton.t -> bool) -> 'a t -> bool
- end) :
+ (P: sig
+ include Type.Polymorphic_input
+ val mk_equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+ val mk_compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
+ val mk_hash: ('a -> int) -> 'a t -> int
+ val map: ('a -> 'a) -> 'a t -> 'a t
+ val mk_internal_pretty_code:
+ (Type.precedence -> Format.formatter -> 'a -> unit) ->
+ Type.precedence -> Format.formatter -> 'a t -> unit
+ val mk_pretty:
+ (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
+ val mk_varname: ('a -> string) -> 'a t -> string
+ val mk_mem_project:
+ ((Project_skeleton.t -> bool) -> 'a -> bool) ->
+ (Project_skeleton.t -> bool) -> 'a t -> bool
+ end) :
Polymorphic with type 'a poly = 'a P.t
(** Output signature of {!Polymorphic2}. *)
@@ -394,31 +394,31 @@ module type Polymorphic2 = sig
module Make(T1: S)(T2: S) : S with type t = (T1.t, T2.t) poly
end
-(** Functor for polymorphic types with 2 type variables.
+(** Functor for polymorphic types with 2 type variables.
@plugin development guide *)
module Polymorphic2
- (P: sig
- include Type.Polymorphic2_input
- val mk_equal:
- ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a, 'b) t -> ('a, 'b) t ->
- bool
- val mk_compare:
- ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a, 'b) t -> ('a, 'b) t -> int
- val mk_hash: ('a -> int) -> ('b -> int) -> ('a, 'b) t -> int
- val map: ('a -> 'a) -> ('b -> 'b) -> ('a, 'b) t -> ('a, 'b) t
- val mk_internal_pretty_code:
- (Type.precedence -> Format.formatter -> 'a -> unit) ->
- (Type.precedence -> Format.formatter -> 'b -> unit) ->
- Type.precedence -> Format.formatter -> ('a, 'b) t -> unit
- val mk_pretty:
- (Format.formatter -> 'a -> unit) -> (Format.formatter -> 'b -> unit) ->
- Format.formatter -> ('a, 'b) t -> unit
- val mk_varname: ('a -> string) -> ('b -> string) -> ('a, 'b) t -> string
- val mk_mem_project:
- ((Project_skeleton.t -> bool) -> 'a -> bool) ->
- ((Project_skeleton.t -> bool) -> 'b -> bool) ->
- (Project_skeleton.t -> bool) -> ('a, 'b) t -> bool
- end) :
+ (P: sig
+ include Type.Polymorphic2_input
+ val mk_equal:
+ ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a, 'b) t -> ('a, 'b) t ->
+ bool
+ val mk_compare:
+ ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a, 'b) t -> ('a, 'b) t -> int
+ val mk_hash: ('a -> int) -> ('b -> int) -> ('a, 'b) t -> int
+ val map: ('a -> 'a) -> ('b -> 'b) -> ('a, 'b) t -> ('a, 'b) t
+ val mk_internal_pretty_code:
+ (Type.precedence -> Format.formatter -> 'a -> unit) ->
+ (Type.precedence -> Format.formatter -> 'b -> unit) ->
+ Type.precedence -> Format.formatter -> ('a, 'b) t -> unit
+ val mk_pretty:
+ (Format.formatter -> 'a -> unit) -> (Format.formatter -> 'b -> unit) ->
+ Format.formatter -> ('a, 'b) t -> unit
+ val mk_varname: ('a -> string) -> ('b -> string) -> ('a, 'b) t -> string
+ val mk_mem_project:
+ ((Project_skeleton.t -> bool) -> 'a -> bool) ->
+ ((Project_skeleton.t -> bool) -> 'b -> bool) ->
+ (Project_skeleton.t -> bool) -> ('a, 'b) t -> bool
+ end) :
Polymorphic2 with type ('a, 'b) poly = ('a, 'b) P.t
(** Output signature of {!Polymorphic3}.
@@ -432,45 +432,45 @@ end
@since Oxygen-20120901
@plugin development guide *)
module Polymorphic3
- (P: sig
- include Type.Polymorphic3_input
- val mk_equal:
- ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('c -> 'c -> bool) ->
- ('a, 'b, 'c) t -> ('a, 'b, 'c) t ->
- bool
- val mk_compare:
- ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('c -> 'c -> int) ->
- ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> int
- val mk_hash:
- ('a -> int) -> ('b -> int) -> ('c -> int) -> ('a, 'b, 'c) t -> int
- val map:
- ('a -> 'a) -> ('b -> 'b) -> ('c -> 'c) -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t
- val mk_internal_pretty_code:
- (Type.precedence -> Format.formatter -> 'a -> unit) ->
- (Type.precedence -> Format.formatter -> 'b -> unit) ->
- (Type.precedence -> Format.formatter -> 'c -> unit) ->
- Type.precedence -> Format.formatter -> ('a, 'b, 'c) t -> unit
- val mk_pretty:
- (Format.formatter -> 'a -> unit) ->
- (Format.formatter -> 'b -> unit) ->
- (Format.formatter -> 'c -> unit) ->
- Format.formatter -> ('a, 'b, 'c) t -> unit
- val mk_varname:
- ('a -> string) -> ('b -> string) -> ('c -> string) ->
- ('a, 'b, 'c) t -> string
- val mk_mem_project:
- ((Project_skeleton.t -> bool) -> 'a -> bool) ->
- ((Project_skeleton.t -> bool) -> 'b -> bool) ->
- ((Project_skeleton.t -> bool) -> 'c -> bool) ->
- (Project_skeleton.t -> bool) -> ('a, 'b, 'c) t -> bool
- end) :
+ (P: sig
+ include Type.Polymorphic3_input
+ val mk_equal:
+ ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('c -> 'c -> bool) ->
+ ('a, 'b, 'c) t -> ('a, 'b, 'c) t ->
+ bool
+ val mk_compare:
+ ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('c -> 'c -> int) ->
+ ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> int
+ val mk_hash:
+ ('a -> int) -> ('b -> int) -> ('c -> int) -> ('a, 'b, 'c) t -> int
+ val map:
+ ('a -> 'a) -> ('b -> 'b) -> ('c -> 'c) -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t
+ val mk_internal_pretty_code:
+ (Type.precedence -> Format.formatter -> 'a -> unit) ->
+ (Type.precedence -> Format.formatter -> 'b -> unit) ->
+ (Type.precedence -> Format.formatter -> 'c -> unit) ->
+ Type.precedence -> Format.formatter -> ('a, 'b, 'c) t -> unit
+ val mk_pretty:
+ (Format.formatter -> 'a -> unit) ->
+ (Format.formatter -> 'b -> unit) ->
+ (Format.formatter -> 'c -> unit) ->
+ Format.formatter -> ('a, 'b, 'c) t -> unit
+ val mk_varname:
+ ('a -> string) -> ('b -> string) -> ('c -> string) ->
+ ('a, 'b, 'c) t -> string
+ val mk_mem_project:
+ ((Project_skeleton.t -> bool) -> 'a -> bool) ->
+ ((Project_skeleton.t -> bool) -> 'b -> bool) ->
+ ((Project_skeleton.t -> bool) -> 'c -> bool) ->
+ (Project_skeleton.t -> bool) -> ('a, 'b, 'c) t -> bool
+ end) :
Polymorphic3 with type ('a, 'b, 'c) poly = ('a, 'b, 'c) P.t
(** Output signature of {!Polymorphic4}.
@since Oxygen-20120901 *)
module type Polymorphic4 = sig
include Type.Polymorphic4
- module Make(T1:S)(T2:S)(T3:S)(T4:S)
+ module Make(T1:S)(T2:S)(T3:S)(T4:S)
: S with type t = (T1.t, T2.t, T3.t, T4.t) poly
end
@@ -478,45 +478,45 @@ end
@since Oxygen-20120901
@plugin development guide *)
module Polymorphic4
- (P: sig
- include Type.Polymorphic4_input
- val mk_equal:
- ('a -> 'a -> bool) -> ('b -> 'b -> bool) ->
- ('c -> 'c -> bool) -> ('d -> 'd -> bool) ->
- ('a, 'b, 'c, 'd) t -> ('a, 'b, 'c, 'd) t ->
- bool
- val mk_compare:
- ('a -> 'a -> int) -> ('b -> 'b -> int) ->
- ('c -> 'c -> int) -> ('d -> 'd -> int) ->
- ('a, 'b, 'c, 'd) t -> ('a, 'b, 'c, 'd) t -> int
- val mk_hash:
- ('a -> int) -> ('b -> int) -> ('c -> int) -> ('d -> int) ->
- ('a, 'b, 'c, 'd) t -> int
- val map:
- ('a -> 'a) -> ('b -> 'b) -> ('c -> 'c) -> ('d -> 'd) ->
- ('a, 'b, 'c, 'd) t -> ('a, 'b, 'c, 'd) t
- val mk_internal_pretty_code:
- (Type.precedence -> Format.formatter -> 'a -> unit) ->
- (Type.precedence -> Format.formatter -> 'b -> unit) ->
- (Type.precedence -> Format.formatter -> 'c -> unit) ->
- (Type.precedence -> Format.formatter -> 'd -> unit) ->
- Type.precedence -> Format.formatter -> ('a, 'b, 'c, 'd) t -> unit
- val mk_pretty:
- (Format.formatter -> 'a -> unit) ->
- (Format.formatter -> 'b -> unit) ->
- (Format.formatter -> 'c -> unit) ->
- (Format.formatter -> 'd -> unit) ->
- Format.formatter -> ('a, 'b, 'c, 'd) t -> unit
- val mk_varname:
- ('a -> string) -> ('b -> string) -> ('c -> string) -> ('d -> string) ->
- ('a, 'b, 'c, 'd) t -> string
- val mk_mem_project:
- ((Project_skeleton.t -> bool) -> 'a -> bool) ->
- ((Project_skeleton.t -> bool) -> 'b -> bool) ->
- ((Project_skeleton.t -> bool) -> 'c -> bool) ->
- ((Project_skeleton.t -> bool) -> 'd -> bool) ->
- (Project_skeleton.t -> bool) -> ('a, 'b, 'c, 'd) t -> bool
- end) :
+ (P: sig
+ include Type.Polymorphic4_input
+ val mk_equal:
+ ('a -> 'a -> bool) -> ('b -> 'b -> bool) ->
+ ('c -> 'c -> bool) -> ('d -> 'd -> bool) ->
+ ('a, 'b, 'c, 'd) t -> ('a, 'b, 'c, 'd) t ->
+ bool
+ val mk_compare:
+ ('a -> 'a -> int) -> ('b -> 'b -> int) ->
+ ('c -> 'c -> int) -> ('d -> 'd -> int) ->
+ ('a, 'b, 'c, 'd) t -> ('a, 'b, 'c, 'd) t -> int
+ val mk_hash:
+ ('a -> int) -> ('b -> int) -> ('c -> int) -> ('d -> int) ->
+ ('a, 'b, 'c, 'd) t -> int
+ val map:
+ ('a -> 'a) -> ('b -> 'b) -> ('c -> 'c) -> ('d -> 'd) ->
+ ('a, 'b, 'c, 'd) t -> ('a, 'b, 'c, 'd) t
+ val mk_internal_pretty_code:
+ (Type.precedence -> Format.formatter -> 'a -> unit) ->
+ (Type.precedence -> Format.formatter -> 'b -> unit) ->
+ (Type.precedence -> Format.formatter -> 'c -> unit) ->
+ (Type.precedence -> Format.formatter -> 'd -> unit) ->
+ Type.precedence -> Format.formatter -> ('a, 'b, 'c, 'd) t -> unit
+ val mk_pretty:
+ (Format.formatter -> 'a -> unit) ->
+ (Format.formatter -> 'b -> unit) ->
+ (Format.formatter -> 'c -> unit) ->
+ (Format.formatter -> 'd -> unit) ->
+ Format.formatter -> ('a, 'b, 'c, 'd) t -> unit
+ val mk_varname:
+ ('a -> string) -> ('b -> string) -> ('c -> string) -> ('d -> string) ->
+ ('a, 'b, 'c, 'd) t -> string
+ val mk_mem_project:
+ ((Project_skeleton.t -> bool) -> 'a -> bool) ->
+ ((Project_skeleton.t -> bool) -> 'b -> bool) ->
+ ((Project_skeleton.t -> bool) -> 'c -> bool) ->
+ ((Project_skeleton.t -> bool) -> 'd -> bool) ->
+ (Project_skeleton.t -> bool) -> ('a, 'b, 'c, 'd) t -> bool
+ end) :
Polymorphic4 with type ('a, 'b, 'c, 'd) poly = ('a, 'b, 'c, 'd) P.t
(* ****************************************************************************)
@@ -584,21 +584,21 @@ module Triple_with_collections(T1: S)(T2: S)(T3: S)(Info: Functor_info):
S_with_collections with type t = T1.t * T2.t * T3.t
(** @since Nitrogen-20111001 *)
-module Quadruple(T1: S)(T2: S)(T3: S)(T4:S):
+module Quadruple(T1: S)(T2: S)(T3: S)(T4:S):
S with type t = T1.t * T2.t * T3.t * T4.t
-val quadruple:
+val quadruple:
'a Type.t -> 'b Type.t -> 'c Type.t -> 'd Type.t -> ('a * 'b * 'c * 'd) Type.t
(** @since Fluorine-20130401 *)
(** @since Nitrogen-20111001 *)
module Quadruple_with_collections
- (T1: S)(T2: S)(T3: S)(T4:S)(Info: Functor_info):
+ (T1: S)(T2: S)(T3: S)(T4:S)(Info: Functor_info):
S_with_collections with type t = T1.t * T2.t * T3.t * T4.t
(** @plugin development guide *)
module Function
- (T1: sig include S val label: (string * (unit -> t) option) option end)
- (T2: S)
+ (T1: sig include S val label: (string * (unit -> t) option) option end)
+ (T2: S)
: S with type t = T1.t -> T2.t
val func:
@@ -609,8 +609,8 @@ val func:
val optlabel_func:
string -> (unit -> 'a) -> 'a Type.t -> 'b Type.t -> ('a -> 'b) Type.t
- (** [optlabel_func lab dft ty1 ty2] is equivalent to
- [func ~label:(lab, Some dft) ty1 ty2] *)
+(** [optlabel_func lab dft ty1 ty2] is equivalent to
+ [func ~label:(lab, Some dft) ty1 ty2] *)
val func2:
?label1:string * (unit -> 'a) option -> 'a Type.t ->
@@ -636,15 +636,15 @@ val func4:
('a -> 'b -> 'c -> 'd -> 'e) Type.t
module Set
- (S: Set.S)(E: S with type t = S.elt)(Info : Functor_info):
+ (S: Set.S)(E: S with type t = S.elt)(Info : Functor_info):
Set with type t = S.t and type elt = E.t
module Map
- (M: Map.S)(Key: S with type t = M.key)(Info: Functor_info) :
+ (M: Map.S)(Key: S with type t = M.key)(Info: Functor_info) :
Map with type 'a t = 'a M.t and type key = M.key and module Key = Key
module Hashtbl
- (H: Hashtbl_with_descr)(Key: S with type t = H.key)(Info : Functor_info):
+ (H: Hashtbl_with_descr)(Key: S with type t = H.key)(Info : Functor_info):
Hashtbl with type 'a t = 'a H.t and type key = H.key and module Key = Key
module type Sub_caml_weak_hashtbl = sig
diff --git a/src/libraries/datatype/descr.ml b/src/libraries/datatype/descr.ml
index c7195a3c07d5068b58df931808a8b46bdd316230..02c00a65f4d6a3cca04affe010f94c50bf740a46 100644
--- a/src/libraries/datatype/descr.ml
+++ b/src/libraries/datatype/descr.ml
@@ -63,8 +63,8 @@ let t_record x _ =
let x =
Array.map
(fun x -> match x with
- | Nopack | Recursive _ -> raise Invalid_descriptor
- | Pack x -> coerce x)
+ | Nopack | Recursive _ -> raise Invalid_descriptor
+ | Pack x -> coerce x)
x
in
unsafe_pack (Unmarshal.t_record x)
@@ -91,7 +91,7 @@ let t_queue = t_poly Unmarshal.t_queue
let of_type ty = pack (Type.structural_descr ty)
let of_structural ty d =
let ty_d = Type.structural_descr ty in
- if not (Type.may_use_obj ()) || Structural_descr.are_consistent ty_d d
+ if not (Type.may_use_obj ()) || Structural_descr.are_consistent ty_d d
then pack d
else invalid_arg "Descr.of_structural: inconsistent descriptor"
@@ -126,8 +126,8 @@ module Unmarshal_tbl =
type t = Unmarshal.t
let equal = (==)
let hash = Hashtbl.hash (* [JS 2012/07/10] what about recursive datatypes?
- Look like [hash] could loop... *)
- end)
+ Look like [hash] could loop... *)
+ end)
let visited = Unmarshal_tbl.create 7
@@ -136,10 +136,10 @@ let rec transform_unmarshal_structure term x = function
let l = ref [] in
Array.iter
(fun a ->
- Array.iteri
- (fun i y ->
- if x == y then l := (a, i) :: !l else transform_unmarshal term x y)
- a)
+ Array.iteri
+ (fun i y ->
+ if x == y then l := (a, i) :: !l else transform_unmarshal term x y)
+ a)
arr;
List.iter (fun (a, i) -> a.(i) <- term) !l
| Unmarshal.Dependent_pair(d, _) | Unmarshal.Array d ->
diff --git a/src/libraries/datatype/descr.mli b/src/libraries/datatype/descr.mli
index 53e712f149c0aef20260aa3ac3d973d3399bb0aa..2a61c7e58a136ea7ebb97ae7ac0ec75ea81328f0 100644
--- a/src/libraries/datatype/descr.mli
+++ b/src/libraries/datatype/descr.mli
@@ -122,8 +122,8 @@ val return: 'a t -> (unit -> 'a) -> 'a t
@raise Invalid_descriptor if the descriptor cannot be built. *)
val dynamic: (unit -> 'a t) -> 'a t
- (** Similar to {!Unmarshal.Dynamic}.
- @raise Invalid_descriptor if the descriptor cannot be built. *)
+(** Similar to {!Unmarshal.Dynamic}.
+ @raise Invalid_descriptor if the descriptor cannot be built. *)
(* ********************************************************************** *)
(** {2 Coercions} *)
diff --git a/src/libraries/datatype/structural_descr.ml b/src/libraries/datatype/structural_descr.ml
index 7e8c2f4e4ce58e2fc5ff4a0bb2131e3b919b0a52..e0d8acc14cd9338d3631d8dd0002f632ea043deb 100644
--- a/src/libraries/datatype/structural_descr.ml
+++ b/src/libraries/datatype/structural_descr.ml
@@ -48,7 +48,7 @@ module Recursive = struct
type t = recursive
let equal = (==)
let hash = Hashtbl.hash
- end)
+ end)
let positions = Tbl.create 7
let arrays = Tbl.create 7
@@ -152,10 +152,10 @@ let array_for_all f a =
with Exit ->
false
-let is_abstract_array a =
+let is_abstract_array a =
array_for_all (fun x -> x = Pack Unmarshal.Abstract) a
-let poly_arr f a =
+let poly_arr f a =
if is_abstract_array a then Abstract
else
try
@@ -184,8 +184,8 @@ let poly2 f a b = match a, b with
let t_map_unchanged_compares = poly2 Unmarshal.t_map_unchangedcompares
let t_hashtbl_unchanged_hashs = poly2 (Unmarshal.t_hashtbl_unchangedhashs)
-let t_sum a =
- if array_for_all (is_abstract_array) a then Abstract
+let t_sum a =
+ if array_for_all (is_abstract_array) a then Abstract
else Structure (Sum a)
(* ********************************************************************** *)
@@ -202,7 +202,7 @@ module Unmarshal_tbl =
type t = Unmarshal.t
let equal = (==)
let hash = Hashtbl.hash
- end)
+ end)
let unmarshal_visited = Unmarshal_tbl.create 7
@@ -213,7 +213,7 @@ module Tbl =
type t = u
let equal = (==)
let hash = Hashtbl.hash
- end)
+ end)
let visited = Tbl.create 7
@@ -310,15 +310,15 @@ and are_consistent_unmarshal d1 d2 = match d1, d2 with
d2 == d2'
with Not_found ->
(* Keep already visited terms in order to prevent looping when visiting
- recursive terms. However, remove them from the table after visiting in
- order to not pollute it when visiting cousins: fixed bts #1277.
- Would be better to use a persistent table instead of a mutable one,
- but not possible to provide a (terminating) comparison. *)
+ recursive terms. However, remove them from the table after visiting in
+ order to not pollute it when visiting cousins: fixed bts #1277.
+ Would be better to use a persistent table instead of a mutable one,
+ but not possible to provide a (terminating) comparison. *)
Unmarshal_tbl.add unmarshal_consistent_visited d1 d2;
let b = are_consistent_unmarshal_structures s1 s2 in
Unmarshal_tbl.remove unmarshal_consistent_visited d1;
b)
- | Unmarshal.Abstract, Unmarshal.Structure _ ->
+ | Unmarshal.Abstract, Unmarshal.Structure _ ->
true (* we provide a more precise version: accept it *)
| _, _ ->
false
@@ -355,14 +355,14 @@ and are_consistent_aux d1 d2 = match d1, d2 with
Tbl.add consistent_visited d1 d2;
are_consistent_structures s1 s2)
| d, T_pack s | T_pack s, d -> are_consistent_unmarshal (to_unmarshal d) s
- | Abstract, Structure _ ->
+ | Abstract, Structure _ ->
true (* we provide a more precise version: accept it *)
| Structure _, Abstract -> false
| _, _ -> false
let are_consistent d1 d2 =
assert (Unmarshal_tbl.length unmarshal_consistent_visited = 0
- && Tbl.length consistent_visited = 0);
+ && Tbl.length consistent_visited = 0);
let b = are_consistent_aux d1 d2 in
Unmarshal_tbl.clear unmarshal_consistent_visited;
Tbl.clear consistent_visited;
diff --git a/src/libraries/datatype/structural_descr.mli b/src/libraries/datatype/structural_descr.mli
index a68e964c68b059c43f1f36ff2f1c3b2f72ef7cb7..e1cdcd25990eec333178a07fe3209fbaef6190c4 100644
--- a/src/libraries/datatype/structural_descr.mli
+++ b/src/libraries/datatype/structural_descr.mli
@@ -59,7 +59,7 @@ type t = private
will be applied on any part of such a data. *)
| Structure of structure
- (** Provide a description of the representation of data.
+ (** Provide a description of the representation of data.
@plugin development guide *)
| T_pack of single_pack (** Internal use only.
@@ -72,7 +72,7 @@ and structure = private
the non-constant constructors of the type being described (in the order
of their declarations in that type). Each element of this latter array
is an array of [t] that describes (in order) the fields of the
- corresponding constructor.
+ corresponding constructor.
@plugin development guide *)
| Array of pack (** The data is an array of values of the same type, each
@@ -83,7 +83,7 @@ and structure = private
(* ********************************************************************** *)
val pack: t -> pack
-(** Pack a structural descriptor in order to embed it inside another one.
+(** Pack a structural descriptor in order to embed it inside another one.
@plugin development guide *)
val recursive_pack: recursive -> pack
diff --git a/src/libraries/datatype/type.ml b/src/libraries/datatype/type.ml
index 54a9a0fb6156e6d628c22970b63bc4b344deff63..de8d26a9cc36d6140b8138c9ea20775dfc17745f 100644
--- a/src/libraries/datatype/type.ml
+++ b/src/libraries/datatype/type.ml
@@ -62,11 +62,11 @@ let par p_caller p_callee fmt pp =
else Format.fprintf fmt "%t" pp
type concrete_repr =
- { mutable name: string;
- digest: Digest.t;
- structural_descr: Structural_descr.t;
- mutable abstract: bool;
- mutable pp_ml_name: precedence -> Format.formatter -> unit }
+ { mutable name: string;
+ digest: Digest.t;
+ structural_descr: Structural_descr.t;
+ mutable abstract: bool;
+ mutable pp_ml_name: precedence -> Format.formatter -> unit }
(* phantom type *)
type 'a t = concrete_repr
@@ -108,16 +108,16 @@ let dummy =
let mk_dyn_pp name = function
| None ->
- let pp fmt =
+ let pp fmt =
let plugin_name = match Str.split (Str.regexp_string ".") name with
- | [] -> None
- | p :: _ -> Some p
+ | [] -> None
+ | p :: _ -> Some p
in
match plugin_name with
- | None ->
- Format.fprintf fmt "(failwith \"%s is not a printable type name\")" name
+ | None ->
+ Format.fprintf fmt "(failwith \"%s is not a printable type name\")" name
| Some p ->
- Format.fprintf fmt "%s.ty" p
+ Format.fprintf fmt "%s.ty" p
in
(fun p fmt -> par p Basic fmt pp)
| Some s ->
@@ -157,7 +157,7 @@ let register ?(closure=false) ~name ~ml_name structural_descr reprs =
{ name = name;
digest = digest;
structural_descr = structural_descr;
- abstract = false;
+ abstract = false;
pp_ml_name = pp_ml_name }
in
let full_ty = { ty = ty; reprs = List.map Obj.repr reprs } in
@@ -171,15 +171,15 @@ exception No_abstract_type of string
module Abstract(T: sig val name: string end) = struct
type t
let ty =
- if !use_obj then
+ if !use_obj then
try (Hashtbl.find types T.name).ty
with Not_found -> raise (No_abstract_type T.name)
else failwith "Cannot call `Type.Abstract' in `no obj' mode"
let () =
let p = match Str.split (Str.regexp_string ".") T.name with
- | [] ->
- failwith "name as argument of `Type.Abstract' must be a valid OCaml \
-type name"
+ | [] ->
+ failwith "name as argument of `Type.Abstract' must be a valid OCaml \
+ type name"
| p :: _ -> p
in
!add_abstract_types p T.name
@@ -253,7 +253,7 @@ module Polymorphic(T: Polymorphic_input) = struct
type 'a poly = 'a T.t
- let ml_name from_ty =
+ let ml_name from_ty =
Format.asprintf "%s.instantiate %t"
T.module_name
(from_ty.pp_ml_name Call)
@@ -309,7 +309,7 @@ module Concrete_pair =
type t = concrete_repr * concrete_repr
let hash (x,y) = Hashtbl.hash (hash x, hash y)
let equal (x1,y1) (x2,y2) = equal x1 x2 && equal y1 y2
- end)
+ end)
module Polymorphic2(T: Polymorphic2_input) = struct
@@ -350,8 +350,8 @@ module Polymorphic2(T: Polymorphic2_input) = struct
in
Concrete_pair.add memo_tbl key ty;
Tbl.add instances ty key;
- Tbl.add embedded_types ty a;
- Tbl.add embedded_types ty b;
+ Tbl.add embedded_types ty a;
+ Tbl.add embedded_types ty b;
ty, true
else
dummy, false
@@ -380,7 +380,7 @@ module Function = struct
type ('a, 'b) poly = 'a -> 'b
type instance =
- { arg: concrete_repr; ret: concrete_repr; label: string option }
+ { arg: concrete_repr; ret: concrete_repr; label: string option }
module Memo =
Hashtbl.Make
@@ -388,13 +388,13 @@ module Function = struct
type t = instance
let hash x = Hashtbl.hash (hash x.arg, hash x.ret, x.label)
let equal x y =
- equal x.arg y.arg && equal x.ret y.ret && x.label = y.label
- end)
+ equal x.arg y.arg && equal x.ret y.ret && x.label = y.label
+ end)
let memo_tbl : concrete_repr Memo.t = Memo.create 17
let instances
- : (instance * Obj.t (* default value of the optional label *) option)
- Tbl.t
- = Tbl.create 17
+ : (instance * Obj.t (* default value of the optional label *) option)
+ Tbl.t
+ = Tbl.create 17
let is_instance_of ty = Tbl.mem instances ty
@@ -453,8 +453,8 @@ module Function = struct
in
Memo.add memo_tbl key ty;
Tbl.add instances ty (key, o);
- Tbl.add embedded_types ty a;
- Tbl.add embedded_types ty b;
+ Tbl.add embedded_types ty a;
+ Tbl.add embedded_types ty b;
ty, true
else
dummy, false
@@ -487,9 +487,9 @@ module Concrete_triple =
(struct
type t = concrete_repr * concrete_repr * concrete_repr
let hash (x,y,z) = Hashtbl.hash (hash x, hash y, hash z)
- let equal (x1,y1,z1) (x2,y2,z2) =
- equal x1 x2 && equal y1 y2 && equal z1 z2
- end)
+ let equal (x1,y1,z1) (x2,y2,z2) =
+ equal x1 x2 && equal y1 y2 && equal z1 z2
+ end)
module Polymorphic3(T:Polymorphic3_input) = struct
@@ -497,8 +497,8 @@ module Polymorphic3(T:Polymorphic3_input) = struct
let memo_tbl: concrete_repr Concrete_triple.t = Concrete_triple.create 17
let instances
- : (concrete_repr * concrete_repr * concrete_repr) Tbl.t
- = Tbl.create 17
+ : (concrete_repr * concrete_repr * concrete_repr) Tbl.t
+ = Tbl.create 17
let ml_name from_ty1 from_ty2 from_ty3 =
Format.asprintf
@@ -518,11 +518,11 @@ module Polymorphic3(T:Polymorphic3_input) = struct
List.fold_left
(fun acc r1 ->
List.fold_left
- (fun acc r2 ->
- List.fold_left
- (fun acc r3 -> T.reprs r1 r2 r3 @ acc)
- acc
- (unsafe_reprs c))
+ (fun acc r2 ->
+ List.fold_left
+ (fun acc r3 -> T.reprs r1 r2 r3 @ acc)
+ acc
+ (unsafe_reprs c))
acc
(unsafe_reprs b))
[]
@@ -532,17 +532,17 @@ module Polymorphic3(T:Polymorphic3_input) = struct
register
~name:(T.name a b c)
~ml_name:(Some (ml_name a b c))
- (T.structural_descr
- a.structural_descr
- b.structural_descr
- c.structural_descr)
+ (T.structural_descr
+ a.structural_descr
+ b.structural_descr
+ c.structural_descr)
reprs
in
Concrete_triple.add memo_tbl key ty;
Tbl.add instances ty key;
- Tbl.add embedded_types ty a;
- Tbl.add embedded_types ty b;
- Tbl.add embedded_types ty c;
+ Tbl.add embedded_types ty a;
+ Tbl.add embedded_types ty b;
+ Tbl.add embedded_types ty c;
ty, true
else
dummy, false
@@ -574,7 +574,7 @@ end
module type Polymorphic4 = sig
type ('a, 'b, 'c, 'd) poly
- val instantiate:
+ val instantiate:
'a t -> 'b t -> 'c t -> 'd t -> ('a, 'b, 'c, 'd) poly t * bool
val is_instance_of: 'a t -> bool
val get_instance: ('a, 'b, 'c, 'd) poly t -> 'a t * 'b t * 'c t * 'd t
@@ -585,21 +585,21 @@ module Concrete_quadruple =
(struct
type t = concrete_repr * concrete_repr * concrete_repr * concrete_repr
let hash (x,y,z,t) = Hashtbl.hash (hash x, hash y, hash z, hash t)
- let equal (x1,y1,z1,t1) (x2,y2,z2,t2) =
- equal x1 x2 && equal y1 y2 && equal z1 z2 && equal t1 t2
- end)
+ let equal (x1,y1,z1,t1) (x2,y2,z2,t2) =
+ equal x1 x2 && equal y1 y2 && equal z1 z2 && equal t1 t2
+ end)
module Polymorphic4(T:Polymorphic4_input) = struct
type ('a, 'b, 'c, 'd) poly = ('a, 'b, 'c, 'd) T.t
let memo_tbl
- : concrete_repr Concrete_quadruple.t
- = Concrete_quadruple.create 17
+ : concrete_repr Concrete_quadruple.t
+ = Concrete_quadruple.create 17
let instances
- : (concrete_repr * concrete_repr * concrete_repr * concrete_repr) Tbl.t
- = Tbl.create 17
+ : (concrete_repr * concrete_repr * concrete_repr * concrete_repr) Tbl.t
+ = Tbl.create 17
let ml_name from_ty1 from_ty2 from_ty3 from_ty4 =
Format.asprintf
@@ -620,15 +620,15 @@ module Polymorphic4(T:Polymorphic4_input) = struct
List.fold_left
(fun acc r1 ->
List.fold_left
- (fun acc r2 ->
- List.fold_left
- (fun acc r3 ->
- List.fold_left
- (fun acc r4 -> T.reprs r1 r2 r3 r4 @ acc)
- acc
- (unsafe_reprs d))
- acc
- (unsafe_reprs c))
+ (fun acc r2 ->
+ List.fold_left
+ (fun acc r3 ->
+ List.fold_left
+ (fun acc r4 -> T.reprs r1 r2 r3 r4 @ acc)
+ acc
+ (unsafe_reprs d))
+ acc
+ (unsafe_reprs c))
acc
(unsafe_reprs b))
[]
@@ -638,19 +638,19 @@ module Polymorphic4(T:Polymorphic4_input) = struct
register
~name:(T.name a b c d)
~ml_name:(Some (ml_name a b c d))
- (T.structural_descr
- a.structural_descr
- b.structural_descr
- c.structural_descr
- d.structural_descr)
+ (T.structural_descr
+ a.structural_descr
+ b.structural_descr
+ c.structural_descr
+ d.structural_descr)
reprs
in
Concrete_quadruple.add memo_tbl key ty;
Tbl.add instances ty key;
- Tbl.add embedded_types ty a;
- Tbl.add embedded_types ty b;
- Tbl.add embedded_types ty c;
- Tbl.add embedded_types ty d;
+ Tbl.add embedded_types ty a;
+ Tbl.add embedded_types ty b;
+ Tbl.add embedded_types ty c;
+ Tbl.add embedded_types ty d;
ty, true
else
dummy, false
@@ -698,17 +698,17 @@ end = struct
if tag = 0 then
0
else if tag = Obj.closure_tag then
- (* Buggy code with OCaml 4.01, deactivated for now
- (* assumes that the first word of a closure does not change in
+ (* Buggy code with OCaml 4.01, deactivated for now
+ (* assumes that the first word of a closure does not change in
any way (even by Gc.compact invocation). *)
Obj.magic (Obj.field x 0)*)
- (* to be tested (suggested by Damien D.): add a 'xor 0' *)
-(* Obj.magic (Obj.field x 0)*)
+ (* to be tested (suggested by Damien D.): add a 'xor 0' *)
+ (* Obj.magic (Obj.field x 0)*)
0
else
Hashtbl.hash x
- else
- 0
+ else
+ 0
end)
type 'a t = 'a O.t Tbl.t
@@ -738,7 +738,7 @@ end = struct
with Not_found ->
false
- let iter tbl f =
+ let iter tbl f =
Tbl.iter (fun ty objs -> O.iter (fun o v -> f ty (Obj.obj o) v) objs) tbl
end
@@ -757,8 +757,8 @@ module type Heterogeneous_table = sig
end
module Make_tbl
- (Key: sig include Hashtbl.HashedType val to_string: t -> string end)
- (Info: sig type 'a t end) =
+ (Key: sig include Hashtbl.HashedType val to_string: t -> string end)
+ (Info: sig type 'a t end) =
struct
type key = Key.t
@@ -788,12 +788,12 @@ struct
let find tbl s ty =
if !use_obj then
let name = Key.to_string s in
- let data =
- try H.find tbl s with Not_found -> raise (Unbound_value name)
- in
- if ty.digest <> data.ty.digest then
- type_error name ty.name data.ty.name;
- Obj.obj data.o
+ let data =
+ try H.find tbl s with Not_found -> raise (Unbound_value name)
+ in
+ if ty.digest <> data.ty.digest then
+ type_error name ty.name data.ty.name;
+ Obj.obj data.o
else
invalid_arg "cannot call function 'find' in the 'no obj' mode"
@@ -810,11 +810,11 @@ end
module String_tbl =
Make_tbl
(struct
- type t = string
- let hash x = Hashtbl.hash x
- let equal : string -> string -> bool = (=)
- let to_string x = x
- end)
+ type t = string
+ let hash x = Hashtbl.hash x
+ let equal : string -> string -> bool = (=)
+ let to_string x = x
+ end)
(*
Local Variables:
diff --git a/src/libraries/datatype/type.mli b/src/libraries/datatype/type.mli
index 6f4c91a277be069eab9c66423a7925076683c067..49c54c44db99f63312e765b508e31d9f5ec8c35f 100644
--- a/src/libraries/datatype/type.mli
+++ b/src/libraries/datatype/type.mli
@@ -77,7 +77,7 @@ val par_ty_name: ('a t -> bool) -> 'a t -> string
(* ****************************************************************************)
exception AlreadyExists of string
-(** May be raised by {!register}.
+(** May be raised by {!register}.
@plugin development guide *)
val register:
@@ -105,7 +105,7 @@ exception No_abstract_type of string
(** Apply this functor to access to the abstract type of the given name.
@raise No_abstract_type if no such abstract type was registered.
- @since Nitrogen-20111001
+ @since Nitrogen-20111001
@plugin development guide *)
module Abstract(T: sig val name: string end): sig
type t
@@ -125,7 +125,7 @@ val get_embedded_type_names: 'a t -> string list
(** Get the list of names containing in the type represented by the given type
value. For instance [get_embedded_type_names (Datatype.func Datatype.unit
(Datatype.list Datatype.int))] returns [ "unit -> int list"; "unit"; "int
- list"; "int" ].
+ list"; "int" ].
@since Oxygen-20120901 *)
val ml_name: 'a t -> string
@@ -167,8 +167,8 @@ module type Polymorphic_input = sig
register. *)
val reprs: 'a -> 'a t list
-(** How to make the representant of each monomorphic instance of the
- polymorphic type value from an underlying representant. *)
+ (** How to make the representant of each monomorphic instance of the
+ polymorphic type value from an underlying representant. *)
end
@@ -181,19 +181,19 @@ module type Polymorphic = sig
instantiated before used. See function [instantiate] below. *)
val instantiate: 'a t -> 'a poly t * bool
- (** @return the monomorphic instantiation of the polymorph type with the
- given type value. For instance, if ['a poly = 'a list], then
- [instantiate int] returns the type value [int list]. *)
+ (** @return the monomorphic instantiation of the polymorph type with the
+ given type value. For instance, if ['a poly = 'a list], then
+ [instantiate int] returns the type value [int list]. *)
val is_instance_of: 'a t -> bool
- (** @return [true] iff the given type value has been created from
- function [instantiate] above.
- For instance, [is_instance_of (instantiate int)] always returns [true]
- but [is_instance_of int] always returns [false]. *)
+ (** @return [true] iff the given type value has been created from
+ function [instantiate] above.
+ For instance, [is_instance_of (instantiate int)] always returns [true]
+ but [is_instance_of int] always returns [false]. *)
val get_instance: 'a poly t -> 'a t
- (** [get_instance ty] returns the type value used to create the given
- monomorphic instantiation. *)
+ (** [get_instance ty] returns the type value used to create the given
+ monomorphic instantiation. *)
end
@@ -231,17 +231,17 @@ module Function : sig
type ('a, 'b) poly = 'a -> 'b
val instantiate:
?label:(string * (unit -> 'a) option) -> 'a t -> 'b t -> ('a -> 'b) t * bool
- (** Possibility to add a label for the parameter.
- - [~label:(p,None)] for a mandatory labeled parameter [p];
- - [~label:(p,Some f)] for an optional labeled parameter [p],
- with default value [f ()]. *)
+ (** Possibility to add a label for the parameter.
+ - [~label:(p,None)] for a mandatory labeled parameter [p];
+ - [~label:(p,Some f)] for an optional labeled parameter [p],
+ with default value [f ()]. *)
val is_instance_of: 'a t -> bool
val get_instance: ('a -> 'b) t -> 'a t * 'b t * string option
val get_optional_argument: ('a -> 'b) t -> (unit -> 'a) option
end
(** See module {!Polymorphic_input}: very same functions with two additional
- arguments corresponding to the second and third type variables.
+ arguments corresponding to the second and third type variables.
@since Oxygen-20120901 *)
module type Polymorphic3_input = sig
val name: 'a t -> 'b t -> 'c t -> string
@@ -253,7 +253,7 @@ module type Polymorphic3_input = sig
val reprs: 'a -> 'b -> 'c -> ('a, 'b, 'c) t list
end
-(** Same as {!Polymorphic} for polymorphic types with three type variables.
+(** Same as {!Polymorphic} for polymorphic types with three type variables.
@since Oxygen-20120901 *)
module type Polymorphic3 = sig
type ('a, 'b, 'c) poly
@@ -263,13 +263,13 @@ module type Polymorphic3 = sig
end
(** Generic implementation of polymorphic type value with three type
- variables.
+ variables.
@since Oxygen-20120901 *)
module Polymorphic3(T:Polymorphic3_input)
: Polymorphic3 with type ('a, 'b, 'c) poly = ('a, 'b, 'c) T.t
(** See module {!Polymorphic_input}: very same functions with three additional
- arguments corresponding to the additional type variables.
+ arguments corresponding to the additional type variables.
@since Oxygen-20120901 *)
module type Polymorphic4_input = sig
val name: 'a t -> 'b t -> 'c t -> 'd t -> string
@@ -281,18 +281,18 @@ module type Polymorphic4_input = sig
val reprs: 'a -> 'b -> 'c -> 'd -> ('a, 'b, 'c, 'd) t list
end
-(** Same as {!Polymorphic} for polymorphic types with four type variables.
+(** Same as {!Polymorphic} for polymorphic types with four type variables.
@since Oxygen-20120901 *)
module type Polymorphic4 = sig
type ('a, 'b, 'c, 'd) poly
- val instantiate:
+ val instantiate:
'a t -> 'b t -> 'c t -> 'd t -> ('a, 'b, 'c, 'd) poly t * bool
val is_instance_of: 'a t -> bool
val get_instance: ('a, 'b, 'c, 'd) poly t -> 'a t * 'b t * 'c t * 'd t
end
(** Generic implementation of polymorphic type value with four type
- variables.
+ variables.
@since Oxygen-20120901 *)
module Polymorphic4(T:Polymorphic4_input)
: Polymorphic4 with type ('a, 'b, 'c, 'd) poly = ('a, 'b, 'c, 'd) T.t
@@ -307,38 +307,38 @@ module Polymorphic4(T:Polymorphic4_input)
module type Heterogeneous_table = sig
type key
- (** @since Carbon-20101201 *)
+ (** @since Carbon-20101201 *)
type 'a info
type t
- (** Type of heterogeneous (hash)tables indexed by values of type Key.t.
- Type values ensure type safety. *)
+ (** Type of heterogeneous (hash)tables indexed by values of type Key.t.
+ Type values ensure type safety. *)
val create: int -> t
- (** [create n] creates a new table of initial size [n]. *)
+ (** [create n] creates a new table of initial size [n]. *)
val add: t -> key -> 'a ty -> 'a info -> unit
- (** [add tbl s ty v] binds [s] to the value [v] in the table [tbl].
- If the returned value is a closure whose the type of one of its
- argument was dynamically registered, then it may raise
- [Incompatible_Type].
- @raise AlreadyExists if [s] is already bound in [tbl].
- @modify Nitrogen-20111001 returns [unit] now. *)
+ (** [add tbl s ty v] binds [s] to the value [v] in the table [tbl].
+ If the returned value is a closure whose the type of one of its
+ argument was dynamically registered, then it may raise
+ [Incompatible_Type].
+ @raise AlreadyExists if [s] is already bound in [tbl].
+ @modify Nitrogen-20111001 returns [unit] now. *)
exception Unbound_value of string
exception Incompatible_type of string
val find: t -> key -> 'a ty -> 'a info
- (** [find tbl s ty] returns the binding of [s] in the table [tbl].
- @raise Unbound_value if [s] is not bound in [tbl].
- @raise Incompatible_Type if [ty] was not the type value used to add
- the binding of [s] in [tbl]. *)
+ (** [find tbl s ty] returns the binding of [s] in the table [tbl].
+ @raise Unbound_value if [s] is not bound in [tbl].
+ @raise Incompatible_Type if [ty] was not the type value used to add
+ the binding of [s] in [tbl]. *)
val iter: (key -> 'a ty -> 'a info -> unit) -> t -> unit
-(** @since Oxygen-20120901 *)
+ (** @since Oxygen-20120901 *)
val fold: (key -> 'a ty -> 'a info -> 'b -> 'b) -> t -> 'b -> 'b
-(** @since Fluorine-20130401 *)
+ (** @since Fluorine-20130401 *)
end
@@ -346,8 +346,8 @@ end
Not efficient for types registered without ml name.
@since Carbon-20101201 *)
module Make_tbl
- (Key: sig include Hashtbl.HashedType val to_string: t -> string end)
- (Info: sig type 'a t end) :
+ (Key: sig include Hashtbl.HashedType val to_string: t -> string end)
+ (Info: sig type 'a t end) :
Heterogeneous_table with type key = Key.t and type 'a info = 'a Info.t
(** Heterogeneous tables indexed by string. *)
@@ -379,8 +379,8 @@ end
(* ****************************************************************************)
val no_obj: unit -> unit
- (** Deactivate all the black magic.
- Roughly, in this mode, nothing is done by this module. *)
+(** Deactivate all the black magic.
+ Roughly, in this mode, nothing is done by this module. *)
val may_use_obj: unit -> bool
(** Internal use only. Please, do not use it yourself. *)
diff --git a/src/libraries/datatype/unmarshal.ml b/src/libraries/datatype/unmarshal.ml
index 314dadf1be0bc74b5a431dddd1ef5192f0376eb6..ea1925800faab220e8bfc34fb2c2788702a5dde2 100644
--- a/src/libraries/datatype/unmarshal.ml
+++ b/src/libraries/datatype/unmarshal.ml
@@ -82,7 +82,7 @@ let getword ch =
let c1 = Char.code (input_char ch) in
let c0 = Char.code (input_char ch) in
Int32.logor (Int32.shift_left (Int32.of_int c3) 24)
- (Int32.of_int ((c2 lsl 16) lor (c1 lsl 8) lor c0))
+ (Int32.of_int ((c2 lsl 16) lor (c1 lsl 8) lor c0))
;;
let read8s ch =
@@ -193,11 +193,11 @@ let readfloat_little =
| '1' -> readfloat_same
| '6' -> readfloat_reverse
| '5' ->
- begin
- fun ch v i ->
- readblock ch v (i * 8 + 4) 4;
- readblock ch v (i * 8) 4;
- end
+ begin
+ fun ch v i ->
+ readblock ch v (i * 8 + 4) 4;
+ readblock ch v (i * 8) 4;
+ end
| _ -> fun _ch _v _i -> failwith "input_value: non-standard floats"
;;
@@ -206,31 +206,31 @@ let readfloat_big =
| '1' -> readfloat_reverse
| '6' -> readfloat_same
| '5' ->
- begin
- fun ch v i ->
- readblock_rev ch v (i * 8) 4;
- readblock_rev ch v (i * 8 + 4) 4;
- end
+ begin
+ fun ch v i ->
+ readblock_rev ch v (i * 8) 4;
+ readblock_rev ch v (i * 8 + 4) 4;
+ end
| _ -> fun _ch _v _i -> failwith "input_value: non-standard floats"
;;
(* Auxiliary functions for handling closures. *)
(* Not used by Frama-C, causing problems with ARM, see:
-http://lists.gforge.inria.fr/pipermail/frama-c-discuss/2013-August/003702.html
-let (code_area_start, cksum) =
- let s = Marshal.to_string id [Marshal.Closures] in
- let cksum = String.sub s 0x1E 16 in
- let c0 = Char.code s.[0x1D] in
- let c1 = Char.code s.[0x1C] in
- let c2 = Char.code s.[0x1B] in
- let c3 = Char.code s.[0x1A] in
- let ofs = Int32.logor (Int32.shift_left (Int32.of_int c3) 24)
+ http://lists.gforge.inria.fr/pipermail/frama-c-discuss/2013-August/003702.html
+ let (code_area_start, cksum) =
+ let s = Marshal.to_string id [Marshal.Closures] in
+ let cksum = String.sub s 0x1E 16 in
+ let c0 = Char.code s.[0x1D] in
+ let c1 = Char.code s.[0x1C] in
+ let c2 = Char.code s.[0x1B] in
+ let c3 = Char.code s.[0x1A] in
+ let ofs = Int32.logor (Int32.shift_left (Int32.of_int c3) 24)
(Int32.of_int ((c2 lsl 16) lor (c1 lsl 8) lor c0))
- in
- let start = Obj.add_offset (Obj.field (Obj.repr id) 0) (Int32.neg ofs) in
- (start, cksum)
-;;
+ in
+ let start = Obj.add_offset (Obj.field (Obj.repr id) 0) (Int32.neg ofs) in
+ (start, cksum)
+ ;;
*)
let check_const ch s =
@@ -351,7 +351,7 @@ let rec get_structure t context =
;;
(* let intext_magic_number_small = "\x84\x95\xA6\xBE";;
-let intext_magic_number_big = "\x84\x95\xA6\xBF";;
+ let intext_magic_number_big = "\x84\x95\xA6\xBF";;
*)
let input_val ch t =
@@ -391,93 +391,93 @@ let input_val ch t =
match code with
| 0x00 (* CODE_INT8 *) ->
- let v = Obj.repr (read8s ch) in
- return stk (do_transform t v)
+ let v = Obj.repr (read8s ch) in
+ return stk (do_transform t v)
| 0x01 (* CODE_INT16 *) ->
- let v = Obj.repr (read16s ch) in
- return stk (do_transform t v)
+ let v = Obj.repr (read16s ch) in
+ return stk (do_transform t v)
| 0x02 (* CODE_INT32 *) ->
- let v = Obj.repr (read32s ch) in
- return stk (do_transform t v)
+ let v = Obj.repr (read32s ch) in
+ return stk (do_transform t v)
| 0x03 (* CODE_INT64 *) ->
- if arch_sixtyfour then begin
- let v = Obj.repr (read64s ch) in
- return stk (do_transform t v)
- end else begin
- failwith "input_value: integer too large"
- end
+ if arch_sixtyfour then begin
+ let v = Obj.repr (read64s ch) in
+ return stk (do_transform t v)
+ end else begin
+ failwith "input_value: integer too large"
+ end
| 0x04 (* CODE_SHARED8 *) ->
- let ofs = read8u ch in
- read_shared stk ofs
+ let ofs = read8u ch in
+ read_shared stk ofs
| 0x05 (* CODE_SHARED16 *) ->
- let ofs = read16u ch in
- read_shared stk ofs
+ let ofs = read16u ch in
+ read_shared stk ofs
| 0x06 (* CODE_SHARED32 *) ->
- let ofs = read32u ch in
- read_shared stk ofs
+ let ofs = read32u ch in
+ read_shared stk ofs
| 0x14 (* CODE_SHARED64 *) ->
- let ofs = read64u ch in
- read_shared stk ofs
+ let ofs = read64u ch in
+ read_shared stk ofs
| 0x08 (* CODE_BLOCK32 *) ->
- let (tag, size) = readheader32 ch in
- read_block stk t tag size
+ let (tag, size) = readheader32 ch in
+ read_block stk t tag size
| 0x13 (* CODE_BLOCK64 *) ->
- let (tag, size) = readheader64 ch in
- read_block stk t tag size
+ let (tag, size) = readheader64 ch in
+ read_block stk t tag size
| 0x09 (* CODE_STRING8 *) ->
- let len = read8u ch in
- read_string stk t len
+ let len = read8u ch in
+ read_string stk t len
| 0x0A (* CODE_STRING32 *) ->
- let len = read32u ch in
- read_string stk t len
+ let len = read32u ch in
+ read_string stk t len
| 0x15 (* CODE_STRING64 *) ->
- let len = read64u ch in
- read_string stk t len
+ let len = read64u ch in
+ read_string stk t len
| 0x0C (* CODE_DOUBLE_LITTLE *) ->
- read_double stk t readfloat_little
+ read_double stk t readfloat_little
| 0x0B (* CODE_DOUBLE_BIG *) ->
- read_double stk t readfloat_big
+ read_double stk t readfloat_big
| 0x0E (* CODE_DOUBLE_ARRAY8_LITTLE *) ->
- let len = read8u ch in
- read_double_array stk t len readfloat_little
+ let len = read8u ch in
+ read_double_array stk t len readfloat_little
| 0x0D (* CODE_DOUBLE_ARRAY8_BIG *) ->
- let len = read8u ch in
- read_double_array stk t len readfloat_big
+ let len = read8u ch in
+ read_double_array stk t len readfloat_big
| 0x07 (* CODE_DOUBLE_ARRAY32_LITTLE *) ->
- let len = read32u ch in
- read_double_array stk t len readfloat_little
+ let len = read32u ch in
+ read_double_array stk t len readfloat_little
| 0x0F (* CODE_DOUBLE_ARRAY32_BIG *) ->
- let len = read32u ch in
- read_double_array stk t len readfloat_big
+ let len = read32u ch in
+ read_double_array stk t len readfloat_big
| 0x17 (* CODE_DOUBLE_ARRAY64_LITTLE *) ->
- let len = read64u ch in
- read_double_array stk t len readfloat_little
+ let len = read64u ch in
+ read_double_array stk t len readfloat_little
| 0x16 (* CODE_DOUBLE_ARRAY64_BIG *) ->
- let len = read64u ch in
- read_double_array stk t len readfloat_big
+ let len = read64u ch in
+ read_double_array stk t len readfloat_big
| 0x10 (* CODE_CODEPOINTER *) ->
- assert false
-(* NOT USED BY Frama-C
- let ofs = getword ch in
- check_const ch cksum "input_value: code mismatch";
- let offset_pointer = Obj.add_offset code_area_start ofs in
- return stk (do_transform t offset_pointer) *)
+ assert false
+ (* NOT USED BY Frama-C
+ let ofs = getword ch in
+ check_const ch cksum "input_value: code mismatch";
+ let offset_pointer = Obj.add_offset code_area_start ofs in
+ return stk (do_transform t offset_pointer) *)
| 0x11 (* CODE_INFIXPOINTER *) ->
- let ofs = getword ch in
- let clos = intern_rec [] t in
- return stk (Obj.add_offset (Obj.repr clos) ofs)
+ let ofs = getword ch in
+ let clos = intern_rec [] t in
+ return stk (Obj.add_offset (Obj.repr clos) ofs)
| 0x12 | 0x19 (* CODE_CUSTOM (deprecated) or CODE_CUSTOM_FIXED *) ->
- let id = read_customident ch in
- let v = read_custom ch id in
- let dest = !ctr in
- ctr := dest + 1;
- return_block stk t v dest
+ let id = read_customident ch in
+ let v = read_custom ch id in
+ let dest = !ctr in
+ ctr := dest + 1;
+ return_block stk t v dest
| 0x18 (* CODE_CUSTOM_LEN *) ->
let id = read_customident ch in
@@ -492,48 +492,48 @@ let input_val ch t =
return_block stk t v dest
| _ when code >= 0x80 (* PREFIX_SMALL_BLOCK *) ->
- let tag = code land 0xF in
- let size = (code lsr 4) land 0x7 in
- read_block stk t tag size
+ let tag = code land 0xF in
+ let size = (code lsr 4) land 0x7 in
+ read_block stk t tag size
| _ when code >= 0x40 (* PREFIX_SMALL_INT *) ->
- let v = Obj.repr (code land 0x3F) in
- return stk (do_transform t v)
+ let v = Obj.repr (code land 0x3F) in
+ return stk (do_transform t v)
| _ when code >= 0x20 (* PREFIX_SMALL_STRING *) ->
- let len = code land 0x1F in
- read_string stk t len
+ let len = code land 0x1F in
+ read_string stk t len
| _ ->
- ill_formed (Printf.sprintf "code 0x%x" code)
+ ill_formed (Printf.sprintf "code 0x%x" code)
in
match t with
| Dynamic f ->
- intern_rec stk (f ())
+ intern_rec stk (f ())
| Abstract
| Structure (Array _ | Sum _ | Dependent_pair _)
| Transform _
| Return _ ->
- read_ch ()
+ read_ch ()
and read_block stk t tag size =
(* read one block of the given tag and size *)
let (t1, alloc) = get_structure t true in
begin match t1 with
- | Abstract -> ()
- | Structure (Dependent_pair(_, _)) ->
- if tag >= 1 || size != 2 then begin
- ill_formed "dep pair"
- end
- | Structure (Sum a) ->
- if tag >= Array.length a || size != Array.length a.(tag)
+ | Abstract -> ()
+ | Structure (Dependent_pair(_, _)) ->
+ if tag >= 1 || size != 2 then begin
+ ill_formed "dep pair"
+ end
+ | Structure (Sum a) ->
+ if tag >= Array.length a || size != Array.length a.(tag)
then begin
let s = Format.sprintf
"structure sum tag=%d size=%d len=%d len-tag=%d"
- tag size (Array.length a) (Array.length a.(tag))
+ tag size (Array.length a) (Array.length a.(tag))
in
- ill_formed s
- end
- | Structure (Array _) -> ()
- | _ -> assert false
+ ill_formed s
+ end
+ | Structure (Array _) -> ()
+ | _ -> assert false
end;
let v = if alloc then Obj.new_block tag size else Obj.repr size in
if size > 0 then begin
@@ -582,9 +582,9 @@ let input_val ch t =
match stk with
| [] -> assert false
| f :: _ ->
- let p = LA.get patch (!ctr - ofs) in
- LA.set patch (!ctr - ofs) ((f.st_ctr, f.st_cur) :: p);
- return stk null
+ let p = LA.get patch (!ctr - ofs) in
+ LA.set patch (!ctr - ofs) ((f.st_ctr, f.st_cur) :: p);
+ return stk null
end else begin
return stk v
end
@@ -593,18 +593,18 @@ let input_val ch t =
match stk with
| [] -> Obj.obj v
| f :: stk1 ->
- let sz =
- if Obj.is_int f.st_obj
- then (Obj.obj f.st_obj : int)
- else begin
- Obj.set_field f.st_obj f.st_cur v;
- Obj.size f.st_obj
- end
- in
- f.st_cur <- f.st_cur + 1;
- if f.st_cur >= sz
- then return_block stk1 f.st_ty f.st_obj f.st_ctr
- else intern_rec stk (get_field_type f.st_ty f.st_constr f.st_cur v)
+ let sz =
+ if Obj.is_int f.st_obj
+ then (Obj.obj f.st_obj : int)
+ else begin
+ Obj.set_field f.st_obj f.st_cur v;
+ Obj.size f.st_obj
+ end
+ in
+ f.st_cur <- f.st_cur + 1;
+ if f.st_cur >= sz
+ then return_block stk1 f.st_ty f.st_obj f.st_ctr
+ else intern_rec stk (get_field_type f.st_ty f.st_constr f.st_cur v)
and return_block stk t v dest = (* call alloc, patch, and return *)
let res = do_transform t v in
@@ -647,7 +647,7 @@ register_custom "_j"
(if arch_bigendian then
if arch_sixtyfour then readint64_big64 else readint64_big32
else
- if arch_sixtyfour then readint64_little64 else readint64_little32
+ if arch_sixtyfour then readint64_little64 else readint64_little32
)
;;
@@ -679,7 +679,7 @@ register_custom "_i"
(if arch_bigendian then
if arch_sixtyfour then readint32_big64 else readint32_big32
else
- if arch_sixtyfour then readint32_little64 else readint32_little32
+ if arch_sixtyfour then readint32_little64 else readint32_little32
)
;;
@@ -719,7 +719,7 @@ register_custom "_n"
(if arch_bigendian then
if arch_sixtyfour then readnativeint_big64 else readnativeint_big32
else
- if arch_sixtyfour then readnativeint_little64 else readnativeint_little32
+ if arch_sixtyfour then readnativeint_little64 else readnativeint_little32
)
;;
@@ -789,20 +789,20 @@ let t_hashtbl_unchangedhashs key value =
let t_hashtbl_changedhashs create add key value =
Dynamic
(fun () ->
- let new_hashtbl = create 27 in
- let return_new_hashtbl () = Obj.repr new_hashtbl in
- let rec bucket =
- Transform
- (Structure (Sum [| [| key; value; bucket |] |]),
- fun cell ->
- ( match Obj.obj cell with
- Empty -> ()
- | Cons (k, v, _) ->
- add new_hashtbl k v);
- Obj.repr Empty
- )
- in
- Return (t_hashtbl bucket, return_new_hashtbl))
+ let new_hashtbl = create 27 in
+ let return_new_hashtbl () = Obj.repr new_hashtbl in
+ let rec bucket =
+ Transform
+ (Structure (Sum [| [| key; value; bucket |] |]),
+ fun cell ->
+ ( match Obj.obj cell with
+ Empty -> ()
+ | Cons (k, v, _) ->
+ add new_hashtbl k v);
+ Obj.repr Empty
+ )
+ in
+ Return (t_hashtbl bucket, return_new_hashtbl))
(**** Sets ****)
diff --git a/src/libraries/datatype/unmarshal.mli b/src/libraries/datatype/unmarshal.mli
index 182112e60cb315252bc038a203333f8cad42b5be..5a5eaa8d98bba7146df693062f124118631699d3 100644
--- a/src/libraries/datatype/unmarshal.mli
+++ b/src/libraries/datatype/unmarshal.mli
@@ -39,24 +39,24 @@
(* Version 3.11.2.0 *)
(** Provides a function [input_val], similar in
-functionality to the standard library function [Marshal.from_channel].
-The main difference with [Marshal.from_channel] is that
-[input_val] is able to apply transformation functions on the
-values on the fly as they are read from the input channel.
-
-Because it has an abstract representation of the type,
-[input_val] is able to catch some inconsistencies that
-[Marshal.from_channel] cannot. It is therefore "more" type-safe,
-but only if it is always used in conditions where the static type
-attributed to the result by the type-checker agrees with the
-representation of the type passed as second argument to [input_val].
-No such verification is done by this module (this would require
-changes to the compiler).
-
-The sanity checks are not the primary purpose of [input_val],
-and it is possible for a bug where the representation of a value of
-the wrong type is passed to [input_val] to go undetected, just
-as this can happen with [Marshal.from_channel].
+ functionality to the standard library function [Marshal.from_channel].
+ The main difference with [Marshal.from_channel] is that
+ [input_val] is able to apply transformation functions on the
+ values on the fly as they are read from the input channel.
+
+ Because it has an abstract representation of the type,
+ [input_val] is able to catch some inconsistencies that
+ [Marshal.from_channel] cannot. It is therefore "more" type-safe,
+ but only if it is always used in conditions where the static type
+ attributed to the result by the type-checker agrees with the
+ representation of the type passed as second argument to [input_val].
+ No such verification is done by this module (this would require
+ changes to the compiler).
+
+ The sanity checks are not the primary purpose of [input_val],
+ and it is possible for a bug where the representation of a value of
+ the wrong type is passed to [input_val] to go undetected, just
+ as this can happen with [Marshal.from_channel].
*)
type t =
@@ -72,50 +72,50 @@ and structure =
| Array of t
(** Type [t] is used to describe the type of the data to be read and
-the transformations to be applied to the data.
-
-[Abstract] is used to input a value without any checking or
-transformation (as [Marshal.from_channel] does). In this case,
-you don't need to provide a precise description of the
-representation of the data.
-
-[Structure a] is used to provide a description of the representation
-of the data, along with optional transformation functions for
-parts of the data.
-
-[a] can be:
-- [Array(t)], indicating that
- the data is an array of values of the same type, each value being
- described by [t].
-- [Sum(c)] for describing a non-array type where [c] is
- an array describing the non-constant constructors of
- the type being described (in the order of their
- declarations in that type). Each element of this latter array is an
- array of [t] that describes (in order) the fields of the
- corresponding constructor.
-- [Dependent_pair(e,f)] for instructing the unmarshaler to
- reconstruct the first component of a pair first, using [e] as
- its description, and to apply function [f] to this value in order
- to get the description of the pair's second component.
-
-The shape of [a] must match the shape
-of the representation of the type of the data being imported, or
-[input_val] may report an error when the data doesn't match the
-description.
-
-[Transform (u, f)] is used to specify a transformation function on
-the data described by [u]. [input_val] will read and rebuild the
-data as described by [u], then call [f] on that data and return
-the result returned by [f].
-
-[Return (u, f)] is the same as [Transform], except that the data
-is not rebuilt, and [()] is passed to [f] instead of the data.
-This is to be used when the transformation functions of [u] rebuild
-the data by side effects and the version rebuilt by [input_val] is
-irrelevant.
-
-[Dynamic f] is used to build a new description on the fly when a
-new data of the current type is encountered.
+ the transformations to be applied to the data.
+
+ [Abstract] is used to input a value without any checking or
+ transformation (as [Marshal.from_channel] does). In this case,
+ you don't need to provide a precise description of the
+ representation of the data.
+
+ [Structure a] is used to provide a description of the representation
+ of the data, along with optional transformation functions for
+ parts of the data.
+
+ [a] can be:
+ - [Array(t)], indicating that
+ the data is an array of values of the same type, each value being
+ described by [t].
+ - [Sum(c)] for describing a non-array type where [c] is
+ an array describing the non-constant constructors of
+ the type being described (in the order of their
+ declarations in that type). Each element of this latter array is an
+ array of [t] that describes (in order) the fields of the
+ corresponding constructor.
+ - [Dependent_pair(e,f)] for instructing the unmarshaler to
+ reconstruct the first component of a pair first, using [e] as
+ its description, and to apply function [f] to this value in order
+ to get the description of the pair's second component.
+
+ The shape of [a] must match the shape
+ of the representation of the type of the data being imported, or
+ [input_val] may report an error when the data doesn't match the
+ description.
+
+ [Transform (u, f)] is used to specify a transformation function on
+ the data described by [u]. [input_val] will read and rebuild the
+ data as described by [u], then call [f] on that data and return
+ the result returned by [f].
+
+ [Return (u, f)] is the same as [Transform], except that the data
+ is not rebuilt, and [()] is passed to [f] instead of the data.
+ This is to be used when the transformation functions of [u] rebuild
+ the data by side effects and the version rebuilt by [input_val] is
+ irrelevant.
+
+ [Dynamic f] is used to build a new description on the fly when a
+ new data of the current type is encountered.
*)
val input_val : in_channel -> t -> 'a
@@ -126,16 +126,16 @@ val input_val : in_channel -> t -> 'a
val null : Obj.t
(** recursive values cannot be completely formed at the time
-they are passed to their transformation function. When traversing
-a recursive value, the transformation function must check the
-fields for physical equality to [null] (with the function [==])
-and avoid using any field that is equal to [null].
+ they are passed to their transformation function. When traversing
+ a recursive value, the transformation function must check the
+ fields for physical equality to [null] (with the function [==])
+ and avoid using any field that is equal to [null].
*)
val id : Obj.t -> Obj.t
(** Use this function when you don't want to change the value
-unmarshaled by input_val. You can also use your own identity
-function, but using this one is more efficient. *)
+ unmarshaled by input_val. You can also use your own identity
+ function, but using this one is more efficient. *)
(** {2 Convenience functions for describing transformations.} *)
diff --git a/src/libraries/datatype/unmarshal_hashtbl_test.ml b/src/libraries/datatype/unmarshal_hashtbl_test.ml
index bd7edbbbfe4dfd3ec7c506b905c8d3fcd312daf0..4f3b1ff4210e6cccf4fb4c40af60a273287932ca 100644
--- a/src/libraries/datatype/unmarshal_hashtbl_test.ml
+++ b/src/libraries/datatype/unmarshal_hashtbl_test.ml
@@ -38,22 +38,22 @@ open Unmarshal
let l = [ 512; 35; 62; 512; 42; 62; 17 ]
-let t_renumber_int =
+let t_renumber_int =
let tbl = Hashtbl.create 42 in
let count = ref 0 in
- let f x =
+ let f x =
match ((Obj.magic x) : int ) with
- | x ->
- let result =
- try
- Hashtbl.find tbl x
- with Not_found ->
- let c = !count in
- count := succ c;
- Hashtbl.add tbl x c;
- c
- in
- Obj.repr (result : int )
+ | x ->
+ let result =
+ try
+ Hashtbl.find tbl x
+ with Not_found ->
+ let c = !count in
+ count := succ c;
+ Hashtbl.add tbl x c;
+ c
+ in
+ Obj.repr (result : int )
in
Transform (t_option t_int, f)
@@ -72,23 +72,23 @@ let () =
let l = [ Some 512; Some 35; Some 62; Some 512; Some 42; Some 62; Some 17 ]
-let t_renumber_intopt =
+let t_renumber_intopt =
let tbl = Hashtbl.create 42 in
let count = ref 0 in
- let f x =
+ let f x =
match ((Obj.magic x) : int option) with
None -> assert false
- | Some x ->
- let result =
- try
- Hashtbl.find tbl x
- with Not_found ->
- let c = !count in
- count := succ c;
- Hashtbl.add tbl x c;
- c
- in
- Obj.repr (Some(result) : int option)
+ | Some x ->
+ let result =
+ try
+ Hashtbl.find tbl x
+ with Not_found ->
+ let c = !count in
+ count := succ c;
+ Hashtbl.add tbl x c;
+ c
+ in
+ Obj.repr (Some(result) : int option)
in
Transform (t_option t_int, f)
@@ -106,11 +106,11 @@ let () =
let h = Hashtbl.create 12;;
-let () =
+let () =
Hashtbl.add h 34 "s34";
Hashtbl.add h 63 "s63"
-let t_h1 =
+let t_h1 =
t_hashtbl_changedhashs Hashtbl.create Hashtbl.add t_renumber_int Abstract
let () =
@@ -123,7 +123,7 @@ let () =
Hashtbl.iter (fun k v -> Format.printf "%d %s@." k v) result;
print_endline "fin test3"
-let t_h2 =
+let t_h2 =
t_hashtbl_unchangedhashs t_int Abstract
let () =
diff --git a/src/libraries/datatype/unmarshal_test.ml b/src/libraries/datatype/unmarshal_test.ml
index 554579575909425d122df40ae3628970f3439d9e..8a6d9a371b02a1dc4ac309874e364a88773ad1d6 100644
--- a/src/libraries/datatype/unmarshal_test.ml
+++ b/src/libraries/datatype/unmarshal_test.ml
@@ -284,7 +284,7 @@ test v t_list4;;
type t = A of int * int | B of int
let l = [ A (3, 4); B 5 ]
-let t_l =
+let t_l =
t_list (Structure (Sum [| [| Abstract; Abstract |]; [| Abstract |] |]));;
let test v ty =
diff --git a/src/libraries/datatype/unmarshal_z.ml b/src/libraries/datatype/unmarshal_z.ml
index b61768bedb3e4256e4ca05fe38eb8eb5af21e2f8..f32acedba0680f49d4f14fee01de2a60df42274f 100644
--- a/src/libraries/datatype/unmarshal_z.ml
+++ b/src/libraries/datatype/unmarshal_z.ml
@@ -27,17 +27,17 @@ open Unmarshal;;
let readz ch =
let sign = read8u ch in
let charlen = read32u ch in
- let str = Bytes.create charlen in
+ let str = Bytes.create charlen in
readblock ch (Obj.repr str) 0 charlen;
-(* My beautiful string reversing code;
- now useless :(
- let max = pred charlen in
- for i = 0 to (pred max) / 2 do
- let c = str.[i] in
- str.[i] <- str.[max - i] ;
- str.[max - i] <- c
- done;
-*)
+ (* My beautiful string reversing code;
+ now useless :(
+ let max = pred charlen in
+ for i = 0 to (pred max) / 2 do
+ let c = str.[i] in
+ str.[i] <- str.[max - i] ;
+ str.[max - i] <- c
+ done;
+ *)
let n = Z.of_bits (Bytes.to_string str) in
let z = if sign = 0 then n else Z.neg n in
Obj.repr z
@@ -56,7 +56,7 @@ register_custom "_z" readz;;
;;
- ocamlc -custom zarith.cma unmarshal.ml unz.ml
+ ocamlc -custom zarith.cma unmarshal.ml unz.ml
*)
(*
@@ -67,16 +67,13 @@ let i = ref (-10000000000000000L) ;;
while !i <= 10000000000000000L do
let z = input_val f Abstract in
let r = Z.to_int64 z in
- if (r <> !i)
+ if (r <> !i)
then begin
Format.printf "read: %Ld expected: %Ld@."
- r !i;
+ r !i;
assert false
end;
- i := Int64.add !i 100000000000L ;
+ i := Int64.add !i 100000000000L ;
done
;;
*)
-
-
-
diff --git a/src/libraries/project/project.ml b/src/libraries/project/project.ml
index b9400c45d0cc06b881dde52b477fbfd984fc0187..1f404faab57c601aae88dc930af49e75366bd36d 100644
--- a/src/libraries/project/project.ml
+++ b/src/libraries/project/project.ml
@@ -29,9 +29,9 @@ open Output
(* re-exporting record fields *)
type project = t = private
- { pid : int;
- mutable name : string;
- mutable unique_name : string }
+ { pid : int;
+ mutable name : string;
+ mutable unique_name : string }
let rehash_ref = ref (fun _ -> assert false)
@@ -60,7 +60,7 @@ module D =
let pretty fmt p = Format.fprintf fmt "project %S" p.unique_name
let varname p = "p_" ^ p.name
let mem_project f x = f x
- end)
+ end)
include (D: Datatype.S_no_copy with type t = Project_skeleton.t)
module Project_tbl = Hashtbl.Make(D)
@@ -171,30 +171,30 @@ module States_operations = struct
iter_on_selection
?selection
(fun s () ->
- try
- let n = get_unique_name s in
- let d = Hashtbl.find tbl n in
- (try
- (private_ops s).unserialize dst d;
+ try
+ let n = get_unique_name s in
+ let d = Hashtbl.find tbl n in
+ (try
+ (private_ops s).unserialize dst d;
(* do not remove if [State.Incompatible_datatype] occurs *)
- Hashtbl.remove tbl n
- with
- | Not_found ->
- fatal "unexpected 'Not_found' when unserializing; \
- possibly an issue with a hook"
- | State.Incompatible_datatype _ ->
+ Hashtbl.remove tbl n
+ with
+ | Not_found ->
+ fatal "unexpected 'Not_found' when unserializing; \
+ possibly an issue with a hook"
+ | State.Incompatible_datatype _ ->
(* datatype of [s] on disk is incompatible with the one in RAM: as
[dst] is a new project, [s] is already equal to its default
value. However must clear the dependencies for consistency, but
it is doable only when all states are loaded. *)
- State.Hashtbl.add invalid_on_disk s ())
- with Not_found ->
+ State.Hashtbl.add invalid_on_disk s ())
+ with Not_found ->
(* [s] is in RAM but not on disk: silently ignore it! Furthermore,
all the dependencies of [s] are consistent with this default
value. So no need to clear them. Whenever the value of [s] in
[dst] changes, the dependencies will be cleared (if required by
the user). *)
- ())
+ ())
();
(* warns for the saved states that cannot be loaded
(either they are not in RAM or they are incompatible). *)
@@ -203,7 +203,7 @@ module States_operations = struct
in
pp_err
"%d state%s in saved file ignored. \
-%s this Frama-C configuration."
+ %s this Frama-C configuration."
nb_ignored
"It is invalid in"
"They are invalid in";
@@ -215,15 +215,15 @@ module States_operations = struct
let to_be_cleared =
State.Hashtbl.fold
(fun s () ->
- State_selection.union
- (State_selection.only_dependencies s))
+ State_selection.union
+ (State_selection.only_dependencies s))
invalid_on_disk
State_selection.empty
in
let nb_cleared = State_selection.cardinal to_be_cleared in
if nb_cleared > 0 then begin
pp_err "%d state%s in memory reset to their default value. \
-%s this Frama_C configuration."
+ %s this Frama_C configuration."
nb_cleared
"It is inconsistent in"
"They are inconsistent in";
@@ -244,7 +244,7 @@ let guarded_feedback selection level fmt_msg =
let states fmt =
if n > 1 then Format.fprintf fmt " (for %d states)" n
else Format.fprintf fmt " (for 1 state)"
- in
+ in
feedback ~dkey ~level ~append:states fmt_msg;
else
Pretty_utils.nullprintf fmt_msg
@@ -254,7 +254,7 @@ let dft_sel () = State_selection.full
module Q = Qstack.Make(struct type t = project let equal = equal end)
let projects = Q.create ()
- (* The stack of projects. *)
+(* The stack of projects. *)
let current () = Q.top projects
let is_current p = equal p (current ())
@@ -263,8 +263,8 @@ let last_created_by_copy_ref: t option ref = ref None
let () =
Cmdline.last_project_created_by_copy :=
(fun () -> match !last_created_by_copy_ref with
- | None -> None
- | Some p -> Some p.unique_name)
+ | None -> None
+ | Some p -> Some p.unique_name)
let iter_on_projects f = Q.iter f projects
let fold_on_projects f acc = Q.fold f acc projects
@@ -278,7 +278,7 @@ let from_unique_name uname =
module Mem = struct
let mem s =
- try ignore (from_unique_name s); true
+ try ignore (from_unique_name s); true
with Unknown_project -> false
end
module Setter = Make_setter(Mem)
@@ -482,10 +482,10 @@ let journalized_clear =
(lbl "selection" dft_sel State_selection.ty
(lbl "project" current ty (Datatype.func Datatype.unit Datatype.unit)))
(fun selection project () ->
- guarded_feedback selection 2 "clearing project %S" project.unique_name;
- Before_Clear_Hook.apply project;
- States_operations.clear ~selection project;
- After_Clear_Hook.apply project;
+ guarded_feedback selection 2 "clearing project %S" project.unique_name;
+ Before_Clear_Hook.apply project;
+ States_operations.clear ~selection project;
+ After_Clear_Hook.apply project;
(*Gc.major ()*))
let clear ?(selection=State_selection.full) ?(project=current()) () =
@@ -573,35 +573,35 @@ let save_all ?(selection=State_selection.full) filename =
module Descr = struct
let project_under_copy_ref: project option ref = ref None
- (* The project which is currently copying. Only set by [create_by_copy].
- In this case, there is no possible dangling project pointers (projects
- at saving time and at loading time are the same).
- Furthermore, we have to merge pre-existing projects and loaded
- projects, except the project under copy. *)
+ (* The project which is currently copying. Only set by [create_by_copy].
+ In this case, there is no possible dangling project pointers (projects
+ at saving time and at loading time are the same).
+ Furthermore, we have to merge pre-existing projects and loaded
+ projects, except the project under copy. *)
module Rehash =
Hashtbl.Make
(struct
- type t = project
- let hash p = Hashtbl.hash p.pid
- let equal x y =
- match !project_under_copy_ref with
- | Some p when p.pid <> x.pid && p.pid <> y.pid ->
- (* Merge projects on disk with pre-existing projects, except the
- project under copy; so don't use (==) in this context. *)
- x.pid = y.pid
- | None | Some _ ->
- (* In all other cases, don't merge.
- (==) ensures that there is no sharing between a pre-existing
- project and a project on disk. Great! *)
- x == y
- end)
+ type t = project
+ let hash p = Hashtbl.hash p.pid
+ let equal x y =
+ match !project_under_copy_ref with
+ | Some p when p.pid <> x.pid && p.pid <> y.pid ->
+ (* Merge projects on disk with pre-existing projects, except the
+ project under copy; so don't use (==) in this context. *)
+ x.pid = y.pid
+ | None | Some _ ->
+ (* In all other cases, don't merge.
+ (==) ensures that there is no sharing between a pre-existing
+ project and a project on disk. Great! *)
+ x == y
+ end)
let rehash_cache : project Rehash.t = Rehash.create 7
let existing_projects : unit Project_tbl.t = Project_tbl.create 7
let rehash p =
-(* Format.printf "REHASHING %S (%d;%x)@." p.unique_name p.pid (Extlib.address_of_value p);*)
+ (* Format.printf "REHASHING %S (%d;%x)@." p.unique_name p.pid (Extlib.address_of_value p);*)
try
Rehash.find rehash_cache p
with Not_found ->
@@ -612,7 +612,7 @@ module Descr = struct
let init project_under_copy =
assert (Rehash.length rehash_cache = 0
- && Project_tbl.length existing_projects = 0);
+ && Project_tbl.length existing_projects = 0);
project_under_copy_ref := project_under_copy;
Q.fold
(fun acc p -> Project_tbl.add existing_projects p (); p :: acc)
@@ -621,22 +621,22 @@ module Descr = struct
let finalize loaded_states selection =
(match !project_under_copy_ref with
- | None ->
- List.iter
- (fun ( (p, _)) ->
- States_operations.clear_some_projects
- ~selection
- (fun p -> not (Project_tbl.mem existing_projects p))
- p)
- loaded_states
- | Some _ ->
- ());
+ | None ->
+ List.iter
+ (fun ( (p, _)) ->
+ States_operations.clear_some_projects
+ ~selection
+ (fun p -> not (Project_tbl.mem existing_projects p))
+ p)
+ loaded_states
+ | Some _ ->
+ ());
Rehash.clear rehash_cache;
Project_tbl.clear existing_projects
let global_state name selection =
let state_on_disk s =
-(* Format.printf "State %S@." s;*)
+ (* Format.printf "State %S@." s;*)
let descr =
try State.get_descr (State.get s)
with State.Unknown -> Structural_descr.p_unit (* dummy value *)
@@ -653,11 +653,11 @@ module Descr = struct
let unmarshal_states p =
Descr.dynamic
(fun () ->
- (* Local states must be up-to-date according to [p] when
- unmarshalling states of [p] *)
- unjournalized_set_current true selection p;
- Before_load.apply ();
- Descr.t_list tbl_on_disk)
+ (* Local states must be up-to-date according to [p] when
+ unmarshalling states of [p] *)
+ unjournalized_set_current true selection p;
+ Before_load.apply ();
+ Descr.t_list tbl_on_disk)
in
Descr.dependent_pair descr unmarshal_states
in
@@ -665,16 +665,16 @@ module Descr = struct
Descr.transform
one_state
(fun (p, s as c) ->
- (* if we provide an explicit name different of the current one,
- rename project [p] *)
- (match name with Some s when s <> p.name -> set_name p s | _ -> ());
- Project_tbl.add existing_projects p ();
- (* At this point, the local states are always up-to-date according
- to the current project, since we load first the old current
- project *)
- States_operations.unserialize ~selection p s;
- After_load.apply ();
- c)
+ (* if we provide an explicit name different of the current one,
+ rename project [p] *)
+ (match name with Some s when s <> p.name -> set_name p s | _ -> ());
+ Project_tbl.add existing_projects p ();
+ (* At this point, the local states are always up-to-date according
+ to the current project, since we load first the old current
+ project *)
+ States_operations.unserialize ~selection p s;
+ After_load.apply ();
+ c)
in
Descr.t_pair
(Descr.t_list final_one_state)
@@ -848,9 +848,9 @@ module Undo = struct
if Cmdline.use_obj then begin
clear_breakpoint ();
filename := Filepath.Normalized.of_string
- (try Extlib.temp_file_cleanup_at_exit short_filename ".sav"
- with Extlib.Temp_file_error s ->
- abort "cannot create temporary file: %s" s);
+ (try Extlib.temp_file_cleanup_at_exit short_filename ".sav"
+ with Extlib.Temp_file_error s ->
+ abort "cannot create temporary file: %s" s);
Journal.prevent save_all !filename;
Journal.save ()
end
diff --git a/src/libraries/project/project.mli b/src/libraries/project/project.mli
index 544ca28b404b9289275dfdffcf16fa07a62139b4..8771487d3c25b3c68dbf974fb839e475d7d18555 100644
--- a/src/libraries/project/project.mli
+++ b/src/libraries/project/project.mli
@@ -38,54 +38,54 @@ module Datatype: Datatype.S_with_collections with type t = Project_skeleton.t
(* re-exporting record fields *)
type project = Project_skeleton.t =
- private
- { pid : int;
- mutable name : string;
- mutable unique_name : string }
- (** Type of a project. *)
+ private
+ { pid : int;
+ mutable name : string;
+ mutable unique_name : string }
+(** Type of a project. *)
(* ************************************************************************* *)
(** {2 Operations on all projects} *)
(* ************************************************************************* *)
val create: string -> t
- (** Create a new project with the given name and attach it after the existing
- projects (so the current project, if existing, is unchanged).
- The given name may be already used by another project.
- If there is no other project, then the new one is the current one. *)
+(** Create a new project with the given name and attach it after the existing
+ projects (so the current project, if existing, is unchanged).
+ The given name may be already used by another project.
+ If there is no other project, then the new one is the current one. *)
val register_create_hook: (t -> unit) -> unit
- (** [register_create_hook f] adds a hook on function [create]: each time a
- new project [p] is created, [f p] is applied.
+(** [register_create_hook f] adds a hook on function [create]: each time a
+ new project [p] is created, [f p] is applied.
- The order in which hooks are applied is the same than the order in which
- hooks are registered. *)
+ The order in which hooks are applied is the same than the order in which
+ hooks are registered. *)
exception NoProject
- (** May be raised by [current]. *)
+(** May be raised by [current]. *)
val current: unit -> t
- (** The current project.
- @raise NoProject if there is no project.
- @plugin development guide *)
+(** The current project.
+ @raise NoProject if there is no project.
+ @plugin development guide *)
val is_current: t -> bool
- (** Check whether the given project is the current one or not. *)
+(** Check whether the given project is the current one or not. *)
val iter_on_projects: (t -> unit) -> unit
- (** iteration on project starting with the current one. *)
+(** iteration on project starting with the current one. *)
val fold_on_projects: ('a -> t -> 'a) -> 'a -> 'a
- (** folding on project starting with the current one.
- @since Boron-20100401 *)
+(** folding on project starting with the current one.
+ @since Boron-20100401 *)
val find_all: string -> t list
- (** Find all projects with the given name. *)
+(** Find all projects with the given name. *)
val clear_all: unit -> unit
- (** Clear all the projects: all the internal states of all the projects are
- now empty (wrt the action registered with
- {!register_todo_after_global_clear} and {!register_todo_after_clear}. *)
+(** Clear all the projects: all the internal states of all the projects are
+ now empty (wrt the action registered with
+ {!register_todo_after_global_clear} and {!register_todo_after_clear}. *)
(* ************************************************************************* *)
(** {2 Operations on one project}
@@ -97,111 +97,111 @@ val clear_all: unit -> unit
(* ************************************************************************* *)
val get_name: t -> string
- (** Project name. Two projects may have the same name. *)
+(** Project name. Two projects may have the same name. *)
val get_unique_name: t -> string
- (** @return a project name based on {!name} but different of each others
- [unique_name]. *)
+(** @return a project name based on {!name} but different of each others
+ [unique_name]. *)
val set_name: t -> string -> unit
- (** Set the name of the given project.
- @since Boron-20100401 *)
+(** Set the name of the given project.
+ @since Boron-20100401 *)
exception Unknown_project
val from_unique_name: string -> t
- (** Return a project based on {!unique_name}.
- @raise Unknown_project if no project has this unique name.
- @modify Sodium-20150201 *)
+(** Return a project based on {!unique_name}.
+ @raise Unknown_project if no project has this unique name.
+ @modify Sodium-20150201 *)
val set_current: ?on:bool -> ?selection:State_selection.t -> t -> unit
- (** Set the current project with the given one.
- The flag [on] is not for casual users.
- @raise Invalid_argument if the given project does not exist anymore.
- @plugin development guide *)
+(** Set the current project with the given one.
+ The flag [on] is not for casual users.
+ @raise Invalid_argument if the given project does not exist anymore.
+ @plugin development guide *)
val register_after_set_current_hook: user_only:bool -> (t -> unit) -> unit
- (** [register_after_set_current_hook f] adds a hook on function
- {!set_current}. The project given as argument to [f] is the old current
- project.
- - If [user_only] is [true], then each time {!set_current} is directly
+(** [register_after_set_current_hook f] adds a hook on function
+ {!set_current}. The project given as argument to [f] is the old current
+ project.
+ - If [user_only] is [true], then each time {!set_current} is directly
called by an user of this library, [f ()] is applied.
- - If [user_only] is [false], then each time {!set_current} is applied
+ - If [user_only] is [false], then each time {!set_current} is applied
(even indirectly through {!Project.on}), [f ()] is applied.
The order in which each hook is applied is unspecified. *)
val on: ?selection:State_selection.t -> t -> ('a -> 'b) -> 'a -> 'b
- (** [on p f x] sets the current project to [p], computes [f x] then
- restores the current project. You should use this function if you use a
- project different of [current ()].
- @modify Carbon-20101201 replace the optional arguments [only] and
- [except] by a single one [selection].
- @plugin development guide *)
+(** [on p f x] sets the current project to [p], computes [f x] then
+ restores the current project. You should use this function if you use a
+ project different of [current ()].
+ @modify Carbon-20101201 replace the optional arguments [only] and
+ [except] by a single one [selection].
+ @plugin development guide *)
val set_keep_current: bool -> unit
- (** [set_keep_current b] keeps the current project forever (even after the end
- of the current {!on}) iff [b] is [true].
- @since Aluminium-20160501 *)
+(** [set_keep_current b] keeps the current project forever (even after the end
+ of the current {!on}) iff [b] is [true].
+ @since Aluminium-20160501 *)
(**/**)
val set_current_as_last_created: unit -> unit
(**/**)
val copy: ?selection:State_selection.t -> ?src:t -> t -> unit
- (** Copy a project into another one. Default project for [src] is [current
- ()]. Replace the destination by [src].
- For each state to copy, the function [copy] given at state registration
- time must be fully implemented.
- @modify Carbon-20101201 replace the optional arguments [only] and
- [except] by a single one [selection]. *)
+(** Copy a project into another one. Default project for [src] is [current
+ ()]. Replace the destination by [src].
+ For each state to copy, the function [copy] given at state registration
+ time must be fully implemented.
+ @modify Carbon-20101201 replace the optional arguments [only] and
+ [except] by a single one [selection]. *)
val create_by_copy:
?selection:State_selection.t -> ?src:t -> last:bool -> string -> t
- (** Return a new project with the given name by copying some states from the
- project [src]. All the other states are initialized with their default
- values.
- Use the save/load mechanism for copying. Thus it does not require that
- the copy function of the copied state is implemented. All the hooks
- applied when loading a project are applied (see {!load}).
- If [last], then remember that the returned project is the last created
- one (see {!last_created_by_copy}).
- @modify Carbon-20101201 replace the optional arguments [only] and
- [except] by a single one [selection].
- @modify Sodium-20150201 add the labeled argument [last]. *)
+(** Return a new project with the given name by copying some states from the
+ project [src]. All the other states are initialized with their default
+ values.
+ Use the save/load mechanism for copying. Thus it does not require that
+ the copy function of the copied state is implemented. All the hooks
+ applied when loading a project are applied (see {!load}).
+ If [last], then remember that the returned project is the last created
+ one (see {!last_created_by_copy}).
+ @modify Carbon-20101201 replace the optional arguments [only] and
+ [except] by a single one [selection].
+ @modify Sodium-20150201 add the labeled argument [last]. *)
val create_by_copy_hook: (t -> t -> unit) -> unit
- (** Register a hook to call at the end of {!create_by_copy}. The first
- argument of the registered function is the copy source while the
- second one is the created project. *)
+(** Register a hook to call at the end of {!create_by_copy}. The first
+ argument of the registered function is the copy source while the
+ second one is the created project. *)
val clear: ?selection:State_selection.t -> ?project:t -> unit -> unit
- (** Clear the given project. Default project is [current ()]. All the
- internal states of the given project are now empty (wrt the action
- registered with {!register_todo_on_clear}).
- @modify Carbon-20101201 replace the optional arguments [only] and
- [except] by a single one [selection].
- @plugin development guide *)
+(** Clear the given project. Default project is [current ()]. All the
+ internal states of the given project are now empty (wrt the action
+ registered with {!register_todo_on_clear}).
+ @modify Carbon-20101201 replace the optional arguments [only] and
+ [except] by a single one [selection].
+ @plugin development guide *)
val register_todo_before_clear: (t -> unit) -> unit
- (** Register an action performed just before clearing a project.
- @since Boron-20100401 *)
+(** Register an action performed just before clearing a project.
+ @since Boron-20100401 *)
val register_todo_after_clear: (t -> unit) -> unit
- (** Register an action performed just after clearing a project.
- @since Boron-20100401 *)
+(** Register an action performed just after clearing a project.
+ @since Boron-20100401 *)
exception Cannot_remove of string
- (** Raised by [remove] *)
+(** Raised by [remove] *)
val remove: ?project:t -> unit -> unit
- (** Default project is [current ()]. If the current project is removed, then
- the new current project is the previous current project if it still
- exists (and so on).
- @raise Cannot_remove if there is only one project. *)
+(** Default project is [current ()]. If the current project is removed, then
+ the new current project is the previous current project if it still
+ exists (and so on).
+ @raise Cannot_remove if there is only one project. *)
val register_before_remove_hook: (t -> unit) -> unit
- (** [register_before_remove_hook f] adds a hook called just before removing
- a project.
- @since Beryllium-20090902 *)
+(** [register_before_remove_hook f] adds a hook called just before removing
+ a project.
+ @since Beryllium-20090902 *)
(* ************************************************************************* *)
(** {3 Inputs/Outputs} *)
@@ -210,64 +210,64 @@ val register_before_remove_hook: (t -> unit) -> unit
exception IOError of string
val save: ?selection:State_selection.t -> ?project:t -> Filepath.Normalized.t -> unit
- (** Save a given project in a file. Default project is [current ()].
- @raise IOError if the project cannot be saved.
- @modify Carbon-20101201 replace the optional arguments [only] and
- [except] by a single one [selection].
- @plugin development guide *)
+(** Save a given project in a file. Default project is [current ()].
+ @raise IOError if the project cannot be saved.
+ @modify Carbon-20101201 replace the optional arguments [only] and
+ [except] by a single one [selection].
+ @plugin development guide *)
val load: ?selection:State_selection.t -> ?name:string -> Filepath.Normalized.t -> t
- (** Load a file into a new project given by its name.
- More precisely, [load only except name file]:
- {ol
- {- creates a new project;}
- {- performs all the registered [before_load] actions;}
- {- loads the (specified) states of the project according to its
- description; and}
- {- performs all the registered [after_load] actions.}
- }
- @raise IOError if the project cannot be loaded
- @return the new project containing the loaded data.
- @modify Carbon-20101201 replace the optional arguments [only] and
- [except] by a single one [selection].
- @plugin development guide *)
+(** Load a file into a new project given by its name.
+ More precisely, [load only except name file]:
+ {ol
+ {- creates a new project;}
+ {- performs all the registered [before_load] actions;}
+ {- loads the (specified) states of the project according to its
+ description; and}
+ {- performs all the registered [after_load] actions.}
+ }
+ @raise IOError if the project cannot be loaded
+ @return the new project containing the loaded data.
+ @modify Carbon-20101201 replace the optional arguments [only] and
+ [except] by a single one [selection].
+ @plugin development guide *)
val save_all: ?selection:State_selection.t -> Filepath.Normalized.t -> unit
- (** Save all the projects in a file.
- @modify Carbon-20101201 replace the optional arguments [only] and
- [except] by a single one [selection].
- @raise IOError a project cannot be saved. *)
+(** Save all the projects in a file.
+ @modify Carbon-20101201 replace the optional arguments [only] and
+ [except] by a single one [selection].
+ @raise IOError a project cannot be saved. *)
val load_all: ?selection:State_selection.t -> Filepath.Normalized.t -> unit
- (** First remove all the existing project, then load all the projects from a
- file. For each project to load, the specification is the same than
- {!Project.load}. Furthermore, after loading, all the hooks registered by
- [register_after_set_current_hook] are applied.
- @modify Carbon-20101201 replace the optional arguments [only] and
- [except] by a single one [selection].
- @raise IOError if a project cannot be loaded. *)
+(** First remove all the existing project, then load all the projects from a
+ file. For each project to load, the specification is the same than
+ {!Project.load}. Furthermore, after loading, all the hooks registered by
+ [register_after_set_current_hook] are applied.
+ @modify Carbon-20101201 replace the optional arguments [only] and
+ [except] by a single one [selection].
+ @raise IOError if a project cannot be loaded. *)
val register_before_load_hook: (unit -> unit) -> unit
- (** [register_before_load_hook f] adds a hook called just before loading
- **each project** (more precisely, the project exists and but is empty
- while the hook is applied): if [n] projects are on disk, the same hook
- will be called [n] times (one call by project).
+(** [register_before_load_hook f] adds a hook called just before loading
+ **each project** (more precisely, the project exists and but is empty
+ while the hook is applied): if [n] projects are on disk, the same hook
+ will be called [n] times (one call by project).
- Besides, for each project, the order in which the hooks are applied is
- the same than the order in which hooks are registered. *)
+ Besides, for each project, the order in which the hooks are applied is
+ the same than the order in which hooks are registered. *)
val register_after_load_hook: (unit -> unit) -> unit
- (** [register_after_load_hook f] adds a hook called just after loading
- **each project**: if [n] projects are on disk, the same hook will be
- called [n] times (one call by project).
+(** [register_after_load_hook f] adds a hook called just after loading
+ **each project**: if [n] projects are on disk, the same hook will be
+ called [n] times (one call by project).
- Besides, for each project, the order in which the hooks are applied is
- the same than the order in which hooks are registered. *)
+ Besides, for each project, the order in which the hooks are applied is
+ the same than the order in which hooks are registered. *)
val register_after_global_load_hook: (unit -> unit) -> unit
- (** [register_after_load_hook f] adds a hook called just after loading
- **all projects**. [f] must not set the current project.
- @since Boron-20100401 *)
+(** [register_after_load_hook f] adds a hook called just after loading
+ **all projects**. [f] must not set the current project.
+ @since Boron-20100401 *)
(* ************************************************************************* *)
(** {3 Handling the selection} *)
diff --git a/src/libraries/project/project_skeleton.mli b/src/libraries/project/project_skeleton.mli
index bd3a8a394caefd3f2b36ab83a1ed9956c2fdc9fe..21e2a0a0d94ef3c3f4ed149e0722d9dc7f13a2ad 100644
--- a/src/libraries/project/project_skeleton.mli
+++ b/src/libraries/project/project_skeleton.mli
@@ -31,7 +31,7 @@
module Output : sig
include Log.Messages
val dkey: category
-(** @since Fluorine-20130401 *)
+ (** @since Fluorine-20130401 *)
end
(* ************************************************************************** *)
@@ -39,7 +39,7 @@ end
(* ************************************************************************** *)
type t = private
- { pid: int; mutable name: string; mutable unique_name: string }
+ { pid: int; mutable name: string; mutable unique_name: string }
(** @since Carbon-20101201
@plugin development guide *)
@@ -64,7 +64,7 @@ module Make_setter(X: sig val mem: string -> bool end) : sig
(** @since Carbon-20101201 *)
val set_name: t -> string -> unit
-(** @since Carbon-20101201 *)
+ (** @since Carbon-20101201 *)
end
diff --git a/src/libraries/project/state.ml b/src/libraries/project/state.ml
index cb3d5a44e7ebba13e16404838f1c6b8ec4473cd3..0d1c021f3b7b746d49fda0eb7e6b50b8f0d9049d 100644
--- a/src/libraries/project/state.ml
+++ b/src/libraries/project/state.ml
@@ -27,29 +27,29 @@ open Project_skeleton
(* ************************************************************************** *)
type state_on_disk =
- { on_disk_value: Obj.t;
- on_disk_computed: bool;
- on_disk_saved: bool;
- on_disk_digest: Digest.t }
+ { on_disk_value: Obj.t;
+ on_disk_computed: bool;
+ on_disk_saved: bool;
+ on_disk_digest: Digest.t }
type private_ops =
- { mutable descr: Structural_descr.pack;
- create: t -> unit;
- remove: t -> unit;
- mutable clear: t -> unit;
- mutable clear_some_projects: (t -> bool) -> t -> bool;
- copy: t -> t -> unit;
- commit: t -> unit;
- update: t -> unit;
- on_update: (unit -> unit) -> unit;
- clean: unit -> unit;
- serialize: t -> state_on_disk;
- unserialize: t -> state_on_disk -> unit }
+ { mutable descr: Structural_descr.pack;
+ create: t -> unit;
+ remove: t -> unit;
+ mutable clear: t -> unit;
+ mutable clear_some_projects: (t -> bool) -> t -> bool;
+ copy: t -> t -> unit;
+ commit: t -> unit;
+ update: t -> unit;
+ on_update: (unit -> unit) -> unit;
+ clean: unit -> unit;
+ serialize: t -> state_on_disk;
+ unserialize: t -> state_on_disk -> unit }
type state =
- { unique_name: string;
- mutable name: string;
- private_ops: private_ops }
+ { unique_name: string;
+ mutable name: string;
+ private_ops: private_ops }
module type Local = sig
type t
@@ -112,7 +112,7 @@ include Datatype.Make_with_collections
let pretty fmt s = Format.fprintf fmt "state %S" s.unique_name
let varname = Datatype.undefined
let mem_project = Datatype.never_any_project
- end)
+ end)
let is_dummy = equal dummy
@@ -147,8 +147,8 @@ let add_hook_on_update s f = s.private_ops.on_update f
let states : t Datatype.String.Hashtbl.t = Datatype.String.Hashtbl.create 997
exception Unknown
-let get s =
- try Datatype.String.Hashtbl.find states s
+let get s =
+ try Datatype.String.Hashtbl.find states s
with Not_found -> raise Unknown
let delete s =
@@ -170,8 +170,8 @@ let add s =
let unique_name_from_name =
let module M =
- Project_skeleton.Make_setter
- (struct let mem s = Datatype.String.Hashtbl.mem states s end)
+ Project_skeleton.Make_setter
+ (struct let mem s = Datatype.String.Hashtbl.mem states s end)
in
M.make_unique_name
diff --git a/src/libraries/project/state.mli b/src/libraries/project/state.mli
index bf32187eb629b249111064b736f13a3a35bbdca3..6c586ab718d8d7d201936c91a9d93bc1bc2c2ea5 100644
--- a/src/libraries/project/state.mli
+++ b/src/libraries/project/state.mli
@@ -39,25 +39,25 @@ include Datatype.S_with_collections
module type Local = sig
type t
- (** Type of the state to register. *)
+ (** Type of the state to register. *)
val create: unit -> t
- (** How to create a new fresh state which must be equal to the initial
- state: that is, if you never change the state, [create ()] and [get
- ()] must be equal (see invariant 1 below). *)
+ (** How to create a new fresh state which must be equal to the initial
+ state: that is, if you never change the state, [create ()] and [get
+ ()] must be equal (see invariant 1 below). *)
val clear: t -> unit
- (** How to clear a state. After clearing, the state should be
- observationally the same that after its creation (see invariant 2
- below). *)
+ (** How to clear a state. After clearing, the state should be
+ observationally the same that after its creation (see invariant 2
+ below). *)
val get: unit -> t
- (** How to access to the current state. Be aware of invariants 3 and 4
- below. *)
+ (** How to access to the current state. Be aware of invariants 3 and 4
+ below. *)
val set: t -> unit
- (** How to change the current state. Be aware of invariants 3 and 4
- below. *)
+ (** How to change the current state. Be aware of invariants 3 and 4
+ below. *)
(** The four following invariants must hold.
{ol
@@ -130,28 +130,28 @@ val add_hook_on_update: t -> (unit -> unit) -> unit
(** @since Carbon-20101201 *)
type state_on_disk =
- { on_disk_value: Obj.t;
- on_disk_computed: bool;
- on_disk_saved: bool;
- on_disk_digest: Digest.t }
+ { on_disk_value: Obj.t;
+ on_disk_computed: bool;
+ on_disk_saved: bool;
+ on_disk_digest: Digest.t }
(** @since Carbon-20101201 *)
type private_ops = private
- { mutable descr: Structural_descr.pack;
- create: project -> unit;
- remove: project -> unit;
- mutable clear: project -> unit;
- mutable clear_some_projects: (project -> bool) -> project -> bool;
- copy: project -> project -> unit;
- commit: project -> unit;
- update: project -> unit;
- on_update: (unit -> unit) -> unit;
- clean: unit -> unit;
- serialize: project -> state_on_disk;
- unserialize: project -> state_on_disk -> unit
- (** @raise Incompatible_datatype if [state_on_disk] is not
- compatible with the datatype expected by Frama-C's state *)
- }
+ { mutable descr: Structural_descr.pack;
+ create: project -> unit;
+ remove: project -> unit;
+ mutable clear: project -> unit;
+ mutable clear_some_projects: (project -> bool) -> project -> bool;
+ copy: project -> project -> unit;
+ commit: project -> unit;
+ update: project -> unit;
+ on_update: (unit -> unit) -> unit;
+ clean: unit -> unit;
+ serialize: project -> state_on_disk;
+ unserialize: project -> state_on_disk -> unit
+ (** @raise Incompatible_datatype if [state_on_disk] is not
+ compatible with the datatype expected by Frama-C's state *)
+ }
exception Incompatible_datatype of string
diff --git a/src/libraries/project/state_builder.ml b/src/libraries/project/state_builder.ml
index b60b0e2d543063e3e6a909c56dc8ef122f5b60e8..de29e89db7baedc1d085c6912ef392d2cd289ba7 100644
--- a/src/libraries/project/state_builder.ml
+++ b/src/libraries/project/state_builder.ml
@@ -88,13 +88,13 @@ module Proxy = struct
~copy:do_nothing_2
~commit:do_nothing
~update:do_nothing
- ~on_update:do_nothing
+ ~on_update:do_nothing
~serialize:
- (fun _ ->
- { on_disk_value = Obj.repr ();
- on_disk_computed = false;
- on_disk_saved = false;
- on_disk_digest = Type.digest Datatype.unit })
+ (fun _ ->
+ { on_disk_value = Obj.repr ();
+ on_disk_computed = false;
+ on_disk_saved = false;
+ on_disk_digest = Type.digest Datatype.unit })
~unserialize:do_nothing_2
~unique_name:(State.unique_name_from_name name)
~name
@@ -114,11 +114,11 @@ module States = struct
let states = S.create 997
let add k ty v = S.add states k ty v
let find ?(prj=Project.current ()) k ty = S.find states k ty prj
- let iter ?(prj=Project.current ()) f =
+ let iter ?(prj=Project.current ()) f =
S.iter (fun name ty get -> let s, b = get prj in f name ty s b) states
- let fold ?(prj=Project.current ()) f acc =
+ let fold ?(prj=Project.current ()) f acc =
S.fold
- (fun name ty get acc -> let s, b = get prj in f name ty s b acc)
+ (fun name ty get acc -> let s, b = get prj in f name ty s b acc)
states
acc
end
@@ -126,17 +126,17 @@ end
module FCDatatype = Datatype
module Register
- (D: Datatype.S)
- (Local_state: State.Local with type t = D.t)
- (Info: sig include Info val unique_name: string end)
+ (D: Datatype.S)
+ (Local_state: State.Local with type t = D.t)
+ (Info: sig include Info val unique_name: string end)
: S with module Datatype = D
- =
+=
struct
let internal_name = ref ""
let debug ~level op_name p =
- debug ~dkey ~level "%s %S (project %s)"
+ debug ~dkey ~level "%s %S (project %s)"
op_name
!internal_name
(Project.get_unique_name p)
@@ -189,7 +189,7 @@ struct
update_with ~force p v.state
let clean () =
- (* Format.printf "cleaning %s@." !internal_name;*)
+ (* Format.printf "cleaning %s@." !internal_name;*)
Local_state.set (Local_state.create ());
Tbl.clear tbl
@@ -251,12 +251,12 @@ struct
assert Cmdline.use_obj;
commit p;
let v = find p in
- let obj =
- if !must_save then begin
- debug ~level:4 "serializing" p;
- !marshal v.state
+ let obj =
+ if !must_save then begin
+ debug ~level:4 "serializing" p;
+ !marshal v.state
end else
- Obj.repr ()
+ Obj.repr ()
in
{ State.on_disk_value = obj;
on_disk_computed = v.computed;
@@ -311,7 +311,7 @@ struct
(* register this state in the static graph and in projects *)
State_dependency_graph.add_state self dependencies;
States.add
- Info.name
+ Info.name
D.ty
(fun p -> let s = Tbl.find tbl p in s.state, s.computed);
Project.iter_on_projects create
@@ -331,8 +331,8 @@ module type Ref = sig
end
module Ref
- (Data: Datatype.S)
- (Info: sig include Info val default: unit -> Data.t end) =
+ (Data: Datatype.S)
+ (Info: sig include Info val default: unit -> Data.t end) =
struct
type data = Data.t
@@ -341,17 +341,17 @@ struct
let state = ref (create ())
include Register
- (Datatype.Ref(Data))
- (struct
- type t = data ref
- let create = create
- let clear tbl = tbl := Info.default ()
- let get () = !state
- let set x = state := x
- let clear_some_projects f x =
- if Data.mem_project f !x then begin clear x; true end else false
- end)
- (struct include Info let unique_name = name end)
+ (Datatype.Ref(Data))
+ (struct
+ type t = data ref
+ let create = create
+ let clear tbl = tbl := Info.default ()
+ let get () = !state
+ let set x = state := x
+ let clear_some_projects f x =
+ if Data.mem_project f !x then begin clear x; true end else false
+ end)
+ (struct include Info let unique_name = name end)
let set v = !state := v
let get () = !(!state)
@@ -377,17 +377,17 @@ module Option_ref(Data:Datatype.S)(Info: Info) = struct
module D = Datatype.Ref(Datatype.Option(Data))
include Register
- (D)
- (struct
- type t = data option ref
- let create = create
- let clear tbl = tbl := None
- let get () = !state
- let set x = state := x
- let clear_some_projects f x =
- if D.mem_project f x then begin clear x; true end else false
- end)
- (struct include Info let unique_name = name end)
+ (D)
+ (struct
+ type t = data option ref
+ let create = create
+ let clear tbl = tbl := None
+ let get () = !state
+ let set x = state := x
+ let clear_some_projects f x =
+ if D.mem_project f x then begin clear x; true end else false
+ end)
+ (struct include Info let unique_name = name end)
let set v = !state := Some v
let get () = match !(!state) with None -> raise Not_found | Some v -> v
@@ -496,9 +496,9 @@ module type Hashtbl = sig
end
module Hashtbl
- (H: Datatype.Hashtbl)
- (Data: Datatype.S)
- (Info: Info_with_size) =
+ (H: Datatype.Hashtbl)
+ (Data: Datatype.S)
+ (Info: Info_with_size) =
struct
type key = H.key
@@ -511,37 +511,37 @@ struct
module D = H.Make(Data)
include Register
- (D)
- (struct
- type t = data H.t
- let create = create
- let clear = H.clear
- let get () = !state
- let set x = state := x
- let clear_some_projects f h =
-(* Format.printf "%S: %S %S@." Info.name H.Key.name Data.name;*)
- let x =
- if D.mem_project == Datatype.never_any_project then
- false
- else
- (* [TODO] BUG: if [Data.mem_project f v] returns [true] and there are
- several bindings for the key [k] of [v] (and [v] is not the last
- added binding) *)
- let found =
- H.fold
- (fun k v l ->
- if H.Key.mem_project f k || Data.mem_project f v then k :: l
- else l)
- h
- []
- in
- List.iter (H.remove h) found;
- found <> []
- in
-(* Format.printf "DONE@.";*)
- x
- end)
- (struct include Info let unique_name = name end)
+ (D)
+ (struct
+ type t = data H.t
+ let create = create
+ let clear = H.clear
+ let get () = !state
+ let set x = state := x
+ let clear_some_projects f h =
+ (* Format.printf "%S: %S %S@." Info.name H.Key.name Data.name;*)
+ let x =
+ if D.mem_project == Datatype.never_any_project then
+ false
+ else
+ (* [TODO] BUG: if [Data.mem_project f v] returns [true] and there are
+ several bindings for the key [k] of [v] (and [v] is not the last
+ added binding) *)
+ let found =
+ H.fold
+ (fun k v l ->
+ if H.Key.mem_project f k || Data.mem_project f v then k :: l
+ else l)
+ h
+ []
+ in
+ List.iter (H.remove h) found;
+ found <> []
+ in
+ (* Format.printf "DONE@.";*)
+ x
+ end)
+ (struct include Info let unique_name = name end)
let clear () = H.clear !state
let length () = H.length !state
@@ -605,9 +605,9 @@ sig
end
module Weak_hashtbl
- (W: Sub_caml_weak_hashtbl)
- (Data: Datatype.S with type t = W.data)
- (Info: Info_with_size) =
+ (W: Sub_caml_weak_hashtbl)
+ (Data: Datatype.S with type t = W.data)
+ (Info: Info_with_size) =
struct
type data = W.data
@@ -617,25 +617,25 @@ struct
let state = ref (create ())
include Register
- (Datatype.Weak(W)(Data))
- (struct
- type t = W.t
- let create = create
- let clear = W.clear
- let get () = !state
- let set x = state := x
- let clear_some_projects f h =
- if Data.mem_project == Datatype.never_any_project then
- false
- else
- let found =
- W.fold
- (fun k l -> if Data.mem_project f k then k :: l else l) h []
- in
- List.iter (W.remove h) found;
- found <> []
- end)
- (struct include Info let unique_name = name end)
+ (Datatype.Weak(W)(Data))
+ (struct
+ type t = W.t
+ let create = create
+ let clear = W.clear
+ let get () = !state
+ let set x = state := x
+ let clear_some_projects f h =
+ if Data.mem_project == Datatype.never_any_project then
+ false
+ else
+ let found =
+ W.fold
+ (fun k l -> if Data.mem_project f k then k :: l else l) h []
+ in
+ List.iter (W.remove h) found;
+ found <> []
+ end)
+ (struct include Info let unique_name = name end)
let merge k = W.merge !state k
let add k = W.add !state k
@@ -654,34 +654,34 @@ module Caml_weak_hashtbl(Data: Datatype.S) =
Weak_hashtbl(Weak.Make(Data))(Data)
module Hashconsing_tbl_weak
- (Data: sig
- include Datatype.S
- val equal_internal: t -> t -> bool
- val hash_internal: t -> int
- val initial_values: t list
- end)
- (Info: Info_with_size)
- =
+ (Data: sig
+ include Datatype.S
+ val equal_internal: t -> t -> bool
+ val hash_internal: t -> int
+ val initial_values: t list
+ end)
+ (Info: Info_with_size)
+=
struct
(* OCaml module typing requires to name this module. Too bad :-( *)
module W = struct
include Weak.Make
- (struct
- include Data
- let equal = Data.equal_internal
- let hash = Data.hash_internal
- end)
+ (struct
+ include Data
+ let equal = Data.equal_internal
+ let hash = Data.hash_internal
+ end)
let add_initial_values h =
-(* Format.printf "adding initial values for %s@." Info.name;*)
+ (* Format.printf "adding initial values for %s@." Info.name;*)
List.iter
(fun vi ->
let _r = merge h vi in
(* (* Check that we do not add the value twice, which is probably a
bug in the calling interface *)
- assert (r == vi) *) ())
+ assert (r == vi) *) ())
Data.initial_values
let create size =
@@ -715,29 +715,29 @@ struct
end
module Hashconsing_tbl_not_weak
- (Data: sig
- include Datatype.S
- val equal_internal: t -> t -> bool
- val hash_internal: t -> int
- val initial_values: t list
- end)
- (Info: Info_with_size)
- =
+ (Data: sig
+ include Datatype.S
+ val equal_internal: t -> t -> bool
+ val hash_internal: t -> int
+ val initial_values: t list
+ end)
+ (Info: Info_with_size)
+=
struct
(* OCaml module typing requires to name this module. Too bad :-( *)
module W = struct
module HW = FCHashtbl.Make
- (struct
- include Data
- let equal = Data.equal_internal
- let hash = Data.hash_internal
- end)
-
+ (struct
+ include Data
+ let equal = Data.equal_internal
+ let hash = Data.hash_internal
+ end)
+
type data = Data.t
type t = data HW.t
-
+
let merge h v =
try HW.find h v
with Not_found ->
@@ -745,7 +745,7 @@ struct
v
let count = HW.length
-
+
let add_initial_values h =
List.iter (fun vi -> let _r = merge h vi in ()) Data.initial_values
@@ -764,7 +764,7 @@ struct
let find_all = HW.find_all
let find = HW.find
let remove = HW.remove
- let add h v = HW.replace h v v
+ let add h v = HW.replace h v v
end
@@ -779,14 +779,14 @@ module type Hashconsing_tbl =
val equal_internal: t -> t -> bool
val hash_internal: t -> int
val initial_values: t list
- end) ->
+ end) ->
functor (Info: Info_with_size) ->
Weak_hashtbl with type data = Data.t
module Hashconsing_tbl =
(val if Cmdline.deterministic
- then (module Hashconsing_tbl_not_weak: Hashconsing_tbl)
- else (module Hashconsing_tbl_weak: Hashconsing_tbl))
+ then (module Hashconsing_tbl_not_weak: Hashconsing_tbl)
+ else (module Hashconsing_tbl_weak: Hashconsing_tbl))
(* ************************************************************************* *)
(** {3 Counters} *)
@@ -806,27 +806,27 @@ module SharedCounter(Info : sig val name : string end) = struct
module Cpt =
Register
(struct
- include Datatype.Int
- let descr =
- Descr.transform
- Descr.t_int
- (fun n ->
- cpt := Extlib.max_cpt n !cpt;
- !cpt)
- end)
+ include Datatype.Int
+ let descr =
+ Descr.transform
+ Descr.t_int
+ (fun n ->
+ cpt := Extlib.max_cpt n !cpt;
+ !cpt)
+ end)
(struct
- type t = int
- let create () = !cpt
- let clear _ = ()
- let get () = !cpt
- let set _ = ()
- let clear_some_projects _ _ = false
- end)
+ type t = int
+ let create () = !cpt
+ let clear _ = ()
+ let get () = !cpt
+ let set _ = ()
+ let clear_some_projects _ _ = false
+ end)
(struct
- let name = Info.name
- let unique_name = Info.name
- let dependencies = []
- end)
+ let name = Info.name
+ let unique_name = Info.name
+ let dependencies = []
+ end)
let next () = incr cpt ; !cpt
let get () = !cpt
@@ -842,28 +842,28 @@ module Counter(Info : sig val name : string end) = struct
module Cpt =
Register
(struct
- include Datatype.Ref(Datatype.Int)
- let descr =
- Descr.transform
- (Descr.t_ref Descr.t_int)
- (fun n ->
- let r = !cpt in
- r := Extlib.max_cpt !n !r;
- r)
- end)
+ include Datatype.Ref(Datatype.Int)
+ let descr =
+ Descr.transform
+ (Descr.t_ref Descr.t_int)
+ (fun n ->
+ let r = !cpt in
+ r := Extlib.max_cpt !n !r;
+ r)
+ end)
(struct
- type t = int ref
- let create = create
- let clear x = x := 0
- let get () = !cpt
- let set x = cpt := x
- let clear_some_projects _ _ = false
- end)
+ type t = int ref
+ let create = create
+ let clear x = x := 0
+ let get () = !cpt
+ let set x = cpt := x
+ let clear_some_projects _ _ = false
+ end)
(struct
- let name = Info.name
- let unique_name = Info.name
- let dependencies = []
- end)
+ let name = Info.name
+ let unique_name = Info.name
+ let dependencies = []
+ end)
let next () = incr !cpt ; !(!cpt)
let get () = !(!cpt)
@@ -890,26 +890,26 @@ module Queue(Data: Datatype.S)(Info: Info) = struct
let state = ref (Queue.create ())
include Register
- (Datatype.Queue(Data))
- (struct
- type t = elt Queue.t
- let create = Queue.create
- let clear = Queue.clear
- let get () = !state
- let set x = state := x
- let clear_some_projects f q =
- if Data.mem_project == Datatype.never_any_project then
- false
- else
- (* cannot remove a single element from a queue *)
- try
- Queue.iter (fun x -> if Data.mem_project f x then raise Exit) q;
- false
- with Exit ->
- clear q;
- true
- end)
- (struct include Info let unique_name = name end)
+ (Datatype.Queue(Data))
+ (struct
+ type t = elt Queue.t
+ let create = Queue.create
+ let clear = Queue.clear
+ let get () = !state
+ let set x = state := x
+ let clear_some_projects f q =
+ if Data.mem_project == Datatype.never_any_project then
+ false
+ else
+ (* cannot remove a single element from a queue *)
+ try
+ Queue.iter (fun x -> if Data.mem_project f x then raise Exit) q;
+ false
+ with Exit ->
+ clear q;
+ true
+ end)
+ (struct include Info let unique_name = name end)
let add x = Queue.add x !state
let iter f = Queue.iter f !state
@@ -942,27 +942,27 @@ struct
let state = ref (Array.make 0 Info.default)
include Register
- (Datatype.Array(Data))
- (struct
- type t = elt array
- let create () = Array.make 0 Info.default
- let clear v = Array.iteri (fun i _ -> v.(i) <- Info.default) v
- let get () = !state
- let set x = state := x
- let clear_some_projects f q =
- if Data.mem_project == Datatype.never_any_project then
- false
- else
- let removed = ref false in
- Array.iteri
- (fun i x -> if Data.mem_project f x then begin
- !state.(i) <- Info.default;
- removed := true;
- end
- ) q;
- !removed
- end)
- (struct include Info let unique_name = name end)
+ (Datatype.Array(Data))
+ (struct
+ type t = elt array
+ let create () = Array.make 0 Info.default
+ let clear v = Array.iteri (fun i _ -> v.(i) <- Info.default) v
+ let get () = !state
+ let set x = state := x
+ let clear_some_projects f q =
+ if Data.mem_project == Datatype.never_any_project then
+ false
+ else
+ let removed = ref false in
+ Array.iteri
+ (fun i x -> if Data.mem_project f x then begin
+ !state.(i) <- Info.default;
+ removed := true;
+ end
+ ) q;
+ !removed
+ end)
+ (struct include Info let unique_name = name end)
let length () = Array.length !state
let set_length i = state := Array.make i Info.default
@@ -985,7 +985,7 @@ let apply_once name dep f =
(struct
let dependencies = dep
let name = name
- end)
+ end)
in
(fun () ->
if First.get () then begin
@@ -994,7 +994,7 @@ let apply_once name dep f =
f ();
if First.get () then First.set false
(* assert
- (verify (First.get () = false)
+ (verify (First.get () = false)
"%s is supposed to be applied once, but resets itself its status"
name) *)
with exn ->
diff --git a/src/libraries/project/state_builder.mli b/src/libraries/project/state_builder.mli
index 91ad1c1635c6ed274b68cb988a7311850f77188d..0815a483f3ebfb42e5a03b50d213519cb78c8e8d 100644
--- a/src/libraries/project/state_builder.mli
+++ b/src/libraries/project/state_builder.mli
@@ -47,7 +47,7 @@ end
module type S = sig
val self: State.t
- (** The kind of the registered state. *)
+ (** The kind of the registered state. *)
val name: string
@@ -65,7 +65,7 @@ module type S = sig
val add_hook_on_update: (Datatype.t -> unit) -> unit
(** Add an hook which is applied each time (just before) the project library
- changes the local value of the state.
+ changes the local value of the state.
@since Nitrogen-20111001 *)
val howto_marshal: (Datatype.t -> 'a) -> ('a -> Datatype.t) -> unit
@@ -84,9 +84,9 @@ end
required information.
@plugin development guide *)
module Register
- (Datatype: Datatype.S)
- (Local_state: State.Local with type t = Datatype.t)
- (Info: sig include Info val unique_name: string end)
+ (Datatype: Datatype.S)
+ (Local_state: State.Local with type t = Datatype.t)
+ (Info: sig include Info val unique_name: string end)
: S with module Datatype = Datatype
(* ************************************************************************* *)
@@ -103,38 +103,38 @@ module Register
module type Ref = sig
include S
type data
- (** Type of the referenced value. *)
+ (** Type of the referenced value. *)
val set: data -> unit
- (** Change the referenced value. *)
+ (** Change the referenced value. *)
val get: unit -> data
- (** Get the referenced value. *)
+ (** Get the referenced value. *)
val clear: unit -> unit
- (** Reset the reference to its default value. *)
+ (** Reset the reference to its default value. *)
end
(** @plugin development guide *)
module Ref
- (Data:Datatype.S)
- (Info:sig
- include Info
- val default: unit -> Data.t
- end)
+ (Data:Datatype.S)
+ (Info:sig
+ include Info
+ val default: unit -> Data.t
+ end)
: Ref with type data = Data.t
(** Output signature of [Option_ref]. Note that [get] will raise [Not_found]
if the stored data is [None]. Use [get_option] if you want to have
access to the option.
- *)
+*)
module type Option_ref = sig
include Ref
val memo: ?change:(data -> data) -> (unit -> data) -> data
- (** Memoization. Compute on need the stored value.
- If the data is already computed (i.e. is not [None]),
- it is possible to change with [change]. *)
+ (** Memoization. Compute on need the stored value.
+ If the data is already computed (i.e. is not [None]),
+ it is possible to change with [change]. *)
val map: (data -> data) -> data option
val may: (data -> unit) -> unit
val get_option : unit -> data option
- (** @since Beryllium-20090901 *)
+ (** @since Beryllium-20090901 *)
end
(** Build a reference on an option. *)
@@ -192,56 +192,56 @@ module Float_ref(Info:sig include Info val default: unit -> float end) :
module type Weak_hashtbl = sig
include S
- (** Hashtbl are a standard computation.
- BUT it is INCORRECT to use projectified hashtables if keys have a
- custom [rehash] function (see {!Project.DATATYPE_OUTPUT.rehash}) *)
+ (** Hashtbl are a standard computation.
+ BUT it is INCORRECT to use projectified hashtables if keys have a
+ custom [rehash] function (see {!Project.DATATYPE_OUTPUT.rehash}) *)
type data
- (** @since Boron-20100401 *)
+ (** @since Boron-20100401 *)
val merge: data -> data
- (** [merge x] returns an instance of [x] found in the table if any, or else
- adds [x] and return [x].
- @since Boron-20100401 *)
+ (** [merge x] returns an instance of [x] found in the table if any, or else
+ adds [x] and return [x].
+ @since Boron-20100401 *)
val add: data -> unit
- (** [add x] adds [x] to the table. If there is already an instance of [x],
- it is unspecified which one will be returned by subsequent calls to
- [find] and [merge].
- @since Boron-20100401 *)
+ (** [add x] adds [x] to the table. If there is already an instance of [x],
+ it is unspecified which one will be returned by subsequent calls to
+ [find] and [merge].
+ @since Boron-20100401 *)
val clear: unit -> unit
- (** Clear the table.
- @since Boron-20100401 *)
+ (** Clear the table.
+ @since Boron-20100401 *)
val count: unit -> int
- (** Length of the table.
- @since Boron-20100401 *)
+ (** Length of the table.
+ @since Boron-20100401 *)
val iter: (data -> unit) -> unit
- (** @since Boron-20100401 *)
+ (** @since Boron-20100401 *)
val fold: (data -> 'a -> 'a) -> 'a -> 'a
- (** @since Boron-20100401 *)
+ (** @since Boron-20100401 *)
val find: data -> data
- (** [find x] returns an instance of [x] found in table.
- @Raise Not_found if there is no such element.
- @since Boron-20100401 *)
+ (** [find x] returns an instance of [x] found in table.
+ @Raise Not_found if there is no such element.
+ @since Boron-20100401 *)
val find_all: data -> data list
- (** [find_all x] returns a list of all the instances of [x] found in t.
- @since Boron-20100401 *)
+ (** [find_all x] returns a list of all the instances of [x] found in t.
+ @since Boron-20100401 *)
val mem: data -> bool
- (** [mem x] returns [true] if there is at least one instance of [x] in the
- table, [false] otherwise.
- @since Boron-20100401 *)
+ (** [mem x] returns [true] if there is at least one instance of [x] in the
+ table, [false] otherwise.
+ @since Boron-20100401 *)
val remove: data -> unit
- (** [remove x] removes from the table one instance of [x]. Does nothing if
- there is no instance of [x].
- @since Boron-20100401 *)
+ (** [remove x] removes from the table one instance of [x]. Does nothing if
+ there is no instance of [x].
+ @since Boron-20100401 *)
end
@@ -249,7 +249,7 @@ end
[W].
@since Boron-20100401 *)
module Weak_hashtbl
- (W: Weak.S)(Data: Datatype.S with type t = W.data)(Info: Info_with_size) :
+ (W: Weak.S)(Data: Datatype.S with type t = W.data)(Info: Info_with_size) :
Weak_hashtbl with type data = W.data
(** Build a weak hashtbl over a datatype [Data] by using [Weak.Make] provided
@@ -272,7 +272,7 @@ module type Hashconsing_tbl =
val initial_values: t list
(** Pre-existing values stored in the built table and shared by all
existing projects. *)
- end) ->
+ end) ->
functor (Info: Info_with_size) ->
Weak_hashtbl with type data = Data.t
@@ -305,20 +305,20 @@ module Hashconsing_tbl: Hashconsing_tbl
(** Output signature of builders of hashtables. *)
module type Hashtbl = sig
include S
- (** Hashtbl are a standard computation.
- BUT that is INCORRECT to use projectified hashtables if keys have a
- custom [rehash] function (see {!Project.DATATYPE_OUTPUT.rehash}) *)
+ (** Hashtbl are a standard computation.
+ BUT that is INCORRECT to use projectified hashtables if keys have a
+ custom [rehash] function (see {!Project.DATATYPE_OUTPUT.rehash}) *)
type key
type data
val replace: key -> data -> unit
- (** Add a new binding. The previous one is removed. *)
+ (** Add a new binding. The previous one is removed. *)
val add: key -> data -> unit
- (** Add a new binding. The previous one is only hidden. *)
+ (** Add a new binding. The previous one is only hidden. *)
val clear: unit -> unit
- (** Clear the table. *)
+ (** Clear the table. *)
val length: unit -> int
- (** Length of the table. *)
+ (** Length of the table. *)
val iter: (key -> data -> unit) -> unit
val iter_sorted:
?cmp:(key -> key -> int) -> (key -> data -> unit) -> unit
@@ -326,26 +326,26 @@ module type Hashtbl = sig
val fold_sorted:
?cmp:(key -> key -> int) -> (key -> data -> 'a -> 'a) -> 'a -> 'a
val memo: ?change:(data -> data) -> (key -> data) -> key -> data
- (** Memoization. Compute on need the data associated to a given key using
- the given function.
- If the data is already computed, it is possible to change with
- [change]. *)
+ (** Memoization. Compute on need the data associated to a given key using
+ the given function.
+ If the data is already computed, it is possible to change with
+ [change]. *)
val find: key -> data
- (** Return the current binding of the given key.
- @raise Not_found if the key is not in the table. *)
+ (** Return the current binding of the given key.
+ @raise Not_found if the key is not in the table. *)
val find_all: key -> data list
- (** Return the list of all data associated with the given key. *)
+ (** Return the list of all data associated with the given key. *)
val mem: key -> bool
val remove: key -> unit
end
(** @plugin development guide *)
module Hashtbl
- (H: Datatype.Hashtbl (** hashtable implementation *))
- (Data: Datatype.S (** datatype for values stored in the table *))
- (Info: Info_with_size) :
+ (H: Datatype.Hashtbl (** hashtable implementation *))
+ (Data: Datatype.S (** datatype for values stored in the table *))
+ (Info: Info_with_size) :
Hashtbl with type key = H.key and type data = Data.t
- and module Datatype = H.Make(Data)
+ and module Datatype = H.Make(Data)
module Int_hashtbl(Data: Datatype.S)(Info:Info_with_size):
Hashtbl with type key = int and type data = Data.t
@@ -366,7 +366,7 @@ module type Set_ref = sig
val iter: (elt -> unit) -> unit
end
-module Set_ref(S: Datatype.Set)(Info: Info)
+module Set_ref(S: Datatype.Set)(Info: Info)
: Set_ref with type elt = S.elt and type data = S.t
(* ************************************************************************* *)
@@ -431,7 +431,7 @@ module Proxy : sig
(** Add some states in the given proxy. *)
val get: t -> State.t
-(** Getting the state corresponding to a proxy. *)
+ (** Getting the state corresponding to a proxy. *)
end
@@ -442,10 +442,10 @@ end
module type Counter = sig
val next : unit -> int
- (** Increments the counter and returns a fresh value *)
+ (** Increments the counter and returns a fresh value *)
val get: unit -> int
- (** @return the current value of the counter, without incrementing it.
+ (** @return the current value of the counter, without incrementing it.
@since Fluorine-20130401 *)
val self: State.t
@@ -501,16 +501,16 @@ module Hashcons
val apply_once:
string -> State.t list -> (unit -> unit) -> (unit -> unit) * State.t
- (** [apply_once name dep f] returns a closure applying [f] only once and the
- state internally used. [name] and [dep] are respectively the name and
- the dependencies of the local state created by this function. Should
- be used partially applied. If [f] raises an exception, then it is
- considered as not applied. *)
+(** [apply_once name dep f] returns a closure applying [f] only once and the
+ state internally used. [name] and [dep] are respectively the name and
+ the dependencies of the local state created by this function. Should
+ be used partially applied. If [f] raises an exception, then it is
+ considered as not applied. *)
(** @since Fluorine-20130401 *)
-module States: sig
+module States: sig
- val iter:
+ val iter:
?prj:Project.t -> (string -> 'a Type.t -> 'a -> bool -> unit) -> unit
(** iterates a function [f] over all registered states. Arguments of [f] are
its name, its type value, its value for the given project
@@ -518,15 +518,15 @@ module States: sig
already computed. @since Fluorine-20130401 *)
val fold:
- ?prj:Project.t ->
+ ?prj:Project.t ->
(string -> 'a Type.t -> 'a -> bool -> 'acc -> 'acc) -> 'acc -> 'acc
(** As iter, but for folding.
@since Fluorine-20130401*)
val find:
?prj:Project.t -> string -> 'a Type.t -> 'a * bool
-(** @return the value of a state given by its name (and if it is computed), in
- the given project ([Project.current ()] by default) *)
+ (** @return the value of a state given by its name (and if it is computed), in
+ the given project ([Project.current ()] by default) *)
end
diff --git a/src/libraries/project/state_dependency_graph.ml b/src/libraries/project/state_dependency_graph.ml
index 7f0eaf0abaf8a334cee47cdd2d3f6022d1dbdd61..4db7fc68437273412b7199450d41c615955f9301 100644
--- a/src/libraries/project/state_dependency_graph.ml
+++ b/src/libraries/project/state_dependency_graph.ml
@@ -21,8 +21,8 @@
(**************************************************************************)
module type S = sig
- module G: Graph.Sig.G with type V.t = State.t
- and type E.t = State.t * State.t
+ module G: Graph.Sig.G with type V.t = State.t
+ and type E.t = State.t * State.t
val graph: G.t
val add_dependencies: from:State.t -> State.t list -> unit
val add_codependencies: onto:State.t -> State.t list -> unit
@@ -45,7 +45,7 @@ module Dependency_graph = Graph.Imperative.Digraph.ConcreteBidirectional(State)
module Static = struct
- module G = Dependency_graph
+ module G = Dependency_graph
let graph = Dependency_graph.create ~size:7 ()
let add_vertex graph v =
@@ -56,7 +56,7 @@ module Static = struct
assert (Dependency_graph.(mem_vertex graph v1 && mem_vertex graph v2));
Dependency_graph.add_edge graph v1 v2
- let add_dependencies ~from deps =
+ let add_dependencies ~from deps =
List.iter (add_edge graph from) deps
let add_codependencies ~onto codeps =
diff --git a/src/libraries/project/state_dependency_graph.mli b/src/libraries/project/state_dependency_graph.mli
index 6af18f0a7d3a1ae52fce5d2bcafd9d8057c726af..72ef9f42d718b5fd44ca19962fb5c350c2b5fb96 100644
--- a/src/libraries/project/state_dependency_graph.mli
+++ b/src/libraries/project/state_dependency_graph.mli
@@ -31,8 +31,8 @@
@since Carbon-20101201 *)
module type S = sig
- module G: Graph.Sig.G with type V.t = State.t
- and type E.t = State.t * State.t
+ module G: Graph.Sig.G with type V.t = State.t
+ and type E.t = State.t * State.t
val graph: G.t
val add_dependencies: from:State.t -> State.t list -> unit
diff --git a/src/libraries/project/state_selection.ml b/src/libraries/project/state_selection.ml
index a3084868f0f422f049d54045911e5fc954d774b0..d46270a28dac122a4a38962638bf1668c70f34b2 100644
--- a/src/libraries/project/state_selection.ml
+++ b/src/libraries/project/state_selection.ml
@@ -79,32 +79,32 @@ let mem (sel, _) s = match sel with
| Subset sel -> Selection.mem_vertex sel s
include Datatype.Make
-(struct
- include Datatype.Undefined
- type t = state_selection
- let name = "State_selection"
- let reprs = [ full; empty; singleton State.dummy ]
- let internal_pretty_code p_caller fmt (s, _) = match s with
- | Full -> Format.fprintf fmt "@[State_selection.full@]"
- | Subset sel ->
- match Selection.fold_vertex (fun s acc -> s :: acc) sel [] with
- | [] -> Format.fprintf fmt "@[State_selection.empty@]"
- | [ s ] ->
- let pp fmt =
- Format.fprintf fmt "@[<hv 2>State_selection.singleton@;%a@]"
- (State.internal_pretty_code Type.Call)
- s
- in
- Type.par p_caller Type.Call fmt pp
- | l ->
- let module D = Datatype.List(State) in
- let pp fmt =
- Format.fprintf fmt "@[<hv 2>State_selection.of_list@;%a@]"
- (D.internal_pretty_code Type.Call)
- l
- in
- Type.par p_caller Type.Call fmt pp
- end)
+ (struct
+ include Datatype.Undefined
+ type t = state_selection
+ let name = "State_selection"
+ let reprs = [ full; empty; singleton State.dummy ]
+ let internal_pretty_code p_caller fmt (s, _) = match s with
+ | Full -> Format.fprintf fmt "@[State_selection.full@]"
+ | Subset sel ->
+ match Selection.fold_vertex (fun s acc -> s :: acc) sel [] with
+ | [] -> Format.fprintf fmt "@[State_selection.empty@]"
+ | [ s ] ->
+ let pp fmt =
+ Format.fprintf fmt "@[<hv 2>State_selection.singleton@;%a@]"
+ (State.internal_pretty_code Type.Call)
+ s
+ in
+ Type.par p_caller Type.Call fmt pp
+ | l ->
+ let module D = Datatype.List(State) in
+ let pp fmt =
+ Format.fprintf fmt "@[<hv 2>State_selection.of_list@;%a@]"
+ (D.internal_pretty_code Type.Call)
+ l
+ in
+ Type.par p_caller Type.Call fmt pp
+ end)
module type S = sig
val with_dependencies: State.t -> t
@@ -132,19 +132,19 @@ module Static = struct
let rec visit acc v =
next_vertices
(fun v' acc ->
- let e = v, v' in
- if Selection.mem_edge_e acc e then acc
- else visit (Selection.add_edge_e acc e) v')
+ let e = v, v' in
+ if Selection.mem_edge_e acc e then acc
+ else visit (Selection.add_edge_e acc e) v')
State_dependency_graph.graph v acc
in
(* add [s] in the selection even if it has no ingoing/outgoing edges *)
visit (Selection.add_vertex Selection.empty s) s
- let with_dependencies s =
+ let with_dependencies s =
Subset (transitive_closure State_dependency_graph.G.fold_succ s),
WDependencies s
- let with_codependencies s =
+ let with_codependencies s =
Subset (transitive_closure State_dependency_graph.G.fold_pred s),
WCoDependencies s
@@ -164,17 +164,17 @@ module Static = struct
let selection =
State_dependency_graph.G.fold_vertex
(fun v acc ->
- if Selection.mem_vertex sel2 v then acc
- else Selection.add_vertex acc v)
+ if Selection.mem_vertex sel2 v then acc
+ else Selection.add_vertex acc v)
State_dependency_graph.graph
Selection.empty
in
let sel =
State_dependency_graph.G.fold_edges
(fun v1 v2 acc ->
- if Selection.mem_vertex sel2 v1 || Selection.mem_vertex sel2 v2
- then acc
- else Selection.add_edge acc v1 v2)
+ if Selection.mem_vertex sel2 v1 || Selection.mem_vertex sel2 v2
+ then acc
+ else Selection.add_edge acc v1 v2)
State_dependency_graph.graph
selection
in
@@ -205,22 +205,22 @@ module Static = struct
| Subset sel -> Selection.nb_vertex sel
let iter_succ f (sel, _) v = match sel with
- | Full ->
+ | Full ->
State_dependency_graph.G.iter_succ f State_dependency_graph.graph v
| Subset sel -> Selection.iter_succ f sel v
let fold_succ f (sel, _) v acc = match sel with
- | Full ->
+ | Full ->
State_dependency_graph.G.fold_succ f State_dependency_graph.graph v acc
| Subset sel -> Selection.fold_succ f sel v acc
let iter f (sel, _) = match sel with
- | Full ->
+ | Full ->
State_dependency_graph.G.iter_vertex f State_dependency_graph.graph
| Subset sel -> Selection.iter_vertex f sel
let fold f (sel, _) acc = match sel with
- | Full ->
+ | Full ->
State_dependency_graph.G.fold_vertex f State_dependency_graph.graph acc
| Subset sel -> Selection.fold_vertex f sel acc
@@ -246,9 +246,9 @@ module Static = struct
in
iter_in_order
(fun s ->
- Format.fprintf fmt "\t state %S%s@\n"
- (State.get_unique_name s)
- (if mem s then "" else "(\"" ^ State.get_name s ^ "\")"))
+ Format.fprintf fmt "\t state %S%s@\n"
+ (State.get_unique_name s)
+ (if mem s then "" else "(\"" ^ State.get_name s ^ "\")"))
sel;
Format.pp_print_flush fmt ()
diff --git a/src/libraries/project/state_selection.mli b/src/libraries/project/state_selection.mli
index 18cb5eaa72947d7cdd9b9ba361af952b0ef3d32b..6980cdf7efa25a14b2e22616ee3460bfee67dfcc 100644
--- a/src/libraries/project/state_selection.mli
+++ b/src/libraries/project/state_selection.mli
@@ -33,7 +33,7 @@ type t
(** Type of a state selection.
@since Carbon-20101201
@plugin development guide
- *)
+*)
val ty: t Type.t
(** Type value representing {!t}.
@@ -115,9 +115,9 @@ module type S = sig
@since Carbon-20101201 *)
val list_union: t list -> t
- (** Union of an arbitrary number of selection (0 gives an empty selection)
- @since Oxygen-20120901
- *)
+ (** Union of an arbitrary number of selection (0 gives an empty selection)
+ @since Oxygen-20120901
+ *)
val diff: t -> t -> t
(** Difference between two selections.
diff --git a/src/libraries/project/state_topological.mli b/src/libraries/project/state_topological.mli
index 800de0f84f38d4f7dcaf5b60408d02f5128c0b4a..3cd0c69365a757f2a770f2536376aef8be6244d1 100644
--- a/src/libraries/project/state_topological.mli
+++ b/src/libraries/project/state_topological.mli
@@ -41,7 +41,7 @@ end
module Make(G: G) : sig
val fold : (State.t -> 'a -> 'a) -> G.t -> 'a -> 'a
- (** [fold action g seed] allows iterating over the graph [g]
+ (** [fold action g seed] allows iterating over the graph [g]
in topological order. [action node accu] is called repeatedly,
where [node] is the node being visited, and [accu] is the result of
the [action]'s previous invocation, if any, and [seed] otherwise.
@@ -49,9 +49,9 @@ module Make(G: G) : sig
every node in the cycles will be presented exactly once. *)
val iter : (State.t -> unit) -> G.t -> unit
- (** [iter action] calls [action node] repeatedly. Nodes are (again)
- presented to [action] in topological order.
- The order is the same as for [fold]. *)
+ (** [iter action] calls [action node] repeatedly. Nodes are (again)
+ presented to [action] in topological order.
+ The order is the same as for [fold]. *)
end
diff --git a/src/libraries/stdlib/FCHashtbl.mli b/src/libraries/stdlib/FCHashtbl.mli
index abe0525d113292aff8f0b65eb0483efd600b05f2..49d287f134530114d1e65b5a33b3638b7e132c1c 100644
--- a/src/libraries/stdlib/FCHashtbl.mli
+++ b/src/libraries/stdlib/FCHashtbl.mli
@@ -32,21 +32,21 @@ module type S = sig
val iter_sorted:
?cmp:(key -> key -> int) -> (key -> 'a -> unit) -> 'a t -> unit
- (** Iter on the hashtbl, but respecting the order on keys induced
- by [cmp]. Use [Stdlib.compare] if [cmp] not given.
+ (** Iter on the hashtbl, but respecting the order on keys induced
+ by [cmp]. Use [Stdlib.compare] if [cmp] not given.
- If the table contains several bindings for the same key, they
- are passed to [f] in reverse order of introduction, that is,
- the most recent binding is passed first. *)
+ If the table contains several bindings for the same key, they
+ are passed to [f] in reverse order of introduction, that is,
+ the most recent binding is passed first. *)
val fold_sorted:
?cmp:(key -> key -> int) -> (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
- (** Fold on the hashtbl, but respecting the order on keys induced
- by [cmp]. Use [Stdlib.compare] if [cmp] not given.
+ (** Fold on the hashtbl, but respecting the order on keys induced
+ by [cmp]. Use [Stdlib.compare] if [cmp] not given.
- If the table contains several bindings for the same key, they
- are passed to [f] in reverse order of introduction, that is,
- the most recent binding is passed first. *)
+ If the table contains several bindings for the same key, they
+ are passed to [f] in reverse order of introduction, that is,
+ the most recent binding is passed first. *)
val iter_sorted_by_entry:
cmp:((key * 'a) -> (key * 'a) -> int) -> (key -> 'a -> unit) -> 'a t -> unit
@@ -60,9 +60,9 @@ module type S = sig
cmp:('a -> 'a -> int) -> (key -> 'a -> unit) -> 'a t -> unit
val fold_sorted_by_value:
cmp:('a -> 'a -> int) -> (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
-(** Iter or fold on the hashtable, respecting the order on entries
- given by [cmp]. The relative order for entries whose values is
- equal according to cmp, is not specified. *)
+ (** Iter or fold on the hashtable, respecting the order on entries
+ given by [cmp]. The relative order for entries whose values is
+ equal according to cmp, is not specified. *)
val find_opt: 'a t -> key -> 'a option
val find_def: 'a t -> key -> 'a -> 'a
@@ -80,4 +80,3 @@ module Make(H: Hashtbl.HashedType) : S with type key = H.t
val hash : 'a -> int
val hash_param : int -> int -> 'a -> int
-
diff --git a/src/libraries/stdlib/extlib.ml b/src/libraries/stdlib/extlib.ml
index 00adc72190a3f3aac6a4e38f49809dc067f9255f..51d4e1917ed6b063fe0d72ed0b84770f81e47a39 100644
--- a/src/libraries/stdlib/extlib.ml
+++ b/src/libraries/stdlib/extlib.ml
@@ -44,9 +44,9 @@ let number_to_color n =
let number = ref n in
for _i = 0 to 7 do
color := (!color lsl 1) +
- (if !number land 1 <> 0 then 1 else 0) +
- (if !number land 2 <> 0 then 256 else 0) +
- (if !number land 4 <> 0 then 65536 else 0);
+ (if !number land 1 <> 0 then 1 else 0) +
+ (if !number land 2 <> 0 then 256 else 0) +
+ (if !number land 4 <> 0 then 65536 else 0);
number := !number lsr 3
done;
!color
@@ -148,25 +148,25 @@ let rec list_compare cmp_elt l1 l2 =
if l1 == l2 then 0
else
match l1, l2 with
- | [], [] -> assert false (* included in l1 == l2 above *)
- | [], _ :: _ -> -1
- | _ :: _, [] -> 1
- | v1::r1, v2::r2 ->
- let c = cmp_elt v1 v2 in
- if c = 0 then list_compare cmp_elt r1 r2 else c
+ | [], [] -> assert false (* included in l1 == l2 above *)
+ | [], _ :: _ -> -1
+ | _ :: _, [] -> 1
+ | v1::r1, v2::r2 ->
+ let c = cmp_elt v1 v2 in
+ if c = 0 then list_compare cmp_elt r1 r2 else c
let opt_of_list =
function
- | [] -> None
- | [a] -> Some a
- | _ -> raise (Invalid_argument "Extlib.opt_of_list")
+ | [] -> None
+ | [a] -> Some a
+ | _ -> raise (Invalid_argument "Extlib.opt_of_list")
let rec find_opt f = function
| [] -> raise Not_found
| e :: q ->
- match f e with
- | None -> find_opt f q
- | Some v -> v
+ match f e with
+ | None -> find_opt f q
+ | Some v -> v
let iteri f l = let i = ref 0 in List.iter (fun x -> f !i x; incr i) l
@@ -227,14 +227,14 @@ let list_slice ?(first = 0) ?last l =
let opt_fold f o b =
match o with
- | None -> b
- | Some a -> f a b
+ | None -> b
+ | Some a -> f a b
let merge_opt f k o1 o2 =
match o1,o2 with
- | None, None -> None
- | Some x, None | None, Some x -> Some x
- | Some x1, Some x2 -> Some (f k x1 x2)
+ | None, None -> None
+ | Some x, None | None, Some x -> Some x
+ | Some x1, Some x2 -> Some (f k x1 x2)
let opt_filter f = function
| None -> None
diff --git a/src/libraries/stdlib/extlib.mli b/src/libraries/stdlib/extlib.mli
index 66405c3253636fe80120c608c3c69b563cf10451..d942da8805cb4c961ab095e56b770c8bc00003d6 100644
--- a/src/libraries/stdlib/extlib.mli
+++ b/src/libraries/stdlib/extlib.mli
@@ -24,17 +24,17 @@
This module does not depend of any of frama-c module. *)
val nop: 'a -> unit
- (** Do nothing. *)
+(** Do nothing. *)
external id: 'a -> 'a = "%identity"
- (** identity function.
- @since Oxygen-20120901
- *)
+(** identity function.
+ @since Oxygen-20120901
+*)
val adapt_filename: string -> string
- (** Ensure that the given filename has the extension "cmo" in bytecode
- and "cmxs" in native *)
+(** Ensure that the given filename has the extension "cmo" in bytecode
+ and "cmxs" in native *)
val max_cpt: int -> int -> int
(** [max_cpt t1 t2] returns the maximum of [t1] and [t2] wrt the total ordering
@@ -58,18 +58,18 @@ val mk_labeled_fun: string -> 'a
@raise Unregistered_function when not properly initialized *)
val mk_fun: string -> ('a -> 'b) ref
- (** Build a reference to an uninitialized function
- @raise Unregistered_function when not properly initialized *)
+(** Build a reference to an uninitialized function
+ @raise Unregistered_function when not properly initialized *)
(* ************************************************************************* *)
(** {2 Function combinators} *)
(* ************************************************************************* *)
val ($) : ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c
- (** Composition. *)
+(** Composition. *)
val swap: ('a -> 'b -> 'c) -> 'b -> 'a -> 'c
- (** Swap arguments. *)
+(** Swap arguments. *)
val uncurry: ('a -> 'b -> 'c) -> ('a * 'b) -> 'c
@@ -82,28 +82,28 @@ val iter_uncurry2:
(* ************************************************************************* *)
val as_singleton: 'a list -> 'a
- (** returns the unique element of a singleton list.
- @raise Invalid_argument on a non singleton list. *)
+(** returns the unique element of a singleton list.
+ @raise Invalid_argument on a non singleton list. *)
val last: 'a list -> 'a
- (** returns the last element of a list.
- @raise Invalid_argument on an empty list
- @since Nitrogen-20111001 *)
+(** returns the last element of a list.
+ @raise Invalid_argument on an empty list
+ @since Nitrogen-20111001 *)
val filter_out: ('a -> bool) -> 'a list -> 'a list
- (** Filter out elements that pass the test *)
+(** Filter out elements that pass the test *)
val replace: ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list
- (** [replace cmp x l] replaces the first element [y] of [l] such that
- [cmp x y] is true by [x]. If no such element exists, [x] is added
- at the tail of [l].
- @since Neon-20140301
- *)
+(** [replace cmp x l] replaces the first element [y] of [l] such that
+ [cmp x y] is true by [x]. If no such element exists, [x] is added
+ at the tail of [l].
+ @since Neon-20140301
+*)
val filter_map: ('a -> bool) -> ('a -> 'b) -> 'a list -> 'b list
val filter_map': ('a -> 'b) -> ('b -> bool) -> 'a list -> 'b list
val filter_map_opt: ('a -> 'b option) -> 'a list -> 'b list
- (** Combines [filter] and [map]. *)
+(** Combines [filter] and [map]. *)
val fold_map: ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list
(** Combines [fold_left] and [map] *)
@@ -116,56 +116,56 @@ val product_fold: ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a
*)
val product: ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
- (** [product f l1 l2] applies [f] to all the pairs of an elt of [l1] and
- an element of [l2].
- *)
+(** [product f l1 l2] applies [f] to all the pairs of an elt of [l1] and
+ an element of [l2].
+*)
val find_index: ('a -> bool) -> 'a list -> int
- (** returns the index (starting at 0) of the first element verifying the
- condition
- @raise Not_found if no element in the list matches the condition
- *)
+(** returns the index (starting at 0) of the first element verifying the
+ condition
+ @raise Not_found if no element in the list matches the condition
+*)
val list_compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int
- (** Generic list comparison function, where the elements are compared
- with the specified function
- @since Boron-20100401 *)
+(** Generic list comparison function, where the elements are compared
+ with the specified function
+ @since Boron-20100401 *)
val opt_of_list: 'a list -> 'a option
- (** converts a list with 0 or 1 element into an option.
- @raise Invalid_argument on lists with more than one argument
- @since Oxygen-20120901 *)
+(** converts a list with 0 or 1 element into an option.
+ @raise Invalid_argument on lists with more than one argument
+ @since Oxygen-20120901 *)
val find_opt : ('a -> 'b option) -> 'a list -> 'b
[@@deprecated "Use List.find_opt instead."]
- (** [find_option p l] returns the value [p e], [e] being the first
- element of [l] such that [p e] is not [None]. Raise [Not_found] if there
- is no such value the list l.
+(** [find_option p l] returns the value [p e], [e] being the first
+ element of [l] such that [p e] is not [None]. Raise [Not_found] if there
+ is no such value the list l.
- @since Nitrogen-20111001
- @deprecated 18.0-Argon use [List.find_opt] instead *)
+ @since Nitrogen-20111001
+ @deprecated 18.0-Argon use [List.find_opt] instead *)
val iteri: (int -> 'a -> unit) -> 'a list -> unit
- (** Same as iter, but the function to be applied take also as argument the
- index of the element (starting from 0). Tail-recursive
- @since Nitrogen-20111001 *)
+(** Same as iter, but the function to be applied take also as argument the
+ index of the element (starting from 0). Tail-recursive
+ @since Nitrogen-20111001 *)
val mapi: (int -> 'a -> 'b) -> 'a list -> 'b list
- (** Same as map, but the function to be applied take also as argument the
- index of the element (starting from 0). Tail-recursive
- @since Oxygen-20120901 *)
+(** Same as map, but the function to be applied take also as argument the
+ index of the element (starting from 0). Tail-recursive
+ @since Oxygen-20120901 *)
val sort_unique: ('a -> 'a -> int) -> 'a list -> 'a list
- (** Same as List.sort , but also remove duplicates.
- @deprecated use List.sort_uniq instead
- *)
+(** Same as List.sort , but also remove duplicates.
+ @deprecated use List.sort_uniq instead
+*)
val subsets: int -> 'a list -> 'a list list
- (** [subsets k l] computes the combinations of [k] elements from list [l].
- E.g. subsets 2 [1;2;3;4] = [[1;2];[1;3];[1;4];[2;3];[2;4];[3;4]].
- This function preserves the order of the elements in [l] when
- computing the sublists. [l] should not contain duplicates.
- @since Aluminium-20160501 *)
+(** [subsets k l] computes the combinations of [k] elements from list [l].
+ E.g. subsets 2 [1;2;3;4] = [[1;2];[1;3];[1;4];[2;3];[2;4];[3;4]].
+ This function preserves the order of the elements in [l] when
+ computing the sublists. [l] should not contain duplicates.
+ @since Aluminium-20160501 *)
val list_first_n : int -> 'a list -> 'a list
(** [list_first_n n l] returns the first [n] elements of the list. Tail
@@ -193,12 +193,12 @@ val opt_fold: ('a -> 'b -> 'b) -> 'a option -> 'b -> 'b
(** [merge f k a b] returns
- [None] if both [a] and [b] are [None]
- - [Some a'] (resp. [b'] if [b] (resp [a]) is [None]
+ - [Some a'] (resp. [b'] if [b] (resp [a]) is [None]
and [a] (resp. [b]) is [Some]
- [f k a' b'] if both [a] and [b] are [Some]
-
+
It is mainly intended to be used with Map.merge
-
+
@since Oxygen-20120901
*)
val merge_opt:
@@ -216,7 +216,7 @@ val the: exn:exn -> 'a option -> 'a
@plugin development guide *)
val opt_hash: ('a -> int) -> 'a option -> int
- (** @since Sodium-20150201 *)
+(** @since Sodium-20150201 *)
(* ************************************************************************* *)
(** {2 Booleans} *)
@@ -230,49 +230,49 @@ val xor: bool -> bool -> bool
(* ************************************************************************* *)
val string_prefix: ?strict:bool -> string -> string -> bool
- (** [string_prefix ~strict p s] returns [true] if and only if [p] is a
- prefix of the string [s]. If [strict] is true, the prefix must be strict
- (that is, [s] must moreover be strictly longer than [p]. [strict]
- is false by default.
- @since Boron-20100401 *)
+(** [string_prefix ~strict p s] returns [true] if and only if [p] is a
+ prefix of the string [s]. If [strict] is true, the prefix must be strict
+ (that is, [s] must moreover be strictly longer than [p]. [strict]
+ is false by default.
+ @since Boron-20100401 *)
val string_del_prefix: ?strict:bool -> string -> string -> string option
- (** [string_del_prefix ~strict p s] returns [None] if [p] is not a prefix of
- [s] and Some [s1] iff [s=p^s1].
- @since Oxygen-20120901 *)
+(** [string_del_prefix ~strict p s] returns [None] if [p] is not a prefix of
+ [s] and Some [s1] iff [s=p^s1].
+ @since Oxygen-20120901 *)
val string_suffix: ?strict:bool -> string -> string -> bool
- (** [string_suffix ~strict suf s] returns [true] iff [suf] is a suffix of
- string [s]. [strict], which defaults to [false], indicates whether [s]
- should be strictly longer than [p].
- @since Aluminium-20160501
- *)
+(** [string_suffix ~strict suf s] returns [true] iff [suf] is a suffix of
+ string [s]. [strict], which defaults to [false], indicates whether [s]
+ should be strictly longer than [p].
+ @since Aluminium-20160501
+*)
val string_del_suffix: ?strict:bool -> string -> string -> string option
- (** [string_del_suffix ~strict suf s] returns [Some s1] when [s = s1 ^ suf]
- and None of [suf] is not a suffix of [s].
- @since Aluminium-20160501
- *)
+(** [string_del_suffix ~strict suf s] returns [Some s1] when [s = s1 ^ suf]
+ and None of [suf] is not a suffix of [s].
+ @since Aluminium-20160501
+*)
val string_split: string -> int -> string * string
-(** [string_split s i] returns the beginning of [s] up to char [i-1] and the
+(** [string_split s i] returns the beginning of [s] up to char [i-1] and the
end of [s] starting from char [i+1]
@raise Invalid_argument if [i] is not in the range [[0,(length s -1)]]
@since Oxygen-20120901 *)
-val make_unique_name:
+val make_unique_name:
(string -> bool) -> ?sep:string -> ?start:int -> string -> int*string
- (** [make_unique_name mem s] returns [(0, s)] when [(mem s)=false]
- otherwise returns [(n,new_string)] such that [new_string] is
- derived from [(s,sep,start)] and [(mem new_string)=false] and [n<>0]
- @since Oxygen-20120901 *)
+(** [make_unique_name mem s] returns [(0, s)] when [(mem s)=false]
+ otherwise returns [(n,new_string)] such that [new_string] is
+ derived from [(s,sep,start)] and [(mem new_string)=false] and [n<>0]
+ @since Oxygen-20120901 *)
val strip_underscore: string -> string
(** remove underscores at the beginning and end of a string. If a string
is composed solely of underscores, return the empty string
@since 18.0-Argon
- *)
+*)
val html_escape: string -> string
@@ -280,7 +280,7 @@ val html_escape: string -> string
or raises an exception if the tag extension is unsupported.
@since 22.0-Titanium
- *)
+*)
val format_string_of_stag: Format.stag -> string
(* ************************************************************************* *)
@@ -300,36 +300,36 @@ val try_finally: finally:(unit -> unit) -> ('a -> 'b) -> 'a -> 'b
(* ************************************************************************* *)
val mkdir : ?parents:bool -> string -> Unix.file_perm -> unit
- (** [mkdir ?parents name perm] creates directory [name] with permission
- [perm]. If [parents] is true, recursively create parent directories
- if needed. [parents] defaults to false.
- Note that this function may create some of the parent directories
- and then fail to create the children, e.g. if [perm] does not allow
- user execution of the created directory. This will leave the filesystem
- in a modified state before raising an exception.
- @raise Unix.Unix_error if cannot create [name] or its parents.
- @since 19.0-Potassium *)
+(** [mkdir ?parents name perm] creates directory [name] with permission
+ [perm]. If [parents] is true, recursively create parent directories
+ if needed. [parents] defaults to false.
+ Note that this function may create some of the parent directories
+ and then fail to create the children, e.g. if [perm] does not allow
+ user execution of the created directory. This will leave the filesystem
+ in a modified state before raising an exception.
+ @raise Unix.Unix_error if cannot create [name] or its parents.
+ @since 19.0-Potassium *)
val safe_at_exit : (unit -> unit) -> unit
- (** Register function to call with [Stdlib.at_exit], but only
- for non-child process (fork). The order of execution is preserved
- {i wrt} ordinary calls to [Stdlib.at_exit]. *)
+(** Register function to call with [Stdlib.at_exit], but only
+ for non-child process (fork). The order of execution is preserved
+ {i wrt} ordinary calls to [Stdlib.at_exit]. *)
val cleanup_at_exit: string -> unit
- (** [cleanup_at_exit file] indicates that [file] must be removed when the
- program exits (except if exit is caused by a signal).
- If [file] does not exist, nothing happens. *)
+(** [cleanup_at_exit file] indicates that [file] must be removed when the
+ program exits (except if exit is caused by a signal).
+ If [file] does not exist, nothing happens. *)
exception Temp_file_error of string
val temp_file_cleanup_at_exit: ?debug:bool -> string -> string -> string
- (** Similar to [Filename.temp_file] except that the temporary file will be
- deleted at the end of the execution (see above), unless [debug] is set
- to true, in which case a message with the name of the kept file will be
- printed.
- @raise Temp_file_error if the temp file cannot be created.
- @modify Nitrogen-20111001 may now raise Temp_file_error
- @modify Oxygen-20120901 optional debug argument
+(** Similar to [Filename.temp_file] except that the temporary file will be
+ deleted at the end of the execution (see above), unless [debug] is set
+ to true, in which case a message with the name of the kept file will be
+ printed.
+ @raise Temp_file_error if the temp file cannot be created.
+ @modify Nitrogen-20111001 may now raise Temp_file_error
+ @modify Oxygen-20120901 optional debug argument
*)
val temp_dir_cleanup_at_exit: ?debug:bool -> string -> string
@@ -338,7 +338,7 @@ val temp_dir_cleanup_at_exit: ?debug:bool -> string -> string
@modify Neon-20130301 add optional debug flag *)
val safe_remove: string -> unit
- (** Tries to delete a file and never fails. *)
+(** Tries to delete a file and never fails. *)
val safe_remove_dir: string -> unit
diff --git a/src/libraries/utils/bag.ml b/src/libraries/utils/bag.ml
index 84ff205276ef5aabfc99039eb643f69e3ba40491..6b4bd139b9a2f0319744b6d26a8f8167974f42f9 100644
--- a/src/libraries/utils/bag.ml
+++ b/src/libraries/utils/bag.ml
@@ -59,11 +59,11 @@ let list = function
let concat a b =
match a,b with
- | Empty,c | c,Empty -> c
- | Elt x,t -> Add(x,t)
- | t,Elt x -> App(t,x)
- | Concat(a,b),c -> Concat(a,Concat(b,c)) (* 1-time optim *)
- | _ -> Concat(a,b)
+ | Empty,c | c,Empty -> c
+ | Elt x,t -> Add(x,t)
+ | t,Elt x -> App(t,x)
+ | Concat(a,b),c -> Concat(a,Concat(b,c)) (* 1-time optim *)
+ | _ -> Concat(a,b)
let rec ulist = function
| [] -> Empty
@@ -125,19 +125,19 @@ let rec partition f = function
| Empty -> Empty , Empty
| Elt x as e -> if f x then e,Empty else Empty,e
| Add(x,ts) ->
- let pos,neg = partition f ts in
- if f x then add x pos , neg else pos , add x neg
+ let pos,neg = partition f ts in
+ if f x then add x pos , neg else pos , add x neg
| App(ts,x) ->
- let ok = f x in
- let pos,neg = partition f ts in
- if ok then append pos x , neg else pos , append neg x
+ let ok = f x in
+ let pos,neg = partition f ts in
+ if ok then append pos x , neg else pos , append neg x
| List xs ->
- let pos,neg = List.partition f xs in
- list pos , list neg
+ let pos,neg = List.partition f xs in
+ list pos , list neg
| Concat(a,b) ->
- let apos,aneg = partition f a in
- let bpos,bneg = partition f b in
- concat apos bpos , concat aneg bneg
+ let apos,aneg = partition f a in
+ let bpos,bneg = partition f b in
+ concat apos bpos , concat aneg bneg
let rec is_empty = function
| Empty | List [] -> true
@@ -149,18 +149,18 @@ let rec singleton = function
| Empty | List _ -> None
| Add(x,t) | App(t,x) -> if is_empty t then Some x else None
| Concat(a,b) ->
- match singleton a with
- | Some x -> if is_empty b then Some x else None
- | None -> if is_empty a then singleton b else None
+ match singleton a with
+ | Some x -> if is_empty b then Some x else None
+ | None -> if is_empty a then singleton b else None
let rec collect t xs =
match t with
- | Elt x -> x :: xs
- | Empty -> xs
- | Add(x,t) -> x :: collect t xs
- | App(t,x) -> collect t (x::xs)
- | List ys -> ys @ xs
- | Concat(a,b) -> collect a (collect b xs)
+ | Elt x -> x :: xs
+ | Empty -> xs
+ | Add(x,t) -> x :: collect t xs
+ | App(t,x) -> collect t (x::xs)
+ | List ys -> ys @ xs
+ | Concat(a,b) -> collect a (collect b xs)
let elements t = collect t []
diff --git a/src/libraries/utils/binary_cache.ml b/src/libraries/utils/binary_cache.ml
index 944446cb1ebd505744e88b6176d8c3cf99c7517c..61ad87e943024184a73d7544624d95adfbccb6c6 100644
--- a/src/libraries/utils/binary_cache.ml
+++ b/src/libraries/utils/binary_cache.ml
@@ -26,7 +26,7 @@ let memory_footprint =
let error () =
Cmdline.Kernel_log.error
"@[Bad value for environment variable@ %s.@ Expected value: \
- integer between@ 1 and 10.@ Using@ default value@ of 2.@]"
+ integer between@ 1 and 10.@ Using@ default value@ of 2.@]"
memory_footprint_var_name;
2
in
@@ -42,18 +42,18 @@ let cache_size = 1 lsl (8 + memory_footprint)
(** The caches of this module are lazy, for two reasons:
- - some caches are never used, because the function that created them is
- never called. This typically happens for functors implementing generic
- datastructures, where not all functions are used in every module
- (but every function with a static cache creates its cache nevertheless)
-
- - Caches must be cleared as soon as some states change, in order to remain
- coherent (for example, when the current project changes). When setting
- multiple command-line options, the caches may be cleared after each option.
- When caches are big, this becomes very time-consuming. To avoid this,
- the functions [clear] do nothing when the caches have not been forced yet.
- (This is not perfect: once a lazy cache has been forced, each 'clear'
- operation becomes costly again.)
+ - some caches are never used, because the function that created them is
+ never called. This typically happens for functors implementing generic
+ datastructures, where not all functions are used in every module
+ (but every function with a static cache creates its cache nevertheless)
+
+ - Caches must be cleared as soon as some states change, in order to remain
+ coherent (for example, when the current project changes). When setting
+ multiple command-line options, the caches may be cleared after each option.
+ When caches are big, this becomes very time-consuming. To avoid this,
+ the functions [clear] do nothing when the caches have not been forced yet.
+ (This is not perfect: once a lazy cache has been forced, each 'clear'
+ operation becomes costly again.)
*)
let (!!) = Lazy.force
@@ -76,44 +76,44 @@ struct
type ('a, 'b) t
let (clear : ('a, 'b) t -> 'a -> 'b -> unit)
- = fun t a b ->
- let t = Obj.repr t in
- let size2 = Obj.size t in
- let i = ref 0 in
- while (!i < size2)
- do
- let base = !i in
- Obj.set_field t (base) (Obj.repr a);
- Obj.set_field t (base+1) (Obj.repr b);
- i := base + 2;
- done
+ = fun t a b ->
+ let t = Obj.repr t in
+ let size2 = Obj.size t in
+ let i = ref 0 in
+ while (!i < size2)
+ do
+ let base = !i in
+ Obj.set_field t (base) (Obj.repr a);
+ Obj.set_field t (base+1) (Obj.repr b);
+ i := base + 2;
+ done
let (make : int -> 'a -> 'b -> ('a, 'b) t)
- = fun size a b ->
- let size2 = 2 * size in
- let t = Obj.obj (Obj.new_block 0 size2) in
- clear t a b;
- t
+ = fun size a b ->
+ let size2 = 2 * size in
+ let t = Obj.obj (Obj.new_block 0 size2) in
+ clear t a b;
+ t
let (set : ('a, 'b) t -> int -> 'a -> 'b -> unit)
- = fun t i a b ->
- let t = Obj.repr t in
- let base = 2 * i in
- Obj.set_field t (base) (Obj.repr a);
- Obj.set_field t (base+1) (Obj.repr b)
+ = fun t i a b ->
+ let t = Obj.repr t in
+ let base = 2 * i in
+ Obj.set_field t (base) (Obj.repr a);
+ Obj.set_field t (base+1) (Obj.repr b)
let (get0 :
- ('a, 'b) t -> int -> 'a)
- = fun t i ->
- let t = Obj.repr t in
- let base = 2 * i in
- Obj.obj (Obj.field t (base))
+ ('a, 'b) t -> int -> 'a)
+ = fun t i ->
+ let t = Obj.repr t in
+ let base = 2 * i in
+ Obj.obj (Obj.field t (base))
let (get1 : ('a, 'b) t -> int -> 'b)
- = fun t i ->
- let t = Obj.repr t in
- let base = 2 * i in
- Obj.obj (Obj.field t (base+1))
+ = fun t i ->
+ let t = Obj.repr t in
+ let base = 2 * i in
+ Obj.obj (Obj.field t (base+1))
end
module Array_3 =
@@ -121,54 +121,54 @@ struct
type ('a, 'b, 'c) t
let (clear : ('a, 'b, 'c) t ->
- 'a -> 'b -> 'c -> unit)
- = fun t a b c ->
- let t = Obj.repr t in
- let size3 = Obj.size t in
- let i = ref 0 in
- while (!i < size3)
- do
- let base = !i in
- Obj.set_field t (base) (Obj.repr a);
- Obj.set_field t (base+1) (Obj.repr b);
- Obj.set_field t (base+2) (Obj.repr c);
- i := base + 3;
- done
+ 'a -> 'b -> 'c -> unit)
+ = fun t a b c ->
+ let t = Obj.repr t in
+ let size3 = Obj.size t in
+ let i = ref 0 in
+ while (!i < size3)
+ do
+ let base = !i in
+ Obj.set_field t (base) (Obj.repr a);
+ Obj.set_field t (base+1) (Obj.repr b);
+ Obj.set_field t (base+2) (Obj.repr c);
+ i := base + 3;
+ done
let (make : int -> 'a -> 'b -> 'c -> ('a, 'b, 'c) t)
- = fun size a b c ->
- let size3 = 3 * size in
- let t = Obj.obj (Obj.new_block 0 size3) in
- clear t a b c;
- t
+ = fun size a b c ->
+ let size3 = 3 * size in
+ let t = Obj.obj (Obj.new_block 0 size3) in
+ clear t a b c;
+ t
let (set : ('a, 'b, 'c) t -> int -> 'a -> 'b -> 'c -> unit)
- = fun t i a b c ->
- let t = Obj.repr t in
- let base = 3 * i in
- Obj.set_field t (base) (Obj.repr a);
- Obj.set_field t (base+1) (Obj.repr b);
- Obj.set_field t (base+2) (Obj.repr c)
+ = fun t i a b c ->
+ let t = Obj.repr t in
+ let base = 3 * i in
+ Obj.set_field t (base) (Obj.repr a);
+ Obj.set_field t (base+1) (Obj.repr b);
+ Obj.set_field t (base+2) (Obj.repr c)
let (get0 :
- ('a, 'b, 'c) t -> int -> 'a)
- = fun t i ->
- let t = Obj.repr t in
- let base = 3 * i in
- Obj.obj (Obj.field t (base))
+ ('a, 'b, 'c) t -> int -> 'a)
+ = fun t i ->
+ let t = Obj.repr t in
+ let base = 3 * i in
+ Obj.obj (Obj.field t (base))
let (get1 : ('a, 'b, 'c) t -> int -> 'b)
- = fun t i ->
- let t = Obj.repr t in
- let base = 3 * i in
- Obj.obj (Obj.field t (base+1))
+ = fun t i ->
+ let t = Obj.repr t in
+ let base = 3 * i in
+ Obj.obj (Obj.field t (base+1))
let (get2 :
- ('a, 'b, 'c) t -> int -> 'c)
- = fun t i ->
- let t = Obj.repr t in
- let base = 3 * i in
- Obj.obj (Obj.field t (base+2))
+ ('a, 'b, 'c) t -> int -> 'c)
+ = fun t i ->
+ let t = Obj.repr t in
+ let base = 3 * i in
+ Obj.obj (Obj.field t (base+2))
end
module Array_4 =
@@ -176,68 +176,68 @@ struct
type ('a, 'b, 'c, 'd) t
let (clear : ('a , 'b , 'c , 'd) t ->
- 'a -> 'b -> 'c -> 'd -> unit)
- = fun t a b c d ->
- let t = Obj.repr t in
- let size4 = Obj.size t in
- let i = ref 0 in
- while (!i < size4)
- do
- let base = !i in
- Obj.set_field t (base) (Obj.repr a);
- Obj.set_field t (base+1) (Obj.repr b);
- Obj.set_field t (base+2) (Obj.repr c);
- Obj.set_field t (base+3) (Obj.repr d);
- i := base + 7;
- done
-
- let (make : int -> 'a -> 'b -> 'c -> 'd ->
- ('a , 'b , 'c , 'd) t)
- = fun size a b c d ->
- let size4 = 4 * size in
- let t = Obj.obj (Obj.new_block 0 size4) in
- clear t a b c d;
- t
-
- let (set :
- ('a, 'b, 'c, 'd) t -> int ->
- 'a -> 'b -> 'c -> 'd -> unit)
- = fun t i a b c d ->
- let t = Obj.repr t in
- let base = 4 * i in
+ 'a -> 'b -> 'c -> 'd -> unit)
+ = fun t a b c d ->
+ let t = Obj.repr t in
+ let size4 = Obj.size t in
+ let i = ref 0 in
+ while (!i < size4)
+ do
+ let base = !i in
Obj.set_field t (base) (Obj.repr a);
Obj.set_field t (base+1) (Obj.repr b);
Obj.set_field t (base+2) (Obj.repr c);
Obj.set_field t (base+3) (Obj.repr d);
+ i := base + 7;
+ done
+
+ let (make : int -> 'a -> 'b -> 'c -> 'd ->
+ ('a , 'b , 'c , 'd) t)
+ = fun size a b c d ->
+ let size4 = 4 * size in
+ let t = Obj.obj (Obj.new_block 0 size4) in
+ clear t a b c d;
+ t
+
+ let (set :
+ ('a, 'b, 'c, 'd) t -> int ->
+ 'a -> 'b -> 'c -> 'd -> unit)
+ = fun t i a b c d ->
+ let t = Obj.repr t in
+ let base = 4 * i in
+ Obj.set_field t (base) (Obj.repr a);
+ Obj.set_field t (base+1) (Obj.repr b);
+ Obj.set_field t (base+2) (Obj.repr c);
+ Obj.set_field t (base+3) (Obj.repr d);
;;
let (get0 :
- ('a, 'b, 'c, 'd) t -> int -> 'a)
- = fun t i ->
- let t = Obj.repr t in
- let base = 4 * i in
- Obj.obj (Obj.field t (base))
+ ('a, 'b, 'c, 'd) t -> int -> 'a)
+ = fun t i ->
+ let t = Obj.repr t in
+ let base = 4 * i in
+ Obj.obj (Obj.field t (base))
let (get1 :
- ('a, 'b, 'c, 'd) t -> int -> 'b)
- = fun t i ->
- let t = Obj.repr t in
- let base = 4 * i in
- Obj.obj (Obj.field t (base+1))
+ ('a, 'b, 'c, 'd) t -> int -> 'b)
+ = fun t i ->
+ let t = Obj.repr t in
+ let base = 4 * i in
+ Obj.obj (Obj.field t (base+1))
let (get2 :
- ('a, 'b, 'c, 'd) t -> int -> 'c)
- = fun t i ->
- let t = Obj.repr t in
- let base = 4 * i in
- Obj.obj (Obj.field t (base+2))
+ ('a, 'b, 'c, 'd) t -> int -> 'c)
+ = fun t i ->
+ let t = Obj.repr t in
+ let base = 4 * i in
+ Obj.obj (Obj.field t (base+2))
let (get3 :
- ('a, 'b, 'c, 'd) t -> int -> 'd)
- = fun t i ->
- let t = Obj.repr t in
- let base = 4 * i in
- Obj.obj (Obj.field t (base+3))
+ ('a, 'b, 'c, 'd) t -> int -> 'd)
+ = fun t i ->
+ let t = Obj.repr t in
+ let base = 4 * i in
+ Obj.obj (Obj.field t (base+3))
end
module Symmetric_Binary (H: Cacheable) (R: Result) =
@@ -266,14 +266,14 @@ struct
let has = has land mask in
if H.equal (Array_3.get0 !!cache has) a0'
- && H.equal (Array_3.get1 !!cache has) a1'
+ && H.equal (Array_3.get1 !!cache has) a1'
then begin
-(* Format.printf "Cache O@."; *)
- Array_3.get2 !!cache has
- end
+ (* Format.printf "Cache O@."; *)
+ Array_3.get2 !!cache has
+ end
else
let result = f a0 a1 in
-(* Format.printf "Cache N@."; *)
+ (* Format.printf "Cache N@."; *)
Array_3.set !!cache has a0' a1' result;
result
end
@@ -294,12 +294,12 @@ struct
let has = h0 land mask in
if H.equal (Array_2.get0 !!cache has) a0
then begin
-(* Format.printf "Cache O@."; *)
- Array_2.get1 !!cache has
- end
+ (* Format.printf "Cache O@."; *)
+ Array_2.get1 !!cache has
+ end
else
let result = f a0 in
-(* Format.printf "Cache N@."; *)
+ (* Format.printf "Cache N@."; *)
Array_2.set !!cache has a0 result;
result
end
@@ -323,14 +323,14 @@ struct
let has = has land mask in
if H0.equal (Array_3.get0 !!cache has) a0
- && H1.equal (Array_3.get1 !!cache has) a1
+ && H1.equal (Array_3.get1 !!cache has) a1
then begin
-(* Format.printf "Cache O@."; *)
- Array_3.get2 !!cache has
- end
+ (* Format.printf "Cache O@."; *)
+ Array_3.get2 !!cache has
+ end
else
let result = f a0 a1 in
-(* Format.printf "Cache N@."; *)
+ (* Format.printf "Cache N@."; *)
Array_3.set !!cache has a0 a1 result;
result
end
@@ -357,12 +357,12 @@ struct
&& H1.equal (Array_4.get1 !!cache has) a1
&& H2.equal (Array_4.get2 !!cache has) a2
then begin
-(* Format.printf "Cache O@."; *)
- Array_4.get3 !!cache has
- end
+ (* Format.printf "Cache O@."; *)
+ Array_4.get3 !!cache has
+ end
else
let result = f a0 a1 a2 in
-(* Format.printf "Cache N@."; *)
+ (* Format.printf "Cache N@."; *)
Array_4.set !!cache has a0 a1 a2 result;
result
end
@@ -383,12 +383,12 @@ struct
let c = i lsr 3 in
let b = 1 lsl (i land 7) in
let oldcontents = Char.code (Bytes.get s c) in
- let newcontents =
- if v
- then b lor oldcontents
- else
- let mask = lnot b in
- oldcontents land mask
+ let newcontents =
+ if v
+ then b lor oldcontents
+ else
+ let mask = lnot b in
+ oldcontents land mask
in
Bytes.set s c (Char.chr newcontents)
@@ -419,14 +419,14 @@ struct
let has = has land mask in
if H0.equal (Array_2.get0 !!cache has) a0
- && H1.equal (Array_2.get1 !!cache has) a1
+ && H1.equal (Array_2.get1 !!cache has) a1
then begin
-(* Format.printf "Cache O@."; *)
- Array_Bit.get !!result has
- end
+ (* Format.printf "Cache O@."; *)
+ Array_Bit.get !!result has
+ end
else
let r = f a0 a1 in
-(* Format.printf "Cache N@."; *)
+ (* Format.printf "Cache N@."; *)
Array_2.set !!cache has a0 a1;
Array_Bit.set !!result has r;
r
@@ -460,14 +460,14 @@ struct
let has = has land mask in
if H0.equal (Array_2.get0 !!cache has) a0
- && H0.equal (Array_2.get1 !!cache has) a1
+ && H0.equal (Array_2.get1 !!cache has) a1
then begin
-(* Format.printf "Cache O@."; *)
- Array_Bit.get !!result has
- end
+ (* Format.printf "Cache O@."; *)
+ Array_Bit.get !!result has
+ end
else
let r = f a0 a1 in
-(* Format.printf "Cache N@."; *)
+ (* Format.printf "Cache N@."; *)
Array_2.set !!cache has a0 a1;
Array_Bit.set !!result has r;
r
diff --git a/src/libraries/utils/bitvector.ml b/src/libraries/utils/bitvector.ml
index 48b5ac70d0f26daf35dcfa36db18291a73a3ae07..4b0d994d368c7559ad964fa3d8ec1097acb875d3 100644
--- a/src/libraries/utils/bitvector.ml
+++ b/src/libraries/utils/bitvector.ml
@@ -25,7 +25,7 @@
(* ------------------------------------------------------------------------ *)
(* Notes:
- - Bits are counted from 0, in string order, then from least to
+ - Bits are counted from 0, in string order, then from least to
most significant. For instance the value of bit 11 is tested
with (s.[1] land (1 lsl 3) == 0)
- Strings can store more bits than the bitvector they represent;
@@ -34,8 +34,8 @@
bitvector, which has to be provided in some informations (such as
concat). We rely on the invariant that the extra bits are set to
0 (this is important e.g. for equality testing). An alternative
- design could have been not to explicitly ignore these extra bits
- in operations that are sensitive to them, but this seems more
+ design could have been not to explicitly ignore these extra bits
+ in operations that are sensitive to them, but this seems more
error-prone. *)
type t = bytes
@@ -242,7 +242,7 @@ let concat bv1 size1 bv2 size2 =
if fst_bits = 0 then
(Bytes.blit bv2 0 copy len1 str2;
copy)
-
+
(* Not aligned. *)
else
let rec loop prev_byte i =
@@ -265,7 +265,7 @@ let iter_true f s =
if x <> 0 then
let q = p lsl 3 in
for r = 0 to 7 do
- if x land (1 lsl r) <> 0 then f (q+r)
+ if x land (1 lsl r) <> 0 then f (q+r)
done
done
@@ -285,16 +285,16 @@ let find_next_true s k =
try
begin
for r' = r to 7 do
- if x land (1 lsl r') <> 0
- then raise (Result ((p lsl 3) lor r'))
+ if x land (1 lsl r') <> 0
+ then raise (Result ((p lsl 3) lor r'))
done;
for p' = (p+1) to (Bytes.length s - 1) do
- let x = int_of_char (Bytes.get s p') in
- if x <> 0 then
- for r' = 0 to 7 do
- if x land (1 lsl r') <> 0
- then raise (Result ((p' lsl 3) lor r'))
- done
+ let x = int_of_char (Bytes.get s p') in
+ if x <> 0 then
+ for r' = 0 to 7 do
+ if x land (1 lsl r') <> 0
+ then raise (Result ((p' lsl 3) lor r'))
+ done
done;
raise Not_found
end
diff --git a/src/libraries/utils/bitvector.mli b/src/libraries/utils/bitvector.mli
index 58d4b876e08f3de1ba189d62d23c048be4682844..076a4708caa893cdfdea9dbe6f81a4037857b068 100644
--- a/src/libraries/utils/bitvector.mli
+++ b/src/libraries/utils/bitvector.mli
@@ -31,11 +31,11 @@ type t
val create : int -> t (** Create a vector of [n] bits, with all bits unset. *)
val create_set : int -> t (** Create a vector of [n] bits, with all bits set.*)
-val capacity : t -> int
+val capacity : t -> int
(** Maximum number of bits in the bitvector. *)
-val resize : int -> t -> t
-(** A copy of the bitvector up-to or down-to [n] bits.
+val resize : int -> t -> t
+(** A copy of the bitvector up-to or down-to [n] bits.
Extra bits up to final bitvector capacity are set to zero. *)
val mem : t -> int -> bool
@@ -49,7 +49,7 @@ val equal: t -> t -> bool
val compare: t -> t -> int
val hash: t -> int
-(** {2 Bitwise Binary Operations}
+(** {2 Bitwise Binary Operations}
The first argument is the size of the vectors. *)
val bnot: int -> t -> t
@@ -58,7 +58,7 @@ val bor: int -> t -> t -> t
val bxor: int -> t -> t -> t (* bitwise difference *)
val beq: int -> t -> t -> t (* bitwise equivalence/equality *)
-(** {2 Generic Bitwise Operations}.
+(** {2 Generic Bitwise Operations}.
Prefer using these rather than create intermediary bitvectors. *)
val bitwise_op2: int -> (int -> int -> int) -> t -> t -> t
@@ -68,17 +68,17 @@ val bitwise_op4: int -> (int -> int -> int -> int -> int) -> t -> t -> t -> t ->
(** {2 Sized Concatenation} *)
val concat: t -> int -> t -> int -> t
-(** [concat b1 s1 b2 s2] concatenates
- the [s1] first bits of [b1] with
+(** [concat b1 s1 b2 s2] concatenates
+ the [s1] first bits of [b1] with
the [s2] first bits of [b2]. *)
(** {2 Misc} *)
val iter_true : (int -> unit) -> t -> unit
- (** Iterates on all indexes of the bitvector with their bit set. *)
+(** Iterates on all indexes of the bitvector with their bit set. *)
val fold_true : ('a -> int -> 'a) -> 'a -> t -> 'a
- (** Iterates on all indexes of the bitvector with their bit set. *)
+(** Iterates on all indexes of the bitvector with their bit set. *)
val find_next_true: t -> int -> int
(** [find_next_true i a] returns the first index greater or equal to
@@ -87,8 +87,8 @@ val find_next_true: t -> int -> int
larger than the array, then raise [Not_found]. *)
val pretty : Format.formatter -> t -> unit
- (** Bit vector, as blocs of 8-bits separated by space,
- first bits to last bits from left to right. *)
+(** Bit vector, as blocs of 8-bits separated by space,
+ first bits to last bits from left to right. *)
val pp_bits : Format.formatter -> int -> unit
- (** 0b... format, for bytes only, most significant bits on left. *)
+(** 0b... format, for bytes only, most significant bits on left. *)
diff --git a/src/libraries/utils/cilconfig.ml b/src/libraries/utils/cilconfig.ml
index 2793ae039e4816b3998e93d06cb85e5772183342..478d2a2017a84999d49cb72fae54206f90e1c7ed 100644
--- a/src/libraries/utils/cilconfig.ml
+++ b/src/libraries/utils/cilconfig.ml
@@ -46,7 +46,7 @@ module H = Hashtbl
(************************************************************************
- Configuration
+ Configuration
************************************************************************)
@@ -74,15 +74,15 @@ let findConfigurationInt (key: string) : int =
match findConfiguration key with
ConfInt i -> i
| _ ->
- Kernel.warning "Configuration %s is not an integer" key;
- raise Not_found
+ Kernel.warning "Configuration %s is not an integer" key;
+ raise Not_found
let findConfigurationFloat (key: string) : float =
match findConfiguration key with
ConfFloat i -> i
| _ ->
- Kernel.warning "Configuration %s is not a float" key;
- raise Not_found
+ Kernel.warning "Configuration %s is not a float" key;
+ raise Not_found
let useConfigurationInt (key: string) (f: int -> unit) =
try f (findConfigurationInt key)
@@ -96,8 +96,8 @@ let findConfigurationString (key: string) : string =
match findConfiguration key with
ConfString s -> s
| _ ->
- Kernel.warning "Configuration %s is not a string" key;
- raise Not_found
+ Kernel.warning "Configuration %s is not a string" key;
+ raise Not_found
let useConfigurationString (key: string) (f: string -> unit) =
try f (findConfigurationString key)
@@ -108,8 +108,8 @@ let findConfigurationBool (key: string) : bool =
match findConfiguration key with
ConfBool b -> b
| _ ->
- Kernel.warning "Configuration %s is not a boolean" key;
- raise Not_found
+ Kernel.warning "Configuration %s is not a boolean" key;
+ raise Not_found
let useConfigurationBool (key: string) (f: bool -> unit) =
try f (findConfigurationBool key)
@@ -119,8 +119,8 @@ let findConfigurationList (key: string) : configData list =
match findConfiguration key with
ConfList l -> l
| _ ->
- Kernel.warning "Configuration %s is not a list" key;
- raise Not_found
+ Kernel.warning "Configuration %s is not a list" key;
+ raise Not_found
let useConfigurationList (key: string) (f: configData list -> unit) =
try f (findConfigurationList key)
@@ -134,31 +134,31 @@ let saveConfiguration (fname : Datatype.Filepath.t) =
let rec loop (c: configData) : unit =
match c with
ConfInt i ->
- Buffer.add_char buff 'i';
- Buffer.add_string buff (string_of_int i);
- Buffer.add_char buff ';'
+ Buffer.add_char buff 'i';
+ Buffer.add_string buff (string_of_int i);
+ Buffer.add_char buff ';'
| ConfBool b ->
- Buffer.add_char buff 'b';
- Buffer.add_string buff (string_of_bool b);
- Buffer.add_char buff ';'
+ Buffer.add_char buff 'b';
+ Buffer.add_string buff (string_of_bool b);
+ Buffer.add_char buff ';'
| ConfFloat f ->
- Buffer.add_char buff 'f';
- Buffer.add_string buff (string_of_float f);
- Buffer.add_char buff ';'
+ Buffer.add_char buff 'f';
+ Buffer.add_string buff (string_of_float f);
+ Buffer.add_char buff ';'
| ConfString s ->
- if String.contains s '"' then
- Kernel.fatal "Guilib: configuration string contains quotes";
- Buffer.add_char buff '"';
- Buffer.add_string buff s;
- Buffer.add_char buff '"'; (* '"' *)
+ if String.contains s '"' then
+ Kernel.fatal "Guilib: configuration string contains quotes";
+ Buffer.add_char buff '"';
+ Buffer.add_string buff s;
+ Buffer.add_char buff '"'; (* '"' *)
| ConfList l ->
- Buffer.add_char buff '[';
- List.iter loop l;
- Buffer.add_char buff ']'
+ Buffer.add_char buff '[';
+ List.iter loop l;
+ Buffer.add_char buff ']'
in
loop c;
Buffer.contents buff
@@ -167,8 +167,8 @@ let saveConfiguration (fname : Datatype.Filepath.t) =
let oc = open_out (fname :> string) in
Kernel.debug "Saving configuration to %s@." (fname :> string);
H.iter (fun k c ->
- output_string oc (k ^ "\n");
- output_string oc ((configToString c) ^ "\n"))
+ output_string oc (k ^ "\n");
+ output_string oc ((configToString c) ^ "\n"))
configurationData;
close_out oc
with _ ->
@@ -192,18 +192,18 @@ let loadConfiguration (fname : Datatype.Filepath.t) : unit =
if !idx >= l then raise Not_found;
if Str.string_match intRegexp s !idx then begin
idx := Str.match_end ();
- let p = Str.matched_group 1 s in
+ let p = Str.matched_group 1 s in
(try ConfInt (int_of_string p)
- with Failure _ ->
- Kernel.warning "Invalid integer configuration element %s" p;
- raise Not_found)
+ with Failure _ ->
+ Kernel.warning "Invalid integer configuration element %s" p;
+ raise Not_found)
end else if Str.string_match floatRegexp s !idx then begin
idx := Str.match_end ();
- let p = Str.matched_group 1 s in
+ let p = Str.matched_group 1 s in
(try ConfFloat (float_of_string p)
- with Failure _ ->
- Kernel.warning "Invalid float configuration element %s" p;
- raise Not_found)
+ with Failure _ ->
+ Kernel.warning "Invalid float configuration element %s" p;
+ raise Not_found)
end else if Str.string_match boolRegexp s !idx then begin
idx := Str.match_end ();
ConfBool (bool_of_string (Str.matched_group 1 s))
@@ -227,27 +227,27 @@ let loadConfiguration (fname : Datatype.Filepath.t) : unit =
ConfList (loop [])
end else begin
Kernel.warning "Bad configuration element in a list: %s"
- (String.sub s !idx (l - !idx));
+ (String.sub s !idx (l - !idx));
raise Not_found
end
in
getOne ()
in
(try
- let ic = open_in (fname :> string) in
- Kernel.debug "Loading configuration from %s@." (fname :> string);
- (try
- while true do
- let k = input_line ic in
- let s = input_line ic in
- try
- let c = stringToConfig s in
- setConfiguration k c
- with Not_found -> ()
- done
- with End_of_file -> ());
- close_in ic;
- with _ -> () (* no file, ignore *));
+ let ic = open_in (fname :> string) in
+ Kernel.debug "Loading configuration from %s@." (fname :> string);
+ (try
+ while true do
+ let k = input_line ic in
+ let s = input_line ic in
+ try
+ let c = stringToConfig s in
+ setConfiguration k c
+ with Not_found -> ()
+ done
+ with End_of_file -> ());
+ close_in ic;
+ with _ -> () (* no file, ignore *));
()
diff --git a/src/libraries/utils/command.ml b/src/libraries/utils/command.ml
index 1849f05a63750f50e4b07fef62b26de35eaeb810..b8805a44557402548bb1ddf603b3b4260e1cb724 100644
--- a/src/libraries/utils/command.ml
+++ b/src/libraries/utils/command.ml
@@ -52,10 +52,10 @@ let pp_from_file fmt file =
done
with
| End_of_file ->
- close_in cin
+ close_in cin
| err ->
- close_in cin ;
- raise err
+ close_in cin ;
+ raise err
let rec bincopy buffer cin cout =
let s = Bytes.length buffer in
@@ -157,19 +157,19 @@ let full_command_async cmd args ~stdin ~stdout ~stderr =
match !last_result with
| Result _ as r -> r
| Not_ready _ as r ->
- let child_id,status =
- Unix.waitpid [Unix.WNOHANG; Unix.WUNTRACED] pid
- in
- if child_id = 0 then r
- else (last_result := Result status; !last_result))
+ let child_id,status =
+ Unix.waitpid [Unix.WNOHANG; Unix.WUNTRACED] pid
+ in
+ if child_id = 0 then r
+ else (last_result := Result status; !last_result))
let flush b f =
match b with
| None -> ()
| Some b ->
- try read_lines f
- (fun line -> Buffer.add_string b line ; Buffer.add_char b '\n') ;
- with Sys_error _ -> ()
+ try read_lines f
+ (fun line -> Buffer.add_string b line ; Buffer.add_char b '\n') ;
+ with Sys_error _ -> ()
(*[LC] return the cancel function *)
let cancelable_at_exit job =
@@ -222,18 +222,18 @@ let command_generic ~async ?stdout ?stderr cmd args =
match !last_result with
| Result _p as r -> r
| Not_ready _ as r ->
- let child_id,status = Unix.waitpid wait_flags pid in
- if child_id = 0 then (assert async;r)
- else
- begin
- let result = Result status in
- flush stdout outf ;
- flush stderr errf ;
- delete () ;
- deleted () ;
- killed () ;
- result
- end
+ let child_id,status = Unix.waitpid wait_flags pid in
+ if child_id = 0 then (assert async;r)
+ else
+ begin
+ let result = Result status in
+ flush stdout outf ;
+ flush stderr errf ;
+ delete () ;
+ deleted () ;
+ killed () ;
+ result
+ end
end
let command_async ?stdout ?stderr cmd args =
@@ -248,19 +248,19 @@ let command ?(timeout=0) ?stdout ?stderr cmd args =
let running () =
match f () with
| Not_ready terminate ->
- begin
- try
- Db.yield () ;
- if timeout > 0 && Unix.gettimeofday () -. !start > ftimeout then
- raise Db.Cancel ;
- true
- with Db.Cancel as e ->
- terminate ();
- raise e
- end
+ begin
+ try
+ Db.yield () ;
+ if timeout > 0 && Unix.gettimeofday () -. !start > ftimeout then
+ raise Db.Cancel ;
+ true
+ with Db.Cancel as e ->
+ terminate ();
+ raise e
+ end
| Result r ->
- res := r;
- false
+ res := r;
+ false
in while running () do Unix.sleepf 0.1 done ; !res
else
let f = command_generic ~async:false ?stdout ?stderr cmd args in
diff --git a/src/libraries/utils/command.mli b/src/libraries/utils/command.mli
index 5e264657ee026b9bc834dfe71067eddfc0793256..faae1ad49315ba93609f2df567c8d5e566c64342 100644
--- a/src/libraries/utils/command.mli
+++ b/src/libraries/utils/command.mli
@@ -29,33 +29,33 @@
val filename : string -> string -> string
val pp_to_file : string -> (Format.formatter -> unit) -> unit
- (** [pp_to_file file pp] runs [pp] on a formatter that writes into [file].
- The formatter is always properly flushed and closed on return.
- Exceptions in [pp] are re-raised after closing. *)
+(** [pp_to_file file pp] runs [pp] on a formatter that writes into [file].
+ The formatter is always properly flushed and closed on return.
+ Exceptions in [pp] are re-raised after closing. *)
val pp_from_file : Format.formatter -> string -> unit
- (** [pp_from_file fmt file] dumps the content of [file] into the [fmt].
- Exceptions in [pp] are re-raised after closing. *)
+(** [pp_from_file fmt file] dumps the content of [file] into the [fmt].
+ Exceptions in [pp] are re-raised after closing. *)
val bincopy : bytes -> in_channel -> out_channel -> unit
- (** [copy buffer cin cout] reads [cin] until end-of-file
- and copy it in [cout].
- [buffer] is a temporary string used during the copy.
- Recommended size is [2048].
- @modify Silicon-20161101 [buffer] has now type [bytes] instead of [string]
- *)
+(** [copy buffer cin cout] reads [cin] until end-of-file
+ and copy it in [cout].
+ [buffer] is a temporary string used during the copy.
+ Recommended size is [2048].
+ @modify Silicon-20161101 [buffer] has now type [bytes] instead of [string]
+*)
val copy : string -> string -> unit
- (** [copy source target] copies source file to target file using [bincopy]. *)
+(** [copy source target] copies source file to target file using [bincopy]. *)
val read_file : string -> (in_channel -> 'a) -> 'a
- (** Properly close the channel and re-raise exceptions *)
+(** Properly close the channel and re-raise exceptions *)
val read_lines : string -> (string -> unit) -> unit
- (** Iter over all text lines in the file *)
+(** Iter over all text lines in the file *)
val write_file : string -> (out_channel -> 'a) -> 'a
- (** Properly close the channel and re-raise exceptions *)
+(** Properly close the channel and re-raise exceptions *)
val print_file : string -> (Format.formatter -> 'a) -> 'a
- (** Properly flush and close the channel and re-raise exceptions *)
+(** Properly flush and close the channel and re-raise exceptions *)
(* ************************************************************************* *)
(** {2 Timing Utility} *)
@@ -64,9 +64,9 @@ val print_file : string -> (Format.formatter -> 'a) -> 'a
type timer = float ref
val time : ?rmax:timer -> ?radd:timer -> ('a -> 'b) -> 'a -> 'b
- (** Compute the elapsed time with [Sys.time].
- The [rmax] timer is maximized and the [radd] timer is cumulated.
- Computed result is returned, or exception is re-raised. *)
+(** Compute the elapsed time with [Sys.time].
+ The [rmax] timer is maximized and the [radd] timer is cumulated.
+ Computed result is returned, or exception is re-raised. *)
(* ************************************************************************* *)
(** {2 System commands} *)
@@ -78,15 +78,15 @@ val full_command :
-> stdout:Unix.file_descr
-> stderr:Unix.file_descr
-> Unix.process_status
- (** Same arguments as {Unix.create_process} but returns only when
- execution is complete.
- @raise Sys_error when a system error occurs *)
+(** Same arguments as {Unix.create_process} but returns only when
+ execution is complete.
+ @raise Sys_error when a system error occurs *)
type process_result =
| Not_ready of (unit -> unit)
| Result of Unix.process_status
- (** [Not_ready f] means that the child process is not yet finished and
- may be terminated manually with [f ()]. *)
+ (** [Not_ready f] means that the child process is not yet finished and
+ may be terminated manually with [f ()]. *)
val full_command_async :
string -> string array
@@ -94,26 +94,26 @@ val full_command_async :
-> stdout:Unix.file_descr
-> stderr:Unix.file_descr
-> (unit -> process_result)
- (** Same arguments as {Unix.create_process}.
- @return a function to call to check if the process execution
- is complete.
- You must call this function until it returns a Result
- to prevent Zombie processes.
- @raise Sys_error when a system error occurs *)
+(** Same arguments as {Unix.create_process}.
+ @return a function to call to check if the process execution
+ is complete.
+ You must call this function until it returns a Result
+ to prevent Zombie processes.
+ @raise Sys_error when a system error occurs *)
val command_async :
?stdout:Buffer.t ->
?stderr:Buffer.t ->
string -> string array
-> (unit -> process_result)
- (** Same arguments as {Unix.create_process}.
- @return a function to call to check if the process execution
- is complete.
- You must call this function until it returns a Result
- to prevent Zombie processes.
- When this function returns a Result, the stdout and stderr of the child
- process will be filled into the arguments buffer.
- @raise Sys_error when a system error occurs *)
+(** Same arguments as {Unix.create_process}.
+ @return a function to call to check if the process execution
+ is complete.
+ You must call this function until it returns a Result
+ to prevent Zombie processes.
+ When this function returns a Result, the stdout and stderr of the child
+ process will be filled into the arguments buffer.
+ @raise Sys_error when a system error occurs *)
val command :
?timeout:int ->
@@ -121,11 +121,11 @@ val command :
?stderr:Buffer.t ->
string -> string array
-> Unix.process_status
- (** Same arguments as {Unix.create_process}.
- When this function returns, the stdout and stderr of the child
- process will be filled into the arguments buffer.
- @raise Sys_error when a system error occurs
- @raise Db.Cancel when the computation is interrupted or on timeout *)
+(** Same arguments as {Unix.create_process}.
+ When this function returns, the stdout and stderr of the child
+ process will be filled into the arguments buffer.
+ @raise Sys_error when a system error occurs
+ @raise Db.Cancel when the computation is interrupted or on timeout *)
(*
Local Variables:
diff --git a/src/libraries/utils/escape.mli b/src/libraries/utils/escape.mli
index f83186be784eb51ad06aef0991d34b21e0ea28d8..d43bb622df4afb9196de0083a664432414df1b68 100644
--- a/src/libraries/utils/escape.mli
+++ b/src/libraries/utils/escape.mli
@@ -43,10 +43,10 @@
(*
*
- * Copyright (c) 2003,
+ * Copyright (c) 2003,
* Ben Liblit <liblit@cs.berkeley.edu>
* All rights reserved.
- *
+ *
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are
* met:
diff --git a/src/libraries/utils/hook.ml b/src/libraries/utils/hook.ml
index 50f42ee5a39f0758afdeef0abc9a3811c2cd6195..185570e7e4b74ab46219b0121c93cdd372ec4dff 100644
--- a/src/libraries/utils/hook.ml
+++ b/src/libraries/utils/hook.ml
@@ -39,13 +39,13 @@ module type Comparable = sig
end
module type S_ordered = sig
- include S
- type key
- type id (** identifier of the hook *)
- val register_key: key -> id
- val extend: id -> (param->result)->unit
- val extend_once: id -> (param->result) -> unit
- val add_dependency: id -> id -> unit
+ include S
+ type key
+ type id (** identifier of the hook *)
+ val register_key: key -> id
+ val extend: id -> (param->result)->unit
+ val extend_once: id -> (param->result) -> unit
+ val add_dependency: id -> id -> unit
end
module type Iter_hook = S with type result = unit
@@ -62,12 +62,12 @@ module Build(P:sig type t end): Iter_hook with type param = P.t = struct
let extend_once f = add_once f hooks
let apply arg = Queue.iter (fun f -> f arg) hooks
- (* [JS 06 October 2008] the following code iter in reverse order without
- changing the order of the queue itself.
+ (* [JS 06 October 2008] the following code iter in reverse order without
+ changing the order of the queue itself.
- let list = ref [] in
- Queue.iter (fun f -> list := f :: !list) hooks;
- List.iter (fun f -> f arg) !list *)
+ let list = ref [] in
+ Queue.iter (fun f -> list := f :: !list) hooks;
+ List.iter (fun f -> f arg) !list *)
let is_empty () = Queue.is_empty hooks
let clear () = Queue.clear hooks
@@ -90,8 +90,8 @@ end
module Make() = Build(struct type t = unit end)
module Make_graph
- (P: sig module Id:Comparable type param type result end)
- =
+ (P: sig module Id:Comparable type param type result end)
+=
struct
type key = P.Id.t
type param = P.param
@@ -142,11 +142,11 @@ struct
let clear () = Hooks.clear hooks
- let length () =
+ let length () =
Hooks.fold_vertex (fun (_,q) l -> Queue.length q + l) hooks 0
end
-module Build_ordered (P: sig module Id:Comparable type t end):
+module Build_ordered (P: sig module Id:Comparable type t end):
S_ordered with type key = P.Id.t and type param = P.t and type result = unit =
struct
include Make_graph(
@@ -154,7 +154,7 @@ struct
let apply v =
let apply_queue (_,q) = Queue.iter (fun f -> f v) q in
- Apply.iter apply_queue hooks
+ Apply.iter apply_queue hooks
end
module Make_ordered(P: sig module Id:Comparable end) =
diff --git a/src/libraries/utils/hook.mli b/src/libraries/utils/hook.mli
index c212b7882aa7d520b1a4c3e13e2516fda6eb7f3a..cbb1d654f2fb6c746a4b865a2edbdfb30d2aeac7 100644
--- a/src/libraries/utils/hook.mli
+++ b/src/libraries/utils/hook.mli
@@ -27,63 +27,63 @@
module type S = sig
type param
- (** Type of the parameter of the functions registered in the hook. *)
+ (** Type of the parameter of the functions registered in the hook. *)
type result
- (** Type of the result of the functions.
- result can be unit (for iterative hooks) or param (for folding hooks)
- *)
+ (** Type of the result of the functions.
+ result can be unit (for iterative hooks) or param (for folding hooks)
+ *)
val extend: (param -> result) -> unit
- (** Add a new function to the hook.
- @modify Oxygen-20120901 no more [once] optional arg (see [extend_once])
- *)
+ (** Add a new function to the hook.
+ @modify Oxygen-20120901 no more [once] optional arg (see [extend_once])
+ *)
val extend_once: (param -> result) -> unit
- (** Same as [extend], but the hook is added only if it is not already
- present; the comparison is made using [(==)]
+ (** Same as [extend], but the hook is added only if it is not already
+ present; the comparison is made using [(==)]
- @since Oxygen-20120901
- *)
+ @since Oxygen-20120901
+ *)
val apply: param -> result
- (** Apply all the functions of the hook on the given parameter.
- These functions are applied from the least recently entered to the most
- recently entered.*)
+ (** Apply all the functions of the hook on the given parameter.
+ These functions are applied from the least recently entered to the most
+ recently entered.*)
val is_empty: unit -> bool
- (** Is no function already registered in the hook? *)
+ (** Is no function already registered in the hook? *)
val clear: unit -> unit
- (** Clear the hook. *)
+ (** Clear the hook. *)
val length: unit -> int
- (** Number of registered functions. *)
+ (** Number of registered functions. *)
end
module type Comparable = sig
- type t
- val equal: t -> t -> bool
- val hash: t -> int
- val compare: t -> t -> int
+ type t
+ val equal: t -> t -> bool
+ val hash: t -> int
+ val compare: t -> t -> int
end
(** hook with a notion of priority.
@since Neon-20140301 *)
module type S_ordered = sig
- include S
- type key
- type id
- val register_key: key -> id
- val extend: id -> (param->result)->unit
- val extend_once: id -> (param->result) -> unit
- val add_dependency: id -> id -> unit
- (** [add_dependency hook1 hook2] indicates that [hook1] must be
- executed before [hook2]. In case of a cycle, all hooks will be
- executed, but an arbitrary order will be chosen among the
- elements of the cycle. *)
+ include S
+ type key
+ type id
+ val register_key: key -> id
+ val extend: id -> (param->result)->unit
+ val extend_once: id -> (param->result) -> unit
+ val add_dependency: id -> id -> unit
+ (** [add_dependency hook1 hook2] indicates that [hook1] must be
+ executed before [hook2]. In case of a cycle, all hooks will be
+ executed, but an arbitrary order will be chosen among the
+ elements of the cycle. *)
end
module type Iter_hook = S with type result = unit
@@ -97,7 +97,7 @@ module Make() : S with type param = unit and type result = unit
module Fold(P: sig type t end): S with type param = P.t and type result = P.t
(** @since Neon-20140301 *)
-module Build_ordered (P: sig module Id:Comparable type t end):
+module Build_ordered (P: sig module Id:Comparable type t end):
S_ordered with type key = P.Id.t and type param = P.t and type result = unit
(** @since Neon-20140301 *)
diff --git a/src/libraries/utils/hptmap.ml b/src/libraries/utils/hptmap.ml
index 670978accabdaaddc3d066435e1648dd28eaacac..6730e46d9d98110fe47323858c1e6161c426eaab 100644
--- a/src/libraries/utils/hptmap.ml
+++ b/src/libraries/utils/hptmap.ml
@@ -18,7 +18,7 @@
let debug_cache = false
type prefix = int * int
-let sentinel_prefix = (-1) , (-1)
+let sentinel_prefix = (-1) , (-1)
module Big_Endian = struct
@@ -60,7 +60,7 @@ end
(*i ------------------------------------------------------------------------ i*)
(*s \mysection{Patricia-tree-based maps} *)
-module Tag_comp :
+module Tag_comp :
sig
type t
val get_tag : t -> int
@@ -71,14 +71,14 @@ end =
struct
type t = int
let get_tag x = x land max_int
- let get_comp x = x < 0
+ let get_comp x = x < 0
let encode tag comp =
if comp then tag lor min_int else tag
let pretty fmt x = Format.fprintf fmt "%x" x
-end
+end
type tag = Tag_comp.t
-module Comp_unused =
+module Comp_unused =
struct
let e = false
let f _ _ = false
@@ -86,13 +86,13 @@ struct
end
type ('key, 'value) tree =
- | Empty
- | Leaf of 'key * 'value * tag
- | Branch of int (** prefix *) *
- Big_Endian.mask *
- ('key, 'value) tree *
- ('key, 'value) tree *
- tag
+ | Empty
+ | Leaf of 'key * 'value * tag
+ | Branch of int (** prefix *) *
+ Big_Endian.mask *
+ ('key, 'value) tree *
+ ('key, 'value) tree *
+ tag
let id tr = match tr with
| Empty -> 0
@@ -101,9 +101,9 @@ let id tr = match tr with
let hash_generic = id
-module type Id_Datatype = sig
- include Datatype.S
- val id: t -> int
+module type Id_Datatype = sig
+ include Datatype.S
+ val id: t -> int
end
module type V = sig
@@ -128,16 +128,16 @@ module Shape(Key: Id_Datatype) = struct
let t1 = Tag_comp.get_tag t1 in
let t2 = Tag_comp.get_tag t2 in
Datatype.Int.compare t1 t2
- (* Taken and adapted from JCF code for the implementation
- without tag *)
- (*let c = Datatype.Int.compare p1 p2 in
- if c <> 0 then c else
- let c = Big_endian.compare m1 m2 in
- if c <> 0 then c else
- let c = compare l1 l2 in
- if c <> 0 then c else
- compare r1 r2
- *)
+ (* Taken and adapted from JCF code for the implementation
+ without tag *)
+ (*let c = Datatype.Int.compare p1 p2 in
+ if c <> 0 then c else
+ let c = Big_endian.compare m1 m2 in
+ if c <> 0 then c else
+ let c = compare l1 l2 in
+ if c <> 0 then c else
+ compare r1 r2
+ *)
let compare =
if Key.compare == Datatype.undefined
@@ -157,706 +157,706 @@ module Shape(Key: Id_Datatype) = struct
iter f tree0;
iter f tree1
- let pretty pretty_value fmt tree =
- Pretty_utils.pp_iter2
- ~pre:"@[<v 3>{[ " ~suf:" ]}@]" ~sep:"@ " ~between:" -> "
- iter Key.pretty (fun fmt v -> Format.fprintf fmt "@[%a@]" pretty_value v)
- fmt tree
+ let pretty pretty_value fmt tree =
+ Pretty_utils.pp_iter2
+ ~pre:"@[<v 3>{[ " ~suf:" ]}@]" ~sep:"@ " ~between:" -> "
+ iter Key.pretty (fun fmt v -> Format.fprintf fmt "@[%a@]" pretty_value v)
+ fmt tree
- let hash = hash_generic
+ let hash = hash_generic
- let equal = ( == )
+ let equal = ( == )
end
module Make
- (Key: Id_Datatype)
- (V : V)
- (Compositional_bool : sig
- val e: bool
- val f : Key.t -> V.t -> bool
- val compose : bool -> bool -> bool
- end)
- (Initial_Values: sig val v : (Key.t * V.t) list list end)
- (Datatype_deps: sig val l : State.t list end)
- =
+ (Key: Id_Datatype)
+ (V : V)
+ (Compositional_bool : sig
+ val e: bool
+ val f : Key.t -> V.t -> bool
+ val compose : bool -> bool -> bool
+ end)
+ (Initial_Values: sig val v : (Key.t * V.t) list list end)
+ (Datatype_deps: sig val l : State.t list end)
+=
struct
- type key = Key.t
- type v = V.t
- module Shape = Shape(Key)
- type 'a shape = 'a Shape.t
- type prefix = int * int
-
- (* A tree is either empty, or a leaf node, containing both
- the integer key and a piece of data, or a binary node.
- Each binary node carries two integers. The first one is
- the longest common prefix of all keys in this
- sub-tree. The second integer is the branching bit.
- It is an integer with a single one bit (i.e. a power of 2),
- which describes the bit being tested at this node. *)
-
- type t = (Key.t, V.t) tree
- type hptmap = t (* Alias needed later *)
-
- let rec pretty_debug fmt = function
- | Empty -> Format.fprintf fmt "Empty"
- | Leaf (k, v, comp) as t ->
- Format.fprintf fmt
- "L@[<v>@[(A %x, T %a)@]@ @[(AK %x)%a@]@ @[ -> (AV %x)@]@ @[%a@]@]"
- (Extlib.address_of_value t) Tag_comp.pretty comp
- (Extlib.address_of_value k) Key.pretty k
- (Extlib.address_of_value v) V.pretty_debug v
- | Branch (prefix, mask, t1, t2, tag) as t ->
- Format.fprintf fmt
- "B@[<v>@[(A %x, T %a, P %x, M %x)@]@ @[%a@]@ @[ %a@]@]"
- (Extlib.address_of_value t) Tag_comp.pretty tag
- prefix mask pretty_debug t1 pretty_debug t2
-
- let compare =
- if V.compare == Datatype.undefined
- then begin
- Cmdline.Kernel_log.debug
- "(%s, %s) ptmap, missing comparison function"
- (Type.name Key.ty) (Type.name V.ty);
- Datatype.undefined
- end
- else Shape.compare V.compare
+ type key = Key.t
+ type v = V.t
+ module Shape = Shape(Key)
+ type 'a shape = 'a Shape.t
+ type prefix = int * int
+
+ (* A tree is either empty, or a leaf node, containing both
+ the integer key and a piece of data, or a binary node.
+ Each binary node carries two integers. The first one is
+ the longest common prefix of all keys in this
+ sub-tree. The second integer is the branching bit.
+ It is an integer with a single one bit (i.e. a power of 2),
+ which describes the bit being tested at this node. *)
+
+ type t = (Key.t, V.t) tree
+ type hptmap = t (* Alias needed later *)
+
+ let rec pretty_debug fmt = function
+ | Empty -> Format.fprintf fmt "Empty"
+ | Leaf (k, v, comp) as t ->
+ Format.fprintf fmt
+ "L@[<v>@[(A %x, T %a)@]@ @[(AK %x)%a@]@ @[ -> (AV %x)@]@ @[%a@]@]"
+ (Extlib.address_of_value t) Tag_comp.pretty comp
+ (Extlib.address_of_value k) Key.pretty k
+ (Extlib.address_of_value v) V.pretty_debug v
+ | Branch (prefix, mask, t1, t2, tag) as t ->
+ Format.fprintf fmt
+ "B@[<v>@[(A %x, T %a, P %x, M %x)@]@ @[%a@]@ @[ %a@]@]"
+ (Extlib.address_of_value t) Tag_comp.pretty tag
+ prefix mask pretty_debug t1 pretty_debug t2
- let compositional_bool t =
- match t with
- Empty -> Compositional_bool.e
- | Leaf (_,_,tc)
- | Branch (_,_,_,_,tc) -> Tag_comp.get_comp tc
+ let compare =
+ if V.compare == Datatype.undefined
+ then begin
+ Cmdline.Kernel_log.debug
+ "(%s, %s) ptmap, missing comparison function"
+ (Type.name Key.ty) (Type.name V.ty);
+ Datatype.undefined
+ end
+ else Shape.compare V.compare
- let rec min_binding t =
- match t with
- Empty -> raise Not_found
- | Branch (_,_,left,_,_) -> min_binding left
- | Leaf (key, data, _) -> key, data
+ let compositional_bool t =
+ match t with
+ Empty -> Compositional_bool.e
+ | Leaf (_,_,tc)
+ | Branch (_,_,_,_,tc) -> Tag_comp.get_comp tc
- let rec max_binding t =
- match t with
- Empty -> raise Not_found
- | Branch (_,_,_,right,_) -> max_binding right
- | Leaf (key, data, _) -> key, data
+ let rec min_binding t =
+ match t with
+ Empty -> raise Not_found
+ | Branch (_,_,left,_,_) -> min_binding left
+ | Leaf (key, data, _) -> key, data
- let iter = Shape.iter
+ let rec max_binding t =
+ match t with
+ Empty -> raise Not_found
+ | Branch (_,_,_,right,_) -> max_binding right
+ | Leaf (key, data, _) -> key, data
- let pretty = Shape.pretty V.pretty
+ let iter = Shape.iter
- let empty = Empty
+ let pretty = Shape.pretty V.pretty
- (* Tags must be > 0, as we use 0 for the id of Empty. *)
- let current_tag_before_initial_values = 1
- let current_tag = ref current_tag_before_initial_values
+ let empty = Empty
- let initial_values =
- let tc k v =
- let b = Compositional_bool.f k v in
- let tag = !current_tag in
- incr current_tag;
- Tag_comp.encode tag b
- in
- List.map
- (function [k,v] -> Leaf (k, v, tc k v)
- | [] -> Empty
- | _ -> assert false)
- Initial_Values.v
-
- let rehash_ref = ref (fun _ -> assert false)
-
- module D =
- Datatype.Make_with_collections
- (struct
- type t = hptmap
- let name = "(" ^ Key.name ^ ", " ^ V.name ^ ") ptmap"
- open Structural_descr
- let r = Recursive.create ()
- let structural_descr =
- if Descr.is_unmarshable Key.descr || Descr.is_unmarshable V.descr
- then t_unknown
- else
- t_sum
- [| [| Key.packed_descr; V.packed_descr; p_abstract |];
- [| p_abstract;
- p_abstract;
- recursive_pack r;
- recursive_pack r;
- p_abstract |] |]
- let () = Recursive.update r structural_descr
- let reprs = [ Empty ]
- let equal = ( == )
- let compare = compare
- let hash = hash_generic
- let rehash =
- if Descr.is_unmarshable Key.descr || Descr.is_unmarshable V.descr
- then Datatype.undefined
- else fun x -> !rehash_ref x
-
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.pp_fail
- let pretty = pretty
- let varname = Datatype.undefined
- let mem_project = Datatype.never_any_project
- end)
- let () = Type.set_ml_name D.ty None
- include (D: Datatype.S_with_collections with type t := t)
-
- module PatriciaHashconsTbl =
- State_builder.Hashconsing_tbl
- (struct
- include D
- (* At this stage, the root of the tree is _not_ hashconsed.
- The functions below cannot rely on the tags for it, only for
- the subtrees. *)
-
- let hash_internal tr = match tr with
- | Empty -> 37
- | Leaf (k, v, _) -> Key.id k + 547 * V.hash v
- | Branch(p,m,l,r, _tag) ->
- m + 3 * p + 2017 * (hash_generic l) + (hash_generic r)
-
- (* here, only one of the arguments is hash-consed *)
- let equal_internal htr1 htr2 =
- match htr1, htr2 with
- | Empty, Empty -> true
- | Leaf(k1, v1, _), Leaf(k2, v2, _) ->
- Key.equal k1 k2 && V.equal v1 v2
- | Branch(p1,m1,l1,r1,_), Branch(p2,m2,l2,r2,_) ->
- p1 = p2 && m1 = m2 && l1 == l2 && r1 == r2
- | _,_ -> false
-
- let equal_internal = equal_internal
- let hash_internal = hash_internal
- let initial_values = initial_values
- end)
- (struct
- let name = Type.name ty ^ " hashconsing table"
- let dependencies = Datatype_deps.l
- let size = 137
- end)
-
- let self = PatriciaHashconsTbl.self
-
- let id = hash_generic
-
- let wrap_Leaf k v =
- (* The test k < p+m and the implementation of [highest_bit] do not work
- with negative keys. *)
- assert (Key.id k >= 0);
+ (* Tags must be > 0, as we use 0 for the id of Empty. *)
+ let current_tag_before_initial_values = 1
+ let current_tag = ref current_tag_before_initial_values
+
+ let initial_values =
+ let tc k v =
let b = Compositional_bool.f k v in
let tag = !current_tag in
- let new_tr = Leaf (k, v, Tag_comp.encode tag b) in
- let result = PatriciaHashconsTbl.merge new_tr in
- if result == new_tr
- then current_tag := (succ tag) land max_int ;
- result
-
- let wrap_Branch p m l r =
- let b =
- Compositional_bool.compose (compositional_bool l) (compositional_bool r)
- in
- let tag = !current_tag in
- let new_tr = Branch (p, m, l, r, Tag_comp.encode tag b) in
- let result = PatriciaHashconsTbl.merge new_tr in
- if result == new_tr
- then current_tag := (succ tag) land max_int ;
- result
-
-
- (* This reference will contain a list of functions that will clear
- all the transient caches used in this module *)
- let clear_caches = ref []
-
-
- (* The auxiliary function [match_prefix] tells whether a given key has a
- given prefix. More specifically, [match_prefix k p m] returns [true] if
- and only if the key [k] has prefix [p] up to bit [m].
-
- Throughout our implementation of Patricia trees, prefixes are assumed to
- be in normal form, i.e. their irrelevant bits are set to some
- predictable value. Formally, we assume
- [Big_Endian.mask p m] equals [p] whenever
- [p] is a prefix with [m] relevant bits. This allows implementing
- [match_prefix] using only one call to [Big_Endian.mask].
- On the other hand, this
- requires normalizing prefixes, as done e.g. in [join] below, where
- [Big_Endian.mask p0 m] has to be used instead of [p0]. *)
- let match_prefix k p m =
- Big_Endian.mask k m = p
-
-
- (* [find k m] looks up the value associated to the key [k] in the map [m],
- and raises [Not_found] if no value is bound to [k].
-
- This implementation takes branches \emph{without} checking whether the
- key matches the prefix found at the current node. This means that a
- query for a non-existent key shall be detected only when finally
- reaching a leaf, rather than higher up in the tree. This strategy is
- better when (most) queries are expected to be successful. *)
- let find key htr =
- let id = Key.id key in
- let rec find htr =
- match htr with
- | Empty ->
- raise Not_found
- | Leaf (key', data, _) ->
- if Key.equal key key' then
- data
- else
- raise Not_found
- | Branch (_, mask, tree0, tree1, _) ->
- find (if (id land mask) = 0 then tree0 else tree1)
- in
- find htr
+ incr current_tag;
+ Tag_comp.encode tag b
+ in
+ List.map
+ (function [k,v] -> Leaf (k, v, tc k v)
+ | [] -> Empty
+ | _ -> assert false)
+ Initial_Values.v
+
+ let rehash_ref = ref (fun _ -> assert false)
+
+ module D =
+ Datatype.Make_with_collections
+ (struct
+ type t = hptmap
+ let name = "(" ^ Key.name ^ ", " ^ V.name ^ ") ptmap"
+ open Structural_descr
+ let r = Recursive.create ()
+ let structural_descr =
+ if Descr.is_unmarshable Key.descr || Descr.is_unmarshable V.descr
+ then t_unknown
+ else
+ t_sum
+ [| [| Key.packed_descr; V.packed_descr; p_abstract |];
+ [| p_abstract;
+ p_abstract;
+ recursive_pack r;
+ recursive_pack r;
+ p_abstract |] |]
+ let () = Recursive.update r structural_descr
+ let reprs = [ Empty ]
+ let equal = ( == )
+ let compare = compare
+ let hash = hash_generic
+ let rehash =
+ if Descr.is_unmarshable Key.descr || Descr.is_unmarshable V.descr
+ then Datatype.undefined
+ else fun x -> !rehash_ref x
+
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.pp_fail
+ let pretty = pretty
+ let varname = Datatype.undefined
+ let mem_project = Datatype.never_any_project
+ end)
+ let () = Type.set_ml_name D.ty None
+ include (D: Datatype.S_with_collections with type t := t)
+
+ module PatriciaHashconsTbl =
+ State_builder.Hashconsing_tbl
+ (struct
+ include D
+ (* At this stage, the root of the tree is _not_ hashconsed.
+ The functions below cannot rely on the tags for it, only for
+ the subtrees. *)
+
+ let hash_internal tr = match tr with
+ | Empty -> 37
+ | Leaf (k, v, _) -> Key.id k + 547 * V.hash v
+ | Branch(p,m,l,r, _tag) ->
+ m + 3 * p + 2017 * (hash_generic l) + (hash_generic r)
+
+ (* here, only one of the arguments is hash-consed *)
+ let equal_internal htr1 htr2 =
+ match htr1, htr2 with
+ | Empty, Empty -> true
+ | Leaf(k1, v1, _), Leaf(k2, v2, _) ->
+ Key.equal k1 k2 && V.equal v1 v2
+ | Branch(p1,m1,l1,r1,_), Branch(p2,m2,l2,r2,_) ->
+ p1 = p2 && m1 = m2 && l1 == l2 && r1 == r2
+ | _,_ -> false
+
+ let equal_internal = equal_internal
+ let hash_internal = hash_internal
+ let initial_values = initial_values
+ end)
+ (struct
+ let name = Type.name ty ^ " hashconsing table"
+ let dependencies = Datatype_deps.l
+ let size = 137
+ end)
+
+ let self = PatriciaHashconsTbl.self
+
+ let id = hash_generic
+
+ let wrap_Leaf k v =
+ (* The test k < p+m and the implementation of [highest_bit] do not work
+ with negative keys. *)
+ assert (Key.id k >= 0);
+ let b = Compositional_bool.f k v in
+ let tag = !current_tag in
+ let new_tr = Leaf (k, v, Tag_comp.encode tag b) in
+ let result = PatriciaHashconsTbl.merge new_tr in
+ if result == new_tr
+ then current_tag := (succ tag) land max_int ;
+ result
+
+ let wrap_Branch p m l r =
+ let b =
+ Compositional_bool.compose (compositional_bool l) (compositional_bool r)
+ in
+ let tag = !current_tag in
+ let new_tr = Branch (p, m, l, r, Tag_comp.encode tag b) in
+ let result = PatriciaHashconsTbl.merge new_tr in
+ if result == new_tr
+ then current_tag := (succ tag) land max_int ;
+ result
+
+
+ (* This reference will contain a list of functions that will clear
+ all the transient caches used in this module *)
+ let clear_caches = ref []
+
+
+ (* The auxiliary function [match_prefix] tells whether a given key has a
+ given prefix. More specifically, [match_prefix k p m] returns [true] if
+ and only if the key [k] has prefix [p] up to bit [m].
+
+ Throughout our implementation of Patricia trees, prefixes are assumed to
+ be in normal form, i.e. their irrelevant bits are set to some
+ predictable value. Formally, we assume
+ [Big_Endian.mask p m] equals [p] whenever
+ [p] is a prefix with [m] relevant bits. This allows implementing
+ [match_prefix] using only one call to [Big_Endian.mask].
+ On the other hand, this
+ requires normalizing prefixes, as done e.g. in [join] below, where
+ [Big_Endian.mask p0 m] has to be used instead of [p0]. *)
+ let match_prefix k p m =
+ Big_Endian.mask k m = p
+
+
+ (* [find k m] looks up the value associated to the key [k] in the map [m],
+ and raises [Not_found] if no value is bound to [k].
+
+ This implementation takes branches \emph{without} checking whether the
+ key matches the prefix found at the current node. This means that a
+ query for a non-existent key shall be detected only when finally
+ reaching a leaf, rather than higher up in the tree. This strategy is
+ better when (most) queries are expected to be successful. *)
+ let find key htr =
+ let id = Key.id key in
+ let rec find htr =
+ match htr with
+ | Empty ->
+ raise Not_found
+ | Leaf (key', data, _) ->
+ if Key.equal key key' then
+ data
+ else
+ raise Not_found
+ | Branch (_, mask, tree0, tree1, _) ->
+ find (if (id land mask) = 0 then tree0 else tree1)
+ in
+ find htr
- (* Similar to [find], but checks the prefix found at the current node *)
- let find_check_missing key htr =
- let id = Key.id key in
- let rec find htr =
- match htr with
- | Empty ->
- raise Not_found
- | Leaf (key', data, _) ->
- if Key.equal key key' then
- data
- else
- raise Not_found
- | Branch (prefix, mask, tree0, tree1, _) ->
- if match_prefix id prefix mask then
- find (if (id land mask) = 0 then tree0 else tree1)
- else raise Not_found
- in
- find htr
+ (* Similar to [find], but checks the prefix found at the current node *)
+ let find_check_missing key htr =
+ let id = Key.id key in
+ let rec find htr =
+ match htr with
+ | Empty ->
+ raise Not_found
+ | Leaf (key', data, _) ->
+ if Key.equal key key' then
+ data
+ else
+ raise Not_found
+ | Branch (prefix, mask, tree0, tree1, _) ->
+ if match_prefix id prefix mask then
+ find (if (id land mask) = 0 then tree0 else tree1)
+ else raise Not_found
+ in
+ find htr
- let find_key key htr =
- let id = Key.id key in
- let rec find htr =
- match htr with
- | Empty ->
- raise Not_found
- | Leaf (key', _, _) ->
- if Key.equal key key' then
- key'
- else
- raise Not_found
- | Branch (prefix, mask, tree0, tree1, _) ->
- if match_prefix id prefix mask then
- find (if (id land mask) = 0 then tree0 else tree1)
- else raise Not_found
- in
- find htr
+ let find_key key htr =
+ let id = Key.id key in
+ let rec find htr =
+ match htr with
+ | Empty ->
+ raise Not_found
+ | Leaf (key', _, _) ->
+ if Key.equal key key' then
+ key'
+ else
+ raise Not_found
+ | Branch (prefix, mask, tree0, tree1, _) ->
+ if match_prefix id prefix mask then
+ find (if (id land mask) = 0 then tree0 else tree1)
+ else raise Not_found
+ in
+ find htr
- let mem key htr =
- let id = Key.id key in
- let rec find htr =
- match htr with
- | Empty ->
- false
- | Leaf (key', _, _) ->
- Key.equal key key'
- | Branch (prefix, mask, tree0, tree1, _) ->
- if match_prefix id prefix mask then
- find (if (id land mask) = 0 then tree0 else tree1)
- else false
- in
- find htr
-
-
- (* The auxiliary function [join] merges two trees in the simple case where
- their prefixes disagree.
-
- Assume $t_0$ and $t_1$ are non-empty trees, with longest common prefixes
- $p_0$ and $p_1$, respectively. Further, suppose that $p_0$ and $p_1$
- disagree, that is, neither prefix is contained in the other. Then, no
- matter how large $t_0$ and $t_1$ are, we can merge them simply by
- creating a new [Branch] node that has $t_0$ and $t_1$ as children! *)
- let join p0 t0 p1 t1 =
- (* Computes a mask for the highest bit differing between [p0] and [p1]. *)
- let m = Big_Endian.branching_bit p0 p1 in
- let p = Big_Endian.mask p0 (* for instance *) m in
- if (p0 land m) = 0 then
- wrap_Branch p m t0 t1
- else
- wrap_Branch p m t1 t0
+ let mem key htr =
+ let id = Key.id key in
+ let rec find htr =
+ match htr with
+ | Empty ->
+ false
+ | Leaf (key', _, _) ->
+ Key.equal key key'
+ | Branch (prefix, mask, tree0, tree1, _) ->
+ if match_prefix id prefix mask then
+ find (if (id land mask) = 0 then tree0 else tree1)
+ else false
+ in
+ find htr
+
+
+ (* The auxiliary function [join] merges two trees in the simple case where
+ their prefixes disagree.
+
+ Assume $t_0$ and $t_1$ are non-empty trees, with longest common prefixes
+ $p_0$ and $p_1$, respectively. Further, suppose that $p_0$ and $p_1$
+ disagree, that is, neither prefix is contained in the other. Then, no
+ matter how large $t_0$ and $t_1$ are, we can merge them simply by
+ creating a new [Branch] node that has $t_0$ and $t_1$ as children! *)
+ let join p0 t0 p1 t1 =
+ (* Computes a mask for the highest bit differing between [p0] and [p1]. *)
+ let m = Big_Endian.branching_bit p0 p1 in
+ let p = Big_Endian.mask p0 (* for instance *) m in
+ if (p0 land m) = 0 then
+ wrap_Branch p m t0 t1
+ else
+ wrap_Branch p m t1 t0
+
+ let pretty_prefix (p,m) fmt tree =
+ let prettykv fmt k v =
+ Format.fprintf fmt "[@[%a@] -> @[%a@]@]@ " Key.pretty k V.pretty v
+ in
+ let rec pretty_prefix_aux tree =
+ match tree with
+ Empty -> ()
+ | Leaf (k,v,_) ->
+ if match_prefix (Key.id k) p m then prettykv fmt k v
+ | Branch(p1,m1,l,r,_) ->
+ if m1 <= m
+ then begin
+ if match_prefix p1 p m then iter (prettykv fmt) tree;
+ end
+ else if p land m1 = 0
+ then pretty_prefix_aux l
+ else pretty_prefix_aux r
+ in
+ Format.fprintf fmt "@[<v 2>[[";
+ pretty_prefix_aux tree;
+ Format.fprintf fmt "]]@]"
- let pretty_prefix (p,m) fmt tree =
- let prettykv fmt k v =
- Format.fprintf fmt "[@[%a@] -> @[%a@]@]@ " Key.pretty k V.pretty v
- in
- let rec pretty_prefix_aux tree =
- match tree with
- Empty -> ()
- | Leaf (k,v,_) ->
- if match_prefix (Key.id k) p m then prettykv fmt k v
- | Branch(p1,m1,l,r,_) ->
- if m1 <= m
- then begin
- if match_prefix p1 p m then iter (prettykv fmt) tree;
- end
- else if p land m1 = 0
- then pretty_prefix_aux l
- else pretty_prefix_aux r
- in
- Format.fprintf fmt "@[<v 2>[[";
- pretty_prefix_aux tree;
- Format.fprintf fmt "]]@]"
-
- type subtree = t
- exception Found_prefix of prefix * subtree * subtree
-
- let rec comp_prefixes t1 t2 =
- assert (t1 != t2);
- let all_comp = compositional_bool t1 && compositional_bool t2 in
- match t1, t2 with
- Leaf (k1, _v1, _), Leaf (k2, _v2, _) ->
- if Key.equal k1 k2 && all_comp
- then begin
-(* Format.printf "PREF leaves:@.";
- prettykv Format.std_formatter k1 _v1;
- prettykv Format.std_formatter k1 _v2; *)
- raise (Found_prefix((Key.id k1, -1), t1, t2))
- end
- | Branch (p1, m1, l1, r1, _), Branch (p2, m2, l2, r2, _) ->
- if (p1 = p2) && (m1 = m2)
- then begin
- if all_comp then begin
-(* Format.printf "PREF subtree:@.";
- pretty Format.std_formatter t1;
- pretty Format.std_formatter t2; *)
- raise (Found_prefix((p1 ,m1), t1, t2));
- end;
- let go_left = l1 != l2 in
- if go_left
- then begin
- let go_right = r1 != r2 in
- if go_right then comp_prefixes r1 r2;
- comp_prefixes l1 l2;
- end
- else begin
- assert (r1 != r2);
- comp_prefixes r1 r2;
- end
- end
- else if (Big_Endian.shorter m1 m2) && (match_prefix p2 p1 m1)
- then
- let sub1 = if (p2 land m1) = 0 then l1 else r1 in
- if sub1 != t2 then comp_prefixes sub1 t2
- else if (Big_Endian.shorter m2 m1) && (match_prefix p1 p2 m2)
- then
- let sub2 = if (p1 land m2) = 0 then l2 else r2 in
- if sub2 != t1 then
- comp_prefixes t1 sub2
- | _, _ -> ()
-
- let rec find_prefix t (p, m as prefix) =
+ type subtree = t
+ exception Found_prefix of prefix * subtree * subtree
+
+ let rec comp_prefixes t1 t2 =
+ assert (t1 != t2);
+ let all_comp = compositional_bool t1 && compositional_bool t2 in
+ match t1, t2 with
+ Leaf (k1, _v1, _), Leaf (k2, _v2, _) ->
+ if Key.equal k1 k2 && all_comp
+ then begin
+ (* Format.printf "PREF leaves:@.";
+ prettykv Format.std_formatter k1 _v1;
+ prettykv Format.std_formatter k1 _v2; *)
+ raise (Found_prefix((Key.id k1, -1), t1, t2))
+ end
+ | Branch (p1, m1, l1, r1, _), Branch (p2, m2, l2, r2, _) ->
+ if (p1 = p2) && (m1 = m2)
+ then begin
+ if all_comp then begin
+ (* Format.printf "PREF subtree:@.";
+ pretty Format.std_formatter t1;
+ pretty Format.std_formatter t2; *)
+ raise (Found_prefix((p1 ,m1), t1, t2));
+ end;
+ let go_left = l1 != l2 in
+ if go_left
+ then begin
+ let go_right = r1 != r2 in
+ if go_right then comp_prefixes r1 r2;
+ comp_prefixes l1 l2;
+ end
+ else begin
+ assert (r1 != r2);
+ comp_prefixes r1 r2;
+ end
+ end
+ else if (Big_Endian.shorter m1 m2) && (match_prefix p2 p1 m1)
+ then
+ let sub1 = if (p2 land m1) = 0 then l1 else r1 in
+ if sub1 != t2 then comp_prefixes sub1 t2
+ else if (Big_Endian.shorter m2 m1) && (match_prefix p1 p2 m2)
+ then
+ let sub2 = if (p1 land m2) = 0 then l2 else r2 in
+ if sub2 != t1 then
+ comp_prefixes t1 sub2
+ | _, _ -> ()
+
+ let rec find_prefix t (p, m as prefix) =
+ match t with
+ Empty -> None
+ | Leaf (k, _, c) ->
+ if Key.id k = p && m = -1 && (Tag_comp.get_comp c)
+ then Some t
+ else None
+ | Branch (p1, m1, l, r, tc) ->
+ if p1 = p && m1 = m
+ then (if Tag_comp.get_comp tc then Some t else None)
+ else if Big_Endian.shorter m m1
+ then None
+ else if match_prefix p p1 m1
+ then find_prefix (if p land m1 = 0 then l else r) prefix
+ else None
+
+ let hash_subtree = hash
+
+ let equal_subtree = equal
+
+ exception Unchanged
+
+ let add k d m =
+ let id = Key.id k in
+ let rec add t =
match t with
- Empty -> None
- | Leaf (k, _, c) ->
- if Key.id k = p && m = -1 && (Tag_comp.get_comp c)
- then Some t
- else None
- | Branch (p1, m1, l, r, tc) ->
- if p1 = p && m1 = m
- then (if Tag_comp.get_comp tc then Some t else None)
- else if Big_Endian.shorter m m1
- then None
- else if match_prefix p p1 m1
- then find_prefix (if p land m1 = 0 then l else r) prefix
- else None
-
- let hash_subtree = hash
-
- let equal_subtree = equal
-
- exception Unchanged
-
- let add k d m =
- let id = Key.id k in
- let rec add t =
- match t with
- | Empty ->
- wrap_Leaf k d
- | Leaf (k0, d0, _) ->
- if Key.equal k k0 then
- if d == d0 then
- raise Unchanged
- else
- wrap_Leaf k d
- else
- join id (wrap_Leaf k d) (Key.id k0) t
- | Branch (p, m, t0, t1, _) ->
- if match_prefix id p m then
- if (id land m) = 0 then wrap_Branch p m (add t0) t1
- else wrap_Branch p m t0 (add t1)
- else
- join id (wrap_Leaf k d) p t
- in
- try add m
- with Unchanged -> m
-
- let replace f k m =
- let id = Key.id k in
- let replace_empty () = match f None with
- | None -> raise Unchanged
- | Some d -> wrap_Leaf k d
- in
- let rec add t =
- match t with
- | Empty -> replace_empty ()
- | Leaf (k0, d0, _) ->
- if Key.equal k k0 then
- match f (Some d0) with
- | None -> Empty
- | Some d ->
- if d == d0 then
- raise Unchanged
- else
- wrap_Leaf k d
- else
- let new_leaf = replace_empty () in
- join id new_leaf (Key.id k0) t
- | Branch (p, m, t0, t1, _) ->
- if match_prefix id p m then
- if (id land m) = 0 then wrap_Branch p m (add t0) t1
- else wrap_Branch p m t0 (add t1)
+ | Empty ->
+ wrap_Leaf k d
+ | Leaf (k0, d0, _) ->
+ if Key.equal k k0 then
+ if d == d0 then
+ raise Unchanged
else
- let new_leaf = replace_empty () in
- join id new_leaf p t
- in
- try add m
- with Unchanged -> m
+ wrap_Leaf k d
+ else
+ join id (wrap_Leaf k d) (Key.id k0) t
+ | Branch (p, m, t0, t1, _) ->
+ if match_prefix id p m then
+ if (id land m) = 0 then wrap_Branch p m (add t0) t1
+ else wrap_Branch p m t0 (add t1)
+ else
+ join id (wrap_Leaf k d) p t
+ in
+ try add m
+ with Unchanged -> m
+
+ let replace f k m =
+ let id = Key.id k in
+ let replace_empty () = match f None with
+ | None -> raise Unchanged
+ | Some d -> wrap_Leaf k d
+ in
+ let rec add t =
+ match t with
+ | Empty -> replace_empty ()
+ | Leaf (k0, d0, _) ->
+ if Key.equal k k0 then
+ match f (Some d0) with
+ | None -> Empty
+ | Some d ->
+ if d == d0 then
+ raise Unchanged
+ else
+ wrap_Leaf k d
+ else
+ let new_leaf = replace_empty () in
+ join id new_leaf (Key.id k0) t
+ | Branch (p, m, t0, t1, _) ->
+ if match_prefix id p m then
+ if (id land m) = 0 then wrap_Branch p m (add t0) t1
+ else wrap_Branch p m t0 (add t1)
+ else
+ let new_leaf = replace_empty () in
+ join id new_leaf p t
+ in
+ try add m
+ with Unchanged -> m
- let singleton k d =
- wrap_Leaf k d
+ let singleton k d =
+ wrap_Leaf k d
- let is_singleton htr = match htr with
+ let is_singleton htr = match htr with
| Leaf (k, d, _) ->
- Some (k, d)
+ Some (k, d)
| Empty
| Branch _ ->
- None
+ None
- let on_singleton f htr = match htr with
+ let on_singleton f htr = match htr with
| Leaf (k, d, _) -> f k d
| Empty | Branch _ -> false
- let is_empty htr = match htr with
+ let is_empty htr = match htr with
| Empty ->
- true
+ true
| Leaf _
| Branch _ ->
- false
+ false
- let rec cardinal htr = match htr with
+ let rec cardinal htr = match htr with
| Empty ->
- 0
+ 0
| Leaf _ ->
- 1
+ 1
| Branch (_, _, t0, t1, _) ->
- cardinal t0 + cardinal t1
+ cardinal t0 + cardinal t1
- let remove key m =
- let id = Key.id key in
- let rec remove htr = match htr with
- | Empty ->
- raise Not_found
- | Leaf (key', _, _) ->
- if Key.equal key key' then
- Empty
- else
- raise Not_found
- | Branch (prefix, mask, tree0, tree1, _) ->
- if match_prefix id prefix mask then
- if (id land mask) = 0 then
- let rtree0 = remove tree0 in
- match rtree0 with
- | Empty ->
- tree1
- | _ ->
- if rtree0 == tree0 then
- htr
- else
- wrap_Branch prefix mask rtree0 tree1
- else
- let rtree1 = remove tree1 in
- match rtree1 with
- | Empty ->
- tree0
- | _ ->
- if rtree1 == tree1 then
- htr
- else
- wrap_Branch prefix mask tree0 rtree1
+ let remove key m =
+ let id = Key.id key in
+ let rec remove htr = match htr with
+ | Empty ->
+ raise Not_found
+ | Leaf (key', _, _) ->
+ if Key.equal key key' then
+ Empty
+ else
+ raise Not_found
+ | Branch (prefix, mask, tree0, tree1, _) ->
+ if match_prefix id prefix mask then
+ if (id land mask) = 0 then
+ let rtree0 = remove tree0 in
+ match rtree0 with
+ | Empty ->
+ tree1
+ | _ ->
+ if rtree0 == tree0 then
+ htr
+ else
+ wrap_Branch prefix mask rtree0 tree1
else
- raise Not_found
- in
- try
- remove m
- with Not_found ->
- m
+ let rtree1 = remove tree1 in
+ match rtree1 with
+ | Empty ->
+ tree0
+ | _ ->
+ if rtree1 == tree1 then
+ htr
+ else
+ wrap_Branch prefix mask tree0 rtree1
+ else
+ raise Not_found
+ in
+ try
+ remove m
+ with Not_found ->
+ m
(*
(** [find_and_remove k m] looks up the value [v] associated to the key [k]
- in the map [m], and raises [Not_found] if no value is bound to [k]. The
- call returns the value [v], together with the map [m] deprived from the
- binding from [k] to [v]. *)
+ in the map [m], and raises [Not_found] if no value is bound to [k]. The
+ call returns the value [v], together with the map [m] deprived from the
+ binding from [k] to [v]. *)
let find_and_remove key htr =
let id = Key.id key in
let rec find_and_remove htr =
match htr with
| Empty ->
- raise Not_found
+ raise Not_found
| Leaf (key', data, _) ->
- if Key.equal key key' then
- data, Empty
- else
- raise Not_found
+ if Key.equal key key' then
+ data, Empty
+ else
+ raise Not_found
| Branch (prefix, mask, tree0, tree1, _) ->
- if (id land mask) = 0 then
- match find_and_remove tree0 with
- | data, Empty ->
- data, tree1
- | data, tree0 ->
- data, (wrap_Branch prefix mask tree0 tree1)
- else
- match find_and_remove tree1 with
- | data, Empty ->
- data, tree0
- | data, tree1 ->
- data, (wrap_Branch prefix mask tree0 tree1)
+ if (id land mask) = 0 then
+ match find_and_remove tree0 with
+ | data, Empty ->
+ data, tree1
+ | data, tree0 ->
+ data, (wrap_Branch prefix mask tree0 tree1)
+ else
+ match find_and_remove tree1 with
+ | data, Empty ->
+ data, tree0
+ | data, tree1 ->
+ data, (wrap_Branch prefix mask tree0 tree1)
in
find_and_remove htr
*)
- let rec fold f m accu =
- match m with
- | Empty ->
- accu
- | Leaf (key, data, _) ->
- f key data accu
- | Branch (_, _, tree0, tree1, _) ->
- fold f tree1 (fold f tree0 accu)
-
- let rec fold_rev f m accu =
- match m with
- | Empty ->
- accu
- | Leaf (key, data, _) ->
- f key data accu
- | Branch (_, _, tree0, tree1, _) ->
- fold_rev f tree0 (fold_rev f tree1 accu)
-
- let rehash_node = function
- | Empty -> Empty
- | Leaf (k, v, _) -> wrap_Leaf k v
- | Branch (p,m,l,r,_) ->
- if Descr.is_abstract Key.descr then
- (* The keys id have not been modified during de-marshalling.
- The shapes of [l] and [r] are compatible, just merge them. *)
- wrap_Branch p m l r
- else
- (* The ids may have been modified, the trees can overlap. Rebuild
- everything from scratch. *)
- fold add l r
+ let rec fold f m accu =
+ match m with
+ | Empty ->
+ accu
+ | Leaf (key, data, _) ->
+ f key data accu
+ | Branch (_, _, tree0, tree1, _) ->
+ fold f tree1 (fold f tree0 accu)
- let () = rehash_ref := rehash_node
+ let rec fold_rev f m accu =
+ match m with
+ | Empty ->
+ accu
+ | Leaf (key, data, _) ->
+ f key data accu
+ | Branch (_, _, tree0, tree1, _) ->
+ fold_rev f tree0 (fold_rev f tree1 accu)
+
+ let rehash_node = function
+ | Empty -> Empty
+ | Leaf (k, v, _) -> wrap_Leaf k v
+ | Branch (p,m,l,r,_) ->
+ if Descr.is_abstract Key.descr then
+ (* The keys id have not been modified during de-marshalling.
+ The shapes of [l] and [r] are compatible, just merge them. *)
+ wrap_Branch p m l r
+ else
+ (* The ids may have been modified, the trees can overlap. Rebuild
+ everything from scratch. *)
+ fold add l r
+ let () = rehash_ref := rehash_node
- let rec for_all f m =
- match m with
- | Empty -> true
- | Leaf (key, data, _) -> f key data
- | Branch (_, _, tree0, tree1, _) -> for_all f tree0 && for_all f tree1
- let rec exists f m =
- match m with
- | Empty -> false
- | Leaf (key, data, _) -> f key data
- | Branch (_, _, tree0, tree1, _) -> exists f tree0 || exists f tree1
+ let rec for_all f m =
+ match m with
+ | Empty -> true
+ | Leaf (key, data, _) -> f key data
+ | Branch (_, _, tree0, tree1, _) -> for_all f tree0 && for_all f tree1
+ let rec exists f m =
+ match m with
+ | Empty -> false
+ | Leaf (key, data, _) -> f key data
+ | Branch (_, _, tree0, tree1, _) -> exists f tree0 || exists f tree1
- let rec map f htr = match htr with
- | Empty ->
- Empty
- | Leaf (key, data, _) ->
- let data' = f data in
- if data == data' then htr
- else
- wrap_Leaf key data'
- | Branch (p, m, tree0, tree1, _) ->
- let tree0' = map f tree0 in
- let tree1' = map f tree1 in
- if tree0' == tree0 && tree1' == tree1 then htr
- else
- wrap_Branch p m tree0' tree1'
-
- let rec map' f htr = match htr with
- | Empty -> Empty
- | Leaf (key, data, _) ->
- begin
- match f key data with
- | Some data' -> if data == data' then htr else wrap_Leaf key data'
- | None -> Empty
- end
- | Branch (p, m, tree0, tree1, _) ->
- let tree0' = map' f tree0 and tree1' = map' f tree1 in
- if tree0' == tree0 && tree1' == tree1
- then htr
- else if tree0' == Empty then tree1'
- else if tree1' == Empty then tree0'
- else wrap_Branch p m tree0' tree1'
-
- let rec filter f htr = match htr with
- | Empty -> Empty
- | Leaf (key, _data, _) ->
- if f key then htr else Empty
- | Branch (p, m, tree0, tree1, _) ->
- let tree0' = filter f tree0 and tree1' = filter f tree1 in
- if tree0' == tree0 && tree1' == tree1
- then htr
- else if tree0' == Empty then tree1'
- else if tree1' == Empty then tree0'
- else wrap_Branch p m tree0' tree1'
-
- (** [endo_map] is similar to [map], but attempts to physically share its
- result with its input. This saves memory when [f] is the identity
- function. *)
- let rec endo_map f tree =
- match tree with
- | Empty ->
- tree
- | Leaf (key, data, _) ->
- let data' = f key data in
- if data == data' then
- tree
- else
- wrap_Leaf key data'
- | Branch (p, m, tree0, tree1, _) ->
- let tree0' = endo_map f tree0 in
- let tree1' = endo_map f tree1 in
- if (tree0' == tree0) && (tree1' == tree1) then
- tree
- else
- wrap_Branch p m tree0' tree1'
-
- let rec from_shape f = function
- | Empty -> Empty
- | Leaf (key, value, _) -> wrap_Leaf key (f key value)
- | Branch (p, m, t1, t2, _) ->
- wrap_Branch p m (from_shape f t1) (from_shape f t2)
-
- let rec from_shape_id = function
- | Empty -> Empty
- | Leaf (key, value, _) -> wrap_Leaf key value
- | Branch (p, m, t1, t2, _) as t ->
- let t1' = from_shape_id t1 in
- let t2' = from_shape_id t2 in
- if (t1' == t1) && (t2' == t2)
- then t
- else wrap_Branch p m t1' t2'
+
+ let rec map f htr = match htr with
+ | Empty ->
+ Empty
+ | Leaf (key, data, _) ->
+ let data' = f data in
+ if data == data' then htr
+ else
+ wrap_Leaf key data'
+ | Branch (p, m, tree0, tree1, _) ->
+ let tree0' = map f tree0 in
+ let tree1' = map f tree1 in
+ if tree0' == tree0 && tree1' == tree1 then htr
+ else
+ wrap_Branch p m tree0' tree1'
+
+ let rec map' f htr = match htr with
+ | Empty -> Empty
+ | Leaf (key, data, _) ->
+ begin
+ match f key data with
+ | Some data' -> if data == data' then htr else wrap_Leaf key data'
+ | None -> Empty
+ end
+ | Branch (p, m, tree0, tree1, _) ->
+ let tree0' = map' f tree0 and tree1' = map' f tree1 in
+ if tree0' == tree0 && tree1' == tree1
+ then htr
+ else if tree0' == Empty then tree1'
+ else if tree1' == Empty then tree0'
+ else wrap_Branch p m tree0' tree1'
+
+ let rec filter f htr = match htr with
+ | Empty -> Empty
+ | Leaf (key, _data, _) ->
+ if f key then htr else Empty
+ | Branch (p, m, tree0, tree1, _) ->
+ let tree0' = filter f tree0 and tree1' = filter f tree1 in
+ if tree0' == tree0 && tree1' == tree1
+ then htr
+ else if tree0' == Empty then tree1'
+ else if tree1' == Empty then tree0'
+ else wrap_Branch p m tree0' tree1'
+
+ (** [endo_map] is similar to [map], but attempts to physically share its
+ result with its input. This saves memory when [f] is the identity
+ function. *)
+ let rec endo_map f tree =
+ match tree with
+ | Empty ->
+ tree
+ | Leaf (key, data, _) ->
+ let data' = f key data in
+ if data == data' then
+ tree
+ else
+ wrap_Leaf key data'
+ | Branch (p, m, tree0, tree1, _) ->
+ let tree0' = endo_map f tree0 in
+ let tree1' = endo_map f tree1 in
+ if (tree0' == tree0) && (tree1' == tree1) then
+ tree
+ else
+ wrap_Branch p m tree0' tree1'
+
+ let rec from_shape f = function
+ | Empty -> Empty
+ | Leaf (key, value, _) -> wrap_Leaf key (f key value)
+ | Branch (p, m, t1, t2, _) ->
+ wrap_Branch p m (from_shape f t1) (from_shape f t2)
+
+ let rec from_shape_id = function
+ | Empty -> Empty
+ | Leaf (key, value, _) -> wrap_Leaf key value
+ | Branch (p, m, t1, t2, _) as t ->
+ let t1' = from_shape_id t1 in
+ let t2' = from_shape_id t2 in
+ if (t1' == t1) && (t2' == t2)
+ then t
+ else wrap_Branch p m t1' t2'
module Cacheable = struct
@@ -892,15 +892,15 @@ struct
| Hptmap_sig.NoCache -> (fun f x y -> f x y)
| Hptmap_sig.PersistentCache _name | Hptmap_sig.TemporaryCache _name ->
if debug_cache then Format.eprintf "CACHE generic_merge %s@." _name;
- let module Cache =
- (val if symmetric
- then (module Binary_cache.Symmetric_Binary (Cacheable) (R) : I)
- else (module Binary_cache.Arity_Two (Cacheable) (Cacheable) (R) : I)
- : I)
- in
- if cache = Hptmap_sig.PersistentCache _name
- then clear_caches := Cache.clear :: !clear_caches;
- Cache.merge
+ let module Cache =
+ (val if symmetric
+ then (module Binary_cache.Symmetric_Binary (Cacheable) (R) : I)
+ else (module Binary_cache.Arity_Two (Cacheable) (Cacheable) (R) : I)
+ : I)
+ in
+ if cache = Hptmap_sig.PersistentCache _name
+ then clear_caches := Cache.clear :: !clear_caches;
+ Cache.merge
in
(* Rewrap of branches.
The initials branches and tree are provided in order to avoid the wrapping
@@ -951,30 +951,30 @@ struct
let rec merge_leaf tree = cache add leaf tree
and add leaf tree =
match tree with
- | Empty -> decide_leaf leaf
- | Leaf (key', data', _) ->
- if idempotent && leaf == tree then leaf
- else if Key.equal key key'
- then
- decide_both key data' tree data leaf
- else
- let tree' = decide_tree tree
- and leaf' = decide_leaf leaf in
- rejoin k_id leaf' (Key.id key') tree'
- | Branch (p, m, t0, t1, _) ->
- if match_prefix k_id p m then
- if (k_id land m) = 0 then
- let t0' = merge_leaf t0
- and t1' = decide_tree t1 in
- rewrap p m t0' t0 t1' t1 tree
- else
- let t1' = merge_leaf t1
- and t0' = decide_tree t0 in
- rewrap p m t0' t0 t1' t1 tree
- else
- let tree' = decide_tree tree
- and leaf' = decide_leaf leaf in
- rejoin k_id leaf' p tree'
+ | Empty -> decide_leaf leaf
+ | Leaf (key', data', _) ->
+ if idempotent && leaf == tree then leaf
+ else if Key.equal key key'
+ then
+ decide_both key data' tree data leaf
+ else
+ let tree' = decide_tree tree
+ and leaf' = decide_leaf leaf in
+ rejoin k_id leaf' (Key.id key') tree'
+ | Branch (p, m, t0, t1, _) ->
+ if match_prefix k_id p m then
+ if (k_id land m) = 0 then
+ let t0' = merge_leaf t0
+ and t1' = decide_tree t1 in
+ rewrap p m t0' t0 t1' t1 tree
+ else
+ let t1' = merge_leaf t1
+ and t0' = decide_tree t0 in
+ rewrap p m t0' t0 t1' t1 tree
+ else
+ let tree' = decide_tree tree
+ and leaf' = decide_leaf leaf in
+ rejoin k_id leaf' p tree'
in
merge_leaf tree
in
@@ -989,10 +989,10 @@ struct
| Leaf (key, v, _), _ -> merge_left_leaf key v s t
| _, Leaf (key, v, _) -> merge_right_leaf key v t s
| Branch (p, m, s0, s1, _), Branch (q, n, t0, t1, _) ->
- let descend = fun s t ->
- merge_branches s (p, m, s0, s1) t (q, n, t0, t1)
- in
- cache_merge descend s t
+ let descend = fun s t ->
+ merge_branches s (p, m, s0, s1) t (q, n, t0, t1)
+ in
+ cache_merge descend s t
(* Called for the recursive descend in two trees.
[s] is [Branch (p, m, s0, s1)] and [t] is [Branch (q, n, t0, t1)]. *)
and merge_branches s (p, m, s0, s1) t (q, n, t0, t1) =
@@ -1039,10 +1039,10 @@ struct
fun ~cache ~symmetric ~idempotent ~decide_both ~decide_left ~decide_right ->
let decide_both key value leaf value' leaf' =
match decide_both key value value' with
- | Some v ->
- if v == value then leaf else if v == value' then leaf'
- else wrap_Leaf key v
- | None -> Empty
+ | Some v ->
+ if v == value then leaf else if v == value' then leaf'
+ else wrap_Leaf key v
+ | None -> Empty
in
generic_merge ~cache ~symmetric ~idempotent ~increasing:false
~decide_both
@@ -1061,7 +1061,7 @@ struct
~decide_both ~decide_left ~decide_right
let join ~cache ~symmetric ~idempotent ~decide =
- let decide_both key value leaf value' leaf' =
+ let decide_both key value leaf value' leaf' =
let v = decide key value value' in
if v == value then leaf else if v == value' then leaf'
else wrap_Leaf key v
@@ -1071,12 +1071,12 @@ struct
~decide_both ~decide_left:decide_none ~decide_right:decide_none
let inter ~cache ~symmetric ~idempotent ~decide =
- let decide_both key value leaf value' leaf' =
- match decide key value value' with
- | Some v ->
- if v == value then leaf else if v == value' then leaf'
- else wrap_Leaf key v
- | None -> Empty
+ let decide_both key value leaf value' leaf' =
+ match decide key value value' with
+ | Some v ->
+ if v == value then leaf else if v == value' then leaf'
+ else wrap_Leaf key v
+ | None -> Empty
and decide_none = fun _ -> Empty
in
generic_merge ~cache ~symmetric ~idempotent ~increasing:false
@@ -1180,9 +1180,9 @@ struct
if debug_cache then Format.eprintf "CACHE fold2_join_heterogeneous %s@." _name;
let module Arg = struct
type t = (Key.t, arg) tree
- let hash : t -> int = hash_generic
- let sentinel : t = Empty
- let equal : t -> t -> bool = (==)
+ let hash : t -> int = hash_generic
+ let sentinel : t = Empty
+ let equal : t -> t -> bool = (==)
end in
let module Result = struct
type t = result
@@ -1190,9 +1190,9 @@ struct
end in
let module Cache = Binary_cache.Arity_Two(Cacheable)(Arg)(Result) in
(match cache with
- | Hptmap_sig.PersistentCache _ ->
- clear_caches := Cache.clear :: !clear_caches
- | _ -> ());
+ | Hptmap_sig.PersistentCache _ ->
+ clear_caches := Cache.clear :: !clear_caches
+ | _ -> ());
Cache.merge
in
let rec compute s t = cache_merge aux s t
@@ -1220,165 +1220,165 @@ struct
| Leaf (ks, _, _), Branch(q, n, t0, t1, _) ->
let k_id = Key.id ks in
- if match_prefix k_id q n then
- if (k_id land n) = 0 then
+ if match_prefix k_id q n then
+ if (k_id land n) = 0 then
join (compute s t0) (empty_left t1)
- else
+ else
join (compute s t1) (empty_left t0)
- else
+ else
join (empty_right s) (empty_left t)
| Branch(p, m, s0, s1, _), Branch(q, n, t0, t1, _) ->
- if (p = q) && (m = n) then
- (* The trees have the same prefix. recurse on the sub-trees *)
+ if (p = q) && (m = n) then
+ (* The trees have the same prefix. recurse on the sub-trees *)
join (compute s0 t0) (compute s1 t1)
- else if (Big_Endian.shorter m n) && (match_prefix q p m) then
+ else if (Big_Endian.shorter m n) && (match_prefix q p m) then
(* [q] contains [p]. Merge [t] with a sub-tree of [s]. *)
- if (q land m) = 0 then
- join (compute s0 t) (empty_right s1)
- else
+ if (q land m) = 0 then
+ join (compute s0 t) (empty_right s1)
+ else
join (compute s1 t) (empty_right s0)
- else if (Big_Endian.shorter n m) && (match_prefix p q n) then
- (* [p] contains [q]. Merge [s] with a sub-tree of [t]. *)
- if (p land n) = 0 then
+ else if (Big_Endian.shorter n m) && (match_prefix p q n) then
+ (* [p] contains [q]. Merge [s] with a sub-tree of [t]. *)
+ if (p land n) = 0 then
join (compute s t0) (empty_left t1)
- else
+ else
join (compute s t1) (empty_left t0)
- else
- (* The prefixes disagree. *)
+ else
+ (* The prefixes disagree. *)
join (empty_right s) (empty_left t)
in
fun s t -> compute s t
- type decide_fast = Done | Unknown
+ type decide_fast = Done | Unknown
- let make_predicate cache_merge exn ~decide_fast ~decide_fst ~decide_snd ~decide_both =
- let rec aux s t =
- if decide_fast s t = Unknown then
+ let make_predicate cache_merge exn ~decide_fast ~decide_fst ~decide_snd ~decide_both =
+ let rec aux s t =
+ if decide_fast s t = Unknown then
match s, t with
| Empty, _ ->
- iter decide_snd t
+ iter decide_snd t
| (Leaf _ | Branch _), Empty ->
- iter decide_fst s
+ iter decide_fst s
| Leaf(k1, v1, _), Leaf(k2, v2, _) ->
- if Key.id k1 = Key.id k2
- then decide_both v1 v2
- else begin
- decide_fst k1 v1;
- decide_snd k2 v2;
- end
- | Leaf(key, _value, _), Branch(p,m,l,r,_) ->
- let i = Key.id key in
- if i < p+m
- then begin
- aux s l;
- aux Empty r;
- end
- else begin
- aux Empty l;
- aux s r;
- end
+ if Key.id k1 = Key.id k2
+ then decide_both v1 v2
+ else begin
+ decide_fst k1 v1;
+ decide_snd k2 v2;
+ end
+ | Leaf(key, _value, _), Branch(p,m,l,r,_) ->
+ let i = Key.id key in
+ if i < p+m
+ then begin
+ aux s l;
+ aux Empty r;
+ end
+ else begin
+ aux Empty l;
+ aux s r;
+ end
| Branch (p,m,l,r,_) , Leaf(key, _value, _) ->
- let i = Key.id key in
- if i < p+m
- then begin
- aux l t;
- aux r Empty;
- end
- else begin
- aux l Empty;
- aux r t;
- end
+ let i = Key.id key in
+ if i < p+m
+ then begin
+ aux l t;
+ aux r Empty;
+ end
+ else begin
+ aux l Empty;
+ aux r t;
+ end
| Branch _, Branch _ ->
(* Beware that [cache_merge compute] may swap the order of its
arguments compared to [aux]. Do not use the result of the match
in [aux] directly inside [compute]. *)
let compute s t = match s, t with
| Branch(p, m, s0, s1, _), Branch(q, n, t0, t1, _) -> begin
- try
- if (p = q) && (m = n) then
- begin
- (*The trees have the same prefix. Compare their sub-trees.*)
- aux s0 t0;
- aux s1 t1
- end
- else if (Big_Endian.shorter m n) && (match_prefix q p m) then
- (* [q] contains [p]. Compare [t] with a sub-tree of [s]. *)
- if (q land m) = 0 then
- begin
- aux s0 t;
- aux s1 Empty;
- end
- else
- begin
- aux s0 Empty;
- aux s1 t
- end
- else if (Big_Endian.shorter n m) && (match_prefix p q n) then
- (* [p] contains [q]. Compare [s] with a sub-tree of [t]. *)
- if (p land n) = 0 then
- begin
- aux s t0;
- aux Empty t1
- end
- else
- begin
- aux s t1;
- aux Empty t0
- end
- else
- begin
- (* The prefixes disagree. *)
- aux s Empty;
- aux Empty t;
- end;
- true
- with e when e = exn -> false
- | _ -> assert false
+ try
+ if (p = q) && (m = n) then
+ begin
+ (*The trees have the same prefix. Compare their sub-trees.*)
+ aux s0 t0;
+ aux s1 t1
+ end
+ else if (Big_Endian.shorter m n) && (match_prefix q p m) then
+ (* [q] contains [p]. Compare [t] with a sub-tree of [s]. *)
+ if (q land m) = 0 then
+ begin
+ aux s0 t;
+ aux s1 Empty;
+ end
+ else
+ begin
+ aux s0 Empty;
+ aux s1 t
+ end
+ else if (Big_Endian.shorter n m) && (match_prefix p q n) then
+ (* [p] contains [q]. Compare [s] with a sub-tree of [t]. *)
+ if (p land n) = 0 then
+ begin
+ aux s t0;
+ aux Empty t1
+ end
+ else
+ begin
+ aux s t1;
+ aux Empty t0
+ end
+ else
+ begin
+ (* The prefixes disagree. *)
+ aux s Empty;
+ aux Empty t;
+ end;
+ true
+ with e when e = exn -> false
+ | _ -> assert false
end
| _ -> assert false (* Branch/Branch comparison *)
- in
- let result = cache_merge compute s t in
- if not result then raise exn
- in
- aux
-
- let replace_key ~decide shape map =
- let cache = Hptmap_sig.NoCache in
- let inter, diff = partition_with_shape shape map in
- if is_empty inter
- then false, map
- else
- let join = join ~cache ~symmetric:true ~idempotent:true ~decide in
- let both _key value new_key = singleton new_key value in
- let new_inter =
- fold2_join_heterogeneous
- ~cache
- ~empty_left:(fun _ -> empty)
- ~empty_right:(fun _ -> assert false)
- ~empty
- ~both ~join inter shape
in
- true, join new_inter diff
-
- let generic_predicate exn ~cache ~decide_fast ~decide_fst ~decide_snd ~decide_both =
- if debug_cache then Format.eprintf "CACHE generic_predicate %s@." (fst cache);
- let module Cache =
- Binary_cache.Binary_Predicate(Cacheable)(Cacheable)
+ let result = cache_merge compute s t in
+ if not result then raise exn
+ in
+ aux
+
+ let replace_key ~decide shape map =
+ let cache = Hptmap_sig.NoCache in
+ let inter, diff = partition_with_shape shape map in
+ if is_empty inter
+ then false, map
+ else
+ let join = join ~cache ~symmetric:true ~idempotent:true ~decide in
+ let both _key value new_key = singleton new_key value in
+ let new_inter =
+ fold2_join_heterogeneous
+ ~cache
+ ~empty_left:(fun _ -> empty)
+ ~empty_right:(fun _ -> assert false)
+ ~empty
+ ~both ~join inter shape
in
- clear_caches := Cache.clear :: !clear_caches;
- make_predicate Cache.merge exn
- ~decide_fast ~decide_fst ~decide_snd ~decide_both
+ true, join new_inter diff
+
+ let generic_predicate exn ~cache ~decide_fast ~decide_fst ~decide_snd ~decide_both =
+ if debug_cache then Format.eprintf "CACHE generic_predicate %s@." (fst cache);
+ let module Cache =
+ Binary_cache.Binary_Predicate(Cacheable)(Cacheable)
+ in
+ clear_caches := Cache.clear :: !clear_caches;
+ make_predicate Cache.merge exn
+ ~decide_fast ~decide_fst ~decide_snd ~decide_both
- let generic_symmetric_predicate exn ~decide_fast ~decide_one ~decide_both =
- if debug_cache then Format.eprintf "CACHE generic_symmetric_predicate@.";
- let module Cache =
- Binary_cache.Symmetric_Binary_Predicate(Cacheable)
- in
- clear_caches := Cache.clear :: !clear_caches;
- make_predicate Cache.merge exn
- ~decide_fast ~decide_fst:decide_one ~decide_snd:decide_one ~decide_both
+ let generic_symmetric_predicate exn ~decide_fast ~decide_one ~decide_both =
+ if debug_cache then Format.eprintf "CACHE generic_symmetric_predicate@.";
+ let module Cache =
+ Binary_cache.Symmetric_Binary_Predicate(Cacheable)
+ in
+ clear_caches := Cache.clear :: !clear_caches;
+ make_predicate Cache.merge exn
+ ~decide_fast ~decide_fst:decide_one ~decide_snd:decide_one ~decide_both
type predicate_type = ExistentialPredicate | UniversalPredicate
@@ -1386,8 +1386,8 @@ struct
let decide_fast_intersection s t =
match s, t with
- | Empty, _ | _, Empty -> PFalse
- | _ -> if s == t then PTrue else PUnknown
+ | Empty, _ | _, Empty -> PFalse
+ | _ -> if s == t then PTrue else PUnknown
let decide_fast_inclusion s t =
if s == t || s == Empty then PTrue else PUnknown
@@ -1399,15 +1399,15 @@ struct
two functions... *)
let comb1, comb2 =
match pt with
- | UniversalPredicate -> let f b f v1 v2 = b && f v1 v2 in f, f
- | ExistentialPredicate -> let f b f v1 v2 = b || f v1 v2 in f, f
+ | UniversalPredicate -> let f b f v1 v2 = b && f v1 v2 in f, f
+ | ExistentialPredicate -> let f b f v1 v2 = b || f v1 v2 in f, f
in
let rec aux s t =
match s, t with
| Empty, Empty ->
(match pt with
- | ExistentialPredicate -> false
- | UniversalPredicate -> true)
+ | ExistentialPredicate -> false
+ | UniversalPredicate -> true)
| Leaf (key, data, _), Empty ->
decide_fst key data
@@ -1422,43 +1422,43 @@ struct
comb1 (aux' tl Empty) aux' tr Empty
| Leaf(k1, v1, _), Leaf(k2, v2, _) ->
- if Key.id k1 = Key.id k2
- then decide_both k1 v1 v2
+ if Key.id k1 = Key.id k2
+ then decide_both k1 v1 v2
else comb2 (decide_fst k1 v1) decide_snd k2 v2
| Leaf(key, _value, _), Branch(p,m,l,r,_) ->
- let i = Key.id key in
- if i < p+m
- then comb1 (aux' Empty r) aux' s l
- else comb1 (aux' Empty l) aux' s r
+ let i = Key.id key in
+ if i < p+m
+ then comb1 (aux' Empty r) aux' s l
+ else comb1 (aux' Empty l) aux' s r
| Branch (p,m,l,r,_) , Leaf(key, _value, _) ->
- let i = Key.id key in
- if i < p+m
- then comb1 (aux' r Empty) aux' l t
- else comb1 (aux' l Empty) aux' r t
+ let i = Key.id key in
+ if i < p+m
+ then comb1 (aux' r Empty) aux' l t
+ else comb1 (aux' l Empty) aux' r t
| Branch(p, m, s0, s1, _), Branch(q, n, t0, t1, _) ->
- if (p = q) && (m = n) then
+ if (p = q) && (m = n) then
(*The trees have the same prefix. Compare their sub-trees.*)
comb1 (aux' s0 t0) aux' s1 t1
- else if (Big_Endian.shorter m n) && (match_prefix q p m) then
- (* [q] contains [p]. Compare [t] with a sub-tree of [s]. *)
- if (q land m) = 0
+ else if (Big_Endian.shorter m n) && (match_prefix q p m) then
+ (* [q] contains [p]. Compare [t] with a sub-tree of [s]. *)
+ if (q land m) = 0
then comb1 (aux' s1 Empty) aux' s0 t
- else comb1 (aux' s0 Empty) aux' s1 t
- else if (Big_Endian.shorter n m) && (match_prefix p q n) then
- (* [p] contains [q]. Compare [s] with a sub-tree of [t]. *)
- if (p land n) = 0
+ else comb1 (aux' s0 Empty) aux' s1 t
+ else if (Big_Endian.shorter n m) && (match_prefix p q n) then
+ (* [p] contains [q]. Compare [s] with a sub-tree of [t]. *)
+ if (p land n) = 0
then comb1 (aux' s t0) aux' Empty t1
- else comb1 (aux' s t1) aux' Empty t0
- else (* The prefixes disagree. *)
- comb1 (aux' s Empty) aux' Empty t
+ else comb1 (aux' s t1) aux' Empty t0
+ else (* The prefixes disagree. *)
+ comb1 (aux' s Empty) aux' Empty t
and aux' s t =
match decide_fast s t with
- | PFalse -> false
- | PTrue -> true
- | PUnknown -> cache_merge aux s t
+ | PFalse -> false
+ | PTrue -> true
+ | PUnknown -> cache_merge aux s t
in
aux'
@@ -1469,12 +1469,12 @@ struct
| Hptmap_sig.PersistentCache _name | Hptmap_sig.TemporaryCache _name ->
if debug_cache then Format.eprintf "CACHE binary_predicate %s@." _name;
let module Cache =
- Binary_cache.Binary_Predicate(Cacheable)(Cacheable)
+ Binary_cache.Binary_Predicate(Cacheable)(Cacheable)
in
(match ct with
- | Hptmap_sig.PersistentCache _ ->
- clear_caches := Cache.clear :: !clear_caches
- | _ -> ());
+ | Hptmap_sig.PersistentCache _ ->
+ clear_caches := Cache.clear :: !clear_caches
+ | _ -> ());
Cache.merge
in
make_binary_predicate cache_merge pt
@@ -1487,84 +1487,84 @@ struct
if debug_cache then Format.eprintf "CACHE symmetric_binary_predicate %s@." _name;
let module Cache = Binary_cache.Symmetric_Binary_Predicate(Cacheable) in
(match ct with
- | Hptmap_sig.PersistentCache _ ->
- clear_caches := Cache.clear :: !clear_caches
- | _ -> ());
+ | Hptmap_sig.PersistentCache _ ->
+ clear_caches := Cache.clear :: !clear_caches
+ | _ -> ());
Cache.merge
in
make_binary_predicate cache_merge pt
~decide_fast ~decide_fst:decide_one ~decide_snd:decide_one ~decide_both
- let cached_fold ~cache_name ~temporary ~f ~joiner ~empty =
- if debug_cache then Format.eprintf "CACHE cached_fold %s@." cache_name;
- let cache_size = Binary_cache.cache_size in
- let cache = Array.make cache_size (Empty, empty) in
- let hash t = abs (hash t mod cache_size) in
- let reset () = Array.fill cache 0 cache_size (Empty, empty) in
- if not temporary then clear_caches := reset :: !clear_caches;
- fun m ->
- let rec traverse t =
- let mem result =
- cache.(hash t) <- (t, result);
- result
- in
- let find () =
- let t', r = cache.(hash t) in
- if equal t t' then r
- else raise Not_found
- in
- match t with
- | Empty -> empty
- | Leaf(key, value, _) ->
- (try
- find ()
- with Not_found ->
- mem (f key value)
- )
- | Branch(_p, _m, s0, s1, _) ->
- try
- find ()
- with Not_found ->
- let result0 = traverse s0 in
- let result1 = traverse s1 in
- mem (joiner result0 result1)
- in
- traverse m
+ let cached_fold ~cache_name ~temporary ~f ~joiner ~empty =
+ if debug_cache then Format.eprintf "CACHE cached_fold %s@." cache_name;
+ let cache_size = Binary_cache.cache_size in
+ let cache = Array.make cache_size (Empty, empty) in
+ let hash t = abs (hash t mod cache_size) in
+ let reset () = Array.fill cache 0 cache_size (Empty, empty) in
+ if not temporary then clear_caches := reset :: !clear_caches;
+ fun m ->
+ let rec traverse t =
+ let mem result =
+ cache.(hash t) <- (t, result);
+ result
+ in
+ let find () =
+ let t', r = cache.(hash t) in
+ if equal t t' then r
+ else raise Not_found
+ in
+ match t with
+ | Empty -> empty
+ | Leaf(key, value, _) ->
+ (try
+ find ()
+ with Not_found ->
+ mem (f key value)
+ )
+ | Branch(_p, _m, s0, s1, _) ->
+ try
+ find ()
+ with Not_found ->
+ let result0 = traverse s0 in
+ let result1 = traverse s1 in
+ mem (joiner result0 result1)
+ in
+ traverse m
let cached_map ~cache ~temporary ~f =
- let _name, cache = cache in
- let table = Hashtbl.create cache in
- if not temporary then
- clear_caches := (fun () -> Hashtbl.clear table) :: !clear_caches;
- let counter = ref 0 in
- fun m ->
- let rec traverse t =
- match t with
- Empty -> empty
- | Leaf(key, value, _) ->
- wrap_Leaf key (f key value)
- | Branch(p, m, s0, s1, _) ->
- try
- let result = Hashtbl.find table t in
-(* Format.printf "find %s %d@." name !counter; *)
- result
- with Not_found ->
- let result0 = traverse s0 in
- let result1 = traverse s1 in
- let result = wrap_Branch p m result0 result1 in
- incr counter;
- if !counter >= cache
- then begin
- (* Format.printf "Clearing %s fold table@." name;*)
- Hashtbl.clear table;
- counter := 0;
- end;
-(* Format.printf "add %s %d@." name !counter; *)
- Hashtbl.add table t result;
- result
- in
- traverse m
+ let _name, cache = cache in
+ let table = Hashtbl.create cache in
+ if not temporary then
+ clear_caches := (fun () -> Hashtbl.clear table) :: !clear_caches;
+ let counter = ref 0 in
+ fun m ->
+ let rec traverse t =
+ match t with
+ Empty -> empty
+ | Leaf(key, value, _) ->
+ wrap_Leaf key (f key value)
+ | Branch(p, m, s0, s1, _) ->
+ try
+ let result = Hashtbl.find table t in
+ (* Format.printf "find %s %d@." name !counter; *)
+ result
+ with Not_found ->
+ let result0 = traverse s0 in
+ let result1 = traverse s1 in
+ let result = wrap_Branch p m result0 result1 in
+ incr counter;
+ if !counter >= cache
+ then begin
+ (* Format.printf "Clearing %s fold table@." name;*)
+ Hashtbl.clear table;
+ counter := 0;
+ end;
+ (* Format.printf "add %s %d@." name !counter; *)
+ Hashtbl.add table t result;
+ result
+ in
+ traverse m
let shape x = ((x : t) :> V.t shape)
diff --git a/src/libraries/utils/hptmap.mli b/src/libraries/utils/hptmap.mli
index c6b2cd2d39512ff501b825f7df053195ce710b2c..c62f6ac9edaaa2fb5f0b471910190092dc257fc0 100644
--- a/src/libraries/utils/hptmap.mli
+++ b/src/libraries/utils/hptmap.mli
@@ -33,9 +33,9 @@ type tag
(** Type of the keys of the map. *)
module type Id_Datatype = sig
- include Datatype.S
- val id: t -> int (** Identity of a key. Must verify [id k >= 0] and
- [equal k1 k2 ==> id k1 = id k2] *)
+ include Datatype.S
+ val id: t -> int (** Identity of a key. Must verify [id k >= 0] and
+ [equal k1 k2 ==> id k1 = id k2] *)
end
(** Values stored in the map *)
@@ -57,38 +57,38 @@ module Shape (Key : Id_Datatype): sig
end
module Make
- (Key : Id_Datatype)
- (V : V)
- (Compositional_bool : sig
- (** A boolean information is maintained for each tree, by composing the
- boolean on the subtrees and the value information present on each leaf.
- See {!Comp_unused} for a default implementation. *)
+ (Key : Id_Datatype)
+ (V : V)
+ (Compositional_bool : sig
+ (** A boolean information is maintained for each tree, by composing the
+ boolean on the subtrees and the value information present on each leaf.
+ See {!Comp_unused} for a default implementation. *)
- val e: bool (** Value for the empty tree *)
- val f : Key.t -> V.t -> bool (** Value for a leaf *)
- val compose : bool -> bool -> bool
+ val e: bool (** Value for the empty tree *)
+ val f : Key.t -> V.t -> bool (** Value for a leaf *)
+ val compose : bool -> bool -> bool
(** Composition of the values of two subtrees *)
- end)
- (Initial_Values : sig
- val v : (Key.t*V.t) list list
- (** List of the maps that must be shared between all instances of Frama-C
- (the maps being described by the list of their elements).
- Must include all maps that are exported at Caml link-time when the
- functor is applied. This usually includes at least the empty map, hence
- [v] nearly always contains [[]]. *)
- end)
- (Datatype_deps: sig
- val l : State.t list
- (** Dependencies of the hash-consing table. The table will be cleared
- whenever one of those dependencies is cleared. *)
- end)
+ end)
+ (Initial_Values : sig
+ val v : (Key.t*V.t) list list
+ (** List of the maps that must be shared between all instances of Frama-C
+ (the maps being described by the list of their elements).
+ Must include all maps that are exported at Caml link-time when the
+ functor is applied. This usually includes at least the empty map, hence
+ [v] nearly always contains [[]]. *)
+ end)
+ (Datatype_deps: sig
+ val l : State.t list
+ (** Dependencies of the hash-consing table. The table will be cleared
+ whenever one of those dependencies is cleared. *)
+ end)
: Hptmap_sig.S with type key = Key.t
and type v = V.t
and type 'a shape = 'a Shape(Key).t
and type prefix = prefix
(** Default implementation for the [Compositional_bool] argument of the functor
- {!Make}. To be used when no interesting compositional bit can be computed. *)
+ {!Make}. To be used when no interesting compositional bit can be computed. *)
module Comp_unused : sig
val e : bool
val f : 'a -> 'b -> bool
diff --git a/src/libraries/utils/hptset.ml b/src/libraries/utils/hptset.ml
index 0d59892b55fe9aba6db38e25257df9cd95202dfc..421368a77d8f43635e8d963adcca9ddb2603ce08 100644
--- a/src/libraries/utils/hptset.ml
+++ b/src/libraries/utils/hptset.ml
@@ -58,61 +58,61 @@ module type S = sig
include Datatype.S_with_collections
include S_Basic_Compare with type t := t
- val contains_single_elt: t -> elt option
- val intersects: t -> t -> bool
+ val contains_single_elt: t -> elt option
+ val intersects: t -> t -> bool
- type action = Neutral | Absorbing | Traversing of (elt -> bool)
+ type action = Neutral | Absorbing | Traversing of (elt -> bool)
- val merge :
- cache:Hptmap_sig.cache_type ->
- symmetric:bool ->
- idempotent:bool ->
- decide_both:(elt -> bool) ->
- decide_left:action ->
- decide_right:action ->
- t -> t -> t
+ val merge :
+ cache:Hptmap_sig.cache_type ->
+ symmetric:bool ->
+ idempotent:bool ->
+ decide_both:(elt -> bool) ->
+ decide_left:action ->
+ decide_right:action ->
+ t -> t -> t
- type 'a shape
- val shape: t -> unit shape
- val from_shape: 'a shape -> t
+ type 'a shape
+ val shape: t -> unit shape
+ val from_shape: 'a shape -> t
- val partition_with_shape: 'a shape -> t -> t * t
+ val partition_with_shape: 'a shape -> t -> t * t
- val fold2_join_heterogeneous:
- cache:Hptmap_sig.cache_type ->
- empty_left:('a shape -> 'b) ->
- empty_right:(t -> 'b) ->
- both:(elt -> 'a -> 'b) ->
- join:('b -> 'b -> 'b) ->
- empty:'b ->
- t -> 'a shape ->
- 'b
+ val fold2_join_heterogeneous:
+ cache:Hptmap_sig.cache_type ->
+ empty_left:('a shape -> 'b) ->
+ empty_right:(t -> 'b) ->
+ both:(elt -> 'a -> 'b) ->
+ join:('b -> 'b -> 'b) ->
+ empty:'b ->
+ t -> 'a shape ->
+ 'b
- val replace: elt shape -> t -> bool * t
+ val replace: elt shape -> t -> bool * t
- val clear_caches: unit -> unit
+ val clear_caches: unit -> unit
- val pretty_debug: t Pretty_utils.formatter
+ val pretty_debug: t Pretty_utils.formatter
end
module Make(X: Hptmap.Id_Datatype)
- (Initial_Values : sig val v : X.t list list end)
- (Datatype_deps: sig val l : State.t list end) : sig
- include S with type elt = X.t
- and type 'a shape = 'a Hptmap.Shape(X).t
- val self : State.t
- end
- = struct
+ (Initial_Values : sig val v : X.t list list end)
+ (Datatype_deps: sig val l : State.t list end) : sig
+ include S with type elt = X.t
+ and type 'a shape = 'a Hptmap.Shape(X).t
+ val self : State.t
+end
+= struct
type elt = X.t
module M =
Hptmap.Make
- (X)
- (struct include Datatype.Unit let pretty_debug = pretty end)
- (Hptmap.Comp_unused)
- (struct let v = List.map (List.map (fun k -> k, ())) Initial_Values.v end)
- (Datatype_deps)
+ (X)
+ (struct include Datatype.Unit let pretty_debug = pretty end)
+ (Hptmap.Comp_unused)
+ (struct let v = List.map (List.map (fun k -> k, ())) Initial_Values.v end)
+ (Datatype_deps)
include M
diff --git a/src/libraries/utils/hptset.mli b/src/libraries/utils/hptset.mli
index 1da170653c0006277b2111ae767e974ab6a48d41..4df2fb4b09a96b5b5a0648ad18b3832d88470e1b 100644
--- a/src/libraries/utils/hptset.mli
+++ b/src/libraries/utils/hptset.mli
@@ -58,72 +58,72 @@ end
(** Output signature of the functor {!Set.Make}. *)
module type S = sig
- include Datatype.S_with_collections
- include S_Basic_Compare with type t := t
- (** The datatype of sets. *)
-
- val contains_single_elt: t -> elt option
-
- val intersects: t -> t -> bool
- (** [intersects s1 s2] returns [true] if and only if [s1] and [s2]
- have an element in common *)
-
- type action = Neutral | Absorbing | Traversing of (elt -> bool)
-
- val merge :
- cache:Hptmap_sig.cache_type ->
- symmetric:bool ->
- idempotent:bool ->
- decide_both:(elt -> bool) ->
- decide_left:action ->
- decide_right:action ->
- t -> t -> t
-
- type 'a shape
- (** Shape of the set, ie. the unique shape of its OCaml value. *)
-
- val shape: t -> unit shape
- (** Export the shape of the set. *)
-
- val from_shape: 'a shape -> t
- (** Build a set from another [elt]-indexed map or set. *)
-
- val partition_with_shape: 'a shape -> t -> t * t
- (** [partition_with_shape shape set] returns two sets [inter, diff] that are
- respectively the intersection and the difference between [set] and
- [shape]. *)
-
- val fold2_join_heterogeneous:
- cache:Hptmap_sig.cache_type ->
- empty_left:('a shape -> 'b) ->
- empty_right:(t -> 'b) ->
- both:(elt -> 'a -> 'b) ->
- join:('b -> 'b -> 'b) ->
- empty:'b ->
- t -> 'a shape ->
- 'b
-
- val replace: elt shape -> t -> bool * t
- (** [replace shape set] replaces the elements of [set] according to [shape].
- The returned boolean indicates whether the set has been modified; it is
- false when the intersection between [shape] and [set] is empty. *)
-
- (** Clear all the caches used internally by the functions of this module.
- Those caches are not project-aware, so this function must be called
- at least each a project switch occurs. *)
- val clear_caches: unit -> unit
-
- val pretty_debug: t Pretty_utils.formatter
+ include Datatype.S_with_collections
+ include S_Basic_Compare with type t := t
+ (** The datatype of sets. *)
+
+ val contains_single_elt: t -> elt option
+
+ val intersects: t -> t -> bool
+ (** [intersects s1 s2] returns [true] if and only if [s1] and [s2]
+ have an element in common *)
+
+ type action = Neutral | Absorbing | Traversing of (elt -> bool)
+
+ val merge :
+ cache:Hptmap_sig.cache_type ->
+ symmetric:bool ->
+ idempotent:bool ->
+ decide_both:(elt -> bool) ->
+ decide_left:action ->
+ decide_right:action ->
+ t -> t -> t
+
+ type 'a shape
+ (** Shape of the set, ie. the unique shape of its OCaml value. *)
+
+ val shape: t -> unit shape
+ (** Export the shape of the set. *)
+
+ val from_shape: 'a shape -> t
+ (** Build a set from another [elt]-indexed map or set. *)
+
+ val partition_with_shape: 'a shape -> t -> t * t
+ (** [partition_with_shape shape set] returns two sets [inter, diff] that are
+ respectively the intersection and the difference between [set] and
+ [shape]. *)
+
+ val fold2_join_heterogeneous:
+ cache:Hptmap_sig.cache_type ->
+ empty_left:('a shape -> 'b) ->
+ empty_right:(t -> 'b) ->
+ both:(elt -> 'a -> 'b) ->
+ join:('b -> 'b -> 'b) ->
+ empty:'b ->
+ t -> 'a shape ->
+ 'b
+
+ val replace: elt shape -> t -> bool * t
+ (** [replace shape set] replaces the elements of [set] according to [shape].
+ The returned boolean indicates whether the set has been modified; it is
+ false when the intersection between [shape] and [set] is empty. *)
+
+ (** Clear all the caches used internally by the functions of this module.
+ Those caches are not project-aware, so this function must be called
+ at least each a project switch occurs. *)
+ val clear_caches: unit -> unit
+
+ val pretty_debug: t Pretty_utils.formatter
end
module Make(X: Hptmap.Id_Datatype)
- (Initial_Values : sig val v : X.t list list end)
- (Datatype_deps: sig val l : State.t list end) :
- sig
- include S with type elt = X.t
- and type 'a shape = 'a Hptmap.Shape(X).t
- val self : State.t
- end
+ (Initial_Values : sig val v : X.t list list end)
+ (Datatype_deps: sig val l : State.t list end) :
+sig
+ include S with type elt = X.t
+ and type 'a shape = 'a Hptmap.Shape(X).t
+ val self : State.t
+end
(*
Local Variables:
diff --git a/src/libraries/utils/indexer.ml b/src/libraries/utils/indexer.ml
index 7d710d4f917a616b7f740788c52f1f3ae762c8ab..7df555a1b04aae9a6e3c2cec0475409e34abbfb7 100644
--- a/src/libraries/utils/indexer.ml
+++ b/src/libraries/utils/indexer.ml
@@ -33,7 +33,7 @@ end
module Make(E : Elt) =
struct
- type t =
+ type t =
| Empty
| Node of int * t * E.t * t
@@ -47,10 +47,10 @@ struct
let rec lookup n a = function
| Empty -> raise Not_found
| Node(_,p,e,q) ->
- let cmp = E.compare a e in
- if cmp < 0 then lookup n a p else
- if cmp > 0 then lookup (n+size p+1) a q else
- n + size p
+ let cmp = E.compare a e in
+ if cmp < 0 then lookup n a p else
+ if cmp > 0 then lookup (n+size p+1) a q else
+ n + size p
let index = lookup 0
@@ -59,18 +59,18 @@ struct
let rec mem a = function
| Empty -> false
| Node(_,p,e,q) ->
- let cmp = E.compare a e in
- if cmp < 0 then mem a p else
- if cmp > 0 then mem a q else
- true
+ let cmp = E.compare a e in
+ if cmp < 0 then mem a p else
+ if cmp > 0 then mem a q else
+ true
let rec get k = function
| Empty -> raise Not_found
| Node(_,p,e,q) ->
- let n = size p in
- if k < n then get k p else
- if k > n then get (k-n-1) q else
- e
+ let n = size p in
+ if k < n then get k p else
+ if k > n then get (k-n-1) q else
+ e
let rec iter f = function
| Empty -> ()
@@ -78,9 +78,9 @@ struct
let rec walk n f = function
| Empty -> ()
- | Node(_,p,e,q) ->
- let m = n + size p in
- walk n f p ; f m e ; walk (m+1) f q
+ | Node(_,p,e,q) ->
+ let m = n + size p in
+ walk n f p ; f m e ; walk (m+1) f q
let iteri = walk 0
@@ -95,45 +95,45 @@ struct
(*TODO: can be better *)
let rec balance p e q =
match p , q with
- | Node(_,p1,x,p2) , _ when size q < size p1 -> node p1 x (balance p2 e q)
- | _ , Node(_,q1,y,q2) when size p < size q2 -> node (balance p e q1) y q2
- | _ -> node p e q
+ | Node(_,p1,x,p2) , _ when size q < size p1 -> node p1 x (balance p2 e q)
+ | _ , Node(_,q1,y,q2) when size p < size q2 -> node (balance p e q1) y q2
+ | _ -> node p e q
(* -------------------------------------------------------------------------- *)
(* --- Add,Remove --- *)
(* -------------------------------------------------------------------------- *)
-
+
let rec add a = function
| Empty -> Node(1,Empty,a,Empty)
| Node(n,p,e,q) ->
- let cmp = E.compare a e in
- if cmp < 0 then balance (add a p) e q else
- if cmp > 0 then balance p e (add a q) else
- Node(n,p,a,q)
+ let cmp = E.compare a e in
+ if cmp < 0 then balance (add a p) e q else
+ if cmp > 0 then balance p e (add a q) else
+ Node(n,p,a,q)
(* requires x<y for each x in p and y in q *)
let rec join p q =
match p,q with
- | Empty,r | r,Empty -> r
- | Node(n,p1,x,p2) , Node(m,q1,y,q2) ->
- if n >= m
- then balance p1 x (join p2 q)
- else balance (join p q1) y q2
+ | Empty,r | r,Empty -> r
+ | Node(n,p1,x,p2) , Node(m,q1,y,q2) ->
+ if n >= m
+ then balance p1 x (join p2 q)
+ else balance (join p q1) y q2
let rec remove a = function
| Empty -> Empty
| Node(_,p,e,q) ->
- let cmp = E.compare a e in
- if cmp < 0 then balance (remove a p) e q else
- if cmp > 0 then balance p e (remove a q) else
- join p q
+ let cmp = E.compare a e in
+ if cmp < 0 then balance (remove a p) e q else
+ if cmp > 0 then balance p e (remove a q) else
+ join p q
let rec filter f = function
| Empty -> Empty
- | Node(_,p,e,q) ->
- let p = filter f p in
- let q = filter f q in
- if f e then balance p e q else join p q
+ | Node(_,p,e,q) ->
+ let p = filter f p in
+ let q = filter f q in
+ if f e then balance p e q else join p q
(* -------------------------------------------------------------------------- *)
(* --- Update --- *)
@@ -141,23 +141,23 @@ struct
let update x y t =
match x , y with
- | None , None -> (* identify *) 0,-1,t
- | Some x , None -> (* remove x *)
- let i = rindex x t in
- if i < 0 then 0,-1,t else i,size t-1,remove x t
- | None , Some y -> (* add y *)
- let t = add y t in
- let j = index y t in
- j , size t-1 , t
- | Some x , Some y ->
- let i = rindex x t in
- if i < 0 then
- let t = add y t in
- let j = rindex y t in
- j , size t-1 , t
- else
- let t = add y (remove x t) in
- let j = rindex y t in
- min i j , max i j , t
+ | None , None -> (* identify *) 0,-1,t
+ | Some x , None -> (* remove x *)
+ let i = rindex x t in
+ if i < 0 then 0,-1,t else i,size t-1,remove x t
+ | None , Some y -> (* add y *)
+ let t = add y t in
+ let j = index y t in
+ j , size t-1 , t
+ | Some x , Some y ->
+ let i = rindex x t in
+ if i < 0 then
+ let t = add y t in
+ let j = rindex y t in
+ j , size t-1 , t
+ else
+ let t = add y (remove x t) in
+ let j = rindex y t in
+ min i j , max i j , t
end
diff --git a/src/libraries/utils/indexer.mli b/src/libraries/utils/indexer.mli
index 5619ad34325afad748bd7a7fa0fd37bc590f6181..1ea66f5efd0401e0b56ce941d6cbd346d85a1555 100644
--- a/src/libraries/utils/indexer.mli
+++ b/src/libraries/utils/indexer.mli
@@ -20,9 +20,9 @@
(* *)
(**************************************************************************)
-(** Indexer implements ordered collection of items with
+(** Indexer implements ordered collection of items with
random access. It is suitable for building fast access operations
- in GUI tree and list widgets. *)
+ in GUI tree and list widgets. *)
module type Elt = sig
type t
@@ -40,15 +40,15 @@ module Make(E : Elt) : sig
val get : int -> t -> E.t (** raises Not_found. Log complexity. *)
val index : E.t -> t -> int (** raise Not_found. Log complexity. *)
val is_empty : t -> bool
-
- val empty : t
+
+ val empty : t
val add : E.t -> t -> t (** Log complexity. *)
val remove : E.t -> t -> t (** Log complexity. *)
val filter : (E.t -> bool) -> t -> t (** Linear. *)
val update : E.t option -> E.t option -> t -> int * int * t
- (** [update x y t] replaces [x] by [y]
- and returns the range [a..b] of modified indices.
- Log complexity. *)
+ (** [update x y t] replaces [x] by [y]
+ and returns the range [a..b] of modified indices.
+ Log complexity. *)
val iter : (E.t -> unit) -> t -> unit (** Linear. *)
val iteri : (int -> E.t -> unit) -> t -> unit (** Linear. *)
diff --git a/src/libraries/utils/pretty_utils.ml b/src/libraries/utils/pretty_utils.ml
index 299b824e430c28870d64856534caa959f566bc77..8c51ac632ac851cc737bb9d556a099d307787f08 100644
--- a/src/libraries/utils/pretty_utils.ml
+++ b/src/libraries/utils/pretty_utils.ml
@@ -45,7 +45,7 @@ let rec pp_print_string_fill out s =
let l = String.length s in
let s1 = String.sub s 0 i in
let s2 = String.sub s (i+1) (l - i - 1) in
- Format.fprintf out "%s@ %a" s1 pp_print_string_fill s2
+ Format.fprintf out "%s@ %a" s1 pp_print_string_fill s2
end else Format.pp_print_string out s
type sformat = (unit,Format.formatter,unit) format
@@ -76,17 +76,17 @@ let pp_array
?(empty=format_of_string "")
pp_elt f xs =
match xs with
- | [| |] -> Format.fprintf f "%(%)" empty
- | xs ->
- begin
- Format.fprintf f pre ;
- pp_elt f 0 xs.(0) ;
- for i = 1 to Array.length xs - 1 do
- Format.fprintf f sep ;
- pp_elt f i xs.(i) ;
- done ;
- Format.fprintf f suf ;
- end
+ | [| |] -> Format.fprintf f "%(%)" empty
+ | xs ->
+ begin
+ Format.fprintf f pre ;
+ pp_elt f 0 xs.(0) ;
+ for i = 1 to Array.length xs - 1 do
+ Format.fprintf f sep ;
+ pp_elt f i xs.(i) ;
+ done ;
+ Format.fprintf f suf ;
+ end
let pp_iter
?(pre=format_of_string "@[")
@@ -96,9 +96,9 @@ let pp_iter
let need_sep = ref false in
Format.fprintf fmt pre;
iter (fun v ->
- if !need_sep then Format.fprintf fmt sep else need_sep := true;
- pp fmt v;
- ) v;
+ if !need_sep then Format.fprintf fmt sep else need_sep := true;
+ pp fmt v;
+ ) v;
Format.fprintf fmt suf;
;;
@@ -136,21 +136,21 @@ let escape_underscores = Str.global_replace (Str.regexp_string "_") "__"
let pp_flowlist ?(left=format_of_string "(") ?(sep=format_of_string ",") ?(right=format_of_string ")") f out =
function
- | [] -> Format.fprintf out "%(%)%(%)" left right
- | x::xs ->
- begin
- Format.fprintf out "@[<hov 1>%(%)%a" left f x ;
- List.iter (fun x -> Format.fprintf out "%(%)@,%a" sep f x) xs ;
- Format.fprintf out "%(%)@]" right ;
- end
+ | [] -> Format.fprintf out "%(%)%(%)" left right
+ | x::xs ->
+ begin
+ Format.fprintf out "@[<hov 1>%(%)%a" left f x ;
+ List.iter (fun x -> Format.fprintf out "%(%)@,%a" sep f x) xs ;
+ Format.fprintf out "%(%)@]" right ;
+ end
let pp_blocklist ?(left=format_of_string "{") ?(right=format_of_string "}") f out =
function
- | [] -> Format.fprintf out "%(%)%(%)" left right
- | xs ->
- Format.fprintf out "@[<hv 0>%(%)@[<hv 2>" left ;
- List.iter (fun x -> Format.fprintf out "@ %a" f x) xs ;
- Format.fprintf out "@]@ %(%)@]" right
+ | [] -> Format.fprintf out "%(%)%(%)" left right
+ | xs ->
+ Format.fprintf out "@[<hv 0>%(%)@[<hv 2>" left ;
+ List.iter (fun x -> Format.fprintf out "@ %a" f x) xs ;
+ Format.fprintf out "@]@ %(%)@]" right
let pp_open_block out msg =
Format.fprintf out ("@[<hv 0>@[<hv 2>" ^^ msg)
@@ -165,7 +165,7 @@ let pp_trail pp fmt x =
if !newlined then
( Format.fprintf fmt "@\n * " ; newlined := false ) ;
if s.[i] = '\n'
- then newlined := true
+ then newlined := true
else Format.pp_print_char fmt s.[i]
done
in
@@ -204,13 +204,13 @@ let pp_margin ?(align=`Center) ?(pp=Format.pp_print_string) marger fmt text =
let w = m-n in
match align with
| `Center ->
- let l = w / 2 in
- let r = w - l in
- space fmt l ; pp fmt text ; space fmt r ;
+ let l = w / 2 in
+ let r = w - l in
+ space fmt l ; pp fmt text ; space fmt r ;
| `Left ->
- pp fmt text ; space fmt w
+ pp fmt text ; space fmt w
| `Right ->
- space fmt w ; pp fmt text
+ space fmt w ; pp fmt text
let pp_items ?align ?margin ?min ?max ~title ~iter ?pp_title ~pp_item fmt =
let m = marger () in
diff --git a/src/libraries/utils/pretty_utils.mli b/src/libraries/utils/pretty_utils.mli
index 10a7e607a22483b9c875977d204f40faed991729..e8840c95564d74e7788106077346ab3ba5d92f68 100644
--- a/src/libraries/utils/pretty_utils.mli
+++ b/src/libraries/utils/pretty_utils.mli
@@ -28,16 +28,16 @@
(* ********************************************************************** *)
val null : Format.formatter
- (** Prints nothing.
- @since Beryllium-20090901 *)
+(** Prints nothing.
+ @since Beryllium-20090901 *)
val nullprintf : ('a,Format.formatter,unit) format -> 'a
- (** Discards the message and returns unit.
- @since Beryllium-20090901 *)
+(** Discards the message and returns unit.
+ @since Beryllium-20090901 *)
val with_null : (unit -> 'b) -> ('a,Format.formatter,unit,'b) format4 -> 'a
- (** Discards the message and call the continuation.
- @since Beryllium-20090901 *)
+(** Discards the message and call the continuation.
+ @since Beryllium-20090901 *)
(* ********************************************************************** *)
(** {2 pretty-printing to a string} *)
@@ -56,8 +56,8 @@ val ksfprintf:
val to_string: ?margin:int -> (Format.formatter -> 'a -> unit) -> 'a -> string
(** pretty-prints the supplied value into a string. [margin] is the
- maximal width of the box before a line-break is inserted.
- See {!Format.set_margin} *)
+ maximal width of the box before a line-break is inserted.
+ See {!Format.set_margin} *)
(** {2 separators} *)
@@ -84,7 +84,7 @@ val pp_list: ?pre:sformat -> ?sep:sformat -> ?last:sformat -> ?suf:sformat ->
- what to print if the list is empty (default: nothing)
@modify Silicon-20161101 new optional argument [empty]
- *)
+*)
val pp_array: ?pre:sformat -> ?sep:sformat -> ?suf:sformat -> ?empty:sformat ->
(int,'a) formatter2 -> 'a array formatter
@@ -95,7 +95,7 @@ val pp_array: ?pre:sformat -> ?sep:sformat -> ?suf:sformat -> ?empty:sformat ->
- what to print if the array is empty (default: nothing)
@modify Silicon-20161101 new optional argument [empty]
- *)
+*)
val pp_iter:
?pre:sformat -> ?sep:sformat -> ?suf:sformat ->
@@ -136,7 +136,7 @@ val pp_pair: ?pre:sformat -> ?sep:sformat -> ?suf:sformat ->
- pre: open a box
- sep: print a comma character
- suf: close a box.
- @since Magnesium-20151001 *)
+ @since Magnesium-20151001 *)
val pp_flowlist:
?left:sformat -> ?sep:sformat -> ?right:sformat -> 'a formatter ->
@@ -168,7 +168,7 @@ val pp_items :
(** Prints a collection of elements, with the possibility of aligning {i titles}
with each others.
- The collection of ['a] to print is provided by iterator [~iter] which
+ The collection of ['a] to print is provided by iterator [~iter] which
is called twice: one for computing the maximal size of {i titles},
obtained {i via} function [~title] for each item. The second pass
pretty-print each item using [~pp_item pp] where the passed [pp] printer
@@ -193,15 +193,15 @@ val pp_items :
with [~pp_title]. Surrounding spaces are {i not} printed via [~pp_title].
The (optional) parameters have the following meaning:
- - [?align] alignment mode (default is [`Center])
- - [?margin] is added to text size (default [0])
- - [?min] minimum size ([~margin] included, default [0])
- - [?max] maximum size ([~margin] included, default [80])
- - [~title] returns the {i title} for each element (only size is relevant)
- - [~iter] iterate over the elements to be printed
- - [?pp_title] pretty-printer used to the (possibly truncated) title
+ - [?align] alignment mode (default is [`Center])
+ - [?margin] is added to text size (default [0])
+ - [?min] minimum size ([~margin] included, default [0])
+ - [?max] maximum size ([~margin] included, default [80])
+ - [~title] returns the {i title} for each element (only size is relevant)
+ - [~iter] iterate over the elements to be printed
+ - [?pp_title] pretty-printer used to the (possibly truncated) title
(default is [Format.pp_print_string])
- - [~pp_item] pretty-printer to print each element.
+ - [~pp_item] pretty-printer to print each element.
There is also a low-level API to this feature, provided by {!marger},
{!pp_margin} and {!add_margin} below.
@@ -213,9 +213,9 @@ val add_margin : marger -> ?margin:int -> ?min:int -> ?max:int -> string -> unit
(** Updates the marger with new text dimension.
The marger width is updated with the width of the provided text.
The optional parameters are used to adjust the text width as follows:
- - [?margin] is added to text size (default [0])
- - [?min] minimum size ([~margin] included, default [0])
- - [?max] maximum size ([~margin] included, default [80]) *)
+ - [?margin] is added to text size (default [0])
+ - [?min] minimum size ([~margin] included, default [0])
+ - [?max] maximum size ([~margin] included, default [80]) *)
val pp_margin : ?align:align -> ?pp:string formatter -> marger -> string formatter
(** Prints a text with margins {i wrt} to marger. If the text does not fit
diff --git a/src/libraries/utils/qstack.ml b/src/libraries/utils/qstack.ml
index 7e91044f0d79f596517d09b6655e47c5970ef5e7..506e066cb587af51891a266228edbaa887d41ebc 100644
--- a/src/libraries/utils/qstack.ml
+++ b/src/libraries/utils/qstack.ml
@@ -56,10 +56,10 @@ module Make(D: DATA) = struct
match t.first, t.last with
| [], [] -> raise Empty
| [], _ :: _ ->
- transfer t;
- (match t.first with
- | [] -> assert false
- | x :: _ -> x)
+ transfer t;
+ (match t.first with
+ | [] -> assert false
+ | x :: _ -> x)
| x :: _, _ -> x
let mem x t =
@@ -120,15 +120,15 @@ module Make(D: DATA) = struct
let nth n t =
try List.nth t.first n
with Failure _ ->
- try List.nth (List.rev t.last) (n - List.length t.first)
- with Failure s -> invalid_arg s
+ try List.nth (List.rev t.last) (n - List.length t.first)
+ with Failure s -> invalid_arg s
let idx x t =
let i = ref 0 in
try
iter (fun e ->
- if D.equal e x then raise Exit;
- incr i)
+ if D.equal e x then raise Exit;
+ incr i)
t;
raise Not_found
with Exit -> !i
diff --git a/src/libraries/utils/qstack.mli b/src/libraries/utils/qstack.mli
index eb0ce8292c916f97416c9de5a82c5633857d7858..3d62ad2c9d1c99eaef84af5464498d2d0c1eb3bd 100644
--- a/src/libraries/utils/qstack.mli
+++ b/src/libraries/utils/qstack.mli
@@ -36,83 +36,83 @@ module Make(D: DATA) : sig
exception Empty
val create: unit -> t
- (** Create a new empty stack. *)
+ (** Create a new empty stack. *)
val singleton: D.t -> t
- (** Create a new qstack with a single element.
- @since Boron-20100401 *)
+ (** Create a new qstack with a single element.
+ @since Boron-20100401 *)
val is_empty: t -> bool
- (** Test whether the stack is empty or not. *)
+ (** Test whether the stack is empty or not. *)
val clear: t -> unit
- (** Remove all the elements of a stack. *)
+ (** Remove all the elements of a stack. *)
val add: D.t -> t -> unit
- (** Add at the beginning of the stack. Complexity: O(1). *)
+ (** Add at the beginning of the stack. Complexity: O(1). *)
val add_at_end: D.t -> t -> unit
- (** Add at the end of the stack. Complexity: O(1). *)
+ (** Add at the end of the stack. Complexity: O(1). *)
val top: t -> D.t
- (** Return the top element of the stack. Raise [Empty] if the stack is
- empty. Complexity: amortized O(1). *)
+ (** Return the top element of the stack. Raise [Empty] if the stack is
+ empty. Complexity: amortized O(1). *)
val mem: D.t -> t -> bool
- (** Return [true] if the data exists in the stack and [false] otherwise.
- Complexity: O(n). *)
+ (** Return [true] if the data exists in the stack and [false] otherwise.
+ Complexity: O(n). *)
val filter: (D.t -> bool) -> t -> D.t list
- (** Return all data of the stack satisfying the specified predicate.
- The order of the data in the input stack is preserved.
- Not tail recursive. *)
+ (** Return all data of the stack satisfying the specified predicate.
+ The order of the data in the input stack is preserved.
+ Not tail recursive. *)
val find: (D.t -> bool) -> t -> D.t
- (** Return the first data of the stack satisfying the specified predicate.
- @raise Not_found if there is no such data in the stack *)
+ (** Return the first data of the stack satisfying the specified predicate.
+ @raise Not_found if there is no such data in the stack *)
val remove: D.t -> t -> unit
- (** Remove an element from the stack.
- Complexity: O(n). *)
+ (** Remove an element from the stack.
+ Complexity: O(n). *)
val move_at_top: D.t -> t -> unit
- (** Move the element [x] at the top of the stack [s].
- Complexity: O(n).
- @raise Invalid_argument if [not (mem x s)]. *)
+ (** Move the element [x] at the top of the stack [s].
+ Complexity: O(n).
+ @raise Invalid_argument if [not (mem x s)]. *)
val move_at_end: D.t -> t -> unit
- (** Move the element [x] at the end of the stack [s].
- Complexity: O(n).
- @raise Invalid_argument if [not (mem x s)].
- @since Beryllium-20090901 *)
+ (** Move the element [x] at the end of the stack [s].
+ Complexity: O(n).
+ @raise Invalid_argument if [not (mem x s)].
+ @since Beryllium-20090901 *)
val iter: (D.t -> unit) -> t -> unit
- (** Iter on all the elements from the top to the end of the stack.
- Not tail recursive. *)
+ (** Iter on all the elements from the top to the end of the stack.
+ Not tail recursive. *)
val map: (D.t -> D.t) -> t -> unit
- (** Replace in-place all the elements of the stack by mapping the old one.
- Not tail recursive.
- @since Beryllium-20090901 *)
+ (** Replace in-place all the elements of the stack by mapping the old one.
+ Not tail recursive.
+ @since Beryllium-20090901 *)
val fold: ('a -> D.t -> 'a) -> 'a -> t -> 'a
- (** Fold on all the elements from the top to the end of the stack.
- Not tail recursive. *)
+ (** Fold on all the elements from the top to the end of the stack.
+ Not tail recursive. *)
val nth: int -> t -> D.t
- (** @return the n-th element of the stack, if any.
- @raise Invalid_argument if there is not enough element in the stack.
- @since Beryllium-20090901 *)
+ (** @return the n-th element of the stack, if any.
+ @raise Invalid_argument if there is not enough element in the stack.
+ @since Beryllium-20090901 *)
val length: t -> int
- (** @return the length of the stack
- @since Beryllium-20090901 *)
+ (** @return the length of the stack
+ @since Beryllium-20090901 *)
val idx: D.t -> t -> int
- (** @return the index of the element in the stack
- @raise Not_found if the element is not in the stack
- This function is not tail recursive
- @since Beryllium-20090901 *)
+ (** @return the index of the element in the stack
+ @raise Not_found if the element is not in the stack
+ This function is not tail recursive
+ @since Beryllium-20090901 *)
end
diff --git a/src/libraries/utils/rangemap.ml b/src/libraries/utils/rangemap.ml
index a0aede1cdd2c9d2557c517af593886865fd53cf3..867f43b8443c24d327c065a841f9373a0b700318 100644
--- a/src/libraries/utils/rangemap.ml
+++ b/src/libraries/utils/rangemap.ml
@@ -107,54 +107,54 @@ module Make(Ord: Datatype.S)(Value: Value) = struct
let hashtree = hashl lxor hashbinding lxor hashr in
Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1), hashtree)
- let bal l x d r =
- let hl = match l with Empty -> 0 | Node(_,_,_,_,h,_) -> h in
- let hr = match r with Empty -> 0 | Node(_,_,_,_,h,_) -> h in
- if hl > hr + 2 then begin
- match l with
- Empty -> invalid_arg "Rangemap.bal"
- | Node(ll, lv, ld, lr, _, _) ->
- if height ll >= height lr then
- create ll lv ld (create lr x d r)
- else begin
- match lr with
- Empty -> invalid_arg "Rangemap.bal"
- | Node(lrl, lrv, lrd, lrr, _, _)->
- create (create ll lv ld lrl) lrv lrd (create lrr x d r)
- end
- end else if hr > hl + 2 then begin
- match r with
- Empty -> invalid_arg "Rangemap.bal"
- | Node(rl, rv, rd, rr, _, _) ->
- if height rr >= height rl then
- create (create l x d rl) rv rd rr
- else begin
- match rl with
- Empty -> invalid_arg "Rangemap.bal"
- | Node(rll, rlv, rld, rlr, _, _) ->
- create (create l x d rll) rlv rld (create rlr rv rd rr)
- end
- end else
- create l x d r
-
- let empty = Empty
-
- let is_empty = function Empty -> true | _ -> false
-
- let singleton x v = create Empty x v Empty
-
- let rec add x data = function
- Empty ->
- create Empty x data Empty
- | Node(l, v, d, r, _, _) as node ->
- let c = Ord.compare x v in
- if c = 0 then
- if Value.fast_equal d data then node
- else create l x data r
- else if c < 0 then
- bal (add x data l) v d r
- else
- bal l v d (add x data r)
+ let bal l x d r =
+ let hl = match l with Empty -> 0 | Node(_,_,_,_,h,_) -> h in
+ let hr = match r with Empty -> 0 | Node(_,_,_,_,h,_) -> h in
+ if hl > hr + 2 then begin
+ match l with
+ Empty -> invalid_arg "Rangemap.bal"
+ | Node(ll, lv, ld, lr, _, _) ->
+ if height ll >= height lr then
+ create ll lv ld (create lr x d r)
+ else begin
+ match lr with
+ Empty -> invalid_arg "Rangemap.bal"
+ | Node(lrl, lrv, lrd, lrr, _, _)->
+ create (create ll lv ld lrl) lrv lrd (create lrr x d r)
+ end
+ end else if hr > hl + 2 then begin
+ match r with
+ Empty -> invalid_arg "Rangemap.bal"
+ | Node(rl, rv, rd, rr, _, _) ->
+ if height rr >= height rl then
+ create (create l x d rl) rv rd rr
+ else begin
+ match rl with
+ Empty -> invalid_arg "Rangemap.bal"
+ | Node(rll, rlv, rld, rlr, _, _) ->
+ create (create l x d rll) rlv rld (create rlr rv rd rr)
+ end
+ end else
+ create l x d r
+
+ let empty = Empty
+
+ let is_empty = function Empty -> true | _ -> false
+
+ let singleton x v = create Empty x v Empty
+
+ let rec add x data = function
+ Empty ->
+ create Empty x data Empty
+ | Node(l, v, d, r, _, _) as node ->
+ let c = Ord.compare x v in
+ if c = 0 then
+ if Value.fast_equal d data then node
+ else create l x data r
+ else if c < 0 then
+ bal (add x data l) v d r
+ else
+ bal l v d (add x data r)
let rec find x = function
| Empty ->
@@ -243,67 +243,67 @@ module Make(Ord: Datatype.S)(Value: Value) = struct
let rec filt accu = function
| Empty -> accu
| Node(l, v, d, r, _, _) ->
- filt (filt (if p v d then add v d accu else accu) l) r in
+ filt (filt (if p v d then add v d accu else accu) l) r in
filt Empty s
let partition p s =
let rec part (t, f as accu) = function
| Empty -> accu
| Node(l, v, d, r, _, _) ->
- part (part (if p v d then (add v d t, f) else (t, add v d f)) l) r in
+ part (part (if p v d then (add v d t, f) else (t, add v d f)) l) r in
part (Empty, Empty) s
- (* Same as create and bal, but no assumptions are made on the
- relative heights of l and r. *)
-
- let rec join l v d r =
- match (l, r) with
- (Empty, _) -> add v d r
- | (_, Empty) -> add v d l
- | (Node(ll, lv, ld, lr, lh, _), Node(rl, rv, rd, rr, rh, _)) ->
- if lh > rh + 2 then bal ll lv ld (join lr v d r) else
- if rh > lh + 2 then bal (join l v d rl) rv rd rr else
- create l v d r
-
- (* Merge two trees l and r into one.
- All elements of l must precede the elements of r.
- No assumption on the heights of l and r. *)
-
- let concat t1 t2 =
- match (t1, t2) with
- (Empty, t) -> t
- | (t, Empty) -> t
- | (_, _) ->
- let (x, d) = min_binding t2 in
- join t1 x d (remove_min_binding t2)
-
- let concat_or_join t1 v d t2 =
- match d with
- | Some d -> join t1 v d t2
- | None -> concat t1 t2
-
- let rec split x = function
- Empty ->
- (Empty, None, Empty)
- | Node(l, v, d, r, _, _) ->
- let c = Ord.compare x v in
- if c = 0 then (l, Some d, r)
- else if c < 0 then
- let (ll, pres, rl) = split x l in (ll, pres, join rl v d r)
- else
- let (lr, pres, rr) = split x r in (join l v d lr, pres, rr)
-
- let rec merge f s1 s2 =
- match (s1, s2) with
- (Empty, Empty) -> Empty
- | (Node (l1, v1, d1, r1, h1, _), _) when h1 >= height s2 ->
- let (l2, d2, r2) = split v1 s2 in
- concat_or_join (merge f l1 l2) v1 (f v1 (Some d1) d2) (merge f r1 r2)
- | (_, Node (l2, v2, d2, r2, _h2, _)) ->
- let (l1, d1, r1) = split v2 s1 in
- concat_or_join (merge f l1 l2) v2 (f v2 d1 (Some d2)) (merge f r1 r2)
- | _ ->
- assert false
+ (* Same as create and bal, but no assumptions are made on the
+ relative heights of l and r. *)
+
+ let rec join l v d r =
+ match (l, r) with
+ (Empty, _) -> add v d r
+ | (_, Empty) -> add v d l
+ | (Node(ll, lv, ld, lr, lh, _), Node(rl, rv, rd, rr, rh, _)) ->
+ if lh > rh + 2 then bal ll lv ld (join lr v d r) else
+ if rh > lh + 2 then bal (join l v d rl) rv rd rr else
+ create l v d r
+
+ (* Merge two trees l and r into one.
+ All elements of l must precede the elements of r.
+ No assumption on the heights of l and r. *)
+
+ let concat t1 t2 =
+ match (t1, t2) with
+ (Empty, t) -> t
+ | (t, Empty) -> t
+ | (_, _) ->
+ let (x, d) = min_binding t2 in
+ join t1 x d (remove_min_binding t2)
+
+ let concat_or_join t1 v d t2 =
+ match d with
+ | Some d -> join t1 v d t2
+ | None -> concat t1 t2
+
+ let rec split x = function
+ Empty ->
+ (Empty, None, Empty)
+ | Node(l, v, d, r, _, _) ->
+ let c = Ord.compare x v in
+ if c = 0 then (l, Some d, r)
+ else if c < 0 then
+ let (ll, pres, rl) = split x l in (ll, pres, join rl v d r)
+ else
+ let (lr, pres, rr) = split x r in (join l v d lr, pres, rr)
+
+ let rec merge f s1 s2 =
+ match (s1, s2) with
+ (Empty, Empty) -> Empty
+ | (Node (l1, v1, d1, r1, h1, _), _) when h1 >= height s2 ->
+ let (l2, d2, r2) = split v1 s2 in
+ concat_or_join (merge f l1 l2) v1 (f v1 (Some d1) d2) (merge f r1 r2)
+ | (_, Node (l2, v2, d2, r2, _h2, _)) ->
+ let (l1, d1, r1) = split v2 s1 in
+ concat_or_join (merge f l1 l2) v2 (f v2 d1 (Some d2)) (merge f r1 r2)
+ | _ ->
+ assert false
type enumeration = End | More of key * Value.t * rangemap * enumeration
@@ -331,7 +331,7 @@ module Make(Ord: Datatype.S)(Value: Value) = struct
| (_, End) -> false
| (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
Ord.equal v1 v2 && Value.equal d1 d2 &&
- equal_aux (cons_enum r1 e1) (cons_enum r2 e2)
+ equal_aux (cons_enum r1 e1) (cons_enum r2 e2)
in
equal_aux (cons_enum m1 End) (cons_enum m2 End)
@@ -339,21 +339,21 @@ module Make(Ord: Datatype.S)(Value: Value) = struct
let rec aux e1 e2 r = match e1, e2 with
| (End, End) -> r
| (End, More (k, v, t, e)) ->
- f k None (Some v) (aux End (cons_enum t e) r)
+ f k None (Some v) (aux End (cons_enum t e) r)
| (More (k, v, t, e), End) ->
- f k (Some v) None (aux (cons_enum t e) End r)
+ f k (Some v) None (aux (cons_enum t e) End r)
| (More (k1, v1, t1, e1'), More (k2, v2, t2, e2')) ->
- let c = Ord.compare k1 k2 in
- if c = 0 then
- f k1 (Some v1) (Some v2)
- (aux (cons_enum t1 e1') (cons_enum t2 e2') r)
- else if c < 0 then
- f k1 (Some v1) None
- (aux (cons_enum t1 e1') e2 r)
- else
- f k2 (Some v2) None
- (aux e1 (cons_enum t2 e2') r)
- in aux (cons_enum m1 End) (cons_enum m2 End) r
+ let c = Ord.compare k1 k2 in
+ if c = 0 then
+ f k1 (Some v1) (Some v2)
+ (aux (cons_enum t1 e1') (cons_enum t2 e2') r)
+ else if c < 0 then
+ f k1 (Some v1) None
+ (aux (cons_enum t1 e1') e2 r)
+ else
+ f k2 (Some v2) None
+ (aux e1 (cons_enum t2 e2') r)
+ in aux (cons_enum m1 End) (cons_enum m2 End) r
(* iter2, exists2 and for_all2 are essentially the same implementation
as fold2 with the appropriate default value and operator, but
@@ -362,41 +362,41 @@ module Make(Ord: Datatype.S)(Value: Value) = struct
let rec aux e1 e2 = match e1, e2 with
| (End, End) -> ()
| (End, More (k, v, t, e)) ->
- f k None (Some v); aux End (cons_enum t e)
+ f k None (Some v); aux End (cons_enum t e)
| (More (k, v, t, e), End) ->
- f k (Some v) None; aux (cons_enum t e) End
+ f k (Some v) None; aux (cons_enum t e) End
| (More (k1, v1, t1, e1'), More (k2, v2, t2, e2')) ->
- let c = Ord.compare k1 k2 in
- if c = 0 then (
- f k1 (Some v1) (Some v2);
- aux (cons_enum t1 e1') (cons_enum t2 e2')
- ) else if c < 0 then (
- f k1 (Some v1) None;
- aux (cons_enum t1 e1') e2
- ) else (
- f k2 (Some v2) None;
- aux e1 (cons_enum t2 e2')
- )
+ let c = Ord.compare k1 k2 in
+ if c = 0 then (
+ f k1 (Some v1) (Some v2);
+ aux (cons_enum t1 e1') (cons_enum t2 e2')
+ ) else if c < 0 then (
+ f k1 (Some v1) None;
+ aux (cons_enum t1 e1') e2
+ ) else (
+ f k2 (Some v2) None;
+ aux e1 (cons_enum t2 e2')
+ )
in aux (cons_enum m1 End) (cons_enum m2 End)
let exists2 f m1 m2 =
let rec aux e1 e2 = match e1, e2 with
| (End, End) -> false
| (End, More (k, v, t, e)) ->
- f k None (Some v) || aux End (cons_enum t e)
+ f k None (Some v) || aux End (cons_enum t e)
| (More (k, v, t, e), End) ->
- f k (Some v) None || aux (cons_enum t e) End
+ f k (Some v) None || aux (cons_enum t e) End
| (More (k1, v1, t1, e1'), More (k2, v2, t2, e2')) ->
- let c = Ord.compare k1 k2 in
- if c = 0 then
- f k1 (Some v1) (Some v2) ||
- aux (cons_enum t1 e1') (cons_enum t2 e2')
- else if c < 0 then
- f k1 (Some v1) None ||
- aux (cons_enum t1 e1') e2
- else
- f k2 (Some v2) None ||
- aux e1 (cons_enum t2 e2')
+ let c = Ord.compare k1 k2 in
+ if c = 0 then
+ f k1 (Some v1) (Some v2) ||
+ aux (cons_enum t1 e1') (cons_enum t2 e2')
+ else if c < 0 then
+ f k1 (Some v1) None ||
+ aux (cons_enum t1 e1') e2
+ else
+ f k2 (Some v2) None ||
+ aux e1 (cons_enum t2 e2')
in aux (cons_enum m1 End) (cons_enum m2 End)
@@ -404,20 +404,20 @@ module Make(Ord: Datatype.S)(Value: Value) = struct
let rec aux e1 e2 = match e1, e2 with
| (End, End) -> true
| (End, More (k, v, t, e)) ->
- f k None (Some v) && aux End (cons_enum t e)
+ f k None (Some v) && aux End (cons_enum t e)
| (More (k, v, t, e), End) ->
- f k (Some v) None && aux (cons_enum t e) End
+ f k (Some v) None && aux (cons_enum t e) End
| (More (k1, v1, t1, e1'), More (k2, v2, t2, e2')) ->
- let c = Ord.compare k1 k2 in
- if c = 0 then
- f k1 (Some v1) (Some v2) &&
- aux (cons_enum t1 e1') (cons_enum t2 e2')
- else if c < 0 then
- f k1 (Some v1) None &&
- aux (cons_enum t1 e1') e2
- else
- f k2 (Some v2) None &&
- aux e1 (cons_enum t2 e2')
+ let c = Ord.compare k1 k2 in
+ if c = 0 then
+ f k1 (Some v1) (Some v2) &&
+ aux (cons_enum t1 e1') (cons_enum t2 e2')
+ else if c < 0 then
+ f k1 (Some v1) None &&
+ aux (cons_enum t1 e1') e2
+ else
+ f k2 (Some v2) None &&
+ aux e1 (cons_enum t2 e2')
in aux (cons_enum m1 End) (cons_enum m2 End)
@@ -491,58 +491,58 @@ module Make(Ord: Datatype.S)(Value: Value) = struct
include Datatype.Make
- (struct
- type t = rangemap
- let name = "(" ^ Ord.name ^ ", " ^ Value.name ^ ") rangemap"
- open Structural_descr
- let r = Recursive.create ()
- let structural_descr =
- t_sum
- [| [| recursive_pack r;
- Ord.packed_descr;
- Value.packed_descr;
- recursive_pack r;
- p_int;
- p_int |] |]
- let () = Recursive.update r structural_descr
- let reprs =
- List.fold_left
- (fun acc k ->
+ (struct
+ type t = rangemap
+ let name = "(" ^ Ord.name ^ ", " ^ Value.name ^ ") rangemap"
+ open Structural_descr
+ let r = Recursive.create ()
+ let structural_descr =
+ t_sum
+ [| [| recursive_pack r;
+ Ord.packed_descr;
+ Value.packed_descr;
+ recursive_pack r;
+ p_int;
+ p_int |] |]
+ let () = Recursive.update r structural_descr
+ let reprs =
List.fold_left
- (fun acc v -> (Node(Empty, k, v, Empty, 0, 0)) :: acc)
- acc
- Value.reprs)
- [ Empty ]
- Ord.reprs
- let equal = equal
- let compare = compare
- let hash = hash
- let rehash = Datatype.identity
- let copy =
- if Ord.copy == Datatype.undefined || Value.copy == Datatype.undefined
- then Datatype.undefined
- else
- let rec aux =
- function
- | Empty -> Empty
- | Node (l,x,d,r,_,_) ->
- let l = aux l in
- let x = Ord.copy x in
- let d = Value.copy d in
- let r = aux r in
- create l x d r
- in aux
-
- let internal_pretty_code = Datatype.undefined
- let pretty = Datatype.undefined
- let varname = Datatype.undefined
- let mem_project =
- if Ord.mem_project == Datatype.never_any_project &&
- Value.mem_project == Datatype.never_any_project then
- Datatype.never_any_project
- else
- (fun s -> exists (fun k v -> Ord.mem_project s k || Value.mem_project s v))
- end)
+ (fun acc k ->
+ List.fold_left
+ (fun acc v -> (Node(Empty, k, v, Empty, 0, 0)) :: acc)
+ acc
+ Value.reprs)
+ [ Empty ]
+ Ord.reprs
+ let equal = equal
+ let compare = compare
+ let hash = hash
+ let rehash = Datatype.identity
+ let copy =
+ if Ord.copy == Datatype.undefined || Value.copy == Datatype.undefined
+ then Datatype.undefined
+ else
+ let rec aux =
+ function
+ | Empty -> Empty
+ | Node (l,x,d,r,_,_) ->
+ let l = aux l in
+ let x = Ord.copy x in
+ let d = Value.copy d in
+ let r = aux r in
+ create l x d r
+ in aux
+
+ let internal_pretty_code = Datatype.undefined
+ let pretty = Datatype.undefined
+ let varname = Datatype.undefined
+ let mem_project =
+ if Ord.mem_project == Datatype.never_any_project &&
+ Value.mem_project == Datatype.never_any_project then
+ Datatype.never_any_project
+ else
+ (fun s -> exists (fun k v -> Ord.mem_project s k || Value.mem_project s v))
+ end)
let () = Type.set_ml_name ty None
end
diff --git a/src/libraries/utils/rangemap.mli b/src/libraries/utils/rangemap.mli
index 206172eb2e07b3370fa2af59d8fe5bdb541f440b..aad77b23a420cd80ec60444dcfd4adb3fa7e3c96 100644
--- a/src/libraries/utils/rangemap.mli
+++ b/src/libraries/utils/rangemap.mli
@@ -73,8 +73,8 @@ module type S = sig
binding disappears. *)
val singleton: key -> value -> t
- (** [singleton x y] returns the one-element map that contains a binding [y]
- for [x]. *)
+ (** [singleton x y] returns the one-element map that contains a binding [y]
+ for [x]. *)
val find: key -> t -> value
(** [find x m] returns the current binding of [x] in [m],
@@ -118,74 +118,74 @@ module type S = sig
(in increasing order), and [d1 ... dN] are the associated data. *)
val for_all: (key -> value -> bool) -> t -> bool
- (** [for_all p m] checks if all the bindings of the map satisfy
- the predicate [p]. *)
+ (** [for_all p m] checks if all the bindings of the map satisfy
+ the predicate [p]. *)
val exists: (key -> value -> bool) -> t -> bool
- (** [exists p m] checks if at least one binding of the map
- satisfy the predicate [p]. *)
+ (** [exists p m] checks if at least one binding of the map
+ satisfy the predicate [p]. *)
val filter: (key -> value -> bool) -> t -> t
- (** [filter p m] returns the map with all the bindings in [m]
- that satisfy predicate [p]. *)
+ (** [filter p m] returns the map with all the bindings in [m]
+ that satisfy predicate [p]. *)
val partition: (key -> value -> bool) -> t -> t * t
- (** [partition p m] returns a pair of maps [(m1, m2)], where
- [m1] contains all the bindings of [s] that satisfy the
- predicate [p], and [m2] is the map with all the bindings of
- [s] that do not satisfy [p]. *)
+ (** [partition p m] returns a pair of maps [(m1, m2)], where
+ [m1] contains all the bindings of [s] that satisfy the
+ predicate [p], and [m2] is the map with all the bindings of
+ [s] that do not satisfy [p]. *)
val cardinal: t -> int
- (** Return the number of bindings of a map. *)
+ (** Return the number of bindings of a map. *)
val bindings: t -> (key * value) list
- (** Return the list of all bindings of the given map.
- The returned list is sorted in increasing order with respect
- to the ordering on keys *)
+ (** Return the list of all bindings of the given map.
+ The returned list is sorted in increasing order with respect
+ to the ordering on keys *)
val min_binding: t -> (key * value)
- (** Return the smallest binding of the given map (with respect to the
- [Ord.compare] ordering), or raise [Not_found] if the map is empty. *)
+ (** Return the smallest binding of the given map (with respect to the
+ [Ord.compare] ordering), or raise [Not_found] if the map is empty. *)
val max_binding: t -> (key * value)
- (** Same as {!Map.S.min_binding}, but returns the largest binding
- of the given map. *)
+ (** Same as {!Map.S.min_binding}, but returns the largest binding
+ of the given map. *)
val choose: t -> (key * value)
- (** Return one binding of the given map, or raise [Not_found] if
- the map is empty. Which binding is chosen is unspecified,
- but equal bindings will be chosen for equal maps. *)
+ (** Return one binding of the given map, or raise [Not_found] if
+ the map is empty. Which binding is chosen is unspecified,
+ but equal bindings will be chosen for equal maps. *)
val merge: (key -> value option -> value option -> value option) -> t -> t -> t
- (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1]
- and of [m2]. The presence of each such binding, and the corresponding
- value, is determined with the function [f]. *)
+ (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1]
+ and of [m2]. The presence of each such binding, and the corresponding
+ value, is determined with the function [f]. *)
val for_all2: (key -> value option -> value option -> bool) -> t -> t -> bool
- (** [for_all2 f m1 m2] returns true if and only if [f k v1 v2] holds
- for each [k] present in either [m1] and [m2], [v_i] being
- [Some (find k m_i)] if [k] is in [m_i], and [None] otherwise
- (for [i=1] or [i=2]) *)
+ (** [for_all2 f m1 m2] returns true if and only if [f k v1 v2] holds
+ for each [k] present in either [m1] and [m2], [v_i] being
+ [Some (find k m_i)] if [k] is in [m_i], and [None] otherwise
+ (for [i=1] or [i=2]) *)
val exists2: (key -> value option -> value option -> bool) -> t -> t -> bool
- (** [exists2 f m1 m2] returns true if and only there exists
- [k] present in [m1] or [m2] such that [f k v1 v2] holds,
- [v_i] being [Some (find k m_i)] if [k] is in [m_i], and [None]
- otherwise (for [i=1] or [i=2]) *)
+ (** [exists2 f m1 m2] returns true if and only there exists
+ [k] present in [m1] or [m2] such that [f k v1 v2] holds,
+ [v_i] being [Some (find k m_i)] if [k] is in [m_i], and [None]
+ otherwise (for [i=1] or [i=2]) *)
val iter2: (key -> value option -> value option -> unit) -> t -> t -> unit
- (** [iter2 f m1 m2] computes [f k v1 v2] for each [k] present in either
- [m1] or [m2] (the [k] being presented in ascending order), [v_i] being
- [Some (find k m_i)] if [k] is in [m_i], and [None] otherwise
- (for [i=1] or [i=2]) *)
+ (** [iter2 f m1 m2] computes [f k v1 v2] for each [k] present in either
+ [m1] or [m2] (the [k] being presented in ascending order), [v_i] being
+ [Some (find k m_i)] if [k] is in [m_i], and [None] otherwise
+ (for [i=1] or [i=2]) *)
val fold2: (key -> value option -> value option -> 'a -> 'a) -> t -> t -> 'a -> 'a
- (** [fold2 f m1 m2 v] computes [(f k_N v1_N v2_N... (f k_1 v1_1 v2_1 a)...)]
- where [k_1 ... k_N] are all the keys of all the bindings in either
- [m1] or [m2] (in increasing order), [vi_j] being [Some (find k_j m_i)]
- if [k_j] is in [m_i], and [None] otherwise (for [i=1] or [i=2]) *)
+ (** [fold2 f m1 m2 v] computes [(f k_N v1_N v2_N... (f k_1 v1_1 v2_1 a)...)]
+ where [k_1 ... k_N] are all the keys of all the bindings in either
+ [m1] or [m2] (in increasing order), [vi_j] being [Some (find k_j m_i)]
+ if [k_j] is in [m_i], and [None] otherwise (for [i=1] or [i=2]) *)
end
@@ -217,15 +217,15 @@ module Make (Ord : Datatype.S) (Value : Value): sig
val concerned_intervals:
(key -> key -> fuzzy_order) ->
key -> t -> (key*Value.t) list
- (** Intervals that match the given key. The resulting list is sorted in
- decreasing order. *)
-
- exception Empty_rangemap
- val lowest_binding : t -> key * Value.t
- exception No_such_binding
- val lowest_binding_above : (key -> bool) -> t -> key * Value.t
- val add_whole : (key -> key -> fuzzy_order) -> key -> Value.t -> t -> t
- val remove_whole : (key -> key -> fuzzy_order) -> key -> t -> t
+ (** Intervals that match the given key. The resulting list is sorted in
+ decreasing order. *)
+
+ exception Empty_rangemap
+ val lowest_binding : t -> key * Value.t
+ exception No_such_binding
+ val lowest_binding_above : (key -> bool) -> t -> key * Value.t
+ val add_whole : (key -> key -> fuzzy_order) -> key -> Value.t -> t -> t
+ val remove_whole : (key -> key -> fuzzy_order) -> key -> t -> t
end
diff --git a/src/libraries/utils/vector.ml b/src/libraries/utils/vector.ml
index af703c3fe23fdb381252952937f5f40fb9a9d686..1b343d1f0678284cac57f48f75da22573d2436b6 100644
--- a/src/libraries/utils/vector.ml
+++ b/src/libraries/utils/vector.ml
@@ -55,7 +55,7 @@ let do_shrink w n =
let resize w n =
let m = Array.length w.elt in
if 0 <= n && n < m then do_shrink w n else
- if n > m then do_grow w n
+ if n > m then do_grow w n
let shrink w = resize w w.top
@@ -63,7 +63,7 @@ let size w = w.top
let length w = w.top
let capacity w = Array.length w.elt
-let get w k =
+let get w k =
if 0 <= k && k < w.top then w.elt.(k) else raise Not_found
let set w k e =
@@ -78,7 +78,7 @@ let addi w e =
let add w e = ignore (addi w e)
-let clear w =
+let clear w =
begin
w.top <- 0 ;
Array.fill w.elt 0 (Array.length w.elt) w.dumb ;
@@ -87,7 +87,7 @@ let clear w =
let iter f w = for k = 0 to w.top - 1 do f w.elt.(k) done
let iteri f w = for k = 0 to w.top - 1 do f k w.elt.(k) done
-let map f w =
+let map f w =
{
dumb = Obj.magic w.dumb ;
top = w.top ;
@@ -104,8 +104,8 @@ let mapi f w =
let find w ?default ?(exn=Not_found) k =
if 0 <= k && k < w.top then w.elt.(k) else
match default with
- | None -> raise exn
- | Some e -> e
+ | None -> raise exn
+ | Some e -> e
let update w ?default k e =
let exn = Invalid_argument "Vector.update" in
diff --git a/src/libraries/utils/vector.mli b/src/libraries/utils/vector.mli
index 69739a6ccceb5c237c627b7f6c212136c9bd1410..f07be8e69b377c16c103b5983f0914811ecb119b 100644
--- a/src/libraries/utils/vector.mli
+++ b/src/libraries/utils/vector.mli
@@ -42,15 +42,15 @@ val map : ('a -> 'b) -> 'a t -> 'b t (** Result is shrunk. *)
val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t (** Result is shrunk. *)
val find : 'a t -> ?default:'a -> ?exn:exn -> int -> 'a
- (** Default exception is [Not_found].
- If a [default] value is provided, no exception is raised. *)
+(** Default exception is [Not_found].
+ If a [default] value is provided, no exception is raised. *)
val update : 'a t -> ?default:'a -> int -> 'a -> unit
- (** Set value at index.
- If the updated index is greater of equal to the vector size,
- empty cells are inserted with the default value.
- @raise Invalid_argument if the index is negative or when it exceeds the
- the vector size but the default value is not provided. *)
+(** Set value at index.
+ If the updated index is greater of equal to the vector size,
+ empty cells are inserted with the default value.
+ @raise Invalid_argument if the index is negative or when it exceeds the
+ the vector size but the default value is not provided. *)
val to_array : 'a t -> 'a array (** Makes a copy. *)
val of_array : 'a array -> 'a t (** Makes a copy. *)
@@ -63,4 +63,3 @@ val resize : 'a t -> int -> unit
(** Low-level interface. Sets capacity to content. *)
val shrink : 'a t -> unit
-
diff --git a/src/libraries/utils/wto.ml b/src/libraries/utils/wto.ml
index cf06bf76c7a83e39248d6b97b8f398c4254cac94..6af133da8b35e40f7625432208e6ea4c142e4c3e 100644
--- a/src/libraries/utils/wto.ml
+++ b/src/libraries/utils/wto.ml
@@ -26,10 +26,10 @@
by a list of components topologically ordered. *)
type 'n component =
| Component of 'n * 'n partition
- (** A strongly connected component, described by its head node and the
- remaining sub-components topologically ordered *)
+ (** A strongly connected component, described by its head node and the
+ remaining sub-components topologically ordered *)
| Node of 'n
- (** A single node without self loop *)
+ (** A single node without self loop *)
(** A list of strongly connected components, sorted topologically *)
and 'n partition = 'n component list
@@ -74,7 +74,7 @@ let flatten wto =
- Each time we visit a node n, we push it on a stack. After the
visit, n is popped, unless a path exists from n to an element
earlier on the stack. So the stack contains elements currently
- visited or that belongs to a non-trivial scc. Moreover, they
+ visited or that belongs to a non-trivial scc. Moreover, they
are in topological order.
About the proof of Tarjan:
diff --git a/src/libraries/utils/wto.mli b/src/libraries/utils/wto.mli
index 39d14925d37fded66790169bd3b9b33455b73a77..068c735c4d0c74c1714f4fc7704ed442d9c1faa2 100644
--- a/src/libraries/utils/wto.mli
+++ b/src/libraries/utils/wto.mli
@@ -32,10 +32,10 @@
by a list of components topologically ordered. *)
type 'n component =
| Component of 'n * 'n partition
- (** A strongly connected component, described by its head node and the
- remaining sub-components topologically ordered *)
+ (** A strongly connected component, described by its head node and the
+ remaining sub-components topologically ordered *)
| Node of 'n
- (** A single node without self loop *)
+ (** A single node without self loop *)
(** A list of strongly connected components, sorted topologically *)
and 'n partition = 'n component list
@@ -59,7 +59,7 @@ module Make(Node:sig
Use "(fun _ _ -> 0)" for no specific preference. *)
(** Implements Bourdoncle "Efficient chaotic iteration strategies with
- widenings" algorithm to compute a WTO. *)
+ widenings" algorithm to compute a WTO. *)
val partition: pref:pref -> init:Node.t -> succs:(Node.t -> Node.t list) -> Node.t partition
val pretty_partition: Format.formatter -> Node.t partition -> unit
diff --git a/src/plugins/aorai/Aorai.mli b/src/plugins/aorai/Aorai.mli
index b4abc4b3932317ec110a5c3302fc9d90546835c5..198bfdbc026b5e07702a83bb52ac32e336b387f3 100644
--- a/src/plugins/aorai/Aorai.mli
+++ b/src/plugins/aorai/Aorai.mli
@@ -26,7 +26,7 @@
(* $Id: Ltl_to_acsl.mli,v 1.3 2008-10-10 16:03:25 uid588 Exp $ *)
(**
- Aorai plugin (AKA Ltl_to_acsl).
- No function is directly exported: they are registered in {!Db.Aorai}.
+ Aorai plugin (AKA Ltl_to_acsl).
+ No function is directly exported: they are registered in {!Db.Aorai}.
*)
diff --git a/src/plugins/aorai/aorai_dataflow.ml b/src/plugins/aorai/aorai_dataflow.ml
index 3cb48086ec7d282274a34d7b2c39a7e7dd0d3e21..2ff1b010c3d14a9f803b1ab902aea36c76c5d6b8 100644
--- a/src/plugins/aorai/aorai_dataflow.ml
+++ b/src/plugins/aorai/aorai_dataflow.ml
@@ -47,84 +47,84 @@ let filter_state set map =
let compose_range loc b r1 r2 =
match r1, r2 with
- | Fixed c1, Fixed c2 -> Fixed (c1 + c2)
- | Fixed c, Interval(min,max) | Interval(min,max), Fixed c ->
- Interval (c+min,c+max)
- | Fixed c, Bounded(min,max) | Bounded(min,max), Fixed c ->
- let max =
- Logic_const.term
- (TBinOp(PlusA,max, Logic_const.tinteger c))
- Linteger
- in
- Bounded(c+min,max)
- | Fixed c1, Unbounded min | Unbounded min, Fixed c1 -> Unbounded (min+c1)
- | Interval(min1,max1), Interval(min2,max2) ->
- Interval(min1+min2,max1+max2)
- (* NB: in the bounded case, we could check if upper bound of interval
- is less then lower bound of bounded to keep bounded.
- *)
- | Interval(min1,_), Bounded(min2,_) | Bounded(min2,_), Interval(min1,_)
- | Interval(min1,_), Unbounded min2 | Unbounded min2, Interval (min1,_)
- | Bounded(min1, _), Bounded (min2, _) | Unbounded min1, Unbounded min2
- | Bounded(min1,_), Unbounded min2 | Unbounded min1, Bounded(min2,_)
- ->
- if Cil.isLogicZero b then Data_for_aorai.absolute_range loc (min1 + min2)
- else Unbounded (min1 + min2)
- | Unknown, _ | _, Unknown -> Unknown
+ | Fixed c1, Fixed c2 -> Fixed (c1 + c2)
+ | Fixed c, Interval(min,max) | Interval(min,max), Fixed c ->
+ Interval (c+min,c+max)
+ | Fixed c, Bounded(min,max) | Bounded(min,max), Fixed c ->
+ let max =
+ Logic_const.term
+ (TBinOp(PlusA,max, Logic_const.tinteger c))
+ Linteger
+ in
+ Bounded(c+min,max)
+ | Fixed c1, Unbounded min | Unbounded min, Fixed c1 -> Unbounded (min+c1)
+ | Interval(min1,max1), Interval(min2,max2) ->
+ Interval(min1+min2,max1+max2)
+ (* NB: in the bounded case, we could check if upper bound of interval
+ is less then lower bound of bounded to keep bounded.
+ *)
+ | Interval(min1,_), Bounded(min2,_) | Bounded(min2,_), Interval(min1,_)
+ | Interval(min1,_), Unbounded min2 | Unbounded min2, Interval (min1,_)
+ | Bounded(min1, _), Bounded (min2, _) | Unbounded min1, Unbounded min2
+ | Bounded(min1,_), Unbounded min2 | Unbounded min1, Bounded(min2,_)
+ ->
+ if Cil.isLogicZero b then Data_for_aorai.absolute_range loc (min1 + min2)
+ else Unbounded (min1 + min2)
+ | Unknown, _ | _, Unknown -> Unknown
let fail_on_both k elt1 elt2 =
match elt1, elt2 with
- | None, None -> None
- | Some v, None
- | None, Some v -> Some v
- | Some _, Some _ ->
- Aorai_option.fatal
- "found a binding in both action and parameters table for %a"
- Printer.pp_term k
+ | None, None -> None
+ | Some v, None
+ | None, Some v -> Some v
+ | Some _, Some _ ->
+ Aorai_option.fatal
+ "found a binding in both action and parameters table for %a"
+ Printer.pp_term k
let compose_bindings map1 loc vals map =
- let vals = Cil_datatype.Term.Map.fold
- (fun base intv vals ->
- let vals' =
- if Cil.isLogicZero base then Cil_datatype.Term.Map.singleton base intv
- else
- try
- let orig_base = Cil_datatype.Term.Map.find base map1 in
- Cil_datatype.Term.Map.fold
- (fun base intv' map ->
- let intv' = compose_range loc base intv' intv in
- Cil_datatype.Term.Map.add base intv' map
- )
- orig_base Cil_datatype.Term.Map.empty
- with Not_found -> Cil_datatype.Term.Map.singleton base intv
- in
- Cil_datatype.Term.Map.merge
- (Extlib.merge_opt (Data_for_aorai.merge_range loc)) vals' vals
- )
- vals Cil_datatype.Term.Map.empty
+ let vals = Cil_datatype.Term.Map.fold
+ (fun base intv vals ->
+ let vals' =
+ if Cil.isLogicZero base then Cil_datatype.Term.Map.singleton base intv
+ else
+ try
+ let orig_base = Cil_datatype.Term.Map.find base map1 in
+ Cil_datatype.Term.Map.fold
+ (fun base intv' map ->
+ let intv' = compose_range loc base intv' intv in
+ Cil_datatype.Term.Map.add base intv' map
+ )
+ orig_base Cil_datatype.Term.Map.empty
+ with Not_found -> Cil_datatype.Term.Map.singleton base intv
+ in
+ Cil_datatype.Term.Map.merge
+ (Extlib.merge_opt (Data_for_aorai.merge_range loc)) vals' vals
+ )
+ vals Cil_datatype.Term.Map.empty
in
try
let vals' = Cil_datatype.Term.Map.find loc map in
let vals' =
- Cil_datatype.Term.Map.merge
+ Cil_datatype.Term.Map.merge
(Extlib.merge_opt (Data_for_aorai.merge_range loc)) vals' vals
in
Cil_datatype.Term.Map.add loc vals' map
with Not_found ->
Cil_datatype.Term.Map.add loc vals map
-let compose_actions
+let compose_actions
?(args=Cil_datatype.Term.Map.empty) (fst,_,map1) (_,last,map2) =
let map_args = Cil_datatype.Term.Map.merge fail_on_both map1 args in
- let map =
+ let map =
Cil_datatype.Term.Map.fold (compose_bindings map_args)
map2 Cil_datatype.Term.Map.empty
in
(fst,last,
Cil_datatype.Term.Map.fold
- (fun elt bind map ->
- if Cil_datatype.Term.Map.mem elt map2 then map
- else Cil_datatype.Term.Map.add elt bind map) map1 map)
+ (fun elt bind map ->
+ if Cil_datatype.Term.Map.mem elt map2 then map
+ else Cil_datatype.Term.Map.add elt bind map) map1 map)
let compose_states
?(args=Cil_datatype.Term.Map.empty) start_state end_state =
@@ -132,7 +132,7 @@ let compose_states
try
let new_states = Data_for_aorai.Aorai_state.Map.find stop end_state in
let composed_actions =
- Data_for_aorai.Aorai_state.Map.map
+ Data_for_aorai.Aorai_state.Map.map
(fun elt -> compose_actions ~args bindings elt) new_states
in
let merge_stop_state _ (fst1, last1, map1) (fst2, last2, map2) =
@@ -146,7 +146,7 @@ let compose_states
in
let treat_one_start_state start curr_states acc =
let trans_state =
- Data_for_aorai.Aorai_state.Map.fold
+ Data_for_aorai.Aorai_state.Map.fold
treat_one_curr_state curr_states Data_for_aorai.Aorai_state.Map.empty
in
if Data_for_aorai.Aorai_state.Map.is_empty trans_state then acc
@@ -160,12 +160,12 @@ module Call_state =
(Cil_datatype.Stmt.Hashtbl)
(Case_state)
(struct
- let name = "Data_for_aorai.Call_state"
- let dependencies =
- [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
- Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
- let size = 17
- end)
+ let name = "Data_for_aorai.Call_state"
+ let dependencies =
+ [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
+ Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
+ let size = 17
+ end)
let set_call_state stmt state =
let real_state =
@@ -194,12 +194,12 @@ module Return_state =
(Cil_datatype.Stmt.Hashtbl)
(Case_state)
(struct
- let name = "Data_for_aorai.Return_state"
- let dependencies =
- [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
- Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
- let size = 17
- end)
+ let name = "Data_for_aorai.Return_state"
+ let dependencies =
+ [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
+ Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
+ let size = 17
+ end)
let set_return_state stmt state =
let change old_state = Data_for_aorai.merge_state old_state state in
@@ -207,35 +207,35 @@ let set_return_state stmt state =
ignore (Return_state.memo ~change set stmt)
module type Init = sig
- val kf: Kernel_function.t
- val stack: (Kernel_function.t * bool ref) list
- (* call stack. flag is set to true for the topmost function of each
- recursion. *)
- val initial_state: Data_for_aorai.state * Cil_datatype.Stmt.Set.t
+ val kf: Kernel_function.t
+ val stack: (Kernel_function.t * bool ref) list
+ (* call stack. flag is set to true for the topmost function of each
+ recursion. *)
+ val initial_state: Data_for_aorai.state * Cil_datatype.Stmt.Set.t
end
-let compute_func =
- ref
- (fun _ _ _ _ ->
- Aorai_option.fatal "Aorai_dataflow.compute_func not properly initialized")
+let compute_func =
+ ref
+ (fun _ _ _ _ ->
+ Aorai_option.fatal "Aorai_dataflow.compute_func not properly initialized")
let extract_current_states s =
Data_for_aorai.Aorai_state.Map.fold
(fun _ tbl acc ->
- Data_for_aorai.Aorai_state.Map.fold
- (fun s _ acc -> Data_for_aorai.Aorai_state.Set.add s acc)
- tbl acc)
+ Data_for_aorai.Aorai_state.Map.fold
+ (fun s _ acc -> Data_for_aorai.Aorai_state.Set.add s acc)
+ tbl acc)
s Data_for_aorai.Aorai_state.Set.empty
let add_or_merge state (fst, last, bindings as elt) tbl =
try
- let (old_fst, old_last, old_bindings) =
+ let (old_fst, old_last, old_bindings) =
Data_for_aorai.Aorai_state.Map.find state tbl
in
let merged_fst = Data_for_aorai.Aorai_state.Set.union old_fst fst in
let merged_last = Data_for_aorai.Aorai_state.Set.union old_last last in
let merged_bindings = Data_for_aorai.merge_bindings old_bindings bindings in
- Data_for_aorai.Aorai_state.Map.add
+ Data_for_aorai.Aorai_state.Map.add
state (merged_fst, merged_last, merged_bindings) tbl
with Not_found ->
Data_for_aorai.Aorai_state.Map.add state elt tbl
@@ -249,26 +249,26 @@ let actions_to_range l =
in
let treat_one_action acc =
function
- | Counter_init lv ->
- let t = Data_for_aorai.tlval lv in
- add_single_action t (Cil.lzero()) (Fixed 1) acc
- | Counter_incr lv ->
- let t = Data_for_aorai.tlval lv in
- add_single_action t t (Fixed 1) acc
- | Pebble_init(_,_,c) -> (* TODO: put post-conds on pebble sets *)
- let t = Logic_const.tvar c in add_single_action t t (Fixed 1) acc
- | Pebble_move _ -> acc (* TODO: put post-conds on pebble sets *)
- | Copy_value (lv,t) ->
- let loc = Data_for_aorai.tlval lv in
- add_single_action loc t (Fixed 0) acc
+ | Counter_init lv ->
+ let t = Data_for_aorai.tlval lv in
+ add_single_action t (Cil.lzero()) (Fixed 1) acc
+ | Counter_incr lv ->
+ let t = Data_for_aorai.tlval lv in
+ add_single_action t t (Fixed 1) acc
+ | Pebble_init(_,_,c) -> (* TODO: put post-conds on pebble sets *)
+ let t = Logic_const.tvar c in add_single_action t t (Fixed 1) acc
+ | Pebble_move _ -> acc (* TODO: put post-conds on pebble sets *)
+ | Copy_value (lv,t) ->
+ let loc = Data_for_aorai.tlval lv in
+ add_single_action loc t (Fixed 0) acc
in List.fold_left treat_one_action Cil_datatype.Term.Map.empty l
let make_start_transition ?(is_main=false) kf init_states =
let auto = Data_for_aorai.getGraph () in
- let is_crossable =
- if is_main then
- Aorai_utils.isCrossableAtInit
- else
+ let is_crossable =
+ if is_main then
+ Aorai_utils.isCrossableAtInit
+ else
(fun trans kf -> Aorai_utils.isCrossable trans kf Promelaast.Call)
in
let treat_one_state state acc =
@@ -288,7 +288,7 @@ let make_start_transition ?(is_main=false) kf init_states =
else acc
in
let possible_states =
- List.fold_left
+ List.fold_left
treat_one_trans Data_for_aorai.Aorai_state.Map.empty my_trans
in
if Data_for_aorai.Aorai_state.Map.is_empty possible_states then acc
@@ -299,13 +299,13 @@ let make_start_transition ?(is_main=false) kf init_states =
Data_for_aorai.Aorai_state.(
Map.add state
(Map.singleton state
- (Set.singleton state, Set.singleton state,
- Cil_datatype.Term.Map.empty))
+ (Set.singleton state, Set.singleton state,
+ Cil_datatype.Term.Map.empty))
acc)
end
in
let res =
- Data_for_aorai.Aorai_state.Set.fold
+ Data_for_aorai.Aorai_state.Set.fold
treat_one_state init_states Data_for_aorai.Aorai_state.Map.empty
in res
@@ -339,40 +339,40 @@ let make_return_transition kf state =
in
let treat_one_path start_state curr_state acc =
let res =
- Data_for_aorai.Aorai_state.Map.fold
+ Data_for_aorai.Aorai_state.Map.fold
treat_one_state curr_state Data_for_aorai.Aorai_state.Map.empty
in
if Data_for_aorai.Aorai_state.Map.is_empty res then acc
else Data_for_aorai.Aorai_state.Map.add start_state res acc
in
- Data_for_aorai.Aorai_state.Map.fold
+ Data_for_aorai.Aorai_state.Map.fold
treat_one_path state Data_for_aorai.Aorai_state.Map.empty
let create_loop_init state =
let res =
Aorai_state.Map.fold
(fun _ s acc ->
- Aorai_state.Map.fold
- (fun final (_,pre_final,_) acc ->
- let map =
- try Aorai_state.Map.find final acc
- with Not_found -> Aorai_state.Map.empty
- in
- let (init,last,actions) =
- try Aorai_state.Map.find final map
- with Not_found ->
- (Aorai_state.Set.empty,Aorai_state.Set.empty,
- Cil_datatype.Term.Map.empty)
- in
- let map = Aorai_state.Map.add
- final
- (Aorai_state.Set.union pre_final init,
- Aorai_state.Set.union pre_final last,
- actions)
- map
- in
- Aorai_state.Map.add final map acc)
- s acc)
+ Aorai_state.Map.fold
+ (fun final (_,pre_final,_) acc ->
+ let map =
+ try Aorai_state.Map.find final acc
+ with Not_found -> Aorai_state.Map.empty
+ in
+ let (init,last,actions) =
+ try Aorai_state.Map.find final map
+ with Not_found ->
+ (Aorai_state.Set.empty,Aorai_state.Set.empty,
+ Cil_datatype.Term.Map.empty)
+ in
+ let map = Aorai_state.Map.add
+ final
+ (Aorai_state.Set.union pre_final init,
+ Aorai_state.Set.union pre_final last,
+ actions)
+ map
+ in
+ Aorai_state.Map.add final map acc)
+ s acc)
state Aorai_state.Map.empty
in
Aorai_option.debug ~dkey:forward_dkey "@[State at loop entry@\n%a@]"
@@ -385,31 +385,31 @@ module Computer(I: Init) = struct
(* We keep track of the loops that we have entered, since we distinguish
states at loop initialization from states during loop itself: when
combining predecessors, we must know where we come from.
- *)
+ *)
type data = (Data_for_aorai.state * Cil_datatype.Stmt.Set.t)
type t = data
let copy = Extlib.id
let pretty fmt (s,_) = Data_for_aorai.pretty_state fmt s
- (* we do not propagate inside the loop the actions made before,
- to obtain more precise loop assigns. This is merged back in doEdge
- when we exit the loop.
+ (* we do not propagate inside the loop the actions made before,
+ to obtain more precise loop assigns. This is merged back in doEdge
+ when we exit the loop.
*)
let computeFirstPredecessor stmt (s,loops as res) =
match stmt.skind with
- | Loop _ ->
- Data_for_aorai.set_loop_init_state stmt s;
- create_loop_init s, Cil_datatype.Stmt.Set.add stmt loops
- | _ -> res
+ | Loop _ ->
+ Data_for_aorai.set_loop_init_state stmt s;
+ create_loop_init s, Cil_datatype.Stmt.Set.add stmt loops
+ | _ -> res
let combinePredecessors stmt ~old (cur,loops) =
- let (old,_) = old in
+ let (old,_) = old in
(* we don't care about loops in old state: it has already been handled *)
let is_loop = match stmt.skind with
- | Loop _ -> true
- | _ -> false
+ | Loop _ -> true
+ | _ -> false
in
- Aorai_option.debug
+ Aorai_option.debug
~dkey:forward_dkey
"Combining state (loop is %B)@\n @[%a@]@\nwith state@\n @[%a@]"
is_loop
@@ -417,18 +417,18 @@ module Computer(I: Init) = struct
if Data_for_aorai.included_state cur old then begin
Aorai_option.debug ~dkey:forward_dkey "Included";
if is_loop && Cil_datatype.Stmt.Set.mem stmt loops &&
- Data_for_aorai.Aorai_state.Map.is_empty
- (Data_for_aorai.get_loop_invariant_state stmt)
- then
+ Data_for_aorai.Aorai_state.Map.is_empty
+ (Data_for_aorai.get_loop_invariant_state stmt)
+ then
Data_for_aorai.set_loop_invariant_state stmt cur;
None
- end else begin
- let res =
+ end else begin
+ let res =
if is_loop then begin
(* set_loop implicitly merges states when needed.
However, we still have to distinguish whether we are already
in the loop or at the initial stage.
- *)
+ *)
if Cil_datatype.Stmt.Set.mem stmt loops then begin
Data_for_aorai.set_loop_invariant_state stmt cur;
Data_for_aorai.get_loop_invariant_state stmt
@@ -437,12 +437,12 @@ module Computer(I: Init) = struct
create_loop_init (Data_for_aorai.get_loop_init_state stmt)
end
end else begin
- Data_for_aorai.merge_state old cur
+ Data_for_aorai.merge_state old cur
end
in
Aorai_option.debug ~dkey:forward_dkey "Merged state is@\n @[%a@]"
Data_for_aorai.pretty_state res;
- let loops =
+ let loops =
if is_loop then
Cil_datatype.Stmt.Set.add stmt loops
else loops
@@ -495,44 +495,44 @@ module Computer(I: Init) = struct
let doInstr s i d =
match i with
- | Call (_,{ enode = Lval(Var v,NoOffset) },args,_) ->
- do_call s v args d
- | Call (_,e,_,_) ->
- Aorai_option.not_yet_implemented
- ~source:(fst e.eloc)
- "Indirect call to %a is not handled yet" Printer.pp_exp e
- | Local_init (v, ConsInit(f,args,kind),_) ->
- let args =
- match kind with
- | Plain_func -> args
- | Constructor -> Cil.mkAddrOfVi v :: args
- in
- do_call s f args d
- | Local_init (_, AssignInit _, _)
- | Set _ | Asm _ | Skip _ | Code_annot _ -> d
+ | Call (_,{ enode = Lval(Var v,NoOffset) },args,_) ->
+ do_call s v args d
+ | Call (_,e,_,_) ->
+ Aorai_option.not_yet_implemented
+ ~source:(fst e.eloc)
+ "Indirect call to %a is not handled yet" Printer.pp_exp e
+ | Local_init (v, ConsInit(f,args,kind),_) ->
+ let args =
+ match kind with
+ | Plain_func -> args
+ | Constructor -> Cil.mkAddrOfVi v :: args
+ in
+ do_call s f args d
+ | Local_init (_, AssignInit _, _)
+ | Set _ | Asm _ | Skip _ | Code_annot _ -> d
let doGuard _ _ _ = (GDefault, GDefault)
let doStmt _ (state,_) =
if Data_for_aorai.Aorai_state.Map.is_empty state then
- (* Statement is not conforming to the automaton. It must be
- on a dead path for the whole program to match the spec.
- *)
+ (* Statement is not conforming to the automaton. It must be
+ on a dead path for the whole program to match the spec.
+ *)
SDone
else
SDefault
-
+
let edge_exits_loop kf s1 s2 =
try
let loop = Kernel_function.find_enclosing_loop kf s1 in
not (Cil_datatype.Stmt.equal loop s2) &&
(match loop.skind with
- | Loop(_,b,_,_,_) ->
-
- List.exists
- (fun b' -> Cil_datatype.Block.equal b b')
- (Kernel_function.blocks_closed_by_edge s1 s2)
- | _ -> false)
+ | Loop(_,b,_,_,_) ->
+
+ List.exists
+ (fun b' -> Cil_datatype.Block.equal b b')
+ (Kernel_function.blocks_closed_by_edge s1 s2)
+ | _ -> false)
with Not_found -> false
let doEdge s1 s2 (state,loops as t) =
@@ -541,17 +541,17 @@ module Computer(I: Init) = struct
let loop = Kernel_function.find_enclosing_loop kf s1 in
let pre_state = Data_for_aorai.get_loop_init_state loop in
let propagate = compose_states pre_state state in
- Aorai_option.debug ~dkey:forward_dkey
+ Aorai_option.debug ~dkey:forward_dkey
"@[Exiting from loop:@\nInit state is@\n%a@\nCurrent state is@\n%a@\n\
- Propagated state is@\n%a@\n@]"
+ Propagated state is@\n%a@\n@]"
Data_for_aorai.pretty_state pre_state
Data_for_aorai.pretty_state state
Data_for_aorai.pretty_state propagate;
propagate,loops
end else t
-
- module StmtStartData =
+
+ module StmtStartData =
Dataflow2.StartData(struct type t = data let size = 17 end)
let () =
@@ -575,18 +575,18 @@ let compute_func_aux stack call_site kf init_state =
end_state
end else begin
let module Init =
- struct
- let kf = kf
- let stack = (kf, ref false) :: stack
- let initial_state =
- match Kernel_function.find_first_stmt kf with
- | { skind = Loop _ } as stmt ->
- Data_for_aorai.set_loop_init_state stmt init_state;
- (* we are directly entering the loop *)
- create_loop_init init_state,
- Cil_datatype.Stmt.Set.singleton stmt
- | _ -> init_state, Cil_datatype.Stmt.Set.empty
- end
+ struct
+ let kf = kf
+ let stack = (kf, ref false) :: stack
+ let initial_state =
+ match Kernel_function.find_first_stmt kf with
+ | { skind = Loop _ } as stmt ->
+ Data_for_aorai.set_loop_init_state stmt init_state;
+ (* we are directly entering the loop *)
+ create_loop_init init_state,
+ Cil_datatype.Stmt.Set.singleton stmt
+ | _ -> init_state, Cil_datatype.Stmt.Set.empty
+ end
in
let module Compute = Computer (Init) in
let module Dataflow = Forwards(Compute) in
@@ -597,38 +597,38 @@ let compute_func_aux stack call_site kf init_state =
if Kernel_function.is_definition kf then begin
let start = Kernel_function.find_first_stmt kf in
(match start.skind with
- (* If the first statement itself is a loop,
- sets the appropriate table, as this won't be done in Computer
- (technically, there is not firstPredecessor in this particular case)
- *)
- | Loop _ -> Data_for_aorai.set_loop_init_state start init_state
- | _ -> ());
+ (* If the first statement itself is a loop,
+ sets the appropriate table, as this won't be done in Computer
+ (technically, there is not firstPredecessor in this particular case)
+ *)
+ | Loop _ -> Data_for_aorai.set_loop_init_state start init_state
+ | _ -> ());
Dataflow.compute [Kernel_function.find_first_stmt kf]
end;
- let end_state =
+ let end_state =
if Kernel_function.is_definition kf then begin
try
Compute.StmtStartData.find (Kernel_function.find_return kf)
with Not_found ->
let source =
match call_site with
- | Kglobal -> None
- | Kstmt _ -> Some (fst (Cil_datatype.Kinstr.loc call_site))
+ | Kglobal -> None
+ | Kstmt _ -> Some (fst (Cil_datatype.Kinstr.loc call_site))
in
Aorai_option.warning ?source
"Call to %a does not follow automaton's specification. \
- This path is assumed to be dead" Kernel_function.pretty kf;
+ This path is assumed to be dead" Kernel_function.pretty kf;
(Data_for_aorai.Aorai_state.Map.empty, Cil_datatype.Stmt.Set.empty)
end
else (* we assume a declared function does not make any call. *)
(init_state, Cil_datatype.Stmt.Set.empty)
in
- let trans_state = make_return_transition kf (fst end_state) in
+ let trans_state = make_return_transition kf (fst end_state) in
let (my_kf, flag) = List.hd Init.stack in
assert (kf == my_kf);
if !flag then begin
let curr_end =
- try Data_for_aorai.get_kf_return_state kf
+ try Data_for_aorai.get_kf_return_state kf
with Not_found -> Data_for_aorai.Aorai_state.Map.empty
in
Data_for_aorai.set_kf_return_state kf trans_state;
@@ -652,55 +652,55 @@ let compute_forward () =
Aorai_option.abort "Main function %a is ignored by Aorai"
Kernel_function.pretty kf;
let (states,_) = Data_for_aorai.getGraph () in
- let start =
+ let start =
List.fold_left
(fun acc s ->
- match s.Promelaast.init with
- | Bool3.True -> Data_for_aorai.Aorai_state.Set.add s acc
- | _ -> acc)
+ match s.Promelaast.init with
+ | Bool3.True -> Data_for_aorai.Aorai_state.Set.add s acc
+ | _ -> acc)
Data_for_aorai.Aorai_state.Set.empty
states
in
let start_state = make_start_transition ~is_main:true kf start in
ignore (compute_func_aux [] Kglobal kf start_state)
-module type Reachable_end_states =
+module type Reachable_end_states =
sig
val kf: Kernel_function.t
val stack: Kernel_function.t list
val end_state: Data_for_aorai.state
end
-module Pre_state =
+module Pre_state =
Kernel_function.Make_Table
(Data_for_aorai.Case_state)
(struct
- let name = "Aorai_dataflow.Pre_state"
- let dependencies =
- [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
- Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
- let size = 17
- end)
+ let name = "Aorai_dataflow.Pre_state"
+ let dependencies =
+ [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
+ Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
+ let size = 17
+ end)
let set_kf_init_state kf state =
let change old_state = Data_for_aorai.merge_state old_state state in
let set _ = state in
let state = (Pre_state.memo ~change set kf) in
- Aorai_option.debug ~dkey:backward_dkey
- "Call to %a, pre-state after backward analysis:@\n @[%a@]"
- Kernel_function.pretty kf Data_for_aorai.pretty_state state;
+ Aorai_option.debug ~dkey:backward_dkey
+ "Call to %a, pre-state after backward analysis:@\n @[%a@]"
+ Kernel_function.pretty kf Data_for_aorai.pretty_state state;
-module Post_state =
+module Post_state =
Kernel_function.Make_Table
(Data_for_aorai.Case_state)
(struct
- let name = "Aorai_dataflow.Post_state"
- let dependencies =
- [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
- Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
- let size = 17
- end)
+ let name = "Aorai_dataflow.Post_state"
+ let dependencies =
+ [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
+ Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
+ let size = 17
+ end)
let set_kf_return_state kf state =
let change old_state = Data_for_aorai.merge_state old_state state in
@@ -712,12 +712,12 @@ module Init_loop_state =
(Cil_datatype.Stmt.Hashtbl)
(Data_for_aorai.Case_state)
(struct
- let name = "Aorai_dataflow.Init_loop_state"
- let dependencies =
- [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
- Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
- let size = 17
- end)
+ let name = "Aorai_dataflow.Init_loop_state"
+ let dependencies =
+ [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
+ Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
+ let size = 17
+ end)
let set_init_loop_state stmt state =
let change old_state = Data_for_aorai.merge_state old_state state in
@@ -729,12 +729,12 @@ module Invariant_loop_state =
(Cil_datatype.Stmt.Hashtbl)
(Data_for_aorai.Case_state)
(struct
- let name = "Aorai_dataflow.Invariant_loop_state"
- let dependencies =
- [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
- Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
- let size = 17
- end)
+ let name = "Aorai_dataflow.Invariant_loop_state"
+ let dependencies =
+ [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
+ Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
+ let size = 17
+ end)
let set_invariant_loop_state stmt state =
let change old_state = Data_for_aorai.merge_state old_state state in
@@ -742,10 +742,10 @@ let set_invariant_loop_state stmt state =
ignore (Invariant_loop_state.memo ~change set stmt)
let backward_analysis =
- ref
- (fun _ _ _ ->
- Aorai_option.fatal
- "Aorai_dataflow.backward_analysis not properly initialized")
+ ref
+ (fun _ _ _ ->
+ Aorai_option.fatal
+ "Aorai_dataflow.backward_analysis not properly initialized")
module Backwards_computer (Reach: Reachable_end_states) =
struct
@@ -764,7 +764,7 @@ struct
s.sid Cil_datatype.Stmt.pretty s
Data_for_aorai.pretty_state old
Data_for_aorai.pretty_state st;
- if Data_for_aorai.included_state st old then
+ if Data_for_aorai.included_state st old then
begin
Aorai_option.debug ~dkey:backward_dkey "Included";
None
@@ -780,8 +780,8 @@ struct
let doStmt s =
match s.skind with
- | Return _ -> Dataflow2.Done Reach.end_state
- | _ -> Dataflow2.Default
+ | Return _ -> Dataflow2.Done Reach.end_state
+ | _ -> Dataflow2.Default
let do_call s f state =
let kf = Globals.Functions.get f in
@@ -822,14 +822,14 @@ struct
let doInstr s instr state =
match instr with
- | Call (_,{ enode = Lval(Var f,NoOffset) },_,_) -> do_call s f state
- | Call (_,e,_,_) ->
- Aorai_option.not_yet_implemented
- ~source:(fst e.eloc)
- "Indirect call to %a is not handled yet" Printer.pp_exp e
- | Local_init (_,ConsInit(f,_,_),_) -> do_call s f state
- | Local_init (_,AssignInit _,_)
- | Set _ | Asm _ | Skip _ | Code_annot _ -> Dataflow2.Default
+ | Call (_,{ enode = Lval(Var f,NoOffset) },_,_) -> do_call s f state
+ | Call (_,e,_,_) ->
+ Aorai_option.not_yet_implemented
+ ~source:(fst e.eloc)
+ "Indirect call to %a is not handled yet" Printer.pp_exp e
+ | Local_init (_,ConsInit(f,_,_),_) -> do_call s f state
+ | Local_init (_,AssignInit _,_)
+ | Set _ | Asm _ | Skip _ | Code_annot _ -> Dataflow2.Default
let filterStmt _ _ = true
@@ -865,12 +865,12 @@ let filter_return_states kf states =
let is_possible_state start_state state _ =
try
let trans = Path_analysis.get_transitions_of_state state auto in
- let return_states =
+ let return_states =
Data_for_aorai.Aorai_state.Map.find start_state states
in
- let crossable tr =
+ let crossable tr =
Aorai_utils.isCrossable tr kf Promelaast.Return &&
- Data_for_aorai.Aorai_state.Map.mem tr.stop return_states
+ Data_for_aorai.Aorai_state.Map.mem tr.stop return_states
in
List.exists crossable trans
with Not_found -> false
@@ -884,31 +884,31 @@ let filter_return_states kf states =
else Data_for_aorai.Aorai_state.Map.add state res acc
in
let res =
- Data_for_aorai.Aorai_state.Map.fold
+ Data_for_aorai.Aorai_state.Map.fold
treat_one_state end_state Data_for_aorai.Aorai_state.Map.empty
in
if Data_for_aorai.Aorai_state.Map.is_empty res &&
- not (Data_for_aorai.Aorai_state.Map.is_empty end_state) then
+ not (Data_for_aorai.Aorai_state.Map.is_empty end_state) then
(* Do not emit warning if forward computation already decided that the
call was not conforming to the spec. *)
Aorai_option.warning ~current:true
"Call to %a not conforming to automaton (post-cond). \
- Assuming it is on a dead path"
+ Assuming it is on a dead path"
Kernel_function.pretty kf;
res
let filter_loop_init_states old_map restrict_map =
let treat_one_state state old_states acc =
try
- let restrict_states =
+ let restrict_states =
Data_for_aorai.Aorai_state.Map.find state restrict_map
in
let old_states = filter_state (set_of_map restrict_states) old_states in
if Data_for_aorai.Aorai_state.Map.is_empty old_states then acc
else Data_for_aorai.Aorai_state.Map.add state old_states acc
with Not_found -> acc (* not accessible in any case *)
- in
- Data_for_aorai.Aorai_state.Map.fold
+ in
+ Data_for_aorai.Aorai_state.Map.fold
treat_one_state old_map Data_for_aorai.Aorai_state.Map.empty
let filter_loop_invariant_states old_map restrict_map =
@@ -941,14 +941,14 @@ let filter_init_state restrict initial map acc =
let backward_analysis_aux stack kf ret_state =
if Data_for_aorai.isIgnoredFunction kf then
- Aorai_option.fatal
+ Aorai_option.fatal
"Call backward analysis on ignored function %a" Kernel_function.pretty kf
else if List.memq kf stack then begin
- (* recursive function: just attempt to filter wrt attainable current states *)
+ (* recursive function: just attempt to filter wrt attainable current states *)
let kf_post_state = filter_possible_states kf ret_state in
set_kf_return_state kf kf_post_state;
let before_state = Data_for_aorai.get_kf_init_state kf in
- let before_state =
+ let before_state =
Data_for_aorai.Aorai_state.Map.filter
(fun s _ -> Data_for_aorai.Aorai_state.Map.mem s kf_post_state)
before_state
@@ -960,12 +960,12 @@ let backward_analysis_aux stack kf ret_state =
set_kf_return_state kf kf_post_state;
let end_state = filter_return_states kf kf_post_state in
let module Computer =
- Backwards_computer
- (struct
- let stack = kf :: stack
- let kf = kf
- let end_state = end_state
- end)
+ Backwards_computer
+ (struct
+ let stack = kf :: stack
+ let kf = kf
+ let end_state = end_state
+ end)
in
let module Compute = Dataflow2.Backwards(Computer) in
let (all_stmts,sink_stmts) =
@@ -979,14 +979,14 @@ let backward_analysis_aux stack kf ret_state =
in
let before_state = Data_for_aorai.get_kf_init_state kf in
let new_state =
- Data_for_aorai.Aorai_state.Map.fold
+ Data_for_aorai.Aorai_state.Map.fold
(filter_init_state restrict_state)
before_state
Data_for_aorai.Aorai_state.Map.empty
in
- if
+ if
Data_for_aorai.Aorai_state.Map.is_empty new_state &&
- not (Data_for_aorai.Aorai_state.Map.is_empty before_state)
+ not (Data_for_aorai.Aorai_state.Map.is_empty before_state)
then begin
Aorai_option.warning ~current:true
"Call to %a not conforming to automaton (pre-cond). \
@@ -1015,12 +1015,12 @@ let backward_analysis_aux stack kf ret_state =
in
let visit = object
inherit Visitor.frama_c_inplace
- method! vstmt_aux s =
- match s.skind with
- | Loop _ -> treat_one_loop s; Cil.DoChildren
- | _ -> Cil.DoChildren
+ method! vstmt_aux s =
+ match s.skind with
+ | Loop _ -> treat_one_loop s; Cil.DoChildren
+ | _ -> Cil.DoChildren
end
- in
+ in
let visit_stmt s = ignore (Visitor.visitFramacStmt visit s) in
List.iter visit_stmt all_stmts;
before_state
@@ -1037,7 +1037,7 @@ let compute_backward () =
let accepted_states =
Data_for_aorai.Aorai_state.Map.fold
(fun _ map acc ->
- Data_for_aorai.Aorai_state.Set.union (set_of_map map) acc)
+ Data_for_aorai.Aorai_state.Set.union (set_of_map map) acc)
final_state Data_for_aorai.Aorai_state.Set.empty
in
ignore (backward_analysis_aux [] kf accepted_states);
@@ -1046,15 +1046,15 @@ let compute_backward () =
Init_loop_state.iter Data_for_aorai.replace_loop_init_state;
Invariant_loop_state.iter Data_for_aorai.replace_loop_invariant_state
-let compute () =
- compute_forward ();
+let compute () =
+ compute_forward ();
Aorai_option.debug ~dkey:forward_dkey "After forward analysis";
Data_for_aorai.debug_computed_state ();
compute_backward ();
Aorai_option.debug ~dkey:backward_dkey "After backward analysis";
Data_for_aorai.debug_computed_state ~dkey:backward_dkey();
-(*
+(*
Local Variables:
compile-command: "make -C ../../.."
End:
diff --git a/src/plugins/aorai/aorai_dataflow.mli b/src/plugins/aorai/aorai_dataflow.mli
index 458982b4d833e16c789f534d401f907565c64a9e..1d9971ec64223cb62b1a95e59d0bcb23b295c9e9 100644
--- a/src/plugins/aorai/aorai_dataflow.mli
+++ b/src/plugins/aorai/aorai_dataflow.mli
@@ -25,4 +25,3 @@
(** Compute the set of possible state at each function call and return. *)
val compute: unit -> unit
-
diff --git a/src/plugins/aorai/data_for_aorai.ml b/src/plugins/aorai/data_for_aorai.ml
index d1593994ece0a17356bb4c6b96ae88912bcf9f22..4a40b1c088a88fbc176bdef0f27857c23cea3c3a 100644
--- a/src/plugins/aorai/data_for_aorai.ml
+++ b/src/plugins/aorai/data_for_aorai.ml
@@ -33,70 +33,70 @@ exception Empty_automaton
module Aorai_state =
Datatype.Make_with_collections(
- struct
- type t = Promelaast.state
- let structural_descr = Structural_descr.t_abstract
- let reprs = [ { nums = -1; name = ""; multi_state = None;
- acceptation = Bool3.False; init = Bool3.False
- } ]
- let name = "Aorai_state"
- let equal x y = Datatype.Int.equal x.nums y.nums
- let hash x = x.nums
- let rehash = Datatype.identity
- let compare x y = Datatype.Int.compare x.nums y.nums
- let copy = Datatype.identity
- let internal_pretty_code = Datatype.undefined
- let pretty fmt x = Format.fprintf fmt "state_%d" x.nums
- let varname _ =
- assert false (* unused while internal_pretty_code is undefined *)
- let mem_project = Datatype.never_any_project
- end
+ struct
+ type t = Promelaast.state
+ let structural_descr = Structural_descr.t_abstract
+ let reprs = [ { nums = -1; name = ""; multi_state = None;
+ acceptation = Bool3.False; init = Bool3.False
+ } ]
+ let name = "Aorai_state"
+ let equal x y = Datatype.Int.equal x.nums y.nums
+ let hash x = x.nums
+ let rehash = Datatype.identity
+ let compare x y = Datatype.Int.compare x.nums y.nums
+ let copy = Datatype.identity
+ let internal_pretty_code = Datatype.undefined
+ let pretty fmt x = Format.fprintf fmt "state_%d" x.nums
+ let varname _ =
+ assert false (* unused while internal_pretty_code is undefined *)
+ let mem_project = Datatype.never_any_project
+ end
)
module Aorai_typed_trans =
Datatype.Make_with_collections(
- struct
- let name = "Aorai_typed_trans"
- type t = Promelaast.typed_trans
- let structural_descr = Structural_descr.t_abstract
- let reprs = [ { numt = -1; start = List.hd (Aorai_state.reprs);
- stop = List.hd (Aorai_state.reprs);
- cross = TTrue; actions=[]; } ]
- let equal x y = Datatype.Int.equal x.numt y.numt
- let hash x = x.numt
- let rehash = Datatype.identity
- let compare x y = Datatype.Int.compare x.numt y.numt
- let copy = Datatype.identity
- let internal_pretty_code = Datatype.undefined
- let pretty = Promelaoutput.Typed.print_transition
- let varname _ = assert false
- let mem_project = Datatype.never_any_project
- end)
+ struct
+ let name = "Aorai_typed_trans"
+ type t = Promelaast.typed_trans
+ let structural_descr = Structural_descr.t_abstract
+ let reprs = [ { numt = -1; start = List.hd (Aorai_state.reprs);
+ stop = List.hd (Aorai_state.reprs);
+ cross = TTrue; actions=[]; } ]
+ let equal x y = Datatype.Int.equal x.numt y.numt
+ let hash x = x.numt
+ let rehash = Datatype.identity
+ let compare x y = Datatype.Int.compare x.numt y.numt
+ let copy = Datatype.identity
+ let internal_pretty_code = Datatype.undefined
+ let pretty = Promelaoutput.Typed.print_transition
+ let varname _ = assert false
+ let mem_project = Datatype.never_any_project
+ end)
module Aorai_automaton =
Datatype.Make(
- struct
- include Datatype.Serializable_undefined
- let name = "Aorai_automaton"
- type t = Promelaast.typed_automaton
- let structural_descr = Structural_descr.t_abstract
- let reprs = [ { states = Aorai_state.reprs;
- trans = Aorai_typed_trans.reprs;
- metavariables = Datatype.String.Map.empty;
- observables = Some Datatype.String.Set.empty;
- }]
- end
- )
+ struct
+ include Datatype.Serializable_undefined
+ let name = "Aorai_automaton"
+ type t = Promelaast.typed_automaton
+ let structural_descr = Structural_descr.t_abstract
+ let reprs = [ { states = Aorai_state.reprs;
+ trans = Aorai_typed_trans.reprs;
+ metavariables = Datatype.String.Map.empty;
+ observables = Some Datatype.String.Set.empty;
+ }]
+ end
+ )
module State_var =
State_builder.Hashtbl
(Aorai_state.Hashtbl)
(Cil_datatype.Varinfo)
(struct
- let name = "Data_for_aorai.State_var"
- let dependencies = [ Ast.self; Aorai_option.Ya.self ]
- let size = 7
- end)
+ let name = "Data_for_aorai.State_var"
+ let dependencies = [ Ast.self; Aorai_option.Ya.self ]
+ let size = 7
+ end)
let get_state_var =
let add_var state = Cil.makeVarinfo true false state.name Cil.intType in
@@ -109,59 +109,59 @@ module Max_value_counter =
(Cil_datatype.Term.Hashtbl)
(Cil_datatype.Term)
(struct
- let name = "Data_for_aorai.Max_value_counter"
- let dependencies = [ Ast.self; Aorai_option.Ya.self ]
- let size = 7
- end)
+ let name = "Data_for_aorai.Max_value_counter"
+ let dependencies = [ Ast.self; Aorai_option.Ya.self ]
+ let size = 7
+ end)
let find_max_value t =
try Some (Max_value_counter.find t) with Not_found -> None
let raise_error msg =
- Aorai_option.fatal "Aorai plugin internal error. \nStatus : %s.\n" msg;;
+ Aorai_option.fatal "Aorai plugin internal error. \nStatus : %s.\n" msg;;
(* Format.printf "Aorai plugin internal error. \nStatus : %s.\n" msg; *)
(* assert false *)
let por t1 t2 =
match t1,t2 with
- PTrue,_ | _,PTrue -> PTrue
- | PFalse,t | t,PFalse -> t
- | _,_ -> POr(t1,t2)
+ PTrue,_ | _,PTrue -> PTrue
+ | PFalse,t | t,PFalse -> t
+ | _,_ -> POr(t1,t2)
let pand t1 t2 =
match t1,t2 with
- PTrue,t | t,PTrue -> t
- | PFalse,_ | _,PFalse -> PFalse
- | _,_ -> PAnd(t1,t2)
+ PTrue,t | t,PTrue -> t
+ | PFalse,_ | _,PFalse -> PFalse
+ | _,_ -> PAnd(t1,t2)
let pnot t =
match t with
- PTrue -> PFalse
- | PFalse -> PTrue
- | PNot t -> t
- | _ -> PNot t
+ PTrue -> PFalse
+ | PFalse -> PTrue
+ | PNot t -> t
+ | _ -> PNot t
let rec is_same_expression e1 e2 =
match e1,e2 with
- | PVar x, PVar y -> x = y
- | PVar _,_ | _,PVar _ -> false
- | PCst cst1, PCst cst2 -> Logic_utils.is_same_pconstant cst1 cst2
- | PCst _,_ | _,PCst _ -> false
- | PPrm (f1,x1), PPrm(f2,x2) -> f1 = f2 && x1 = x2
- | PPrm _,_ | _,PPrm _ -> false
- | PMetavar x, PMetavar y -> x = y
- | PMetavar _,_ | _,PMetavar _ -> false
- | PBinop(b1,l1,r1), PBinop(b2,l2,r2) ->
- b1 = b2 && is_same_expression l1 l2 && is_same_expression r1 r2
- | PBinop _, _ | _, PBinop _ -> false
- | PUnop(u1,e1), PUnop(u2,e2) -> u1 = u2 && is_same_expression e1 e2
- | PUnop _,_ | _,PUnop _ -> false
- | PArrget(a1,i1), PArrget(a2,i2) ->
- is_same_expression a1 a2 && is_same_expression i1 i2
- | PArrget _,_ | _,PArrget _ -> false
- | PField(e1,f1), PField(e2,f2) -> f1 = f2 && is_same_expression e1 e2
- | PField _,_ | _,PField _ -> false
- | PArrow(e1,f1), PArrow(e2,f2) -> f1 = f2 && is_same_expression e1 e2
+ | PVar x, PVar y -> x = y
+ | PVar _,_ | _,PVar _ -> false
+ | PCst cst1, PCst cst2 -> Logic_utils.is_same_pconstant cst1 cst2
+ | PCst _,_ | _,PCst _ -> false
+ | PPrm (f1,x1), PPrm(f2,x2) -> f1 = f2 && x1 = x2
+ | PPrm _,_ | _,PPrm _ -> false
+ | PMetavar x, PMetavar y -> x = y
+ | PMetavar _,_ | _,PMetavar _ -> false
+ | PBinop(b1,l1,r1), PBinop(b2,l2,r2) ->
+ b1 = b2 && is_same_expression l1 l2 && is_same_expression r1 r2
+ | PBinop _, _ | _, PBinop _ -> false
+ | PUnop(u1,e1), PUnop(u2,e2) -> u1 = u2 && is_same_expression e1 e2
+ | PUnop _,_ | _,PUnop _ -> false
+ | PArrget(a1,i1), PArrget(a2,i2) ->
+ is_same_expression a1 a2 && is_same_expression i1 i2
+ | PArrget _,_ | _,PArrget _ -> false
+ | PField(e1,f1), PField(e2,f2) -> f1 = f2 && is_same_expression e1 e2
+ | PField _,_ | _,PField _ -> false
+ | PArrow(e1,f1), PArrow(e2,f2) -> f1 = f2 && is_same_expression e1 e2
let declared_logics = Hashtbl.create 97
@@ -269,15 +269,15 @@ let getNumberOfStates () =
let is_c_global name =
try ignore (Globals.Vars.find_from_astinfo name VGlobal); true
with Not_found ->
- try ignore (Globals.Functions.find_by_name name); true
- with Not_found -> false
+ try ignore (Globals.Functions.find_by_name name); true
+ with Not_found -> false
let get_fresh =
let used_names = Hashtbl.create 5 in
fun name ->
if Clexer.is_c_keyword name
- || Logic_lexer.is_acsl_keyword name || is_c_global name
- || Hashtbl.mem used_names name
+ || Logic_lexer.is_acsl_keyword name || is_c_global name
+ || Hashtbl.mem used_names name
then begin
let i = ref (try Hashtbl.find used_names name with Not_found -> 0) in
let proposed_name () = name ^ "_" ^ string_of_int !i in
@@ -298,17 +298,17 @@ module AuxVariables =
let dependencies =
[ Aorai_option.Ltl_File.self; Aorai_option.Buchi.self;
Aorai_option.Ya.self; Ast.self ]
- end)
+ end)
module AbstractLogicInfo =
State_builder.List_ref
(Cil_datatype.Logic_info)
(struct
- let name = "Data_for_aorai.AbstractLogicInfo"
- let dependencies =
+ let name = "Data_for_aorai.AbstractLogicInfo"
+ let dependencies =
[ Aorai_option.Ltl_File.self; Aorai_option.Buchi.self;
Aorai_option.Ya.self; Ast.self ]
- end)
+ end)
class change_var vi1 vi2 =
object
@@ -323,12 +323,12 @@ let change_var_term vi1 vi2 t =
let update_condition vi1 vi2 cond =
let rec aux e =
match e with
- | TOr (e1,e2) -> TOr(aux e1, aux e2)
- | TAnd (e1,e2) -> TAnd(aux e1, aux e2)
- | TNot e -> TNot (aux e)
- | TCall _ | TReturn _ | TTrue | TFalse -> e
- | TRel(rel,t1,t2) ->
- TRel(rel,change_var_term vi1 vi2 t1,change_var_term vi1 vi2 t2)
+ | TOr (e1,e2) -> TOr(aux e1, aux e2)
+ | TAnd (e1,e2) -> TAnd(aux e1, aux e2)
+ | TNot e -> TNot (aux e)
+ | TCall _ | TReturn _ | TTrue | TFalse -> e
+ | TRel(rel,t1,t2) ->
+ TRel(rel,change_var_term vi1 vi2 t1,change_var_term vi1 vi2 t2)
in aux cond
let pebble_set_at li lab =
@@ -338,21 +338,21 @@ let pebble_set_at li lab =
let memo_multi_state st =
match st.multi_state with
- | None ->
- let aux = Cil.makeGlobalVar (get_fresh "aorai_aux") Cil.intType in
- let laux = Cil.cvar_to_lvar aux in
- let set = Cil_const.make_logic_info (get_fresh (st.name ^ "_pebble")) in
- let typ = Logic_const.make_set_type (Ctype Cil.intType) in
- set.l_var_info.lv_type <- typ;
- set.l_labels <- [FormalLabel "L"];
- set.l_type <- Some typ;
- set.l_body <-
- LBreads
+ | None ->
+ let aux = Cil.makeGlobalVar (get_fresh "aorai_aux") Cil.intType in
+ let laux = Cil.cvar_to_lvar aux in
+ let set = Cil_const.make_logic_info (get_fresh (st.name ^ "_pebble")) in
+ let typ = Logic_const.make_set_type (Ctype Cil.intType) in
+ set.l_var_info.lv_type <- typ;
+ set.l_labels <- [FormalLabel "L"];
+ set.l_type <- Some typ;
+ set.l_body <-
+ LBreads
[ Logic_const.new_identified_term (Logic_const.tvar laux) ];
- let multi_state = set,laux in
- st.multi_state <- Some multi_state;
- multi_state
- | Some multi_state -> multi_state
+ let multi_state = set,laux in
+ st.multi_state <- Some multi_state;
+ multi_state
+ | Some multi_state -> multi_state
let change_bound_var st1 st2 cond =
if Option.is_some st1.multi_state then begin
@@ -394,23 +394,23 @@ let check_states s =
states;
List.iter
(fun x ->
- try
- let y = List.find (fun y -> x.nums = y.nums && not (x==y)) states in
- Aorai_option.fatal "%s: State %s and %s share same id %d"
- s x.name y.name x.nums
- with Not_found -> ()
+ try
+ let y = List.find (fun y -> x.nums = y.nums && not (x==y)) states in
+ Aorai_option.fatal "%s: State %s and %s share same id %d"
+ s x.name y.name x.nums
+ with Not_found -> ()
)
states;
List.iter
(fun x ->
- if not (List.memq x.start states) then
- Aorai_option.fatal
- "%s: Start state %d of transition %d is not among known states"
- s x.start.nums x.numt;
- if not (List.memq x.stop states) then
- Aorai_option.fatal
- "%s: End state %d of transition %d is not among known states"
- s x.start.nums x.numt;)
+ if not (List.memq x.start states) then
+ Aorai_option.fatal
+ "%s: Start state %d of transition %d is not among known states"
+ s x.start.nums x.numt;
+ if not (List.memq x.stop states) then
+ Aorai_option.fatal
+ "%s: End state %d of transition %d is not among known states"
+ s x.start.nums x.numt;)
trans
let cst_one = PCst (Logic_ptree.IntConstant "1")
@@ -419,18 +419,18 @@ let cst_zero = PCst (Logic_ptree.IntConstant "0")
let is_cst_zero e =
match e with
- | PCst(IntConstant "0") -> true
- | _ -> false
+ | PCst(IntConstant "0") -> true
+ | _ -> false
let is_cst_one e =
match e with
- PCst (IntConstant "1") -> true
- | _ -> false
+ PCst (IntConstant "1") -> true
+ | _ -> false
let is_single elt =
match elt.min_rep, elt.max_rep with
- | Some min, Some max -> is_cst_one min && is_cst_one max
- | _ -> false
+ | Some min, Some max -> is_cst_one min && is_cst_one max
+ | _ -> false
(* Epsilon transitions will account for the possibility of
not entering a repeated sequence at all. They will be normalized after
@@ -442,7 +442,7 @@ type 'a eps = Normal of 'a | Epsilon of 'a
let print_eps f fmt = function
| Normal x -> f fmt x
| Epsilon x -> Format.fprintf fmt "epsilon-trans:@\n%a" f x
-
+
let print_eps_trans fmt tr =
Format.fprintf fmt "%s -> %s:@[%a%a@]"
tr.start.name tr.stop.name
@@ -452,8 +452,8 @@ let print_eps_trans fmt tr =
type current_event =
| ECall of
kernel_function
- * Cil_types.logic_var Cil_datatype.Varinfo.Hashtbl.t
- * (typed_condition eps,typed_action) Promelaast.trans
+ * Cil_types.logic_var Cil_datatype.Varinfo.Hashtbl.t
+ * (typed_condition eps,typed_action) Promelaast.trans
| EReturn of kernel_function
| ECOR of kernel_function
| ENone (* None found yet *)
@@ -464,99 +464,99 @@ type current_event =
let add_current_event event env cond =
let is_empty tbl = Cil_datatype.Varinfo.Hashtbl.length tbl = 0 in
match env with
- [] -> assert false
- | old_event :: tl ->
- match event, old_event with
- | ENone, _ -> env, cond
- | _, ENone -> event::tl, cond
- | ECall (kf1,_,_), ECall (kf2,_,_)
- when Kernel_function.equal kf1 kf2 -> env, cond
- | ECall (kf1,tbl1,_), ECall (kf2,tbl2,_)->
- (* ltl2buchi generates such inconsistent guards, but luckily does
- not speak about formals. In this case, we just return False with
- an empty event. If this situation occurs in an handwritten
- automaton that uses formals we simply reject it.
- *)
- if is_empty tbl1 && is_empty tbl2 then ENone::tl, TFalse
- else
- Aorai_option.abort
- "specification is inconsistent: two call events for distinct \
- functions %a and %a at the same time."
- Kernel_function.pretty kf1 Kernel_function.pretty kf2
- | ECall (_,_,_), EMulti -> event::tl, cond
- | ECall (kf1,tbl1,_), EReturn kf2 ->
- if is_empty tbl1 then ENone::tl, TFalse
- else
- Aorai_option.abort
- "specification is inconsistent: trying to call %a and \
- return from %a at the same time."
- Kernel_function.pretty kf1 Kernel_function.pretty kf2
- | ECall(kf1,_,_), ECOR kf2
- when Kernel_function.equal kf1 kf2 ->
- event::tl, cond
- | ECall (kf1,tbl1,_), ECOR kf2 ->
- if is_empty tbl1 then ENone::tl, TFalse
- else
- Aorai_option.abort
- "specification is inconsistent: trying to call %a and \
- call or return from %a at the same time."
- Kernel_function.pretty kf1 Kernel_function.pretty kf2
- | EReturn kf1, ECall(kf2,tbl2,_) ->
- if is_empty tbl2 then ENone::tl, TFalse
- else
- Aorai_option.abort
- "specification is inconsistent: trying to call %a and \
- return from %a at the same time."
- Kernel_function.pretty kf2 Kernel_function.pretty kf1
- | EReturn kf1, (ECOR kf2 | EReturn kf2)
- when Kernel_function.equal kf1 kf2 -> event::tl, cond
- | EReturn _, EReturn _ -> ENone::tl, TFalse
- | EReturn _, ECOR _ -> ENone::tl, TFalse
- | EReturn _, EMulti -> ENone::tl, TFalse
- | (EMulti | ECOR _), _ -> assert false
- (* These are compound event. They cannot be found as individual ones*)
+ [] -> assert false
+ | old_event :: tl ->
+ match event, old_event with
+ | ENone, _ -> env, cond
+ | _, ENone -> event::tl, cond
+ | ECall (kf1,_,_), ECall (kf2,_,_)
+ when Kernel_function.equal kf1 kf2 -> env, cond
+ | ECall (kf1,tbl1,_), ECall (kf2,tbl2,_)->
+ (* ltl2buchi generates such inconsistent guards, but luckily does
+ not speak about formals. In this case, we just return False with
+ an empty event. If this situation occurs in an handwritten
+ automaton that uses formals we simply reject it.
+ *)
+ if is_empty tbl1 && is_empty tbl2 then ENone::tl, TFalse
+ else
+ Aorai_option.abort
+ "specification is inconsistent: two call events for distinct \
+ functions %a and %a at the same time."
+ Kernel_function.pretty kf1 Kernel_function.pretty kf2
+ | ECall (_,_,_), EMulti -> event::tl, cond
+ | ECall (kf1,tbl1,_), EReturn kf2 ->
+ if is_empty tbl1 then ENone::tl, TFalse
+ else
+ Aorai_option.abort
+ "specification is inconsistent: trying to call %a and \
+ return from %a at the same time."
+ Kernel_function.pretty kf1 Kernel_function.pretty kf2
+ | ECall(kf1,_,_), ECOR kf2
+ when Kernel_function.equal kf1 kf2 ->
+ event::tl, cond
+ | ECall (kf1,tbl1,_), ECOR kf2 ->
+ if is_empty tbl1 then ENone::tl, TFalse
+ else
+ Aorai_option.abort
+ "specification is inconsistent: trying to call %a and \
+ call or return from %a at the same time."
+ Kernel_function.pretty kf1 Kernel_function.pretty kf2
+ | EReturn kf1, ECall(kf2,tbl2,_) ->
+ if is_empty tbl2 then ENone::tl, TFalse
+ else
+ Aorai_option.abort
+ "specification is inconsistent: trying to call %a and \
+ return from %a at the same time."
+ Kernel_function.pretty kf2 Kernel_function.pretty kf1
+ | EReturn kf1, (ECOR kf2 | EReturn kf2)
+ when Kernel_function.equal kf1 kf2 -> event::tl, cond
+ | EReturn _, EReturn _ -> ENone::tl, TFalse
+ | EReturn _, ECOR _ -> ENone::tl, TFalse
+ | EReturn _, EMulti -> ENone::tl, TFalse
+ | (EMulti | ECOR _), _ -> assert false
+(* These are compound event. They cannot be found as individual ones*)
let merge_current_event env1 env2 cond1 cond2 =
assert (List.tl env1 == List.tl env2);
let old_env = List.tl env2 in
match List.hd env1, List.hd env2 with
- | ENone, _ -> env2, tor cond1 cond2
- | _, ENone -> env1, tor cond1 cond2
- | ECall(kf1,_,_), ECall(kf2,_,_)
- when Kernel_function.equal kf1 kf2 -> env2, tor cond1 cond2
- | ECall _, ECall _ -> EMulti::old_env, tor cond1 cond2
- | ECall _, EMulti -> env2, tor cond1 cond2
- | ECall (kf1,_,_), ECOR kf2 when Kernel_function.equal kf1 kf2 ->
- env2, tor cond1 cond2
- | ECall (kf1,_,_), EReturn kf2 when Kernel_function.equal kf1 kf2 ->
- ECOR kf1 :: old_env, tor cond1 cond2
- | ECall _, (ECOR _ | EReturn _) -> EMulti :: old_env, tor cond1 cond2
- | EReturn kf1, ECall (kf2,_,_) when Kernel_function.equal kf1 kf2 ->
- ECOR kf1 :: old_env, tor cond1 cond2
- | EReturn _, ECall _ -> EMulti :: old_env, tor cond1 cond2
- | EReturn kf1, EReturn kf2 when Kernel_function.equal kf1 kf2 ->
- env2, tor cond1 cond2
- | EReturn _, EReturn _ -> EMulti :: old_env, tor cond1 cond2
- | EReturn _, EMulti -> env2, tor cond1 cond2
- | EReturn kf1, ECOR kf2 when Kernel_function.equal kf1 kf2 ->
- env2, tor cond1 cond2
- | EReturn _, ECOR _ ->
- EMulti :: old_env, tor cond1 cond2
- | ECOR kf1, (ECall(kf2,_,_) | EReturn kf2 | ECOR kf2)
- when Kernel_function.equal kf1 kf2 -> env1, tor cond1 cond2
- | ECOR _, (ECall _ | EReturn _ | ECOR _) ->
- EMulti :: old_env, tor cond1 cond2
- | ECOR _, EMulti -> env2, tor cond1 cond2
- | EMulti, (ECall _ | EReturn _ | ECOR _) -> env1, tor cond1 cond2
- | EMulti, EMulti -> EMulti::old_env, tor cond1 cond2
+ | ENone, _ -> env2, tor cond1 cond2
+ | _, ENone -> env1, tor cond1 cond2
+ | ECall(kf1,_,_), ECall(kf2,_,_)
+ when Kernel_function.equal kf1 kf2 -> env2, tor cond1 cond2
+ | ECall _, ECall _ -> EMulti::old_env, tor cond1 cond2
+ | ECall _, EMulti -> env2, tor cond1 cond2
+ | ECall (kf1,_,_), ECOR kf2 when Kernel_function.equal kf1 kf2 ->
+ env2, tor cond1 cond2
+ | ECall (kf1,_,_), EReturn kf2 when Kernel_function.equal kf1 kf2 ->
+ ECOR kf1 :: old_env, tor cond1 cond2
+ | ECall _, (ECOR _ | EReturn _) -> EMulti :: old_env, tor cond1 cond2
+ | EReturn kf1, ECall (kf2,_,_) when Kernel_function.equal kf1 kf2 ->
+ ECOR kf1 :: old_env, tor cond1 cond2
+ | EReturn _, ECall _ -> EMulti :: old_env, tor cond1 cond2
+ | EReturn kf1, EReturn kf2 when Kernel_function.equal kf1 kf2 ->
+ env2, tor cond1 cond2
+ | EReturn _, EReturn _ -> EMulti :: old_env, tor cond1 cond2
+ | EReturn _, EMulti -> env2, tor cond1 cond2
+ | EReturn kf1, ECOR kf2 when Kernel_function.equal kf1 kf2 ->
+ env2, tor cond1 cond2
+ | EReturn _, ECOR _ ->
+ EMulti :: old_env, tor cond1 cond2
+ | ECOR kf1, (ECall(kf2,_,_) | EReturn kf2 | ECOR kf2)
+ when Kernel_function.equal kf1 kf2 -> env1, tor cond1 cond2
+ | ECOR _, (ECall _ | EReturn _ | ECOR _) ->
+ EMulti :: old_env, tor cond1 cond2
+ | ECOR _, EMulti -> env2, tor cond1 cond2
+ | EMulti, (ECall _ | EReturn _ | ECOR _) -> env1, tor cond1 cond2
+ | EMulti, EMulti -> EMulti::old_env, tor cond1 cond2
let get_bindings st my_var =
let my_lval = TVar my_var, TNoOffset in
match st with
- None -> my_lval
- | Some st ->
- let (_,idx) = memo_multi_state st in
- Logic_const.addTermOffsetLval (TIndex (Logic_const.tvar idx,TNoOffset)) my_lval
+ None -> my_lval
+ | Some st ->
+ let (_,idx) = memo_multi_state st in
+ Logic_const.addTermOffsetLval (TIndex (Logic_const.tvar idx,TNoOffset)) my_lval
let get_bindings_term st my_var typ =
Logic_const.term (TLval (get_bindings st my_var)) typ
@@ -568,8 +568,8 @@ let memo_aux_variable tr counter used_prms vi =
with Not_found ->
let my_type =
match counter with
- | None -> vi.vtype
- | Some _ -> TArray(vi.vtype,None,{scache=Not_Computed},[])
+ | None -> vi.vtype
+ | Some _ -> TArray(vi.vtype,None,{scache=Not_Computed},[])
in
let my_var =
Cil.makeGlobalVar (get_fresh ("aorai_" ^ vi.vname)) my_type
@@ -578,33 +578,33 @@ let memo_aux_variable tr counter used_prms vi =
let my_lvar = Cil.cvar_to_lvar my_var in
Cil_datatype.Varinfo.Hashtbl.add used_prms vi my_lvar;
(match tr.cross with
- | Normal _ ->
- let st = Option.map (fun _ -> tr.stop) counter in
- let loc = get_bindings st my_lvar in
- let copy = Copy_value (loc,Logic_const.tvar (Cil.cvar_to_lvar vi)) in
- tr.actions <- copy :: tr.actions
- | Epsilon _ ->
- Aorai_option.fatal "Epsilon transition used as Call event"
+ | Normal _ ->
+ let st = Option.map (fun _ -> tr.stop) counter in
+ let loc = get_bindings st my_lvar in
+ let copy = Copy_value (loc,Logic_const.tvar (Cil.cvar_to_lvar vi)) in
+ tr.actions <- copy :: tr.actions
+ | Epsilon _ ->
+ Aorai_option.fatal "Epsilon transition used as Call event"
);
get_bindings_term counter my_lvar (Ctype vi.vtype)
let check_one top info counter s =
match info with
- | ECall (kf,used_prms,tr) ->
- (try
- let vi = Globals.Vars.find_from_astinfo s (VFormal kf) in
- if top then Some (Logic_const.tvar (Cil.cvar_to_lvar vi))
- else Some (memo_aux_variable tr counter used_prms vi)
- with Not_found -> None)
- | EReturn kf when top && ( Datatype.String.equal s "return"
- || Datatype.String.equal s "\\result") ->
- let rt = Kernel_function.get_return_type kf in
- if Cil.isVoidType rt then
- Aorai_option.abort
- "%a returns void. \\result is meaningless in this context"
- Kernel_function.pretty kf;
- Some (Logic_const.term (TLval (TResult rt,TNoOffset)) (Ctype rt))
- | ECOR _ | EReturn _ | EMulti | ENone -> None
+ | ECall (kf,used_prms,tr) ->
+ (try
+ let vi = Globals.Vars.find_from_astinfo s (VFormal kf) in
+ if top then Some (Logic_const.tvar (Cil.cvar_to_lvar vi))
+ else Some (memo_aux_variable tr counter used_prms vi)
+ with Not_found -> None)
+ | EReturn kf when top && ( Datatype.String.equal s "return"
+ || Datatype.String.equal s "\\result") ->
+ let rt = Kernel_function.get_return_type kf in
+ if Cil.isVoidType rt then
+ Aorai_option.abort
+ "%a returns void. \\result is meaningless in this context"
+ Kernel_function.pretty kf;
+ Some (Logic_const.term (TLval (TResult rt,TNoOffset)) (Ctype rt))
+ | ECOR _ | EReturn _ | EMulti | ENone -> None
let find_metavar s metaenv =
@@ -616,25 +616,25 @@ let find_metavar s metaenv =
let find_in_env env counter s =
let current, stack =
match env with
- | current::stack -> current, stack
- | [] -> Aorai_option.fatal "Empty type-checking environment"
+ | current::stack -> current, stack
+ | [] -> Aorai_option.fatal "Empty type-checking environment"
in
match check_one true current counter s with
- Some lv -> lv
- | None ->
- let module M = struct exception Found of term end in
- (try
- List.iter
- (fun x ->
- match check_one false x counter s with
- None -> ()
- | Some lv -> raise (M.Found lv))
- stack;
- let vi = Globals.Vars.find_from_astinfo s VGlobal in
- Logic_const.tvar (Cil.cvar_to_lvar vi)
- with
- M.Found lv -> lv
- | Not_found -> Aorai_option.abort "Unknown variable %s" s)
+ Some lv -> lv
+ | None ->
+ let module M = struct exception Found of term end in
+ (try
+ List.iter
+ (fun x ->
+ match check_one false x counter s with
+ None -> ()
+ | Some lv -> raise (M.Found lv))
+ stack;
+ let vi = Globals.Vars.find_from_astinfo s VGlobal in
+ Logic_const.tvar (Cil.cvar_to_lvar vi)
+ with
+ M.Found lv -> lv
+ | Not_found -> Aorai_option.abort "Unknown variable %s" s)
let find_prm_in_env env ?tr counter f x =
let kf =
@@ -642,7 +642,7 @@ let find_prm_in_env env ?tr counter f x =
with Not_found -> Aorai_option.abort "Unknown function %s" f
in
if Datatype.String.equal x "return" ||
- Datatype.String.equal x "\\result" then begin
+ Datatype.String.equal x "\\result" then begin
(* Return event *)
let rt = Kernel_function.get_return_type kf in
if Cil.isVoidType rt then
@@ -656,38 +656,38 @@ let find_prm_in_env env ?tr counter f x =
end else begin (* Complete Call followed by Return event *)
let rec treat_env top =
function
- | ECall(kf',_,_) as event :: _
- when Kernel_function.equal kf kf'->
- (match check_one top event counter x with
- Some lv ->
- env, lv, TTrue
- | None ->
- Aorai_option.abort "Function %s has no parameter %s" f x)
- | (ENone | EReturn _ | EMulti | ECOR _ | ECall _ )
- :: tl ->
- treat_env false tl
- | [] ->
- let env, cond =
- match tr with
- None ->
- Aorai_option.abort
- "Function %s is not in the call stack. \
- Cannot use its parameter %s here" f x
- | Some tr ->
- add_current_event
- (ECall (kf, Cil_datatype.Varinfo.Hashtbl.create 3, tr))
- env
- (TCall (kf,None))
- in
- let vi =
- try Globals.Vars.find_from_astinfo x (VFormal kf)
- with Not_found ->
- Aorai_option.abort "Function %s has no parameter %s" f x
- in
- (* By definition, we are at the call event: no need to store
- it in an aux variable or array here.
- *)
- env, Logic_const.tvar (Cil.cvar_to_lvar vi), cond
+ | ECall(kf',_,_) as event :: _
+ when Kernel_function.equal kf kf'->
+ (match check_one top event counter x with
+ Some lv ->
+ env, lv, TTrue
+ | None ->
+ Aorai_option.abort "Function %s has no parameter %s" f x)
+ | (ENone | EReturn _ | EMulti | ECOR _ | ECall _ )
+ :: tl ->
+ treat_env false tl
+ | [] ->
+ let env, cond =
+ match tr with
+ None ->
+ Aorai_option.abort
+ "Function %s is not in the call stack. \
+ Cannot use its parameter %s here" f x
+ | Some tr ->
+ add_current_event
+ (ECall (kf, Cil_datatype.Varinfo.Hashtbl.create 3, tr))
+ env
+ (TCall (kf,None))
+ in
+ let vi =
+ try Globals.Vars.find_from_astinfo x (VFormal kf)
+ with Not_found ->
+ Aorai_option.abort "Function %s has no parameter %s" f x
+ in
+ (* By definition, we are at the call event: no need to store
+ it in an aux variable or array here.
+ *)
+ env, Logic_const.tvar (Cil.cvar_to_lvar vi), cond
in treat_env true env
end
@@ -731,188 +731,188 @@ let type_expr metaenv env ?tr ?current e =
let loc = Cil_datatype.Location.unknown in
let rec aux env cond e =
match e with
- | PVar s ->
- let var = find_in_env env current s in
- env, var, cond
- | PPrm(f,x) -> find_prm_in_env env ?tr current f x
- | PMetavar s ->
- let var = Logic_const.tvar (Cil.cvar_to_lvar (find_metavar s metaenv)) in
- env, var, cond
- | PCst (Logic_ptree.IntConstant s) ->
- let e = Cil.parseIntLogic ~loc s in
- env, e, cond
- | PCst (Logic_ptree.FloatConstant str) ->
- env, Logic_utils.parse_float ~loc str, cond
- | PCst (Logic_ptree.StringConstant s) ->
- let t =
- Logic_const.term
- (TConst(LStr (Logic_typing.unescape s))) (Ctype Cil.charPtrType)
- in
- env,t,cond
- | PCst (Logic_ptree.WStringConstant s) ->
- let t =
+ | PVar s ->
+ let var = find_in_env env current s in
+ env, var, cond
+ | PPrm(f,x) -> find_prm_in_env env ?tr current f x
+ | PMetavar s ->
+ let var = Logic_const.tvar (Cil.cvar_to_lvar (find_metavar s metaenv)) in
+ env, var, cond
+ | PCst (Logic_ptree.IntConstant s) ->
+ let e = Cil.parseIntLogic ~loc s in
+ env, e, cond
+ | PCst (Logic_ptree.FloatConstant str) ->
+ env, Logic_utils.parse_float ~loc str, cond
+ | PCst (Logic_ptree.StringConstant s) ->
+ let t =
+ Logic_const.term
+ (TConst(LStr (Logic_typing.unescape s))) (Ctype Cil.charPtrType)
+ in
+ env,t,cond
+ | PCst (Logic_ptree.WStringConstant s) ->
+ let t =
+ Logic_const.term
+ (TConst (LWStr (Logic_typing.wcharlist_of_string s)))
+ (Ctype (TPtr(Cil.theMachine.wcharType,[])))
+ in env,t,cond
+ | PBinop(bop,e1,e2) ->
+ let op = Logic_typing.type_binop bop in
+ let env,e1,cond = aux env cond e1 in
+ let env,e2,cond = aux env cond e2 in
+ let t1 = e1.term_type in
+ let t2 = e2.term_type in
+ let t =
+ if Logic_typing.is_arithmetic_type t1
+ && Logic_typing.is_arithmetic_type t2
+ then
+ let t = Logic_typing.arithmetic_conversion t1 t2 in
Logic_const.term
- (TConst (LWStr (Logic_typing.wcharlist_of_string s)))
- (Ctype (TPtr(Cil.theMachine.wcharType,[])))
- in env,t,cond
- | PBinop(bop,e1,e2) ->
- let op = Logic_typing.type_binop bop in
- let env,e1,cond = aux env cond e1 in
- let env,e2,cond = aux env cond e2 in
- let t1 = e1.term_type in
- let t2 = e2.term_type in
- let t =
- if Logic_typing.is_arithmetic_type t1
- && Logic_typing.is_arithmetic_type t2
- then
- let t = Logic_typing.arithmetic_conversion t1 t2 in
- Logic_const.term
- (TBinOp (op,LTyping.mk_cast e1 t,LTyping.mk_cast e2 t))
- t
- else
- (match bop with
- | Logic_ptree.Badd
- when
- Logic_typing.is_integral_type t2
- && Logic_utils.isLogicPointerType t1 ->
- Logic_const.term (TBinOp (PlusPI,e1,e2)) t1
- | Logic_ptree.Bsub
- when
- Logic_typing.is_integral_type t2
- && Logic_utils.isLogicPointerType t1 ->
- Logic_const.term (TBinOp (MinusPI,e1,e2)) t1
- | Logic_ptree.Badd
- when
- Logic_typing.is_integral_type t1
- && Logic_utils.isLogicPointerType t2 ->
- Logic_const.term (TBinOp (PlusPI,e2,e1)) t2
- | Logic_ptree.Bsub
- when
- Logic_typing.is_integral_type t1
- && Logic_utils.isLogicPointerType t2 ->
- Logic_const.term (TBinOp (MinusPI,e2,e1)) t2
- | Logic_ptree.Bsub
- when
- Logic_utils.isLogicPointerType t1
- && Logic_utils.isLogicPointerType t2 ->
- Logic_const.term
- (TBinOp (MinusPP,e1,LTyping.mk_cast e2 t1))
- Linteger
- | _ ->
- Aorai_option.abort
- "Invalid operands for binary operator %a: \
- unexpected %a and %a"
- Printer.pp_binop op
- Printer.pp_term e1
- Printer.pp_term e2)
- in
- env, t, cond
- | PUnop(Logic_ptree.Uminus,e) ->
- let env,t,cond = aux env cond e in
- if Logic_typing.is_arithmetic_type t.term_type then
- env,Logic_const.term (TUnOp (Neg,t)) Linteger,cond
- else Aorai_option.abort
+ (TBinOp (op,LTyping.mk_cast e1 t,LTyping.mk_cast e2 t))
+ t
+ else
+ (match bop with
+ | Logic_ptree.Badd
+ when
+ Logic_typing.is_integral_type t2
+ && Logic_utils.isLogicPointerType t1 ->
+ Logic_const.term (TBinOp (PlusPI,e1,e2)) t1
+ | Logic_ptree.Bsub
+ when
+ Logic_typing.is_integral_type t2
+ && Logic_utils.isLogicPointerType t1 ->
+ Logic_const.term (TBinOp (MinusPI,e1,e2)) t1
+ | Logic_ptree.Badd
+ when
+ Logic_typing.is_integral_type t1
+ && Logic_utils.isLogicPointerType t2 ->
+ Logic_const.term (TBinOp (PlusPI,e2,e1)) t2
+ | Logic_ptree.Bsub
+ when
+ Logic_typing.is_integral_type t1
+ && Logic_utils.isLogicPointerType t2 ->
+ Logic_const.term (TBinOp (MinusPI,e2,e1)) t2
+ | Logic_ptree.Bsub
+ when
+ Logic_utils.isLogicPointerType t1
+ && Logic_utils.isLogicPointerType t2 ->
+ Logic_const.term
+ (TBinOp (MinusPP,e1,LTyping.mk_cast e2 t1))
+ Linteger
+ | _ ->
+ Aorai_option.abort
+ "Invalid operands for binary operator %a: \
+ unexpected %a and %a"
+ Printer.pp_binop op
+ Printer.pp_term e1
+ Printer.pp_term e2)
+ in
+ env, t, cond
+ | PUnop(Logic_ptree.Uminus,e) ->
+ let env,t,cond = aux env cond e in
+ if Logic_typing.is_arithmetic_type t.term_type then
+ env,Logic_const.term (TUnOp (Neg,t)) Linteger,cond
+ else Aorai_option.abort
"Invalid operand for unary -: unexpected %a" Printer.pp_term t
- | PUnop(Logic_ptree.Ubw_not,e) ->
- let env,t,cond = aux env cond e in
- if Logic_typing.is_arithmetic_type t.term_type then
- env,Logic_const.term (TUnOp (BNot,t)) Linteger,cond
- else Aorai_option.abort
+ | PUnop(Logic_ptree.Ubw_not,e) ->
+ let env,t,cond = aux env cond e in
+ if Logic_typing.is_arithmetic_type t.term_type then
+ env,Logic_const.term (TUnOp (BNot,t)) Linteger,cond
+ else Aorai_option.abort
"Invalid operand for bitwise not: unexpected %a" Printer.pp_term t
- | PUnop(Logic_ptree.Uamp,e) ->
- let env, t, cond = aux env cond e in
- let ptr =
- try Ctype (TPtr (Logic_utils.logicCType t.term_type,[]))
- with Failure _ ->
- Aorai_option.abort "Cannot take address: not a C type(%a): %a"
- Printer.pp_logic_type t.term_type Printer.pp_term t
- in
- (match t.term_node with
- | TLval v | TStartOf v -> env, Logic_const.taddrof v ptr, cond
- | _ ->
- Aorai_option.abort "Cannot take address: not an lvalue %a"
- Printer.pp_term t
- )
- | PUnop (Logic_ptree.Ustar,e) ->
- let env, t, cond = aux env cond e in
- if Logic_utils.isLogicPointerType t.term_type then
- env,
+ | PUnop(Logic_ptree.Uamp,e) ->
+ let env, t, cond = aux env cond e in
+ let ptr =
+ try Ctype (TPtr (Logic_utils.logicCType t.term_type,[]))
+ with Failure _ ->
+ Aorai_option.abort "Cannot take address: not a C type(%a): %a"
+ Printer.pp_logic_type t.term_type Printer.pp_term t
+ in
+ (match t.term_node with
+ | TLval v | TStartOf v -> env, Logic_const.taddrof v ptr, cond
+ | _ ->
+ Aorai_option.abort "Cannot take address: not an lvalue %a"
+ Printer.pp_term t
+ )
+ | PUnop (Logic_ptree.Ustar,e) ->
+ let env, t, cond = aux env cond e in
+ if Logic_utils.isLogicPointerType t.term_type then
+ env,
+ Logic_const.term
+ (TLval (TMem t, TNoOffset))
+ (Logic_typing.type_of_pointed t.term_type),
+ cond
+ else
+ Aorai_option.abort "Cannot dereference term %a" Printer.pp_term t
+ | PArrget(e1,e2) ->
+ let env, t1, cond = aux env cond e1 in
+ let env, t2, cond = aux env cond e2 in
+ let t =
+ if Logic_utils.isLogicPointerType t1.term_type
+ && Logic_typing.is_integral_type t2.term_type
+ then
+ Logic_const.term
+ (TBinOp (IndexPI,t1,t2))
+ (Logic_typing.type_of_pointed t1.term_type)
+ else if Logic_utils.isLogicPointerType t2.term_type
+ && Logic_typing.is_integral_type t1.term_type
+ then
Logic_const.term
- (TLval (TMem t, TNoOffset))
- (Logic_typing.type_of_pointed t.term_type),
- cond
+ (TBinOp (IndexPI,t2,t1))
+ (Logic_typing.type_of_pointed t2.term_type)
+ else if Logic_utils.isLogicArrayType t1.term_type
+ && Logic_typing.is_integral_type t2.term_type
+ then
+ (match t1.term_node with
+ | TStartOf lv | TLval lv ->
+ Logic_const.term
+ (TLval
+ (Logic_const.addTermOffsetLval
+ (TIndex (t2, TNoOffset)) lv))
+ (Logic_typing.type_of_array_elem t1.term_type)
+ | _ ->
+ Aorai_option.fatal
+ "Unsupported operation: %a[%a]"
+ Printer.pp_term t1 Printer.pp_term t2)
+ else if Logic_utils.isLogicArrayType t2.term_type
+ && Logic_typing.is_integral_type t1.term_type
+ then
+ (match t2.term_node with
+ | TStartOf lv | TLval lv ->
+ Logic_const.term
+ (TLval
+ (Logic_const.addTermOffsetLval (TIndex (t1, TNoOffset)) lv))
+ (Logic_typing.type_of_array_elem t2.term_type)
+ | _ ->
+ Aorai_option.fatal
+ "Unsupported operation: %a[%a]"
+ Printer.pp_term t1 Printer.pp_term t2)
else
- Aorai_option.abort "Cannot dereference term %a" Printer.pp_term t
- | PArrget(e1,e2) ->
- let env, t1, cond = aux env cond e1 in
- let env, t2, cond = aux env cond e2 in
- let t =
- if Logic_utils.isLogicPointerType t1.term_type
- && Logic_typing.is_integral_type t2.term_type
- then
- Logic_const.term
- (TBinOp (IndexPI,t1,t2))
- (Logic_typing.type_of_pointed t1.term_type)
- else if Logic_utils.isLogicPointerType t2.term_type
- && Logic_typing.is_integral_type t1.term_type
- then
- Logic_const.term
- (TBinOp (IndexPI,t2,t1))
- (Logic_typing.type_of_pointed t2.term_type)
- else if Logic_utils.isLogicArrayType t1.term_type
- && Logic_typing.is_integral_type t2.term_type
- then
- (match t1.term_node with
- | TStartOf lv | TLval lv ->
- Logic_const.term
- (TLval
- (Logic_const.addTermOffsetLval
- (TIndex (t2, TNoOffset)) lv))
- (Logic_typing.type_of_array_elem t1.term_type)
- | _ ->
- Aorai_option.fatal
- "Unsupported operation: %a[%a]"
- Printer.pp_term t1 Printer.pp_term t2)
- else if Logic_utils.isLogicArrayType t2.term_type
- && Logic_typing.is_integral_type t1.term_type
- then
- (match t2.term_node with
- | TStartOf lv | TLval lv ->
- Logic_const.term
- (TLval
- (Logic_const.addTermOffsetLval (TIndex (t1, TNoOffset)) lv))
- (Logic_typing.type_of_array_elem t2.term_type)
- | _ ->
- Aorai_option.fatal
- "Unsupported operation: %a[%a]"
- Printer.pp_term t1 Printer.pp_term t2)
- else
- Aorai_option.abort
- "Subscripted value is neither array nor pointer: %a[%a]"
- Printer.pp_term t1 Printer.pp_term t2
+ Aorai_option.abort
+ "Subscripted value is neither array nor pointer: %a[%a]"
+ Printer.pp_term t1 Printer.pp_term t2
+ in
+ env, t, cond
+ | PField(e,s) ->
+ let env, t, cond = aux env cond e in
+ (match t.term_node with
+ | TLval lv ->
+ let off, ty = LTyping.type_of_field loc s t.term_type in
+ let lv = Logic_const.addTermOffsetLval off lv in
+ env, Logic_const.term (TLval lv) ty, cond
+ | _ ->
+ Aorai_option.fatal
+ "Unsupported operation: %a.%s" Printer.pp_term t s)
+ | PArrow(e,s) ->
+ let env, t, cond = aux env cond e in
+ if Logic_utils.isLogicPointerType t.term_type then begin
+ let off, ty =
+ LTyping.type_of_field loc s
+ (Logic_typing.type_of_pointed t.term_type)
in
- env, t, cond
- | PField(e,s) ->
- let env, t, cond = aux env cond e in
- (match t.term_node with
- | TLval lv ->
- let off, ty = LTyping.type_of_field loc s t.term_type in
- let lv = Logic_const.addTermOffsetLval off lv in
- env, Logic_const.term (TLval lv) ty, cond
- | _ ->
- Aorai_option.fatal
- "Unsupported operation: %a.%s" Printer.pp_term t s)
- | PArrow(e,s) ->
- let env, t, cond = aux env cond e in
- if Logic_utils.isLogicPointerType t.term_type then begin
- let off, ty =
- LTyping.type_of_field loc s
- (Logic_typing.type_of_pointed t.term_type)
- in
- let lv = Logic_const.addTermOffsetLval off (TMem t,TNoOffset) in
- env, Logic_const.term (TLval lv) ty, cond
- end else
- Aorai_option.abort "base term is not a pointer in %a -> %s"
+ let lv = Logic_const.addTermOffsetLval off (TMem t,TNoOffset) in
+ env, Logic_const.term (TLval lv) ty, cond
+ end else
+ Aorai_option.abort "base term is not a pointer in %a -> %s"
Printer.pp_term t s
in
aux env TTrue e
@@ -921,72 +921,72 @@ let type_cond needs_pebble metaenv env tr cond =
let current = if needs_pebble then Some tr.stop else None in
let rec aux pos env =
function
- | PRel(rel,e1,e2) ->
- let env, e1, c1 = type_expr metaenv env ~tr ?current e1 in
- let env, e2, c2 = type_expr metaenv env ~tr ?current e2 in
- let call_cond = if pos then tand c1 c2 else tor (tnot c1) (tnot c2) in
- let rel = TRel(Logic_typing.type_rel rel,e1,e2) in
- let cond = if pos then tand call_cond rel else tor call_cond rel in
- env, cond
- | PTrue -> env, TTrue
- | PFalse -> env, TFalse
- | POr(c1,c2) ->
- let env1, c1 = aux pos env c1 in
- let env2, c2 = aux pos env c2 in
- let env, c = merge_current_event env1 env2 c1 c2 in
- env, c
- | PAnd(c1,c2) ->
- let env, c1 = aux pos env c1 in
- let env, c2 = aux pos env c2 in
- env, TAnd (c1,c2)
- | PNot c ->
- let env, c = aux (not pos) env c in
- env, TNot c
- | PCall (s,b) ->
- let kf =
- try Globals.Functions.find_by_name s
- with Not_found -> Aorai_option.abort "No such function: %s" s
- in
- let b =
- Option.map
- (fun b ->
- let bhvs = Annotations.behaviors ~populate:false kf in
- try List.find (fun x -> x.b_name = b) bhvs
- with Not_found ->
- Aorai_option.abort "Function %a has no behavior named %s"
- Kernel_function.pretty kf b)
- b
- in
- if pos then
- let env, c = add_current_event
+ | PRel(rel,e1,e2) ->
+ let env, e1, c1 = type_expr metaenv env ~tr ?current e1 in
+ let env, e2, c2 = type_expr metaenv env ~tr ?current e2 in
+ let call_cond = if pos then tand c1 c2 else tor (tnot c1) (tnot c2) in
+ let rel = TRel(Logic_typing.type_rel rel,e1,e2) in
+ let cond = if pos then tand call_cond rel else tor call_cond rel in
+ env, cond
+ | PTrue -> env, TTrue
+ | PFalse -> env, TFalse
+ | POr(c1,c2) ->
+ let env1, c1 = aux pos env c1 in
+ let env2, c2 = aux pos env c2 in
+ let env, c = merge_current_event env1 env2 c1 c2 in
+ env, c
+ | PAnd(c1,c2) ->
+ let env, c1 = aux pos env c1 in
+ let env, c2 = aux pos env c2 in
+ env, TAnd (c1,c2)
+ | PNot c ->
+ let env, c = aux (not pos) env c in
+ env, TNot c
+ | PCall (s,b) ->
+ let kf =
+ try Globals.Functions.find_by_name s
+ with Not_found -> Aorai_option.abort "No such function: %s" s
+ in
+ let b =
+ Option.map
+ (fun b ->
+ let bhvs = Annotations.behaviors ~populate:false kf in
+ try List.find (fun x -> x.b_name = b) bhvs
+ with Not_found ->
+ Aorai_option.abort "Function %a has no behavior named %s"
+ Kernel_function.pretty kf b)
+ b
+ in
+ if pos then
+ let env, c = add_current_event
(ECall (kf, Cil_datatype.Varinfo.Hashtbl.create 3, tr)) env
(TCall (kf,b))
- in
- env, c
- else
- env, TCall (kf,b)
- | PReturn s ->
- let kf =
- try
- Globals.Functions.find_by_name s
- with Not_found -> Aorai_option.abort "No such function %s" s
in
- if pos then
- let env,c = add_current_event (EReturn kf) env (TReturn kf) in
- env, c
- else
- env, TReturn kf
+ env, c
+ else
+ env, TCall (kf,b)
+ | PReturn s ->
+ let kf =
+ try
+ Globals.Functions.find_by_name s
+ with Not_found -> Aorai_option.abort "No such function %s" s
+ in
+ if pos then
+ let env,c = add_current_event (EReturn kf) env (TReturn kf) in
+ env, c
+ else
+ env, TReturn kf
in
aux true (ENone::env) cond
module Reject_state =
State_builder.Option_ref(Aorai_state)
(struct
- let name = "Data_for_aorai.Reject_state"
- let dependencies =
- [ Aorai_option.Ltl_File.self; Aorai_option.Buchi.self;
- Aorai_option.Ya.self]
- end)
+ let name = "Data_for_aorai.Reject_state"
+ let dependencies =
+ [ Aorai_option.Ltl_File.self; Aorai_option.Buchi.self;
+ Aorai_option.Ya.self]
+ end)
let get_reject_state () =
let create () = new_state "aorai_reject" in
@@ -994,8 +994,8 @@ let get_reject_state () =
let is_reject_state state =
match Reject_state.get_option () with
- None -> false
- | Some state' -> Aorai_state.equal state state'
+ None -> false
+ | Some state' -> Aorai_state.equal state state'
let has_reject_state () =
match Reject_state.get_option () with None -> false | Some _ -> true
@@ -1008,313 +1008,313 @@ let add_if_needed states st =
let rec type_seq default_state tr metaenv env needs_pebble curr_start curr_end seq =
let loc = Cil_datatype.Location.unknown in
match seq with
- | [] -> (* We identify start and end. *)
- (env, [], [], curr_end, curr_end)
- | elt :: seq ->
- let is_single_trans =
- match elt.min_rep, elt.max_rep with
- | Some min, Some max -> is_cst_one min && is_cst_one max
- | None, _ | _, None -> false
- in
- let is_opt =
- match elt.min_rep with
- | Some min -> is_cst_zero min
- | None-> true
- in
- let might_be_zero =
- is_opt ||
- (match Option.get elt.min_rep with PCst _ -> false | _ -> true)
- in
- let at_most_one =
- is_opt &&
- match elt.max_rep with
- | None -> false
- | Some max -> is_cst_one max
- in
- let has_loop = not at_most_one && not is_single_trans in
- let needs_counter =
- match elt.min_rep, elt.max_rep with
- | None, None -> false
- | Some min, None -> not (is_cst_zero min || is_cst_one min)
- | None, Some max -> not (is_cst_one max)
- | Some min, Some max ->
- not (is_cst_zero min || is_cst_one min) || not (is_cst_one max)
- in
- let fixed_number_of_loop =
- match elt.min_rep, elt.max_rep with
- | _, None -> false
- | None, Some max -> not (is_cst_zero max)
- | Some min, Some max -> is_same_expression min max
- in
- let my_end =
- match seq with
- [] when not (curr_end.nums = tr.stop.nums)
- || is_single_trans || at_most_one -> curr_end
+ | [] -> (* We identify start and end. *)
+ (env, [], [], curr_end, curr_end)
+ | elt :: seq ->
+ let is_single_trans =
+ match elt.min_rep, elt.max_rep with
+ | Some min, Some max -> is_cst_one min && is_cst_one max
+ | None, _ | _, None -> false
+ in
+ let is_opt =
+ match elt.min_rep with
+ | Some min -> is_cst_zero min
+ | None-> true
+ in
+ let might_be_zero =
+ is_opt ||
+ (match Option.get elt.min_rep with PCst _ -> false | _ -> true)
+ in
+ let at_most_one =
+ is_opt &&
+ match elt.max_rep with
+ | None -> false
+ | Some max -> is_cst_one max
+ in
+ let has_loop = not at_most_one && not is_single_trans in
+ let needs_counter =
+ match elt.min_rep, elt.max_rep with
+ | None, None -> false
+ | Some min, None -> not (is_cst_zero min || is_cst_one min)
+ | None, Some max -> not (is_cst_one max)
+ | Some min, Some max ->
+ not (is_cst_zero min || is_cst_one min) || not (is_cst_one max)
+ in
+ let fixed_number_of_loop =
+ match elt.min_rep, elt.max_rep with
+ | _, None -> false
+ | None, Some max -> not (is_cst_zero max)
+ | Some min, Some max -> is_same_expression min max
+ in
+ let my_end =
+ match seq with
+ [] when not (curr_end.nums = tr.stop.nums)
+ || is_single_trans || at_most_one -> curr_end
+ | _ -> new_intermediate_state ()
+ in
+ Aorai_option.debug "Examining single elt:@\n%s -> %s:@[%a@]"
+ curr_start.name my_end.name Promelaoutput.Parsed.print_seq_elt elt;
+ let guard_exit_loop env current counter =
+ if is_opt then TTrue
+ else
+ let e = Option.get elt.min_rep in
+ let _,e,_ = type_expr metaenv env ?current e in
+ (* If we have done at least the lower bound of cycles, we can exit
+ the loop. *)
+ TRel(Cil_types.Rle,e,counter)
+ in
+ let guard_loop env current counter =
+ match elt.max_rep with
+ | None ->
+ (* We're using an int: adds an (somewhat artificial) requirements
+ that the counter itself does not overflow...
+ *)
+ let i = Cil.max_signed_number (Cil.bitsSizeOf Cil.intType) in
+ let e = Logic_const.tint ~loc i in
+ TRel(Cil_types.Rlt, counter, e)
+ | Some e ->
+ let _,e,_ = type_expr metaenv env ?current e in
+ Max_value_counter.replace counter e;
+ (* The counter is incremented after the test: it
+ must be strictly less than the upper bound to enter
+ a new cycle.
+ *)
+ TRel(Cil_types.Rlt, counter, e)
+ in
+ let env,inner_states, inner_trans, inner_start, inner_end =
+ match elt.condition with
+ | None ->
+ assert (elt.nested <> []);
+ (* we don't have a completely empty condition. *)
+ type_seq
+ default_state tr metaenv env needs_pebble curr_start my_end elt.nested
+ | Some cond ->
+ let seq_start =
+ match elt.nested with
+ [] -> my_end
| _ -> new_intermediate_state ()
- in
- Aorai_option.debug "Examining single elt:@\n%s -> %s:@[%a@]"
- curr_start.name my_end.name Promelaoutput.Parsed.print_seq_elt elt;
- let guard_exit_loop env current counter =
- if is_opt then TTrue
- else
- let e = Option.get elt.min_rep in
- let _,e,_ = type_expr metaenv env ?current e in
- (* If we have done at least the lower bound of cycles, we can exit
- the loop. *)
- TRel(Cil_types.Rle,e,counter)
- in
- let guard_loop env current counter =
- match elt.max_rep with
- | None ->
- (* We're using an int: adds an (somewhat artificial) requirements
- that the counter itself does not overflow...
- *)
- let i = Cil.max_signed_number (Cil.bitsSizeOf Cil.intType) in
- let e = Logic_const.tint ~loc i in
- TRel(Cil_types.Rlt, counter, e)
- | Some e ->
- let _,e,_ = type_expr metaenv env ?current e in
- Max_value_counter.replace counter e;
- (* The counter is incremented after the test: it
- must be strictly less than the upper bound to enter
- a new cycle.
- *)
- TRel(Cil_types.Rlt, counter, e)
- in
- let env,inner_states, inner_trans, inner_start, inner_end =
- match elt.condition with
- | None ->
- assert (elt.nested <> []);
- (* we don't have a completely empty condition. *)
- type_seq
- default_state tr metaenv env needs_pebble curr_start my_end elt.nested
- | Some cond ->
- let seq_start =
- match elt.nested with
- [] -> my_end
- | _ -> new_intermediate_state ()
- in
- let trans_start = new_trans curr_start seq_start (Normal TTrue) []
- in
- let inner_env, cond =
- type_cond needs_pebble metaenv env trans_start cond
- in
- let (env,states, seq_transitions, seq_end) =
- match elt.nested with
- | [] -> inner_env, [], [], my_end
- | _ ->
- let intermediate = new_intermediate_state () in
- let (env, states, transitions, _, seq_end) =
- type_seq
- default_state tr metaenv
- inner_env needs_pebble seq_start intermediate elt.nested
- in env, states, transitions, seq_end
- in
- let states = add_if_needed states curr_start in
- let transitions = trans_start :: seq_transitions in
- (match trans_start.cross with
- | Normal conds ->
- trans_start.cross <- Normal (tand cond conds)
- | Epsilon _ ->
- Aorai_option.fatal
- "Transition guard translated as epsilon transition");
- let states = add_if_needed states seq_start in
- (match env with
- | [] | (ENone | ECall _) :: _ ->
- (env, states, transitions, curr_start, seq_end)
- | EReturn kf1 :: ECall (kf2,_,_) :: tl
- when Kernel_function.equal kf1 kf2 ->
- tl, states, transitions, curr_start, seq_end
- | (EReturn _ | ECOR _ ) :: _ ->
- (* If there is as mismatch (e.g. Call f; Return g), it will
- be caught later. There are legitimate situations for
- this pattern however (if the sequence itself occurs
- in a non-empty context in particular)
- *)
- (env, states, transitions, curr_start, seq_end)
- | EMulti :: env_tmp ->
- env_tmp, states, transitions, curr_start, seq_end)
- in
- let loop_end = if has_loop then new_intermediate_state () else inner_end
- in
- let (_,oth_states,oth_trans,oth_start,_) =
- type_seq default_state tr metaenv env needs_pebble loop_end curr_end seq
- in
- let trans = inner_trans @ oth_trans in
- let states = List.fold_left add_if_needed oth_states inner_states in
- let auto = (inner_states,inner_trans) in
- if at_most_one then begin
- (* Just adds an epsilon transition from start to end *)
- let opt = new_trans curr_start oth_start (Epsilon TTrue) [] in
- env, states, opt::trans, curr_start, curr_end
- end
- else if has_loop then begin
- (* TODO: makes it an integer *)
- let counter =
- let ty = if needs_pebble then
- Cil_types.TArray (Cil.intType,None,{scache=Not_Computed},[])
- else Cil.intType
- in (* We won't always need a counter *)
- lazy (
- let vi = Cil.makeGlobalVar (get_fresh "aorai_counter") ty in
- add_aux_variable vi;
- vi
- )
in
- let make_counter st =
- let vi = Lazy.force counter in
- let base = TVar (Cil.cvar_to_lvar vi), TNoOffset in
- if needs_pebble then
- let (_,idx) = memo_multi_state st in
- Logic_const.addTermOffsetLval
- (TIndex (Logic_const.tvar idx,TNoOffset)) base
- else base
+ let trans_start = new_trans curr_start seq_start (Normal TTrue) []
in
- let make_counter_term st =
- Logic_const.term (TLval (make_counter st)) (Ctype Cil.intType)
+ let inner_env, cond =
+ type_cond needs_pebble metaenv env trans_start cond
in
- Aorai_option.debug "Inner start is %s; Inner end is %s"
- inner_start.name inner_end.name;
- let treat_state (states, oth_trans) st =
- let trans = Path_analysis.get_transitions_of_state st auto in
- if st.nums = inner_start.nums then begin
- let loop_trans =
- if needs_counter then begin
- List.fold_left
- (fun acc tr ->
- let init_action = Counter_init (make_counter tr.stop) in
- let init_actions = init_action :: tr.actions in
- let init_trans =
- new_trans st tr.stop tr.cross init_actions
- in
- Aorai_option.debug "New init trans %a"
- print_eps_trans init_trans;
- if at_most_one then init_trans :: acc
- else begin
- let st =
- if needs_pebble then Some curr_start else None
- in
- let loop_cond =
- if needs_counter then
- guard_loop env st
- (make_counter_term curr_start)
- else TTrue
- in
- let loop_actions =
- if needs_counter then
- let counter = make_counter curr_start in
- Counter_incr counter :: tr.actions
- else tr.actions
- in
- let loop_cross =
- match tr.cross with
- | Normal cond -> Normal (tand loop_cond cond)
- | Epsilon cond -> Epsilon (tand loop_cond cond)
- in
- let loop_trans =
- new_trans inner_end tr.stop loop_cross loop_actions
- in
- Aorai_option.debug "New loop trans %a"
- print_eps_trans loop_trans;
- init_trans :: loop_trans :: acc
- end)
- oth_trans trans
- end else oth_trans
- in
- let trans =
- if might_be_zero then begin
+ let (env,states, seq_transitions, seq_end) =
+ match elt.nested with
+ | [] -> inner_env, [], [], my_end
+ | _ ->
+ let intermediate = new_intermediate_state () in
+ let (env, states, transitions, _, seq_end) =
+ type_seq
+ default_state tr metaenv
+ inner_env needs_pebble seq_start intermediate elt.nested
+ in env, states, transitions, seq_end
+ in
+ let states = add_if_needed states curr_start in
+ let transitions = trans_start :: seq_transitions in
+ (match trans_start.cross with
+ | Normal conds ->
+ trans_start.cross <- Normal (tand cond conds)
+ | Epsilon _ ->
+ Aorai_option.fatal
+ "Transition guard translated as epsilon transition");
+ let states = add_if_needed states seq_start in
+ (match env with
+ | [] | (ENone | ECall _) :: _ ->
+ (env, states, transitions, curr_start, seq_end)
+ | EReturn kf1 :: ECall (kf2,_,_) :: tl
+ when Kernel_function.equal kf1 kf2 ->
+ tl, states, transitions, curr_start, seq_end
+ | (EReturn _ | ECOR _ ) :: _ ->
+ (* If there is as mismatch (e.g. Call f; Return g), it will
+ be caught later. There are legitimate situations for
+ this pattern however (if the sequence itself occurs
+ in a non-empty context in particular)
+ *)
+ (env, states, transitions, curr_start, seq_end)
+ | EMulti :: env_tmp ->
+ env_tmp, states, transitions, curr_start, seq_end)
+ in
+ let loop_end = if has_loop then new_intermediate_state () else inner_end
+ in
+ let (_,oth_states,oth_trans,oth_start,_) =
+ type_seq default_state tr metaenv env needs_pebble loop_end curr_end seq
+ in
+ let trans = inner_trans @ oth_trans in
+ let states = List.fold_left add_if_needed oth_states inner_states in
+ let auto = (inner_states,inner_trans) in
+ if at_most_one then begin
+ (* Just adds an epsilon transition from start to end *)
+ let opt = new_trans curr_start oth_start (Epsilon TTrue) [] in
+ env, states, opt::trans, curr_start, curr_end
+ end
+ else if has_loop then begin
+ (* TODO: makes it an integer *)
+ let counter =
+ let ty = if needs_pebble then
+ Cil_types.TArray (Cil.intType,None,{scache=Not_Computed},[])
+ else Cil.intType
+ in (* We won't always need a counter *)
+ lazy (
+ let vi = Cil.makeGlobalVar (get_fresh "aorai_counter") ty in
+ add_aux_variable vi;
+ vi
+ )
+ in
+ let make_counter st =
+ let vi = Lazy.force counter in
+ let base = TVar (Cil.cvar_to_lvar vi), TNoOffset in
+ if needs_pebble then
+ let (_,idx) = memo_multi_state st in
+ Logic_const.addTermOffsetLval
+ (TIndex (Logic_const.tvar idx,TNoOffset)) base
+ else base
+ in
+ let make_counter_term st =
+ Logic_const.term (TLval (make_counter st)) (Ctype Cil.intType)
+ in
+ Aorai_option.debug "Inner start is %s; Inner end is %s"
+ inner_start.name inner_end.name;
+ let treat_state (states, oth_trans) st =
+ let trans = Path_analysis.get_transitions_of_state st auto in
+ if st.nums = inner_start.nums then begin
+ let loop_trans =
+ if needs_counter then begin
+ List.fold_left
+ (fun acc tr ->
+ let init_action = Counter_init (make_counter tr.stop) in
+ let init_actions = init_action :: tr.actions in
+ let init_trans =
+ new_trans st tr.stop tr.cross init_actions
+ in
+ Aorai_option.debug "New init trans %a"
+ print_eps_trans init_trans;
+ if at_most_one then init_trans :: acc
+ else begin
+ let st =
+ if needs_pebble then Some curr_start else None
+ in
+ let loop_cond =
+ if needs_counter then
+ guard_loop env st
+ (make_counter_term curr_start)
+ else TTrue
+ in
+ let loop_actions =
+ if needs_counter then
+ let counter = make_counter curr_start in
+ Counter_incr counter :: tr.actions
+ else tr.actions
+ in
+ let loop_cross =
+ match tr.cross with
+ | Normal cond -> Normal (tand loop_cond cond)
+ | Epsilon cond -> Epsilon (tand loop_cond cond)
+ in
+ let loop_trans =
+ new_trans inner_end tr.stop loop_cross loop_actions
+ in
+ Aorai_option.debug "New loop trans %a"
+ print_eps_trans loop_trans;
+ init_trans :: loop_trans :: acc
+ end)
+ oth_trans trans
+ end else oth_trans
+ in
+ let trans =
+ if might_be_zero then begin
(* We can bypass the inner transition altogether *)
- let zero_cond =
- if is_opt then TTrue
- else
- let current =
- if needs_pebble then Some curr_start else None
- in
- let _,t,_ =
- type_expr metaenv env ?current (Option.get elt.min_rep)
- in
- TRel (Cil_types.Req, t, Logic_const.tinteger ~loc 0)
- in
- let no_seq = new_trans st oth_start (Epsilon zero_cond) [] in
- no_seq :: loop_trans
- end else loop_trans
- in
- states, trans
- end
- else if st.nums = inner_end.nums then begin
- (* adds conditions on counter if needed *)
- let st =
- if needs_pebble then Some curr_end else None
- in
- let min_cond =
- if needs_counter then
- guard_exit_loop env st (make_counter_term curr_end)
- else TTrue
- in
- let min_cond = Epsilon min_cond in
- let exit_trans = new_trans inner_end oth_start min_cond [] in
- Aorai_option.debug "New exit trans %a"
- print_eps_trans exit_trans;
- let trans = exit_trans :: trans @ oth_trans in
- states, trans
- end else begin
- (* inner state: add a rejection state for consistency purposes
- iff we don't have a constant number of repetition (i.e. cut
- out branches where automaton wrongly start a new step) and
- don't have an otherwise branch in the original automaton.
- *)
- if fixed_number_of_loop || default_state then
- states, trans @ oth_trans
- else begin
- let cond =
- List.fold_left
- (fun acc tr ->
- match tr.cross with
- | Normal cond | Epsilon cond ->
- let cond = change_bound_var tr.stop st cond in
- tor acc cond)
- TFalse trans
+ let zero_cond =
+ if is_opt then TTrue
+ else
+ let current =
+ if needs_pebble then Some curr_start else None
+ in
+ let _,t,_ =
+ type_expr metaenv env ?current (Option.get elt.min_rep)
+ in
+ TRel (Cil_types.Req, t, Logic_const.tinteger ~loc 0)
in
- let (cond,_) = Logic_simplification.simplifyCond cond in
- let cond = tnot cond in
- (match cond with
- TFalse -> states, trans @ oth_trans
- | _ ->
- let reject = get_reject_state () in
- let states = add_if_needed states reject in
- let trans = new_trans st reject (Normal cond) [] :: trans
- in states, trans @ oth_trans
- )
- end
+ let no_seq = new_trans st oth_start (Epsilon zero_cond) [] in
+ no_seq :: loop_trans
+ end else loop_trans
+ in
+ states, trans
+ end
+ else if st.nums = inner_end.nums then begin
+ (* adds conditions on counter if needed *)
+ let st =
+ if needs_pebble then Some curr_end else None
+ in
+ let min_cond =
+ if needs_counter then
+ guard_exit_loop env st (make_counter_term curr_end)
+ else TTrue
+ in
+ let min_cond = Epsilon min_cond in
+ let exit_trans = new_trans inner_end oth_start min_cond [] in
+ Aorai_option.debug "New exit trans %a"
+ print_eps_trans exit_trans;
+ let trans = exit_trans :: trans @ oth_trans in
+ states, trans
+ end else begin
+ (* inner state: add a rejection state for consistency purposes
+ iff we don't have a constant number of repetition (i.e. cut
+ out branches where automaton wrongly start a new step) and
+ don't have an otherwise branch in the original automaton.
+ *)
+ if fixed_number_of_loop || default_state then
+ states, trans @ oth_trans
+ else begin
+ let cond =
+ List.fold_left
+ (fun acc tr ->
+ match tr.cross with
+ | Normal cond | Epsilon cond ->
+ let cond = change_bound_var tr.stop st cond in
+ tor acc cond)
+ TFalse trans
+ in
+ let (cond,_) = Logic_simplification.simplifyCond cond in
+ let cond = tnot cond in
+ (match cond with
+ TFalse -> states, trans @ oth_trans
+ | _ ->
+ let reject = get_reject_state () in
+ let states = add_if_needed states reject in
+ let trans = new_trans st reject (Normal cond) [] :: trans
+ in states, trans @ oth_trans
+ )
end
- in
- let states, trans =
- List.fold_left treat_state
- (* inner transition gets added in treat_state *)
- (states, oth_trans)
- inner_states
- in
- env, states, trans, curr_start, curr_end
- end else
- env, states, trans, curr_start, curr_end
+ end
+ in
+ let states, trans =
+ List.fold_left treat_state
+ (* inner transition gets added in treat_state *)
+ (states, oth_trans)
+ inner_states
+ in
+ env, states, trans, curr_start, curr_end
+ end else
+ env, states, trans, curr_start, curr_end
let type_action metaenv env = function
-| Metavar_assign (s, e) ->
- let vi = find_metavar s metaenv in
- let _, e, _ = type_expr metaenv env e in
- (* TODO: check type assignability *)
- Copy_value ((TVar (Cil.cvar_to_lvar vi), TNoOffset), e)
+ | Metavar_assign (s, e) ->
+ let vi = find_metavar s metaenv in
+ let _, e, _ = type_expr metaenv env e in
+ (* TODO: check type assignability *)
+ Copy_value ((TVar (Cil.cvar_to_lvar vi), TNoOffset), e)
let single_path (states,transitions as auto) tr =
Aorai_option.Deterministic.get () ||
- (let init = Path_analysis.get_init_states auto in
- match init with
- | [ st ] ->
- let auto = (states,
- List.filter (fun x -> x.numt <> tr.numt) transitions)
- in
- Path_analysis.at_most_one_path auto st tr.start
- | _ -> false)
+ (let init = Path_analysis.get_init_states auto in
+ match init with
+ | [ st ] ->
+ let auto = (states,
+ List.filter (fun x -> x.numt <> tr.numt) transitions)
+ in
+ Path_analysis.at_most_one_path auto st tr.start
+ | _ -> false)
let find_otherwise_trans auto st =
let trans = Path_analysis.get_transitions_of_state st auto in
@@ -1325,10 +1325,10 @@ let type_trans auto metaenv env tr =
let needs_pebble = not (single_path auto tr) in
let has_siblings =
match Path_analysis.get_transitions_of_state tr.start auto with
- | [] -> Aorai_option.fatal "Ill-formed automaton"
- (* at least tr should be there *)
- | [ _ ] -> false (* We only have one sequence to exit from there anyway *)
- | _::_::_ -> true
+ | [] -> Aorai_option.fatal "Ill-formed automaton"
+ (* at least tr should be there *)
+ | [ _ ] -> false (* We only have one sequence to exit from there anyway *)
+ | _::_::_ -> true
in
Aorai_option.debug
"Analyzing transition %s -> %s: %a (needs pebble: %B)"
@@ -1336,74 +1336,74 @@ let type_trans auto metaenv env tr =
Promelaoutput.Parsed.print_guard
tr.cross needs_pebble;
match tr.cross with
- | Seq seq ->
- let default_state = find_otherwise_trans auto tr.start in
- let has_default_state = Option.is_some default_state in
- let env,states, transitions,_,_ =
- type_seq has_default_state tr metaenv env needs_pebble tr.start tr.stop seq
- in
- (* Insert metavariable assignments for transitions to tr.stop *)
- let meta_actions = List.map (type_action metaenv env) tr.actions in
- let add_meta_actions t =
- if Aorai_state.equal t.stop tr.stop then
- { t with actions = t.actions @ meta_actions }
- else
- t
- in
- let transitions = List.map add_meta_actions transitions in
- let transitions =
- if List.exists (fun st -> st.multi_state <> None) states then begin
+ | Seq seq ->
+ let default_state = find_otherwise_trans auto tr.start in
+ let has_default_state = Option.is_some default_state in
+ let env,states, transitions,_,_ =
+ type_seq has_default_state tr metaenv env needs_pebble tr.start tr.stop seq
+ in
+ (* Insert metavariable assignments for transitions to tr.stop *)
+ let meta_actions = List.map (type_action metaenv env) tr.actions in
+ let add_meta_actions t =
+ if Aorai_state.equal t.stop tr.stop then
+ { t with actions = t.actions @ meta_actions }
+ else
+ t
+ in
+ let transitions = List.map add_meta_actions transitions in
+ let transitions =
+ if List.exists (fun st -> st.multi_state <> None) states then begin
(* We have introduced some multi-state somewhere, we have to introduce
pebbles and propagate them from state to state. *)
- let start = tr.start in
- let count = (* TODO: make it an integer. *)
- Cil.makeGlobalVar
- (get_fresh ("aorai_cnt_" ^ start.name)) Cil.intType
- in
- add_aux_variable count;
- let transitions =
- List.map
- (fun trans ->
- match trans.cross with
- | Epsilon _ -> trans
- | Normal _ ->
- let (dest,d_aux) = memo_multi_state tr.stop in
- let actions =
- if tr.start.nums <> start.nums then begin
- let src,s_aux = memo_multi_state tr.start in
- Pebble_move(dest,d_aux,src,s_aux) :: trans.actions
- end else begin
- let v = Cil.cvar_to_lvar count in
- let incr = Counter_incr (TVar v, TNoOffset) in
- let init = Pebble_init (dest, d_aux, v) in
- init::incr::trans.actions
- end
- in
- { trans with actions })
- transitions
- in
- transitions
- end else
- transitions
- in
- (* For each intermediate state, add a transition
- to either the default state or a rejection state (in which we will
- stay until the end of the execution, while another branch might
- succeed in an acceptance state.
- )*)
- let needs_default =
- has_siblings &&
- match transitions with
- | [] | [ _ ] -> false
- | _::_::_ -> true
- in
- Aorai_option.debug "Resulting transitions:@\n%a"
- (Pretty_utils.pp_list ~sep:"@\n"
- (fun fmt tr -> Format.fprintf fmt "%a"
- print_eps_trans tr))
- transitions;
- states, transitions, needs_default
- | Otherwise -> [],[], false (* treated directly by type_seq *)
+ let start = tr.start in
+ let count = (* TODO: make it an integer. *)
+ Cil.makeGlobalVar
+ (get_fresh ("aorai_cnt_" ^ start.name)) Cil.intType
+ in
+ add_aux_variable count;
+ let transitions =
+ List.map
+ (fun trans ->
+ match trans.cross with
+ | Epsilon _ -> trans
+ | Normal _ ->
+ let (dest,d_aux) = memo_multi_state tr.stop in
+ let actions =
+ if tr.start.nums <> start.nums then begin
+ let src,s_aux = memo_multi_state tr.start in
+ Pebble_move(dest,d_aux,src,s_aux) :: trans.actions
+ end else begin
+ let v = Cil.cvar_to_lvar count in
+ let incr = Counter_incr (TVar v, TNoOffset) in
+ let init = Pebble_init (dest, d_aux, v) in
+ init::incr::trans.actions
+ end
+ in
+ { trans with actions })
+ transitions
+ in
+ transitions
+ end else
+ transitions
+ in
+ (* For each intermediate state, add a transition
+ to either the default state or a rejection state (in which we will
+ stay until the end of the execution, while another branch might
+ succeed in an acceptance state.
+ )*)
+ let needs_default =
+ has_siblings &&
+ match transitions with
+ | [] | [ _ ] -> false
+ | _::_::_ -> true
+ in
+ Aorai_option.debug "Resulting transitions:@\n%a"
+ (Pretty_utils.pp_list ~sep:"@\n"
+ (fun fmt tr -> Format.fprintf fmt "%a"
+ print_eps_trans tr))
+ transitions;
+ states, transitions, needs_default
+ | Otherwise -> [],[], false (* treated directly by type_seq *)
let add_reject_trans auto intermediate_states =
let treat_one_state (states, trans) st =
@@ -1413,18 +1413,18 @@ let add_reject_trans auto intermediate_states =
let cond =
List.fold_left
(fun acc tr ->
- let cond = change_bound_var tr.stop st tr.cross in
- tor cond acc)
+ let cond = change_bound_var tr.stop st tr.cross in
+ tor cond acc)
TFalse my_trans
in
let cond = fst (Logic_simplification.simplifyCond (tnot cond)) in
match cond with
- TFalse -> states,trans
- | _ ->
- Aorai_option.debug
- "Adding default transition %s -> %s: %a"
- st.name reject_state.name Promelaoutput.Typed.print_condition cond;
- states, new_trans st reject_state cond [] :: trans
+ TFalse -> states,trans
+ | _ ->
+ Aorai_option.debug
+ "Adding default transition %s -> %s: %a"
+ st.name reject_state.name Promelaoutput.Typed.print_condition cond;
+ states, new_trans st reject_state cond [] :: trans
in
List.fold_left treat_one_state auto intermediate_states
@@ -1434,23 +1434,23 @@ let propagate_epsilon_transitions (states, _ as auto) =
let trans = Path_analysis.get_transitions_of_state curr auto in
List.fold_left
(fun acc tr ->
- match tr.cross with
- | Epsilon cond ->
- Aorai_option.debug "Treating epsilon trans %s -> %s"
- curr.name tr.stop.name;
- if List.exists (fun st -> st.nums = tr.stop.nums) known_states
- then acc
- else
- transitive_closure
- start (tand cond conds) (tr.actions @ actions)
- known_states tr.stop @ acc
- | Normal cond ->
- Aorai_option.debug "Adding transition %s -> %s from epsilon trans"
- start.name tr.stop.name;
- let tr =
- new_trans start tr.stop (tand cond conds) (tr.actions @ actions)
- in
- tr :: acc)
+ match tr.cross with
+ | Epsilon cond ->
+ Aorai_option.debug "Treating epsilon trans %s -> %s"
+ curr.name tr.stop.name;
+ if List.exists (fun st -> st.nums = tr.stop.nums) known_states
+ then acc
+ else
+ transitive_closure
+ start (tand cond conds) (tr.actions @ actions)
+ known_states tr.stop @ acc
+ | Normal cond ->
+ Aorai_option.debug "Adding transition %s -> %s from epsilon trans"
+ start.name tr.stop.name;
+ let tr =
+ new_trans start tr.stop (tand cond conds) (tr.actions @ actions)
+ in
+ tr :: acc)
[] trans
in
let treat_one_state acc st =
@@ -1468,18 +1468,18 @@ let add_default_trans (states, transitions as auto) otherwise =
let cond =
List.fold_left
(fun acc c ->
- let cond = c.cross in
- Aorai_option.debug "considering trans %s -> %s: %a"
- c.start.name c.stop.name Promelaoutput.Typed.print_condition cond;
- let neg = tnot cond in
- Aorai_option.debug "negation: %a"
- Promelaoutput.Typed.print_condition neg;
- Aorai_option.debug "acc: %a"
- Promelaoutput.Typed.print_condition acc;
- let res = tand acc (tnot cond) in
- Aorai_option.debug "partial result: %a"
- Promelaoutput.Typed.print_condition res;
- res
+ let cond = c.cross in
+ Aorai_option.debug "considering trans %s -> %s: %a"
+ c.start.name c.stop.name Promelaoutput.Typed.print_condition cond;
+ let neg = tnot cond in
+ Aorai_option.debug "negation: %a"
+ Promelaoutput.Typed.print_condition neg;
+ Aorai_option.debug "acc: %a"
+ Promelaoutput.Typed.print_condition acc;
+ let res = tand acc (tnot cond) in
+ Aorai_option.debug "partial result: %a"
+ Promelaoutput.Typed.print_condition res;
+ res
)
TTrue
my_trans
@@ -1512,7 +1512,7 @@ let type_cond_auto auto =
if needs_reject then
(List.filter
(fun x -> not (Aorai_state.equal tr.start x ||
- Aorai_state.equal tr.stop x))
+ Aorai_state.equal tr.stop x))
intermediate_states) @ add_reject
else add_reject
in
@@ -1529,12 +1529,12 @@ let type_cond_auto auto =
(* nums (and in the past numt) are used as indices in arrays. Therefore, we
must ensure that we use consecutive numbers starting from 0, or we'll
have needlessly long arrays.
- *)
+ *)
let states, trans =
match Reject_state.get_option () with
- | Some state ->
- (states, new_trans state state TTrue [] :: transitions)
- | None -> auto
+ | Some state ->
+ (states, new_trans state state TTrue [] :: transitions)
+ | None -> auto
in
let auto = { original_auto with states ; trans } in
if Aorai_option.debug_atleast 1 then
@@ -1542,10 +1542,10 @@ let type_cond_auto auto =
let (_,trans) =
List.fold_left
(fun (i,l as acc) t ->
- let cond = fst (Logic_simplification.simplifyCond t.cross)
- in match cond with
- TFalse -> acc
- | _ -> (i+1,{ t with cross = cond; numt = i } :: l))
+ let cond = fst (Logic_simplification.simplifyCond t.cross)
+ in match cond with
+ TFalse -> acc
+ | _ -> (i+1,{ t with cross = cond; numt = i } :: l))
(0,[]) trans
in
let states =
@@ -1556,18 +1556,18 @@ let type_cond_auto auto =
let _, states =
List.fold_left
(fun (i,l as acc) s ->
- if
- is_reject_state s ||
- List.exists
- (fun t -> t.start.nums = s.nums || t.stop.nums = s.nums)
- trans
- then begin
- s.nums <- i;
- (i+1, s :: l)
- end else acc)
+ if
+ is_reject_state s ||
+ List.exists
+ (fun t -> t.start.nums = s.nums || t.stop.nums = s.nums)
+ trans
+ then begin
+ s.nums <- i;
+ (i+1, s :: l)
+ end else acc)
(0,[]) states
in
- { original_auto with states = List.rev states; trans = List.rev trans }
+ { original_auto with states = List.rev states; trans = List.rev trans }
(* Check Metavariable compatibility *)
@@ -1588,31 +1588,31 @@ let checkMetavariableCompatibility auto =
automata, such as automata using extended transitions."
let check_observables auto =
- match auto.observables with
- | None -> () (* No observable list set, everything is observable *)
- | Some set ->
- let is_relevant name =
- try
- let kf = Globals.Functions.find_by_name name in
- if not (Kernel_function.is_definition kf) then
- Aorai_option.warning
- "Function %a is observable by the automaton but is not defined \
- in the C code. It will be ignored in the instrumentation"
- Printer.pp_varname (Kernel_function.get_name kf)
- with Not_found ->
- Aorai_option.abort "Observable %s doesn't match any function" name
- in
- let rec check = function
- | TAnd (c1,c2) | TOr (c1,c2) -> check c1; check c2
- | TNot (c) -> check c
- | TRel _ | TTrue | TFalse -> ()
- | TCall (kf,_) | TReturn kf ->
- let name = Kernel_function.get_name kf in
- if not (Datatype.String.Set.mem name set) then
- Aorai_option.abort "Function %s is not observable" name
- in
- Datatype.String.Set.iter is_relevant set;
- List.iter (fun tr -> check tr.cross) auto.trans
+ match auto.observables with
+ | None -> () (* No observable list set, everything is observable *)
+ | Some set ->
+ let is_relevant name =
+ try
+ let kf = Globals.Functions.find_by_name name in
+ if not (Kernel_function.is_definition kf) then
+ Aorai_option.warning
+ "Function %a is observable by the automaton but is not defined \
+ in the C code. It will be ignored in the instrumentation"
+ Printer.pp_varname (Kernel_function.get_name kf)
+ with Not_found ->
+ Aorai_option.abort "Observable %s doesn't match any function" name
+ in
+ let rec check = function
+ | TAnd (c1,c2) | TOr (c1,c2) -> check c1; check c2
+ | TNot (c) -> check c
+ | TRel _ | TTrue | TFalse -> ()
+ | TCall (kf,_) | TReturn kf ->
+ let name = Kernel_function.get_name kf in
+ if not (Datatype.String.Set.mem name set) then
+ Aorai_option.abort "Function %s is not observable" name
+ in
+ Datatype.String.Set.iter is_relevant set;
+ List.iter (fun tr -> check tr.cross) auto.trans
(** Stores the buchi automaton and its variables and
functions as it is returned by the parsing *)
@@ -1625,7 +1625,7 @@ let setAutomata auto =
if Aorai_option.debug_atleast 1 then
Promelaoutput.Typed.output_dot_automata auto "aorai_debug_reduced.dot";
if (Array.length !cond_of_parametrizedTransitions) <
- (getNumberOfTransitions ())
+ (getNumberOfTransitions ())
then
(* all transitions have a true parameterized guard, i.e. [[]] *)
cond_of_parametrizedTransitions :=
@@ -1647,8 +1647,8 @@ let setCData () =
Globals.Functions.fold
(fun f (lf_decl,lf_def) ->
match f.fundec with
- | Definition _ -> (lf_decl, f :: lf_def)
- | Declaration _ -> (f :: lf_decl, lf_def))
+ | Definition _ -> (lf_decl, f :: lf_def)
+ | Declaration _ -> (f :: lf_decl, lf_def))
([],[])
in
defined_functions := f_def;
@@ -1683,13 +1683,13 @@ let getIgnoredFunctions () =
module Aux_varinfos =
State_builder.Hashtbl(Datatype.String.Hashtbl)(Cil_datatype.Varinfo)
- (struct
- let name = "Data_for_aorai.Aux_varinfos"
- let dependencies =
- [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
- Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
- let size = 13
- end)
+ (struct
+ let name = "Data_for_aorai.Aux_varinfos"
+ let dependencies =
+ [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
+ Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
+ let size = 13
+ end)
let () = Ast.add_linked_state Aux_varinfos.self
@@ -1700,13 +1700,13 @@ module StringPair =
module Paraminfos =
State_builder.Hashtbl(StringPair.Hashtbl)(Cil_datatype.Varinfo)
- (struct
- let name = "Data_for_aorai.Paraminfos"
- let dependencies =
- [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
- Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
- let size = 13
- end)
+ (struct
+ let name = "Data_for_aorai.Paraminfos"
+ let dependencies =
+ [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
+ Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
+ let size = 13
+ end)
(* Add a new variable into the association table name -> varinfo *)
let set_varinfo = Aux_varinfos.add
@@ -1727,7 +1727,7 @@ let get_varinfo_option name =
try
Some(Aux_varinfos.find name)
with
- | Not_found -> None
+ | Not_found -> None
(* Add a new param into the association table (funcname,paramname) -> varinfo *)
let set_paraminfo funcname paramname vi =
@@ -1761,40 +1761,40 @@ type range =
| Interval of int * int (** range of values *)
| Bounded of int * term (** range bounded by a logic term (depending on
program parameter).
- *)
+ *)
| Unbounded of int (** only the lower bound is known,
there is no upper bound *)
| Unknown (** completely unknown value. *)
module Range = Datatype.Make_with_collections
- (struct
+ (struct
type t = range
let name = "Data_for_aorai.Range"
let rehash = Datatype.identity
let structural_descr = Structural_descr.t_abstract
let reprs =
Fixed 0 :: Interval (0,1) :: Unbounded 0 ::
- List.map (fun x -> Bounded (0,x)) Cil_datatype.Term.reprs
+ List.map (fun x -> Bounded (0,x)) Cil_datatype.Term.reprs
let equal = Datatype.from_compare
let compare x y =
match x,y with
- | Fixed c1, Fixed c2 -> Datatype.Int.compare c1 c2
- | Fixed _, _ -> 1
- | _, Fixed _ -> -1
- | Interval (min1,max1), Interval(min2, max2) ->
- let c1 = Datatype.Int.compare min1 min2 in
- if c1 = 0 then Datatype.Int.compare max1 max2 else c1
- | Interval _, _ -> 1
- | _,Interval _ -> -1
- | Bounded (min1,max1), Bounded(min2,max2) ->
- let c1 = Datatype.Int.compare min1 min2 in
- if c1 = 0 then Cil_datatype.Term.compare max1 max2 else c1
- | Bounded _, _ -> 1
- | _, Bounded _ -> -1
- | Unbounded c1, Unbounded c2 -> Datatype.Int.compare c1 c2
- | Unbounded _, _ -> 1
- | _, Unbounded _ -> -1
- | Unknown, Unknown -> 0
+ | Fixed c1, Fixed c2 -> Datatype.Int.compare c1 c2
+ | Fixed _, _ -> 1
+ | _, Fixed _ -> -1
+ | Interval (min1,max1), Interval(min2, max2) ->
+ let c1 = Datatype.Int.compare min1 min2 in
+ if c1 = 0 then Datatype.Int.compare max1 max2 else c1
+ | Interval _, _ -> 1
+ | _,Interval _ -> -1
+ | Bounded (min1,max1), Bounded(min2,max2) ->
+ let c1 = Datatype.Int.compare min1 min2 in
+ if c1 = 0 then Cil_datatype.Term.compare max1 max2 else c1
+ | Bounded _, _ -> 1
+ | _, Bounded _ -> -1
+ | Unbounded c1, Unbounded c2 -> Datatype.Int.compare c1 c2
+ | Unbounded _, _ -> 1
+ | _, Unbounded _ -> -1
+ | Unknown, Unknown -> 0
let hash = function
| Fixed c1 -> 2 * c1
| Interval(c1,c2) -> 3 * (c1 + c2)
@@ -1822,7 +1822,7 @@ module Range = Datatype.Make_with_collections
| Unknown -> Format.fprintf fmt "[..]"
let varname _ = "r"
let mem_project = Datatype.never_any_project
- end)
+ end)
module Intervals = Cil_datatype.Term.Map.Make(Range)
@@ -1834,91 +1834,91 @@ module Vals = Cil_datatype.Term.Map.Make(Intervals)
let absolute_range loc min =
let max = find_max_value loc in
match max with
- | Some { term_node = TConst(Integer (t,_)) } ->
- Interval(min,Integer.to_int t)
- | Some x ->
- Bounded (min, Logic_const.term x.term_node x.term_type)
- | None -> Unbounded min
+ | Some { term_node = TConst(Integer (t,_)) } ->
+ Interval(min,Integer.to_int t)
+ | Some x ->
+ Bounded (min, Logic_const.term x.term_node x.term_type)
+ | None -> Unbounded min
let merge_range loc base r1 r2 =
match r1,r2 with
- | Fixed c1, Fixed c2 when Datatype.Int.compare c1 c2 = 0 -> r1
- | Fixed c1, Fixed c2 ->
- let min, max =
- if Datatype.Int.compare c1 c2 <= 0 then c1,c2 else c2,c1 in
- Interval (min,max)
- | Fixed c1, Interval(min,max) ->
- let min = if Datatype.Int.compare c1 min <= 0 then c1 else min in
- let max = if Datatype.Int.compare max c1 <= 0 then c1 else max in
- Interval (min,max)
- | Fixed c1, Bounded(min,_) ->
- let min = if Datatype.Int.compare c1 min <= 0 then c1 else min in
- Unbounded min
- | Fixed c1, Unbounded min ->
- let min = if Datatype.Int.compare c1 min <= 0 then c1 else min in
- Unbounded min
- | Interval(min,max), Fixed c ->
- if Datatype.Int.compare c min < 0 || Datatype.Int.compare c max > 0 then
- begin
- let min = if Datatype.Int.compare c min < 0 then c else min in
- if Cil.isLogicZero base then
- absolute_range loc min
- else Unbounded min
- end else r1
- | Interval(min1,max1), Interval(min2,max2) ->
- if Datatype.Int.compare min2 min1 < 0
- || Datatype.Int.compare max2 max1 > 0 then
- begin
- let min =
- if Datatype.Int.compare min2 min1 < 0 then min2 else min1
- in
- if Cil.isLogicZero base then
- absolute_range loc min
- else Unbounded min
- end else r1
- | Interval(min1,_), (Bounded(min2,_) | Unbounded min2)->
- let min = if Datatype.Int.compare min1 min2 <= 0 then min1 else min2 in
- Unbounded min
- | Bounded(min1,max1), Bounded(min2,max2)
- when Cil_datatype.Term.equal max1 max2 ->
- let min =
- if Datatype.Int.compare min2 min1 < 0 then min2 else min1
- in
- Bounded(min,max1)
- | Bounded(min1,_),
- (Fixed min2 | Interval(min2,_) | Bounded (min2,_) | Unbounded min2) ->
- let min =
- if Datatype.Int.compare min2 min1 < 0 then min2 else min1
- in Unbounded min
- | Unbounded min1,
- (Fixed min2 | Interval(min2,_) | Bounded (min2,_) | Unbounded min2) ->
- let min =
- if Datatype.Int.compare min2 min1 < 0 then min2 else min1
- in Unbounded min
- | Unknown, _ | _, Unknown -> Unknown
+ | Fixed c1, Fixed c2 when Datatype.Int.compare c1 c2 = 0 -> r1
+ | Fixed c1, Fixed c2 ->
+ let min, max =
+ if Datatype.Int.compare c1 c2 <= 0 then c1,c2 else c2,c1 in
+ Interval (min,max)
+ | Fixed c1, Interval(min,max) ->
+ let min = if Datatype.Int.compare c1 min <= 0 then c1 else min in
+ let max = if Datatype.Int.compare max c1 <= 0 then c1 else max in
+ Interval (min,max)
+ | Fixed c1, Bounded(min,_) ->
+ let min = if Datatype.Int.compare c1 min <= 0 then c1 else min in
+ Unbounded min
+ | Fixed c1, Unbounded min ->
+ let min = if Datatype.Int.compare c1 min <= 0 then c1 else min in
+ Unbounded min
+ | Interval(min,max), Fixed c ->
+ if Datatype.Int.compare c min < 0 || Datatype.Int.compare c max > 0 then
+ begin
+ let min = if Datatype.Int.compare c min < 0 then c else min in
+ if Cil.isLogicZero base then
+ absolute_range loc min
+ else Unbounded min
+ end else r1
+ | Interval(min1,max1), Interval(min2,max2) ->
+ if Datatype.Int.compare min2 min1 < 0
+ || Datatype.Int.compare max2 max1 > 0 then
+ begin
+ let min =
+ if Datatype.Int.compare min2 min1 < 0 then min2 else min1
+ in
+ if Cil.isLogicZero base then
+ absolute_range loc min
+ else Unbounded min
+ end else r1
+ | Interval(min1,_), (Bounded(min2,_) | Unbounded min2)->
+ let min = if Datatype.Int.compare min1 min2 <= 0 then min1 else min2 in
+ Unbounded min
+ | Bounded(min1,max1), Bounded(min2,max2)
+ when Cil_datatype.Term.equal max1 max2 ->
+ let min =
+ if Datatype.Int.compare min2 min1 < 0 then min2 else min1
+ in
+ Bounded(min,max1)
+ | Bounded(min1,_),
+ (Fixed min2 | Interval(min2,_) | Bounded (min2,_) | Unbounded min2) ->
+ let min =
+ if Datatype.Int.compare min2 min1 < 0 then min2 else min1
+ in Unbounded min
+ | Unbounded min1,
+ (Fixed min2 | Interval(min2,_) | Bounded (min2,_) | Unbounded min2) ->
+ let min =
+ if Datatype.Int.compare min2 min1 < 0 then min2 else min1
+ in Unbounded min
+ | Unknown, _ | _, Unknown -> Unknown
let tlval lv = Logic_const.term (TLval lv) (Cil.typeOfTermLval lv)
let included_range range1 range2 =
match range1, range2 with
- | Fixed c1, Fixed c2 -> Datatype.Int.equal c1 c2
- | Fixed c, Interval(l,h) ->
- Datatype.Int.compare l c <= 0 && Datatype.Int.compare c h <= 0
- | Fixed _, Bounded _ -> false
- | Fixed c1, Unbounded c2 -> Datatype.Int.compare c1 c2 >= 0
- | Interval (l1,h1), Interval(l2,h2) ->
- Datatype.Int.compare l1 l2 >= 0 && Datatype.Int.compare h1 h2 <= 0
- | Interval (l1,_), Unbounded l2 ->
- Datatype.Int.compare l1 l2 >= 0
- | Interval _, (Fixed _ | Bounded _ ) -> false
- | Bounded _, (Fixed _ | Interval _) -> false
- | Bounded(l1,h1), Bounded(l2,h2) ->
- Datatype.Int.compare l1 l2 >= 0 && Cil_datatype.Term.equal h1 h2
- | Bounded(l1,_), Unbounded l2 -> Datatype.Int.compare l1 l2 <= 0
- | Unbounded l1, Unbounded l2 -> Datatype.Int.compare l1 l2 <= 0
- | Unbounded _, (Fixed _ | Interval _ | Bounded _) -> false
- | _, Unknown -> true
- | Unknown, _ -> false
+ | Fixed c1, Fixed c2 -> Datatype.Int.equal c1 c2
+ | Fixed c, Interval(l,h) ->
+ Datatype.Int.compare l c <= 0 && Datatype.Int.compare c h <= 0
+ | Fixed _, Bounded _ -> false
+ | Fixed c1, Unbounded c2 -> Datatype.Int.compare c1 c2 >= 0
+ | Interval (l1,h1), Interval(l2,h2) ->
+ Datatype.Int.compare l1 l2 >= 0 && Datatype.Int.compare h1 h2 <= 0
+ | Interval (l1,_), Unbounded l2 ->
+ Datatype.Int.compare l1 l2 >= 0
+ | Interval _, (Fixed _ | Bounded _ ) -> false
+ | Bounded _, (Fixed _ | Interval _) -> false
+ | Bounded(l1,h1), Bounded(l2,h2) ->
+ Datatype.Int.compare l1 l2 >= 0 && Cil_datatype.Term.equal h1 h2
+ | Bounded(l1,_), Unbounded l2 -> Datatype.Int.compare l1 l2 <= 0
+ | Unbounded l1, Unbounded l2 -> Datatype.Int.compare l1 l2 <= 0
+ | Unbounded _, (Fixed _ | Interval _ | Bounded _) -> false
+ | _, Unknown -> true
+ | Unknown, _ -> false
let unchanged loc =
Cil_datatype.Term.Map.add loc (Fixed 0) Cil_datatype.Term.Map.empty
@@ -1927,13 +1927,13 @@ let merge_bindings tbl1 tbl2 =
let merge_range loc = Extlib.merge_opt (merge_range loc) in
let merge_vals loc tbl1 tbl2 =
match tbl1, tbl2 with
- | None, None -> None
- | Some tbl, None | None, Some tbl ->
- Some
- (Cil_datatype.Term.Map.merge
- (merge_range loc) tbl (unchanged loc))
- | Some tbl1, Some tbl2 ->
- Some (Cil_datatype.Term.Map.merge (merge_range loc) tbl1 tbl2)
+ | None, None -> None
+ | Some tbl, None | None, Some tbl ->
+ Some
+ (Cil_datatype.Term.Map.merge
+ (merge_range loc) tbl (unchanged loc))
+ | Some tbl1, Some tbl2 ->
+ Some (Cil_datatype.Term.Map.merge (merge_range loc) tbl1 tbl2)
in
Cil_datatype.Term.Map.merge merge_vals tbl1 tbl2
@@ -1946,7 +1946,7 @@ type end_state = End_state.t
possible state at the entrance to the function (before actual transition)
to the current state possibles, associated to any action that has occurred
on that path.
- *)
+*)
module Case_state = Aorai_state.Map.Make(End_state)
type state = Case_state.t
@@ -1954,32 +1954,32 @@ type state = Case_state.t
let pretty_end_state start fmt tbl =
Aorai_state.Map.iter
(fun stop (fst,last, actions) ->
- Format.fprintf fmt
- "Possible path from %s to %s@\n Initial trans:@\n"
- start.Promelaast.name stop.Promelaast.name;
- Aorai_state.Set.iter
- (fun state ->
- Format.fprintf fmt " %s -> %s@\n"
- start.Promelaast.name
- state.Promelaast.name)
- fst;
- Format.fprintf fmt " Final trans:@\n";
- Aorai_state.Set.iter
- (fun state ->
- Format.fprintf fmt " %s -> %s@\n"
- state.Promelaast.name stop.Promelaast.name)
- last;
- Format.fprintf fmt " Related actions:@\n";
- Cil_datatype.Term.Map.iter
- (fun loc tbl ->
- Cil_datatype.Term.Map.iter
- (fun base itv ->
- Format.fprintf fmt " %a <- %a + %a@\n"
- Cil_datatype.Term.pretty loc
- Cil_datatype.Term.pretty base
- Range.pretty itv)
- tbl)
- actions)
+ Format.fprintf fmt
+ "Possible path from %s to %s@\n Initial trans:@\n"
+ start.Promelaast.name stop.Promelaast.name;
+ Aorai_state.Set.iter
+ (fun state ->
+ Format.fprintf fmt " %s -> %s@\n"
+ start.Promelaast.name
+ state.Promelaast.name)
+ fst;
+ Format.fprintf fmt " Final trans:@\n";
+ Aorai_state.Set.iter
+ (fun state ->
+ Format.fprintf fmt " %s -> %s@\n"
+ state.Promelaast.name stop.Promelaast.name)
+ last;
+ Format.fprintf fmt " Related actions:@\n";
+ Cil_datatype.Term.Map.iter
+ (fun loc tbl ->
+ Cil_datatype.Term.Map.iter
+ (fun base itv ->
+ Format.fprintf fmt " %a <- %a + %a@\n"
+ Cil_datatype.Term.pretty loc
+ Cil_datatype.Term.pretty base
+ Range.pretty itv)
+ tbl)
+ actions)
tbl
let pretty_state fmt cases =
@@ -1989,26 +1989,26 @@ let included_state tbl1 tbl2 =
try
Aorai_state.Map.iter
(fun s1 tbl1 ->
- let tbl2 = Aorai_state.Map.find s1 tbl2 in
- Aorai_state.Map.iter
- (fun s2 (fst1, last1, tbl1) ->
- let (fst2, last2, tbl2) = Aorai_state.Map.find s2 tbl2 in
- if not (Aorai_state.Set.subset fst1 fst2)
+ let tbl2 = Aorai_state.Map.find s1 tbl2 in
+ Aorai_state.Map.iter
+ (fun s2 (fst1, last1, tbl1) ->
+ let (fst2, last2, tbl2) = Aorai_state.Map.find s2 tbl2 in
+ if not (Aorai_state.Set.subset fst1 fst2)
|| not (Aorai_state.Set.subset last1 last2)
- then raise Not_found;
- Cil_datatype.Term.Map.iter
- (fun base bindings1 ->
- let bindings2 =
- Cil_datatype.Term.Map.find base tbl2
- in
- Cil_datatype.Term.Map.iter
- (fun loc range1 ->
- let range2 = Cil_datatype.Term.Map.find loc bindings2 in
- if not
- (included_range range1 range2) then raise Not_found)
- bindings1)
- tbl1)
- tbl1)
+ then raise Not_found;
+ Cil_datatype.Term.Map.iter
+ (fun base bindings1 ->
+ let bindings2 =
+ Cil_datatype.Term.Map.find base tbl2
+ in
+ Cil_datatype.Term.Map.iter
+ (fun loc range1 ->
+ let range2 = Cil_datatype.Term.Map.find loc bindings2 in
+ if not
+ (included_range range1 range2) then raise Not_found)
+ bindings1)
+ tbl1)
+ tbl1)
tbl1;
true
with Not_found -> false
@@ -2030,12 +2030,12 @@ module Pre_state =
Kernel_function.Make_Table
(Case_state)
(struct
- let name = "Data_for_aorai.Pre_state"
- let dependencies =
- [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
- Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
- let size = 17
- end)
+ let name = "Data_for_aorai.Pre_state"
+ let dependencies =
+ [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
+ Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
+ let size = 17
+ end)
let set_kf_init_state kf state =
let change old_state = merge_state old_state state in
@@ -2059,12 +2059,12 @@ module Post_state =
Kernel_function.Make_Table
(Case_state)
(struct
- let name = "Data_for_aorai.Post_state"
- let dependencies =
- [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
- Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
- let size = 17
- end)
+ let name = "Data_for_aorai.Post_state"
+ let dependencies =
+ [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
+ Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
+ let size = 17
+ end)
let set_kf_return_state kf state =
let change old_state = merge_state old_state state in
@@ -2083,12 +2083,12 @@ module Loop_init_state =
(Cil_datatype.Stmt.Hashtbl)
(Case_state)
(struct
- let name = "Data_for_aorai.Loop_init_state"
- let dependencies =
- [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
- Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
- let size = 17
- end)
+ let name = "Data_for_aorai.Loop_init_state"
+ let dependencies =
+ [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
+ Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
+ let size = 17
+ end)
let set_loop_init_state stmt state =
let change old_state = merge_state old_state state in
@@ -2107,12 +2107,12 @@ module Loop_invariant_state =
(Cil_datatype.Stmt.Hashtbl)
(Case_state)
(struct
- let name = "Data_for_aorai.Loop_invariant_state"
- let dependencies =
- [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
- Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
- let size = 17
- end)
+ let name = "Data_for_aorai.Loop_invariant_state"
+ let dependencies =
+ [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self;
+ Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ]
+ let size = 17
+ end)
let set_loop_invariant_state stmt state =
let change old_state = merge_state old_state state in
@@ -2128,28 +2128,28 @@ let get_loop_invariant_state stmt =
let pretty_pre_state fmt =
Pre_state.iter
(fun kf state ->
- Format.fprintf fmt "Function %a:@\n @[%a@]@\n"
- Kernel_function.pretty kf pretty_state state)
+ Format.fprintf fmt "Function %a:@\n @[%a@]@\n"
+ Kernel_function.pretty kf pretty_state state)
let pretty_post_state fmt =
Post_state.iter
(fun kf state ->
- Format.fprintf fmt "Function %a:@\n @[%a@]@\n"
- Kernel_function.pretty kf pretty_state state)
+ Format.fprintf fmt "Function %a:@\n @[%a@]@\n"
+ Kernel_function.pretty kf pretty_state state)
let pretty_loop_init fmt =
Loop_init_state.iter
(fun stmt state ->
- let kf = Kernel_function.find_englobing_kf stmt in
- Format.fprintf fmt "Function %a, sid %d:@\n @[%a@]@\n"
- Kernel_function.pretty kf stmt.sid pretty_state state)
+ let kf = Kernel_function.find_englobing_kf stmt in
+ Format.fprintf fmt "Function %a, sid %d:@\n @[%a@]@\n"
+ Kernel_function.pretty kf stmt.sid pretty_state state)
let pretty_loop_invariant fmt =
Loop_invariant_state.iter
(fun stmt state ->
- let kf = Kernel_function.find_englobing_kf stmt in
- Format.fprintf fmt "Function %a, sid %d:@\n @[%a@]@\n"
- Kernel_function.pretty kf stmt.sid pretty_state state)
+ let kf = Kernel_function.find_englobing_kf stmt in
+ Format.fprintf fmt "Function %a, sid %d:@\n @[%a@]@\n"
+ Kernel_function.pretty kf stmt.sid pretty_state state)
let debug_computed_state ?(dkey=dkey) () =
Aorai_option.debug ~dkey
@@ -2165,9 +2165,9 @@ let removeUnusedTransitionsAndStates () =
let treat_one_state state map set =
Aorai_state.Map.fold
(fun state (fst, last, _) set ->
- Aorai_state.Set.add state
- (Aorai_state.Set.union last
- (Aorai_state.Set.union fst set)))
+ Aorai_state.Set.add state
+ (Aorai_state.Set.union last
+ (Aorai_state.Set.union fst set)))
map
(Aorai_state.Set.add state set)
in
@@ -2194,28 +2194,28 @@ let removeUnusedTransitionsAndStates () =
let (_, translate_table) =
List.fold_left
(fun (i,map) x ->
- let map = Aorai_state.Map.add x { x with nums = i } map in (i+1,map))
+ let map = Aorai_state.Map.add x { x with nums = i } map in (i+1,map))
(0,Aorai_state.Map.empty) state_list
in
let new_state s = Aorai_state.Map.find s translate_table in
let (_, trans_list) =
List.fold_left
(fun (i,list as acc) trans ->
- try
- let new_start = new_state trans.start in
- let new_stop = new_state trans.stop in
- (i+1,
- { trans with start = new_start; stop = new_stop; numt = i } :: list)
- with Not_found -> acc)
+ try
+ let new_start = new_state trans.start in
+ let new_stop = new_state trans.stop in
+ (i+1,
+ { trans with start = new_start; stop = new_stop; numt = i } :: list)
+ with Not_found -> acc)
(0,[]) auto.trans
in
let state_list = List.map new_state state_list in
Reject_state.may
(fun reject_state ->
- try
- let new_reject = Aorai_state.Map.find reject_state translate_table in
- Reject_state.set new_reject
- with Not_found -> Reject_state.clear ());
+ try
+ let new_reject = Aorai_state.Map.find reject_state translate_table in
+ Reject_state.set new_reject
+ with Not_found -> Reject_state.clear ());
(* Step 3 : rewriting stored information *)
Automaton.set (Some { auto with states =state_list; trans = trans_list });
check_states "reduced automaton";
@@ -2265,21 +2265,21 @@ let get_usedinfo name =
let get_cenum_option name =
let opnamed = func_to_op_func name in
- Hashtbl.fold
- (fun _ ei value ->
- match value with
- | Some(_) as r -> r (* Already found *)
- | None ->
- let rec search = function
- | {einame = n} as ei ::_ when n=name -> Some(CEnum ei)
- | {einame = n} as ei ::_ when n=opnamed -> Some(CEnum ei)
- | _::l -> search l
- | [] -> None
- in
- search ei.eitems
- )
- used_enuminfo
- None
+ Hashtbl.fold
+ (fun _ ei value ->
+ match value with
+ | Some(_) as r -> r (* Already found *)
+ | None ->
+ let rec search = function
+ | {einame = n} as ei ::_ when n=name -> Some(CEnum ei)
+ | {einame = n} as ei ::_ when n=opnamed -> Some(CEnum ei)
+ | _::l -> search l
+ | [] -> None
+ in
+ search ei.eitems
+ )
+ used_enuminfo
+ None
let func_enum_type () =
try TEnum(Hashtbl.find used_enuminfo listOp,[])
@@ -2301,10 +2301,10 @@ let func_to_cenum func =
| {einame = n} as ei ::_ when n=name -> CEnum ei
| _::l -> search l
| [] -> raise_error
- ("Operation '"^name^"' not found in operations enumeration")
+ ("Operation '"^name^"' not found in operations enumeration")
in
- search ei.eitems
- (* CEnum(ex,s,ei)*)
+ search ei.eitems
+ (* CEnum(ex,s,ei)*)
with Not_found -> raise_error ("Operation not found")
let op_status_to_cenum status =
@@ -2316,7 +2316,7 @@ let op_status_to_cenum status =
| _::l -> search l
| [] -> raise_error ("Status not found")
in
- search ei.eitems
+ search ei.eitems
with Not_found -> raise_error ("Status not found")
diff --git a/src/plugins/aorai/data_for_aorai.mli b/src/plugins/aorai/data_for_aorai.mli
index 43040e122ef946a4b0f6712f6ddfbacf388c76d8..f132d7fbc5fad717044bdb2e71bf89339ef8265f 100644
--- a/src/plugins/aorai/data_for_aorai.mli
+++ b/src/plugins/aorai/data_for_aorai.mli
@@ -100,7 +100,7 @@ val is_single: seq_elt -> bool
(** Returns a string guaranteed not to clash with C/ACSL keywords or an
existing global.
@since Nitrogen-20111001
- *)
+*)
val get_fresh: string -> string
(* Logic variables *)
@@ -165,7 +165,7 @@ val macro_pure : string
(** returns the C variable associated to a given state
(non-deterministic mode only).
- *)
+*)
val get_state_var: state -> varinfo
(** returns the logic variable associated to a given state.
@@ -291,20 +291,20 @@ val set_returninfo : string -> Cil_types.varinfo -> unit
If the variable is not found then an error message is print and an assert false is raised. *)
val get_returninfo : string -> Cil_types.varinfo
-(** Given the representation of an auxiliary counter
+(** Given the representation of an auxiliary counter
(found in a {!Promelaast.Counter_incr}), returns the maximal value
that it can take according to the automaton.
- *)
+*)
val find_max_value: Cil_types.term -> Cil_types.term option
(** information we have about the range of values that an auxiliary variable
can take.
- *)
+*)
type range =
| Fixed of int (** constant value *)
| Interval of int * int (** range of values *)
| Bounded of int * Cil_types.term
- (** range bounded by a logic term (depending on program parameter). *)
+ (** range bounded by a logic term (depending on program parameter). *)
| Unbounded of int (** only the lower bound is known,
there is no upper bound *)
| Unknown (** completely unknown relation. *)
@@ -324,7 +324,7 @@ val absolute_range: Cil_types.term -> int -> Range.t
(** Given an auxiliary variable, a base for its variations and two ranges of
variations, returns a range that encompasses both.
- *)
+*)
val merge_range:
Cil_types.term -> Cil_types.term -> Range.t -> Range.t -> Range.t
@@ -332,17 +332,17 @@ val merge_range:
val tlval: Cil_types.term_lval -> Cil_types.term
-(** The propagated state: Mapping from possible start states
- to reachable states, with
- - set of states for the initial transition leading to the corresponding
+(** The propagated state: Mapping from possible start states
+ to reachable states, with
+ - set of states for the initial transition leading to the corresponding
reachable state.
- - set of states for the last transition.
- - possible values for intermediate variables.
- *)
-type end_state =
- (Aorai_state.Set.t * Aorai_state.Set.t * Vals.t) Aorai_state.Map.t
+ - set of states for the last transition.
+ - possible values for intermediate variables.
+*)
+type end_state =
+ (Aorai_state.Set.t * Aorai_state.Set.t * Vals.t) Aorai_state.Map.t
-module Case_state:
+module Case_state:
Datatype.S with type t = end_state Aorai_state.Map.t
type state = Case_state.t
@@ -352,11 +352,11 @@ val pretty_end_state: Aorai_state.t -> Format.formatter -> end_state -> unit
val pretty_state: Format.formatter -> state -> unit
(** [included_state st1 st2] is [true] iff [st1] is included in [st2], i.e:
- - possible start states of [st1] are included in [st2]
- - for each possible start state, reachable states in [st1] are included in
- the one of [st2]
- - for each possible path in [st1], range of possible values for intermediate
- variables are included in the corresponding one in [st2].
+ - possible start states of [st1] are included in [st2]
+ - for each possible start state, reachable states in [st1] are included in
+ the one of [st2]
+ - for each possible path in [st1], range of possible values for intermediate
+ variables are included in the corresponding one in [st2].
*)
val included_state: state -> state -> bool
@@ -373,7 +373,7 @@ val merge_state: state -> state -> state
(** Register a new init state for kernel function.
If there is already an init state registered, the new one is merged with
the old.
- *)
+*)
val set_kf_init_state: Kernel_function.t -> state -> unit
(** Register a new end state for kernel function.
@@ -406,7 +406,7 @@ val get_loop_init_state: Cil_types.stmt -> state
val get_loop_invariant_state: Cil_types.stmt -> state
val debug_computed_state: ?dkey:Aorai_option.category -> unit -> unit
-(** Pretty-prints all computed states. Default key is dataflow. *)
+(** Pretty-prints all computed states. Default key is dataflow. *)
(* ************************************************************************* *)
(**{b Enumeration management}*)
@@ -439,7 +439,7 @@ val get_usedinfo : string -> Cil_types.enuminfo
(** Simplify the automaton by removing transitions and states that are
never active during an execution of the program.
@raise Empty_automaton if the simplification result in an empty automaton.
- *)
+*)
val removeUnusedTransitionsAndStates : unit -> unit
(*
diff --git a/src/plugins/aorai/logic_simplification.ml b/src/plugins/aorai/logic_simplification.ml
index e9afa1fc738dff521b8ceee4646ed011d41db448..a67c23f76f0a8ae0b8c7316c7d66bef83c030089 100644
--- a/src/plugins/aorai/logic_simplification.ml
+++ b/src/plugins/aorai/logic_simplification.ml
@@ -34,65 +34,65 @@ let pretty_dnf fmt l =
Format.fprintf fmt "@[<2>[%a@]]@\n"
(Pretty_utils.pp_list pretty_clause) l
-let opposite_rel =
+let opposite_rel =
function
- | Rlt -> Rge
- | Rgt -> Rle
- | Rge -> Rlt
- | Rle -> Rgt
- | Req -> Rneq
- | Rneq -> Req
-
-let rec condToDNF cond =
+ | Rlt -> Rge
+ | Rgt -> Rle
+ | Rge -> Rlt
+ | Rle -> Rgt
+ | Req -> Rneq
+ | Rneq -> Req
+
+let rec condToDNF cond =
(*Typing : condition --> list of list of terms (disjunction of conjunction of terms)
DNF(term) = {{term}}
- DNF(a or b) = DNF(a) \/ DNF(b)
- DNF(a and b) = Composition (DNF(a),DNF(b))
- DNF(not a) = tmp = DNF(a)
- composition (tmp)
- negation of each term
+ DNF(a or b) = DNF(a) \/ DNF(b)
+ DNF(a and b) = Composition (DNF(a),DNF(b))
+ DNF(not a) = tmp = DNF(a)
+ composition (tmp)
+ negation of each term
*)
match cond with
- | TOr (c1, c2) -> (condToDNF c1)@(condToDNF c2)
- | TAnd (c1, c2) ->
- let d1,d2=(condToDNF c1), (condToDNF c2) in
- List.rev
- (List.fold_left
- (fun lclause clauses1 ->
- (List.map (fun clauses2 -> clauses1@clauses2) d2) @ lclause
- )
- [] d1)
- | TNot (c) ->
- begin
- match c with
- | TOr (c1, c2) -> condToDNF (TAnd(TNot(c1),TNot(c2)))
- | TAnd (c1, c2) -> condToDNF (TOr (TNot(c1),TNot(c2)))
- | TNot (c1) -> condToDNF c1
- | TTrue -> condToDNF TFalse
- | TFalse -> condToDNF TTrue
- | TRel(rel,t1,t2) -> [[TRel(opposite_rel rel,t1,t2)]]
- | _ as t -> [[TNot(t)]]
- end
- | TTrue -> [[TTrue]]
- | TFalse -> []
- | _ as t -> [[t]]
-
-let removeTerm term lterm =
+ | TOr (c1, c2) -> (condToDNF c1)@(condToDNF c2)
+ | TAnd (c1, c2) ->
+ let d1,d2=(condToDNF c1), (condToDNF c2) in
+ List.rev
+ (List.fold_left
+ (fun lclause clauses1 ->
+ (List.map (fun clauses2 -> clauses1@clauses2) d2) @ lclause
+ )
+ [] d1)
+ | TNot (c) ->
+ begin
+ match c with
+ | TOr (c1, c2) -> condToDNF (TAnd(TNot(c1),TNot(c2)))
+ | TAnd (c1, c2) -> condToDNF (TOr (TNot(c1),TNot(c2)))
+ | TNot (c1) -> condToDNF c1
+ | TTrue -> condToDNF TFalse
+ | TFalse -> condToDNF TTrue
+ | TRel(rel,t1,t2) -> [[TRel(opposite_rel rel,t1,t2)]]
+ | _ as t -> [[TNot(t)]]
+ end
+ | TTrue -> [[TTrue]]
+ | TFalse -> []
+ | _ as t -> [[t]]
+
+let removeTerm term lterm =
List.fold_left
- (fun treated t ->
- match term,t with
- | TCall (kf1,None), TCall (kf2,_)
- | TReturn kf1, TReturn kf2
- when Kernel_function.equal kf1 kf2 -> treated
- | TCall(kf1,Some b1), TCall(kf2, Some b2)
- when Kernel_function.equal kf1 kf2 &&
+ (fun treated t ->
+ match term,t with
+ | TCall (kf1,None), TCall (kf2,_)
+ | TReturn kf1, TReturn kf2
+ when Kernel_function.equal kf1 kf2 -> treated
+ | TCall(kf1,Some b1), TCall(kf2, Some b2)
+ when Kernel_function.equal kf1 kf2 &&
Datatype.String.equal b1.b_name b2.b_name -> treated
- | _ -> t::treated)
+ | _ -> t::treated)
[]
lterm
-(** Given a list of terms (representing a conjunction),
- if a positive call or return is present,
+(** Given a list of terms (representing a conjunction),
+ if a positive call or return is present,
then all negative ones are obvious and removed *)
let positiveCallOrRet clause =
try
@@ -100,109 +100,109 @@ let positiveCallOrRet clause =
let positive, computePositive=
List.fold_left
(fun (positive,treated as res) term ->
- match term with
- | TCall (kf1,None) ->
- begin match positive with
- | None -> (Some term, term::treated)
- | Some (TCall (kf2,None)) ->
- if Kernel_function.equal kf1 kf2 then res else raise Exit
- | Some (TReturn _) -> raise Exit
- | Some(TCall (kf2,Some _) as term2) ->
- if Kernel_function.equal kf1 kf2 then
- Some term, term :: removeTerm term2 treated
- else raise Exit
- | _ ->
- Aorai_option.fatal
- "inconsistent environment in positiveCallOrRet"
- end
- | TCall (kf1, Some b1) ->
- begin match positive with
- | None -> (Some term, term::treated)
- | Some (TCall (kf2,None)) ->
- if Kernel_function.equal kf1 kf2 then res else raise Exit
- | Some (TReturn _) -> raise Exit
- | Some(TCall (kf2,Some b2)) ->
- if Kernel_function.equal kf1 kf2 then
- if Datatype.String.equal b1.b_name b2.b_name then
- res
- else
- positive, term :: treated
- else raise Exit
- | _ ->
- Aorai_option.fatal
- "inconsistent environment in positiveCallOrRet"
- end
- | TReturn kf1 ->
- begin match positive with
- | None -> (Some term, term::treated)
- | Some (TReturn kf2) ->
- if Kernel_function.equal kf1 kf2 then res else raise Exit
- | Some (TCall _) -> raise Exit
- | _ ->
- Aorai_option.fatal
- "inconsistent environment in positiveCallOrRet"
- end
- | _ -> positive, term::treated
+ match term with
+ | TCall (kf1,None) ->
+ begin match positive with
+ | None -> (Some term, term::treated)
+ | Some (TCall (kf2,None)) ->
+ if Kernel_function.equal kf1 kf2 then res else raise Exit
+ | Some (TReturn _) -> raise Exit
+ | Some(TCall (kf2,Some _) as term2) ->
+ if Kernel_function.equal kf1 kf2 then
+ Some term, term :: removeTerm term2 treated
+ else raise Exit
+ | _ ->
+ Aorai_option.fatal
+ "inconsistent environment in positiveCallOrRet"
+ end
+ | TCall (kf1, Some b1) ->
+ begin match positive with
+ | None -> (Some term, term::treated)
+ | Some (TCall (kf2,None)) ->
+ if Kernel_function.equal kf1 kf2 then res else raise Exit
+ | Some (TReturn _) -> raise Exit
+ | Some(TCall (kf2,Some b2)) ->
+ if Kernel_function.equal kf1 kf2 then
+ if Datatype.String.equal b1.b_name b2.b_name then
+ res
+ else
+ positive, term :: treated
+ else raise Exit
+ | _ ->
+ Aorai_option.fatal
+ "inconsistent environment in positiveCallOrRet"
+ end
+ | TReturn kf1 ->
+ begin match positive with
+ | None -> (Some term, term::treated)
+ | Some (TReturn kf2) ->
+ if Kernel_function.equal kf1 kf2 then res else raise Exit
+ | Some (TCall _) -> raise Exit
+ | _ ->
+ Aorai_option.fatal
+ "inconsistent environment in positiveCallOrRet"
+ end
+ | _ -> positive, term::treated
)
(None, [])
clause
in
let computePositive = List.rev computePositive in
(* Step 2 : Remove negatives not enough expressive *)
- match positive with
- | None -> computePositive
- | Some (TCall (kf1,None)) ->
- List.rev
- (List.fold_left
- (fun treated term ->
- match term with
- | TNot(TCall (kf2,_)) ->
- if Kernel_function.equal kf1 kf2 then raise Exit
- (* Positive information more specific than negative *)
- else treated
- | TNot(TReturn _) -> treated
- | _ -> term::treated
- )
- [] computePositive)
- | Some (TCall (kf1, Some b1)) ->
- List.rev
- (List.fold_left
- (fun treated term ->
- match term with
- | TNot(TCall (kf2,None)) ->
- if Kernel_function.equal kf1 kf2 then raise Exit
- (* Positive information more specific than negative *)
- else treated
- | TNot(TCall(kf2, Some b2)) ->
- if Kernel_function.equal kf1 kf2 then
- if Datatype.String.equal b1.b_name b2.b_name then
- raise Exit
- else term :: treated
- else treated
- | TNot(TReturn _) -> treated
- | _ -> term::treated
- )
- [] computePositive)
- | Some (TReturn kf1) ->
- List.rev
- (List.fold_left
- (fun treated term ->
- match term with
- | TNot(TCall _) -> treated
- | TNot(TReturn kf2) ->
- (* Two opposite information *)
- if Kernel_function.equal kf1 kf2 then raise Exit
- else treated
- | _ -> term::treated
- )
- [] computePositive)
- | _ ->
- Aorai_option.fatal "inconsistent environment in positiveCallOrRet"
+ match positive with
+ | None -> computePositive
+ | Some (TCall (kf1,None)) ->
+ List.rev
+ (List.fold_left
+ (fun treated term ->
+ match term with
+ | TNot(TCall (kf2,_)) ->
+ if Kernel_function.equal kf1 kf2 then raise Exit
+ (* Positive information more specific than negative *)
+ else treated
+ | TNot(TReturn _) -> treated
+ | _ -> term::treated
+ )
+ [] computePositive)
+ | Some (TCall (kf1, Some b1)) ->
+ List.rev
+ (List.fold_left
+ (fun treated term ->
+ match term with
+ | TNot(TCall (kf2,None)) ->
+ if Kernel_function.equal kf1 kf2 then raise Exit
+ (* Positive information more specific than negative *)
+ else treated
+ | TNot(TCall(kf2, Some b2)) ->
+ if Kernel_function.equal kf1 kf2 then
+ if Datatype.String.equal b1.b_name b2.b_name then
+ raise Exit
+ else term :: treated
+ else treated
+ | TNot(TReturn _) -> treated
+ | _ -> term::treated
+ )
+ [] computePositive)
+ | Some (TReturn kf1) ->
+ List.rev
+ (List.fold_left
+ (fun treated term ->
+ match term with
+ | TNot(TCall _) -> treated
+ | TNot(TReturn kf2) ->
+ (* Two opposite information *)
+ if Kernel_function.equal kf1 kf2 then raise Exit
+ else treated
+ | _ -> term::treated
+ )
+ [] computePositive)
+ | _ ->
+ Aorai_option.fatal "inconsistent environment in positiveCallOrRet"
with Exit -> [TFalse] (* contradictory requirements for current event. *)
let rel_are_equals (rel1,t11,t12) (rel2,t21,t22) =
- rel1 = rel2
- && Logic_utils.is_same_term t11 t21
+ rel1 = rel2
+ && Logic_utils.is_same_term t11 t21
&& Logic_utils.is_same_term t12 t22
let swap_rel (rel,t1,t2) =
@@ -221,27 +221,27 @@ let contradict_rel r1 (rel2,t21,t22) =
let rec termsAreEqual term1 term2 =
match term1,term2 with
- | TTrue,TTrue
- | TFalse,TFalse -> true
- | TCall (a,None), TCall (b,None)
- | TReturn a, TReturn b -> Kernel_function.equal a b
- | TCall (f1,Some b1), TCall(f2, Some b2) ->
- Kernel_function.equal f1 f2 && Datatype.String.equal b1.b_name b2.b_name
- | TNot(TRel(rel1,t11,t12)), TRel(rel2,t21,t22)
- | TRel(rel1,t11,t12), TNot(TRel(rel2,t21,t22)) ->
- contradict_rel (rel1,t11,t12) (rel2,t21,t22)
- | TNot(a),TNot(b) -> termsAreEqual a b
- | TRel(rel1,t11,t12), TRel(rel2,t21,t22) ->
- rel_are_equals (rel1,t11,t12) (rel2,t21,t22)
- | _ -> false
+ | TTrue,TTrue
+ | TFalse,TFalse -> true
+ | TCall (a,None), TCall (b,None)
+ | TReturn a, TReturn b -> Kernel_function.equal a b
+ | TCall (f1,Some b1), TCall(f2, Some b2) ->
+ Kernel_function.equal f1 f2 && Datatype.String.equal b1.b_name b2.b_name
+ | TNot(TRel(rel1,t11,t12)), TRel(rel2,t21,t22)
+ | TRel(rel1,t11,t12), TNot(TRel(rel2,t21,t22)) ->
+ contradict_rel (rel1,t11,t12) (rel2,t21,t22)
+ | TNot(a),TNot(b) -> termsAreEqual a b
+ | TRel(rel1,t11,t12), TRel(rel2,t21,t22) ->
+ rel_are_equals (rel1,t11,t12) (rel2,t21,t22)
+ | _ -> false
let negative_term term =
match term with
- | TNot(c) -> c
- | TCall _ | TReturn _ | TRel _ -> TNot term
- | TTrue -> TFalse
- | TFalse -> TTrue
- | TAnd (_,_) | TOr (_,_) -> Aorai_option.fatal "not a term of DNF clause"
+ | TNot(c) -> c
+ | TCall _ | TReturn _ | TRel _ -> TNot term
+ | TTrue -> TFalse
+ | TFalse -> TTrue
+ | TAnd (_,_) | TOr (_,_) -> Aorai_option.fatal "not a term of DNF clause"
(** Simplify redundant relations. *)
let simplify clause =
@@ -249,26 +249,26 @@ let simplify clause =
List.rev
(List.fold_left
(fun clause term ->
- match term with
- | TTrue | TNot(TFalse) -> clause
- | TFalse | TNot(TTrue) -> raise Exit
- | _ ->
- if List.exists (termsAreEqual (negative_term term)) clause
- then raise Exit;
- if List.exists (termsAreEqual term) clause then clause
- else term :: clause)
+ match term with
+ | TTrue | TNot(TFalse) -> clause
+ | TFalse | TNot(TTrue) -> raise Exit
+ | _ ->
+ if List.exists (termsAreEqual (negative_term term)) clause
+ then raise Exit;
+ if List.exists (termsAreEqual term) clause then clause
+ else term :: clause)
[] clause)
with Exit -> [TFalse]
(** true iff clause1 <: clause2*)
-let clausesAreSubSetEq clause1 clause2 =
- (List.for_all
+let clausesAreSubSetEq clause1 clause2 =
+ (List.for_all
(fun t1 ->List.exists ( fun t2 -> termsAreEqual t1 t2) clause2)
- clause1)
+ clause1)
(** true iff clause1 <: clause2 and clause2 <: clause1 *)
-let clausesAreEqual clause1 clause2 =
+let clausesAreEqual clause1 clause2 =
clausesAreSubSetEq clause1 clause2 && clausesAreSubSetEq clause2 clause1
(** return the clauses list named lclauses without any clause c such as cl <: c *)
@@ -282,94 +282,94 @@ let simplifyClauses clauses =
try
List.rev
(List.fold_left
- (fun acc c ->
- (* If 2 clauses are C and not C then their disjunction implies true *)
- if List.exists (clausesAreEqual (negativeClause c)) acc then
- raise Exit
- (* If an observed clause c2 is included inside the current clause
- then the current is not added *)
- else if (List.exists (fun c2 -> clausesAreSubSetEq c2 c) acc) then
- acc
- (* If the current clause is included inside an observed clause
- c2 then the current is added and c2 is removed *)
- else if (List.exists (fun c2 -> clausesAreSubSetEq c c2) acc) then
- c::(removeClause acc c)
- (* If no simplification then c is add to the list *)
- else c::acc
- )
- [] clauses)
+ (fun acc c ->
+ (* If 2 clauses are C and not C then their disjunction implies true *)
+ if List.exists (clausesAreEqual (negativeClause c)) acc then
+ raise Exit
+ (* If an observed clause c2 is included inside the current clause
+ then the current is not added *)
+ else if (List.exists (fun c2 -> clausesAreSubSetEq c2 c) acc) then
+ acc
+ (* If the current clause is included inside an observed clause
+ c2 then the current is added and c2 is removed *)
+ else if (List.exists (fun c2 -> clausesAreSubSetEq c c2) acc) then
+ c::(removeClause acc c)
+ (* If no simplification then c is add to the list *)
+ else c::acc
+ )
+ [] clauses)
with Exit -> [[]]
let tor t1 t2 =
match t1,t2 with
- TTrue,_ | _,TTrue -> TTrue
- | TFalse,t | t,TFalse -> t
- | _,_ -> TOr(t1,t2)
+ TTrue,_ | _,TTrue -> TTrue
+ | TFalse,t | t,TFalse -> t
+ | _,_ -> TOr(t1,t2)
let tand t1 t2 =
match t1,t2 with
- TTrue,t | t,TTrue -> t
- | TFalse,_ | _,TFalse -> TFalse
- | _,_ -> TAnd(t1,t2)
+ TTrue,t | t,TTrue -> t
+ | TFalse,_ | _,TFalse -> TFalse
+ | _,_ -> TAnd(t1,t2)
let has_result t =
let module M = struct exception Has_result end in
let vis = object
- inherit Visitor.frama_c_inplace
- method! vterm_lhost = function
- | TResult _ -> raise M.Has_result
- | _ -> Cil.DoChildren
- end
+ inherit Visitor.frama_c_inplace
+ method! vterm_lhost = function
+ | TResult _ -> raise M.Has_result
+ | _ -> Cil.DoChildren
+ end
in
try ignore (Visitor.visitFramacTerm vis t); false
with M.Has_result -> true
let rec tnot t =
match t with
- | TTrue -> TFalse
- | TFalse -> TTrue
- | TNot t -> t
- (* If relation uses \result, keep information about which function
- is returning close to it. *)
- | TAnd ((TReturn _ as t1), (TRel (_,op1,op2) as t2))
- when has_result op1 || has_result op2 ->
- TOr (tnot t1, TAnd (t1, tnot t2))
- | TAnd (t1,t2) -> TOr(tnot t1, tnot t2)
- | TOr (t1,t2) -> TAnd(tnot t1, tnot t2)
- | TRel(rel,t1,t2) -> TRel(opposite_rel rel, t1, t2)
- | TCall _ | TReturn _ -> TNot t
+ | TTrue -> TFalse
+ | TFalse -> TTrue
+ | TNot t -> t
+ (* If relation uses \result, keep information about which function
+ is returning close to it. *)
+ | TAnd ((TReturn _ as t1), (TRel (_,op1,op2) as t2))
+ when has_result op1 || has_result op2 ->
+ TOr (tnot t1, TAnd (t1, tnot t2))
+ | TAnd (t1,t2) -> TOr(tnot t1, tnot t2)
+ | TOr (t1,t2) -> TAnd(tnot t1, tnot t2)
+ | TRel(rel,t1,t2) -> TRel(opposite_rel rel, t1, t2)
+ | TCall _ | TReturn _ -> TNot t
let tands l = List.fold_right tand l TTrue
let tors l = List.fold_right tor l TFalse
-(** Given a DNF condition, it returns a condition in Promelaast.condition form.
+(** Given a DNF condition, it returns a condition in Promelaast.condition form.
WARNING : empty lists not supported
*)
let dnfToCond d = tors (List.map tands d)
let simplClause clause dnf =
match clause with
- | [] | [TTrue] | [TNot TFalse]-> [[]]
- | [TFalse] | [TNot TTrue] -> dnf
- | _ -> clause :: dnf
+ | [] | [TTrue] | [TNot TFalse]-> [[]]
+ | [TFalse] | [TNot TTrue] -> dnf
+ | _ -> clause :: dnf
-(** Given a condition, this function does some logical simplifications.
- It returns both the simplified condition and a disjunction of
+(** Given a condition, this function does some logical simplifications.
+ It returns both the simplified condition and a disjunction of
conjunctions of parametrized call or return.
*)
let simplifyCond condition =
- Aorai_option.debug
+ Aorai_option.debug
"initial condition: %a" Promelaoutput.Typed.print_condition condition;
(* Step 1 : Condition is translate into Disjunctive Normal Form *)
- let res1 = condToDNF condition in
+ let res1 = condToDNF condition in
Aorai_option.debug "initial dnf: %a" pretty_dnf res1;
(* Step 2 : Positive Call/Ret are used to simplify negative ones *)
- let res =
+ let res =
List.rev
(List.fold_left
(fun lclauses clause ->
- simplClause (positiveCallOrRet clause) lclauses)
+ simplClause (positiveCallOrRet clause) lclauses)
[] res1)
in
Aorai_option.debug "after step 2: %a" pretty_dnf res;
@@ -380,62 +380,62 @@ let simplifyCond condition =
(fun lclauses clause -> simplClause (simplify clause) lclauses) [] res)
in
Aorai_option.debug "after step 3: %a" pretty_dnf res;
-
+
(* Step 4 : simplification between clauses *)
- let res = simplifyClauses res in
+ let res = simplifyClauses res in
Aorai_option.debug "after step 4: %a" pretty_dnf res;
((dnfToCond res), res)
(** Given a list of transitions, this function returns the same list of
- transition with simplifyCond done on its cross condition *)
+ transition with simplifyCond done on its cross condition *)
let simplifyTrans transl =
- List.fold_left
- (fun (ltr,lpcond) tr ->
- let (crossCond , pcond ) = simplifyCond (tr.cross) in
- (* pcond stands for parametrized condition :
+ List.fold_left
+ (fun (ltr,lpcond) tr ->
+ let (crossCond , pcond ) = simplifyCond (tr.cross) in
+ (* pcond stands for parametrized condition :
disjunction of conjunctions of parametrized call/return *)
- let tr'= { tr with cross = crossCond } in
- Aorai_option.debug "condition is %a, dnf is %a"
- Promelaoutput.Typed.print_condition crossCond pretty_dnf pcond;
- if tr'.cross <> TFalse then (tr'::ltr,pcond::lpcond) else (ltr,lpcond)
- )
- ([],[])
+ let tr'= { tr with cross = crossCond } in
+ Aorai_option.debug "condition is %a, dnf is %a"
+ Promelaoutput.Typed.print_condition crossCond pretty_dnf pcond;
+ if tr'.cross <> TFalse then (tr'::ltr,pcond::lpcond) else (ltr,lpcond)
+ )
+ ([],[])
(List.rev transl)
-(** Given a DNF condition, it returns the same condition simplified according
- to the context (function name and status). Hence, the returned condition
- is without any Call/Return stmts.
+(** Given a DNF condition, it returns the same condition simplified according
+ to the context (function name and status). Hence, the returned condition
+ is without any Call/Return stmts.
*)
let simplifyDNFwrtCtx dnf kf1 status =
Aorai_option.debug "Before simplification: %a" pretty_dnf dnf;
let rec simplCondition c =
match c with
- | TCall (kf2, None) ->
- if Kernel_function.equal kf1 kf2 && status = Promelaast.Call then
- TTrue
- else TFalse
- | TCall (kf2, Some _) ->
- if Kernel_function.equal kf1 kf2 && status = Promelaast.Call then
- c
- else TFalse
- | TReturn kf2 ->
- if Kernel_function.equal kf1 kf2 && status = Promelaast.Return then
- TTrue
- else TFalse
- | TNot c -> tnot (simplCondition c)
- | TAnd(c1,c2) -> tand (simplCondition c1) (simplCondition c2)
- | TOr (c1,c2) -> tor (simplCondition c1) (simplCondition c2)
- | TTrue | TFalse | TRel _ -> c
+ | TCall (kf2, None) ->
+ if Kernel_function.equal kf1 kf2 && status = Promelaast.Call then
+ TTrue
+ else TFalse
+ | TCall (kf2, Some _) ->
+ if Kernel_function.equal kf1 kf2 && status = Promelaast.Call then
+ c
+ else TFalse
+ | TReturn kf2 ->
+ if Kernel_function.equal kf1 kf2 && status = Promelaast.Return then
+ TTrue
+ else TFalse
+ | TNot c -> tnot (simplCondition c)
+ | TAnd(c1,c2) -> tand (simplCondition c1) (simplCondition c2)
+ | TOr (c1,c2) -> tor (simplCondition c1) (simplCondition c2)
+ | TTrue | TFalse | TRel _ -> c
in
let simplCNFwrtCtx cnf =
tands (List.map simplCondition cnf)
in
let res = tors (List.map simplCNFwrtCtx dnf) in
- Aorai_option.debug
+ Aorai_option.debug
"After simplification: %a" Promelaoutput.Typed.print_condition res; res
(*
-Tests :
+Tests :
Working :
==========
@@ -485,5 +485,3 @@ Local Variables:
compile-command: "make -C ../../.."
End:
*)
-
-
diff --git a/src/plugins/aorai/logic_simplification.mli b/src/plugins/aorai/logic_simplification.mli
index 725be670273c2d43c4ee7367136981ce81452d74..15551a19d55941b9fdf11316b6e3335ad1da3a7a 100644
--- a/src/plugins/aorai/logic_simplification.mli
+++ b/src/plugins/aorai/logic_simplification.mli
@@ -37,23 +37,23 @@ val tnot: typed_condition -> typed_condition
(** Given a condition, this function does some logical simplifications
and returns an equivalent DNF form together with the simplified version *)
-val simplifyCond:
- Promelaast.typed_condition ->
+val simplifyCond:
+ Promelaast.typed_condition ->
Promelaast.typed_condition *(Promelaast.typed_condition list list)
(** Given a transition list, this function returns the same transition list with
simplifyCond done on each cross condition. Uncrossable transition are
- removed. *)
-val simplifyTrans:
+ removed. *)
+val simplifyTrans:
Promelaast.typed_trans list ->
(Promelaast.typed_trans list)*
- (Promelaast.typed_condition list list list)
+ (Promelaast.typed_condition list list list)
-val dnfToCond :
+val dnfToCond :
(Promelaast.typed_condition list list) -> Promelaast.typed_condition
-val simplifyDNFwrtCtx :
- Promelaast.typed_condition list list -> Cil_types.kernel_function ->
+val simplifyDNFwrtCtx :
+ Promelaast.typed_condition list list -> Cil_types.kernel_function ->
Promelaast.funcStatus -> Promelaast.typed_condition
(*
diff --git a/src/plugins/aorai/ltl_output.ml b/src/plugins/aorai/ltl_output.ml
index 5f6d155c4c5c1778622d4f79486b210e65035fbe..13d5e24ac147b6f58c742c447c858643af8c0973 100644
--- a/src/plugins/aorai/ltl_output.ml
+++ b/src/plugins/aorai/ltl_output.ml
@@ -29,50 +29,50 @@ open Ltlast
let out_fmt=ref (formatter_of_out_channel stdout)
let rec ltl_form_to_string = function
- | LNext (f) ->
- "X("^(ltl_form_to_string f)^")"
- | LUntil (f1,f2) ->
- "("^(ltl_form_to_string f1)^" U "^(ltl_form_to_string f2)^")"
- | LFatally (f) ->
- "<>("^(ltl_form_to_string f)^")"
- | LGlobally (f) ->
- "[]("^(ltl_form_to_string f)^")"
- | LRelease (f1,f2) ->
- "("^(ltl_form_to_string f1)^" V "^(ltl_form_to_string f2)^")"
+ | LNext (f) ->
+ "X("^(ltl_form_to_string f)^")"
+ | LUntil (f1,f2) ->
+ "("^(ltl_form_to_string f1)^" U "^(ltl_form_to_string f2)^")"
+ | LFatally (f) ->
+ "<>("^(ltl_form_to_string f)^")"
+ | LGlobally (f) ->
+ "[]("^(ltl_form_to_string f)^")"
+ | LRelease (f1,f2) ->
+ "("^(ltl_form_to_string f1)^" V "^(ltl_form_to_string f2)^")"
- | LNot (f) ->
- "!("^(ltl_form_to_string f)^")"
- | LAnd (f1,f2) ->
- "("^(ltl_form_to_string f1)^" && "^(ltl_form_to_string f2)^")"
- | LOr (f1,f2) ->
- "("^(ltl_form_to_string f1)^" || "^(ltl_form_to_string f2)^")"
- | LImplies (f1,f2) ->
- "("^(ltl_form_to_string f1)^" -> "^(ltl_form_to_string f2)^")"
- | LIff (f1,f2) ->
- "("^(ltl_form_to_string f1)^" <-> "^(ltl_form_to_string f2)^")"
+ | LNot (f) ->
+ "!("^(ltl_form_to_string f)^")"
+ | LAnd (f1,f2) ->
+ "("^(ltl_form_to_string f1)^" && "^(ltl_form_to_string f2)^")"
+ | LOr (f1,f2) ->
+ "("^(ltl_form_to_string f1)^" || "^(ltl_form_to_string f2)^")"
+ | LImplies (f1,f2) ->
+ "("^(ltl_form_to_string f1)^" -> "^(ltl_form_to_string f2)^")"
+ | LIff (f1,f2) ->
+ "("^(ltl_form_to_string f1)^" <-> "^(ltl_form_to_string f2)^")"
- | LTrue ->
- "1"
- | LFalse ->
- "0"
+ | LTrue ->
+ "1"
+ | LFalse ->
+ "0"
- | LCall (s) ->
- "callof_"^s
- | LReturn (s) ->
- "returnof_"^s
- | LCallOrReturn (s) ->
- "callorreturnof_"^s
+ | LCall (s) ->
+ "callof_"^s
+ | LReturn (s) ->
+ "returnof_"^s
+ | LCallOrReturn (s) ->
+ "callorreturnof_"^s
- | LIdent (s) ->
- s
+ | LIdent (s) ->
+ s
let output ltl_form file =
let c = open_out file in
- out_fmt:=formatter_of_out_channel c ;
- fprintf !out_fmt "%s\n\n" (ltl_form_to_string ltl_form);
- fprintf !out_fmt "@?"; (* Flush du flux *)
- close_out c;
- out_fmt:=formatter_of_out_channel stdout
+ out_fmt:=formatter_of_out_channel c ;
+ fprintf !out_fmt "%s\n\n" (ltl_form_to_string ltl_form);
+ fprintf !out_fmt "@?"; (* Flush du flux *)
+ close_out c;
+ out_fmt:=formatter_of_out_channel stdout
(*
Local Variables:
diff --git a/src/plugins/aorai/path_analysis.ml b/src/plugins/aorai/path_analysis.ml
index d9afc0d49c1dcbe7d464229e7313878727f3fdce..0ce2ab315a4b9f0f878e5528343fa7f60edfc266 100644
--- a/src/plugins/aorai/path_analysis.ml
+++ b/src/plugins/aorai/path_analysis.ml
@@ -26,34 +26,34 @@
open Promelaast
(*open Graph.Pack.Digraph
-let st_array = ref (Array.make 1 (V.create 0)) ;;
+ let st_array = ref (Array.make 1 (V.create 0)) ;;
-let auto2digraph (stl,trl) =
+ let auto2digraph (stl,trl) =
Aorai_option.feedback "auto2digraph:" ;
let digraph = create () in
st_array:= Array.make (List.length stl) (V.create 0);
Aorai_option.feedback " array : ok\n" ;
let _ = List.iter
- (fun st ->
+ (fun st ->
(!st_array).(st.nums)<-(V.create st.nums);
add_vertex digraph (!st_array).(st.nums)
)
- stl
+ stl
in
Aorai_option.feedback " array remplissage : ok\n" ;
- List.iter
+ List.iter
(fun tr -> add_edge digraph (V.create tr.start.nums) (V.create tr.stop.nums))
trl;
digraph
-;;
-
-
-let existing_path auto st1 st2 =
+ ;;
+
+
+ let existing_path auto st1 st2 =
Aorai_option.feedback "existing path ..\n" ;
let digraph = auto2digraph auto in
- let start = (!st_array).(st1.nums) in
- let stop = (!st_array).(st2.nums) in
+ let start = (!st_array).(st1.nums) in
+ let stop = (!st_array).(st2.nums) in
Aorai_option.feedback "%s" ("test : Etats choisis ("^(string_of_int (V.label start))^","^(string_of_int (V.label stop))^")\n") ;
display_with_gv digraph;
@@ -63,16 +63,16 @@ let existing_path auto st1 st2 =
let path=shortest_path digraph start stop in
Aorai_option.feedback "done.\n" ;
path
-;;
+ ;;
-let test (stl,trl) =
+ let test (stl,trl) =
let st2 = List.hd stl in
let st1 = List.hd (List.tl stl) in
-
+
let _ = existing_path (stl,trl) st1 st2 in
Aorai_option.feedback "Fini.\n" ;
()
-;;
+ ;;
*)
let voisins (_,trans_l) st =
@@ -84,21 +84,21 @@ let voisins (_,trans_l) st =
let empty () = [] ;;
let is_empty heap = (List.length heap)=0 ;;
let add (length,(st,path)) heap = (length,(st,path))::heap ;;
-let extract_min heap =
- let (min,h) =
+let extract_min heap =
+ let (min,h) =
List.fold_left
- (fun ((lmin,min),h) (lcur,cur) ->
+ (fun ((lmin,min),h) (lcur,cur) ->
if lmin<=lcur then
- ((lmin,min),(lcur,cur)::h)
+ ((lmin,min),(lcur,cur)::h)
else
- ((lcur,cur),(lmin,min)::h)
+ ((lcur,cur),(lmin,min)::h)
)
((List.hd heap),[])
(List.tl heap)
in
(min,h)
-
-
+
+
(* Source : wikipedia*)
@@ -109,19 +109,19 @@ let dijkstra (adj: 'a -> ('a * int) list) (v1:'a) (v2:'a) =
let rec loop h =
if is_empty h then raise Not_found;
let (w,(v,p)),h = extract_min h in
- if v = v2 then
- List.rev p, w
- else
- let h =
- if not (Hashtbl.mem visited v) then begin
- Hashtbl.add visited v ();
- List.fold_left (fun h (e,d) -> add (w+d, (e, e::p)) h) h (adj v)
- end else
- h
- in
- loop h
+ if v = v2 then
+ List.rev p, w
+ else
+ let h =
+ if not (Hashtbl.mem visited v) then begin
+ Hashtbl.add visited v ();
+ List.fold_left (fun h (e,d) -> add (w+d, (e, e::p)) h) h (adj v)
+ end else
+ h
+ in
+ loop h
in
- loop (add (0,(v1,[])) (empty()))
+ loop (add (0,(v1,[])) (empty()))
@@ -129,18 +129,18 @@ let dijkstra (adj: 'a -> ('a * int) list) (v1:'a) (v2:'a) =
let existing_path (stl,_ as auto) stn1 stn2 =
let st1 = ref (List.hd stl) in
let st2 = ref (List.hd stl) in
- List.iter
- (fun st ->
+ List.iter
+ (fun st ->
if st.nums=stn1 then st1:=st;
if st.nums=stn2 then st2:=st;
)
stl;
-
+
try
let _ = dijkstra (voisins auto) !st1 !st2 in
true
- with
- | Not_found -> false
+ with
+ | Not_found -> false
;;
@@ -148,13 +148,13 @@ let existing_path (stl,_ as auto) stn1 stn2 =
let get_transitions_of_state st (_,tr) =
List.fold_left
(fun acc tr ->
- if tr.start.nums = st.nums then tr::acc else acc)
+ if tr.start.nums = st.nums then tr::acc else acc)
[] tr
let get_transitions_to_state st (_,tr) =
List.fold_left
(fun acc tr ->
- if tr.stop.nums = st.nums then tr::acc else acc)
+ if tr.stop.nums = st.nums then tr::acc else acc)
[] tr
let get_edges st1 st2 (_,tr) =
@@ -168,17 +168,17 @@ let at_most_one_path (states,transitions as auto) st1 st2 =
try
let path,_ = dijkstra (voisins auto) st1 st2 in
match path with
- | [] | [ _ ] -> true
- | x::y::_ ->
- let (trans1,trans2) =
- List.partition
- (fun t -> t.start.nums = x.nums && t.stop.nums = y.nums)
- transitions
- in
- let transitions = (List.tl trans1) @ trans2 in
- let auto = states, transitions in
- ignore (dijkstra (voisins auto) st1 st2);
- false
+ | [] | [ _ ] -> true
+ | x::y::_ ->
+ let (trans1,trans2) =
+ List.partition
+ (fun t -> t.start.nums = x.nums && t.stop.nums = y.nums)
+ transitions
+ in
+ let transitions = (List.tl trans1) @ trans2 in
+ let auto = states, transitions in
+ ignore (dijkstra (voisins auto) st1 st2);
+ false
with Not_found -> true
let test (stl,_ as auto) =
diff --git a/src/plugins/aorai/utils_parser.ml b/src/plugins/aorai/utils_parser.ml
index d9b243618eb702fc8fa1408e4f8fa89a8a2e471e..819ae335d6fa9032c9d849097025b71066c5025f 100644
--- a/src/plugins/aorai/utils_parser.ml
+++ b/src/plugins/aorai/utils_parser.ml
@@ -25,16 +25,16 @@
let rec get_last_field my_field my_offset =
match my_offset with
- | Cil_types.NoOffset -> my_field
- | Cil_types.Field(fieldinfo,the_offset) -> get_last_field fieldinfo the_offset
- | _ -> Aorai_option.fatal "NOT YET IMPLEMENTED : struct with array access."
+ | Cil_types.NoOffset -> my_field
+ | Cil_types.Field(fieldinfo,the_offset) -> get_last_field fieldinfo the_offset
+ | _ -> Aorai_option.fatal "NOT YET IMPLEMENTED : struct with array access."
let rec add_offset father_offset new_offset =
match father_offset with
- | Cil_types.NoOffset -> new_offset
- | Cil_types.Field(_,the_offset) -> (Cil.addOffset father_offset (add_offset the_offset new_offset))
- | _ -> Aorai_option.fatal "NOT YET IMPLEMENTED : struct with array access."
+ | Cil_types.NoOffset -> new_offset
+ | Cil_types.Field(_,the_offset) -> (Cil.addOffset father_offset (add_offset the_offset new_offset))
+ | _ -> Aorai_option.fatal "NOT YET IMPLEMENTED : struct with array access."
@@ -50,33 +50,33 @@ let rec get_field_info_from_name my_list name =
let get_new_offset my_host my_offset name=
match my_host with
- | Cil_types.Var(var) ->
- let var_info = var in
- (* if my_offset is null no need to search the last field *)
- (* else we need to have the last *)
+ | Cil_types.Var(var) ->
+ let var_info = var in
+ (* if my_offset is null no need to search the last field *)
+ (* else we need to have the last *)
- let my_comp =
- if (my_offset = Cil_types.NoOffset) then
- match var_info.Cil_types.vtype with
- | Cil_types.TComp(mc,_,_) -> mc
- | _ -> assert false
- (*Cil_types.TComp(my_comp,_,_) = var_info.Cil_types.vtype in*)
+ let my_comp =
+ if (my_offset = Cil_types.NoOffset) then
+ match var_info.Cil_types.vtype with
+ | Cil_types.TComp(mc,_,_) -> mc
+ | _ -> assert false
+ (*Cil_types.TComp(my_comp,_,_) = var_info.Cil_types.vtype in*)
- else begin
- let get_field_from_offset my_offset = begin
- match my_offset with
- | Cil_types.Field(fieldinfo,_) -> fieldinfo
- | _ -> Aorai_option.fatal "support only struct no array with struct"
- end in
- let field_info = get_field_from_offset my_offset in
- let last_field_offset = get_last_field field_info my_offset in
- (* last field in offset but not the field we want, for that we search in*)
- let mc = last_field_offset.Cil_types.fcomp in
- mc
- end
- in
- let cfields = Option.value ~default:[] my_comp.Cil_types.cfields in
- let field_info = get_field_info_from_name cfields name in
- Cil_types.Field(field_info,Cil_types.NoOffset)
+ else begin
+ let get_field_from_offset my_offset = begin
+ match my_offset with
+ | Cil_types.Field(fieldinfo,_) -> fieldinfo
+ | _ -> Aorai_option.fatal "support only struct no array with struct"
+ end in
+ let field_info = get_field_from_offset my_offset in
+ let last_field_offset = get_last_field field_info my_offset in
+ (* last field in offset but not the field we want, for that we search in*)
+ let mc = last_field_offset.Cil_types.fcomp in
+ mc
+ end
+ in
+ let cfields = Option.value ~default:[] my_comp.Cil_types.cfields in
+ let field_info = get_field_info_from_name cfields name in
+ Cil_types.Field(field_info,Cil_types.NoOffset)
- | _ -> Aorai_option.fatal "NOT YET IMPLEMENTED : mem is not supported"
+ | _ -> Aorai_option.fatal "NOT YET IMPLEMENTED : mem is not supported"
diff --git a/src/plugins/callgraph/callgraph_api.mli b/src/plugins/callgraph/callgraph_api.mli
index 2eaf5ffbfb201629476a0d35fcda0116c613111f..3bf0256c73dceed2534fe026b8fc1f3c0dfd1376 100644
--- a/src/plugins/callgraph/callgraph_api.mli
+++ b/src/plugins/callgraph/callgraph_api.mli
@@ -50,13 +50,13 @@ end
(** Signature for a callgraph. Each edge is labeled by the callsite. Its source
is the caller, while the destination is the callee. *)
module type S = Graph with type G.V.t = Kernel_function.t
- and type G.E.label = Cil_types.stmt
+ and type G.E.label = Cil_types.stmt
(** Signature for a graph of services *)
module type Services = sig
include Graph with type G.V.t = Kernel_function.t Service_graph.vertex
- and type G.E.label = Service_graph.edge
+ and type G.E.label = Service_graph.edge
val entry_point: unit -> G.V.t option
val is_root: Kernel_function.t -> bool
diff --git a/src/plugins/callgraph/cg.ml b/src/plugins/callgraph/cg.ml
index 4593f34eb37c0d46c076856687d582b72f88d114..8781cee00fb4eb8b00afeb2abcd53697894cdcc5 100644
--- a/src/plugins/callgraph/cg.ml
+++ b/src/plugins/callgraph/cg.ml
@@ -62,9 +62,9 @@ module State =
State_builder.Option_ref
(D)
(struct
- let name = "Callgraph.Cg"
- let dependencies = [ Db.Value.self; Globals.Functions.self ]
- end)
+ let name = "Callgraph.Cg"
+ let dependencies = [ Db.Value.self; Globals.Functions.self ]
+ end)
let self = State.self
let is_computed () = State.is_computed ()
@@ -80,16 +80,16 @@ let get_pointed_kfs =
let o = object
inherit Visitor.frama_c_inplace
method !vexpr e = match e.enode with
- | AddrOf (Var vi, NoOffset) when Cil.isFunctionType vi.vtype ->
- (* function pointer *)
- let kf =
- try Globals.Functions.get vi
- with Not_found -> assert false
- in
- l := kf :: !l;
- Cil.SkipChildren
- | _ ->
- Cil.DoChildren
+ | AddrOf (Var vi, NoOffset) when Cil.isFunctionType vi.vtype ->
+ (* function pointer *)
+ let kf =
+ try Globals.Functions.get vi
+ with Not_found -> assert false
+ in
+ l := kf :: !l;
+ Cil.SkipChildren
+ | _ ->
+ Cil.DoChildren
end
in
Visitor.visitFramacFileSameGlobals o (Ast.get ());
@@ -138,37 +138,37 @@ let syntactic_compute g =
(* add edges from callers to callees into the graph *)
method !vinst = function
- | Call(_, { enode = Lval(Var vi, NoOffset) }, _, _) ->
- (* direct function call *)
- let callee =
- try Globals.Functions.get vi
- with Not_found -> assert false
- in
- let caller = Option.get self#current_kf in
- G.add_edge_e g (caller, Option.get self#current_stmt, callee);
- Cil.SkipChildren
- | Call _ ->
- (* call via a function pointer: add an edge from each function which
- the address is taken to this callee. *)
- let pointed = get_pointed_kfs () in
- let caller = Option.get self#current_kf in
- List.iter
- (fun callee ->
- G.add_edge_e g (caller, Option.get self#current_stmt, callee))
- pointed;
- Cil.SkipChildren
- | Local_init (_,ConsInit(v,_,_),_) ->
- let callee =
- try Globals.Functions.get v
- with Not_found -> assert false
- in
- let caller = Option.get self#current_kf in
- G.add_edge_e g (caller, Option.get self#current_stmt, callee);
- Cil.SkipChildren
- | Local_init (_, AssignInit _, _) | Set _
- | Skip _ | Asm _ | Code_annot _ ->
- (* skip children for efficiency *)
- Cil.SkipChildren
+ | Call(_, { enode = Lval(Var vi, NoOffset) }, _, _) ->
+ (* direct function call *)
+ let callee =
+ try Globals.Functions.get vi
+ with Not_found -> assert false
+ in
+ let caller = Option.get self#current_kf in
+ G.add_edge_e g (caller, Option.get self#current_stmt, callee);
+ Cil.SkipChildren
+ | Call _ ->
+ (* call via a function pointer: add an edge from each function which
+ the address is taken to this callee. *)
+ let pointed = get_pointed_kfs () in
+ let caller = Option.get self#current_kf in
+ List.iter
+ (fun callee ->
+ G.add_edge_e g (caller, Option.get self#current_stmt, callee))
+ pointed;
+ Cil.SkipChildren
+ | Local_init (_,ConsInit(v,_,_),_) ->
+ let callee =
+ try Globals.Functions.get v
+ with Not_found -> assert false
+ in
+ let caller = Option.get self#current_kf in
+ G.add_edge_e g (caller, Option.get self#current_stmt, callee);
+ Cil.SkipChildren
+ | Local_init (_, AssignInit _, _) | Set _
+ | Skip _ | Asm _ | Code_annot _ ->
+ (* skip children for efficiency *)
+ Cil.SkipChildren
(* for efficiency purpose, skip many items *)
method !vexpr _ = Cil.SkipChildren
@@ -182,22 +182,22 @@ let syntactic_compute g =
if not (Options.Uncalled.get () && Options.Uncalled_leaf.get ()) then
G.iter_vertex
(fun kf ->
- let has_pred =
- try
- G.iter_pred (fun _ -> raise Exit) g kf;
- false
- with Exit ->
- true
- in
- if not (has_pred (* no caller *) || is_entry_point kf)
- then
- let must_kept =
- Options.Uncalled.get () (* uncalled functions must be kept *)
- &&
- (Options.Uncalled_leaf.get () (* uncalled leaf must be kept *)
- || Kernel_function.is_definition kf (* [kf] is a leaf *))
- in
- if not must_kept then G.remove_vertex g kf)
+ let has_pred =
+ try
+ G.iter_pred (fun _ -> raise Exit) g kf;
+ false
+ with Exit ->
+ true
+ in
+ if not (has_pred (* no caller *) || is_entry_point kf)
+ then
+ let must_kept =
+ Options.Uncalled.get () (* uncalled functions must be kept *)
+ &&
+ (Options.Uncalled_leaf.get () (* uncalled leaf must be kept *)
+ || Kernel_function.is_definition kf (* [kf] is a leaf *))
+ in
+ if not must_kept then G.remove_vertex g kf)
g
(* complexity = O(number of function calls);
@@ -205,23 +205,23 @@ let syntactic_compute g =
let semantic_compute g =
Globals.Functions.iter
(fun kf ->
- let callers = !Db.Value.callers kf in
- let must_add =
- callers <> [] (* the function is called *)
- || is_entry_point kf
- ||
- (Options.Uncalled.get () (* uncalled functions must be added *)
- && (Options.Uncalled_leaf.get () (* uncalled leaf must be added *)
- || Kernel_function.is_definition kf) (* [kf] is not a leaf *))
- in
- if must_add then begin
- G.add_vertex g kf;
- List.iter
- (fun (caller, callsites) ->
- List.iter
- (fun stmt -> G.add_edge_e g (caller, stmt, kf)) callsites)
- callers
- end)
+ let callers = !Db.Value.callers kf in
+ let must_add =
+ callers <> [] (* the function is called *)
+ || is_entry_point kf
+ ||
+ (Options.Uncalled.get () (* uncalled functions must be added *)
+ && (Options.Uncalled_leaf.get () (* uncalled leaf must be added *)
+ || Kernel_function.is_definition kf) (* [kf] is not a leaf *))
+ in
+ if must_add then begin
+ G.add_vertex g kf;
+ List.iter
+ (fun (caller, callsites) ->
+ List.iter
+ (fun stmt -> G.add_edge_e g (caller, stmt, kf)) callsites)
+ callers
+ end)
let compute () =
let g = G.create () in
@@ -270,7 +270,7 @@ module Subgraph =
let name = State.name
let get = get
let vertex kf = kf
- end)
+ end)
let dump () =
let module GV = Graph.Graphviz.Dot(Graphviz_attributes) in
@@ -285,7 +285,7 @@ include Journalize.Make
type t = G.t
let ty = D.ty
let get = get
- end)
+ end)
(*
Local Variables:
diff --git a/src/plugins/callgraph/cg.mli b/src/plugins/callgraph/cg.mli
index e2414d5e49f1e9b8483bdc75cafec9d2f0503a26..c0b54b6e5a02824e501fb65e84adc59c180ab4c2 100644
--- a/src/plugins/callgraph/cg.mli
+++ b/src/plugins/callgraph/cg.mli
@@ -24,8 +24,8 @@ include Callgraph_api.S
module Graphviz_attributes: Graph.Graphviz.GraphWithDotAttrs
with type t = G.t
- and type V.t = Kernel_function.t
- and type E.t = G.E.t
+ and type V.t = Kernel_function.t
+ and type E.t = G.E.t
(*
Local Variables:
diff --git a/src/plugins/callgraph/journalize.ml b/src/plugins/callgraph/journalize.ml
index 7471d201b83e11e05c4b41c9f710f51769f2c1b2..549a67381c59de7dfd7d203cc3a0f98dc9272bc6 100644
--- a/src/plugins/callgraph/journalize.ml
+++ b/src/plugins/callgraph/journalize.ml
@@ -21,14 +21,14 @@
(**************************************************************************)
module Make
- (C: sig
- val name: string
- val dump: unit -> unit
- val compute: unit -> unit
- type t
- val ty: t Type.t
- val get: unit -> t
- end) =
+ (C: sig
+ val name: string
+ val dump: unit -> unit
+ val compute: unit -> unit
+ type t
+ val ty: t Type.t
+ val get: unit -> t
+ end) =
struct
let name = "Callgraph." ^ C.name
let unit_unit = Datatype.func Datatype.unit Datatype.unit
diff --git a/src/plugins/callgraph/journalize.mli b/src/plugins/callgraph/journalize.mli
index afb124a4ffde37467dec06b73799380d5ffc563d..44ebe2d177aa62a8dbbda3cf07659470d668a548 100644
--- a/src/plugins/callgraph/journalize.mli
+++ b/src/plugins/callgraph/journalize.mli
@@ -23,14 +23,14 @@
(** Journalize the API of a callgraph *)
module Make
- (C: sig
- val name: string
- val dump: unit -> unit
- val compute: unit -> unit
- type t
- val ty: t Type.t
- val get: unit -> t
- end):
+ (C: sig
+ val name: string
+ val dump: unit -> unit
+ val compute: unit -> unit
+ type t
+ val ty: t Type.t
+ val get: unit -> t
+ end):
sig
val dump: unit -> unit
val compute: unit -> unit
diff --git a/src/plugins/callgraph/register.ml b/src/plugins/callgraph/register.ml
index 487f6d51055e43009da0df956a6e071653fd135d..b104be7b144745ae3f173500634f99321a733e1f 100644
--- a/src/plugins/callgraph/register.ml
+++ b/src/plugins/callgraph/register.ml
@@ -25,7 +25,7 @@ let main () =
if Options.Services.get () then begin
if not (Services.is_computed ()) then Services.dump ()
end else
- if not (Cg.is_computed ()) then Cg.dump ()
+ if not (Cg.is_computed ()) then Cg.dump ()
let () = Db.Main.extend main
diff --git a/src/plugins/callgraph/services.ml b/src/plugins/callgraph/services.ml
index fae225ee3cb3c0f04093d51ce77df9acc07e4e00..e143affabf65bb3b583edac5d918ae36b5a6a537 100644
--- a/src/plugins/callgraph/services.ml
+++ b/src/plugins/callgraph/services.ml
@@ -30,8 +30,8 @@ let initial_service_roots cg =
(* otherwise use every uncalled function *)
Cg.G.fold_vertex
(fun v set ->
- if Cg.G.in_degree cg v = 0 then Kernel_function.Set.add v set
- else set)
+ if Cg.G.in_degree cg v = 0 then Kernel_function.Set.add v set
+ else set)
cg
Kernel_function.Set.empty
else
@@ -73,7 +73,7 @@ module State =
(struct
let name = "Callgraph.Services"
let dependencies = [ Cg.self; Kernel.MainFunction.self ]
- end)
+ end)
(* eta-expansion required to mask optional argument [?project] *)
let is_computed () = State.is_computed ()
@@ -104,7 +104,7 @@ module Subgraph =
let name = State.name
let get = get
let vertex = S.vertex
- end)
+ end)
let dump () =
let sg = Subgraph.get () in
@@ -119,7 +119,7 @@ include Journalize.Make
type t = S.Service_graph.t
let ty = S.Service_graph.Datatype.ty
let get = get
- end)
+ end)
(*
Local Variables:
diff --git a/src/plugins/callgraph/services.mli b/src/plugins/callgraph/services.mli
index 1230f2106ad6fbc8c4ba13fe792ddf847ddb9ce4..6aef5f8f5e3271571a1cc0ff8ffa0a42e955ae60 100644
--- a/src/plugins/callgraph/services.mli
+++ b/src/plugins/callgraph/services.mli
@@ -24,8 +24,8 @@ include Callgraph_api.Services
module Graphviz_attributes: Graph.Graphviz.GraphWithDotAttrs
with type t = G.t
- and type V.t = Kernel_function.t Service_graph.vertex
- and type E.t = G.E.t
+ and type V.t = Kernel_function.t Service_graph.vertex
+ and type E.t = G.E.t
(*
Local Variables:
diff --git a/src/plugins/callgraph/subgraph.ml b/src/plugins/callgraph/subgraph.ml
index a6d31f082556a7d61f031efdaf1f906271335f9f..de93307e600f15c1bf29f8de3f7ce8dc9f070992 100644
--- a/src/plugins/callgraph/subgraph.ml
+++ b/src/plugins/callgraph/subgraph.ml
@@ -21,27 +21,27 @@
(**************************************************************************)
module Make
- (G: sig
- include Graph.Sig.G
- val create: ?size:int -> unit -> t
- val add_edge_e: t -> E.t -> unit
- end)
- (D: Datatype.S with type t = G.t)
- (Info: sig
- val self: State.t
- val name: string
- val get: unit -> G.t
- val vertex: Kernel_function.t -> G.V.t
- end) =
+ (G: sig
+ include Graph.Sig.G
+ val create: ?size:int -> unit -> t
+ val add_edge_e: t -> E.t -> unit
+ end)
+ (D: Datatype.S with type t = G.t)
+ (Info: sig
+ val self: State.t
+ val name: string
+ val get: unit -> G.t
+ val vertex: Kernel_function.t -> G.V.t
+ end) =
struct
module S =
State_builder.Option_ref
(Datatype.Option(D)) (* none if no root is specified *)
- (struct
+ (struct
let name = "Subgraph of " ^ Info.name
let dependencies = [ Info.self; Options.Roots.self ]
- end)
+ end)
let self = S.self
@@ -61,8 +61,8 @@ struct
HNodes.add visited v ();
G.iter_succ_e
(fun e ->
- G.add_edge_e subg e;
- add_component (G.E.dst e))
+ G.add_edge_e subg e;
+ add_component (G.E.dst e))
g
v
end
diff --git a/src/plugins/callgraph/subgraph.mli b/src/plugins/callgraph/subgraph.mli
index 00f19b29c3819427913a1a51d7216f43dd6b10d6..4671d4d55c888ee47bf03fd00da5200a6ffdf7b9 100644
--- a/src/plugins/callgraph/subgraph.mli
+++ b/src/plugins/callgraph/subgraph.mli
@@ -22,20 +22,20 @@
(** Subgraph from a given vertex *)
module Make
- (G: sig
- (** Graph datastructure *)
- include Graph.Sig.G
- val create: ?size:int -> unit -> t
- val add_edge_e: t -> E.t -> unit
- end)
- (D: Datatype.S with type t = G.t (** Graph datatype *))
- (Info: sig
- (** additional information *)
- val self: State.t
- val name: string (** name of the state *)
- val get: unit -> G.t
- val vertex: Kernel_function.t -> G.V.t
- end) :
+ (G: sig
+ (** Graph datastructure *)
+ include Graph.Sig.G
+ val create: ?size:int -> unit -> t
+ val add_edge_e: t -> E.t -> unit
+ end)
+ (D: Datatype.S with type t = G.t (** Graph datatype *))
+ (Info: sig
+ (** additional information *)
+ val self: State.t
+ val name: string (** name of the state *)
+ val get: unit -> G.t
+ val vertex: Kernel_function.t -> G.V.t
+ end) :
sig
val get: unit -> G.t
val self: State.t
diff --git a/src/plugins/callgraph/uses.ml b/src/plugins/callgraph/uses.ml
index 1f6b72b02d9b13741a2e3e75a6539f5567df0274..2befdd59d1ab047dc12cfa9386e53166c8c8f991 100644
--- a/src/plugins/callgraph/uses.ml
+++ b/src/plugins/callgraph/uses.ml
@@ -25,8 +25,8 @@
(* ************************************************************************** *)
module Make
- (G:Graph.Sig.G with type V.t = Kernel_function.t)
- (N:sig val name: string end) =
+ (G:Graph.Sig.G with type V.t = Kernel_function.t)
+ (N:sig val name: string end) =
struct
(* Topological iterations are memoized in order to improve efficiency when
@@ -39,7 +39,7 @@ struct
(struct
let name = "Callgraph.Uses" ^ N.name
let dependencies = [ Cg.self ]
- end)
+ end)
module T = Graph.Topological.Make_stable(G)
@@ -61,15 +61,15 @@ let iter_in_order =
let iter_in_rev_order =
let module I =
- Make
- (struct
- include Cg.G
- (* inverse operations over successors required by
- [Graph.Topological.G] *)
- let iter_succ = iter_pred
- let in_degree = out_degree
- end)
- (struct let name = "iter_in_rev_order" end)
+ Make
+ (struct
+ include Cg.G
+ (* inverse operations over successors required by
+ [Graph.Topological.G] *)
+ let iter_succ = iter_pred
+ let in_degree = out_degree
+ end)
+ (struct let name = "iter_in_rev_order" end)
in
fun f -> I.iter (Cg.get ()) f
@@ -80,11 +80,11 @@ let iter_on_aux iter_dir f kf =
let rec aux kf =
iter_dir
(fun kf' ->
- if not (Kernel_function.Hashtbl.mem visited kf') then begin
- f kf';
- Kernel_function.Hashtbl.add visited kf' ();
- aux kf'
- end)
+ if not (Kernel_function.Hashtbl.mem visited kf') then begin
+ f kf';
+ Kernel_function.Hashtbl.add visited kf' ();
+ aux kf'
+ end)
cg
kf
in
@@ -97,8 +97,8 @@ let is_local_or_formal_of_caller v kf =
try
iter_on_callers
(fun caller ->
- if Base.is_formal_or_local v (Kernel_function.get_definition caller)
- then raise Exit)
+ if Base.is_formal_or_local v (Kernel_function.get_definition caller)
+ then raise Exit)
kf;
false
with Exit ->
@@ -109,11 +109,11 @@ let accept_base ~with_formals ~with_locals kf v =
Base.is_global v
||
(match with_formals, with_locals, kf.fundec with
- | false, false, _ | false, _, Declaration _ -> false
- | true, false, Definition (fundec,_) -> Base.is_formal v fundec
- | false, true, Definition (fundec, _) -> Base.is_local v fundec
- | true, true, Definition (fundec, _) -> Base.is_formal_or_local v fundec
- | true , _, Declaration (_, vd, _, _) -> Base.is_formal_of_prototype v vd)
+ | false, false, _ | false, _, Declaration _ -> false
+ | true, false, Definition (fundec,_) -> Base.is_formal v fundec
+ | false, true, Definition (fundec, _) -> Base.is_local v fundec
+ | true, true, Definition (fundec, _) -> Base.is_formal_or_local v fundec
+ | true , _, Declaration (_, vd, _, _) -> Base.is_formal_of_prototype v vd)
|| is_local_or_formal_of_caller v kf
let nb_calls () =
diff --git a/src/plugins/constant_propagation/propagationParameters.ml b/src/plugins/constant_propagation/propagationParameters.ml
index 40f995c204b01ee8780b3f4bab7a41a243968ee9..7de22e289304a15927d957969e7dd321d48b0191 100644
--- a/src/plugins/constant_propagation/propagationParameters.ml
+++ b/src/plugins/constant_propagation/propagationParameters.ml
@@ -22,44 +22,44 @@
(** Constant Propagation *)
include Plugin.Register
- (struct
- let name = "semantic constant folding"
- let shortname = "scf"
- let help = "propagates constants semantically"
- end)
+ (struct
+ let name = "semantic constant folding"
+ let shortname = "scf"
+ let help = "propagates constants semantically"
+ end)
module SemanticConstFolding =
False
- (struct
- let option_name = "-scf"
- let help = "pretty print a version of the source code where each constant expression is replaced by its value"
- end)
+ (struct
+ let option_name = "-scf"
+ let help = "pretty print a version of the source code where each constant expression is replaced by its value"
+ end)
let () = SemanticConstFolding.add_aliases ["-semantic-const-folding"]
module SemanticConstFold =
Fundec_set
(struct
- let option_name = "-scf-fct"
- let arg_name = "f1, ..., fn"
- let help = "propagate constants only into functions f1,...,fn"
- end)
+ let option_name = "-scf-fct"
+ let arg_name = "f1, ..., fn"
+ let help = "propagate constants only into functions f1,...,fn"
+ end)
let () = SemanticConstFold.add_aliases ["-semantic-const-fold"]
module CastIntro =
- False
- (struct
- let option_name = "-scf-allow-cast"
- let help = "replace expressions by constants even when doing so \
-requires a pointer cast"
- end)
+ False
+ (struct
+ let option_name = "-scf-allow-cast"
+ let help = "replace expressions by constants even when doing so \
+ requires a pointer cast"
+ end)
let () = CastIntro.add_aliases ["-cast-from-constant"]
module ExpandLogicContext =
False
- (struct
- let option_name = "-scf-logic"
- let help = "replace values from logical context and create corresponding variables (HIGHLY EXPERIMENTAL)"
- end)
+ (struct
+ let option_name = "-scf-logic"
+ let help = "replace values from logical context and create corresponding variables (HIGHLY EXPERIMENTAL)"
+ end)
let () = ExpandLogicContext.add_aliases ["-semantic-const-fold-logic"]
module Project_name =
@@ -69,7 +69,7 @@ module Project_name =
let default = "propagated"
let arg_name = ""
let help = "name of the generated project (default is `propagated`)"
- end)
+ end)
(*
Local Variables:
diff --git a/src/plugins/from/callwise.ml b/src/plugins/from/callwise.ml
index 454e2c0953ee3f215766687de9c8618fd7875bef..03a681ae3f05d4b92d306c351a5eb5f23765ae67 100644
--- a/src/plugins/from/callwise.ml
+++ b/src/plugins/from/callwise.ml
@@ -27,10 +27,10 @@ module Tbl =
Cil_state_builder.Kinstr_hashtbl
(Function_Froms)
(struct
- let name = "Callwise dependencies"
- let size = 17
- let dependencies = [ Db.Value.self ]
- end)
+ let name = "Callwise dependencies"
+ let size = 17
+ let dependencies = [ Db.Value.self ]
+ end)
let () = From_parameters.ForceCallDeps.set_output_dependencies [Tbl.self]
let merge_call_froms table callsite froms =
@@ -47,9 +47,9 @@ type from_state = {
value_initial_state: Db.Value.state (** State of Value at the beginning of
the call *);
table_for_calls: Function_Froms.t Kinstr.Hashtbl.t
- (** State of the From plugin for each statement containing a function call
- in the body of [current_function]. Updated incrementally each time
- Value analyses such a statement *);
+(** State of the From plugin for each statement containing a function call
+ in the body of [current_function]. Updated incrementally each time
+ Value analyses such a statement *);
}
(** The state of the callwise From analysis. Only the top of this callstack
@@ -85,38 +85,38 @@ let call_for_individual_froms (call_type, value_initial_state, call_stack) =
register_from froms
in
match call_type with
- | `Def | `Memexec ->
+ | `Def | `Memexec ->
let table_for_calls = Kinstr.Hashtbl.create 7 in
call_froms_stack :=
{ current_function; value_initial_state; table_for_calls } ::
!call_froms_stack
| `Builtin (Some (result,_)) ->
- register_from result
+ register_from result
| `Builtin None ->
- let behaviors =
- !Db.Value.valid_behaviors current_function value_initial_state
- in
- compute_from_behaviors behaviors
+ let behaviors =
+ !Db.Value.valid_behaviors current_function value_initial_state
+ in
+ compute_from_behaviors behaviors
| `Spec spec ->
- compute_from_behaviors spec.Cil_types.spec_behavior
+ compute_from_behaviors spec.Cil_types.spec_behavior
end
let end_record call_stack froms =
- let (current_function_value, call_site) = List.hd call_stack in
- record_callwise_dependencies_in_db call_site froms;
- (* pop + record in top of stack the froms of function that just finished *)
- match !call_froms_stack with
- | {current_function} :: ({table_for_calls = table} :: _ as tail) ->
- if current_function_value != current_function then
- From_parameters.fatal "calldeps %a != %a@."
- Kernel_function.pretty current_function
- Kernel_function.pretty current_function_value;
- call_froms_stack := tail;
- merge_call_froms table call_site froms
-
- | _ -> (* the entry point, probably *)
- Tbl.mark_as_computed ();
- call_froms_stack := []
+ let (current_function_value, call_site) = List.hd call_stack in
+ record_callwise_dependencies_in_db call_site froms;
+ (* pop + record in top of stack the froms of function that just finished *)
+ match !call_froms_stack with
+ | {current_function} :: ({table_for_calls = table} :: _ as tail) ->
+ if current_function_value != current_function then
+ From_parameters.fatal "calldeps %a != %a@."
+ Kernel_function.pretty current_function
+ Kernel_function.pretty current_function_value;
+ call_froms_stack := tail;
+ merge_call_froms table call_site froms
+
+ | _ -> (* the entry point, probably *)
+ Tbl.mark_as_computed ();
+ call_froms_stack := []
module MemExec =
@@ -124,10 +124,10 @@ module MemExec =
(Datatype.Int.Hashtbl)
(Function_Froms)
(struct
- let size = 17
- let dependencies = [Tbl.self]
- let name = "From.Callwise.MemExec"
- end)
+ let size = 17
+ let dependencies = [Tbl.self]
+ let name = "From.Callwise.MemExec"
+ end)
let compute_call_from_value_states current_function states =
let module To_Use = struct
@@ -156,50 +156,50 @@ let record_for_individual_froms (call_stack, value_res) =
let froms = match value_res with
| Value_types.Normal (states, _after_states)
| Value_types.NormalStore ((states, _after_states), _) ->
- let cur_kf, _ = List.hd call_stack in
- let froms =
- try
- if !Db.Value.no_results (Kernel_function.get_definition cur_kf)
- then
- Function_Froms.top
- else
- compute_call_from_value_states cur_kf (Lazy.force states)
- with Kernel_function.No_Definition -> Function_Froms.top
- in
- let pre_state = match !call_froms_stack with
- | [] -> assert false
- | { value_initial_state } :: _ -> value_initial_state
- in
- if From_parameters.VerifyAssigns.get () then
- !Db.Value.verify_assigns_froms cur_kf pre_state froms;
- (match value_res with
- | Value_types.NormalStore (_, memexec_counter) ->
- MemExec.replace memexec_counter froms
- | _ -> ());
- froms
+ let cur_kf, _ = List.hd call_stack in
+ let froms =
+ try
+ if !Db.Value.no_results (Kernel_function.get_definition cur_kf)
+ then
+ Function_Froms.top
+ else
+ compute_call_from_value_states cur_kf (Lazy.force states)
+ with Kernel_function.No_Definition -> Function_Froms.top
+ in
+ let pre_state = match !call_froms_stack with
+ | [] -> assert false
+ | { value_initial_state } :: _ -> value_initial_state
+ in
+ if From_parameters.VerifyAssigns.get () then
+ !Db.Value.verify_assigns_froms cur_kf pre_state froms;
+ (match value_res with
+ | Value_types.NormalStore (_, memexec_counter) ->
+ MemExec.replace memexec_counter froms
+ | _ -> ());
+ froms
| Value_types.Reuse counter ->
- MemExec.find counter
+ MemExec.find counter
in
end_record call_stack froms
-
+
end
(* Register our callbacks inside the value analysis *)
let () = From_parameters.ForceCallDeps.add_update_hook
- (fun _bold bnew ->
- if bnew then begin
- Db.Value.Call_Type_Value_Callbacks.extend_once call_for_individual_froms;
- Db.Value.Record_Value_Callbacks_New.extend_once
- record_for_individual_froms;
- end)
+ (fun _bold bnew ->
+ if bnew then begin
+ Db.Value.Call_Type_Value_Callbacks.extend_once call_for_individual_froms;
+ Db.Value.Record_Value_Callbacks_New.extend_once
+ record_for_individual_froms;
+ end)
let force_compute_all_calldeps ()=
if Db.Value.is_computed () then
Project.clear
- ~selection:(State_selection.with_dependencies Db.Value.self)
+ ~selection:(State_selection.with_dependencies Db.Value.self)
();
!Db.Value.compute ()
diff --git a/src/plugins/from/from_compute.ml b/src/plugins/from/from_compute.ml
index 4b34ced746b15200da5e6c8a079b2a8157af28a1..c28f33766a4107d7df9bdea8d498c8d166d60740 100644
--- a/src/plugins/from/from_compute.ml
+++ b/src/plugins/from/from_compute.ml
@@ -40,24 +40,24 @@ let rec find_deps_no_transitivity state expr =
(* The value of the expression [expr], just before executing the statement
[instr], is a function of the values of the returned zones. *)
match expr.enode with
- | Info (e, _) -> find_deps_no_transitivity state e
- | AlignOfE _| AlignOf _| SizeOfStr _ |SizeOfE _| SizeOf _ | Const _
- -> Function_Froms.Deps.bottom
- | AddrOf lv | StartOf lv ->
- let deps, _ = !Db.Value.lval_to_loc_with_deps_state (* loc ignored *)
- state
- ~deps:Zone.bottom
- lv
- in
- Function_Froms.Deps.from_data_deps deps
- | CastE (_, e)|UnOp (_, e, _) ->
- find_deps_no_transitivity state e
- | BinOp (_, e1, e2, _) ->
- Function_Froms.Deps.join
- (find_deps_no_transitivity state e1)
- (find_deps_no_transitivity state e2)
- | Lval v ->
- find_deps_lval_no_transitivity state v
+ | Info (e, _) -> find_deps_no_transitivity state e
+ | AlignOfE _| AlignOf _| SizeOfStr _ |SizeOfE _| SizeOf _ | Const _
+ -> Function_Froms.Deps.bottom
+ | AddrOf lv | StartOf lv ->
+ let deps, _ = !Db.Value.lval_to_loc_with_deps_state (* loc ignored *)
+ state
+ ~deps:Zone.bottom
+ lv
+ in
+ Function_Froms.Deps.from_data_deps deps
+ | CastE (_, e)|UnOp (_, e, _) ->
+ find_deps_no_transitivity state e
+ | BinOp (_, e1, e2, _) ->
+ Function_Froms.Deps.join
+ (find_deps_no_transitivity state e1)
+ (find_deps_no_transitivity state e2)
+ | Lval v ->
+ find_deps_lval_no_transitivity state v
and find_deps_lval_no_transitivity state lv =
let ind_deps, direct_deps, _exact =
@@ -72,108 +72,108 @@ let compute_using_prototype_for_state state kf assigns =
let varinfo = Kernel_function.get_vi kf in
let return_deps,deps =
match assigns with
- | WritesAny ->
- From_parameters.warning "@[no assigns clauses@ for function %a.@]@ \
- Results will be imprecise."
- Kernel_function.pretty kf;
- Function_Froms.Memory.(top_return, top)
- | Writes assigns ->
- let (rt_typ,_,_,_) = splitFunctionTypeVI varinfo in
- let input_zone out ins =
- (* Technically out is unused, but there is a signature problem *)
- !Db.Value.assigns_inputs_to_zone state (Writes [out, ins])
- in
- let treat_assign acc (out, ins) =
- try
- let (output_loc_under, output_loc_over, _deps) =
- !Db.Properties.Interp.loc_to_loc_under_over
- ~result:None state out.it_content
- in
- let input_zone = input_zone out ins in
- (* assign clauses do not let us specify address
- dependencies for now, so we assume it is all data
- dependencies *)
- let input_deps =
- Function_Froms.Deps.from_data_deps input_zone
- in
- (* Weak update of the over-approximation of the zones assigned *)
- let acc = Function_Froms.Memory.add_binding_loc ~exact:false
- acc output_loc_over input_deps in
- let output_loc_under_zone = Locations.enumerate_valid_bits_under
- Write output_loc_under in
- (* Now, perform a strong update on the zones that are guaranteed
- to be assigned (under-approximation) AND that do not depend
- on themselves.
- Note: here we remove an overapproximation from an
- underapproximation to get an underapproximation, which is not
- the usual direction. It works here because diff on non-top
- zones is an exact operation. *)
- let sure_out_zone =
- Zone.(if equal top input_zone then bottom
- else diff output_loc_under_zone input_zone)
- in
- let acc = Function_Froms.Memory.add_binding ~exact:true
- acc sure_out_zone input_deps in
- acc
- with Db.Properties.Interp.No_conversion ->
- From_parameters.result
- ~once:true ~current:true "Unable to extract assigns in %a"
- Kernel_function.pretty kf;
- acc
+ | WritesAny ->
+ From_parameters.warning "@[no assigns clauses@ for function %a.@]@ \
+ Results will be imprecise."
+ Kernel_function.pretty kf;
+ Function_Froms.Memory.(top_return, top)
+ | Writes assigns ->
+ let (rt_typ,_,_,_) = splitFunctionTypeVI varinfo in
+ let input_zone out ins =
+ (* Technically out is unused, but there is a signature problem *)
+ !Db.Value.assigns_inputs_to_zone state (Writes [out, ins])
+ in
+ let treat_assign acc (out, ins) =
+ try
+ let (output_loc_under, output_loc_over, _deps) =
+ !Db.Properties.Interp.loc_to_loc_under_over
+ ~result:None state out.it_content
in
- let treat_ret_assign acc (out, from) =
- let zone_from = input_zone out from in
- (* assign clauses do not let us specify address dependencies for
- now, so we assume it is all data dependencies *)
- let inputs_deps = Function_Froms.Deps.from_data_deps zone_from in
- try
- let coffs =
- !Db.Properties.Interp.loc_to_offset ~result:None out.it_content
- in
- List.fold_left
- (fun acc coff ->
- let (base,width) = bitsOffset rt_typ coff in
- let size = Int_Base.inject (Int.of_int width) in
- Function_Froms.Memory.(add_to_return
- ~start:base ~size ~m:acc inputs_deps)
- )
- acc coffs
- with Db.Properties.Interp.No_conversion | SizeOfError _ ->
- From_parameters.result ~once:true ~current:true
- "Unable to extract a proper offset. \
- Using FROM for the whole \\result";
- let size = Bit_utils.sizeof rt_typ in
- Function_Froms.(Memory.add_to_return ~size ~m:acc inputs_deps)
+ let input_zone = input_zone out ins in
+ (* assign clauses do not let us specify address
+ dependencies for now, so we assume it is all data
+ dependencies *)
+ let input_deps =
+ Function_Froms.Deps.from_data_deps input_zone
in
- let return_assigns, other_assigns =
- List.fold_left
- (fun (ra,oa) (loc,_ as a) ->
- if Logic_utils.is_result loc.it_content
- then a::ra,oa else ra,a::oa)
- ([],[]) assigns
+ (* Weak update of the over-approximation of the zones assigned *)
+ let acc = Function_Froms.Memory.add_binding_loc ~exact:false
+ acc output_loc_over input_deps in
+ let output_loc_under_zone = Locations.enumerate_valid_bits_under
+ Write output_loc_under in
+ (* Now, perform a strong update on the zones that are guaranteed
+ to be assigned (under-approximation) AND that do not depend
+ on themselves.
+ Note: here we remove an overapproximation from an
+ underapproximation to get an underapproximation, which is not
+ the usual direction. It works here because diff on non-top
+ zones is an exact operation. *)
+ let sure_out_zone =
+ Zone.(if equal top input_zone then bottom
+ else diff output_loc_under_zone input_zone)
in
- let return_assigns =
- match return_assigns with
- | [] when Cil.isVoidType rt_typ ->
- Function_Froms.Memory.default_return
- | [] -> (* \from unspecified. *)
- let size = Bit_utils.sizeof rt_typ in
- Function_Froms.Memory.top_return_size size
- | _ ->
- List.fold_left treat_ret_assign
- Function_Froms.Memory.default_return return_assigns
+ let acc = Function_Froms.Memory.add_binding ~exact:true
+ acc sure_out_zone input_deps in
+ acc
+ with Db.Properties.Interp.No_conversion ->
+ From_parameters.result
+ ~once:true ~current:true "Unable to extract assigns in %a"
+ Kernel_function.pretty kf;
+ acc
+ in
+ let treat_ret_assign acc (out, from) =
+ let zone_from = input_zone out from in
+ (* assign clauses do not let us specify address dependencies for
+ now, so we assume it is all data dependencies *)
+ let inputs_deps = Function_Froms.Deps.from_data_deps zone_from in
+ try
+ let coffs =
+ !Db.Properties.Interp.loc_to_offset ~result:None out.it_content
in
- return_assigns,
List.fold_left
- treat_assign Function_Froms.Memory.empty other_assigns
+ (fun acc coff ->
+ let (base,width) = bitsOffset rt_typ coff in
+ let size = Int_Base.inject (Int.of_int width) in
+ Function_Froms.Memory.(add_to_return
+ ~start:base ~size ~m:acc inputs_deps)
+ )
+ acc coffs
+ with Db.Properties.Interp.No_conversion | SizeOfError _ ->
+ From_parameters.result ~once:true ~current:true
+ "Unable to extract a proper offset. \
+ Using FROM for the whole \\result";
+ let size = Bit_utils.sizeof rt_typ in
+ Function_Froms.(Memory.add_to_return ~size ~m:acc inputs_deps)
+ in
+ let return_assigns, other_assigns =
+ List.fold_left
+ (fun (ra,oa) (loc,_ as a) ->
+ if Logic_utils.is_result loc.it_content
+ then a::ra,oa else ra,a::oa)
+ ([],[]) assigns
+ in
+ let return_assigns =
+ match return_assigns with
+ | [] when Cil.isVoidType rt_typ ->
+ Function_Froms.Memory.default_return
+ | [] -> (* \from unspecified. *)
+ let size = Bit_utils.sizeof rt_typ in
+ Function_Froms.Memory.top_return_size size
+ | _ ->
+ List.fold_left treat_ret_assign
+ Function_Froms.Memory.default_return return_assigns
+ in
+ return_assigns,
+ List.fold_left
+ treat_assign Function_Froms.Memory.empty other_assigns
in
{ deps_return = return_deps; Function_Froms.deps_table = deps }
module ZoneStmtMap = struct
include
Hptmap.Make(Stmt_Id)(Zone)(Hptmap.Comp_unused)
- (struct let v = [[]] end)
- (struct let l = [Ast.self] end)
+ (struct let v = [[]] end)
+ (struct let l = [Ast.self] end)
let join =
let decide _k z1 z2 = Zone.join z1 z2 in
@@ -184,17 +184,17 @@ end
module Make (To_Use: To_Use) =
struct
type t' =
- { additional_deps_table : ZoneStmtMap.t;
- (** Additional control dependencies to add to all modified variables,
- coming from the control statements encountered so far (If, Switch).
- The statement information is used to remove the dependencies that
- are no longer useful, when we reach a statement that post-dominates
- the statement that gave rise to the dependency. *)
- additional_deps : Zone.t;
- (** Union of the sets in {!additional_deps_table} *)
- deps_table : Function_Froms.Memory.t
- (** dependency table *)
- }
+ { additional_deps_table : ZoneStmtMap.t;
+ (** Additional control dependencies to add to all modified variables,
+ coming from the control statements encountered so far (If, Switch).
+ The statement information is used to remove the dependencies that
+ are no longer useful, when we reach a statement that post-dominates
+ the statement that gave rise to the dependency. *)
+ additional_deps : Zone.t;
+ (** Union of the sets in {!additional_deps_table} *)
+ deps_table : Function_Froms.Memory.t
+ (** dependency table *)
+ }
let call_stack : kernel_function Stack.t = Stack.create ()
(** Stack of function being processed *)
@@ -298,14 +298,14 @@ struct
let pretty fmt (v: t) =
display_one_from fmt v
- let transfer_conditional_exp s exp state =
+ let transfer_conditional_exp s exp state =
let additional = find s state.deps_table exp in
let additional = Function_Froms.Deps.to_zone additional in
{state with
- additional_deps_table =
- ZoneStmtMap.add s additional state.additional_deps_table;
- additional_deps =
- Zone.join additional state.additional_deps }
+ additional_deps_table =
+ ZoneStmtMap.add s additional state.additional_deps_table;
+ additional_deps =
+ Zone.join additional state.additional_deps }
let join_and_is_included new_ old =
@@ -349,8 +349,8 @@ struct
let deps = Function_Froms.Deps.add_indirect_dep deps_right all_indirect in
let access = if init then Read else Write in
{ state with deps_table =
- Function_Froms.Memory.add_binding_precise_loc
- ~exact access state.deps_table loc deps }
+ Function_Froms.Memory.add_binding_precise_loc
+ ~exact access state.deps_table loc deps }
let transfer_call stmt dest f args _loc state =
Db.yield ();
@@ -458,41 +458,41 @@ struct
let transfer_instr stmt (i: instr) (state: t) =
Db.yield ();
match i with
- | Set (lv, exp, _) ->
- let comp_vars = find stmt state.deps_table exp in
- let init = Cil.is_mutable_or_initialized lv in
- transfer_assign stmt ~init lv comp_vars state
- | Local_init(v, AssignInit i, _) ->
- let rec aux lv i acc =
- let doinit o i _ state = aux (Cil.addOffsetLval o lv) i state in
- match i with
- | SingleInit e ->
- let comp_vars = find stmt acc.deps_table e in
- transfer_assign stmt ~init:true lv comp_vars acc
- | CompoundInit (ct, initl) ->
- (* To avoid a performance issue, do not fold implicit initializers
- of scalar or large arrays. We still use implicit initializers
- for small struct arrays, as this may be more precise in case of
- padding bits. The 100 limit is arbitrary. *)
- let implicit =
- not (Cil.isArrayType ct &&
- (Cil.isArithmeticOrPointerType (Cil.typeOf_array_elem ct)
- || Ast_info.array_size ct > (Integer.of_int 100)))
- in
- let r = Cil.foldLeftCompound ~implicit ~doinit ~ct ~initl ~acc in
- if implicit then r else
- (* If implicit zero-initializers have been skipped, also mark
- the entire array as initialized from no dependency (nothing
- is read by the implicit zero-initializers). *)
- transfer_assign stmt ~init:true lv Function_Froms.Deps.bottom r
- in
- aux (Cil.var v) i state
- | Call (lvaloption,funcexp,argl,loc) ->
- transfer_call stmt lvaloption funcexp argl loc state
- | Local_init (v, ConsInit(f, args, kind), loc) ->
- Cil.treat_constructor_as_func
- (transfer_call stmt) v f args kind loc state
- | Asm _ | Code_annot _ | Skip _ -> state
+ | Set (lv, exp, _) ->
+ let comp_vars = find stmt state.deps_table exp in
+ let init = Cil.is_mutable_or_initialized lv in
+ transfer_assign stmt ~init lv comp_vars state
+ | Local_init(v, AssignInit i, _) ->
+ let rec aux lv i acc =
+ let doinit o i _ state = aux (Cil.addOffsetLval o lv) i state in
+ match i with
+ | SingleInit e ->
+ let comp_vars = find stmt acc.deps_table e in
+ transfer_assign stmt ~init:true lv comp_vars acc
+ | CompoundInit (ct, initl) ->
+ (* To avoid a performance issue, do not fold implicit initializers
+ of scalar or large arrays. We still use implicit initializers
+ for small struct arrays, as this may be more precise in case of
+ padding bits. The 100 limit is arbitrary. *)
+ let implicit =
+ not (Cil.isArrayType ct &&
+ (Cil.isArithmeticOrPointerType (Cil.typeOf_array_elem ct)
+ || Ast_info.array_size ct > (Integer.of_int 100)))
+ in
+ let r = Cil.foldLeftCompound ~implicit ~doinit ~ct ~initl ~acc in
+ if implicit then r else
+ (* If implicit zero-initializers have been skipped, also mark
+ the entire array as initialized from no dependency (nothing
+ is read by the implicit zero-initializers). *)
+ transfer_assign stmt ~init:true lv Function_Froms.Deps.bottom r
+ in
+ aux (Cil.var v) i state
+ | Call (lvaloption,funcexp,argl,loc) ->
+ transfer_call stmt lvaloption funcexp argl loc state
+ | Local_init (v, ConsInit(f, args, kind), loc) ->
+ Cil.treat_constructor_as_func
+ (transfer_call stmt) v f args kind loc state
+ | Asm _ | Code_annot _ | Skip _ -> state
let transfer_guard s e d =
@@ -502,7 +502,7 @@ struct
let do_then, do_else =
if isIntegralType t1 || isPointerType t1
then Cvalue.V.contains_non_zero interpreted_e,
- Cvalue.V.contains_zero interpreted_e
+ Cvalue.V.contains_zero interpreted_e
else true, true (* TODO: a float condition is true iff != 0.0 *)
in
(if do_then then d else bottom),
@@ -517,9 +517,9 @@ struct
let map' =
ZoneStmtMap.fold
(fun k _v acc_map ->
- if !Db.Postdominators.is_postdominator kf ~opening:k ~closing:s
- then ZoneStmtMap.remove k acc_map
- else acc_map
+ if !Db.Postdominators.is_postdominator kf ~opening:k ~closing:s
+ then ZoneStmtMap.remove k acc_map
+ else acc_map
) map map
in
if not (map == map') then
@@ -536,24 +536,24 @@ struct
| Instr i -> map_on_all_succs (transfer_instr s i data)
| If(exp,_,_,_) ->
- let data = transfer_conditional_exp s exp data in
- Dataflows.transfer_if_from_guard transfer_guard s data
+ let data = transfer_conditional_exp s exp data in
+ Dataflows.transfer_if_from_guard transfer_guard s data
| Switch(exp,_,_,_) ->
- let data = transfer_conditional_exp s exp data in
- Dataflows.transfer_switch_from_guard transfer_guard s data
+ let data = transfer_conditional_exp s exp data in
+ Dataflows.transfer_switch_from_guard transfer_guard s data
| Return _ | Throw _ -> []
| UnspecifiedSequence _ | Loop _ | Block _
| Goto _ | Break _ | Continue _
| TryExcept _ | TryFinally _ | TryCatch _
- -> map_on_all_succs data
+ -> map_on_all_succs data
;;
(* Filter out unreachable values. *)
- let transfer_stmt s d =
+ let transfer_stmt s d =
if Db.Value.is_reachable (To_Use.get_value_state s) &&
- not (Function_Froms.Memory.is_bottom d.deps_table)
+ not (Function_Froms.Memory.is_bottom d.deps_table)
then transfer_stmt s d
else []
@@ -566,12 +566,12 @@ struct
let dt = List.fold_left bind_locals dt opened in
let dt = List.fold_left unbind_locals dt closed in
{ d with deps_table = dt }
- else
- bottom_from
+ else
+ bottom_from
(* Filter the outgoing data using doEdge. *)
- let transfer_stmt s d =
- let ds = transfer_stmt s d in
+ let transfer_stmt s d =
+ let ds = transfer_stmt s d in
List.map (fun (succ, d) -> (succ, doEdge s succ d)) ds
;;
@@ -582,17 +582,17 @@ struct
let externalize return kf state =
let deps_return =
(match return.skind with
- | Return (Some ({enode = Lval v}),_) ->
- let deps, target, _exact =
- lval_to_zone_with_deps ~for_writing:false return v
- in
- let z = Zone.join target deps in
- let deps = Function_Froms.Memory.find_precise state.deps_table z in
- let size = Bit_utils.sizeof (Cil.typeOfLval v) in
- Function_Froms.(Memory.add_to_return ~size deps)
- | Return (None,_) ->
- Function_Froms.Memory.default_return
- | _ -> assert false)
+ | Return (Some ({enode = Lval v}),_) ->
+ let deps, target, _exact =
+ lval_to_zone_with_deps ~for_writing:false return v
+ in
+ let z = Zone.join target deps in
+ let deps = Function_Froms.Memory.find_precise state.deps_table z in
+ let size = Bit_utils.sizeof (Cil.typeOfLval v) in
+ Function_Froms.(Memory.add_to_return ~size deps)
+ | Return (None,_) ->
+ Function_Froms.Memory.default_return
+ | _ -> assert false)
in
let accept = To_Use.keep_base kf in
let deps_table =
@@ -610,24 +610,24 @@ struct
try
Stack.iter
(fun g ->
- if kf == g then begin
- if Db.Value.ignored_recursive_call kf then
- From_parameters.error
- "during dependencies computations for %a, \
- ignoring probable recursive"
- Kernel_function.pretty kf;
- raise Exit
- end)
+ if kf == g then begin
+ if Db.Value.ignored_recursive_call kf then
+ From_parameters.error
+ "during dependencies computations for %a, \
+ ignoring probable recursive"
+ Kernel_function.pretty kf;
+ raise Exit
+ end)
call_stack;
Stack.push kf call_stack;
let state =
{ empty_from with
- deps_table = bind_locals empty_from.deps_table f.sbody }
+ deps_table = bind_locals empty_from.deps_table f.sbody }
in
- let module Fenv =
- (val Dataflows.function_env kf: Dataflows.FUNCTION_ENV)
+ let module Fenv =
+ (val Dataflows.function_env kf: Dataflows.FUNCTION_ENV)
in
- let module Dataflow_arg = struct
+ let module Dataflow_arg = struct
include Computer
let init = [(Kernel_function.find_first_stmt kf, state)]
end
@@ -640,8 +640,8 @@ struct
let states =
Stmt.Hashtbl.create Fenv.nb_stmts
in
- Compute.iter_on_result (fun k record ->
- Stmt.Hashtbl.add states k record.deps_table);
+ Compute.iter_on_result (fun k record ->
+ Stmt.Hashtbl.add states k record.deps_table);
Db.From.Record_From_Callbacks.apply
(call_stack, states, Dataflow_arg.callwise_states_with_formals)
end;
@@ -653,17 +653,17 @@ struct
externalize
ret_id
kf
- Compute.before.(Fenv.to_ordered ret_id)
+ Compute.before.(Fenv.to_ordered ret_id)
else
raise Not_found
with Not_found -> begin
- From_parameters.result
- "Non-terminating function %a (no dependencies)"
- Kernel_function.pretty kf;
- { Function_Froms.deps_return =
- Function_Froms.Memory.default_return;
- deps_table = Function_Froms.Memory.bottom }
- end
+ From_parameters.result
+ "Non-terminating function %a (no dependencies)"
+ Kernel_function.pretty kf;
+ { Function_Froms.deps_return =
+ Function_Froms.Memory.default_return;
+ deps_table = Function_Froms.Memory.bottom }
+ end
in
last_from
@@ -685,7 +685,7 @@ struct
(let s = ref "" in
Stack.iter
(fun kf ->
- s := !s^" <-"^(Format.asprintf "%a" Kernel_function.pretty kf))
+ s := !s^" <-"^(Format.asprintf "%a" Kernel_function.pretty kf))
call_stack;
!s);
Db.yield ();
diff --git a/src/plugins/from/from_parameters.ml b/src/plugins/from/from_parameters.ml
index 24b34fb037bed661b5444823278e6be31c95cc84..6024bcf327135b422f0e7a23f8a4d30c55ac0b7b 100644
--- a/src/plugins/from/from_parameters.ml
+++ b/src/plugins/from/from_parameters.ml
@@ -21,46 +21,46 @@
(**************************************************************************)
include Plugin.Register
- (struct
- let name = "from analysis"
- let shortname = "from"
- let help = "functional dependencies"
- end)
+ (struct
+ let name = "from analysis"
+ let shortname = "from"
+ let help = "functional dependencies"
+ end)
module ForceDeps =
WithOutput
(struct
- let option_name = "-deps"
- let help = "force dependencies display"
- let output_by_default = true
- end)
+ let option_name = "-deps"
+ let help = "force dependencies display"
+ let output_by_default = true
+ end)
module ForceCallDeps =
WithOutput
(struct
- let option_name = "-calldeps"
- let help = "force callsite-wise dependencies"
- let output_by_default = true
- end)
+ let option_name = "-calldeps"
+ let help = "force callsite-wise dependencies"
+ let output_by_default = true
+ end)
module ShowIndirectDeps =
-False
+ False
(struct
- let option_name = "-show-indirect-deps"
- let help = "experimental"
- end)
+ let option_name = "-show-indirect-deps"
+ let help = "experimental"
+ end)
module VerifyAssigns =
-False
+ False
(struct
- let option_name = "-from-verify-assigns"
- let help = "verification of assigns/from clauses for functions with \
- bodies. Implies -calldeps"
- end)
+ let option_name = "-from-verify-assigns"
+ let help = "verification of assigns/from clauses for functions with \
+ bodies. Implies -calldeps"
+ end)
let () =
VerifyAssigns.add_set_hook
(fun _ new_ ->
- if new_ then ForceCallDeps.set true)
+ if new_ then ForceCallDeps.set true)
diff --git a/src/plugins/from/from_register.ml b/src/plugins/from/from_register.ml
index 4d580479eb2f6a13dfe69997c162e361209bceeb..f304820f30a29ebb9e235b314a0de1e917e3d643 100644
--- a/src/plugins/from/from_register.ml
+++ b/src/plugins/from/from_register.ml
@@ -30,20 +30,20 @@ let display fmtopt =
Option.iter (fun fmt -> Format.fprintf fmt "@[<v>") fmtopt;
Callgraph.Uses.iter_in_rev_order
(fun kf ->
- if !Db.Value.is_called kf then
- let header fmt =
- Format.fprintf fmt "Function %a:" Kernel_function.pretty kf
- in
- let pretty =
- if From_parameters.ShowIndirectDeps.get ()
- then pretty_with_indirect
- else !Db.From.pretty
- in
- match fmtopt with
- | None ->
- From_parameters.printf ~header "@[ %a@]" pretty kf
- | Some fmt ->
- Format.fprintf fmt "@[%t@]@ @[ %a]" header pretty kf
+ if !Db.Value.is_called kf then
+ let header fmt =
+ Format.fprintf fmt "Function %a:" Kernel_function.pretty kf
+ in
+ let pretty =
+ if From_parameters.ShowIndirectDeps.get ()
+ then pretty_with_indirect
+ else !Db.From.pretty
+ in
+ match fmtopt with
+ | None ->
+ From_parameters.printf ~header "@[ %a@]" pretty kf
+ | Some fmt ->
+ Format.fprintf fmt "@[%t@]@ @[ %a]" header pretty kf
);
Option.iter (fun fmt -> Format.fprintf fmt "@]") fmtopt
@@ -52,7 +52,7 @@ module SortCalls = struct
(* Sort first by original source code location, then by sid *)
let compare s1 s2 =
let r = Cil_datatype.Location.compare
- (Cil_datatype.Stmt.loc s1) (Cil_datatype.Stmt.loc s2) in
+ (Cil_datatype.Stmt.loc s1) (Cil_datatype.Stmt.loc s2) in
if r = 0
then Cil_datatype.Stmt.compare s1 s2 (* This is not really stable, but no
good criterion is left *)
@@ -61,20 +61,20 @@ end
module MapStmtCalls = Map.Make(SortCalls)
let iter_callwise_calls_sorted f =
- let hkf = Kernel_function.Hashtbl.create 17 in
+ let hkf = Kernel_function.Hashtbl.create 17 in
let kglobal = ref None in
!Db.From.Callwise.iter
(fun ki d ->
match ki with
- | Kglobal -> kglobal := Some d
- | Kstmt s ->
- let kf = Kernel_function.find_englobing_kf s in
- let m =
- try Kernel_function.Hashtbl.find hkf kf
- with Not_found -> MapStmtCalls.empty
- in
- let m = MapStmtCalls.add s d m in
- Kernel_function.Hashtbl.replace hkf kf m
+ | Kglobal -> kglobal := Some d
+ | Kstmt s ->
+ let kf = Kernel_function.find_englobing_kf s in
+ let m =
+ try Kernel_function.Hashtbl.find hkf kf
+ with Not_found -> MapStmtCalls.empty
+ in
+ let m = MapStmtCalls.add s d m in
+ Kernel_function.Hashtbl.replace hkf kf m
);
Callgraph.Uses.iter_in_rev_order
(fun kf ->
@@ -84,8 +84,8 @@ let iter_callwise_calls_sorted f =
with Not_found -> ()
);
match !kglobal with
- | None -> ()
- | Some d -> f Kglobal d
+ | None -> ()
+ | Some d -> f Kglobal d
let main () =
@@ -124,37 +124,37 @@ let main () =
!Db.From.compute_all ();
From_parameters.ForceDeps.output
(fun () ->
- From_parameters.feedback "====== DEPENDENCIES COMPUTED ======@\n\
-These dependencies hold at termination for the executions that terminate:";
- display None;
- From_parameters.feedback "====== END OF DEPENDENCIES ======"
+ From_parameters.feedback "====== DEPENDENCIES COMPUTED ======@\n\
+ These dependencies hold at termination for the executions that terminate:";
+ display None;
+ From_parameters.feedback "====== END OF DEPENDENCIES ======"
)
end;
if forcecalldeps then !Db.From.compute_all_calldeps ();
if not_quiet && forcecalldeps then begin
From_parameters.ForceCallDeps.output
(fun () ->
- From_parameters.feedback "====== DISPLAYING CALLWISE DEPENDENCIES ======";
- iter_callwise_calls_sorted
- (fun ki d ->
- let header, typ =
- match ki with
- | Kglobal ->
- (fun fmt -> Format.fprintf fmt "@[entry point:@]"),
- Kernel_function.get_type (fst (Globals.entry_point ()))
- | Kstmt ({skind = Instr (Call (_, ekf, _, _))} as s) ->
- treat_call s (Cil.typeOf ekf)
- | Kstmt ({skind = Instr (Local_init(_,ConsInit(f,_,_),_))} as s)->
- treat_call s f.vtype
- | _ -> assert false (* Not a call *)
- in
- From_parameters.printf ~header
- "@[ %a@]"
- ((if From_parameters.ShowIndirectDeps.get ()
- then Function_Froms.pretty_with_type_indirect
- else Function_Froms.pretty_with_type) typ)
- d);
- From_parameters.feedback "====== END OF CALLWISE DEPENDENCIES ======";
+ From_parameters.feedback "====== DISPLAYING CALLWISE DEPENDENCIES ======";
+ iter_callwise_calls_sorted
+ (fun ki d ->
+ let header, typ =
+ match ki with
+ | Kglobal ->
+ (fun fmt -> Format.fprintf fmt "@[entry point:@]"),
+ Kernel_function.get_type (fst (Globals.entry_point ()))
+ | Kstmt ({skind = Instr (Call (_, ekf, _, _))} as s) ->
+ treat_call s (Cil.typeOf ekf)
+ | Kstmt ({skind = Instr (Local_init(_,ConsInit(f,_,_),_))} as s)->
+ treat_call s f.vtype
+ | _ -> assert false (* Not a call *)
+ in
+ From_parameters.printf ~header
+ "@[ %a@]"
+ ((if From_parameters.ShowIndirectDeps.get ()
+ then Function_Froms.pretty_with_type_indirect
+ else Function_Froms.pretty_with_type) typ)
+ d);
+ From_parameters.feedback "====== END OF CALLWISE DEPENDENCIES ======";
)
end
diff --git a/src/plugins/from/functionwise.ml b/src/plugins/from/functionwise.ml
index fd9fa80228382ff682e148e29ac01bb0e144147f..9f4eb54bf0a961c0029b390607e62531f66c9fe9 100644
--- a/src/plugins/from/functionwise.ml
+++ b/src/plugins/from/functionwise.ml
@@ -27,10 +27,10 @@ module Tbl =
Kernel_function.Make_Table
(Function_Froms)
(struct
- let name = "Functionwise dependencies"
- let size = 17
- let dependencies = [ Db.Value.self ]
- end)
+ let name = "Functionwise dependencies"
+ let size = 17
+ let dependencies = [ Db.Value.self ]
+ end)
let () = From_parameters.ForceDeps.set_output_dependencies [Tbl.self]
(* Forward reference to a function computing the from for a given function *)
@@ -56,28 +56,28 @@ module To_Use = struct
if Function_Froms.Memory.is_bottom froms.Function_Froms.deps_table
then froms
else
- let f b intervs =
- if Callgraph.Uses.accept_base ~with_formals:true ~with_locals:false kf b
- then Zone.inject b intervs
- else Zone.bottom
- in
- let joiner = Zone.join in
- let projection _ = Int_Intervals.top in
- let zone_substitution =
- Zone.cached_fold ~cache_name:"from cleanup" ~temporary:true
- ~f ~joiner ~empty:Zone.bottom ~projection
- in
- let zone_substitution x =
- try
- zone_substitution x
- with Abstract_interp.Error_Top -> Zone.top
- in
- let map_zone = Function_Froms.Deps.map zone_substitution in
- let subst = Function_Froms.DepsOrUnassigned.subst map_zone in
- let open Function_Froms in
- { deps_table = Memory.map subst froms.deps_table;
- deps_return = Deps.map zone_substitution froms.deps_return;
- }
+ let f b intervs =
+ if Callgraph.Uses.accept_base ~with_formals:true ~with_locals:false kf b
+ then Zone.inject b intervs
+ else Zone.bottom
+ in
+ let joiner = Zone.join in
+ let projection _ = Int_Intervals.top in
+ let zone_substitution =
+ Zone.cached_fold ~cache_name:"from cleanup" ~temporary:true
+ ~f ~joiner ~empty:Zone.bottom ~projection
+ in
+ let zone_substitution x =
+ try
+ zone_substitution x
+ with Abstract_interp.Error_Top -> Zone.top
+ in
+ let map_zone = Function_Froms.Deps.map zone_substitution in
+ let subst = Function_Froms.DepsOrUnassigned.subst map_zone in
+ let open Function_Froms in
+ { deps_table = Memory.map subst froms.deps_table;
+ deps_return = Deps.map zone_substitution froms.deps_return;
+ }
let cleanup_and_save kf froms =
let froms = cleanup kf froms in
@@ -107,8 +107,8 @@ let () =
Db.From.get := To_Use.memo;
Db.From.pretty :=
(fun fmt v ->
- let deps = To_Use.memo v in
- Function_Froms.pretty_with_type (Kernel_function.get_type v) fmt deps);
+ let deps = To_Use.memo v in
+ Function_Froms.pretty_with_type (Kernel_function.get_type v) fmt deps);
Db.From.find_deps_no_transitivity :=
(fun stmt lv ->
let state = Db.Value.get_stmt_state stmt in
@@ -118,8 +118,8 @@ let () =
from From. *)
Db.From.find_deps_no_transitivity_state :=
(fun s e ->
- let deps = From_compute.find_deps_no_transitivity s e in
- Function_Froms.Deps.to_zone deps);
+ let deps = From_compute.find_deps_no_transitivity s e in
+ Function_Froms.Deps.to_zone deps);
ignore (
Db.register_compute "From.compute_all"
diff --git a/src/plugins/gui/analyses_manager.ml b/src/plugins/gui/analyses_manager.ml
index c1319c838726303831b59b78d3ef2014178e1331..889947d00a75ff57a6e750720b6b315d1359f122 100644
--- a/src/plugins/gui/analyses_manager.ml
+++ b/src/plugins/gui/analyses_manager.ml
@@ -41,14 +41,14 @@ let run title filter_name extension loader
(fun () ->
match dialog#run () with
| `EXECUTE ->
- let run f =
- loader f;
- !Db.Main.play ();
- host_window#reset ()
- in
- Option.iter run dialog#filename;
+ let run f =
+ loader f;
+ !Db.Main.play ();
+ host_window#reset ()
+ in
+ Option.iter run dialog#filename;
| `DELETE_EVENT | `CANCEL ->
- ());
+ ());
dialog#destroy ()
let run_module =
diff --git a/src/plugins/gui/book_manager.ml b/src/plugins/gui/book_manager.ml
index fe3baaaaa5722e552c7f2e35bb8092d0ab9a20e4..376061ead151e6e8fc6113a7e03a8e01ed1f6f2c 100644
--- a/src/plugins/gui/book_manager.ml
+++ b/src/plugins/gui/book_manager.ml
@@ -172,7 +172,7 @@ let append_source_tab w titre =
in
let window = (Source_viewer.make ~packing:sw#add ()) in
ignore
- (cbutton#connect#clicked
+ (cbutton#connect#clicked
~callback:(fun () -> delete_view_and_loc w window ()));
(* Remove default pango menu for textviews *)
ignore (window#event#connect#button_press ~callback:
@@ -180,7 +180,7 @@ let append_source_tab w titre =
Q.add_at_end window w.views;
let last = pred (Q.length w.views) in
(* THIS CALLS THE SWITCH_PAGE CALLBACK IMMEDIATELY! *)
- w.notebook#goto_page last;
+ w.notebook#goto_page last;
window
(*
diff --git a/src/plugins/gui/book_manager.mli b/src/plugins/gui/book_manager.mli
index 89614ee59dc75994b07a785916d94f38c48fffff..c9382d9f186a656f58a01fcbe988cad52b7f950d 100644
--- a/src/plugins/gui/book_manager.mli
+++ b/src/plugins/gui/book_manager.mli
@@ -20,16 +20,16 @@
(* *)
(**************************************************************************)
-(** Undocumented.
+(** Undocumented.
Do not use this module if you don't know what you are doing. *)
(* [JS 2011/10/03] Yet useless for the Frama-C platform. It seems to be only
- used by a CEA private plug-in (AP via LC).
+ used by a CEA private plug-in (AP via LC).
To the authors/users of this module: please document it. *)
type t
-val make:
+val make:
?tab_pos:Gtk.Tags.position -> ?packing:(GObj.widget -> unit) -> unit -> t
val get_notebook: t -> GPack.notebook
diff --git a/src/plugins/gui/design.mli b/src/plugins/gui/design.mli
index ea4c1f49f057bbee527a20fa38d88cc42d66cbd5..7827dbddfdb000569b0376109a2557153b223b40 100644
--- a/src/plugins/gui/design.mli
+++ b/src/plugins/gui/design.mli
@@ -159,8 +159,8 @@ class type main_window_extension_points = object
(** register an action to perform when button is released on a given
localizable.
If the button 3 is released, the first argument is popped as a
- contextual menu.
- @plugin development guide *)
+ contextual menu.
+ @plugin development guide *)
method register_source_highlighter :
(reactive_buffer -> Pretty_source.localizable ->
@@ -234,7 +234,7 @@ class type main_window_extension_points = object
be used (line numbers, etc.). *)
method help_message : 'a 'b.
- (<event : GObj.event_ops ; .. > as 'a) ->
+ (<event : GObj.event_ops ; .. > as 'a) ->
('b, Format.formatter, unit) format ->
'b
(** Help message displayed when entering the widget *)
diff --git a/src/plugins/gui/gtk_form.ml b/src/plugins/gui/gtk_form.ml
index da851951be67b45cc9d6c6a7dd99143c9bef5504..1f561e1a83e6669b7c0b761eed4cb88cf94c48da 100644
--- a/src/plugins/gui/gtk_form.ml
+++ b/src/plugins/gui/gtk_form.ml
@@ -67,15 +67,15 @@ let menu entries ?width ?tooltip ~packing get set demon =
match combo_box#active_iter with
| None -> ()
| Some row ->
- let title = (combo_box#model#get ~row ~column) in
- let (_,item) = List.find (fun (t,_) -> t=title) entries in
- set item
+ let title = (combo_box#model#get ~row ~column) in
+ let (_,item) = List.find (fun (t,_) -> t=title) entries in
+ set item
with Not_found -> ()
in
let rec lookup k item = function
| [] -> raise Not_found
| (_,value) :: entries ->
- if value = item then k else lookup (succ k) item entries
+ if value = item then k else lookup (succ k) item entries
in
let update () =
try combo_box#set_active (lookup 0 (get ()) entries)
@@ -93,7 +93,7 @@ let spinner ?(lower=0) ?(upper=max_int) ?width ?tooltip ~packing get set demon =
let spin = GEdit.spin_button ~digits:0 ?width ~packing () in
spin#adjustment#set_bounds
~lower:(float lower) ~upper:(float upper) ~step_incr:1. () ;
- let callback () =
+ let callback () =
let a = spin#value_as_int in
let b = get () in
if a<>b then set a in
diff --git a/src/plugins/gui/gtk_form.mli b/src/plugins/gui/gtk_form.mli
index 769e3d726e92bafaa439e7e8bcb90b88918cc6ff..a8721cd7f4d8edc6ca72e77a6b6c34a89279738c 100644
--- a/src/plugins/gui/gtk_form.mli
+++ b/src/plugins/gui/gtk_form.mli
@@ -20,7 +20,7 @@
(* *)
(**************************************************************************)
-(** {b DEPRECATED.} Helpers around [Gtk_helper] to create side-panel widgets.
+(** {b DEPRECATED.} Helpers around [Gtk_helper] to create side-panel widgets.
This module should not be used anymore.
The provided helpers allow for synchronizing plugin options with
@@ -47,8 +47,8 @@ val check : ?label:string -> bool field
val menu : (string * 'a) list -> ?width:int -> 'a field
val spinner : ?lower:int -> ?upper:int -> ?width:int -> int field
val label : text:string -> packing:(GObj.widget -> unit) -> unit -> unit
-val button :
- label:string -> ?tooltip:string -> callback:(unit -> unit) ->
+val button :
+ label:string -> ?tooltip:string -> callback:(unit -> unit) ->
packing:(GObj.widget -> unit) -> unit -> unit
class form : packing:(GObj.widget -> unit) -> object
diff --git a/src/plugins/gui/gui_printers.ml b/src/plugins/gui/gui_printers.ml
index 617a671256bcf1569bbbabb4c74a0ba3610f3b2d..9b0887e126f5af673f4635258380bcf34633c3f2 100644
--- a/src/plugins/gui/gui_printers.ml
+++ b/src/plugins/gui/gui_printers.ml
@@ -72,14 +72,14 @@ module ResolveLoc =
let tid_of_typ typ =
match typ with
| TNamed _ | TComp _ | TEnum _ ->
- (try
- Some (ResolveTypId.find typ)
- with
- | Not_found ->
- let nextId = ResolveTypId.length () in
- ResolveTypId.replace typ nextId;
- ResolveTyp.replace nextId typ;
- Some nextId)
+ (try
+ Some (ResolveTypId.find typ)
+ with
+ | Not_found ->
+ let nextId = ResolveTypId.length () in
+ ResolveTypId.replace typ nextId;
+ ResolveTyp.replace nextId typ;
+ Some nextId)
| _ -> None
(* Returns the ID associated to a location (adding it to the maps if needed). *)
@@ -88,10 +88,10 @@ let lid_of_loc loc =
ResolveLocId.find loc
with
| Not_found ->
- let nextId = ResolveLocId.length () in
- ResolveLocId.replace loc nextId;
- ResolveLoc.replace nextId loc;
- nextId
+ let nextId = ResolveLocId.length () in
+ ResolveLocId.replace loc nextId;
+ ResolveLoc.replace nextId loc;
+ nextId
(* Returns the base type for a pointer/array, otherwise [t] itself.
E.g. for [t = int***], returns [int]. *)
@@ -120,16 +120,16 @@ let pp_enum_unfolded fmt enum attrs =
let pp_typ_unfolded fmt (t : typ) =
match t with
| TNamed (ty, attrs) ->
- begin
- (* unfolds the typedef, and one step further if it is a TComp/TEnum *)
- match ty.ttype with
- | TComp (comp, _, cattrs) ->
- pp_tcomp_unfolded fmt comp (Cil.addAttributes attrs cattrs)
- | TEnum (enum, eattrs) ->
- pp_enum_unfolded fmt enum (Cil.addAttributes attrs eattrs)
- | _ ->
- Printer.pp_typ fmt (Cil.typeAddAttributes attrs ty.ttype)
- end
+ begin
+ (* unfolds the typedef, and one step further if it is a TComp/TEnum *)
+ match ty.ttype with
+ | TComp (comp, _, cattrs) ->
+ pp_tcomp_unfolded fmt comp (Cil.addAttributes attrs cattrs)
+ | TEnum (enum, eattrs) ->
+ pp_enum_unfolded fmt enum (Cil.addAttributes attrs eattrs)
+ | _ ->
+ Printer.pp_typ fmt (Cil.typeAddAttributes attrs ty.ttype)
+ end
| TComp (comp, _, attrs) -> pp_tcomp_unfolded fmt comp attrs
| TEnum (enum, attrs) -> pp_enum_unfolded fmt enum attrs
| _ -> Printer.pp_typ fmt t
@@ -138,7 +138,7 @@ let pp_typ fmt typ =
match tid_of_typ typ with
| None -> Format.fprintf fmt "@{%a@}" Printer.pp_typ typ
| Some tid ->
- Format.fprintf fmt "@{<link:typ%d>%a@}" tid Printer.pp_typ typ
+ Format.fprintf fmt "@{<link:typ%d>%a@}" tid Printer.pp_typ typ
(* Override the default printer to add <link> tags around types and
some l-values *)
@@ -150,8 +150,8 @@ module LinkPrinter(X: Printer.PrinterClass) = struct
match tid_of_typ t with
| None -> Format.fprintf fmt "@{%a@}" (super#typ ?fundecl nameOpt) t
| Some tid ->
- Format.fprintf fmt "@{<link:typ%d>%a@}"
- tid (super#typ ?fundecl nameOpt) t
+ Format.fprintf fmt "@{<link:typ%d>%a@}"
+ tid (super#typ ?fundecl nameOpt) t
method! varinfo fmt vi =
ResolveVid.replace vi.vid vi;
diff --git a/src/plugins/gui/history.ml b/src/plugins/gui/history.ml
index 29faae0a64ef52297423ec4fb00ee6f53fb12f0b..be4771062cbd89762597bd888bcae9a0465157c5 100644
--- a/src/plugins/gui/history.ml
+++ b/src/plugins/gui/history.ml
@@ -37,17 +37,17 @@ module HistoryElt = struct
let equal e1 e2 = match e1, e2 with
| Global g1, Global g2 -> Cil_datatype.Global.equal g1 g2
| Localizable l1, Localizable l2 ->
- Printer_tag.Localizable.equal l1 l2
+ Printer_tag.Localizable.equal l1 l2
| (Global _ | Localizable _), __ -> false
end)
(* Identify two elements that belong to the same function *)
let in_same_fun e1 e2 =
let f = function
| Global (GFunDecl (_, vi, _) | GFun ({svar = vi}, _)) ->
- (try Some (Globals.Functions.get vi)
- with Not_found -> None)
+ (try Some (Globals.Functions.get vi)
+ with Not_found -> None)
| Localizable l ->
- Pretty_source.kf_of_localizable l
+ Pretty_source.kf_of_localizable l
| _ -> None
in
match f e1 with
@@ -111,14 +111,14 @@ let back () =
let h = CurrentHistory.get () in
match h.current, h.back with
| Some cur, prev :: prevs ->
- let h' = {back = prevs; current = Some prev; forward= cur::h.forward} in
- !display_elt prev;
- CurrentHistory.set h'
+ let h' = {back = prevs; current = Some prev; forward= cur::h.forward} in
+ !display_elt prev;
+ CurrentHistory.set h'
| None, prev :: prevs ->
- let h' = { back = prevs; current = Some prev ; forward = h.forward } in
- !display_elt prev;
- CurrentHistory.set h'
+ let h' = { back = prevs; current = Some prev ; forward = h.forward } in
+ !display_elt prev;
+ CurrentHistory.set h'
| _, [] -> ()
@@ -126,14 +126,14 @@ let forward () =
let h = CurrentHistory.get () in
match h.current, h.forward with
| Some cur, next :: nexts ->
- let h' = { back = cur::h.back; current = Some next; forward = nexts} in
- !display_elt next;
- CurrentHistory.set h'
+ let h' = { back = cur::h.back; current = Some next; forward = nexts} in
+ !display_elt next;
+ CurrentHistory.set h'
| None, next :: nexts ->
- let h' = { back = h.back; current = Some next; forward = nexts } in
- !display_elt next;
- CurrentHistory.set h'
+ let h' = { back = h.back; current = Some next; forward = nexts } in
+ !display_elt next;
+ CurrentHistory.set h'
| _, [] -> ()
@@ -148,12 +148,12 @@ let push cur =
let h' = match h.current with
| None -> { back = h.back; current = Some cur; forward = [] }
| Some prev ->
- if HistoryElt.equal cur prev
- then h
- else if HistoryElt.in_same_fun cur prev then
- { h with current = Some cur }
- else
- { back = prev :: h.back; current = Some cur; forward = [] }
+ if HistoryElt.equal cur prev
+ then h
+ else if HistoryElt.in_same_fun cur prev then
+ { h with current = Some cur }
+ else
+ { back = prev :: h.back; current = Some cur; forward = [] }
in
CurrentHistory.set h'
@@ -230,7 +230,7 @@ let translate_history_elt old_helt =
GAnnot(Dfun_or_pred({l_var_info= {lv_name=new_name}},_), new_loc))
when test_name_file old_name new_name old_loc new_loc ->
- raise (Found_global new_g)
+ raise (Found_global new_g)
| GAsm _, GAsm _
| GText _, GText _
@@ -258,39 +258,39 @@ let translate_history_elt old_helt =
| Localizable ( PStmt(kf,_) | PStmtStart(kf,_) |
PLval(Some kf,_,_) | PExp(Some kf,_,_)
| PTermLval(Some kf,_,_,_) as loc) ->
- begin match global (kf_to_global kf) with
- | None ->
- (** The kernel function can't be found nothing to say *)
- None
- | Some g ->
- (** Try to stay at the same offset in the function *)
- let old_kf_loc = fst (Kernel_function.get_location kf) in
- let old_loc = match ki_of_localizable loc with
- | Kstmt s -> fst (Stmt.loc s)
- | Kglobal -> (* fallback *) old_kf_loc
- in
- let offset = old_loc.Filepath.pos_lnum - old_kf_loc.Filepath.pos_lnum in
- let new_kf_loc = fst (Global.loc g) in
- let new_loc = {new_kf_loc with
- Filepath.pos_lnum = new_kf_loc.Filepath.pos_lnum + offset;
- Filepath.pos_cnum = old_loc.Filepath.pos_cnum;
- }
- in
- match Pretty_source.loc_to_localizable new_loc with
- | None -> (** the line is unknown *)
- Some (Global g)
- | Some locali ->
- begin match kf_of_localizable locali with
- | None -> (** not in a kf so return the start of the function *)
- Some (Global g)
- | Some kf when not (Global.equal (kf_to_global kf) g) ->
- (** Fall in the wrong global, so return the start of the function *)
- Some (Global g)
- | _ ->
- (** Fall in the correct global *)
- Some (Localizable locali)
- end
- end
+ begin match global (kf_to_global kf) with
+ | None ->
+ (** The kernel function can't be found nothing to say *)
+ None
+ | Some g ->
+ (** Try to stay at the same offset in the function *)
+ let old_kf_loc = fst (Kernel_function.get_location kf) in
+ let old_loc = match ki_of_localizable loc with
+ | Kstmt s -> fst (Stmt.loc s)
+ | Kglobal -> (* fallback *) old_kf_loc
+ in
+ let offset = old_loc.Filepath.pos_lnum - old_kf_loc.Filepath.pos_lnum in
+ let new_kf_loc = fst (Global.loc g) in
+ let new_loc = {new_kf_loc with
+ Filepath.pos_lnum = new_kf_loc.Filepath.pos_lnum + offset;
+ Filepath.pos_cnum = old_loc.Filepath.pos_cnum;
+ }
+ in
+ match Pretty_source.loc_to_localizable new_loc with
+ | None -> (** the line is unknown *)
+ Some (Global g)
+ | Some locali ->
+ begin match kf_of_localizable locali with
+ | None -> (** not in a kf so return the start of the function *)
+ Some (Global g)
+ | Some kf when not (Global.equal (kf_to_global kf) g) ->
+ (** Fall in the wrong global, so return the start of the function *)
+ Some (Global g)
+ | _ ->
+ (** Fall in the correct global *)
+ Some (Localizable locali)
+ end
+ end
| Localizable (PLval(None,_,_) | PExp(None,_,_) | PTermLval(None,_,_,_)
| PVDecl(None,_,_)) -> (** no names useful? *) None
| Localizable (PIP _ ) -> (** no names available *) None
diff --git a/src/plugins/gui/history.mli b/src/plugins/gui/history.mli
index 67fa426f9dc8434a0d947feb4bd1234867ef1a9e..b7bb7cc0e19eb1dafce586436811eae37c444656 100644
--- a/src/plugins/gui/history.mli
+++ b/src/plugins/gui/history.mli
@@ -20,7 +20,7 @@
(* *)
(**************************************************************************)
-(** {1 Source code navigation history.}
+(** {1 Source code navigation history.}
@since Nitrogen-20111001 *)
type history_elt =
diff --git a/src/plugins/gui/launcher.ml b/src/plugins/gui/launcher.ml
index be6cf7e656067064add06833ceec9094bbb440b0..b19ad71e25404bb0ceb9a43ce0463f670e8c5628 100644
--- a/src/plugins/gui/launcher.ml
+++ b/src/plugins/gui/launcher.ml
@@ -51,63 +51,63 @@ let add_parameter (box:GPack.box) p =
let hname = highlight name in
(match p.Typed_parameter.accessor with
| Typed_parameter.Bool ({ Typed_parameter.get = get; set = set }, None) ->
- let name = if use_markup then hname else name in
- (* fix bts#510: a parameter [p] must be set if and only if it is set by the
- user in the launcher. In particular, it must not be reset to its old
- value if setting another parameter [p'] modifies [p] via hooking. *)
- let old = get () in
- let set r = if r <> old then set r in
- Kernel_hook.extend (on_bool ~tooltip ~use_markup box name get set);
+ let name = if use_markup then hname else name in
+ (* fix bts#510: a parameter [p] must be set if and only if it is set by the
+ user in the launcher. In particular, it must not be reset to its old
+ value if setting another parameter [p'] modifies [p] via hooking. *)
+ let old = get () in
+ let set r = if r <> old then set r in
+ Kernel_hook.extend (on_bool ~tooltip ~use_markup box name get set);
| Typed_parameter.Bool
({ Typed_parameter.get = get; set = set }, Some negative_name) ->
- let use_markup = is_set () in
- let name, _negative_name =
- if use_markup then hname, highlight negative_name
- else name, negative_name
- in
- let old = get () in
- let set r = if r <> old then set r in
- Kernel_hook.extend
- (on_bool ~tooltip ~use_markup box name (*negative_name*) get set);
+ let use_markup = is_set () in
+ let name, _negative_name =
+ if use_markup then hname, highlight negative_name
+ else name, negative_name
+ in
+ let old = get () in
+ let set r = if r <> old then set r in
+ Kernel_hook.extend
+ (on_bool ~tooltip ~use_markup box name (*negative_name*) get set);
| Typed_parameter.Int ({ Typed_parameter.get = get; set = set }, range) ->
- let use_markup = is_set () in
- let name = if use_markup then hname else name in
- let lower, upper = range () in
- let old = get () in
- let set r = if r <> old then set r in
- Kernel_hook.extend
- (on_int ~tooltip ~use_markup ~lower ~upper ~width:120 box name get set);
+ let use_markup = is_set () in
+ let name = if use_markup then hname else name in
+ let lower, upper = range () in
+ let old = get () in
+ let set r = if r <> old then set r in
+ Kernel_hook.extend
+ (on_int ~tooltip ~use_markup ~lower ~upper ~width:120 box name get set);
| Typed_parameter.String
({ Typed_parameter.get = get; set = set }, possible_values) ->
- let use_markup = is_set () in
- let hname = if use_markup then hname else name in
- let old = get () in
- let widget_value = ref old in
- let w_set r = widget_value := r in
- let w_get () = !widget_value in
- (match possible_values () with
- | [] ->
- let _refresh =
- on_string ~tooltip ~use_markup ~width:250 box hname w_get w_set
- in
- Kernel_hook.extend
- (fun () -> if !widget_value <> old then set !widget_value)
+ let use_markup = is_set () in
+ let hname = if use_markup then hname else name in
+ let old = get () in
+ let widget_value = ref old in
+ let w_set r = widget_value := r in
+ let w_get () = !widget_value in
+ (match possible_values () with
+ | [] ->
+ let _refresh =
+ on_string ~tooltip ~use_markup ~width:250 box hname w_get w_set
+ in
+ Kernel_hook.extend
+ (fun () -> if !widget_value <> old then set !widget_value)
- | v ->
- let validator s =
- let b = List.mem s v in
- if not b then Gui_parameters.error "invalid input `%s' for %s" s name;
- b
- in
- let _refresh =
- on_string_completion
- ~tooltip ~use_markup ~validator v box hname w_get w_set
- in
- Kernel_hook.extend
- (fun () -> if !widget_value <> old then set !widget_value))
+ | v ->
+ let validator s =
+ let b = List.mem s v in
+ if not b then Gui_parameters.error "invalid input `%s' for %s" s name;
+ b
+ in
+ let _refresh =
+ on_string_completion
+ ~tooltip ~use_markup ~validator v box hname w_get w_set
+ in
+ Kernel_hook.extend
+ (fun () -> if !widget_value <> old then set !widget_value))
);
use_markup
diff --git a/src/plugins/gui/menu_manager.ml b/src/plugins/gui/menu_manager.ml
index bb75ce6d774dea2960e148dffdf0775fb006f5a8..67e02cd83e7e2277230e8293f09ca1cf2799c91a 100644
--- a/src/plugins/gui/menu_manager.ml
+++ b/src/plugins/gui/menu_manager.ml
@@ -29,24 +29,24 @@ type callback_state =
| Unit_callback of (unit -> unit)
| Bool_callback of (bool -> unit) * (unit -> bool)
-type entry =
+type entry =
{ e_where: where;
e_callback: callback_state;
e_sensitive: unit -> bool }
-let toolbar
- ?(sensitive=(fun _ -> true)) ~icon ~label ?(tooltip=label) callback =
+let toolbar
+ ?(sensitive=(fun _ -> true)) ~icon ~label ?(tooltip=label) callback =
{ e_where = Toolbar (icon, label, tooltip);
e_callback = callback;
e_sensitive = sensitive }
-let menubar ?(sensitive=(fun _ -> true)) ?icon text callback =
+let menubar ?(sensitive=(fun _ -> true)) ?icon text callback =
{ e_where = Menubar (icon, text);
e_callback = callback;
e_sensitive = sensitive }
-let toolmenubar
- ?(sensitive=(fun _ -> true)) ~icon ~label ?(tooltip=label) callback =
+let toolmenubar
+ ?(sensitive=(fun _ -> true)) ~icon ~label ?(tooltip=label) callback =
{ e_where = ToolMenubar (icon, label, tooltip);
e_callback = callback;
e_sensitive = sensitive }
@@ -91,7 +91,7 @@ class item ?menu ?menu_item ?button group = object (self)
Option.iter
(fun (i : GMenu.menu_item_skel) ->
i#add_accelerator
- ~group ~flags:[ `VISIBLE ] ~modi:[ modifier ] (int_of_char c))
+ ~group ~flags:[ `VISIBLE ] ~modi:[ modifier ] (int_of_char c))
self#menu_item_skel
method menu: GMenu.menu option = menu
@@ -198,23 +198,23 @@ class menu_manager ?packing (_:Gtk_helper.host) =
*)
let b = match callback with
| Unit_callback callback ->
- let b = GButton.tool_button
- ~label:tooltip ~stock ~packing:toolbar_packing ()
- in
- b#set_label label;
- ignore (b#connect#clicked ~callback);
- BStandard b
+ let b = GButton.tool_button
+ ~label:tooltip ~stock ~packing:toolbar_packing ()
+ in
+ b#set_label label;
+ ignore (b#connect#clicked ~callback);
+ BStandard b
| Bool_callback (callback, active) ->
- let b = GButton.toggle_tool_button
- ~active:(active ()) ~label:tooltip ~stock
- ~packing:toolbar_packing ()
- in
- b#set_label tooltip;
- ignore (b#connect#toggled
- ~callback:(fun () -> callback b#get_active));
- set_active_states <-
- (fun () -> b#set_active (active ())) :: set_active_states;
- BToggle b
+ let b = GButton.toggle_tool_button
+ ~active:(active ()) ~label:tooltip ~stock
+ ~packing:toolbar_packing ()
+ in
+ b#set_label tooltip;
+ ignore (b#connect#toggled
+ ~callback:(fun () -> callback b#get_active));
+ set_active_states <-
+ (fun () -> b#set_active (active ())) :: set_active_states;
+ BToggle b
in
(bt_type_as_skel b)#misc#set_tooltip_text tooltip;
toolbar_buttons <- (b, sensitive) :: toolbar_buttons;
@@ -234,8 +234,8 @@ class menu_manager ?packing (_:Gtk_helper.host) =
(match title with
| None -> container_packing, container
| Some s ->
- let sub = snd (add_submenu container ~pos:!menu_pos s) in
- (fun w -> sub#append w), sub
+ let sub = snd (add_submenu container ~pos:!menu_pos s) in
+ (fun w -> sub#append w), sub
)
in
lazy (fst !!aux), lazy (snd !!aux)
@@ -248,24 +248,24 @@ class menu_manager ?packing (_:Gtk_helper.host) =
let add_item_menu stock_opt label callback sensitive =
let item = match stock_opt, callback with
| None, Unit_callback callback ->
- let mi = GMenu.menu_item ~packing:!!menubar_packing ~label () in
- ignore (mi#connect#activate callback);
- MStandard mi
+ let mi = GMenu.menu_item ~packing:!!menubar_packing ~label () in
+ ignore (mi#connect#activate callback);
+ MStandard mi
| Some stock, Unit_callback callback ->
- let image = (GMisc.image ~stock ~xalign:0. () :> GObj.widget) in
- let text = label in
- let packing = !!menubar_packing in
- let mi = Gtk_helper.image_menu_item ~image ~text ~packing in
- ignore (mi#connect#activate callback);
- MStandard mi
+ let image = (GMisc.image ~stock ~xalign:0. () :> GObj.widget) in
+ let text = label in
+ let packing = !!menubar_packing in
+ let mi = Gtk_helper.image_menu_item ~image ~text ~packing in
+ ignore (mi#connect#activate callback);
+ MStandard mi
| _, Bool_callback (callback, active) ->
- let mi = GMenu.check_menu_item
- ~packing:!!menubar_packing ~label ~active:(active ()) ()
- in
- ignore (mi#connect#activate (fun () -> callback mi#active));
- set_active_states <-
- (fun () -> mi#set_active (active ())) :: set_active_states;
- MCheck mi
+ let mi = GMenu.check_menu_item
+ ~packing:!!menubar_packing ~label ~active:(active ()) ()
+ in
+ ignore (mi#connect#activate (fun () -> callback mi#active));
+ set_active_states <-
+ (fun () -> mi#set_active (active ())) :: set_active_states;
+ MCheck mi
in
menubar_items <- (item, sensitive) :: menubar_items;
item
@@ -278,15 +278,15 @@ class menu_manager ?packing (_:Gtk_helper.host) =
let add_item { e_where = kind; e_callback = callback; e_sensitive = sensitive} =
match kind with
| Toolbar(stock, label, tooltip) ->
- let button = add_item_toolbar stock label tooltip callback sensitive in
- new item ~button factory#accel_group
+ let button = add_item_toolbar stock label tooltip callback sensitive in
+ new item ~button factory#accel_group
| Menubar(stock_opt, label) ->
- let menu_item = add_item_menu stock_opt label callback sensitive in
- new item ~menu:!!in_menu ~menu_item factory#accel_group
+ let menu_item = add_item_menu stock_opt label callback sensitive in
+ new item ~menu:!!in_menu ~menu_item factory#accel_group
| ToolMenubar(stock, label, tooltip) ->
- let button = add_item_toolbar stock label tooltip callback sensitive in
- let menu_item = add_item_menu (Some stock) label callback sensitive in
- new item ~menu:!!in_menu ~menu_item ~button factory#accel_group
+ let button = add_item_toolbar stock label tooltip callback sensitive in
+ let menu_item = add_item_menu (Some stock) label callback sensitive in
+ new item ~menu:!!in_menu ~menu_item ~button factory#accel_group
in
let edit_menubar =
List.exists
diff --git a/src/plugins/gui/menu_manager.mli b/src/plugins/gui/menu_manager.mli
index 6b5a3145cd23f67c81a55c7112dff27ff4ec4512..e92f048897d40c730c7b6699061c31c6dd67093f 100644
--- a/src/plugins/gui/menu_manager.mli
+++ b/src/plugins/gui/menu_manager.mli
@@ -111,7 +111,7 @@ class type item = object
end
-(** How to handle a Frama-C menu.
+(** How to handle a Frama-C menu.
@since Boron-20100401 *)
class menu_manager: ?packing:(GObj.widget -> unit) -> Gtk_helper.host ->
object
diff --git a/src/plugins/gui/project_manager.ml b/src/plugins/gui/project_manager.ml
index 5d2c08cc77998476a14f0603aad4b2da7840d1d7..f339fda9d370e3cd56b1e211cc4d7f8e74ca299d 100644
--- a/src/plugins/gui/project_manager.ml
+++ b/src/plugins/gui/project_manager.ml
@@ -100,9 +100,9 @@ let save_project_as (main_ui: Design.main_window_extension_points) project =
(fun () ->
match dialog#run () with
| `SAVE ->
- Option.iter
- (save_in main_ui (dialog :> GWindow.window_skel) project)
- (Option.map Filepath.Normalized.of_string dialog#filename)
+ Option.iter
+ (save_in main_ui (dialog :> GWindow.window_skel) project)
+ (Option.map Filepath.Normalized.of_string dialog#filename)
| `DELETE_EVENT | `CANCEL -> ());
dialog#destroy ()
@@ -127,15 +127,15 @@ let load_project (host_window: Design.main_window_extension_points) =
host_window#protect ~cancelable:true ~parent:(dialog:>GWindow.window_skel)
(fun () -> match dialog#run () with
| `OPEN ->
- begin match dialog#filename with
- | None -> ()
- | Some f ->
- (try ignore (Project.load (Filepath.Normalized.of_string f))
- with Project.IOError s | Failure s ->
- host_window#error
- ~reset:true ~parent:(dialog:>GWindow.window_skel)
- "Cannot load: %s" s)
- end
+ begin match dialog#filename with
+ | None -> ()
+ | Some f ->
+ (try ignore (Project.load (Filepath.Normalized.of_string f))
+ with Project.IOError s | Failure s ->
+ host_window#error
+ ~reset:true ~parent:(dialog:>GWindow.window_skel)
+ "Cannot load: %s" s)
+ end
| `DELETE_EVENT | `CANCEL -> ());
dialog#destroy ()
@@ -155,7 +155,7 @@ let reset ?filter (menu: GMenu.menu) =
match acc with
| [] -> raise Exit
| p2 :: acc ->
- if compare_prj p1 p2 = 0 then acc else raise Exit)
+ if compare_prj p1 p2 = 0 then acc else raise Exit)
!project_radios
pl
in
@@ -253,10 +253,10 @@ and make_project_entries ?filter window menu =
match projects_list ?filter () with
| [] -> assert (filter <> None)
| (pa, _name) :: tl ->
- let mk = mk_project_entry window menu in
- let pa_item = mk pa in
- let group = pa_item#group in
- List.iter (fun (pa, _) -> ignore (mk ~group pa)) tl
+ let mk = mk_project_entry window menu in
+ let pa_item = mk pa in
+ let group = pa_item#group in
+ List.iter (fun (pa, _) -> ignore (mk ~group pa)) tl
and recompute ?filter window menu =
let is_reset = reset ?filter menu in
diff --git a/src/plugins/gui/project_manager.mli b/src/plugins/gui/project_manager.mli
index 388a97c33bc9bc84c04c914849dcfca8513765c2..4d10a1241ab266ec9dfc3490b4b0178da9a14637 100644
--- a/src/plugins/gui/project_manager.mli
+++ b/src/plugins/gui/project_manager.mli
@@ -20,7 +20,7 @@
(* *)
(**************************************************************************)
-(** No function is exported.
+(** No function is exported.
Extension of the GUI in order to support project switching. *)
(*
diff --git a/src/plugins/gui/source_manager.mli b/src/plugins/gui/source_manager.mli
index 58c5ae021948078f2be3bb0ae2a08e0be6b45736..3c310da42b9c6557d4e66f74f51c60cff4566b13 100644
--- a/src/plugins/gui/source_manager.mli
+++ b/src/plugins/gui/source_manager.mli
@@ -28,10 +28,10 @@ val selection_locked : bool ref
(** Prevents the filetree callback from resetting the selected line when it
was selected via a click in the original source viewer. *)
-val make:
+val make:
?tab_pos:Gtk.Tags.position -> ?packing:(GObj.widget -> unit) -> unit -> t
-val load_file:
+val load_file:
t -> ?title:string -> filename:Datatype.Filepath.t -> ?line:int ->
click_cb:(Pretty_source.localizable option -> unit) -> unit -> unit
(** If [line] is 0 then the last line of the text is shown.
diff --git a/src/plugins/gui/warning_manager.mli b/src/plugins/gui/warning_manager.mli
index 16231b02c402e85b73692b00baa1abd7bfeb000a..3e1ba8f09500561d8ef066d39985cb127106dba7 100644
--- a/src/plugins/gui/warning_manager.mli
+++ b/src/plugins/gui/warning_manager.mli
@@ -26,7 +26,7 @@ type t
(** Type of the widget containing the warnings. *)
val make :
- packing:(GObj.widget -> unit) ->
+ packing:(GObj.widget -> unit) ->
callback:(Log.event -> GTree.view_column -> unit) -> t
(** Build a new widget for storing the warnings. *)
diff --git a/src/plugins/gui/wbox.ml b/src/plugins/gui/wbox.ml
index 95e9dd438c83507f347c6c2d525bfa88fdca386d..c07ffdfe7762bf1784a774246a314ff01292aaab 100644
--- a/src/plugins/gui/wbox.ml
+++ b/src/plugins/gui/wbox.ml
@@ -49,15 +49,15 @@ let label ?(fill=false) ?style ?align ?padding text =
let rec populate dir (box : #GPack.box) from = function
| [] -> ()
| Pack(e,padding,w)::ws ->
- box#pack ~from ~expand:(dir e) ~padding w#coerce ;
- populate dir box from ws
+ box#pack ~from ~expand:(dir e) ~padding w#coerce ;
+ populate dir box from ws
| Void::ws ->
- populate dir box from ws
+ populate dir box from ws
| ToEnd::ws ->
- if from = `START then
- populate dir box `END (List.rev ws)
- else
- populate dir box from ws
+ if from = `START then
+ populate dir box `END (List.rev ws)
+ else
+ populate dir box from ws
let hbox ws =
let box = GPack.hbox ~show:true () in
diff --git a/src/plugins/gui/wfile.ml b/src/plugins/gui/wfile.ml
index 7b71886509632f777351a07d2f5ef0d764cd96a0..096c4847753e6a305b7230b60c7fabcec2c2d032 100644
--- a/src/plugins/gui/wfile.ml
+++ b/src/plugins/gui/wfile.ml
@@ -57,18 +57,18 @@ class dialog
| None , None -> ignore (chooser#set_filename "")
| None , Some path -> ignore (chooser#set_filename path)
| Some dir , None ->
- ignore (chooser#set_current_folder dir) ;
- ignore (chooser#set_current_name "")
+ ignore (chooser#set_current_folder dir) ;
+ ignore (chooser#set_current_name "")
| Some dir , Some file ->
- ignore (chooser#set_current_folder dir) ;
- ignore (chooser#set_current_name file)
+ ignore (chooser#set_current_folder dir) ;
+ ignore (chooser#set_current_name file)
end ;
let result = dialog#run () in
dialog#misc#hide () ;
match result with
| `DELETE_EVENT -> ()
| `SELECT ->
- match chooser#get_filenames with | f::_ -> signal#fire f | _ -> ()
+ match chooser#get_filenames with | f::_ -> signal#fire f | _ -> ()
end
diff --git a/src/plugins/gui/widget.ml b/src/plugins/gui/widget.ml
index 361d46e9d7e01f26cf3685fe49f189cb2f5d6bf6..011a7587d25c304c39598f5352829a4aced8aecd 100644
--- a/src/plugins/gui/widget.ml
+++ b/src/plugins/gui/widget.ml
@@ -71,23 +71,23 @@ class label ?(style=`Label) ?(align=`Left) ?width ?text () =
match fg , c with
| None , `NORMAL -> ()
| Some c0 , `NORMAL ->
- w#misc#modify_fg [ `NORMAL , `COLOR c0 ]
+ w#misc#modify_fg [ `NORMAL , `COLOR c0 ]
| None , (#GDraw.color as c) ->
fg <- Some (w#misc#style#fg `NORMAL) ;
w#misc#modify_fg [ `NORMAL , c ]
| Some _ , (#GDraw.color as c) ->
- w#misc#modify_fg [ `NORMAL , c ]
+ w#misc#modify_fg [ `NORMAL , c ]
method set_bg (c : color) =
match bg , c with
| None , `NORMAL -> ()
| Some c0 , `NORMAL ->
- w#misc#modify_bg [ `NORMAL , `COLOR c0 ]
+ w#misc#modify_bg [ `NORMAL , `COLOR c0 ]
| None , (#GDraw.color as c) ->
bg <- Some (w#misc#style#bg `NORMAL) ;
w#misc#modify_bg [ `NORMAL , c ]
| Some _ , (#GDraw.color as c) ->
- w#misc#modify_bg [ `NORMAL , c ]
+ w#misc#modify_bg [ `NORMAL , c ]
initializer
Wutil.on width w#set_width_chars ;
@@ -96,10 +96,10 @@ class label ?(style=`Label) ?(align=`Left) ?width ?text () =
| `Code -> set_monospace w
| `Title -> set_bold_font w
| `Descr ->
- w#set_single_line_mode false ;
- w#set_line_wrap true ;
- w#set_justify `LEFT ;
- set_small_font w
+ w#set_single_line_mode false ;
+ w#set_line_wrap true ;
+ w#set_justify `LEFT ;
+ set_small_font w
method set_text = w#set_text
method set_tooltip msg =
@@ -143,7 +143,7 @@ let shared_icon (f:string) =
default_icon ()
in Hashtbl.add pixbufs f pixbuf ; pixbuf
-let gimage = function
+let gimage = function
| `None -> GMisc.image ()
| `Share f -> GMisc.image ~pixbuf:(shared_icon f) ()
| #GtkStock.id as stock -> GMisc.image ~stock ()
@@ -181,12 +181,12 @@ class button_skel ?align ?(icon=`None) ?tooltip (button:GButton.button_skel) =
match i with
| `None -> button#unset_image ()
| #icon as icn ->
- let image =
- try List.assoc icn images
- with Not_found ->
- let img = gimage icn in
- images <- (icn,img)::images ; img
- in button#set_image image#coerce
+ let image =
+ try List.assoc icn images
+ with Not_found ->
+ let img = gimage icn in
+ images <- (icn,img)::images ; img
+ in button#set_image image#coerce
end
class button ?align ?icon ?label ?(border=true) ?tooltip () =
diff --git a/src/plugins/gui/wpalette.ml b/src/plugins/gui/wpalette.ml
index 96935c86465bbbadc3e56623138f5a9501c5178b..038d386fd7c4ff2210681f593bad801dbd1e2c4b 100644
--- a/src/plugins/gui/wpalette.ml
+++ b/src/plugins/gui/wpalette.ml
@@ -62,10 +62,10 @@ class tool ?label ?tooltip ?content () =
match details with
| None -> hbox#coerce
| Some w ->
- let vbox = GPack.vbox ~show:true () in
- vbox#pack ~expand:false hbox#coerce ;
- vbox#pack ~expand:true ~fill:false w#coerce ;
- vbox#coerce
+ let vbox = GPack.vbox ~show:true () in
+ vbox#pack ~expand:false hbox#coerce ;
+ vbox#pack ~expand:true ~fill:false w#coerce ;
+ vbox#coerce
method tool = (self :> tool)
@@ -120,17 +120,17 @@ class panel () =
val mutable lock = false
val mutable tools = []
-
+
method add_widget (w : GObj.widget) =
box#pack ~expand:false w
-
+
method add_tool (w : tool) =
begin
self#add_widget w#coerce ;
w#on_active (self#active w) ;
tools <- w :: tools ;
end
-
+
method private active w a =
if a && not lock then
try
@@ -139,5 +139,5 @@ class panel () =
lock <- false ;
with e ->
lock <- false ; raise e
-
+
end
diff --git a/src/plugins/gui/wpalette.mli b/src/plugins/gui/wpalette.mli
index dac298466751950bf27deea42abaa1937a3098eb..cbf486921de420979374cfe7f596655dad0a5741 100644
--- a/src/plugins/gui/wpalette.mli
+++ b/src/plugins/gui/wpalette.mli
@@ -27,9 +27,9 @@ open Widget
(**
Configurable palette-tool.
Each tool is a widget that consists of three components:
- - a selectable label with optional status icon
- - an optional action button (icon only)
- - an optional configuration panel
+ - a selectable label with optional status icon
+ - an optional action button (icon only)
+ - an optional configuration panel
The action button is only displayed when associated with a callback.
Clicking the label toggles the configuration panel, if the tool is [active].
@@ -47,7 +47,7 @@ class tool :
method on_active : (bool -> unit) -> unit
method set_active : bool -> unit
method has_action : bool
-
+
method set_label : string -> unit
method set_status : icon -> unit
method set_tooltip : string -> unit
@@ -58,29 +58,29 @@ class tool :
?callback:(unit -> unit) ->
unit -> unit
(** Makes the {i action} button visible.
- - If no icon is provided, the previous one is kept.
- - If no tooltip is provided, the previous one is kept.
- - If no callback is given, the button is deactivated.
- - The callback replaces any previous one and makes
+ - If no icon is provided, the previous one is kept.
+ - If no tooltip is provided, the previous one is kept.
+ - If no callback is given, the button is deactivated.
+ - The callback replaces any previous one and makes
the action button clickable. *)
method clear_action : unit
(** Deactivate and hide the {i action} button. *)
-
+
method set_content : widget -> unit
(** Shall be used at most once, and before [#coerce] or [#widget]. *)
-
+
end
(** A Palette. Implemented with a vertical box with a scrollbar. *)
class panel : unit ->
object
inherit widget
-
+
method add_tool : tool -> unit
- (** Append a palette-tool.
+ (** Append a palette-tool.
The panel ensures that only one tool is selected and toggled. *)
-
+
method add_widget : GObj.widget -> unit
(** Append an arbitrary widget among other widget tools. *)
end
diff --git a/src/plugins/gui/wpane.ml b/src/plugins/gui/wpane.ml
index 4877b7cf30d9f739437a737110378b785c2d1e97..74df52184216a8f39141d95cdfe61914f37a0d05 100644
--- a/src/plugins/gui/wpane.ml
+++ b/src/plugins/gui/wpane.ml
@@ -145,12 +145,12 @@ class ['a] warray ?(dir=`VERTICAL) ?(entry = no_entry) () =
let zs = match after with
| None -> x :: ys
| Some z ->
- let rec hook z x = function
- | [] -> [x]
- | y::ys ->
- if y = z then z :: x :: ys
- else y :: hook z x ys
- in hook z x ys
+ let rec hook z x = function
+ | [] -> [x]
+ | y::ys ->
+ if y = z then z :: x :: ys
+ else y :: hook z x ys
+ in hook z x ys
in self#set zs
method remove x = self#set (self#others x)
@@ -255,13 +255,13 @@ class ['a] dialog ~title ~window ?(resize=false) () =
in box#pack ~expand:false w#coerce ;
match action with
| `ALT r | `SELECT r | `DEFAULT r ->
- w#connect (fun () -> self#select r)
+ w#connect (fun () -> self#select r)
| `CANCEL ->
- w#connect (fun () -> self#select `CANCEL)
+ w#connect (fun () -> self#select `CANCEL)
| `APPLY ->
- w#connect (fun () -> self#select `APPLY)
+ w#connect (fun () -> self#select `APPLY)
| `ACTION f ->
- w#connect f
+ w#connect f
method select r =
begin
diff --git a/src/plugins/gui/wpane.mli b/src/plugins/gui/wpane.mli
index cb2b8a6db9c519289c77b4acc8c7b12070c3694a..1905ea2346f44754b1054ca9183d9da1620bca77 100644
--- a/src/plugins/gui/wpane.mli
+++ b/src/plugins/gui/wpane.mli
@@ -60,21 +60,21 @@ class form : unit ->
method add_label_widget : GObj.widget -> unit
(** Inserts a small (fixed) widget in place of a label.
- Moves to right column. *)
+ Moves to right column. *)
method add_field : ?label:string -> ?field:field -> GObj.widget -> unit
(** Inserts an entry in the form.
Optional label is inserted in right column is specified.
Default [field] is [`Field].
Moves to next line. *)
-
+
method add_row :
?field:field ->
?xpadding:int ->
?ypadding:int -> GObj.widget -> unit
- (** Inserts a wide entry in the form, spanning the two columns.
- Default [field] is [`Field].
- Moves to next line. *)
+ (** Inserts a wide entry in the form, spanning the two columns.
+ Default [field] is [`Field].
+ Moves to next line. *)
end
(** {2 Tabbed-pane} *)
diff --git a/src/plugins/gui/wtable.ml b/src/plugins/gui/wtable.ml
index 82069877008c14f4ee42ae106ac2b1c1a57b2a0f..2ecfb597fa88b54e88a0908fd91d5899c6733dd4 100644
--- a/src/plugins/gui/wtable.ml
+++ b/src/plugins/gui/wtable.ml
@@ -111,8 +111,8 @@ class ['a] makecolumns ?packing ?width ?height
method scroll =
match scroll with
| None ->
- let s = GBin.scrolled_window ?width ?height () in
- s#add view#coerce ; scroll <- Some s ; s
+ let s = GBin.scrolled_window ?width ?height () in
+ s#add view#coerce ; scroll <- Some s ; s
| Some s -> s
method pack packing = packing self#scroll#coerce
@@ -158,12 +158,12 @@ class ['a] makecolumns ?packing ?width ?height
let y = int_of_float (Button.y evt) in
match view#get_path_at_pos ~x ~y with
| Some (path,col,_,_) ->
- begin
- match model#custom_get_iter path with
- | None -> false
- | Some item ->
- let () = f item col in false
- end
+ begin
+ match model#custom_get_iter path with
+ | None -> false
+ | Some item ->
+ let () = f item col in false
+ end
| _ -> false
end
else false
@@ -173,11 +173,11 @@ class ['a] makecolumns ?packing ?width ?height
let callback () =
match view#get_cursor () with
| Some path , Some col ->
- begin
- match model#custom_get_iter path with
- | None -> ()
- | Some item -> f item col
- end
+ begin
+ match model#custom_get_iter path with
+ | None -> ()
+ | Some item -> f item col
+ end
| _ -> ()
in ignore (view#connect#cursor_changed ~callback)
@@ -265,9 +265,9 @@ class ['a] glist_model (m : 'a listmodel) =
method custom_iter_children e = match e with
| None when (m#size > 0) ->
- Some(m#get 0)
+ Some(m#get 0)
| _ ->
- None
+ None
method custom_iter_has_child (_:'a) =
false
@@ -279,7 +279,7 @@ class ['a] glist_model (m : 'a listmodel) =
method custom_iter_nth_child r k = match r with
| Some _ -> failwith "GwList: no nth-child"
| None ->
- if k < m#size then Some (m#get k) else None
+ if k < m#size then Some (m#get k) else None
method custom_iter_parent (_:'a) = None
diff --git a/src/plugins/gui/wtext.ml b/src/plugins/gui/wtext.ml
index 291e0ff838c961b1758423b2a298f86fd4fa9020..c905fecaee0a4ab0cc015e83ea3d41e9d218fbc6 100644
--- a/src/plugins/gui/wtext.ml
+++ b/src/plugins/gui/wtext.ml
@@ -85,7 +85,7 @@ let configure tag = function
| StyleSet -> StyleSet
| Style [] -> NoStyle
| Style sty -> tag#set_properties sty ; StyleSet
-
+
(* -------------------------------------------------------------------------- *)
(* --- Monomorphic Marker --- *)
(* -------------------------------------------------------------------------- *)
@@ -110,7 +110,7 @@ class ['a] poly_marker
object(self)
(*--- Style Configuration ---*)
-
+
val mutable style_props = NoStyle
val mutable hover_props = Style (List.assoc "hover" css_sheet)
val mutable to_configure = true
@@ -125,7 +125,7 @@ class ['a] poly_marker
hover_props <- configure hover hover_props ;
to_configure <- false ;
end
-
+
val mutable demon : (GdkEvent.Button.t -> 'a entry -> unit) list = []
val mutable demon_click : ('a entry -> unit) list = []
val mutable demon_double : ('a entry -> unit) list = []
@@ -168,7 +168,7 @@ class ['a] poly_marker
registry (p,q,{ hover ; click }) ;
ignore (fire e demon_added) ;
end
-
+
method wrap pp (fmt:Format.formatter) (w:'a) : unit =
self#mark w pp fmt w
@@ -176,7 +176,7 @@ class ['a] poly_marker
'b. 'a ->
(Format.formatter -> 'b -> unit) -> Format.formatter -> 'b -> unit =
fun e pp fmt w ->
- wrapper (fun p q -> self#add (p,q,e)) (fun fmt -> pp fmt w) fmt
+ wrapper (fun p q -> self#add (p,q,e)) (fun fmt -> pp fmt w) fmt
end
@@ -212,7 +212,7 @@ class text ?(autoscroll=false) ?(width=80) ?(indent=60) () =
val mutable index : blind Rangemap.t = Rangemap.empty
val mutable hovered = None
val mutable double = false
-
+
(* -------------------------------------------------------------------------- *)
(* --- Text Initializer --- *)
(* -------------------------------------------------------------------------- *)
@@ -289,10 +289,10 @@ class text ?(autoscroll=false) ?(width=80) ?(indent=60) () =
match links with
| Some marker -> marker
| None ->
- let marker = self#marker in
- marker#set_style (List.assoc "link" css_sheet) ;
- marker#set_hover (List.assoc "hover" css_sheet) ;
- links <- Some marker ; marker
+ let marker = self#marker in
+ marker#set_style (List.assoc "link" css_sheet) ;
+ marker#set_hover (List.assoc "hover" css_sheet) ;
+ links <- Some marker ; marker
method private link p name =
let q = buffer#end_iter#offset in
@@ -320,7 +320,7 @@ class text ?(autoscroll=false) ?(width=80) ?(indent=60) () =
method private css_style name props =
let sty = TAG(buffer#create_tag ~name props) in
Hashtbl.replace css name sty ; sty
-
+
method private tag name =
if Hashtbl.mem marks name then MARK(buffer#end_iter#offset,name)
else
@@ -343,17 +343,17 @@ class text ?(autoscroll=false) ?(width=80) ?(indent=60) () =
match self#tag name with
| PLAIN | LINK _ | MARK _ -> ()
| TAG tag ->
- let start = buffer#get_iter (`OFFSET p) in
- let stop = buffer#get_iter (`OFFSET q) in
- buffer#apply_tag tag ~start ~stop
+ let start = buffer#get_iter (`OFFSET p) in
+ let stop = buffer#get_iter (`OFFSET q) in
+ buffer#apply_tag tag ~start ~stop
method remove_style name p q =
match Hashtbl.find css name with
| PLAIN | LINK _ | MARK _ -> ()
| TAG tag ->
- let start = buffer#get_iter (`OFFSET p) in
- let stop = buffer#get_iter (`OFFSET q) in
- buffer#remove_tag tag ~start ~stop
+ let start = buffer#get_iter (`OFFSET p) in
+ let stop = buffer#get_iter (`OFFSET q) in
+ buffer#remove_tag tag ~start ~stop
method remove_all names =
let start,stop = buffer#bounds in
@@ -376,18 +376,18 @@ class text ?(autoscroll=false) ?(width=80) ?(indent=60) () =
| `BUTTON_PRESS -> double <- false ; false
| `TWO_BUTTON_PRESS -> double <- true ; false
| `BUTTON_RELEASE ->
- begin
- match hovered with
- | None -> ()
- | Some (_,_,blind) ->
- blind.click double (GdkEvent.Button.cast evt)
- end ; false
+ begin
+ match hovered with
+ | None -> ()
+ | Some (_,_,blind) ->
+ blind.click double (GdkEvent.Button.cast evt)
+ end ; false
| `MOTION_NOTIFY ->
- let offset = GtkText.Iter.get_offset iter in
- let entry =
- try Some(Rangemap.find offset offset index)
- with Not_found -> None
- in self#hover entry ; false
+ let offset = GtkText.Iter.get_offset iter in
+ let entry =
+ try Some(Rangemap.find offset offset index)
+ with Not_found -> None
+ in self#hover entry ; false
| _ -> false
in ( ignore (react#connect#event ~callback) ; reactive <- true )
@@ -396,21 +396,21 @@ class text ?(autoscroll=false) ?(width=80) ?(indent=60) () =
| Some e0 , Some e when e == e0 -> ()
| None , None -> ()
| _ ->
- begin
- (match hovered with None -> () | Some (_,_,{hover}) ->
+ begin
+ (match hovered with None -> () | Some (_,_,{hover}) ->
let start,stop = buffer#bounds in
buffer#remove_tag hover ~start ~stop) ;
- (match h with None -> () | Some (a,b,{hover}) ->
+ (match h with None -> () | Some (a,b,{hover}) ->
let start = buffer#get_iter (`OFFSET a) in
let stop = buffer#get_iter (`OFFSET b) in
self#hover None ;
buffer#apply_tag hover ~start ~stop) ;
- hovered <- h
- end
+ hovered <- h
+ end
method private register e =
index <- Rangemap.add e index
-
+
(* -------------------------------------------------------------------------- *)
(* --- User API --- *)
(* -------------------------------------------------------------------------- *)
@@ -420,19 +420,19 @@ class text ?(autoscroll=false) ?(width=80) ?(indent=60) () =
method printf : 'a. ?scroll:bool ->
('a,Format.formatter,unit) format -> 'a =
fun ?(scroll=autoscroll) text ->
- (* Save current number of lines in the buffer *)
- let line = view#buffer#line_count in
- let finally fmt =
- Format.pp_print_flush fmt () ;
- Hashtbl.clear marks ;
- hid <- 0 ;
- ruled <- false ;
- if scroll then
- (* scrolling must be performed asynchronously using Gtk_helper.later,
- otherwise it will not take into account the newly added text. *)
- Wutil.later (self#scroll ~line)
- in
- Format.kfprintf finally self#fmt text
+ (* Save current number of lines in the buffer *)
+ let line = view#buffer#line_count in
+ let finally fmt =
+ Format.pp_print_flush fmt () ;
+ Hashtbl.clear marks ;
+ hid <- 0 ;
+ ruled <- false ;
+ if scroll then
+ (* scrolling must be performed asynchronously using Gtk_helper.later,
+ otherwise it will not take into account the newly added text. *)
+ Wutil.later (self#scroll ~line)
+ in
+ Format.kfprintf finally self#fmt text
method hrule =
if not ruled then
@@ -443,7 +443,7 @@ class text ?(autoscroll=false) ?(width=80) ?(indent=60) () =
Format.pp_print_newline self#fmt () ;
ruled <- true ;
end
-
+
method lines = view#buffer#line_count
method scroll ?line () =
diff --git a/src/plugins/gui/wtext.mli b/src/plugins/gui/wtext.mli
index e7afc48bf36638d11bf833bf0324a56d230b8418..7e16e811f27cc93736cef1ec886d8d864a130488 100644
--- a/src/plugins/gui/wtext.mli
+++ b/src/plugins/gui/wtext.mli
@@ -50,7 +50,7 @@ class type ['a] marker =
method add : 'a entry -> unit
(** Register an entry *)
-
+
end
class text : ?autoscroll:bool -> ?width:int -> ?indent:int -> unit ->
@@ -64,7 +64,7 @@ class text : ?autoscroll:bool -> ?width:int -> ?indent:int -> unit ->
(** Append material to the text buffer, optionally scrolling it to the
beginning of the message (defaults to autoscrolling setting).
- The underlying formatter (method [fmt]) recognizes the following default
+ The underlying formatter (method [fmt]) recognizes the following default
tags:
- ["bf"] bold face
- ["it"] italic style
@@ -76,10 +76,10 @@ class text : ?autoscroll:bool -> ?width:int -> ?indent:int -> unit ->
- ["fg:<color name>"] foreground color
- ["bg:<color name>"] background color
- ["link:<name>"] add a link marker
-
+
Properties for any tag (except parametric and mark) can be modified
with method [set_tag_style].
-
+
[t#printf] is a shortcut for [Format.fprintf t#fmt] followed
by flushing and optional scrolling. *)
diff --git a/src/plugins/impact/Impact.mli b/src/plugins/impact/Impact.mli
index 8a177504b16ead1779a8067d27b430d0f513fb2b..c6526973a3639f1de13d153b29e4505c63922967 100644
--- a/src/plugins/impact/Impact.mli
+++ b/src/plugins/impact/Impact.mli
@@ -28,13 +28,13 @@ open Cil_types
@see <../impact/index.html> internal documentation. *)
module Register : sig
val compute_pragmas: (unit -> stmt list)
- (** Compute the impact analysis from the impact pragma in the program.
- Print and slice the results according to the parameters -impact-print
- and -impact-slice.
- @return the impacted statements *)
+ (** Compute the impact analysis from the impact pragma in the program.
+ Print and slice the results according to the parameters -impact-print
+ and -impact-slice.
+ @return the impacted statements *)
val from_stmt: (stmt -> stmt list)
- (** Compute the impact analysis of the given statement.
- @return the impacted statements *)
+ (** Compute the impact analysis of the given statement.
+ @return the impacted statements *)
val from_nodes:
(kernel_function -> PdgTypes.Node.t list -> PdgTypes.NodeSet.t)
(** Compute the impact analysis of the given set of PDG nodes,
diff --git a/src/plugins/impact/compute_impact.ml b/src/plugins/impact/compute_impact.ml
index 6ce1a5dbf944c32c8b40440e98209d1b79e2f19f..e6011b9cf1fb4feb335dfee79176284442e4f2cc 100644
--- a/src/plugins/impact/compute_impact.ml
+++ b/src/plugins/impact/compute_impact.ml
@@ -60,58 +60,58 @@ type result = nodes KFM.t
(* Modelization of a call. The first function (the caller) calls the second
(the callee) at the given statement. *)
module KfKfCall = Datatype.Triple_with_collections
- (Kernel_function)(Kernel_function)(Cil_datatype.Stmt)
- (struct let module_name = "Impact.Compute.KfKfCall" end)
+ (Kernel_function)(Kernel_function)(Cil_datatype.Stmt)
+ (struct let module_name = "Impact.Compute.KfKfCall" end)
(** Worklist maintained by the plugin to build its results *)
type worklist = {
mutable todo: todolist (** nodes that are impacted, but that have not been
- propagated yet. *);
+ propagated yet. *);
mutable result: result (** impacted nodes. This field only grows.
- An invariant is that nodes in [todolist] are not already in [result],
- except with differing [init] fields. *);
+ An invariant is that nodes in [todolist] are not already in [result],
+ except with differing [init] fields. *);
mutable downward_calls: Pdg_aux.call_interface KfKfCall.Map.t
- (** calls for which an input may be impacted. If so, we must compute the
- impact within the called function. For each call, we associate to each
- PDG input of the callee the nodes that define the input in the caller.
- The contents of this field grow. *);
+(** calls for which an input may be impacted. If so, we must compute the
+ impact within the called function. For each call, we associate to each
+ PDG input of the callee the nodes that define the input in the caller.
+ The contents of this field grow. *);
mutable callers: KFS.t (** all the callers of the functions in which the
- initial nodes are located. Constant after initialization, used to
- initialize [upward_calls] below. *);
+ initial nodes are located. Constant after initialization, used to
+ initialize [upward_calls] below. *);
mutable upward_calls: Pdg_aux.call_interface Lazy.t KfKfCall.Map.t
- (** calls for which an output may be impacted. If so, we must compute the
- impact after the call in the caller (which is part of the [callers]
- field by construction). For each output node at the call point in the
- caller, associate all the nodes of the callee that define this output.
- The field is lazy: if the impact "dies" before before reaching the call,
- we may avoid a costly computation. Constant once initialized. *);
+(** calls for which an output may be impacted. If so, we must compute the
+ impact after the call in the caller (which is part of the [callers]
+ field by construction). For each output node at the call point in the
+ caller, associate all the nodes of the callee that define this output.
+ The field is lazy: if the impact "dies" before before reaching the call,
+ we may avoid a costly computation. Constant once initialized. *);
mutable fun_changed_downward: KFS.t (** Functions in which a new pdg node has
- been found since the last iteration. The impact on downward calls with
- those callers will have to be computed again. *);
+ been found since the last iteration. The impact on downward calls with
+ those callers will have to be computed again. *);
mutable fun_changed_upward: KFS.t (** Functions in which a new pdg node has
- been found. The impact on upward calls to those callees
- will have to be computed again. *);
+ been found. The impact on upward calls to those callees
+ will have to be computed again. *);
mutable skip: Locations.Zone.t (** Locations for which the impact is
- dismissed. Nodes that involve only those zones are skipped. Constant
- after initialization *);
+ dismissed. Nodes that involve only those zones are skipped. Constant
+ after initialization *);
mutable initial_nodes: nodes KFM.t
- (** Nodes that are part of the initial impact query, or directly
- equivalent to those (corresponding nodes in a caller). *);
+(** Nodes that are part of the initial impact query, or directly
+ equivalent to those (corresponding nodes in a caller). *);
mutable unimpacted_initial: nodes KFM.t
- (** Initial nodes (as defined above) that are not "self-impacting"
- so far. Those nodes will not be part of the final results. *);
+(** Initial nodes (as defined above) that are not "self-impacting"
+ so far. Those nodes will not be part of the final results. *);
mutable reason: reason_graph
- (** Reasons why nodes in [result] are marked as impacted. *);
+(** Reasons why nodes in [result] are marked as impacted. *);
compute_reason: bool (** compute the field [reason]; may be costly *);
}
@@ -127,7 +127,7 @@ let result_by_kf wl kf =
let result_to_node_origin (r: result) : Reason_graph.nodes_origin =
KFM.fold
(fun kf ns acc ->
- NS.fold (fun (n, _) acc -> PdgTypes.Node.Map.add n kf acc) ns acc)
+ NS.fold (fun (n, _) acc -> PdgTypes.Node.Map.add n kf acc) ns acc)
r PdgTypes.Node.Map.empty
let initial_to_node_set (init: nodes KFM.t) : NS.t =
@@ -150,8 +150,8 @@ let remove_from_unimpacted_initial wl kf (n, z) =
;;
(** Add a node to the sets of impacted nodes. Update the various fields
- of the worklist that need it. [init] indicates that the node
- is added only because it belongs to the set of initial nodes. *)
+ of the worklist that need it. [init] indicates that the node
+ is added only because it belongs to the set of initial nodes. *)
let add_to_result wl n kf init =
if init = false then remove_from_unimpacted_initial wl kf n;
(* if useful, mark that a new node was found in [kf] *)
@@ -167,30 +167,30 @@ let add_to_result wl n kf init =
case the node should be skipped entirely *)
let node_to_skip skip n =
match !Db.Pdg.node_key n with
- | Key.SigKey (Signature.In (Signature.InImpl z))
- | Key.SigKey (Signature.Out (Signature.OutLoc z))
- | Key.SigCallKey (_, Signature.In (Signature.InImpl z))
- | Key.SigCallKey (_, Signature.Out (Signature.OutLoc z)) ->
- Locations.Zone.equal Locations.Zone.bottom
- (Locations.Zone.diff z skip)
- | _ -> false
+ | Key.SigKey (Signature.In (Signature.InImpl z))
+ | Key.SigKey (Signature.Out (Signature.OutLoc z))
+ | Key.SigCallKey (_, Signature.In (Signature.InImpl z))
+ | Key.SigCallKey (_, Signature.Out (Signature.OutLoc z)) ->
+ Locations.Zone.equal Locations.Zone.bottom
+ (Locations.Zone.diff z skip)
+ | _ -> false
(** Auxiliary function, used to refuse some nodes that should not go in
the results *)
let filter wl (n, z) =
not (Locations.Zone.is_bottom z) &&
match !Db.Pdg.node_key n with
- | Key.SigKey (Signature.In Signature.InCtrl) -> false
- (* do not consider node [InCtrl]. YYY: find when this may happen *)
- | Key.VarDecl _ -> false
- (* do not consider variable declarations. This is probably impossible
- in a forward analysis anyway. *)
- | _ ->
- if node_to_skip wl.skip n then (
- Options.debug ~once:true ~level:2 "skipping node %a as required"
- PdgTypes.Node.pretty n;
- false)
- else true
+ | Key.SigKey (Signature.In Signature.InCtrl) -> false
+ (* do not consider node [InCtrl]. YYY: find when this may happen *)
+ | Key.VarDecl _ -> false
+ (* do not consider variable declarations. This is probably impossible
+ in a forward analysis anyway. *)
+ | _ ->
+ if node_to_skip wl.skip n then (
+ Options.debug ~once:true ~level:2 "skipping node %a as required"
+ PdgTypes.Node.pretty n;
+ false)
+ else true
(** Add a new edge in the graph explaining the results *)
let add_to_reason wl ~nsrc ~ndst rt =
@@ -258,16 +258,16 @@ let add_to_do_part_of_initial wl kf pdg n =
unimpacted_initial fields (it may leave the second later) *)
Options.debug ~level:2 "node %a is a part of the initial impact"
Pdg_aux.pretty_node n;
- let unimpacted_kf = unimpacted_initial_by_kf wl kf in
- let new_unimpacted = NS.add' n unimpacted_kf in
- let new_initial = NS.add' n initial_nodes in
- wl.unimpacted_initial <- KFM.add kf new_unimpacted wl.unimpacted_initial;
- wl.initial_nodes <- KFM.add kf new_initial wl.initial_nodes;
+ let unimpacted_kf = unimpacted_initial_by_kf wl kf in
+ let new_unimpacted = NS.add' n unimpacted_kf in
+ let new_initial = NS.add' n initial_nodes in
+ wl.unimpacted_initial <- KFM.add kf new_unimpacted wl.unimpacted_initial;
+ wl.initial_nodes <- KFM.add kf new_initial wl.initial_nodes;
end
;;
(** From now on, most functions will pass [init = false] to [add_to_do_aux]. We
- define an alias instead *)
+ define an alias instead *)
let add_to_do = add_to_do_aux ~init:false
@@ -321,61 +321,61 @@ let add_downward_call wl (caller_kf, pdg) (called_kf, called_pdg) stmt =
field [downward_calls]. *)
let downward_one_call_node wl (pnode, _ as node) caller_kf pdg =
match !Db.Pdg.node_key pnode with
- | Key.SigKey (Signature.In Signature.InCtrl) (* never in the worklist *)
- | Key.VarDecl _ (* never in the worklist *)
- | Key.CallStmt _ (* pdg returns a SigCallKey instead *)
- -> assert false
-
- | Key.SigKey _ | Key.Stmt _ | Key.Label _ ->
- (* Only intraprocedural part needed, done by
- [intraprocedural_one_node] *) ()
-
- | Key.SigCallKey(id, key) ->
- let stmt = Key.call_from_id id in
- let called_kfs = Db.Value.call_to_kernel_function stmt in
- KFS.iter
- (fun called_kf ->
- let called_pdg = !Db.Pdg.get called_kf in
- let nodes_callee, pdg_ok =
- Options.debug ~level:3 "%a: considering call to %a"
- Pdg_aux.pretty_node node Kernel_function.pretty called_kf;
- try
- (match key with
- | Signature.In (Signature.InNum n) ->
- (try [!Db.Pdg.find_input_node called_pdg n,
- Locations.Zone.top]
- with Not_found -> [])
- | Signature.In Signature.InCtrl ->
- (try [!Db.Pdg.find_entry_point_node called_pdg,
- Locations.Zone.top]
- with Not_found -> [])
- | Signature.In (Signature.InImpl _) -> assert false
- | Signature.Out _ -> []
- ), true
- with
- | Db.Pdg.Top ->
- Options.warning
- "no precise pdg for function %s. \n\
-Ignoring this function in the analysis (potentially incorrect results)."
- (Kernel_function.get_name called_kf);
- [], false
- | Db.Pdg.Bottom ->
- (*Function that fails or never returns immediately *)
- [], false
- | Not_found -> assert false
- in
- Options.debug ~level:4 "Direct call nodes %a"
- (Pretty_utils.pp_list ~sep:" " Pdg_aux.pretty_node) nodes_callee;
- List.iter
- (fun n ->
- add_to_reason wl ~nsrc:node ~ndst:n InterproceduralDownward;
- add_to_do wl called_kf called_pdg n
- ) nodes_callee;
- if pdg_ok then
- add_downward_call wl (caller_kf, pdg) (called_kf, called_pdg) stmt
- ) called_kfs;
- Options.debug ~level:3 "propagation of call %a done"
- Pdg_aux.pretty_node node
+ | Key.SigKey (Signature.In Signature.InCtrl) (* never in the worklist *)
+ | Key.VarDecl _ (* never in the worklist *)
+ | Key.CallStmt _ (* pdg returns a SigCallKey instead *)
+ -> assert false
+
+ | Key.SigKey _ | Key.Stmt _ | Key.Label _ ->
+ (* Only intraprocedural part needed, done by
+ [intraprocedural_one_node] *) ()
+
+ | Key.SigCallKey(id, key) ->
+ let stmt = Key.call_from_id id in
+ let called_kfs = Db.Value.call_to_kernel_function stmt in
+ KFS.iter
+ (fun called_kf ->
+ let called_pdg = !Db.Pdg.get called_kf in
+ let nodes_callee, pdg_ok =
+ Options.debug ~level:3 "%a: considering call to %a"
+ Pdg_aux.pretty_node node Kernel_function.pretty called_kf;
+ try
+ (match key with
+ | Signature.In (Signature.InNum n) ->
+ (try [!Db.Pdg.find_input_node called_pdg n,
+ Locations.Zone.top]
+ with Not_found -> [])
+ | Signature.In Signature.InCtrl ->
+ (try [!Db.Pdg.find_entry_point_node called_pdg,
+ Locations.Zone.top]
+ with Not_found -> [])
+ | Signature.In (Signature.InImpl _) -> assert false
+ | Signature.Out _ -> []
+ ), true
+ with
+ | Db.Pdg.Top ->
+ Options.warning
+ "no precise pdg for function %s. \n\
+ Ignoring this function in the analysis (potentially incorrect results)."
+ (Kernel_function.get_name called_kf);
+ [], false
+ | Db.Pdg.Bottom ->
+ (*Function that fails or never returns immediately *)
+ [], false
+ | Not_found -> assert false
+ in
+ Options.debug ~level:4 "Direct call nodes %a"
+ (Pretty_utils.pp_list ~sep:" " Pdg_aux.pretty_node) nodes_callee;
+ List.iter
+ (fun n ->
+ add_to_reason wl ~nsrc:node ~ndst:n InterproceduralDownward;
+ add_to_do wl called_kf called_pdg n
+ ) nodes_callee;
+ if pdg_ok then
+ add_downward_call wl (caller_kf, pdg) (called_kf, called_pdg) stmt
+ ) called_kfs;
+ Options.debug ~level:3 "propagation of call %a done"
+ Pdg_aux.pretty_node node
@@ -396,7 +396,7 @@ let downward_one_call_inputs wl kf_caller kf_callee (node, deps) =
let node' = (node, z) in
NS.iter'
(fun nsrc ->
- add_to_reason wl ~nsrc ~ndst:node' InterproceduralDownward)
+ add_to_reason wl ~nsrc ~ndst:node' InterproceduralDownward)
inter;
add_to_do wl kf_callee (!Db.Pdg.get kf_callee) node';
;;
@@ -472,7 +472,7 @@ let upward_in_callers wl =
if KFS.mem callee wl.fun_changed_upward then
List.iter
(fun (n, nodes) ->
- let results_for_callee = result_by_kf wl callee in
+ let results_for_callee = result_by_kf wl callee in
if NS.intersects nodes results_for_callee then
let inter = NS.inter nodes results_for_callee in
let unimpacted_callee = unimpacted_initial_by_kf wl callee in
@@ -482,8 +482,8 @@ let upward_in_callers wl =
let z = zone_restrict inter in
let n = (n, z) in
NS.iter' (fun nsrc ->
- add_to_reason wl ~nsrc ~ndst:n InterproceduralUpward
- ) inter;
+ add_to_reason wl ~nsrc ~ndst:n InterproceduralUpward
+ ) inter;
if init then
add_to_do_part_of_initial wl caller (!Db.Pdg.get caller) n
else
@@ -500,10 +500,10 @@ let upward_in_callers wl =
(** Compute the initial state of the worklist. *)
let initial_worklist ?(skip=Locations.Zone.bottom) ?(reason=false) nodes kf =
- let initial =
- KFM.add kf
- (List.fold_left (fun s n -> NS.add' n s) NS.empty nodes)
- KFM.empty;
+ let initial =
+ KFM.add kf
+ (List.fold_left (fun s n -> NS.add' n s) NS.empty nodes)
+ KFM.empty;
in
let wl = {
todo = NM.empty;
@@ -526,7 +526,7 @@ let initial_worklist ?(skip=Locations.Zone.bottom) ?(reason=false) nodes kf =
if Options.Upward.get () then KFS.singleton kf else KFS.empty
in
(* Fill the [callers] and [upward_calls] fields *)
- all_upward_callers wl initial_callers;
+ all_upward_callers wl initial_callers;
wl
(** To compute the impact of a statement, find the initial PDG nodes that must
@@ -545,12 +545,12 @@ let initial_nodes ~skip kf stmt =
in
List.filter filter all
with
- | PdgTypes.Pdg.Top ->
- Options.warning
- "analysis of %a is too imprecise, impact cannot be computed@."
- Kernel_function.pretty kf;
- []
- | Not_found -> assert false
+ | PdgTypes.Pdg.Top ->
+ Options.warning
+ "analysis of %a is too imprecise, impact cannot be computed@."
+ Kernel_function.pretty kf;
+ []
+ | Not_found -> assert false
else begin
Options.debug ~level:3 "stmt %d is dead. skipping." stmt.sid;
[]
@@ -575,16 +575,16 @@ let pick wl =
let rec intraprocedural wl = match pick wl with
| None -> ()
| Some (pnode, { kf; pdg; init; zone }) ->
- let node = pnode, zone in
- add_to_result wl node kf init;
- Db.yield ();
- Options.debug ~level:2 "considering new node %a in %a:@ <%a>%t"
- PdgTypes.Node.pretty pnode Kernel_function.pretty kf
- Pdg_aux.pretty_node node
- (fun fmt -> if init then Format.pp_print_string fmt " (init)");
- intraprocedural_one_node wl node kf pdg;
- downward_one_call_node wl node kf pdg;
- intraprocedural wl
+ let node = pnode, zone in
+ add_to_result wl node kf init;
+ Db.yield ();
+ Options.debug ~level:2 "considering new node %a in %a:@ <%a>%t"
+ PdgTypes.Node.pretty pnode Kernel_function.pretty kf
+ Pdg_aux.pretty_node node
+ (fun fmt -> if init then Format.pp_print_string fmt " (init)");
+ intraprocedural_one_node wl node kf pdg;
+ downward_one_call_node wl node kf pdg;
+ intraprocedural wl
let something_to_do wl = not (NM.is_empty wl.todo)
@@ -598,7 +598,7 @@ let rec fixpoint wl =
if something_to_do wl then begin
intraprocedural wl;
(* Save functions on which the results have changed, as
- [downward_calls_inputs] clears the field [fun_changed_downward] *)
+ [downward_calls_inputs] clears the field [fun_changed_downward] *)
wl.fun_changed_upward <-
KFS.union wl.fun_changed_downward wl.fun_changed_upward;
downward_calls_inputs wl;
@@ -612,8 +612,8 @@ let rec fixpoint wl =
let remove_unimpacted _kf impact initial =
match impact, initial with
- | None, None | Some _, None | None, Some _ (* impossible *) -> impact
- | Some impact, Some initial -> Some (NS.diff impact initial)
+ | None, None | Some _, None | None, Some _ (* impossible *) -> impact
+ | Some impact, Some initial -> Some (NS.diff impact initial)
(** Impact of a set of nodes. Once the worklist has reached its fixpoint,
remove the initial nodes that are not self-impacting from the result,
@@ -673,7 +673,7 @@ let nodes_to_stmts ns =
(* Do not generate a list immediately, some nodes would be duplicated *)
NS.fold
(fun (n, _z) acc ->
- Option.fold ~none:acc ~some:(fun s -> Stmt.Set.add s acc) (get_stmt n)
+ Option.fold ~none:acc ~some:(fun s -> Stmt.Set.add s acc) (get_stmt n)
) ns Stmt.Set.empty
in
Stmt.Set.elements set
@@ -704,20 +704,20 @@ let skip_bases vars =
(** Computation of the [skip] field from the [-impact-skip] option *)
let skip () =
let bases = Options.Skip.fold
- (fun name l ->
- let vi =
- try
- Base.of_varinfo (Globals.Vars.find_from_astinfo name VGlobal)
- with Not_found ->
- if name = "NULL" then Base.null
- else
- Options.abort "cannot skip unknown variable %s" name
- in
- vi :: l) []
+ (fun name l ->
+ let vi =
+ try
+ Base.of_varinfo (Globals.Vars.find_from_astinfo name VGlobal)
+ with Not_found ->
+ if name = "NULL" then Base.null
+ else
+ Options.abort "cannot skip unknown variable %s" name
+ in
+ vi :: l) []
in
- skip_bases bases
+ skip_bases bases
+
-
(* TODO: dynamically register more high-level functions *)
diff --git a/src/plugins/impact/compute_impact.mli b/src/plugins/impact/compute_impact.mli
index d5040bf75d69d556af1f8702f3c2eb252c35d9e5..ca1b73eb4cb71338e7687dcea6705ff2539e1614 100644
--- a/src/plugins/impact/compute_impact.mli
+++ b/src/plugins/impact/compute_impact.mli
@@ -52,7 +52,7 @@ val nodes_to_stmts: nodes -> stmt list
val impact_in_kf: result -> Cil_types.kernel_function -> nodes
val skip: unit -> Locations.Zone.t
- (** computed from the option [-impact-skip] *)
+(** computed from the option [-impact-skip] *)
(*
Local Variables:
diff --git a/src/plugins/impact/options.ml b/src/plugins/impact/options.ml
index b661d84289550e1a0773839f01ff9c5e22e80377..ae4cbe24a1b8407bc1b49af337071656e38b5468 100644
--- a/src/plugins/impact/options.ml
+++ b/src/plugins/impact/options.ml
@@ -21,57 +21,57 @@
(**************************************************************************)
include Plugin.Register
- (struct
- let name = "impact"
- let shortname = "impact"
- let help = "impact analysis"
- end)
+ (struct
+ let name = "impact"
+ let shortname = "impact"
+ let help = "impact analysis"
+ end)
module Pragma =
Kernel_function_set
(struct
- let option_name = "-impact-pragma"
- let arg_name = "f1, ..., fn"
- let help = "use the impact pragmas in the code of functions f1,...,fn"
- end)
+ let option_name = "-impact-pragma"
+ let arg_name = "f1, ..., fn"
+ let help = "use the impact pragmas in the code of functions f1,...,fn"
+ end)
module Print =
False
(struct
- let option_name = "-impact-print"
- let help = "print the impacted stmt"
- end)
+ let option_name = "-impact-print"
+ let help = "print the impacted stmt"
+ end)
module Reason =
False
(struct
- let option_name = "-impact-graph"
- let help = "build a graph that explains why a statement is in the set \
- of impacted nodes"
- end)
+ let option_name = "-impact-graph"
+ let help = "build a graph that explains why a statement is in the set \
+ of impacted nodes"
+ end)
module Slicing =
False
(struct
- let option_name = "-impact-slicing"
- let help = "slice from the impacted stmt"
- end)
+ let option_name = "-impact-slicing"
+ let help = "slice from the impacted stmt"
+ end)
module Skip =
String_set
(struct
- let arg_name = "v1,...,vn"
- let help = "consider that those variables are not impacted"
- let option_name = "-impact-skip"
- end)
+ let arg_name = "v1,...,vn"
+ let help = "consider that those variables are not impacted"
+ let option_name = "-impact-skip"
+ end)
let () = Parameter_customize.set_negative_option_name "-impact-not-in-callers"
module Upward =
True
(struct
- let option_name = "-impact-in-callers"
- let help = "compute compute impact in callers as well as in callees"
- end)
+ let option_name = "-impact-in-callers"
+ let help = "compute compute impact in callers as well as in callees"
+ end)
let is_on () = not (Pragma.is_empty ())
diff --git a/src/plugins/impact/options.mli b/src/plugins/impact/options.mli
index 3486fec752f7654c4328c4f07481f353b68b76b7..eb8450709d30be3086c97d00a597602914e2fca0 100644
--- a/src/plugins/impact/options.mli
+++ b/src/plugins/impact/options.mli
@@ -23,22 +23,22 @@
include Plugin.S
module Pragma: Parameter_sig.Kernel_function_set
- (** Use pragmas of given function. *)
+(** Use pragmas of given function. *)
module Print: Parameter_sig.Bool
- (** Print the impacted stmt on stdout. *)
+(** Print the impacted stmt on stdout. *)
module Reason: Parameter_sig.Bool
- (** Build the graphs that explains why a node is impacted. *)
+(** Build the graphs that explains why a node is impacted. *)
module Slicing: Parameter_sig.Bool
- (** Slicing from the impacted stmt. *)
+(** Slicing from the impacted stmt. *)
module Skip: Parameter_sig.String_set
- (** Consider that the variables in the string are not impacted *)
+(** Consider that the variables in the string are not impacted *)
module Upward: Parameter_sig.Bool
- (** Also compute impact within callers *)
+(** Also compute impact within callers *)
val is_on: unit -> bool
diff --git a/src/plugins/impact/pdg_aux.ml b/src/plugins/impact/pdg_aux.ml
index 7e310efb327777bdefeaf6c07f42a87993c55548..4c5844ee30e2c53dfab592c8ec505fc5f3140ee8 100644
--- a/src/plugins/impact/pdg_aux.ml
+++ b/src/plugins/impact/pdg_aux.ml
@@ -28,11 +28,11 @@ type node = PdgTypes.Node.t * Zone.t
module NS = struct
include Hptmap.Make
- (PdgTypes.Node)
- (Locations.Zone)
- (Hptmap.Comp_unused)
- (struct let v = [[]] end)
- (struct let l = [Ast.self] end)
+ (PdgTypes.Node)
+ (Locations.Zone)
+ (Hptmap.Comp_unused)
+ (struct let v = [[]] end)
+ (struct let l = [Ast.self] end)
let intersects =
let name = "Impact.Pdg_aux.NS.intersects" in
@@ -41,9 +41,9 @@ module NS = struct
symmetric_binary_predicate
(Hptmap_sig.PersistentCache name)
ExistentialPredicate
- ~decide_fast:decide_fast_intersection
- ~decide_one:(fun _ _ -> false)
- ~decide_both:z_intersects
+ ~decide_fast:decide_fast_intersection
+ ~decide_one:(fun _ _ -> false)
+ ~decide_both:z_intersects
in
fun s1 s2 -> map_intersects s1 s2
@@ -136,8 +136,8 @@ let pretty_node fmt (n, z) =
let node_list_to_set ?(z=Zone.top) =
List.fold_left
(fun set (n, zopt) ->
- match zopt, z with
- | Some z, _ | None, z -> NS.add' (n, z) set
+ match zopt, z with
+ | Some z, _ | None, z -> NS.add' (n, z) set
)
NS.empty
@@ -155,14 +155,14 @@ let find_call_input_nodes pdg_caller call_stmt ?(z=Locations.Zone.top) in_key =
let node = PdgIndex.Signature.find_in_info call_sgn in_key in
[ node, None ]
| PdgIndex.Signature.InImpl zone ->
- let zone' = Locations.Zone.narrow zone z in
- (* skip undef zone: any result different from None is due to calldeps or
- some imprecision. *)
- let nodes, _undef =
- !Db.Pdg.find_location_nodes_at_stmt
- pdg_caller call_stmt ~before:true zone'
- in
- nodes
+ let zone' = Locations.Zone.narrow zone z in
+ (* skip undef zone: any result different from None is due to calldeps or
+ some imprecision. *)
+ let nodes, _undef =
+ !Db.Pdg.find_location_nodes_at_stmt
+ pdg_caller call_stmt ~before:true zone'
+ in
+ nodes
let all_call_input_nodes ~caller:pdg_caller ~callee:(kf_callee, pdg_callee) call_stmt =
let real_inputs =
@@ -178,11 +178,11 @@ let all_call_input_nodes ~caller:pdg_caller ~callee:(kf_callee, pdg_callee) call
(in_node, in_nodes) :: acc
in
match in_key with
- | Signature.InCtrl | Signature.InNum _ -> default ()
- | Signature.InImpl z ->
- if Locations.Zone.intersects z real_inputs
- then default ~z:real_inputs ()
- else acc
+ | Signature.InCtrl | Signature.InNum _ -> default ()
+ | Signature.InImpl z ->
+ if Locations.Zone.intersects z real_inputs
+ then default ~z:real_inputs ()
+ else acc
in
try
let sgn = FctIndex.sgn (PdgTypes.Pdg.get_index pdg_callee) in
@@ -211,7 +211,7 @@ let all_call_out_nodes ~callee ~caller call_stmt =
"cannot propagate impact into imprecisely analyzed caller function %a"
Kernel_function.pretty (Kernel_function.find_englobing_kf call_stmt);
[]
-
+
(*
Local Variables:
compile-command: "make -C ../../.."
diff --git a/src/plugins/impact/pdg_aux.mli b/src/plugins/impact/pdg_aux.mli
index 361d7707d1cbd941d78056012f832427be264570..b05d5ee8ed895065b3bebb9f18aa2b7f4b723a2f 100644
--- a/src/plugins/impact/pdg_aux.mli
+++ b/src/plugins/impact/pdg_aux.mli
@@ -82,6 +82,6 @@ val all_call_input_nodes:
(** [all_call_out_nodes ~callee ~caller stmt] find all the nodes of [callee]
that define the Call/Out nodes of [caller] for the call to [callee]
that occurs at [stmt]. Each such out node is returned, with the set
- of nodes that define it in [callee] *)
+ of nodes that define it in [callee] *)
val all_call_out_nodes :
callee:Db.Pdg.t -> caller:Db.Pdg.t -> stmt -> call_interface
diff --git a/src/plugins/impact/register.ml b/src/plugins/impact/register.ml
index 20d35c07912fbbfaa88fda1de1a9525bb7eec680..37f3e58b2fce135afa784d8cd93133ec96ef0f0e 100644
--- a/src/plugins/impact/register.ml
+++ b/src/plugins/impact/register.ml
@@ -25,7 +25,7 @@ open Cil_datatype
let rec pp_stmt fmt s = match s.skind with
| Instr _ | Return _ | Goto _ | Break _ | Continue _ | TryFinally _
- | TryExcept _ | Throw _ | TryCatch _ ->
+ | TryExcept _ | Throw _ | TryCatch _ ->
Printer.without_annot Printer.pp_stmt fmt s
| If (e, _, _, _) ->
Format.fprintf fmt "if(%a) <..>" Printer.pp_exp e
@@ -34,16 +34,16 @@ let rec pp_stmt fmt s = match s.skind with
| Loop _ -> Format.fprintf fmt "while (...)"
| Block b ->
begin match b.bstmts with
- | [] -> Format.fprintf fmt "<Block {}>"
- | s :: _ -> Format.fprintf fmt "<Block { %a }>" pp_stmt s
+ | [] -> Format.fprintf fmt "<Block {}>"
+ | s :: _ -> Format.fprintf fmt "<Block { %a }>" pp_stmt s
end
| UnspecifiedSequence _ -> Format.fprintf fmt "TODO"
let print_results fmt a =
Pretty_utils.pp_list
- (fun fmt s ->
- Format.fprintf fmt "@[<hov 2>%a (sid %d): %a@]"
- Printer.pp_location (Stmt.loc s) s.sid pp_stmt s
+ (fun fmt s ->
+ Format.fprintf fmt "@[<hov 2>%a (sid %d): %a@]"
+ Printer.pp_location (Stmt.loc s) s.sid pp_stmt s
) fmt a
let compute_from_stmt stmt =
@@ -99,11 +99,11 @@ let slice (stmts:stmt list) =
let all_pragmas_kf l =
List.fold_left
(fun acc (s, a) ->
- match a.annot_content with
- | APragma (Impact_pragma IPstmt) -> s :: acc
- | APragma (Impact_pragma (IPexpr _)) ->
- Options.not_yet_implemented "impact pragmas: expr"
- | _ -> assert false)
+ match a.annot_content with
+ | APragma (Impact_pragma IPstmt) -> s :: acc
+ | APragma (Impact_pragma (IPexpr _)) ->
+ Options.not_yet_implemented "impact pragmas: expr"
+ | _ -> assert false)
[] l
let compute_pragmas () =
@@ -120,8 +120,8 @@ let compute_pragmas () =
pragmas :=
List.map
(fun a -> s, a)
- (Annotations.code_annot ~filter:Logic_utils.is_impact_pragma s)
- @ !pragmas;
+ (Annotations.code_annot ~filter:Logic_utils.is_impact_pragma s)
+ @ !pragmas;
Cil.DoChildren
end
in
@@ -129,19 +129,19 @@ let compute_pragmas () =
let pragmas =
Options.Pragma.fold
(fun kf acc ->
- (* Pragma option only accept defined functions. *)
- let f = Kernel_function.get_definition kf in
- ignore (Visitor.visitFramacFunction visitor f);
- if !pragmas != [] then (kf, !pragmas) :: acc else acc)
+ (* Pragma option only accept defined functions. *)
+ let f = Kernel_function.get_definition kf in
+ ignore (Visitor.visitFramacFunction visitor f);
+ if !pragmas != [] then (kf, !pragmas) :: acc else acc)
[]
in
let skip = Compute_impact.skip () in
(* compute impact analyses on each kf *)
let nodes = List.fold_left
- (fun nodes (kf, pragmas) ->
- let pragmas_stmts = all_pragmas_kf pragmas in
- Pdg_aux.NS.union nodes (compute_multiple_stmts skip kf pragmas_stmts)
- ) Pdg_aux.NS.empty pragmas
+ (fun nodes (kf, pragmas) ->
+ let pragmas_stmts = all_pragmas_kf pragmas in
+ Pdg_aux.NS.union nodes (compute_multiple_stmts skip kf pragmas_stmts)
+ ) Pdg_aux.NS.empty pragmas
in
let stmts = Compute_impact.nodes_to_stmts nodes in
if Options.Slicing.get () then ignore (slice stmts);
diff --git a/src/plugins/inout/cumulative_analysis.ml b/src/plugins/inout/cumulative_analysis.ml
index bf0b78ccfeb1a5dd63db125e5f504f4b60b79a12..174693b09f5442f9a6e48ef503bb510ec597ee7a 100644
--- a/src/plugins/inout/cumulative_analysis.ml
+++ b/src/plugins/inout/cumulative_analysis.ml
@@ -37,26 +37,26 @@ let fold_implicit_initializer typ =
let specialize_state_on_call ?stmt kf =
match stmt with
- | Some ({ skind = Instr (Call (_, _, l, _)) } as stmt) ->
- let at_stmt = Db.Value.get_stmt_state stmt in
- if Cvalue.Model.is_top at_stmt then
- Cvalue.Model.top (* can occur with -no-results-function option *)
- else !Db.Value.add_formals_to_state at_stmt kf l
- | Some
- ({skind =
- Instr(Local_init(v, ConsInit(_,args,kind),_))} as stmt) ->
- let at_stmt = Db.Value.get_stmt_state stmt in
- if Cvalue.Model.is_top at_stmt then
- Cvalue.Model.top
- else begin
- let args =
- match kind with
- | Constructor -> Cil.mkAddrOfVi v :: args
- | Plain_func -> args
- in
- !Db.Value.add_formals_to_state at_stmt kf args
- end
- | _ -> Db.Value.get_initial_state kf
+ | Some ({ skind = Instr (Call (_, _, l, _)) } as stmt) ->
+ let at_stmt = Db.Value.get_stmt_state stmt in
+ if Cvalue.Model.is_top at_stmt then
+ Cvalue.Model.top (* can occur with -no-results-function option *)
+ else !Db.Value.add_formals_to_state at_stmt kf l
+ | Some
+ ({skind =
+ Instr(Local_init(v, ConsInit(_,args,kind),_))} as stmt) ->
+ let at_stmt = Db.Value.get_stmt_state stmt in
+ if Cvalue.Model.is_top at_stmt then
+ Cvalue.Model.top
+ else begin
+ let args =
+ match kind with
+ | Constructor -> Cil.mkAddrOfVi v :: args
+ | Plain_func -> args
+ in
+ !Db.Value.add_formals_to_state at_stmt kf args
+ end
+ | _ -> Db.Value.get_initial_state kf
class virtual ['a] cumulative_visitor = object
@@ -84,23 +84,23 @@ end
module Make (X:
- sig
- val analysis_name: string
+ sig
+ val analysis_name: string
- type t
- module T: Datatype.S with type t = t
+ type t
+ module T: Datatype.S with type t = t
- class virtual do_it: [t] cumulative_class
- end) =
+ class virtual do_it: [t] cumulative_class
+ end) =
struct
module Memo =
Kernel_function.Make_Table(X.T)
(struct
- let name = "Inout.Cumulative_analysis.Memo(" ^ X.analysis_name ^ ")"
- let dependencies = [ Db.Value.self ]
- let size = 97
- end)
+ let name = "Inout.Cumulative_analysis.Memo(" ^ X.analysis_name ^ ")"
+ let dependencies = [ Db.Value.self ]
+ let size = 97
+ end)
class do_it_cached call_stack = object(self)
inherit X.do_it
@@ -161,8 +161,8 @@ struct
do not cache the results. Maybe [compute_funspec] will be able
to deliver a more precise result on this given statement *)
match self#current_stmt with
- | None -> self#compute_kf_with_spec_generic kf
- | Some _stmt -> self#compute_funspec kf
+ | None -> self#compute_kf_with_spec_generic kf
+ | Some _stmt -> self#compute_funspec kf
else
try Memo.find kf
with Not_found -> self#compute_kf_with_def kf
diff --git a/src/plugins/inout/cumulative_analysis.mli b/src/plugins/inout/cumulative_analysis.mli
index 07bc86c0089ee592aa744337883c297feb65971d..d88e29dc7f2a1d4d63cf187685cdd817ad1918a9 100644
--- a/src/plugins/inout/cumulative_analysis.mli
+++ b/src/plugins/inout/cumulative_analysis.mli
@@ -38,10 +38,10 @@ val fold_implicit_initializer: typ -> bool
val specialize_state_on_call: ?stmt:stmt -> kernel_function -> Db.Value.state
- (** If the given statement is a call to the given function,
- enrich the superposed memory state at this statement with
- the formal arguments of this function. This is usually more precise
- than the superposition of all initial states of the function *)
+(** If the given statement is a call to the given function,
+ enrich the superposed memory state at this statement with
+ the formal arguments of this function. This is usually more precise
+ than the superposition of all initial states of the function *)
(** Frama-C visitor for cumulative analyses: we add a few useful methods.
@@ -51,17 +51,17 @@ class virtual ['a] cumulative_visitor : object
inherit Visitor.frama_c_inplace
method specialize_state_on_call: kernel_function -> Db.Value.state
- (** If the current statement is a call to the given function,
- enrich the superposed memory state at this statement with
- the formal arguments of this function. Useful to do an analysis
- with a limited amount of context *)
-
+ (** If the current statement is a call to the given function,
+ enrich the superposed memory state at this statement with
+ the formal arguments of this function. Useful to do an analysis
+ with a limited amount of context *)
+
method virtual compute_kf: kernel_function -> 'a
- (** Virtual function to use when one needs to compute the effect
- of a function call. This function carries implicitly a context:
- thus calling [self#compute_kf k1; self#compute_kf k2]
- is different from calling one within the other *)
+ (** Virtual function to use when one needs to compute the effect
+ of a function call. This function carries implicitly a context:
+ thus calling [self#compute_kf k1; self#compute_kf k2]
+ is different from calling one within the other *)
end
@@ -72,7 +72,7 @@ class type virtual ['a] cumulative_class = object
(** Result of the analysis *)
method result: 'a
- (** Adding partial results to the current ones *)
+ (** Adding partial results to the current ones *)
method join: 'a -> unit
(** Function that computes and returns the partial results on a funspec.
@@ -90,17 +90,17 @@ end
module Make (X:
- sig
- val analysis_name: string
+ sig
+ val analysis_name: string
- (** Type of the results *)
- type t
- module T: Datatype.S with type t = t
+ (** Type of the results *)
+ type t
+ module T: Datatype.S with type t = t
- (** Class that implements the analysis. Must not deal with memoization,
- as this is automatically done by the functor *)
- class virtual do_it: [t] cumulative_class
- end) :
+ (** Class that implements the analysis. Must not deal with memoization,
+ as this is automatically done by the functor *)
+ class virtual do_it: [t] cumulative_class
+ end) :
sig
(** Module that contains the memoized results *)
@@ -110,17 +110,17 @@ sig
Recursion in the dynamic call graphs are handled, provided the value
analysis terminated without detecting a real recursion *)
class do_it_cached: Kernel_function.t list ->
- object
- inherit X.do_it
+ object
+ inherit X.do_it
- (** Internal methods that gives the functions for which a cycle
- has been detected in the dynamic call-graph. Results cannot
- be safely memoized if this set is not empty *)
- method cycle: Kernel_function.Hptset.t
+ (** Internal methods that gives the functions for which a cycle
+ has been detected in the dynamic call-graph. Results cannot
+ be safely memoized if this set is not empty *)
+ method cycle: Kernel_function.Hptset.t
- (** Memoized version of the analysis of a kernel-function *)
- method compute_kf: kernel_function -> X.t
- end
+ (** Memoized version of the analysis of a kernel-function *)
+ method compute_kf: kernel_function -> X.t
+ end
(** Effects of the given kernel_function, using memoization *)
val kernel_function: kernel_function -> X.t
diff --git a/src/plugins/inout/derefs.ml b/src/plugins/inout/derefs.ml
index 6183da7d9cf8e21666dab9b920140e2bb913583c..19bba4c86cccbfb4e72afb0a15313f0db8239d84 100644
--- a/src/plugins/inout/derefs.ml
+++ b/src/plugins/inout/derefs.ml
@@ -40,14 +40,14 @@ class virtual do_it_ = object(self)
begin match base with
| Var _ -> ()
| Mem e ->
- let state =
- Db.Value.get_state (Kstmt (Option.get self#current_stmt))
- in
- let r = !Db.Value.eval_expr state e in
- let loc = loc_bytes_to_loc_bits r in
- let size = Bit_utils.sizeof_lval lv in
- self#join
- (enumerate_valid_bits Read (make_loc loc size))
+ let state =
+ Db.Value.get_state (Kstmt (Option.get self#current_stmt))
+ in
+ let r = !Db.Value.eval_expr state e in
+ let loc = loc_bytes_to_loc_bits r in
+ let size = Bit_utils.sizeof_lval lv in
+ self#join
+ (enumerate_valid_bits Read (make_loc loc size))
end;
DoChildren
@@ -66,7 +66,7 @@ module Analysis = Cumulative_analysis.Make(
module T = Locations.Zone
class virtual do_it = do_it_
-end)
+ end)
let get_internal = Analysis.kernel_function
@@ -78,10 +78,10 @@ let externalize _return fundec x =
module Externals =
Kernel_function.Make_Table(Locations.Zone)
(struct
- let name = "Inout.Derefs.Externals"
- let dependencies = [ Analysis.Memo.self ]
- let size = 17
- end)
+ let name = "Inout.Derefs.Externals"
+ let dependencies = [ Analysis.Memo.self ]
+ let size = 17
+ end)
let get_external =
Externals.memo
diff --git a/src/plugins/inout/inout_parameters.ml b/src/plugins/inout/inout_parameters.ml
index 49240507a187efe1a9548e5a0dea94d61f9574de..56326aa086cc1482fff32860b62cc75be7df58e2 100644
--- a/src/plugins/inout/inout_parameters.ml
+++ b/src/plugins/inout/inout_parameters.ml
@@ -21,68 +21,68 @@
(**************************************************************************)
include Plugin.Register
- (struct
- let name = "inout"
- let shortname = "inout"
- let help = "operational, imperative and all kinds of inputs/outputs"
- end)
+ (struct
+ let name = "inout"
+ let shortname = "inout"
+ let help = "operational, imperative and all kinds of inputs/outputs"
+ end)
module ForceDeref =
False
(struct
- let option_name = "-deref"
- let help = "force deref computation (undocumented)"
- end)
+ let option_name = "-deref"
+ let help = "force deref computation (undocumented)"
+ end)
module ForceAccessPath =
False
(struct
- let option_name = "-access-path"
- let help = "force the access path information to be computed"
- end)
+ let option_name = "-access-path"
+ let help = "force the access path information to be computed"
+ end)
module ForceOut =
False
(struct
- let option_name = "-out"
- let help = "Compute internal out. Those are an over-approximation of the set of written locations"
- end)
+ let option_name = "-out"
+ let help = "Compute internal out. Those are an over-approximation of the set of written locations"
+ end)
module ForceExternalOut =
False
(struct
- let option_name = "-out-external"
- let help = "Compute external out. Those are an over-approximation of the set of written locations, excluding locals"
- end)
+ let option_name = "-out-external"
+ let help = "Compute external out. Those are an over-approximation of the set of written locations, excluding locals"
+ end)
module ForceInput =
False
- (struct
- let option_name = "-input"
- let help = "Compute imperative inputs. Locals and function parameters are not displayed"
- end)
+ (struct
+ let option_name = "-input"
+ let help = "Compute imperative inputs. Locals and function parameters are not displayed"
+ end)
module ForceInputWithFormals =
False
(struct
- let option_name = "-input-with-formals"
- let help = "Compute imperative inputs. Function parameters are displayed, locals are not"
- end)
+ let option_name = "-input-with-formals"
+ let help = "Compute imperative inputs. Function parameters are displayed, locals are not"
+ end)
module ForceInout =
False
(struct
- let option_name = "-inout"
- let help = "Compute operational inputs, an over-approximation of the set of locations whose initial value is used; and the sure outputs, an under-approximation of the set of the certainly written locations"
- end)
+ let option_name = "-inout"
+ let help = "Compute operational inputs, an over-approximation of the set of locations whose initial value is used; and the sure outputs, an under-approximation of the set of the certainly written locations"
+ end)
module ForceInoutExternalWithFormals =
False
(struct
- let option_name = "-inout-with-formals"
- let help = "same as -inout but without local variables and with function parameters"
- end)
+ let option_name = "-inout-with-formals"
+ let help = "same as -inout but without local variables and with function parameters"
+ end)
let () = Parameter_customize.set_group messages
module Output =
diff --git a/src/plugins/inout/inputs.ml b/src/plugins/inout/inputs.ml
index 9151573d28633934c1f932bf574e5dba8d5db6b8..c27850de74562566b24348a43c1f1efb32cc1c51 100644
--- a/src/plugins/inout/inputs.ml
+++ b/src/plugins/inout/inputs.ml
@@ -37,13 +37,13 @@ class virtual do_it_ = object(self)
method! vstmt_aux s =
match s.skind with
- | UnspecifiedSequence seq ->
- List.iter
- (fun (stmt,_,_,_,_) ->
- ignore (visitFramacStmt (self:>frama_c_visitor) stmt))
- seq;
- Cil.SkipChildren (* do not visit the additional lvals *)
- | _ -> super#vstmt_aux s
+ | UnspecifiedSequence seq ->
+ List.iter
+ (fun (stmt,_,_,_,_) ->
+ ignore (visitFramacStmt (self:>frama_c_visitor) stmt))
+ seq;
+ Cil.SkipChildren (* do not visit the additional lvals *)
+ | _ -> super#vstmt_aux s
method! vlval lv =
let state = Db.Value.get_state self#current_kinstr in
@@ -86,9 +86,9 @@ class virtual do_it_ = object(self)
if Db.Value.is_reachable (Db.Value.get_state self#current_kinstr) then begin
match i with
| Set (lv,exp,_) ->
- self#do_assign lv;
- ignore (visitFramacExpr (self:>frama_c_visitor) exp);
- Cil.SkipChildren
+ self#do_assign lv;
+ ignore (visitFramacExpr (self:>frama_c_visitor) exp);
+ Cil.SkipChildren
| Local_init(v, AssignInit i,_) ->
let rec aux lv = function
@@ -126,13 +126,13 @@ class virtual do_it_ = object(self)
method! vexpr exp =
match exp.enode with
| AddrOf lv | StartOf lv ->
- let deps,_loc =
- !Db.Value.lval_to_loc_with_deps (* loc ignored *)
- ~deps:Zone.bottom
- self#current_kinstr lv
- in
- self#join deps;
- Cil.SkipChildren
+ let deps,_loc =
+ !Db.Value.lval_to_loc_with_deps (* loc ignored *)
+ ~deps:Zone.bottom
+ self#current_kinstr lv
+ in
+ self#join deps;
+ Cil.SkipChildren
| SizeOfE _ | AlignOfE _ | SizeOf _ | AlignOf _ ->
(* we're not evaluating an expression here: there's no input. *)
Cil.SkipChildren
@@ -156,24 +156,24 @@ module Analysis = Cumulative_analysis.Make(
module T = Locations.Zone
class virtual do_it = do_it_
-end)
+ end)
let get_internal = Analysis.kernel_function
module Externals =
Kernel_function.Make_Table(Locations.Zone)
(struct
- let name = "Inout.Inputs.Externals"
- let dependencies = [ Analysis.Memo.self ]
- let size = 17
- end)
+ let name = "Inout.Inputs.Externals"
+ let dependencies = [ Analysis.Memo.self ]
+ let size = 17
+ end)
let get_external =
Externals.memo
(fun kf ->
- Zone.filter_base
- (Callgraph.Uses.accept_base ~with_formals:false ~with_locals:false kf)
- (get_internal kf))
+ Zone.filter_base
+ (Callgraph.Uses.accept_base ~with_formals:false ~with_locals:false kf)
+ (get_internal kf))
let get_with_formals kf =
Zone.filter_base
diff --git a/src/plugins/inout/operational_inputs.ml b/src/plugins/inout/operational_inputs.ml
index 9cced9ee2b48f45c64890bc919e5f5d31be281f3..0fae49bb5f3cc278c6e53409e25b12bcce26407a 100644
--- a/src/plugins/inout/operational_inputs.ml
+++ b/src/plugins/inout/operational_inputs.ml
@@ -115,9 +115,9 @@ let eval_assigns kf state assigns =
let clean_deps =
Locations.Zone.filter_base
(function
- | Base.Var (v, _) | Base.Allocated (v, _, _) ->
- not (Kernel_function.is_formal v kf)
- | Base.CLogic_Var _ | Base.Null | Base.String _ -> true)
+ | Base.Var (v, _) | Base.Allocated (v, _, _) ->
+ not (Kernel_function.is_formal v kf)
+ | Base.CLogic_Var _ | Base.Null | Base.String _ -> true)
in
let out_term = out.it_content in
let outputs_under, outputs_over, deps =
@@ -126,11 +126,11 @@ let eval_assigns kf state assigns =
then (Zone.bottom, Zone.bottom, Zone.bottom)
else
let loc_out_under, loc_out_over, deps =
- !Db.Properties.Interp.loc_to_loc_under_over ~result:None state out_term
+ !Db.Properties.Interp.loc_to_loc_under_over ~result:None state out_term
in
- (enumerate_valid_bits_under Write loc_out_under,
- enumerate_valid_bits Write loc_out_over,
- clean_deps deps)
+ (enumerate_valid_bits_under Write loc_out_under,
+ enumerate_valid_bits Write loc_out_over,
+ clean_deps deps)
with Db.Properties.Interp.No_conversion ->
Inout_parameters.warning ~current:true ~once:true
"failed to interpret assigns clause '%a'" Printer.pp_term out_term;
@@ -140,16 +140,16 @@ let eval_assigns kf state assigns =
let inputs =
try
match froms with
- | FromAny -> Zone.top
- | From l ->
- let aux acc { it_content = from } =
- let _, loc, deps =
- !Db.Properties.Interp.loc_to_loc_under_over None state from in
- let acc = Zone.join (clean_deps deps) acc in
- let z = enumerate_valid_bits Read loc in
- Zone.join z acc
- in
- List.fold_left aux deps l
+ | FromAny -> Zone.top
+ | From l ->
+ let aux acc { it_content = from } =
+ let _, loc, deps =
+ !Db.Properties.Interp.loc_to_loc_under_over None state from in
+ let acc = Zone.join (clean_deps deps) acc in
+ let z = enumerate_valid_bits Read loc in
+ Zone.join z acc
+ in
+ List.fold_left aux deps l
with Db.Properties.Interp.No_conversion ->
Inout_parameters.warning ~current:true ~once:true
"failed to interpret inputs in assigns clause '%a'"
@@ -173,21 +173,21 @@ let eval_assigns kf state assigns =
}
in
match assigns with
- | WritesAny ->
- Inout_parameters.warning "@[no assigns clauses for@ function %a.@]@ \
- Results will be imprecise."
- Kernel_function.pretty kf;
- top
- | Writes l ->
- let init = { bottom with under_outputs_d = Zone.bottom } in
- let r = List.fold_left treat_one_zone init l in {
- over_inputs = r.over_inputs_d;
- over_logic_inputs = r.over_inputs_d;
- over_inputs_if_termination = r.over_inputs_d;
- under_outputs_if_termination = r.under_outputs_d;
- over_outputs = r.over_outputs_d;
- over_outputs_if_termination = r.over_outputs_d;
- }
+ | WritesAny ->
+ Inout_parameters.warning "@[no assigns clauses for@ function %a.@]@ \
+ Results will be imprecise."
+ Kernel_function.pretty kf;
+ top
+ | Writes l ->
+ let init = { bottom with under_outputs_d = Zone.bottom } in
+ let r = List.fold_left treat_one_zone init l in {
+ over_inputs = r.over_inputs_d;
+ over_logic_inputs = r.over_inputs_d;
+ over_inputs_if_termination = r.over_inputs_d;
+ under_outputs_if_termination = r.under_outputs_d;
+ over_outputs = r.over_outputs_d;
+ over_outputs_if_termination = r.over_outputs_d;
+ }
let compute_using_prototype_state state kf =
let behaviors = !Db.Value.valid_behaviors kf state in
@@ -207,10 +207,10 @@ let compute_using_prototype ?stmt kf =
module Internals =
Kernel_function.Make_Table(Inout_type)
(struct
- let name = "Inout.Operational_inputs.Internals"
- let dependencies = [ Db.Value.self ]
- let size = 17
- end)
+ let name = "Inout.Operational_inputs.Internals"
+ let dependencies = [ Db.Value.self ]
+ let size = 17
+ end)
module CallsiteHash = Value_types.Callsite.Hashtbl
@@ -218,22 +218,22 @@ module CallsiteHash = Value_types.Callsite.Hashtbl
*)
module CallwiseResults =
State_builder.Hashtbl
- (Value_types.Callsite.Hashtbl)
- (Inout_type)
- (struct
- let size = 17
- let dependencies = [Internals.self]
- let name = "Inout.Operational_inputs.CallwiseResults"
- end)
+ (Value_types.Callsite.Hashtbl)
+ (Inout_type)
+ (struct
+ let size = 17
+ let dependencies = [Internals.self]
+ let name = "Inout.Operational_inputs.CallwiseResults"
+ end)
module Computer(Fenv:Dataflows.FUNCTION_ENV)(X:sig
- val _version: string (* Debug: Callwise or functionwise *)
- val _kf: kernel_function (* Debug: Function being analyzed *)
- val kf_pre_state: Db.Value.state (* Memory pre-state of the function. *)
- val stmt_state: stmt -> Db.Value.state (* Memory state at the given stmt *)
- val at_call: stmt -> kernel_function -> Inout_type.t (* Results of the
- analysis for the given call. Must not contain locals or formals *)
-end) = struct
+ val _version: string (* Debug: Callwise or functionwise *)
+ val _kf: kernel_function (* Debug: Function being analyzed *)
+ val kf_pre_state: Db.Value.state (* Memory pre-state of the function. *)
+ val stmt_state: stmt -> Db.Value.state (* Memory state at the given stmt *)
+ val at_call: stmt -> kernel_function -> Inout_type.t (* Results of the
+ analysis for the given call. Must not contain locals or formals *)
+ end) = struct
(* We want to compute the in/out for all terminating and
non-terminating points of the function. This is not immediate
@@ -403,8 +403,8 @@ end) = struct
match i with
| Set (lv, exp, _) ->
let state = X.stmt_state stmt in
- let e_inputs =
- !Db.From.find_deps_no_transitivity_state state exp
+ let e_inputs =
+ !Db.From.find_deps_no_transitivity_state state exp
in
add_out ~for_writing:true state lv e_inputs data
| Local_init (v, AssignInit i, _) ->
@@ -515,30 +515,30 @@ let compute_externals_using_prototype ?stmt kf =
let get_internal_aux ?stmt kf =
match stmt with
- | None -> !Db.Operational_inputs.get_internal kf
- | Some stmt ->
- try CallwiseResults.find (kf, Kstmt stmt)
- with Not_found ->
- if !Db.Value.use_spec_instead_of_definition kf then
- compute_using_prototype ~stmt kf
- else !Db.Operational_inputs.get_internal kf
+ | None -> !Db.Operational_inputs.get_internal kf
+ | Some stmt ->
+ try CallwiseResults.find (kf, Kstmt stmt)
+ with Not_found ->
+ if !Db.Value.use_spec_instead_of_definition kf then
+ compute_using_prototype ~stmt kf
+ else !Db.Operational_inputs.get_internal kf
let get_external_aux ?stmt kf =
match stmt with
- | None -> !Db.Operational_inputs.get_external kf
- | Some stmt ->
- try
- let internals = CallwiseResults.find (kf, Kstmt stmt) in
- externalize ~with_formals:false kf internals
- with Not_found ->
- if !Db.Value.use_spec_instead_of_definition kf then
- let r = compute_externals_using_prototype ~stmt kf in
- CallwiseResults.add (kf, Kstmt stmt) r;
- r
- else !Db.Operational_inputs.get_external kf
+ | None -> !Db.Operational_inputs.get_external kf
+ | Some stmt ->
+ try
+ let internals = CallwiseResults.find (kf, Kstmt stmt) in
+ externalize ~with_formals:false kf internals
+ with Not_found ->
+ if !Db.Value.use_spec_instead_of_definition kf then
+ let r = compute_externals_using_prototype ~stmt kf in
+ CallwiseResults.add (kf, Kstmt stmt) r;
+ r
+ else !Db.Operational_inputs.get_external kf
let extract_inout_from_froms froms =
- let open Function_Froms in
+ let open Function_Froms in
let {deps_return; deps_table } = froms in
let in_return = Deps.to_zone deps_return in
let in_, out_ =
@@ -596,7 +596,7 @@ module Callwise = struct
let call_for_callwise_inout (call_type, state, call_stack) =
let (current_function, ki as call_site) = List.hd call_stack in
let merge_inout inout =
- if ki = Kglobal
+ if ki = Kglobal
then merge_call_in_global_tables call_site inout
else
let _above_function, table =
@@ -634,10 +634,10 @@ module Callwise = struct
(Datatype.Int.Hashtbl)
(Inout_type)
(struct
- let size = 17
- let dependencies = [Internals.self]
- let name = "Operational_inputs.MemExec"
- end)
+ let size = 17
+ let dependencies = [Internals.self]
+ let name = "Operational_inputs.MemExec"
+ end)
let end_record call_stack inout =
@@ -646,18 +646,18 @@ module Callwise = struct
let (current_function, _ as call_site) = List.hd call_stack in
(* pop + record in top of stack the inout of function that just finished*)
match !call_inout_stack with
- | (current_function2, _) :: (((_caller, table) :: _) as tail) ->
- if current_function2 != current_function then
- Inout_parameters.fatal "callwise inout %a != %a@."
- Kernel_function.pretty current_function (* g *)
- Kernel_function.pretty current_function2 (* f *);
- call_inout_stack := tail;
- merge_call_in_local_table call_site table inout;
-
- | _ -> (* the entry point, probably *)
- merge_call_in_global_tables call_site inout;
- call_inout_stack := [];
- CallwiseResults.mark_as_computed ()
+ | (current_function2, _) :: (((_caller, table) :: _) as tail) ->
+ if current_function2 != current_function then
+ Inout_parameters.fatal "callwise inout %a != %a@."
+ Kernel_function.pretty current_function (* g *)
+ Kernel_function.pretty current_function2 (* f *);
+ call_inout_stack := tail;
+ merge_call_in_local_table call_site table inout;
+
+ | _ -> (* the entry point, probably *)
+ merge_call_in_global_tables call_site inout;
+ call_inout_stack := [];
+ CallwiseResults.mark_as_computed ()
let compute_call_from_value_states kf call_stack states =
let module Fenv = (val Dataflows.function_env kf: Dataflows.FUNCTION_ENV) in
@@ -747,24 +747,24 @@ module FunctionWise = struct
let compute_internal_using_cfg kf =
try
let module Fenv =
- (val Dataflows.function_env kf: Dataflows.FUNCTION_ENV)
+ (val Dataflows.function_env kf: Dataflows.FUNCTION_ENV)
in
let module Computer = Computer(Fenv)(struct
- let _version = "functionwise"
- let _kf = kf
- let kf_pre_state = Db.Value.get_initial_state kf
- let stmt_state s = Db.Value.get_stmt_state s
- let at_call stmt kf = get_external_aux ~stmt kf
- end) in
+ let _version = "functionwise"
+ let _kf = kf
+ let kf_pre_state = Db.Value.get_initial_state kf
+ let stmt_state s = Db.Value.get_stmt_state s
+ let at_call stmt kf = get_external_aux ~stmt kf
+ end) in
Stack.iter
(fun g -> if kf == g then begin
- if Db.Value.ignored_recursive_call kf then
- Inout_parameters.warning ~current:true
- "During inout context analysis of %a:@ \
+ if Db.Value.ignored_recursive_call kf then
+ Inout_parameters.warning ~current:true
+ "During inout context analysis of %a:@ \
ignoring probable recursive call."
- Kernel_function.pretty kf;
- raise Exit
- end)
+ Kernel_function.pretty kf;
+ raise Exit
+ end)
call_stack;
Stack.push kf call_stack;
@@ -776,12 +776,12 @@ module FunctionWise = struct
result
with Exit -> Inout_type.bottom (*TODO*) (*{
- Inout_type.over_inputs_if_termination = empty.over_inputs_d ;
- under_outputs_if_termination = empty.under_outputs_d;
- over_inputs = empty.over_inputs_d;
- over_outputs = empty.over_outputs_d;
- over_outputs_if_termination = empty.over_outputs_d;
- }*)
+ Inout_type.over_inputs_if_termination = empty.over_inputs_d ;
+ under_outputs_if_termination = empty.under_outputs_d;
+ over_inputs = empty.over_inputs_d;
+ over_outputs = empty.over_outputs_d;
+ over_outputs_if_termination = empty.over_outputs_d;
+ }*)
let compute_internal_using_cfg kf =
if !Db.Value.no_results (Kernel_function.get_definition kf) then
@@ -792,7 +792,7 @@ module FunctionWise = struct
(let s = ref "" in
Stack.iter
(fun kf -> s := !s^" <-"^
- (Format.asprintf "%a" Kernel_function.pretty kf))
+ (Format.asprintf "%a" Kernel_function.pretty kf))
call_stack;
!s);
let r = compute_internal_using_cfg kf in
@@ -810,11 +810,11 @@ let get_internal =
try Internals.find kf (* The results may have been computed by the call
to Value.compute *)
with
- | Not_found ->
- if!Db.Value.use_spec_instead_of_definition kf then
- compute_using_prototype kf
- else
- FunctionWise.compute_internal_using_cfg kf
+ | Not_found ->
+ if!Db.Value.use_spec_instead_of_definition kf then
+ compute_using_prototype kf
+ else
+ FunctionWise.compute_internal_using_cfg kf
)
let raw_externals ~with_formals kf =
@@ -824,10 +824,10 @@ let raw_externals ~with_formals kf =
module Externals =
Kernel_function.Make_Table(Inout_type)
(struct
- let name = "External inouts full"
- let dependencies = [ Internals.self ]
- let size = 17
- end)
+ let name = "External inouts full"
+ let dependencies = [ Internals.self ]
+ let size = 17
+ end)
let get_external = Externals.memo (raw_externals ~with_formals:false)
let compute_external kf = ignore (get_external kf)
@@ -836,10 +836,10 @@ let compute_external kf = ignore (get_external kf)
module Externals_With_Formals =
Kernel_function.Make_Table(Inout_type)
(struct
- let name = "Inout.Operational_inputs.Externals_With_Formals"
- let dependencies = [ Internals.self ]
- let size = 17
- end)
+ let name = "Inout.Operational_inputs.Externals_With_Formals"
+ let dependencies = [ Internals.self ]
+ let size = 17
+ end)
let get_external_with_formals =
Externals_With_Formals.memo (raw_externals ~with_formals:true)
let compute_external_with_formals kf = ignore (get_external_with_formals kf)
diff --git a/src/plugins/inout/outputs.ml b/src/plugins/inout/outputs.ml
index ae8eefa76c4399815631235f40663ccc1a080cd2..1137bece59862b3720436f2da090395382a8cc9e 100644
--- a/src/plugins/inout/outputs.ml
+++ b/src/plugins/inout/outputs.ml
@@ -34,43 +34,43 @@ class virtual do_it_ = object(self)
method! vstmt_aux s =
match s.skind with
- | UnspecifiedSequence seq ->
- List.iter
- (fun (stmt,_,_,_,_) ->
- ignore(visitFramacStmt (self:>frama_c_visitor) stmt))
- seq;
- Cil.SkipChildren (* do not visit the additional lvals *)
- | _ -> super#vstmt_aux s
+ | UnspecifiedSequence seq ->
+ List.iter
+ (fun (stmt,_,_,_,_) ->
+ ignore(visitFramacStmt (self:>frama_c_visitor) stmt))
+ seq;
+ Cil.SkipChildren (* do not visit the additional lvals *)
+ | _ -> super#vstmt_aux s
method join new_ =
outs <- Zone.join new_ outs;
- (* For local initializations, counts the written variable as an output of the
- function, even if it is const; thus, [for_writing] is false in this case. *)
+ (* For local initializations, counts the written variable as an output of the
+ function, even if it is const; thus, [for_writing] is false in this case. *)
method private do_assign ~for_writing lv =
let state = Db.Value.get_state self#current_kinstr in
let _deps, bits_loc, _exact =
!Db.Value.lval_to_zone_with_deps_state state
- ~deps:None ~for_writing lv
+ ~deps:None ~for_writing lv
in
self#join bits_loc
method! vinst i =
- if Db.Value.is_reachable (Db.Value.noassert_get_state self#current_kinstr)
+ if Db.Value.is_reachable (Db.Value.noassert_get_state self#current_kinstr)
then
(* noassert needed for Eval.memoize. Not really satisfactory *)
- begin
- match i with
- | Set (lv,_,_) ->
- let for_writing = not (Cil.is_mutable_or_initialized lv) in
- self#do_assign ~for_writing lv
- | Call (lv_opt,exp,_,_) ->
+ begin
+ match i with
+ | Set (lv,_,_) ->
+ let for_writing = not (Cil.is_mutable_or_initialized lv) in
+ self#do_assign ~for_writing lv
+ | Call (lv_opt,exp,_,_) ->
(match lv_opt with None -> ()
- | Some lv ->
- let for_writing =
- not (Cil.is_mutable_or_initialized lv)
- in
- self#do_assign ~for_writing lv);
+ | Some lv ->
+ let for_writing =
+ not (Cil.is_mutable_or_initialized lv)
+ in
+ self#do_assign ~for_writing lv);
let state = Db.Value.get_state self#current_kinstr in
if Cvalue.Model.is_top state then
self#join Zone.top
@@ -79,44 +79,44 @@ class virtual do_it_ = object(self)
!Db.Value.expr_to_kernel_function_state ~deps:None state exp in
Kernel_function.Hptset.iter
(fun kf ->
- let { Inout_type.over_outputs = z } =
- Operational_inputs.get_external_aux
- ?stmt:self#current_stmt kf
- in
- self#join z
+ let { Inout_type.over_outputs = z } =
+ Operational_inputs.get_external_aux
+ ?stmt:self#current_stmt kf
+ in
+ self#join z
) callees
- | Local_init (v, AssignInit i, _) ->
- let rec aux lv = function
- | SingleInit _ -> self#do_assign ~for_writing:false lv
- | CompoundInit (ct, initl) ->
- (* Avoid folding the implicit zero-initializers of large arrays. *)
- if Cumulative_analysis.fold_implicit_initializer ct
- then
- let implicit = true in
- let doinit o i _ () = aux (Cil.addOffsetLval o lv) i in
- Cil.foldLeftCompound ~implicit ~doinit ~ct ~initl ~acc:()
- else
- (* For arrays of scalar elements, all the zone covered by the
- array is written. For arrays of structs containing padding
- bits, this is a sound over-approximation. *)
- self#do_assign ~for_writing:false lv
- in
- aux (Cil.var v) i
- | Local_init (v, ConsInit(f, _, _),_) ->
- let state = Db.Value.get_state self#current_kinstr in
- if Cvalue.Model.is_top state then self#join Zone.top
- else begin
- let { Inout_type.over_outputs = z } =
- Operational_inputs.get_external_aux ?stmt:self#current_stmt
- (Globals.Functions.get f)
+ | Local_init (v, AssignInit i, _) ->
+ let rec aux lv = function
+ | SingleInit _ -> self#do_assign ~for_writing:false lv
+ | CompoundInit (ct, initl) ->
+ (* Avoid folding the implicit zero-initializers of large arrays. *)
+ if Cumulative_analysis.fold_implicit_initializer ct
+ then
+ let implicit = true in
+ let doinit o i _ () = aux (Cil.addOffsetLval o lv) i in
+ Cil.foldLeftCompound ~implicit ~doinit ~ct ~initl ~acc:()
+ else
+ (* For arrays of scalar elements, all the zone covered by the
+ array is written. For arrays of structs containing padding
+ bits, this is a sound over-approximation. *)
+ self#do_assign ~for_writing:false lv
in
- self#do_assign ~for_writing:false (Cil.var v);
- (* might be redundant with z in case f takes address of
- v as first argument, but this shouldn't hurt. *)
- self#join z
- end
- | Asm _ | Skip _ | Code_annot _ -> ()
- end;
+ aux (Cil.var v) i
+ | Local_init (v, ConsInit(f, _, _),_) ->
+ let state = Db.Value.get_state self#current_kinstr in
+ if Cvalue.Model.is_top state then self#join Zone.top
+ else begin
+ let { Inout_type.over_outputs = z } =
+ Operational_inputs.get_external_aux ?stmt:self#current_stmt
+ (Globals.Functions.get f)
+ in
+ self#do_assign ~for_writing:false (Cil.var v);
+ (* might be redundant with z in case f takes address of
+ v as first argument, but this shouldn't hurt. *)
+ self#join z
+ end
+ | Asm _ | Skip _ | Code_annot _ -> ()
+ end;
Cil.SkipChildren
method clean_kf_result kf r =
@@ -139,7 +139,7 @@ module Analysis = Cumulative_analysis.Make(
module T = Locations.Zone
class virtual do_it = do_it_
-end)
+ end)
let get_internal = Analysis.kernel_function
@@ -151,10 +151,10 @@ let externalize kf x =
module Externals =
Kernel_function.Make_Table(Locations.Zone)
(struct
- let name = "Inout.Outputs.Externals"
- let dependencies = [ Analysis.Memo.self ]
- let size = 17
- end)
+ let name = "Inout.Outputs.Externals"
+ let dependencies = [ Analysis.Memo.self ]
+ let size = 17
+ end)
let get_external =
Externals.memo (fun kf -> externalize kf (get_internal kf))
diff --git a/src/plugins/inout/register.ml b/src/plugins/inout/register.ml
index 992a0b81711a6e08eaf01b4eb95c6419ee9ec249..f8615a255af358297d2005df233cabb149b43e94 100644
--- a/src/plugins/inout/register.ml
+++ b/src/plugins/inout/register.ml
@@ -27,11 +27,11 @@ module ShouldOutput =
State_builder.True_ref
(struct
let dependencies = [Db.Value.self] (* To be completed if some computations
- use some other results than value *)
+ use some other results than value *)
let name = "Inout.Register.ShouldOuput"
- end)
+ end)
let () = Inout_parameters.Output.add_set_hook
- (fun _ v -> if v then ShouldOutput.set true)
+ (fun _ v -> if v then ShouldOutput.set true)
let main () =
@@ -46,7 +46,7 @@ let main () =
let forceinputwithformals = Inout_parameters.ForceInputWithFormals.get () in
if (forceout || forceexternalout || forceinput || forceinputwithformals
|| forcederef || forceinout || forceinoutwithformals) &&
- Inout_parameters.Output.get () && ShouldOutput.get ()
+ Inout_parameters.Output.get () && ShouldOutput.get ()
then begin
ShouldOutput.set false;
!Db.Value.compute ();
diff --git a/src/plugins/loop_analysis/region_analysis.ml b/src/plugins/loop_analysis/region_analysis.ml
index 9e090003c07d6b48928abe1932ead9d08dab4fd9..c04f9f6ec334804ad68163320611d5063f7fe9d4 100644
--- a/src/plugins/loop_analysis/region_analysis.ml
+++ b/src/plugins/loop_analysis/region_analysis.ml
@@ -29,8 +29,8 @@
- We never build regions; the nesting of natural loops suffice.
- We do not compose transfer functions. Instead, we rely on the
- fact that Ocaml has first-class functions, and associate to "loop
- edges" functions describing the behaviour of loops.
+ fact that Ocaml has first-class functions, and associate to "loop
+ edges" functions describing the behaviour of loops.
The composition of region of the Dragon Book does not fit well the
translation to terms, for which composition of transfer function
@@ -60,7 +60,7 @@ struct
let graph_size = N.Set.cardinal N.Graph.all_nodes
let iter_nodes f = N.Set.iter f N.Graph.all_nodes
-
+
(****************************************************************)
(* Back edges. *)
@@ -70,7 +70,7 @@ struct
iter_nodes (fun n ->
N.Graph.iter_succs n (fun head ->
if N.DomTree.dominates head n
- then N.Dict.set back_edges head
+ then N.Dict.set back_edges head
(N.Set.add n (N.Dict.get back_edges head))));
back_edges
;;
diff --git a/src/plugins/loop_analysis/region_analysis_stmt.ml b/src/plugins/loop_analysis/region_analysis_stmt.ml
index 66d4b4987be91724e7e982ccc12eb9d3c4d560d2..b9db0a8032b4b90af9badd2ef66b37bdefa0131c 100644
--- a/src/plugins/loop_analysis/region_analysis_stmt.ml
+++ b/src/plugins/loop_analysis/region_analysis_stmt.ml
@@ -56,7 +56,7 @@ struct
then loop s) v.Cil_types.succs
in loop entry_node; !visited
;;
-
+
let exit_nodes =
let ret = Kernel_function.find_return M.kf in
if Set.mem ret all_nodes then [ret] else [];;
diff --git a/src/plugins/metrics/metrics_acsl.ml b/src/plugins/metrics/metrics_acsl.ml
index 9800d450ab5c59d5bb1a1c992edcd52403c8d4b6..1011d1206b159b42e743c1ddb1ab38648fabf3cc 100644
--- a/src/plugins/metrics/metrics_acsl.ml
+++ b/src/plugins/metrics/metrics_acsl.ml
@@ -83,7 +83,7 @@ let incr_asserts stat = stat.asserts <- stat.asserts + 1
let pretty_acsl_stats fmt stat =
Format.fprintf fmt
"@[<v 0>requires: %d total, %d in function contracts,\
- %d in statement contracts@;\
+ %d in statement contracts@;\
ensures: %d total, %d in function contracts, %d in statement contracts@;\
behaviors: %d total, %d in function contracts, %d in statement contracts@;\
assumes: %d total, %d in function contracts, %d in statement contracts@;\
@@ -92,7 +92,7 @@ let pretty_acsl_stats fmt stat =
invariants: %d@;loop assigns: %d@;loop froms: %d@;variants: %d@;\
asserts: %d@;@]"
(stat.f_requires + stat.s_requires)
- stat.f_requires stat.s_requires
+ stat.f_requires stat.s_requires
(stat.f_ensures + stat.s_ensures)
stat.f_ensures stat.s_ensures
(stat.f_behaviors + stat.s_behaviors)
@@ -137,7 +137,7 @@ let pretty_acsl_stats_html fmt stat =
@{<tr>@{<td class=\"entry\">asserts@}@{<td class=\"stat\">%d@}@}@;\
@}@]"
(stat.f_requires + stat.s_requires)
- stat.f_requires stat.s_requires
+ stat.f_requires stat.s_requires
(stat.f_ensures + stat.s_ensures)
stat.f_ensures stat.s_ensures
(stat.f_behaviors + stat.s_behaviors)
@@ -153,24 +153,24 @@ let pretty_acsl_stats_html fmt stat =
module Acsl_stats =
Datatype.Make(
- struct
- type t = acsl_stats
- let reprs = [empty_acsl_stat ()]
- let name = "Metrics_acsl.acsl_stats"
- include Datatype.Serializable_undefined
- let pretty = pretty_acsl_stats
- end)
+ struct
+ type t = acsl_stats
+ let reprs = [empty_acsl_stat ()]
+ let name = "Metrics_acsl.acsl_stats"
+ include Datatype.Serializable_undefined
+ let pretty = pretty_acsl_stats
+ end)
module Global_acsl_stats =
State_builder.Ref(Acsl_stats)
(struct
- let name = "Metrics_acsl.Global_acsl_stats"
- let dependencies =
- [ Ast.self; Annotations.code_annot_state; Annotations.funspec_state;
- Annotations.global_state
- ]
- let default = empty_acsl_stat
- end)
+ let name = "Metrics_acsl.Global_acsl_stats"
+ let dependencies =
+ [ Ast.self; Annotations.code_annot_state; Annotations.funspec_state;
+ Annotations.global_state
+ ]
+ let default = empty_acsl_stat
+ end)
module Functions_acsl_stats =
State_builder.Hashtbl
@@ -181,7 +181,7 @@ module Functions_acsl_stats =
let dependencies =
[Ast.self; Annotations.code_annot_state; Annotations.funspec_state]
let size = 17
- end)
+ end)
let get_kf_stats kf =
try Functions_acsl_stats.find kf with Not_found -> empty_acsl_stat()
@@ -191,7 +191,7 @@ module Computed =
(struct
let name = "Metrics_acsl.Computed"
let dependencies = [ Global_acsl_stats.self; Functions_acsl_stats.self]
- end)
+ end)
let treat_behavior local_stats ki b =
let incr_behaviors =
@@ -218,15 +218,15 @@ let treat_behavior local_stats ki b =
List.iter (incr_all incr_ensures) b.b_post_cond;
List.iter (incr_all incr_assumes) b.b_assumes;
(match b.b_assigns with
- | WritesAny -> ()
- | Writes l ->
- incr_all incr_assigns ();
- List.iter
- (function
- | (_,FromAny) -> ()
- | (_,From _) -> incr_all incr_froms ())
- l)
- (*TODO: allocation *)
+ | WritesAny -> ()
+ | Writes l ->
+ incr_all incr_assigns ();
+ List.iter
+ (function
+ | (_,FromAny) -> ()
+ | (_,From _) -> incr_all incr_froms ())
+ l)
+(*TODO: allocation *)
let add_function_contract_stats kf =
let local_stats = get_kf_stats kf in
@@ -238,18 +238,18 @@ let add_code_annot_stats stmt _ ca =
let local_stats = get_kf_stats kf in
let incr_all f = f local_stats; f (Global_acsl_stats.get()) in
match ca.annot_content with
- | AAssert _ -> incr_all incr_asserts
- | AStmtSpec (_,spec) ->
- List.iter (treat_behavior local_stats (Kstmt stmt)) spec.spec_behavior
- | AInvariant _ -> incr_all incr_invariants
- | AVariant _ -> incr_all incr_variants
- | AAssigns (_,WritesAny) -> ()
- | AAssigns (_,Writes l) ->
- incr_all incr_loop_assigns;
- List.iter
- (function (_,FromAny) -> () | (_,From _) -> incr_all incr_loop_froms) l
- | AAllocation _ -> () (* TODO *)
- | APragma _ | AExtended _ -> ()
+ | AAssert _ -> incr_all incr_asserts
+ | AStmtSpec (_,spec) ->
+ List.iter (treat_behavior local_stats (Kstmt stmt)) spec.spec_behavior
+ | AInvariant _ -> incr_all incr_invariants
+ | AVariant _ -> incr_all incr_variants
+ | AAssigns (_,WritesAny) -> ()
+ | AAssigns (_,Writes l) ->
+ incr_all incr_loop_assigns;
+ List.iter
+ (function (_,FromAny) -> () | (_,From _) -> incr_all incr_loop_froms) l
+ | AAllocation _ -> () (* TODO *)
+ | APragma _ | AExtended _ -> ()
let compute () =
if not (Computed.get()) then begin
@@ -266,9 +266,9 @@ let dump_html_global fmt = pretty_acsl_stats_html fmt (get_global_stats())
let dump_html_by_function fmt =
compute ();
Functions_acsl_stats.iter
- (fun kf stats ->
- Format.fprintf fmt "@{<h2>Function %a@}@;%a"
- Kernel_function.pretty kf pretty_acsl_stats_html stats)
+ (fun kf stats ->
+ Format.fprintf fmt "@{<h2>Function %a@}@;%a"
+ Kernel_function.pretty kf pretty_acsl_stats_html stats)
let dump_acsl_stats fmt =
Metrics_base.mk_hdr 1 fmt "ACSL Statistics";
@@ -277,35 +277,35 @@ let dump_acsl_stats fmt =
compute ();
Functions_acsl_stats.iter
(fun kf stats ->
- let kf_name = Format.asprintf "%a" Kernel_function.pretty kf in
- Format.fprintf fmt "@[<v 2>%a@;%a@]@;"
- (Metrics_base.mk_hdr 2) kf_name pretty_acsl_stats stats)
+ let kf_name = Format.asprintf "%a" Kernel_function.pretty kf in
+ Format.fprintf fmt "@[<v 2>%a@;%a@]@;"
+ (Metrics_base.mk_hdr 2) kf_name pretty_acsl_stats stats)
end else pretty_acsl_stats fmt (get_global_stats())
-
+
let dump_acsl_stats_html fmt =
Format.pp_set_formatter_stag_functions fmt Metrics_base.html_stag_functions;
Format.fprintf fmt
"@[<v 0> <!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\"\
- \"http://www.w3.org/TR/html4/strict.dtd\">@ \
- @{<html>@ \
- @{<head>@ \
- @{<title>%s@}@ \
- <meta content=\"text/html; charset=iso-8859-1\" \
- http-equiv=\"Content-Type\"/>@ \
- @{<style type=\"text/css\">%s@}@ \
- @}@ \
- @{<body>\
- @[<v 2>@ \
- @{<h1>%s@}@;\
- %t@]@}@}@]@?"
+ \"http://www.w3.org/TR/html4/strict.dtd\">@ \
+ @{<html>@ \
+ @{<head>@ \
+ @{<title>%s@}@ \
+ <meta content=\"text/html; charset=iso-8859-1\" \
+ http-equiv=\"Content-Type\"/>@ \
+ @{<style type=\"text/css\">%s@}@ \
+ @}@ \
+ @{<body>\
+ @[<v 2>@ \
+ @{<h1>%s@}@;\
+ %t@]@}@}@]@?"
"ACSL Metrics"
Css_html.css
(if Metrics_parameters.ByFunction.get ()
then "Detailed ACSL statistics" else "Global ACSL statistics")
(if Metrics_parameters.ByFunction.get ()
then dump_html_global else dump_html_by_function)
-
+
let dump () =
if not (Metrics_parameters.OutputFile.is_empty ()) then begin
@@ -314,15 +314,14 @@ let dump () =
let chan = open_out (out:>string) in
let fmt = Format.formatter_of_out_channel chan in
(match Metrics_base.get_file_type out with
- | Metrics_base.Html -> dump_acsl_stats_html fmt
- | Metrics_base.Text -> dump_acsl_stats fmt
- | Metrics_base.Json ->
- Metrics_parameters.not_yet_implemented
- "JSON format for ACSL metrics"
+ | Metrics_base.Html -> dump_acsl_stats_html fmt
+ | Metrics_base.Text -> dump_acsl_stats fmt
+ | Metrics_base.Json ->
+ Metrics_parameters.not_yet_implemented
+ "JSON format for ACSL metrics"
);
close_out chan
with Sys_error s ->
Metrics_parameters.abort "Cannot open file %a (%s)"
Filepath.Normalized.pretty out s
end else Metrics_parameters.result "%t" dump_acsl_stats
-
diff --git a/src/plugins/metrics/metrics_cabs.ml b/src/plugins/metrics/metrics_cabs.ml
index 788ecf4c98d882147f792e67097184e1abec56c6..5f7929d605735f42fd156d47c60b687ab3f8e295 100644
--- a/src/plugins/metrics/metrics_cabs.ml
+++ b/src/plugins/metrics/metrics_cabs.ml
@@ -39,7 +39,7 @@ class metricsCabsVisitor = object(self)
(* Local metrics are kept stored after computation in this map of maps.
Its storing hierarchy is as follows: filename -> function_name -> metrics *)
val mutable metrics_map:
- (BasicMetrics.t Metrics_base.OptionKf.Map.t) Datatype.Filepath.Map.t =
+ (BasicMetrics.t Metrics_base.OptionKf.Map.t) Datatype.Filepath.Map.t =
Datatype.Filepath.Map.empty
val functions_no_source: (string, int) Hashtbl.t = Hashtbl.create 97
@@ -67,175 +67,175 @@ class metricsCabsVisitor = object(self)
let filename = metrics.cfile_name
and func = metrics.cfunc in
local_metrics := BasicMetrics.set_cyclo !local_metrics
- (BasicMetrics.compute_cyclo !local_metrics);
+ (BasicMetrics.compute_cyclo !local_metrics);
global_metrics := BasicMetrics.set_cyclo !global_metrics
- (!global_metrics.ccyclo + !local_metrics.ccyclo);
+ (!global_metrics.ccyclo + !local_metrics.ccyclo);
(try
let fun_tbl = Datatype.Filepath.Map.find filename metrics_map in
self#update_metrics_map filename
(Metrics_base.OptionKf.Map.add func !local_metrics fun_tbl);
with
- | Not_found ->
- let new_stringmap =
- Metrics_base.OptionKf.Map.add func !local_metrics
- Metrics_base.OptionKf.Map.empty
- in
- self#update_metrics_map filename new_stringmap;
+ | Not_found ->
+ let new_stringmap =
+ Metrics_base.OptionKf.Map.add func !local_metrics
+ Metrics_base.OptionKf.Map.empty
+ in
+ self#update_metrics_map filename new_stringmap;
);
local_metrics := empty_metrics;
method! vdef def =
match def with
- | FUNDEF (_, sname, _, _, _) ->
- begin
- let funcname = Metrics_base.extract_fundef_name sname in
- local_metrics :=
- {!local_metrics with
- cfile_name = get_filename def;
- cfunc = Some (Metrics_base.kf_of_cabs_name sname);
- cfuncs = 1; (* Only one function is indeed being defined here *)};
- Metrics_parameters.debug
- ~level:1 "Definition of function %s encountered@." funcname;
- apply_then_set incr_funcs global_metrics;
- self#add_to_functions_with_source funcname;
- (* On return record the analysis of the function. *)
- Cil.ChangeDoChildrenPost
- ([def],
- fun _ ->
- begin
- if !local_metrics <> empty_metrics
- then self#record_and_clear !local_metrics;
- [def]
- end
- );
- end
- | DECDEF _
- | TYPEDEF _
- | ONLYTYPEDEF _
- | GLOBASM _
- | PRAGMA _
- | LINKAGE _
- | CUSTOM _
- | GLOBANNOT _ -> Cil.DoChildren;
+ | FUNDEF (_, sname, _, _, _) ->
+ begin
+ let funcname = Metrics_base.extract_fundef_name sname in
+ local_metrics :=
+ {!local_metrics with
+ cfile_name = get_filename def;
+ cfunc = Some (Metrics_base.kf_of_cabs_name sname);
+ cfuncs = 1; (* Only one function is indeed being defined here *)};
+ Metrics_parameters.debug
+ ~level:1 "Definition of function %s encountered@." funcname;
+ apply_then_set incr_funcs global_metrics;
+ self#add_to_functions_with_source funcname;
+ (* On return record the analysis of the function. *)
+ Cil.ChangeDoChildrenPost
+ ([def],
+ fun _ ->
+ begin
+ if !local_metrics <> empty_metrics
+ then self#record_and_clear !local_metrics;
+ [def]
+ end
+ );
+ end
+ | DECDEF _
+ | TYPEDEF _
+ | ONLYTYPEDEF _
+ | GLOBASM _
+ | PRAGMA _
+ | LINKAGE _
+ | CUSTOM _
+ | GLOBANNOT _ -> Cil.DoChildren;
method! vexpr expr =
(match expr.expr_node with
- | NOTHING -> ()
- | UNARY (unop, _) ->
- begin
- match unop with
- | PREINCR
- | POSINCR
- | PREDECR
- | POSDECR -> self#incr_both_metrics incr_assigns
- | MINUS
- | PLUS
- | NOT
- | BNOT -> ()
- | MEMOF -> self#incr_both_metrics incr_ptrs
- | ADDROF -> ()
- end
- | LABELADDR _ -> ()
- | BINARY (bop, _, _) ->
- begin
- match bop with
- | ADD | SUB | MUL | DIV | MOD
- | BAND | BOR | XOR
- | SHL | SHR | EQ | NE | LT
- | GT | LE | GE -> ()
- | AND | OR -> self#incr_both_metrics incr_dpoints
- | ASSIGN
- | ADD_ASSIGN | SUB_ASSIGN | MUL_ASSIGN
- | DIV_ASSIGN | BOR_ASSIGN | XOR_ASSIGN
- | SHL_ASSIGN | SHR_ASSIGN | BAND_ASSIGN
- | MOD_ASSIGN ->
- self#incr_both_metrics incr_assigns;
- end
- | CAST _ -> ()
- | CALL _ -> self#incr_both_metrics incr_calls;
- | QUESTION _ ->
- self#incr_both_metrics incr_dpoints;
- self#incr_both_metrics incr_ifs;
- | COMMA _
- | CONSTANT _
- | PAREN _
- | VARIABLE _
- | EXPR_SIZEOF _
- | TYPE_SIZEOF _
- | EXPR_ALIGNOF _
- | TYPE_ALIGNOF _
- | INDEX _
- | MEMBEROF _
- | MEMBEROFPTR _
- | GNU_BODY _
- | EXPR_PATTERN _ -> ());
+ | NOTHING -> ()
+ | UNARY (unop, _) ->
+ begin
+ match unop with
+ | PREINCR
+ | POSINCR
+ | PREDECR
+ | POSDECR -> self#incr_both_metrics incr_assigns
+ | MINUS
+ | PLUS
+ | NOT
+ | BNOT -> ()
+ | MEMOF -> self#incr_both_metrics incr_ptrs
+ | ADDROF -> ()
+ end
+ | LABELADDR _ -> ()
+ | BINARY (bop, _, _) ->
+ begin
+ match bop with
+ | ADD | SUB | MUL | DIV | MOD
+ | BAND | BOR | XOR
+ | SHL | SHR | EQ | NE | LT
+ | GT | LE | GE -> ()
+ | AND | OR -> self#incr_both_metrics incr_dpoints
+ | ASSIGN
+ | ADD_ASSIGN | SUB_ASSIGN | MUL_ASSIGN
+ | DIV_ASSIGN | BOR_ASSIGN | XOR_ASSIGN
+ | SHL_ASSIGN | SHR_ASSIGN | BAND_ASSIGN
+ | MOD_ASSIGN ->
+ self#incr_both_metrics incr_assigns;
+ end
+ | CAST _ -> ()
+ | CALL _ -> self#incr_both_metrics incr_calls;
+ | QUESTION _ ->
+ self#incr_both_metrics incr_dpoints;
+ self#incr_both_metrics incr_ifs;
+ | COMMA _
+ | CONSTANT _
+ | PAREN _
+ | VARIABLE _
+ | EXPR_SIZEOF _
+ | TYPE_SIZEOF _
+ | EXPR_ALIGNOF _
+ | TYPE_ALIGNOF _
+ | INDEX _
+ | MEMBEROF _
+ | MEMBEROFPTR _
+ | GNU_BODY _
+ | EXPR_PATTERN _ -> ());
Cil.DoChildren
(* Allows to count only one control-flow branch per case lists *)
method private set_case stmt =
match stmt.stmt_node with
- | CASERANGE _ | CASE _ -> was_case := true;
- | DEFAULT _
- | _ -> was_case := false
+ | CASERANGE _ | CASE _ -> was_case := true;
+ | DEFAULT _
+ | _ -> was_case := false
method! vstmt stmt =
self#incr_both_metrics incr_slocs;
(match stmt.stmt_node with
- | DEFAULT _ -> () (* The default case is not counted as a path choice
- point *)
- | CASERANGE _
- | CASE _ ->
- if not !was_case then self#incr_both_metrics incr_dpoints;
- | IF _ ->
- self#incr_both_metrics incr_ifs;
- self#incr_both_metrics incr_dpoints;
- | NOP _
- | COMPUTATION _
- | BLOCK _ -> ()
- (* Next 3 are all loop instructions *)
- | WHILE _
- | DOWHILE _
- | FOR _ ->
- self#incr_both_metrics incr_loops;
- self#incr_both_metrics incr_dpoints;
- | BREAK _
- | CONTINUE _ -> ()
- | RETURN _ | THROW _ -> self#incr_both_metrics incr_exits;
- | SWITCH _ -> ()
- | LABEL _ -> ()
- | GOTO _
- | COMPGOTO _ -> self#incr_both_metrics incr_gotos;
- | DEFINITION _
- | ASM _
- | SEQUENCE _
- | TRY_EXCEPT _
- | TRY_FINALLY _
- | TRY_CATCH _
- | CODE_ANNOT _
- | CODE_SPEC _ -> ());
+ | DEFAULT _ -> () (* The default case is not counted as a path choice
+ point *)
+ | CASERANGE _
+ | CASE _ ->
+ if not !was_case then self#incr_both_metrics incr_dpoints;
+ | IF _ ->
+ self#incr_both_metrics incr_ifs;
+ self#incr_both_metrics incr_dpoints;
+ | NOP _
+ | COMPUTATION _
+ | BLOCK _ -> ()
+ (* Next 3 are all loop instructions *)
+ | WHILE _
+ | DOWHILE _
+ | FOR _ ->
+ self#incr_both_metrics incr_loops;
+ self#incr_both_metrics incr_dpoints;
+ | BREAK _
+ | CONTINUE _ -> ()
+ | RETURN _ | THROW _ -> self#incr_both_metrics incr_exits;
+ | SWITCH _ -> ()
+ | LABEL _ -> ()
+ | GOTO _
+ | COMPGOTO _ -> self#incr_both_metrics incr_gotos;
+ | DEFINITION _
+ | ASM _
+ | SEQUENCE _
+ | TRY_EXCEPT _
+ | TRY_FINALLY _
+ | TRY_CATCH _
+ | CODE_ANNOT _
+ | CODE_SPEC _ -> ());
self#set_case stmt;
Cil.DoChildren
method private stats_of_filename filename =
try Datatype.Filepath.Map.find filename metrics_map
with
- | Not_found ->
- Metrics_parameters.fatal "Metrics for file %a not_found@."
- Datatype.Filepath.pretty filename
+ | Not_found ->
+ Metrics_parameters.fatal "Metrics for file %a not_found@."
+ Datatype.Filepath.pretty filename
method pp_file_metrics fmt filename =
Format.fprintf fmt "@[<v 0>%a@]"
(fun fmt filename ->
- let fun_tbl = self#stats_of_filename filename in
- OptionKf.Map.iter (fun _fun_name fmetrics ->
- Format.fprintf fmt "@ %a" pp_base_metrics fmetrics)
- fun_tbl;
+ let fun_tbl = self#stats_of_filename filename in
+ OptionKf.Map.iter (fun _fun_name fmetrics ->
+ Format.fprintf fmt "@ %a" pp_base_metrics fmetrics)
+ fun_tbl;
) filename
method pp_detailed_text_metrics fmt () =
Datatype.Filepath.Map.iter
(fun filename _func_tbl ->
- Format.fprintf fmt "%a" self#pp_file_metrics filename) metrics_map
+ Format.fprintf fmt "%a" self#pp_file_metrics filename) metrics_map
end
;;
@@ -243,65 +243,65 @@ end
(** Halstead metrics computation *)
module Halstead = struct
-(* We follow http://www.verifysoft.com/en_halstead_metrics.html
- for the classification of operands and operators
- operands = ids, typenames, typespecs, constants
-*)
+ (* We follow http://www.verifysoft.com/en_halstead_metrics.html
+ for the classification of operands and operators
+ operands = ids, typenames, typespecs, constants
+ *)
-let update_val value key tbl =
- try
- let v = Hashtbl.find tbl key in
- Hashtbl.replace tbl key (v + value);
- with
+ let update_val value key tbl =
+ try
+ let v = Hashtbl.find tbl key in
+ Hashtbl.replace tbl key (v + value);
+ with
| Not_found -> Hashtbl.add tbl key value
-;;
+ ;;
-let update_val_incr key tbl = update_val 1 key tbl;;
+ let update_val_incr key tbl = update_val 1 key tbl;;
-type operand_tbl = {
- var_tbl : (string, int) Hashtbl.t;
- cst_tbl : (Cabs.constant, int) Hashtbl.t;
-}
-;;
+ type operand_tbl = {
+ var_tbl : (string, int) Hashtbl.t;
+ cst_tbl : (Cabs.constant, int) Hashtbl.t;
+ }
+ ;;
-type operator_tbl = {
- knownop_tbl : (string, int) Hashtbl.t;
- otherop_tbl : (string, int) Hashtbl.t;
- reserved_tbl : (string, int) Hashtbl.t;
- tspec_tbl : (Cabs.typeSpecifier, int) Hashtbl.t;
-}
-;;
+ type operator_tbl = {
+ knownop_tbl : (string, int) Hashtbl.t;
+ otherop_tbl : (string, int) Hashtbl.t;
+ reserved_tbl : (string, int) Hashtbl.t;
+ tspec_tbl : (Cabs.typeSpecifier, int) Hashtbl.t;
+ }
+ ;;
-let id_from_init iname =
- match (fst iname) with
+ let id_from_init iname =
+ match (fst iname) with
| s, _, _, _ -> s
-;;
+ ;;
-class halsteadCabsVisitor = object(self)
+ class halsteadCabsVisitor = object(self)
- inherit Cabsvisit.nopCabsVisitor
+ inherit Cabsvisit.nopCabsVisitor
- val operand_tbl = {
- var_tbl = Hashtbl.create 7;
- cst_tbl = Hashtbl.create 7;
- }
+ val operand_tbl = {
+ var_tbl = Hashtbl.create 7;
+ cst_tbl = Hashtbl.create 7;
+ }
- val operator_tbl = {
- knownop_tbl = Hashtbl.create 7;
- otherop_tbl = Hashtbl.create 7;
- reserved_tbl = Hashtbl.create 7;
- tspec_tbl = Hashtbl.create 7;
- }
+ val operator_tbl = {
+ knownop_tbl = Hashtbl.create 7;
+ otherop_tbl = Hashtbl.create 7;
+ reserved_tbl = Hashtbl.create 7;
+ tspec_tbl = Hashtbl.create 7;
+ }
- method get_operator_tbl () = operator_tbl
- method get_operand_tbl () = operand_tbl
+ method get_operator_tbl () = operator_tbl
+ method get_operand_tbl () = operand_tbl
- method add_paren () =
- update_val_incr "(" operator_tbl.otherop_tbl;
- update_val_incr ")" operator_tbl.otherop_tbl;
+ method add_paren () =
+ update_val_incr "(" operator_tbl.otherop_tbl;
+ update_val_incr ")" operator_tbl.otherop_tbl;
- method! vexpr e =
- match e.Cabs.expr_node with
+ method! vexpr e =
+ match e.Cabs.expr_node with
| UNARY _ ->
let unop = fst (Cprint.get_operator e) in
update_val_incr unop operator_tbl.knownop_tbl;
@@ -317,7 +317,7 @@ class halsteadCabsVisitor = object(self)
| COMMA elist ->
let n = List.length elist in
if (n > 1) then
- update_val (n - 1) "," operator_tbl.otherop_tbl;
+ update_val (n - 1) "," operator_tbl.otherop_tbl;
Cil.DoChildren;
| CONSTANT c ->
update_val_incr c operand_tbl.cst_tbl;
@@ -340,12 +340,12 @@ class halsteadCabsVisitor = object(self)
| _ -> Cil.DoChildren;
- method! vstmt s =
- let reserved rstr =
- update_val_incr rstr operator_tbl.reserved_tbl;
- Cil.DoChildren;
- in
- match s.Cabs.stmt_node with
+ method! vstmt s =
+ let reserved rstr =
+ update_val_incr rstr operator_tbl.reserved_tbl;
+ Cil.DoChildren;
+ in
+ match s.Cabs.stmt_node with
| BLOCK _ ->
update_val_incr "{" operator_tbl.otherop_tbl;
update_val_incr "}" operator_tbl.otherop_tbl;
@@ -396,16 +396,16 @@ class halsteadCabsVisitor = object(self)
reserved "try";
| _ -> Cil.DoChildren;
- method! vtypespec tspec =
- update_val_incr tspec operator_tbl.tspec_tbl;
- Cil.DoChildren;
+ method! vtypespec tspec =
+ update_val_incr tspec operator_tbl.tspec_tbl;
+ Cil.DoChildren;
- method! vspec spec =
- let reserved rstr =
- update_val_incr rstr operator_tbl.reserved_tbl;
- in
- let do_spec s =
- match s with
+ method! vspec spec =
+ let reserved rstr =
+ update_val_incr rstr operator_tbl.reserved_tbl;
+ in
+ let do_spec s =
+ match s with
| SpecTypedef -> reserved "typedef"
| SpecInline -> reserved "inline"
| SpecStorage AUTO -> reserved "auto"
@@ -416,10 +416,10 @@ class halsteadCabsVisitor = object(self)
| SpecCV CV_VOLATILE -> reserved "volatile"
| SpecCV CV_RESTRICT -> reserved "restrict"
| _ -> ()
- in List.iter do_spec spec; Cil.DoChildren;
+ in List.iter do_spec spec; Cil.DoChildren;
- method! vdecltype tdecl =
- match tdecl with
+ method! vdecltype tdecl =
+ match tdecl with
| JUSTBASE ->
Cil.SkipChildren;
| PARENTYPE _ ->
@@ -435,25 +435,25 @@ class halsteadCabsVisitor = object(self)
Cil.SkipChildren;
- method! vinitexpr ie =
- ( match ie with
- | COMPOUND_INIT l ->
- let n = List.length l in
- if n > 0 then
- update_val n "," operator_tbl.otherop_tbl;
- | _ -> ());
- Cil.DoChildren
-
- method! vblock b =
- if b.bstmts <> [] then (
- let n = List.length b.bstmts in
- update_val n ";" operator_tbl.otherop_tbl);
- if b.battrs <> [] then
- update_val (List.length b.battrs) "," operator_tbl.otherop_tbl;
- Cil.DoChildren;
+ method! vinitexpr ie =
+ ( match ie with
+ | COMPOUND_INIT l ->
+ let n = List.length l in
+ if n > 0 then
+ update_val n "," operator_tbl.otherop_tbl;
+ | _ -> ());
+ Cil.DoChildren
+
+ method! vblock b =
+ if b.bstmts <> [] then (
+ let n = List.length b.bstmts in
+ update_val n ";" operator_tbl.otherop_tbl);
+ if b.battrs <> [] then
+ update_val (List.length b.battrs) "," operator_tbl.otherop_tbl;
+ Cil.DoChildren;
- method! vdef d =
- match d with
+ method! vdef d =
+ match d with
| FUNDEF (bl, (_, (fname, dtype, _, nloc)), b, loc1, loc2) ->
Cil.ChangeDoChildrenPost(
[FUNDEF(bl, ([], (fname, dtype, [], nloc)), b, loc1, loc2)],
@@ -463,9 +463,9 @@ class halsteadCabsVisitor = object(self)
let n =
List.fold_left
(fun acc n ->
- update_val_incr (id_from_init n) operand_tbl.var_tbl;
- acc + 1 )
- (-1) name_list in
+ update_val_incr (id_from_init n) operand_tbl.var_tbl;
+ acc + 1 )
+ (-1) name_list in
begin
assert(n >= 0);
if (n > 0) then update_val n "," operator_tbl.otherop_tbl;
@@ -474,171 +474,171 @@ class halsteadCabsVisitor = object(self)
| _ -> Cil.DoChildren
-end
-;;
-
-
-
-let compose _x1 y1 (x2, y2) = (1 + x2), (y1 + y2);;
-let fold x y = Hashtbl.fold compose x y;;
-
-let compute_operators operator_tbl =
- let x, y =
- fold operator_tbl.tspec_tbl (
- fold operator_tbl.otherop_tbl (
- fold operator_tbl.reserved_tbl (
- fold operator_tbl.knownop_tbl (0,0))))
- in (float_of_int x), (float_of_int y)
-;;
-
-let compute_operands operand_tbl =
- let x, y =
- fold operand_tbl.cst_tbl (
- fold operand_tbl.var_tbl (0,0))
- in (float_of_int x), (float_of_int y)
-;;
-
-type halstead_metrics = {
- distinct_operators : float;
- total_operators : float;
- distinct_operands : float;
- total_operands : float;
- program_length : float;
- program_volume : float;
- program_level : float;
- vocabulary_size : float;
- difficulty_level : float;
- effort_to_implement : float;
- time_to_implement : float;
- bugs_delivered : float;
-}
-
-let get_metrics cabs_visitor =
- let operator_tbl = cabs_visitor#get_operator_tbl () in
- let operand_tbl = cabs_visitor#get_operand_tbl () in
- let distinct_operators, total_operators = compute_operators operator_tbl
- and distinct_operands, total_operands = compute_operands operand_tbl in
- let program_length = total_operands +. total_operators in
- let vocabulary_size = distinct_operands +. distinct_operators in
- let log2 x = (log x) /. (log 2.0) in
- let program_volume = program_length *. (log2 vocabulary_size) in
- let difficulty_level =
- (distinct_operators /. 2.) *. (total_operands /. distinct_operands) in
- let program_level = 1. /. difficulty_level in
- let effort_to_implement = program_volume *. difficulty_level in
- let time_to_implement = effort_to_implement /. 18. in
- let bugs_delivered = (effort_to_implement ** (2./.3.)) /. 3000. in
- { distinct_operators = distinct_operators;
- total_operators = total_operators;
- distinct_operands = distinct_operands;
- total_operands = total_operands;
- program_length = program_length;
- program_volume = program_volume;
- program_level = program_level;
- vocabulary_size = vocabulary_size;
- difficulty_level = difficulty_level;
- effort_to_implement = effort_to_implement;
- time_to_implement = time_to_implement;
- bugs_delivered = bugs_delivered;
+ end
+ ;;
+
+
+
+ let compose _x1 y1 (x2, y2) = (1 + x2), (y1 + y2);;
+ let fold x y = Hashtbl.fold compose x y;;
+
+ let compute_operators operator_tbl =
+ let x, y =
+ fold operator_tbl.tspec_tbl (
+ fold operator_tbl.otherop_tbl (
+ fold operator_tbl.reserved_tbl (
+ fold operator_tbl.knownop_tbl (0,0))))
+ in (float_of_int x), (float_of_int y)
+ ;;
+
+ let compute_operands operand_tbl =
+ let x, y =
+ fold operand_tbl.cst_tbl (
+ fold operand_tbl.var_tbl (0,0))
+ in (float_of_int x), (float_of_int y)
+ ;;
+
+ type halstead_metrics = {
+ distinct_operators : float;
+ total_operators : float;
+ distinct_operands : float;
+ total_operands : float;
+ program_length : float;
+ program_volume : float;
+ program_level : float;
+ vocabulary_size : float;
+ difficulty_level : float;
+ effort_to_implement : float;
+ time_to_implement : float;
+ bugs_delivered : float;
}
-;;
-
-let to_list hmetrics =
- [ [ "Total operators"; float_to_string hmetrics.total_operators; ];
- [ "Distinct operators"; float_to_string hmetrics.distinct_operators; ];
- [ "Total_operands"; float_to_string hmetrics.total_operands; ];
- [ "Distinct operands"; float_to_string hmetrics.distinct_operands; ];
- [ "Program length"; float_to_string hmetrics.program_length; ];
- [ "Vocabulary size"; float_to_string hmetrics.vocabulary_size; ];
- [ "Program volume"; float_to_string hmetrics.program_volume; ];
- [ "Effort"; float_to_string hmetrics.effort_to_implement; ];
- [ "Program level"; float_to_string hmetrics.program_level; ];
- [ "Difficulty level"; float_to_string hmetrics.difficulty_level; ];
- [ "Time to implement"; float_to_string hmetrics.time_to_implement; ];
- [ "Bugs delivered"; float_to_string hmetrics.bugs_delivered; ];
- ]
-;;
-let pp_metrics ppf cabs_visitor =
- let metrics = get_metrics cabs_visitor in
- (* Compute the metrics from the informations gathered by the visitor. *)
- let minutes = (int_of_float metrics.time_to_implement) / 60 in
- let _hours, _minutes = minutes / 60, minutes mod 60 in
-
- let operator_tbl = cabs_visitor#get_operator_tbl () in
- let operand_tbl = cabs_visitor#get_operand_tbl () in
-
- let dummy_cst cst =
- { expr_loc = Cil_datatype.Location.unknown;
- expr_node = CONSTANT cst;
+ let get_metrics cabs_visitor =
+ let operator_tbl = cabs_visitor#get_operator_tbl () in
+ let operand_tbl = cabs_visitor#get_operand_tbl () in
+ let distinct_operators, total_operators = compute_operators operator_tbl
+ and distinct_operands, total_operands = compute_operands operand_tbl in
+ let program_length = total_operands +. total_operators in
+ let vocabulary_size = distinct_operands +. distinct_operators in
+ let log2 x = (log x) /. (log 2.0) in
+ let program_volume = program_length *. (log2 vocabulary_size) in
+ let difficulty_level =
+ (distinct_operators /. 2.) *. (total_operands /. distinct_operands) in
+ let program_level = 1. /. difficulty_level in
+ let effort_to_implement = program_volume *. difficulty_level in
+ let time_to_implement = effort_to_implement /. 18. in
+ let bugs_delivered = (effort_to_implement ** (2./.3.)) /. 3000. in
+ { distinct_operators = distinct_operators;
+ total_operators = total_operators;
+ distinct_operands = distinct_operands;
+ total_operands = total_operands;
+ program_length = program_length;
+ program_volume = program_volume;
+ program_level = program_level;
+ vocabulary_size = vocabulary_size;
+ difficulty_level = difficulty_level;
+ effort_to_implement = effort_to_implement;
+ time_to_implement = time_to_implement;
+ bugs_delivered = bugs_delivered;
}
- and simple_pp_htbl ppf htbl =
- Hashtbl.iter (fun k v -> Format.fprintf ppf "%s: %d@ " k v) htbl in
- (* Halstead metrics' bugs delivered statistics is said to be underapproximated
- for C. Hence the "lower bound" commentary on the output next to "bugs
- delivered".
- *)
- let title = "Halstead metrics"
- and stats = "Global statistics (Halstead)"
- and operator_sec = "Operators"
- and operand_sec = "Operands" in
- Format.fprintf ppf
- "@[<v 0>%a@ %a@ @ \
+ ;;
+
+ let to_list hmetrics =
+ [ [ "Total operators"; float_to_string hmetrics.total_operators; ];
+ [ "Distinct operators"; float_to_string hmetrics.distinct_operators; ];
+ [ "Total_operands"; float_to_string hmetrics.total_operands; ];
+ [ "Distinct operands"; float_to_string hmetrics.distinct_operands; ];
+ [ "Program length"; float_to_string hmetrics.program_length; ];
+ [ "Vocabulary size"; float_to_string hmetrics.vocabulary_size; ];
+ [ "Program volume"; float_to_string hmetrics.program_volume; ];
+ [ "Effort"; float_to_string hmetrics.effort_to_implement; ];
+ [ "Program level"; float_to_string hmetrics.program_level; ];
+ [ "Difficulty level"; float_to_string hmetrics.difficulty_level; ];
+ [ "Time to implement"; float_to_string hmetrics.time_to_implement; ];
+ [ "Bugs delivered"; float_to_string hmetrics.bugs_delivered; ];
+ ]
+ ;;
+
+ let pp_metrics ppf cabs_visitor =
+ let metrics = get_metrics cabs_visitor in
+ (* Compute the metrics from the informations gathered by the visitor. *)
+ let minutes = (int_of_float metrics.time_to_implement) / 60 in
+ let _hours, _minutes = minutes / 60, minutes mod 60 in
+
+ let operator_tbl = cabs_visitor#get_operator_tbl () in
+ let operand_tbl = cabs_visitor#get_operand_tbl () in
+
+ let dummy_cst cst =
+ { expr_loc = Cil_datatype.Location.unknown;
+ expr_node = CONSTANT cst;
+ }
+ and simple_pp_htbl ppf htbl =
+ Hashtbl.iter (fun k v -> Format.fprintf ppf "%s: %d@ " k v) htbl in
+ (* Halstead metrics' bugs delivered statistics is said to be underapproximated
+ for C. Hence the "lower bound" commentary on the output next to "bugs
+ delivered".
+ *)
+ let title = "Halstead metrics"
+ and stats = "Global statistics (Halstead)"
+ and operator_sec = "Operators"
+ and operand_sec = "Operands" in
+ Format.fprintf ppf
+ "@[<v 0>%a@ %a@ @ \
%a@ \
@[<v 2>%a@ %a%a%a%a@]@ \
@[<v 2>%a@ %a%a@]@ \
- @]"
- (mk_hdr 1) title
- (fun ppf l ->
- List.iter (fun rowl ->
- Format.fprintf ppf "@[<hov>";
- (match rowl with
- | title :: contents ->
- Format.fprintf ppf "%s:@ " title;
- List.iter (fun s -> Format.fprintf ppf "%s@ " s) contents;
- | [] -> ());
- Format.fprintf ppf "@]@ ";
- ) l) (to_list metrics)
- (mk_hdr 1) stats
-
- (mk_hdr 2) operator_sec
- (* Operators table *)
- simple_pp_htbl operator_tbl.reserved_tbl
- simple_pp_htbl operator_tbl.otherop_tbl
- simple_pp_htbl operator_tbl.knownop_tbl
- (fun ppf htbl ->
- Hashtbl.iter
- (fun k v ->
- Format.fprintf ppf "%a: %d@ " Cprint.print_type_spec k v) htbl)
- operator_tbl.tspec_tbl
- (* Operands *)
- (mk_hdr 2) operand_sec
- simple_pp_htbl operand_tbl.var_tbl
- (fun ppf htbl ->
- Hashtbl.iter
- (fun k v ->
- Format.fprintf ppf "%a: %d@ " Cprint.print_expression (dummy_cst k) v)
- htbl)
- operand_tbl.cst_tbl;
-;;
+ @]"
+ (mk_hdr 1) title
+ (fun ppf l ->
+ List.iter (fun rowl ->
+ Format.fprintf ppf "@[<hov>";
+ (match rowl with
+ | title :: contents ->
+ Format.fprintf ppf "%s:@ " title;
+ List.iter (fun s -> Format.fprintf ppf "%s@ " s) contents;
+ | [] -> ());
+ Format.fprintf ppf "@]@ ";
+ ) l) (to_list metrics)
+ (mk_hdr 1) stats
+
+ (mk_hdr 2) operator_sec
+ (* Operators table *)
+ simple_pp_htbl operator_tbl.reserved_tbl
+ simple_pp_htbl operator_tbl.otherop_tbl
+ simple_pp_htbl operator_tbl.knownop_tbl
+ (fun ppf htbl ->
+ Hashtbl.iter
+ (fun k v ->
+ Format.fprintf ppf "%a: %d@ " Cprint.print_type_spec k v) htbl)
+ operator_tbl.tspec_tbl
+ (* Operands *)
+ (mk_hdr 2) operand_sec
+ simple_pp_htbl operand_tbl.var_tbl
+ (fun ppf htbl ->
+ Hashtbl.iter
+ (fun k v ->
+ Format.fprintf ppf "%a: %d@ " Cprint.print_expression (dummy_cst k) v)
+ htbl)
+ operand_tbl.cst_tbl;
+ ;;
+
+ let compute_metrics () =
+ (* Run the visitor on all files *)
+ let cabs_files = Ast.UntypedFiles.get () in
+ let cabs_visitor = new halsteadCabsVisitor in
+ List.iter (fun file ->
+ ignore (Cabsvisit.visitCabsFile (cabs_visitor:>Cabsvisit.cabsVisitor) file))
+ cabs_files ;
+ Metrics_parameters.result "%a" pp_metrics cabs_visitor
-let compute_metrics () =
- (* Run the visitor on all files *)
- let cabs_files = Ast.UntypedFiles.get () in
- let cabs_visitor = new halsteadCabsVisitor in
- List.iter (fun file ->
- ignore (Cabsvisit.visitCabsFile (cabs_visitor:>Cabsvisit.cabsVisitor) file))
- cabs_files ;
- Metrics_parameters.result "%a" pp_metrics cabs_visitor
-
-let get_metrics () =
- let cabs_files = Ast.UntypedFiles.get () in
- let cabs_visitor = new halsteadCabsVisitor in
- List.iter (fun file ->
- ignore (Cabsvisit.visitCabsFile (cabs_visitor:>Cabsvisit.cabsVisitor) file))
- cabs_files ;
- get_metrics cabs_visitor
-;;
+ let get_metrics () =
+ let cabs_files = Ast.UntypedFiles.get () in
+ let cabs_visitor = new halsteadCabsVisitor in
+ List.iter (fun file ->
+ ignore (Cabsvisit.visitCabsFile (cabs_visitor:>Cabsvisit.cabsVisitor) file))
+ cabs_files ;
+ get_metrics cabs_visitor
+ ;;
end
@@ -647,24 +647,24 @@ let compute_on_cabs () =
let cabs_files = Ast.UntypedFiles.get () in
let cabs_visitor = new metricsCabsVisitor in
List.iter (fun file ->
- Metrics_parameters.debug
- ~level:2 "Compute Cabs metrics for file %a@."
- Datatype.Filepath.pretty (fst file);
- ignore
- (Cabsvisit.visitCabsFile (cabs_visitor:>Cabsvisit.cabsVisitor) file);
- )
+ Metrics_parameters.debug
+ ~level:2 "Compute Cabs metrics for file %a@."
+ Datatype.Filepath.pretty (fst file);
+ ignore
+ (Cabsvisit.visitCabsFile (cabs_visitor:>Cabsvisit.cabsVisitor) file);
+ )
cabs_files
;
if Metrics_parameters.ByFunction.get () then
- Metrics_parameters.result
- "@[<v 0>Cabs:@ %a@]" cabs_visitor#pp_detailed_text_metrics ();
+ Metrics_parameters.result
+ "@[<v 0>Cabs:@ %a@]" cabs_visitor#pp_detailed_text_metrics ();
Halstead.compute_metrics ();
with
- | Ast.NoUntypedAst ->
- Metrics_parameters.warning
- "@[<v 0> Project has no untyped AST. Only metrics over normalized CIL \
- AST are available. \
- @]@."
+ | Ast.NoUntypedAst ->
+ Metrics_parameters.warning
+ "@[<v 0> Project has no untyped AST. Only metrics over normalized CIL \
+ AST are available. \
+ @]@."
(*
Local Variables:
diff --git a/src/plugins/metrics/metrics_cilast.mli b/src/plugins/metrics/metrics_cilast.mli
index 5a54f1ef8b35afd7fc6a8661e2e4ecf274fb37e0..b0145ecb605317df2e9cc502f09e9e53497a61af 100644
--- a/src/plugins/metrics/metrics_cilast.mli
+++ b/src/plugins/metrics/metrics_cilast.mli
@@ -55,7 +55,7 @@ class type sloc_visitor = object
method get_metrics_map:
(Metrics_base.BasicMetrics.t Metrics_base.OptionKf.Map.t)
Datatype.Filepath.Map.t
- (** Compute and return per-function metrics *)
+ (** Compute and return per-function metrics *)
end
class slocVisitor : libc:bool -> sloc_visitor ;;
@@ -93,11 +93,11 @@ val compute_locals_size: Kernel_function.t -> unit;;
Returns [None] if there is no entry point. *)
val reachable_from_main: unit -> Cil_types.varinfo list option;;
-(** Computes the set of files defining all global variables syntactically
+(** Computes the set of files defining all global variables syntactically
reachable from the entry point of the program
(as given by [reachable_from_main]).
This function requires a defined entry point.
- *)
+*)
val used_files: unit -> Datatype.Filepath.Set.t
(** Pretty-prints the result of [used_files] in a verbose way. *)
diff --git a/src/plugins/metrics/metrics_coverage.ml b/src/plugins/metrics/metrics_coverage.ml
index 21a82a7fa2f115c33b30a09534d50a746271c9e4..bf3b7b52a55fb339b3366610c86449419777786d 100644
--- a/src/plugins/metrics/metrics_coverage.ml
+++ b/src/plugins/metrics/metrics_coverage.ml
@@ -101,8 +101,8 @@ class callableFunctionsVisitor ~libc = object(self)
method! visit_non_function_var vi =
let r = super#visit_non_function_var vi in
(match r with
- | None -> ()
- | Some init -> initializers <- (vi, init) :: initializers
+ | None -> ()
+ | Some init -> initializers <- (vi, init) :: initializers
);
r
@@ -138,68 +138,68 @@ type coverage_metrics = {
class deadCallsVisitor fmt ~libc cov_metrics =
let unseen = Varinfo.Set.diff cov_metrics.syntactic cov_metrics.semantic in
-object(self)
- inherit coverageAuxVisitor ~libc
+ object(self)
+ inherit coverageAuxVisitor ~libc
- val mutable current_initializer = None
+ val mutable current_initializer = None
- (* When an unseen function is reachable by the body of a function reached,
- or inside an initializer, display the information *)
- method private reached_fun vi =
- if Metrics_base.consider_function ~libc vi && Varinfo.Set.mem vi unseen then
- match self#current_kf with
- | None ->
+ (* When an unseen function is reachable by the body of a function reached,
+ or inside an initializer, display the information *)
+ method private reached_fun vi =
+ if Metrics_base.consider_function ~libc vi && Varinfo.Set.mem vi unseen then
+ match self#current_kf with
+ | None ->
(match current_initializer with
- | None -> assert false
- | Some vinit ->
- Format.fprintf fmt
- "@[<h>Initializer of %s references %s (at %t)@]@ "
- vinit.vname vi.vname Cil.pp_thisloc
+ | None -> assert false
+ | Some vinit ->
+ Format.fprintf fmt
+ "@[<h>Initializer of %s references %s (at %t)@]@ "
+ vinit.vname vi.vname Cil.pp_thisloc
)
- | Some f ->
- if Varinfo.Set.mem (Kernel_function.get_vi f) cov_metrics.semantic then
- let mess =
- match self#current_stmt with
+ | Some f ->
+ if Varinfo.Set.mem (Kernel_function.get_vi f) cov_metrics.semantic then
+ let mess =
+ match self#current_stmt with
| Some
{skind =
Instr (
Call (_, {enode = Lval (Var v, NoOffset)}, _, _)
| Local_init (_, ConsInit(v, _, _),_))}
- when Varinfo.equal v vi -> "calls"
+ when Varinfo.equal v vi -> "calls"
| _ -> "references"
- in
- Format.fprintf fmt
- "@[<h>Function %a %s %s (at %a)@]@ "
- Kernel_function.pretty f mess vi.vname
- Location.pretty (Cil.CurrentLoc.get ())
-
- method! vvrbl vi =
- if Cil.isFunctionType vi.vtype then self#reached_fun vi;
- Cil.SkipChildren (* no children anyway *)
-
- (* uses initializers *)
- method compute_and_print =
- if not (Varinfo.Set.is_empty unseen) || cov_metrics.initializers <> [] then begin
- Format.fprintf fmt "@[<v>%a@ "
- (Metrics_base.mk_hdr 2) "References to non-analyzed functions";
- let sorted_semantic =
- List.sort compare_vi_names (Varinfo.Set.elements cov_metrics.semantic)
- in
- List.iter self#visit_function sorted_semantic;
- let sorted_initializers =
- List.sort (fun (v1, _) (v2, _) -> compare_vi_names v1 v2) cov_metrics.initializers
- in
- List.iter (fun (vinit, init) ->
- current_initializer <- Some vinit;
- ignore (Visitor.visitFramacInit
- (self:>Visitor.frama_c_visitor)
- vinit NoOffset init);
- current_initializer <- None;
- ) sorted_initializers;
- Format.fprintf fmt "@]"
- end
-
-end
+ in
+ Format.fprintf fmt
+ "@[<h>Function %a %s %s (at %a)@]@ "
+ Kernel_function.pretty f mess vi.vname
+ Location.pretty (Cil.CurrentLoc.get ())
+
+ method! vvrbl vi =
+ if Cil.isFunctionType vi.vtype then self#reached_fun vi;
+ Cil.SkipChildren (* no children anyway *)
+
+ (* uses initializers *)
+ method compute_and_print =
+ if not (Varinfo.Set.is_empty unseen) || cov_metrics.initializers <> [] then begin
+ Format.fprintf fmt "@[<v>%a@ "
+ (Metrics_base.mk_hdr 2) "References to non-analyzed functions";
+ let sorted_semantic =
+ List.sort compare_vi_names (Varinfo.Set.elements cov_metrics.semantic)
+ in
+ List.iter self#visit_function sorted_semantic;
+ let sorted_initializers =
+ List.sort (fun (v1, _) (v2, _) -> compare_vi_names v1 v2) cov_metrics.initializers
+ in
+ List.iter (fun (vinit, init) ->
+ current_initializer <- Some vinit;
+ ignore (Visitor.visitFramacInit
+ (self:>Visitor.frama_c_visitor)
+ vinit NoOffset init);
+ current_initializer <- None;
+ ) sorted_initializers;
+ Format.fprintf fmt "@]"
+ end
+
+ end
class coverageByFun = object
inherit Visitor.frama_c_inplace
@@ -267,9 +267,9 @@ let compute_semantic ~libc =
Metrics_base.consider_function ~libc
(Kernel_function.get_vi kf)
then begin
- Metrics_parameters.feedback ~dkey:dkey_sem
- "marking %a as called" Kernel_function.pretty kf;
- res := Varinfo.Set.add (Kernel_function.get_vi kf) !res
+ Metrics_parameters.feedback ~dkey:dkey_sem
+ "marking %a as called" Kernel_function.pretty kf;
+ res := Varinfo.Set.add (Kernel_function.get_vi kf) !res
end
);
!res
diff --git a/src/plugins/metrics/metrics_gui.ml b/src/plugins/metrics/metrics_gui.ml
index e8360699d1289248a937da17658f7bca1f559748..911adfb3c9aeba2f19d6e6ea2aaef98ffd82c952 100644
--- a/src/plugins/metrics/metrics_gui.ml
+++ b/src/plugins/metrics/metrics_gui.ml
@@ -36,13 +36,13 @@ type ('a, 'b, 'c) metrics_panel = {
*)
let get_panel, set_panel, add_panel_action =
let panel = ref {
- top = None;
- bottom = None;
- actions = [];
- } in
+ top = None;
+ bottom = None;
+ actions = [];
+ } in
(fun () -> !panel),
(fun top_widget bottom_widget ->
- panel := { top = top_widget; bottom = bottom_widget; actions = []; }
+ panel := { top = top_widget; bottom = bottom_widget; actions = []; }
),
(fun action -> panel := { !panel with actions = action :: !panel.actions; })
;;
@@ -50,14 +50,14 @@ let get_panel, set_panel, add_panel_action =
(** Display the [table_contents] matrix as a GTK table *)
let display_as_table table_contents (parent:GPack.box) =
let table = GPack.table
- ~columns:(List.length (List.hd table_contents))
- ~rows:(List.length table_contents)
- ~homogeneous:true
- ~packing:parent#pack () in
+ ~columns:(List.length (List.hd table_contents))
+ ~rows:(List.length table_contents)
+ ~homogeneous:true
+ ~packing:parent#pack () in
Extlib.iteri (fun i row ->
- Extlib.iteri (fun j text ->
- table#attach ~left:j ~top:i
- ((GMisc.label ~justify:`LEFT ~text:text ()):>GObj.widget)) row)
+ Extlib.iteri (fun j text ->
+ table#attach ~left:j ~top:i
+ ((GMisc.label ~justify:`LEFT ~text:text ()):>GObj.widget)) row)
table_contents ;
;;
@@ -79,12 +79,12 @@ let init_panel (main_ui: Design.main_window_extension_points) =
let choices = GEdit.combo_box_text ~active:0 ~strings:[] ~packing:(up#pack) ()
in
let launch_button = GButton.button ~label:"Launch"
- ~packing:(up#pack) ()
+ ~packing:(up#pack) ()
in
ignore(launch_button#connect#clicked (fun () ->
- let actions = (get_panel ()).actions in
- let sopt = GEdit.text_combo_get_active choices in
- match sopt with
+ let actions = (get_panel ()).actions in
+ let sopt = GEdit.text_combo_get_active choices in
+ match sopt with
| None -> ()
| Some s ->
if List.mem_assoc s actions then
@@ -93,7 +93,7 @@ let init_panel (main_ui: Design.main_window_extension_points) =
ignore (main_ui#full_protect ~cancelable:true
(fun () -> action bottom))
else ()
- ) );
+ ) );
set_panel (Some choices) (Some bottom);
v
;;
@@ -101,8 +101,8 @@ let init_panel (main_ui: Design.main_window_extension_points) =
let reset_panel _ =
let metrics_panel = get_panel () in
match metrics_panel.bottom with
- | None -> ()
- | Some b -> clear_container b;
+ | None -> ()
+ | Some b -> clear_container b;
;;
diff --git a/src/plugins/metrics/metrics_parameters.ml b/src/plugins/metrics/metrics_parameters.ml
index 5aeae5dc6886cb3b151c7a285471a7421f72e207..9b2922193260332b719e24a49ec0412dc79c6c67 100644
--- a/src/plugins/metrics/metrics_parameters.ml
+++ b/src/plugins/metrics/metrics_parameters.ml
@@ -22,10 +22,10 @@
include Plugin.Register
(struct
- let name = "metrics"
- let shortname = "metrics"
- let help = "syntactic metrics"
- end)
+ let name = "metrics"
+ let shortname = "metrics"
+ let help = "syntactic metrics"
+ end)
module Enabled =
WithOutput
@@ -33,7 +33,7 @@ module Enabled =
let option_name = "-metrics"
let help = "activate metrics computation"
let output_by_default = true
- end)
+ end)
module ByFunction =
WithOutput
@@ -41,7 +41,7 @@ module ByFunction =
let option_name = "-metrics-by-function"
let help = "also compute metrics on a per-function basis"
let output_by_default = true
- end)
+ end)
module OutputFile =
Filepath
@@ -53,16 +53,16 @@ module OutputFile =
let help = "print some metrics into the specified file; \
the output format is recognized through the extension: \
.text/.txt for text, .html/.htm for HTML, or .json for JSON."
- end)
+ end)
module ValueCoverage =
WithOutput (
- struct
- let option_name = "-metrics-eva-cover"
- let help = "estimate Eva coverage w.r.t. \
- to reachable syntactic definitions"
- let output_by_default = true
- end)
+ struct
+ let option_name = "-metrics-eva-cover"
+ let help = "estimate Eva coverage w.r.t. \
+ to reachable syntactic definitions"
+ let output_by_default = true
+ end)
let () = ValueCoverage.add_aliases [ "-metrics-value-cover" ]
module AstType =
@@ -72,7 +72,7 @@ module AstType =
let arg_name = "[cabs | cil | acsl]"
let help = "apply metrics to Cabs or CIL AST, or to ACSL specs"
let default = "cil"
- end
+ end
)
module Libc =
@@ -81,7 +81,7 @@ module Libc =
let option_name = "-metrics-libc"
let help = "show functions from Frama-C standard C library in the \
results; deactivated by default."
- end
+ end
)
@@ -94,7 +94,7 @@ module SyntacticallyReachable =
let arg_name = "f1,..,fn"
let help = "compute an overapproximation of the functions reachable from \
f1,..,fn."
- end
+ end
)
module LocalsSize =
diff --git a/src/plugins/metrics/register.ml b/src/plugins/metrics/register.ml
index c074b9fa5ea1597c01e857d5dca5203c2b682ad7..1ab4336a288ce79a1cc5a57321819fddc016c314 100644
--- a/src/plugins/metrics/register.ml
+++ b/src/plugins/metrics/register.ml
@@ -24,18 +24,18 @@ open Metrics_parameters
;;
let () = Enabled.set_output_dependencies
- [ Ast.self; AstType.self; OutputFile.self; SyntacticallyReachable.self;
- Libc.self ]
+ [ Ast.self; AstType.self; OutputFile.self; SyntacticallyReachable.self;
+ Libc.self ]
;;
let syntactic ?(libc=Metrics_parameters.Libc.get ()) () =
begin
match AstType.get () with
- | "cil" -> Metrics_cilast.compute_on_cilast ~libc
- (* Cabs metrics are experimental. unregistered, unjournalized *)
- | "cabs" -> Metrics_cabs.compute_on_cabs ()
- | "acsl" -> Metrics_acsl.dump()
- | _ -> assert false (* the possible values are checked by the kernel*)
+ | "cil" -> Metrics_cilast.compute_on_cilast ~libc
+ (* Cabs metrics are experimental. unregistered, unjournalized *)
+ | "cabs" -> Metrics_cabs.compute_on_cabs ()
+ | "acsl" -> Metrics_acsl.dump()
+ | _ -> assert false (* the possible values are checked by the kernel*)
end;
SyntacticallyReachable.iter
(fun kf ->
diff --git a/src/plugins/metrics/register_gui.ml b/src/plugins/metrics/register_gui.ml
index f424d2004526263cdefd35d9e2427fc2c74b0eef..6cd3d4ad6b556d8b711ce147987db6ed4d644cc5 100644
--- a/src/plugins/metrics/register_gui.ml
+++ b/src/plugins/metrics/register_gui.ml
@@ -26,13 +26,13 @@
let mk_bi_label (parent:GPack.box) l1 =
let container = GPack.hbox ~packing:parent#pack () in
let t = GMisc.label ~text:l1 ~xalign:0.0
- ~packing:(container#pack ~expand:false ~fill:true)
- ()
+ ~packing:(container#pack ~expand:false ~fill:true)
+ ()
in
Gtk_helper.old_gtk_compat t#set_width_chars 7;
let label = GMisc.label ~selectable:true ~xalign:0.0 ~text:""
- ~packing:(container#pack ~expand:true)
- ()
+ ~packing:(container#pack ~expand:true)
+ ()
in label
@@ -40,8 +40,8 @@ let mk_bi_label (parent:GPack.box) l1 =
module HalsteadMetricsGUI = struct
- let compute = Metrics_cabs.compute_on_cabs
- let name = "Halstead"
+ let compute = Metrics_cabs.compute_on_cabs
+ let name = "Halstead"
let display_result (main_ui:Design.main_window_extension_points) (parent_win:GPack.box) =
try
@@ -68,7 +68,7 @@ module CyclomaticMetricsGUI = struct
open Metrics_base
open Pretty_source
open Visitor
-
+
let name = "Cyclomatic"
@@ -84,63 +84,63 @@ module CyclomaticMetricsGUI = struct
(* 2 becomes "2*checker#funcs" in the general case *)
method do_value (main_ui:Design.main_window_extension_points) loc
- (total:int) (valeur:int) (percent:float) =
- match loc with
- | PVDecl (Some kf,_,_) ->
- begin
- (* Get the global of this function *)
- let fname = Kernel_function.get_name kf in
- (* create a small results window *)
- let dialog = GWindow.window
- ~title:(Format.sprintf "Value analysis statistics of %s" fname)
- ~modal:false
- ~position:`CENTER_ON_PARENT
- ~border_width:3
- ~resizable:true
- ()
- in
- dialog#set_transient_for main_ui#main_window#as_window;
- let padder = GBin.alignment
- ~padding:(5, 0, 15, 15) ~packing:dialog#add () in
- let vbox = GPack.vbox () in
- padder#add (vbox:>GObj.widget);
- ignore (dialog#event#connect#delete
- ~callback:(fun _ -> dialog#misc#hide ();
- true));
- ignore(GMisc.label ~markup:(Printf.sprintf "<b>%s</b>" fname)
- ~justify:`LEFT ~packing:vbox#pack ());
- ignore(GMisc.separator `HORIZONTAL ~packing:vbox#pack ());
- let metrics_data = [["total stmts";(string_of_int total)];
- ["stmts analyzed";(string_of_int valeur)];
- ["percentage of stmts covered"; (string_of_float percent)]
- ] in
- Metrics_gui.display_as_table metrics_data vbox;
- let close_button = GButton.button ~stock:`OK ~packing:vbox#pack () in
- close_button#set_border_width 10;
- ignore (close_button#connect#clicked ~callback:dialog#misc#hide);
- dialog#show ()
- end
- | _ -> prerr_endline "no function"
+ (total:int) (valeur:int) (percent:float) =
+ match loc with
+ | PVDecl (Some kf,_,_) ->
+ begin
+ (* Get the global of this function *)
+ let fname = Kernel_function.get_name kf in
+ (* create a small results window *)
+ let dialog = GWindow.window
+ ~title:(Format.sprintf "Value analysis statistics of %s" fname)
+ ~modal:false
+ ~position:`CENTER_ON_PARENT
+ ~border_width:3
+ ~resizable:true
+ ()
+ in
+ dialog#set_transient_for main_ui#main_window#as_window;
+ let padder = GBin.alignment
+ ~padding:(5, 0, 15, 15) ~packing:dialog#add () in
+ let vbox = GPack.vbox () in
+ padder#add (vbox:>GObj.widget);
+ ignore (dialog#event#connect#delete
+ ~callback:(fun _ -> dialog#misc#hide ();
+ true));
+ ignore(GMisc.label ~markup:(Printf.sprintf "<b>%s</b>" fname)
+ ~justify:`LEFT ~packing:vbox#pack ());
+ ignore(GMisc.separator `HORIZONTAL ~packing:vbox#pack ());
+ let metrics_data = [["total stmts";(string_of_int total)];
+ ["stmts analyzed";(string_of_int valeur)];
+ ["percentage of stmts covered"; (string_of_float percent)]
+ ] in
+ Metrics_gui.display_as_table metrics_data vbox;
+ let close_button = GButton.button ~stock:`OK ~packing:vbox#pack () in
+ close_button#set_border_width 10;
+ ignore (close_button#connect#clicked ~callback:dialog#misc#hide);
+ dialog#show ()
+ end
+ | _ -> prerr_endline "no function"
method do_cyclo (main_ui:Design.main_window_extension_points) =
let fname = Kernel_function.get_name checked_fun in
- (* create a small results window *)
+ (* create a small results window *)
let dialog = GWindow.window
- ~title:(Format.sprintf "Measures for %s" fname)
- ~modal:false
- ~position:`CENTER_ON_PARENT
- ~border_width:3
- ~resizable:true
- ()
+ ~title:(Format.sprintf "Measures for %s" fname)
+ ~modal:false
+ ~position:`CENTER_ON_PARENT
+ ~border_width:3
+ ~resizable:true
+ ()
in
dialog#set_transient_for main_ui#main_window#as_window;
let padder = GBin.alignment
- ~padding:(5, 0, 15, 15) ~packing:dialog#add () in
+ ~padding:(5, 0, 15, 15) ~packing:dialog#add () in
let vbox = GPack.vbox () in
padder#add (vbox:>GObj.widget);
ignore (dialog#event#connect#delete
~callback:(fun _ -> dialog#misc#hide ();
- true));
+ true));
ignore(GMisc.label ~markup:(Printf.sprintf "<b>%s</b>" fname)
~justify:`LEFT ~packing:vbox#pack ());
ignore(GMisc.separator `HORIZONTAL ~packing:vbox#pack ());
@@ -151,42 +151,42 @@ module CyclomaticMetricsGUI = struct
ignore (close_button#connect#clicked ~callback:dialog#misc#hide);
dialog#show ()
- (* callback of menu_item "Cyclo" *)
+ (* callback of menu_item "Cyclo" *)
method display_localizable localizable () =
begin
match localizable with
- | PVDecl (Some kf,_,_) -> (* Process only the function selected *)
- (* Get the global of this function *)
- checked_fun <- kf;
- self#do_cyclo main_ui;
- | _ -> ()
+ | PVDecl (Some kf,_,_) -> (* Process only the function selected *)
+ (* Get the global of this function *)
+ checked_fun <- kf;
+ self#do_cyclo main_ui;
+ | _ -> ()
end
method cyclo_selector (popup_factory:GMenu.menu GMenu.factory) main_ui ~button localizable =
if button = 3 && Db.Value.is_computed () then
match localizable with
- | PVDecl (Some kf, _,_) ->
- let callback1 () =
- Metrics_parameters.debug "cyclo_selector - callback";
- self#display_localizable localizable ()
- in
- let callback2 () =
- (* function selected is kf *)
- Metrics_coverage.compute_coverage_by_fun ();
- (* Got a list of (kf,value,total,percent).
- Now let's scan this list *)
- try
- let valeur,total,percent = Metrics_coverage.get_coverage kf in
- self#do_value main_ui localizable valeur total percent
- with Not_found -> ()
- in
- begin
- ignore (popup_factory#add_item "Cyclomatic metrics"
- ~callback:callback1);
- ignore (popup_factory#add_item "Value metrics"
- ~callback:callback2)
- end
- | _ -> ()
+ | PVDecl (Some kf, _,_) ->
+ let callback1 () =
+ Metrics_parameters.debug "cyclo_selector - callback";
+ self#display_localizable localizable ()
+ in
+ let callback2 () =
+ (* function selected is kf *)
+ Metrics_coverage.compute_coverage_by_fun ();
+ (* Got a list of (kf,value,total,percent).
+ Now let's scan this list *)
+ try
+ let valeur,total,percent = Metrics_coverage.get_coverage kf in
+ self#do_value main_ui localizable valeur total percent
+ with Not_found -> ()
+ in
+ begin
+ ignore (popup_factory#add_item "Cyclomatic metrics"
+ ~callback:callback1);
+ ignore (popup_factory#add_item "Value metrics"
+ ~callback:callback2)
+ end
+ | _ -> ()
initializer
main_ui#register_source_selector self#cyclo_selector
@@ -196,7 +196,7 @@ module CyclomaticMetricsGUI = struct
let display_result ~libc (parent_win:GPack.box) =
let padder = GBin.alignment
- ~padding:(5, 5, 15, 15) ~packing:parent_win#pack () in
+ ~padding:(5, 5, 15, 15) ~packing:parent_win#pack () in
let box = GPack.vbox ~homogeneous:false () in
padder#add (box:>GObj.widget);
ignore(GMisc.label ~markup:(Printf.sprintf "<b>%s</b>" name)
@@ -219,7 +219,7 @@ module ValueCoverageGUI = struct
let name = "Eva coverage"
- let result = ref None
+ let result = ref None
let highlight = ref false
let update_filetree = ref (fun _ -> ())
@@ -232,10 +232,10 @@ module ValueCoverageGUI = struct
let compute ~libc =
begin
match !result with
- | None ->
- !Db.Value.compute ();
- result := Some (Metrics_coverage.compute ~libc)
- | Some _ -> ()
+ | None ->
+ !Db.Value.compute ();
+ result := Some (Metrics_coverage.compute ~libc)
+ | Some _ -> ()
end;
Metrics_coverage.compute_coverage_by_fun ();
!update_filetree `Contents;
@@ -294,46 +294,46 @@ module ValueCoverageGUI = struct
Db.Value.Table_By_Callstack.add_hook_on_update
(fun _ ->
Metrics_coverage.clear_coverage_by_fun ();
- !update_filetree `Visibility)
+ !update_filetree `Visibility)
(* Functions are highlighted using different colors according to the
following scheme:
- Both semantically and syntactically reachable functions are green;
- Only syntactically reachable are yellow;
- Unreachable (neither semantically nor syntactically) functions
- are in red (bad!)
+ are in red (bad!)
*)
let highlighter buffer loc ~start ~stop =
if !highlight then begin
match !result with
- | None -> ()
- | Some metrics ->
- begin
- let pure_syntactic =
- Varinfo.Set.diff metrics.syntactic metrics.semantic
- in
- let hilit color =
- let tag = make_tag buffer#buffer "metrics" [`BACKGROUND color] in
- apply_tag buffer#buffer tag start stop
- in
- let syn_hilit () = hilit "yellow"
- and sem_hilit () = hilit "green"
- and unseen_hilit () = hilit "red"
- in
- match loc with
- | Pretty_source.PVDecl(_, _, vi) ->
- if Ast_info.is_function_type vi then begin
- if Varinfo.Set.mem vi pure_syntactic then syn_hilit ()
- else if Varinfo.Set.mem vi metrics.semantic then sem_hilit ()
- else unseen_hilit ()
- end
- | _ -> ()
- end
+ | None -> ()
+ | Some metrics ->
+ begin
+ let pure_syntactic =
+ Varinfo.Set.diff metrics.syntactic metrics.semantic
+ in
+ let hilit color =
+ let tag = make_tag buffer#buffer "metrics" [`BACKGROUND color] in
+ apply_tag buffer#buffer tag start stop
+ in
+ let syn_hilit () = hilit "yellow"
+ and sem_hilit () = hilit "green"
+ and unseen_hilit () = hilit "red"
+ in
+ match loc with
+ | Pretty_source.PVDecl(_, _, vi) ->
+ if Ast_info.is_function_type vi then begin
+ if Varinfo.Set.mem vi pure_syntactic then syn_hilit ()
+ else if Varinfo.Set.mem vi metrics.semantic then sem_hilit ()
+ else unseen_hilit ()
+ end
+ | _ -> ()
+ end
end
let display_result ~libc main_ui (parent_win:GPack.box) =
let padder = GBin.alignment
- ~padding:(5, 5, 15, 15) ~packing:parent_win#pack () in
+ ~padding:(5, 5, 15, 15) ~packing:parent_win#pack () in
let box = GPack.vbox ~homogeneous:false () in
padder#add (box:>GObj.widget);
ignore(GMisc.label ~markup:(Printf.sprintf "<b>%s</b>" name)
diff --git a/src/plugins/occurrence/Occurrence.mli b/src/plugins/occurrence/Occurrence.mli
index 54e5e73932fba43f2400f41606c7efc6dc468aff..8c3ebf0ffbf6c4c15a64be738c77be0e5306ba88 100644
--- a/src/plugins/occurrence/Occurrence.mli
+++ b/src/plugins/occurrence/Occurrence.mli
@@ -30,11 +30,11 @@ module Register: sig
val get_last_result:
unit -> ((kernel_function option * kinstr * lval) list * varinfo) option
val get: (varinfo -> (kernel_function option * kinstr * lval) list)
- (** Return the occurrences of the given varinfo.
- An occurrence [ki, lv] is a left-value [lv] which uses the location of
- [vi] at the position [ki]. *)
+ (** Return the occurrences of the given varinfo.
+ An occurrence [ki, lv] is a left-value [lv] which uses the location of
+ [vi] at the position [ki]. *)
val print_all: (unit -> unit)
- (** Print all the occurrence of each variable declarations. *)
+ (** Print all the occurrence of each variable declarations. *)
end
(*
diff --git a/src/plugins/occurrence/options.ml b/src/plugins/occurrence/options.ml
index 81c60ea7e4612dd9408b4cf2484c99ae850e93cb..71c4d7ad9a97b60689aac21cdc6a05e3c98a0ec7 100644
--- a/src/plugins/occurrence/options.ml
+++ b/src/plugins/occurrence/options.ml
@@ -21,18 +21,18 @@
(**************************************************************************)
include Plugin.Register
- (struct
- let name = "occurrence"
- let shortname = "occurrence"
- let help = "automatically computes where variables are used"
- end)
+ (struct
+ let name = "occurrence"
+ let shortname = "occurrence"
+ let help = "automatically computes where variables are used"
+ end)
module Print =
False
(struct
- let option_name = "-occurrence"
- let help = "print results of occurrence analysis"
- end)
+ let option_name = "-occurrence"
+ let help = "print results of occurrence analysis"
+ end)
(*
Local Variables:
diff --git a/src/plugins/occurrence/register.ml b/src/plugins/occurrence/register.ml
index 8fb2758b0404f0d601b34183b64fc6f14b5792bf..9d4f0680471f3286ffbf940813c0ed386ef42b15 100644
--- a/src/plugins/occurrence/register.ml
+++ b/src/plugins/occurrence/register.ml
@@ -48,18 +48,18 @@ end = struct
Cil_state_builder.Varinfo_hashtbl
(Occurrence_datatype)
(struct
- let size = 17
- let name = "Occurrences.State"
- let dependencies = [ Db.Value.self ]
- end)
+ let size = 17
+ let name = "Occurrences.State"
+ let dependencies = [ Db.Value.self ]
+ end)
module LastResult =
State_builder.Option_ref
(Varinfo)
(struct
- let name = "Occurrences.LastResult"
- let dependencies = [ Ast.self; IState.self ]
- end)
+ let name = "Occurrences.LastResult"
+ let dependencies = [ Ast.self; IState.self ]
+ end)
let add vi kf ki lv = IState.add vi (kf, ki, lv)
@@ -80,21 +80,21 @@ end = struct
let old, l =
fold
(fun v elt (old, l) -> match v, old with
- | v, None ->
- assert (l = []);
- Some v, [ elt ]
- | v, (Some old as some) when Varinfo.equal v old ->
- some, elt :: l
- | v, Some old ->
- f old l;
- Some v, [ elt ])
+ | v, None ->
+ assert (l = []);
+ Some v, [ elt ]
+ | v, (Some old as some) when Varinfo.equal v old ->
+ some, elt :: l
+ | v, Some old ->
+ f old l;
+ Some v, [ elt ])
(None, [])
in
Option.iter (fun v -> f v l) old
let fold_sorted f init =
let map = IState.fold Varinfo.Map.add Varinfo.Map.empty in
- Varinfo.Map.fold f map init
+ Varinfo.Map.fold f map init
let iter = iter_aux IState.fold
let iter_sorted = iter_aux fold_sorted
@@ -114,10 +114,10 @@ class occurrence = object (self)
try
Locations.Zone.fold_topset_ok
(fun b _ () ->
- match b with
- | Base.Var (vi, _) | Base.Allocated (vi, _, _) ->
- Occurrences.add vi self#current_kf ki lv
- | _ -> ()
+ match b with
+ | Base.Var (vi, _) | Base.Allocated (vi, _, _) ->
+ Occurrences.add vi self#current_kf ki lv
+ | _ -> ()
) z ()
with Abstract_interp.Error_Top ->
error ~current:true "Found completely imprecise value (%a). Ignoring@."
@@ -130,8 +130,8 @@ class occurrence = object (self)
let lv = !Db.Properties.Interp.term_lval_to_lval ~result:None tlv in
ignore (self#vlval lv)
with
- (* Translation to lval failed.*)
- | Db.Properties.Interp.No_conversion -> ());
+ (* Translation to lval failed.*)
+ | Db.Properties.Interp.No_conversion -> ());
DoChildren
method! vstmt_aux s =
@@ -163,40 +163,40 @@ let classify_accesses (_kf, ki, lv) =
let is_lv = Cil_datatype.Lval.equal lv in
let contained_exp = aux Cil.visitCilExpr in
match ki with
- | Kglobal -> (* Probably initializers *) Read
-
- | Kstmt { skind = Instr i } ->
- (match i with
- | Set (lv', e, _) ->
- if is_lv lv' then
- if contained_exp e then Both
- else Write
- else Read
-
- | Call (Some lv', f, args, _) ->
- if is_lv lv' then
- if contained_exp f || List.exists contained_exp args then Both
- else Write
- else Read
-
- | Local_init (v, _, _) ->
- (match lv with
- | Var v', _ when Cil_datatype.Varinfo.equal v v' ->
- (* We are initializing v. We can't read from it at the same time.
- Hence, there's no need to perform the additional checks done
- in the cases above. *)
- Write
- | _ -> Read)
-
- | Asm (_, _, Some { asm_outputs; asm_inputs },_) ->
- if List.exists (fun (_, _, out) -> is_lv out) asm_outputs then
- if List.exists (fun (_, _, inp) -> contained_exp inp) asm_inputs
- then Both
- else Write
- else Read
-
+ | Kglobal -> (* Probably initializers *) Read
+
+ | Kstmt { skind = Instr i } ->
+ (match i with
+ | Set (lv', e, _) ->
+ if is_lv lv' then
+ if contained_exp e then Both
+ else Write
+ else Read
+
+ | Call (Some lv', f, args, _) ->
+ if is_lv lv' then
+ if contained_exp f || List.exists contained_exp args then Both
+ else Write
+ else Read
+
+ | Local_init (v, _, _) ->
+ (match lv with
+ | Var v', _ when Cil_datatype.Varinfo.equal v v' ->
+ (* We are initializing v. We can't read from it at the same time.
+ Hence, there's no need to perform the additional checks done
+ in the cases above. *)
+ Write
| _ -> Read)
- | _ -> Read
+
+ | Asm (_, _, Some { asm_outputs; asm_inputs },_) ->
+ if List.exists (fun (_, _, out) -> is_lv out) asm_outputs then
+ if List.exists (fun (_, _, inp) -> contained_exp inp) asm_inputs
+ then Both
+ else Write
+ else Read
+
+ | _ -> Read)
+ | _ -> Read
let compute, _self =
let run () =
@@ -213,26 +213,26 @@ let get vi =
let d_ki fmt = function
| None, Kglobal -> Format.fprintf fmt "global"
| Some kf, Kglobal ->
- Format.fprintf fmt "specification of %a" Kernel_function.pretty kf
+ Format.fprintf fmt "specification of %a" Kernel_function.pretty kf
| _, Kstmt s -> Format.fprintf fmt "sid %d" s.sid
let print_one fmt v l =
- Format.fprintf fmt "variable %s (%s):@\n"
- v.vname
+ Format.fprintf fmt "variable %s (%s):@\n"
+ v.vname
(if v.vglob then "global"
- else
- let kf_name = match l with
- | [] -> assert false
- | (Some kf, _, _) :: _ -> Kernel_function.get_name kf
- | (None,Kstmt _,_)::_ -> assert false
- | (None,Kglobal,_)::_ ->
- fatal "inconsistent context for occurrence of variable %s" v.vname
- in
- if v.vformal then "parameter of " ^ kf_name
- else "local of " ^ kf_name);
+ else
+ let kf_name = match l with
+ | [] -> assert false
+ | (Some kf, _, _) :: _ -> Kernel_function.get_name kf
+ | (None,Kstmt _,_)::_ -> assert false
+ | (None,Kglobal,_)::_ ->
+ fatal "inconsistent context for occurrence of variable %s" v.vname
+ in
+ if v.vformal then "parameter of " ^ kf_name
+ else "local of " ^ kf_name);
List.iter
(fun (kf, ki, lv) ->
- Format.fprintf fmt " %a: %a@\n" d_ki (kf,ki) Printer.pp_lval lv) l
+ Format.fprintf fmt " %a: %a@\n" d_ki (kf,ki) Printer.pp_lval lv) l
let print_all () =
compute ();
@@ -249,11 +249,11 @@ let get =
Journal.register
"Occurrence.get"
(Datatype.func
- Varinfo.ty
- (* [JS 2011/04/01] Datatype.list buggy in presence of journalisation.
- See comment in datatype.ml *)
- (*(Datatype.list (Datatype.pair Kinstr.ty Lval.ty))*)
- (let module L = Datatype.List(Occurrence_datatype) in L.ty))
+ Varinfo.ty
+ (* [JS 2011/04/01] Datatype.list buggy in presence of journalisation.
+ See comment in datatype.ml *)
+ (*(Datatype.list (Datatype.pair Kinstr.ty Lval.ty))*)
+ (let module L = Datatype.List(Occurrence_datatype) in L.ty))
get
let print_all =
diff --git a/src/plugins/occurrence/register_gui.ml b/src/plugins/occurrence/register_gui.ml
index 2263f173e76207b6451bbff2a4aa8c809fa81c42..d72c4e32a2ffb6494551a14665fe2c32fc5d3d97 100644
--- a/src/plugins/occurrence/register_gui.ml
+++ b/src/plugins/occurrence/register_gui.ml
@@ -33,43 +33,43 @@ let update_column = ref (fun _ -> ())
module Enabled = State_builder.Ref
(Datatype.Bool)
(struct
- let name = "Occurrence_gui.State"
- let dependencies = [Register.self]
- let default () = false
- end)
+ let name = "Occurrence_gui.State"
+ let dependencies = [Register.self]
+ let default () = false
+ end)
module ShowRead = State_builder.Ref
- (Datatype.Bool)
- (struct
- let name = "Occurrence_gui.ShowRead"
- let dependencies = []
- let default () = true
- end)
+ (Datatype.Bool)
+ (struct
+ let name = "Occurrence_gui.ShowRead"
+ let dependencies = []
+ let default () = true
+ end)
module ShowWrite = State_builder.Ref
- (Datatype.Bool)
- (struct
- let name = "Occurrence_gui.ShowWrite"
- let dependencies = []
- let default () = true
- end)
+ (Datatype.Bool)
+ (struct
+ let name = "Occurrence_gui.ShowWrite"
+ let dependencies = []
+ let default () = true
+ end)
let consider_access () =
match ShowRead.get (), ShowWrite.get () with
- | false, false -> (fun _ -> false)
- | true, true -> (fun _ -> true)
- | true, false ->
- (fun ak -> ak = Register.Read || ak = Register.Both)
- | false, true ->
- (fun ak -> ak = Register.Write || ak = Register.Both)
+ | false, false -> (fun _ -> false)
+ | true, true -> (fun _ -> true)
+ | true, false ->
+ (fun ak -> ak = Register.Read || ak = Register.Both)
+ | false, true ->
+ (fun ak -> ak = Register.Write || ak = Register.Both)
let filter_accesses l =
match ShowRead.get (), ShowWrite.get () with
- | false, false -> []
- | true, true -> l
- | true, false | false, true ->
- let f = consider_access () in
- List.filter (fun access -> f (Register.classify_accesses access)) l
+ | false, false -> []
+ | true, true -> l
+ | true, false | false, true ->
+ let f = consider_access () in
+ List.filter (fun access -> f (Register.classify_accesses access)) l
let _ignore =
Dynamic.register
@@ -102,39 +102,39 @@ let apply_on_vi f localizable = match localizable with
| PVDecl(_,_,vi)
| PLval(_, _, (Var vi, NoOffset))
| PTermLval(_, _, _, (TVar { lv_origin = Some vi }, TNoOffset)) ->
- if not (Cil.isFunctionType vi.vtype) then
- f vi
+ if not (Cil.isFunctionType vi.vtype) then
+ f vi
| _ -> ()
let occurrence_highlighter buffer loc ~start ~stop =
if Enabled.get () then
match Register.get_last_result () with
| None -> (* occurrence not computed *)
- ()
+ ()
| Some (result, vi) ->
- let result = filter_accesses result in
- let buffer = buffer#buffer in
- let highlight () =
- let tag = make_tag buffer "occurrence" [`BACKGROUND "yellow" ] in
- apply_tag buffer tag start stop
+ let result = filter_accesses result in
+ let buffer = buffer#buffer in
+ let highlight () =
+ let tag = make_tag buffer "occurrence" [`BACKGROUND "yellow" ] in
+ apply_tag buffer tag start stop
+ in
+ match loc with
+ | PLval (_, ki, lval) ->
+ let same_lval (_kf, k, l) =
+ Kinstr.equal k ki && Lval.equal l lval
in
- match loc with
- | PLval (_, ki, lval) ->
- let same_lval (_kf, k, l) =
- Kinstr.equal k ki && Lval.equal l lval
- in
- if List.exists same_lval result then highlight ()
- | PTermLval (_,ki,_,term_lval) ->
- let same_tlval (_kf, k, l) =
- Logic_utils.is_same_tlval
- (Logic_utils.lval_to_term_lval l)
- term_lval
- && Kinstr.equal k ki
- in
- if List.exists same_tlval result then highlight ()
- | PVDecl(_, _,vi') when Varinfo.equal vi vi' ->
- highlight ()
- | PExp _ | PVDecl _ | PStmt _ | PStmtStart _ | PGlobal _ | PIP _ -> ()
+ if List.exists same_lval result then highlight ()
+ | PTermLval (_,ki,_,term_lval) ->
+ let same_tlval (_kf, k, l) =
+ Logic_utils.is_same_tlval
+ (Logic_utils.lval_to_term_lval l)
+ term_lval
+ && Kinstr.equal k ki
+ in
+ if List.exists same_tlval result then highlight ()
+ | PVDecl(_, _,vi') when Varinfo.equal vi vi' ->
+ highlight ()
+ | PExp _ | PVDecl _ | PStmt _ | PStmtStart _ | PGlobal _ | PIP _ -> ()
module FollowFocus =
State_builder.Ref
@@ -143,7 +143,7 @@ module FollowFocus =
let name = "Occurrence_gui.FollowFocus"
let dependencies = []
let default () = false
- end)
+ end)
let occurrence_panel main_ui =
let w = GPack.vbox () in
@@ -153,25 +153,25 @@ let occurrence_panel main_ui =
(GMisc.label ~xalign:0.0 ~text:"Current var: "
~packing:(selected_var_box#pack ~expand:false) ());
let e = GMisc.label ~xalign:0.0
- ~selectable:true
- ~packing:(selected_var_box#pack ~expand:true ~fill:true)
- ()
+ ~selectable:true
+ ~packing:(selected_var_box#pack ~expand:true ~fill:true)
+ ()
in
e#set_use_markup true;
old_gtk_compat e#set_single_line_mode true;
(* check_button enabled *)
let refresh_enabled_button = on_bool
- w
- "Enable"
- Enabled.get
- (fun v -> Enabled.set v;
- !update_column `Visibility;
- main_ui#rehighlight ())
+ w
+ "Enable"
+ Enabled.get
+ (fun v -> Enabled.set v;
+ !update_column `Visibility;
+ main_ui#rehighlight ())
in
(* check_button followFocus *)
let refresh_followFocus = on_bool w "Follow focus"
- FollowFocus.get
- FollowFocus.set
+ FollowFocus.get
+ FollowFocus.set
in
let h_read_write = GPack.hbox ~packing:w#pack () in
let refresh_rw_aux f v =
@@ -181,11 +181,11 @@ let occurrence_panel main_ui =
in
let refresh_read =
Gtk_helper.on_bool
- ~tooltip:"Show only occurrences where the zone is read"
+ ~tooltip:"Show only occurrences where the zone is read"
h_read_write "Read" ShowRead.get (refresh_rw_aux ShowRead.set) in
let refresh_write =
Gtk_helper.on_bool
- ~tooltip:"Show only occurrences where the zone is written"
+ ~tooltip:"Show only occurrences where the zone is written"
h_read_write "Write" ShowWrite.get (refresh_rw_aux ShowWrite.set) in
let refresh =
let old_vi = ref (-2) in
@@ -197,52 +197,52 @@ let occurrence_panel main_ui =
let new_result = Register.get_last_result () in
(match new_result with
| None when !old_vi<> -1 ->
- old_vi := -1; e#set_label "<i>None</i>"
+ old_vi := -1; e#set_label "<i>None</i>"
| Some (_,vi) when vi.vid<> !old_vi->
- old_vi := vi.vid;
- e#set_label vi.vname
+ old_vi := vi.vid;
+ e#set_label vi.vname
| _ -> ()))
in
"Occurrence",w#coerce,Some refresh
let occurrence_selector
(popup_factory:GMenu.menu GMenu.factory) main_ui ~button localizable =
- apply_on_vi
- (fun vi ->
+ apply_on_vi
+ (fun vi ->
if button = 3 || FollowFocus.get () then begin
let callback = find_occurrence main_ui vi in
ignore (popup_factory#add_item "_Occurrence" ~callback);
if FollowFocus.get () then
ignore (Glib.Idle.add (fun () -> callback (); false))
end)
- localizable
+ localizable
let file_tree_decorate (file_tree:Filetree.t) =
update_column :=
file_tree#append_pixbuf_column
~title:"Occurrence"
(fun globs ->
- match Register.get_last_result () with
- | None -> (* occurrence not computed *)
- [`STOCK_ID ""]
- | Some (result, _) ->
- let in_globals (kf,ki,_ as access) =
- (let ak = Register.classify_accesses access in
- consider_access () ak)
- &&
- match ki with
- | Kglobal -> false
- | Kstmt _ ->
- let kf = Option.get kf in
- let v0 = Kernel_function.get_vi kf in
- List.exists
- (fun glob -> match glob with
- | GFun ({svar =v1},_ ) -> Varinfo.equal v1 v0
- | _ -> false)
- globs
- in
- if List.exists in_globals result then [`STOCK_ID "gtk-apply"]
- else [`STOCK_ID ""])
+ match Register.get_last_result () with
+ | None -> (* occurrence not computed *)
+ [`STOCK_ID ""]
+ | Some (result, _) ->
+ let in_globals (kf,ki,_ as access) =
+ (let ak = Register.classify_accesses access in
+ consider_access () ak)
+ &&
+ match ki with
+ | Kglobal -> false
+ | Kstmt _ ->
+ let kf = Option.get kf in
+ let v0 = Kernel_function.get_vi kf in
+ List.exists
+ (fun glob -> match glob with
+ | GFun ({svar =v1},_ ) -> Varinfo.equal v1 v0
+ | _ -> false)
+ globs
+ in
+ if List.exists in_globals result then [`STOCK_ID "gtk-apply"]
+ else [`STOCK_ID ""])
(fun () -> Enabled.get ());
!update_column `Visibility
diff --git a/src/plugins/pdg/annot.ml b/src/plugins/pdg/annot.ml
index e660ddae5513f5ed58430dec0d5cb3ad0f590f9c..2c7f35d5d7ee2c8f325f61846bdf7b5364a07eea 100644
--- a/src/plugins/pdg/annot.ml
+++ b/src/plugins/pdg/annot.ml
@@ -25,7 +25,7 @@ open Cil_datatype
open PdgIndex
type data_info = ((PdgTypes.Node.t * Locations.Zone.t option) list
- * Locations.Zone.t option) option
+ * Locations.Zone.t option) option
type ctrl_info = PdgTypes.Node.t list
@@ -36,30 +36,30 @@ let zone_info_nodes pdg data_info =
let stmt = info.Db.Properties.Interp.To_zone.ki in
let before = info.Db.Properties.Interp.To_zone.before in
let zone = info.Db.Properties.Interp.To_zone.zone in
- Pdg_parameters.debug ~level:2 "[pdg:annotation] need %a %s stmt %d@."
- Locations.Zone.pretty zone
- (if before then "before" else "after") stmt.sid;
- let nodes, undef_loc =
- Sets.find_location_nodes_at_stmt pdg stmt ~before zone
- in
- let undef_acc = match undef_acc, undef_loc with
- | None, _ -> undef_loc
- | _, None -> undef_acc
- | Some z1, Some z2 -> Some (Locations.Zone.join z1 z2)
- in
- (nodes @ nodes_acc, undef_acc)
+ Pdg_parameters.debug ~level:2 "[pdg:annotation] need %a %s stmt %d@."
+ Locations.Zone.pretty zone
+ (if before then "before" else "after") stmt.sid;
+ let nodes, undef_loc =
+ Sets.find_location_nodes_at_stmt pdg stmt ~before zone
+ in
+ let undef_acc = match undef_acc, undef_loc with
+ | None, _ -> undef_loc
+ | _, None -> undef_acc
+ | Some z1, Some z2 -> Some (Locations.Zone.join z1 z2)
+ in
+ (nodes @ nodes_acc, undef_acc)
in match data_info with
- | None -> None (* To_zone.xxx didn't manage to compute the zone *)
- | Some data_info ->
- let data_dpds = ([], None) in
- let data_dpds =
- List.fold_left (add_info_nodes pdg) data_dpds data_info
- in Some data_dpds
+ | None -> None (* To_zone.xxx didn't manage to compute the zone *)
+ | Some data_info ->
+ let data_dpds = ([], None) in
+ let data_dpds =
+ List.fold_left (add_info_nodes pdg) data_dpds data_info
+ in Some data_dpds
let get_decl_nodes pdg decl_info =
let add_decl_nodes decl_var nodes_acc =
let node = Sets.find_decl_var_node pdg decl_var in
- node::nodes_acc
+ node::nodes_acc
in
Varinfo.Set.fold add_decl_nodes decl_info []
@@ -70,36 +70,36 @@ let find_nodes_for_function_contract pdg f_interpret =
let decl_nodes = (* No way to get stmt from labels of at construct into function contracts *)
get_decl_nodes pdg decl_label_info.Db.Properties.Interp.To_zone.var
in
- decl_nodes, data_dpds
+ decl_nodes, data_dpds
let find_fun_precond_nodes (pdg:PdgTypes.Pdg.t) p =
let f_interpret kf =
let f_ctx = !Db.Properties.Interp.To_zone.mk_ctx_func_contrat
- ~state_opt:(Some true) kf in
- !Db.Properties.Interp.To_zone.from_pred p f_ctx
+ ~state_opt:(Some true) kf in
+ !Db.Properties.Interp.To_zone.from_pred p f_ctx
in find_nodes_for_function_contract pdg f_interpret
let find_fun_postcond_nodes pdg p =
let f_interpret kf =
let f_ctx = !Db.Properties.Interp.To_zone.mk_ctx_func_contrat
- ~state_opt:(Some false) kf in
- !Db.Properties.Interp.To_zone.from_pred p f_ctx
+ ~state_opt:(Some false) kf in
+ !Db.Properties.Interp.To_zone.from_pred p f_ctx
in let nodes,deps = find_nodes_for_function_contract pdg f_interpret
in let nodes =
- (* find is \result is used in p, and if it is the case,
- * add the node [Sets.find_output_node pdg]
- * to the returned list of nodes.
+ (* find is \result is used in p, and if it is the case,
+ * add the node [Sets.find_output_node pdg]
+ * to the returned list of nodes.
*)
- if !Db.Properties.Interp.to_result_from_pred p then
- (Sets.find_output_node pdg)::nodes
- else nodes
+ if !Db.Properties.Interp.to_result_from_pred p then
+ (Sets.find_output_node pdg)::nodes
+ else nodes
in nodes,deps
let find_fun_variant_nodes pdg t =
let f_interpret kf =
let f_ctx = !Db.Properties.Interp.To_zone.mk_ctx_func_contrat
- ~state_opt:(Some true) kf in
- !Db.Properties.Interp.To_zone.from_term t f_ctx
+ ~state_opt:(Some true) kf in
+ !Db.Properties.Interp.To_zone.from_term t f_ctx
in find_nodes_for_function_contract pdg f_interpret
let find_code_annot_nodes pdg stmt annot =
@@ -107,66 +107,66 @@ let find_code_annot_nodes pdg stmt annot =
annot.annot_id stmt.sid
Printer.pp_code_annotation annot;
if Db.Value.is_reachable_stmt stmt then
- begin
- let kf = PdgTypes.Pdg.get_kf pdg in
- let (data_info, decl_label_info), pragmas =
- !Db.Properties.Interp.To_zone.from_stmt_annot annot (stmt, kf)
- in
- let data_dpds = zone_info_nodes pdg data_info in
- let decl_nodes = get_decl_nodes pdg decl_label_info.Db.Properties.Interp.To_zone.var in
- let labels = decl_label_info.Db.Properties.Interp.To_zone.lbl in
- let stmt_key = Key.stmt_key stmt in
- let stmt_node = match stmt_key with
- | Key.Stmt _ -> !Db.Pdg.find_stmt_node pdg stmt
- | Key.CallStmt _ -> !Db.Pdg.find_call_ctrl_node pdg stmt
- | _ -> assert false
- in
- let ctrl_dpds = !Db.Pdg.direct_ctrl_dpds pdg stmt_node in
- let add_stmt_nodes s acc =
- try !Db.Pdg.find_stmt_and_blocks_nodes pdg s @ acc
- with Not_found -> acc
- in
- (* can safely ignore pragmas.ctrl
- * because we already have the ctrl dpds from the stmt node. *)
- let stmt_pragmas = pragmas.Db.Properties.Interp.To_zone.stmt in
- let ctrl_dpds = Stmt.Set.fold add_stmt_nodes stmt_pragmas ctrl_dpds in
- let add_label_nodes l acc = match l with
- | StmtLabel stmt ->
- (* TODO: we could be more precise here if we knew which label
- * is really useful... *)
- let add acc l =
- try (Sets.find_label_node pdg !stmt l)::acc
- with Not_found -> acc
- in List.fold_left add acc (!stmt).labels
- | FormalLabel _ | BuiltinLabel _ -> acc
+ begin
+ let kf = PdgTypes.Pdg.get_kf pdg in
+ let (data_info, decl_label_info), pragmas =
+ !Db.Properties.Interp.To_zone.from_stmt_annot annot (stmt, kf)
+ in
+ let data_dpds = zone_info_nodes pdg data_info in
+ let decl_nodes = get_decl_nodes pdg decl_label_info.Db.Properties.Interp.To_zone.var in
+ let labels = decl_label_info.Db.Properties.Interp.To_zone.lbl in
+ let stmt_key = Key.stmt_key stmt in
+ let stmt_node = match stmt_key with
+ | Key.Stmt _ -> !Db.Pdg.find_stmt_node pdg stmt
+ | Key.CallStmt _ -> !Db.Pdg.find_call_ctrl_node pdg stmt
+ | _ -> assert false
+ in
+ let ctrl_dpds = !Db.Pdg.direct_ctrl_dpds pdg stmt_node in
+ let add_stmt_nodes s acc =
+ try !Db.Pdg.find_stmt_and_blocks_nodes pdg s @ acc
+ with Not_found -> acc
+ in
+ (* can safely ignore pragmas.ctrl
+ * because we already have the ctrl dpds from the stmt node. *)
+ let stmt_pragmas = pragmas.Db.Properties.Interp.To_zone.stmt in
+ let ctrl_dpds = Stmt.Set.fold add_stmt_nodes stmt_pragmas ctrl_dpds in
+ let add_label_nodes l acc = match l with
+ | StmtLabel stmt ->
+ (* TODO: we could be more precise here if we knew which label
+ * is really useful... *)
+ let add acc l =
+ try (Sets.find_label_node pdg !stmt l)::acc
+ with Not_found -> acc
+ in List.fold_left add acc (!stmt).labels
+ | FormalLabel _ | BuiltinLabel _ -> acc
+ in
+ let ctrl_dpds = Logic_label.Set.fold add_label_nodes labels ctrl_dpds in
+ if Pdg_parameters.debug_atleast 2 then begin
+ let p fmt (n,z) = match z with
+ | None -> PdgTypes.Node.pretty fmt n
+ | Some z -> Format.fprintf fmt "%a(%a)"
+ PdgTypes.Node.pretty n Locations.Zone.pretty z
in
- let ctrl_dpds = Logic_label.Set.fold add_label_nodes labels ctrl_dpds in
- if Pdg_parameters.debug_atleast 2 then begin
- let p fmt (n,z) = match z with
- | None -> PdgTypes.Node.pretty fmt n
- | Some z -> Format.fprintf fmt "%a(%a)"
- PdgTypes.Node.pretty n Locations.Zone.pretty z
- in
- let pl fmt l = List.iter (fun n -> Format.fprintf fmt " %a" p n) l in
- Pdg_parameters.debug " ctrl nodes = %a"
- PdgTypes.Node.pretty_list ctrl_dpds;
- Pdg_parameters.debug " decl nodes = %a"
- PdgTypes.Node.pretty_list decl_nodes;
- match data_dpds with
- | None ->
- Pdg_parameters.debug " data nodes = None (failed to compute)"
- | Some (data_nodes, data_undef) ->
- begin
- Pdg_parameters.debug " data nodes = %a" pl data_nodes;
- match data_undef with
- | None -> ()
- | Some data_undef ->
- Pdg_parameters.debug " data undef = %a"
- Locations.Zone.pretty data_undef;
- end
- end;
- ctrl_dpds, decl_nodes, data_dpds
- end
+ let pl fmt l = List.iter (fun n -> Format.fprintf fmt " %a" p n) l in
+ Pdg_parameters.debug " ctrl nodes = %a"
+ PdgTypes.Node.pretty_list ctrl_dpds;
+ Pdg_parameters.debug " decl nodes = %a"
+ PdgTypes.Node.pretty_list decl_nodes;
+ match data_dpds with
+ | None ->
+ Pdg_parameters.debug " data nodes = None (failed to compute)"
+ | Some (data_nodes, data_undef) ->
+ begin
+ Pdg_parameters.debug " data nodes = %a" pl data_nodes;
+ match data_undef with
+ | None -> ()
+ | Some data_undef ->
+ Pdg_parameters.debug " data undef = %a"
+ Locations.Zone.pretty data_undef;
+ end
+ end;
+ ctrl_dpds, decl_nodes, data_dpds
+ end
else begin
Pdg_parameters.debug ~level:2
"[pdg:annotation] CodeAnnot-%d : unreachable stmt ! @."
diff --git a/src/plugins/pdg/annot.mli b/src/plugins/pdg/annot.mli
index 2c324e817440a36b3f1d443e7dc5d6dde8ea34c9..cb104929e6606df21539f6cb634effe44a75a631 100644
--- a/src/plugins/pdg/annot.mli
+++ b/src/plugins/pdg/annot.mli
@@ -21,24 +21,24 @@
(**************************************************************************)
(** All these functions find the nodes needed for various kind of annotations.
-*
-* @raise Kernel_function.No_Definition on annotations for function declarations.
-*
-* *)
+ *
+ * @raise Kernel_function.No_Definition on annotations for function declarations.
+ *
+ * *)
(** [data_info] is composed of [(node,z_part) list, undef_loc)]
-* and correspond to data dependencies nodes.
-* Can be None if we don't know how to compute them.
+ * and correspond to data dependencies nodes.
+ * Can be None if we don't know how to compute them.
*)
type data_info =
((PdgTypes.Node.t * Locations.Zone.t option) list
- * Locations.Zone.t option) option
+ * Locations.Zone.t option) option
(** [ctrl_info] correspond to control dependencies nodes *)
type ctrl_info = PdgTypes.Node.t list
(** [decl_info] correspond to the declarations nodes of the variables needed to
-* parse the annotation *)
+ * parse the annotation *)
type decl_info = PdgTypes.Node.t list
(** @raise Not_found when the statement is unreachable. *)
diff --git a/src/plugins/pdg/build.ml b/src/plugins/pdg/build.ml
index 77b36a3e72c447c5aa2f8e8a937ef3f3332ce2b5..0be61e58080f0321e7d2220cfdbe58783ae94e6d 100644
--- a/src/plugins/pdg/build.ml
+++ b/src/plugins/pdg/build.ml
@@ -29,7 +29,7 @@
(see module {{: ../html/Dataflow2.html}Dataflow2}
which is instantiated with the module
{!module: Build.Computer} below).
- *)
+*)
let dkey = Pdg_parameters.register_category "build"
let debug fmt = Pdg_parameters.debug ~dkey fmt
@@ -47,558 +47,558 @@ exception Err_Bot of string
module BoolNodeSet =
Stdlib.Set.Make(Datatype.Pair(Datatype.Bool)(PdgTypes.Node))
-let pretty_node ?(key=false) fmt n =
+let pretty_node ?(key=false) fmt n =
PdgTypes.Node.pretty fmt n;
- if key then
- Format.fprintf fmt ": %a" PdgIndex.Key.pretty (PdgTypes.Node.elem_key n)
+ if key then
+ Format.fprintf fmt ": %a" PdgIndex.Key.pretty (PdgTypes.Node.elem_key n)
let is_variadic kf =
let varf = Kernel_function.get_vi kf in
- match varf.vtype with
- | TFun (_, _, is_variadic, _) -> is_variadic
- | _ -> Pdg_parameters.fatal
- "The variable of a kernel_function has to be a function !"
+ match varf.vtype with
+ | TFun (_, _, is_variadic, _) -> is_variadic
+ | _ -> Pdg_parameters.fatal
+ "The variable of a kernel_function has to be a function !"
(* -------------------------------------------------------------------------- *)
(* --- Auxiliary functions --- *)
(* -------------------------------------------------------------------------- *)
- type arg_nodes = Node.t list
-
- (** type of the whole PDG representation during its building process *)
- type pdg_build = {
- fct : kernel_function;
- mutable topinput : PdgTypes.Node.t option;
- mutable other_inputs :
- (PdgTypes.Node.t * Dpd.td * Locations.Zone.t) list;
- graph : G.t;
- states : Pdg_state.states;
- index : PdgTypes.Pdg.fi;
- ctrl_dpds : BoolNodeSet.t Stmt.Hashtbl.t ;
- (** The nodes to which each stmt control-depend on.
- * The links will be added in the graph at the end. *)
- decl_nodes : Node.t Varinfo.Hashtbl.t ;
- (** map between declaration nodes and the variables
- to build the dependencies. *)
- }
-
- (** create an empty build pdg for the function*)
- let create_pdg_build kf =
- let nb_stmts =
- if !Db.Value.use_spec_instead_of_definition kf then 17
- else List.length (Kernel_function.get_definition kf).sallstmts
- in
- let index = FctIndex.create nb_stmts in
- let states = Stmt.Hashtbl.create nb_stmts in
- let graph = G.create () in
- { fct = kf; graph = graph; states = states; index = index;
- topinput = None; other_inputs = [];
- ctrl_dpds = Stmt.Hashtbl.create nb_stmts ;
- decl_nodes = Varinfo.Hashtbl.create 10 ;
- }
-
- let _pretty fmt pdg = PdgTypes.Pdg.pretty_graph fmt pdg.graph
-
- (** add a node to the PDG, but if it is associated with a stmt,
- check before if it doesn't exist already (useful for loops).
- @return the (new or old) node. *)
- let add_elem pdg key =
- match key with
- | Key.CallStmt _ -> assert false
- | _ ->
- try
- FctIndex.find_info pdg.index key
- with Not_found ->
- let new_node = G.add_elem pdg.graph key in
- debug "add_new_node %a@." (pretty_node ~key:true) new_node;
- FctIndex.add pdg.index key new_node;
- new_node
-
- let decl_var pdg var =
- let new_node = add_elem pdg (Key.decl_var_key var) in
- Varinfo.Hashtbl.add pdg.decl_nodes var new_node;
+type arg_nodes = Node.t list
+
+(** type of the whole PDG representation during its building process *)
+type pdg_build = {
+ fct : kernel_function;
+ mutable topinput : PdgTypes.Node.t option;
+ mutable other_inputs :
+ (PdgTypes.Node.t * Dpd.td * Locations.Zone.t) list;
+ graph : G.t;
+ states : Pdg_state.states;
+ index : PdgTypes.Pdg.fi;
+ ctrl_dpds : BoolNodeSet.t Stmt.Hashtbl.t ;
+ (** The nodes to which each stmt control-depend on.
+ * The links will be added in the graph at the end. *)
+ decl_nodes : Node.t Varinfo.Hashtbl.t ;
+ (** map between declaration nodes and the variables
+ to build the dependencies. *)
+}
+
+(** create an empty build pdg for the function*)
+let create_pdg_build kf =
+ let nb_stmts =
+ if !Db.Value.use_spec_instead_of_definition kf then 17
+ else List.length (Kernel_function.get_definition kf).sallstmts
+ in
+ let index = FctIndex.create nb_stmts in
+ let states = Stmt.Hashtbl.create nb_stmts in
+ let graph = G.create () in
+ { fct = kf; graph = graph; states = states; index = index;
+ topinput = None; other_inputs = [];
+ ctrl_dpds = Stmt.Hashtbl.create nb_stmts ;
+ decl_nodes = Varinfo.Hashtbl.create 10 ;
+ }
+
+let _pretty fmt pdg = PdgTypes.Pdg.pretty_graph fmt pdg.graph
+
+(** add a node to the PDG, but if it is associated with a stmt,
+ check before if it doesn't exist already (useful for loops).
+ @return the (new or old) node. *)
+let add_elem pdg key =
+ match key with
+ | Key.CallStmt _ -> assert false
+ | _ ->
+ try
+ FctIndex.find_info pdg.index key
+ with Not_found ->
+ let new_node = G.add_elem pdg.graph key in
+ debug "add_new_node %a@." (pretty_node ~key:true) new_node;
+ FctIndex.add pdg.index key new_node;
new_node
- let get_var_base zone =
+let decl_var pdg var =
+ let new_node = add_elem pdg (Key.decl_var_key var) in
+ Varinfo.Hashtbl.add pdg.decl_nodes var new_node;
+ new_node
+
+let get_var_base zone =
+ try
+ let base, _ = Locations.Zone.find_lonely_key zone in
+ match base with
+ | Base.Var (var,_) -> Some var
+ | _ -> None
+ with Not_found -> None
+
+(** add a dependency with the given label between the two nodes.
+ Pre : the nodes have to be already in pdg. *)
+let add_dpd_in_g graph v1 dpd_kind part_opt v2 =
+ debug "add_dpd : %a -%a-> %a@."
+ PdgTypes.Node.pretty v1 Dpd.pretty_td dpd_kind
+ PdgTypes.Node.pretty v2;
+ G.add_dpd graph v1 dpd_kind part_opt v2
+
+let add_z_dpd pdg n1 k z_part n2 =
+ add_dpd_in_g pdg.graph n1 k z_part n2
+
+let add_ctrl_dpd pdg n1 n2 =
+ add_dpd_in_g pdg.graph n1 Dpd.Ctrl None n2
+
+let add_decl_dpd pdg n1 k n2 =
+ add_dpd_in_g pdg.graph n1 k None n2
+
+(** add a dependency on the variable declaration.
+ The kind of the dependency is address if the variable appears
+ in a lvalue, data otherwise.
+*)
+let add_decl_dpds pdg node dpd_kind varset =
+ let add_dpd var =
try
- let base, _ = Locations.Zone.find_lonely_key zone in
- match base with
- | Base.Var (var,_) -> Some var
- | _ -> None
- with Not_found -> None
-
- (** add a dependency with the given label between the two nodes.
- Pre : the nodes have to be already in pdg. *)
- let add_dpd_in_g graph v1 dpd_kind part_opt v2 =
- debug "add_dpd : %a -%a-> %a@."
- PdgTypes.Node.pretty v1 Dpd.pretty_td dpd_kind
- PdgTypes.Node.pretty v2;
- G.add_dpd graph v1 dpd_kind part_opt v2
-
- let add_z_dpd pdg n1 k z_part n2 =
- add_dpd_in_g pdg.graph n1 k z_part n2
-
- let add_ctrl_dpd pdg n1 n2 =
- add_dpd_in_g pdg.graph n1 Dpd.Ctrl None n2
-
- let add_decl_dpd pdg n1 k n2 =
- add_dpd_in_g pdg.graph n1 k None n2
-
- (** add a dependency on the variable declaration.
- The kind of the dependency is address if the variable appears
- in a lvalue, data otherwise.
- *)
- let add_decl_dpds pdg node dpd_kind varset =
- let add_dpd var =
- try
- let var_decl_node = Varinfo.Hashtbl.find pdg.decl_nodes var in
- add_decl_dpd pdg node dpd_kind var_decl_node
- with Not_found ->
- ()
- in
- Varinfo.Set.iter add_dpd varset
+ let var_decl_node = Varinfo.Hashtbl.find pdg.decl_nodes var in
+ add_decl_dpd pdg node dpd_kind var_decl_node
+ with Not_found ->
+ ()
+ in
+ Varinfo.Set.iter add_dpd varset
- (** [add_dpds pdg v dpd_kind state loc]
- * add 'dpd_kind' dependencies from node n to each element
- * which are stored for loc in state
- *)
- let add_dpds pdg n dpd_kind state loc =
- let add (node,z_part) =
- (* we only use [z_part] for dependencies to OutCall.
- * Would it be interesting to have it on other cases ? *)
- let z_part = match PdgTypes.Node.elem_key node with
- | PdgIndex.Key.SigCallKey
- (_, PdgIndex.Signature.Out (PdgIndex.Signature.OutLoc _)) ->
- z_part
- | _ -> None
- in add_z_dpd pdg n dpd_kind z_part node in
- let nodes, undef_zone = Pdg_state.get_loc_nodes state loc in
- List.iter add nodes;
- match undef_zone with
- | None -> ()
- | Some undef_zone ->
- pdg.other_inputs <- (n, dpd_kind, undef_zone) :: pdg.other_inputs
-
- (** Process and clear [pdg.ctrl_dpds] which contains a mapping between the
- * statements and the control dependencies that have to be added to the
- * statement nodes.
- * Because some jump nodes can vanish due to optimisations using the value
- * analysis, we can not rely on the transitivity of the dependencies.
- * So let's compute a transitive closure of the control dependencies.
- * The table gives : stmt -> ctrl dependency nodes of the statement.
- * So for each stmt, we have to find if some of its ctrl nodes
- * also have dependencies that have to be added to the stmt.
- * *)
- let add_ctrl_dpds pdg =
- let add_indirect ctrl_node_set =
- (* Also add the ctrl_node dependencies to the set.
- * TODOopt: probably a better way to do that if it happens to work ! *)
- let rec add_node (real, n) (acc, seen) =
- if BoolNodeSet.mem (real, n) seen then (acc, seen)
- else
- let seen = BoolNodeSet.add (real, n) seen in
- let acc = if real then BoolNodeSet.add (true, n) acc else acc in
- add_rec n (acc, seen)
- and add_rec ctrl_node acc =
- match PdgTypes.Node.elem_key ctrl_node with
- | Key.Stmt ctrl_stmt ->
- (try
- let stmt_dpds = Stmt.Hashtbl.find pdg.ctrl_dpds ctrl_stmt in
- BoolNodeSet.fold add_node stmt_dpds acc
- with Not_found -> acc)
- | _ -> (* strange control dependency ! Ignore. *) acc
- in
- let acc = BoolNodeSet.empty, BoolNodeSet.empty in
- let acc, _ = BoolNodeSet.fold add_node ctrl_node_set acc in
- acc
+(** [add_dpds pdg v dpd_kind state loc]
+ * add 'dpd_kind' dependencies from node n to each element
+ * which are stored for loc in state
+*)
+let add_dpds pdg n dpd_kind state loc =
+ let add (node,z_part) =
+ (* we only use [z_part] for dependencies to OutCall.
+ * Would it be interesting to have it on other cases ? *)
+ let z_part = match PdgTypes.Node.elem_key node with
+ | PdgIndex.Key.SigCallKey
+ (_, PdgIndex.Signature.Out (PdgIndex.Signature.OutLoc _)) ->
+ z_part
+ | _ -> None
+ in add_z_dpd pdg n dpd_kind z_part node in
+ let nodes, undef_zone = Pdg_state.get_loc_nodes state loc in
+ List.iter add nodes;
+ match undef_zone with
+ | None -> ()
+ | Some undef_zone ->
+ pdg.other_inputs <- (n, dpd_kind, undef_zone) :: pdg.other_inputs
+
+(** Process and clear [pdg.ctrl_dpds] which contains a mapping between the
+ * statements and the control dependencies that have to be added to the
+ * statement nodes.
+ * Because some jump nodes can vanish due to optimisations using the value
+ * analysis, we can not rely on the transitivity of the dependencies.
+ * So let's compute a transitive closure of the control dependencies.
+ * The table gives : stmt -> ctrl dependency nodes of the statement.
+ * So for each stmt, we have to find if some of its ctrl nodes
+ * also have dependencies that have to be added to the stmt.
+ * *)
+let add_ctrl_dpds pdg =
+ let add_indirect ctrl_node_set =
+ (* Also add the ctrl_node dependencies to the set.
+ * TODOopt: probably a better way to do that if it happens to work ! *)
+ let rec add_node (real, n) (acc, seen) =
+ if BoolNodeSet.mem (real, n) seen then (acc, seen)
+ else
+ let seen = BoolNodeSet.add (real, n) seen in
+ let acc = if real then BoolNodeSet.add (true, n) acc else acc in
+ add_rec n (acc, seen)
+ and add_rec ctrl_node acc =
+ match PdgTypes.Node.elem_key ctrl_node with
+ | Key.Stmt ctrl_stmt ->
+ (try
+ let stmt_dpds = Stmt.Hashtbl.find pdg.ctrl_dpds ctrl_stmt in
+ BoolNodeSet.fold add_node stmt_dpds acc
+ with Not_found -> acc)
+ | _ -> (* strange control dependency ! Ignore. *) acc
in
- let add_stmt_ctrl_dpd stmt ctrl_node_set =
- let stmt_nodes =
- try FctIndex.find_all pdg.index (Key.stmt_key stmt)
- with Not_found -> []
- (* some stmts have no node if they are dead code for instance*)
- in
- let label_nodes acc label =
- try acc @ FctIndex.find_all pdg.index (Key.label_key stmt label)
- with Not_found -> acc
- in
- let stmt_nodes = List.fold_left label_nodes stmt_nodes stmt.labels in
- let ctrl_node_set = add_indirect ctrl_node_set in
- let add_node_ctrl_dpds stmt_node =
- BoolNodeSet.iter
- (fun (_, n) -> add_ctrl_dpd pdg stmt_node n) ctrl_node_set
- in List.iter add_node_ctrl_dpds stmt_nodes
+ let acc = BoolNodeSet.empty, BoolNodeSet.empty in
+ let acc, _ = BoolNodeSet.fold add_node ctrl_node_set acc in
+ acc
+ in
+ let add_stmt_ctrl_dpd stmt ctrl_node_set =
+ let stmt_nodes =
+ try FctIndex.find_all pdg.index (Key.stmt_key stmt)
+ with Not_found -> []
+ (* some stmts have no node if they are dead code for instance*)
in
- Stmt.Hashtbl.iter add_stmt_ctrl_dpd pdg.ctrl_dpds;
- Stmt.Hashtbl.clear pdg.ctrl_dpds
-
-
- let process_declarations pdg ~formals ~locals =
- (** 2 new nodes for each formal parameters :
- one for its declaration, and one for its values.
- This is because it might be the case that we only need the declaration
- whatever the value is.
- Might allow us to do a better slicing of the callers.
- TODO: normally, the value should depend on the the declaration,
- but because we don't know how to select a declaration
- without selecting the value at the moment,
- we do the dependence the other way round.
- *)
- let do_param (n, state) v =
- let decl_node = decl_var pdg v in
- let new_node = add_elem pdg (Key.param_key n) in
- add_decl_dpd pdg new_node Dpd.Addr decl_node ;
- add_decl_dpd pdg decl_node Dpd.Addr new_node ;
- let z = Locations.zone_of_varinfo v in
- let new_state = Pdg_state.add_loc_node state ~exact:true z new_node in
- (n+1, new_state)
+ let label_nodes acc label =
+ try acc @ FctIndex.find_all pdg.index (Key.label_key stmt label)
+ with Not_found -> acc
in
- let _next_in_num, new_state =
- List.fold_left do_param (1, Pdg_state.empty) formals in
- List.iter (fun v -> ignore (decl_var pdg v)) locals;
- new_state
-
- let ctrl_call_node pdg call_stmt =
- try FctIndex.find_info pdg.index (Key.call_ctrl_key call_stmt)
- with Not_found -> assert false
-
- let process_call_args pdg d_state stmt args_dpds : arg_nodes =
- let num = ref 1 in
- let process_arg (dpds, decl_dpds) =
- let new_node = add_elem pdg (Key.call_input_key stmt !num) in
- add_dpds pdg new_node Dpd.Data d_state dpds;
- add_decl_dpds pdg new_node Dpd.Data decl_dpds;
- incr num; new_node
- in List.map process_arg args_dpds
-
- (** Add a PDG node for each formal argument,
- * and add its dependencies to the corresponding argument node.
+ let stmt_nodes = List.fold_left label_nodes stmt_nodes stmt.labels in
+ let ctrl_node_set = add_indirect ctrl_node_set in
+ let add_node_ctrl_dpds stmt_node =
+ BoolNodeSet.iter
+ (fun (_, n) -> add_ctrl_dpd pdg stmt_node n) ctrl_node_set
+ in List.iter add_node_ctrl_dpds stmt_nodes
+ in
+ Stmt.Hashtbl.iter add_stmt_ctrl_dpd pdg.ctrl_dpds;
+ Stmt.Hashtbl.clear pdg.ctrl_dpds
+
+
+let process_declarations pdg ~formals ~locals =
+ (** 2 new nodes for each formal parameters :
+ one for its declaration, and one for its values.
+ This is because it might be the case that we only need the declaration
+ whatever the value is.
+ Might allow us to do a better slicing of the callers.
+ TODO: normally, the value should depend on the the declaration,
+ but because we don't know how to select a declaration
+ without selecting the value at the moment,
+ we do the dependence the other way round.
*)
- let process_call_params pdg d_state stmt called_kf (arg_nodes:arg_nodes) =
- let ctrl_node = ctrl_call_node pdg stmt in
- let param_list = Kernel_function.get_formals called_kf in
- let process_param state param arg =
- let new_node = arg in
- add_ctrl_dpd pdg new_node ctrl_node;
- let z = Locations.zone_of_varinfo param in
- Pdg_state.add_loc_node state z new_node ~exact:true
- in
- let rec do_param_arg state param_list (arg_nodes: arg_nodes) =
- match param_list, arg_nodes with
- | [], [] -> state
- | p :: param_list, a :: arg_nodes ->
- let state = process_param state p a in
- do_param_arg state param_list arg_nodes
- | [], _ -> (* call to a variadic function *)
- (* warning already sent during 'from' computation. *)
- state
- | _, [] -> Pdg_parameters.fatal
- "call to a function with to few arguments"
- in do_param_arg d_state param_list arg_nodes
-
- let create_call_output_node pdg state stmt out_key out_from fct_dpds =
- let new_node = add_elem pdg out_key in
- add_dpds pdg new_node Dpd.Data state out_from;
- add_dpds pdg new_node Dpd.Ctrl state fct_dpds;
- let ctrl_node = ctrl_call_node pdg stmt in
+ let do_param (n, state) v =
+ let decl_node = decl_var pdg v in
+ let new_node = add_elem pdg (Key.param_key n) in
+ add_decl_dpd pdg new_node Dpd.Addr decl_node ;
+ add_decl_dpd pdg decl_node Dpd.Addr new_node ;
+ let z = Locations.zone_of_varinfo v in
+ let new_state = Pdg_state.add_loc_node state ~exact:true z new_node in
+ (n+1, new_state)
+ in
+ let _next_in_num, new_state =
+ List.fold_left do_param (1, Pdg_state.empty) formals in
+ List.iter (fun v -> ignore (decl_var pdg v)) locals;
+ new_state
+
+let ctrl_call_node pdg call_stmt =
+ try FctIndex.find_info pdg.index (Key.call_ctrl_key call_stmt)
+ with Not_found -> assert false
+
+let process_call_args pdg d_state stmt args_dpds : arg_nodes =
+ let num = ref 1 in
+ let process_arg (dpds, decl_dpds) =
+ let new_node = add_elem pdg (Key.call_input_key stmt !num) in
+ add_dpds pdg new_node Dpd.Data d_state dpds;
+ add_decl_dpds pdg new_node Dpd.Data decl_dpds;
+ incr num; new_node
+ in List.map process_arg args_dpds
+
+(** Add a PDG node for each formal argument,
+ * and add its dependencies to the corresponding argument node.
+*)
+let process_call_params pdg d_state stmt called_kf (arg_nodes:arg_nodes) =
+ let ctrl_node = ctrl_call_node pdg stmt in
+ let param_list = Kernel_function.get_formals called_kf in
+ let process_param state param arg =
+ let new_node = arg in
add_ctrl_dpd pdg new_node ctrl_node;
- new_node
-
- (** creates a node for lval : caller has to add dpds about the right part *)
- let create_lval_node pdg state key ~l_loc ~exact ~l_dpds ~l_decl =
- let new_node = add_elem pdg key in
- add_dpds pdg new_node Dpd.Addr state l_dpds;
- add_decl_dpds pdg new_node Dpd.Addr l_decl;
- let new_state = Pdg_state.add_loc_node state exact l_loc new_node in
- (new_node, new_state)
-
- let add_from pdg state_before state lval (default, deps) =
- let new_node = add_elem pdg (Key.out_from_key lval) in
- let exact = (not default) in
- let state = Pdg_state.add_loc_node state exact lval new_node in
- add_dpds pdg new_node Dpd.Data state_before deps;
+ let z = Locations.zone_of_varinfo param in
+ Pdg_state.add_loc_node state z new_node ~exact:true
+ in
+ let rec do_param_arg state param_list (arg_nodes: arg_nodes) =
+ match param_list, arg_nodes with
+ | [], [] -> state
+ | p :: param_list, a :: arg_nodes ->
+ let state = process_param state p a in
+ do_param_arg state param_list arg_nodes
+ | [], _ -> (* call to a variadic function *)
+ (* warning already sent during 'from' computation. *)
state
+ | _, [] -> Pdg_parameters.fatal
+ "call to a function with to few arguments"
+ in do_param_arg d_state param_list arg_nodes
+
+let create_call_output_node pdg state stmt out_key out_from fct_dpds =
+ let new_node = add_elem pdg out_key in
+ add_dpds pdg new_node Dpd.Data state out_from;
+ add_dpds pdg new_node Dpd.Ctrl state fct_dpds;
+ let ctrl_node = ctrl_call_node pdg stmt in
+ add_ctrl_dpd pdg new_node ctrl_node;
+ new_node
+
+(** creates a node for lval : caller has to add dpds about the right part *)
+let create_lval_node pdg state key ~l_loc ~exact ~l_dpds ~l_decl =
+ let new_node = add_elem pdg key in
+ add_dpds pdg new_node Dpd.Addr state l_dpds;
+ add_decl_dpds pdg new_node Dpd.Addr l_decl;
+ let new_state = Pdg_state.add_loc_node state exact l_loc new_node in
+ (new_node, new_state)
+
+let add_from pdg state_before state lval (default, deps) =
+ let new_node = add_elem pdg (Key.out_from_key lval) in
+ let exact = (not default) in
+ let state = Pdg_state.add_loc_node state exact lval new_node in
+ add_dpds pdg new_node Dpd.Data state_before deps;
+ state
+
+let process_call_output pdg state_before_call state stmt out default from_out fct_dpds =
+ let exact = (not default) in
+ debug "call-%d Out : %a From %a (%sexact)@."
+ stmt.sid
+ Locations.Zone.pretty out Locations.Zone.pretty from_out
+ (if exact then "" else "not ");
+ let key = Key.call_output_key stmt out in
+ let new_node = create_call_output_node pdg state_before_call stmt
+ key from_out fct_dpds in
+ let state = Pdg_state.add_loc_node state exact out new_node
+ in state
+
+(** mix between process_call_output and process_asgn *)
+let process_call_return pdg state_before_call state_with_inputs stmt
+ ~l_loc ~exact ~l_dpds ~l_decl ~r_dpds fct_dpds =
+ let out_key = Key.call_outret_key stmt in
+ let new_node =
+ create_call_output_node pdg state_with_inputs stmt out_key r_dpds fct_dpds
+ in
+ add_dpds pdg new_node Dpd.Addr state_before_call l_dpds;
+ add_decl_dpds pdg new_node Dpd.Addr l_decl;
+ let new_state =
+ Pdg_state.add_loc_node state_before_call exact l_loc new_node in
+ new_state
- let process_call_output pdg state_before_call state stmt out default from_out fct_dpds =
- let exact = (not default) in
- debug "call-%d Out : %a From %a (%sexact)@."
- stmt.sid
- Locations.Zone.pretty out Locations.Zone.pretty from_out
- (if exact then "" else "not ");
- let key = Key.call_output_key stmt out in
- let new_node = create_call_output_node pdg state_before_call stmt
- key from_out fct_dpds in
- let state = Pdg_state.add_loc_node state exact out new_node
- in state
-
- (** mix between process_call_output and process_asgn *)
- let process_call_return pdg state_before_call state_with_inputs stmt
- ~l_loc ~exact ~l_dpds ~l_decl ~r_dpds fct_dpds =
- let out_key = Key.call_outret_key stmt in
- let new_node =
- create_call_output_node pdg state_with_inputs stmt out_key r_dpds fct_dpds
- in
- add_dpds pdg new_node Dpd.Addr state_before_call l_dpds;
- add_decl_dpds pdg new_node Dpd.Addr l_decl;
- let new_state =
- Pdg_state.add_loc_node state_before_call exact l_loc new_node in
- new_state
-
- (** for skip statement : we want to add a node in the PDG in order to be able
- * to store information (like marks) about this statement later on *)
- let process_skip pdg state stmt =
- ignore (add_elem pdg (Key.stmt_key stmt)); state
-
- (** for asm: similar to [process_skip], except that we emit a warning *)
- let process_asm pdg state stmt =
- Pdg_parameters.warning ~once:true ~current:true
- "Ignoring inline assembly code";
- ignore (add_elem pdg (Key.stmt_key stmt));
- state
-
-
- let add_label pdg label label_stmt =
- let key = Key.label_key label_stmt label in
- try FctIndex.find_info pdg.index key
- with Not_found -> add_elem pdg key
-
- let process_stmt_labels pdg stmt =
- let add label = match label with
- | Label _ -> ignore (add_label pdg label stmt)
- | _ -> (* see [add_dpd_switch_cases] *) ()
- in List.iter add stmt.labels
-
- let add_label_and_dpd pdg label label_stmt jump_node =
- let label_node = add_label pdg label label_stmt in
- add_ctrl_dpd pdg jump_node label_node
-
- let add_dpd_goto_label pdg goto_node dest_goto =
+(** for skip statement : we want to add a node in the PDG in order to be able
+ * to store information (like marks) about this statement later on *)
+let process_skip pdg state stmt =
+ ignore (add_elem pdg (Key.stmt_key stmt)); state
+
+(** for asm: similar to [process_skip], except that we emit a warning *)
+let process_asm pdg state stmt =
+ Pdg_parameters.warning ~once:true ~current:true
+ "Ignoring inline assembly code";
+ ignore (add_elem pdg (Key.stmt_key stmt));
+ state
+
+
+let add_label pdg label label_stmt =
+ let key = Key.label_key label_stmt label in
+ try FctIndex.find_info pdg.index key
+ with Not_found -> add_elem pdg key
+
+let process_stmt_labels pdg stmt =
+ let add label = match label with
+ | Label _ -> ignore (add_label pdg label stmt)
+ | _ -> (* see [add_dpd_switch_cases] *) ()
+ in List.iter add stmt.labels
+
+let add_label_and_dpd pdg label label_stmt jump_node =
+ let label_node = add_label pdg label label_stmt in
+ add_ctrl_dpd pdg jump_node label_node
+
+let add_dpd_goto_label pdg goto_node dest_goto =
+ let rec pickLabel = function
+ | [] -> None
+ | Label _ as lab :: _ -> Some lab
+ | _ :: rest -> pickLabel rest
+ in
+ let label = match pickLabel dest_goto.labels with
+ | Some label -> label
+ | None ->
+ (* break and continue might not jump to a stmt with label : create one*)
+ let lname = Printf.sprintf "fc_stmt_%d" dest_goto.sid in
+ let label = Label (lname, Cil_datatype.Stmt.loc dest_goto, false) in
+ dest_goto.labels <- label::dest_goto.labels;
+ label
+ in add_label_and_dpd pdg label dest_goto goto_node
+
+let add_dpd_switch_cases pdg switch_node case_stmts =
+ let add_case stmt =
let rec pickLabel = function
| [] -> None
- | Label _ as lab :: _ -> Some lab
+ | Case _ as lab :: _ -> Some lab
+ | Default _ as lab :: _ -> Some lab
| _ :: rest -> pickLabel rest
in
- let label = match pickLabel dest_goto.labels with
- | Some label -> label
- | None ->
- (* break and continue might not jump to a stmt with label : create one*)
- let lname = Printf.sprintf "fc_stmt_%d" dest_goto.sid in
- let label = Label (lname, Cil_datatype.Stmt.loc dest_goto, false) in
- dest_goto.labels <- label::dest_goto.labels;
- label
- in add_label_and_dpd pdg label dest_goto goto_node
-
- let add_dpd_switch_cases pdg switch_node case_stmts =
- let add_case stmt =
- let rec pickLabel = function
- | [] -> None
- | Case _ as lab :: _ -> Some lab
- | Default _ as lab :: _ -> Some lab
- | _ :: rest -> pickLabel rest
- in
- match pickLabel stmt.labels with
- | Some label -> add_label_and_dpd pdg label stmt switch_node
- | None -> assert false (* switch sans case ou default ??? *)
- in List.iter add_case case_stmts
-
- (** The control dependencies are stored : they will be added at the end
- by [finalize_pdg] *)
- let store_ctrl_dpds pdg node iterator (real_dpd, controlled_stmt) =
- debug2 "store_ctrl_dpds on %a (real = %b)@."
- (pretty_node ~key:true) node real_dpd ;
- let add_ctrl_dpd stmt =
- let new_dpds =
- try
- let old_dpds = Stmt.Hashtbl.find pdg.ctrl_dpds stmt in
- BoolNodeSet.add (real_dpd, node) old_dpds
- with Not_found -> BoolNodeSet.singleton (real_dpd, node)
- in
- Stmt.Hashtbl.replace pdg.ctrl_dpds stmt new_dpds
- in iterator add_ctrl_dpd controlled_stmt
-
- let mk_jump_node pdg stmt controlled_stmts =
- let new_node = add_elem pdg (Key.stmt_key stmt) in
- begin match stmt.skind with
- | If _ | Loop _ | Return _ -> ()
- | Break _ | Continue _ ->
- (* can use : add_dpd_goto_label pdg new_node s
- * if we want later to change break and continue to goto...
- *) ()
- | Goto (sref,_) -> add_dpd_goto_label pdg new_node !sref
- | Switch (_,_,stmts,_) -> add_dpd_switch_cases pdg new_node stmts
- | _ -> assert false
- end;
- store_ctrl_dpds pdg new_node Stmt.Hptset.iter controlled_stmts;
- new_node
-
-
- (** Add a node for a stmt that is a jump.
- Add control dependencies from this node to the nodes which correspond to
- the stmt list.
- Also add dependencies for the jump to the label.
- Don't use for jumps with data dependencies : use [process_jump_with_exp]
- instead !
- *)
- let process_jump pdg stmt controlled_stmts =
- ignore (mk_jump_node pdg stmt controlled_stmts)
-
- (** like [process_jump] but also add data dependencies on the data and their
- declarations. Use for conditional jumps and returns.
- *)
- let process_jump_with_exp pdg stmt controlled_stmts state loc_cond decls_cond =
- let jump_node = mk_jump_node pdg stmt controlled_stmts in
- add_dpds pdg jump_node Dpd.Data state loc_cond;
- add_decl_dpds pdg jump_node Dpd.Data decls_cond
-
- let add_blk_ctrl_dpds pdg key bstmts =
- let new_node = add_elem pdg key in
- store_ctrl_dpds pdg new_node List.iter (true, bstmts)
-
- let process_block pdg stmt blk =
- add_blk_ctrl_dpds pdg (Key.stmt_key stmt) blk.bstmts
-
- let process_entry_point pdg bstmts =
- add_blk_ctrl_dpds pdg Key.entry_point bstmts
-
- let create_fun_output_node pdg state dpds =
- let new_node = add_elem pdg Key.output_key in
- match state with
- | Some state -> add_dpds pdg new_node Dpd.Data state dpds
- | None -> (* return is unreachable *) ()
-
- (** add a node corresponding to the returned value. *)
- let add_retres pdg state ret_stmt retres_loc_dpds retres_decls =
- let key_return = Key.stmt_key ret_stmt in
- let return_node = add_elem pdg key_return in
- let retres_loc = Db.Value.find_return_loc pdg.fct in
- let retres = Locations.(enumerate_valid_bits Read retres_loc) in
- add_dpds pdg return_node Dpd.Data state retres_loc_dpds;
- add_decl_dpds pdg return_node Dpd.Data retres_decls;
- let new_state = Pdg_state.add_loc_node state true retres return_node in
- create_fun_output_node pdg (Some new_state) retres;
- new_state
-
- (** part of [finalize_pdg] : add missing inputs
- * and build a state with the new nodes to find them back when searching for
- * undefined zones.
- * (notice that now, they can overlap, for example we can have G and G.a)
- * And also deals with warning for uninitialized local variables. *)
- let process_other_inputs pdg =
- debug2 "process_other_inputs@.";
- let rec add n dpd_kind (state, zones) z_or_top =
- (* be careful because [z] can intersect several elements in [zones] *)
- match zones with
- | [] ->
- let key = Key.implicit_in_key z_or_top in
- let nz = add_elem pdg key in
- debug "add_implicit_input : %a@."
- Locations.Zone.pretty z_or_top ;
- let state = Pdg_state.add_init_state_input state z_or_top nz in
- add_z_dpd pdg n dpd_kind None nz;
- state, [(z_or_top, nz)]
- | (zone, nz)::tl_zones ->
- match z_or_top, zone with
- | (Locations.Zone.Top (_,_), Locations.Zone.Top (_,_)) ->
- add_z_dpd pdg n dpd_kind None nz;
- (state, zones)
- | (z, _) when (Locations.Zone.equal zone z) ->
- add_z_dpd pdg n dpd_kind None nz;
- (* don't add z : already in *)
- (state, zones)
- | _ -> (* rec : look for z in tail *)
- let state, tl_zones =
- add n dpd_kind (state, tl_zones) z_or_top in
- state, (zone, nz)::tl_zones
- in
- let add_zone acc (n, dpd_kind, z) =
- let do_add = match get_var_base z with
- | Some v -> if Kernel_function.is_local v pdg.fct then false else true
- | None -> true
- in if do_add then
- let acc = match z with
- | Locations.Zone.Top (_,_) -> add n dpd_kind acc z
- | _ ->
- let aux b intervs acc =
- let z = Locations.Zone.inject b intervs in
- add n dpd_kind acc z
- in
- Locations.Zone.fold_i aux z acc
- in acc
- else begin
- debug2 "might use uninitialized : %a" Locations.Zone.pretty z;
- acc
- end
- in
- let (state, _) =
- List.fold_left add_zone (Pdg_state.empty, []) pdg.other_inputs
- in state
-
- (** to call then the building process is over :
- add the control dependencies in the graph.
- @return the real PDG that will be used later on.
- @param from_opt for undefined functions (declarations) *)
- let finalize_pdg pdg from_opt =
- debug2 "try to finalize_pdg";
- let last_state =
- try Some (Pdg_state.get_last_state pdg.states)
- with Not_found ->
- let ret =
- try Kernel_function.find_return pdg.fct
- with Kernel_function.No_Statement ->
- Pdg_parameters.abort "No return in a declaration"
- in
- Pdg_parameters.warning ~once:true ~source:(fst (Stmt.loc ret))
- "no final state. Probably unreachable...";
- None
+ match pickLabel stmt.labels with
+ | Some label -> add_label_and_dpd pdg label stmt switch_node
+ | None -> assert false (* switch sans case ou default ??? *)
+ in List.iter add_case case_stmts
+
+(** The control dependencies are stored : they will be added at the end
+ by [finalize_pdg] *)
+let store_ctrl_dpds pdg node iterator (real_dpd, controlled_stmt) =
+ debug2 "store_ctrl_dpds on %a (real = %b)@."
+ (pretty_node ~key:true) node real_dpd ;
+ let add_ctrl_dpd stmt =
+ let new_dpds =
+ try
+ let old_dpds = Stmt.Hashtbl.find pdg.ctrl_dpds stmt in
+ BoolNodeSet.add (real_dpd, node) old_dpds
+ with Not_found -> BoolNodeSet.singleton (real_dpd, node)
in
- (match from_opt with
- | None -> () (* defined function : retres already processed. *)
- | Some froms -> (* undefined function : add output 0 *)
- (* TODO : also add the nodes for the other from ! *)
- let state = match last_state with Some s -> s | None -> assert false in
- let process_out out deps s =
- let open Function_Froms.DepsOrUnassigned in
- if (equal Unassigned deps)
- then s
- else
- let from_out = to_zone deps in
- let default = may_be_unassigned deps in
- add_from pdg state s out (default, from_out)
- in
- let from_table = froms.Function_Froms.deps_table in
- let new_state =
- if Function_Froms.Memory.is_bottom from_table then
- Pdg_state.bottom
- else
- let new_state =
- match from_table with
- | Function_Froms.Memory.Top ->
- process_out
- Locations.Zone.top Function_Froms.DepsOrUnassigned.top state
- | Function_Froms.Memory.Map m ->
- Function_Froms.Memory.fold_fuse_same process_out m state
- | Function_Froms.Memory.Bottom -> assert false (* checked above *)
+ Stmt.Hashtbl.replace pdg.ctrl_dpds stmt new_dpds
+ in iterator add_ctrl_dpd controlled_stmt
+
+let mk_jump_node pdg stmt controlled_stmts =
+ let new_node = add_elem pdg (Key.stmt_key stmt) in
+ begin match stmt.skind with
+ | If _ | Loop _ | Return _ -> ()
+ | Break _ | Continue _ ->
+ (* can use : add_dpd_goto_label pdg new_node s
+ * if we want later to change break and continue to goto...
+ *) ()
+ | Goto (sref,_) -> add_dpd_goto_label pdg new_node !sref
+ | Switch (_,_,stmts,_) -> add_dpd_switch_cases pdg new_node stmts
+ | _ -> assert false
+ end;
+ store_ctrl_dpds pdg new_node Stmt.Hptset.iter controlled_stmts;
+ new_node
+
+
+(** Add a node for a stmt that is a jump.
+ Add control dependencies from this node to the nodes which correspond to
+ the stmt list.
+ Also add dependencies for the jump to the label.
+ Don't use for jumps with data dependencies : use [process_jump_with_exp]
+ instead !
+*)
+let process_jump pdg stmt controlled_stmts =
+ ignore (mk_jump_node pdg stmt controlled_stmts)
+
+(** like [process_jump] but also add data dependencies on the data and their
+ declarations. Use for conditional jumps and returns.
+*)
+let process_jump_with_exp pdg stmt controlled_stmts state loc_cond decls_cond =
+ let jump_node = mk_jump_node pdg stmt controlled_stmts in
+ add_dpds pdg jump_node Dpd.Data state loc_cond;
+ add_decl_dpds pdg jump_node Dpd.Data decls_cond
+
+let add_blk_ctrl_dpds pdg key bstmts =
+ let new_node = add_elem pdg key in
+ store_ctrl_dpds pdg new_node List.iter (true, bstmts)
+
+let process_block pdg stmt blk =
+ add_blk_ctrl_dpds pdg (Key.stmt_key stmt) blk.bstmts
+
+let process_entry_point pdg bstmts =
+ add_blk_ctrl_dpds pdg Key.entry_point bstmts
+
+let create_fun_output_node pdg state dpds =
+ let new_node = add_elem pdg Key.output_key in
+ match state with
+ | Some state -> add_dpds pdg new_node Dpd.Data state dpds
+ | None -> (* return is unreachable *) ()
+
+(** add a node corresponding to the returned value. *)
+let add_retres pdg state ret_stmt retres_loc_dpds retres_decls =
+ let key_return = Key.stmt_key ret_stmt in
+ let return_node = add_elem pdg key_return in
+ let retres_loc = Db.Value.find_return_loc pdg.fct in
+ let retres = Locations.(enumerate_valid_bits Read retres_loc) in
+ add_dpds pdg return_node Dpd.Data state retres_loc_dpds;
+ add_decl_dpds pdg return_node Dpd.Data retres_decls;
+ let new_state = Pdg_state.add_loc_node state true retres return_node in
+ create_fun_output_node pdg (Some new_state) retres;
+ new_state
+
+(** part of [finalize_pdg] : add missing inputs
+ * and build a state with the new nodes to find them back when searching for
+ * undefined zones.
+ * (notice that now, they can overlap, for example we can have G and G.a)
+ * And also deals with warning for uninitialized local variables. *)
+let process_other_inputs pdg =
+ debug2 "process_other_inputs@.";
+ let rec add n dpd_kind (state, zones) z_or_top =
+ (* be careful because [z] can intersect several elements in [zones] *)
+ match zones with
+ | [] ->
+ let key = Key.implicit_in_key z_or_top in
+ let nz = add_elem pdg key in
+ debug "add_implicit_input : %a@."
+ Locations.Zone.pretty z_or_top ;
+ let state = Pdg_state.add_init_state_input state z_or_top nz in
+ add_z_dpd pdg n dpd_kind None nz;
+ state, [(z_or_top, nz)]
+ | (zone, nz)::tl_zones ->
+ match z_or_top, zone with
+ | (Locations.Zone.Top (_,_), Locations.Zone.Top (_,_)) ->
+ add_z_dpd pdg n dpd_kind None nz;
+ (state, zones)
+ | (z, _) when (Locations.Zone.equal zone z) ->
+ add_z_dpd pdg n dpd_kind None nz;
+ (* don't add z : already in *)
+ (state, zones)
+ | _ -> (* rec : look for z in tail *)
+ let state, tl_zones =
+ add n dpd_kind (state, tl_zones) z_or_top in
+ state, (zone, nz)::tl_zones
+ in
+ let add_zone acc (n, dpd_kind, z) =
+ let do_add = match get_var_base z with
+ | Some v -> if Kernel_function.is_local v pdg.fct then false else true
+ | None -> true
+ in if do_add then
+ let acc = match z with
+ | Locations.Zone.Top (_,_) -> add n dpd_kind acc z
+ | _ ->
+ let aux b intervs acc =
+ let z = Locations.Zone.inject b intervs in
+ add n dpd_kind acc z
in
- if not (Kernel_function.returns_void pdg.fct) then begin
- let from0 = froms.Function_Froms.deps_return in
- let deps_ret = Function_Froms.Memory.collapse_return from0 in
- let deps_ret = Function_Froms.Deps.to_zone deps_ret in
- ignore
- (create_fun_output_node pdg (Some new_state) deps_ret)
- end;
- new_state
+ Locations.Zone.fold_i aux z acc
+ in acc
+ else begin
+ debug2 "might use uninitialized : %a" Locations.Zone.pretty z;
+ acc
+ end
+ in
+ let (state, _) =
+ List.fold_left add_zone (Pdg_state.empty, []) pdg.other_inputs
+ in state
+
+(** to call then the building process is over :
+ add the control dependencies in the graph.
+ @return the real PDG that will be used later on.
+ @param from_opt for undefined functions (declarations) *)
+let finalize_pdg pdg from_opt =
+ debug2 "try to finalize_pdg";
+ let last_state =
+ try Some (Pdg_state.get_last_state pdg.states)
+ with Not_found ->
+ let ret =
+ try Kernel_function.find_return pdg.fct
+ with Kernel_function.No_Statement ->
+ Pdg_parameters.abort "No return in a declaration"
in
- Pdg_state.store_last_state pdg.states new_state);
- let init_state = process_other_inputs pdg in
- Pdg_state.store_init_state pdg.states init_state;
- add_ctrl_dpds pdg ;
- debug2 "finalize_pdg ok";
- PdgTypes.Pdg.make pdg.fct pdg.graph pdg.states pdg.index
+ Pdg_parameters.warning ~once:true ~source:(fst (Stmt.loc ret))
+ "no final state. Probably unreachable...";
+ None
+ in
+ (match from_opt with
+ | None -> () (* defined function : retres already processed. *)
+ | Some froms -> (* undefined function : add output 0 *)
+ (* TODO : also add the nodes for the other from ! *)
+ let state = match last_state with Some s -> s | None -> assert false in
+ let process_out out deps s =
+ let open Function_Froms.DepsOrUnassigned in
+ if (equal Unassigned deps)
+ then s
+ else
+ let from_out = to_zone deps in
+ let default = may_be_unassigned deps in
+ add_from pdg state s out (default, from_out)
+ in
+ let from_table = froms.Function_Froms.deps_table in
+ let new_state =
+ if Function_Froms.Memory.is_bottom from_table then
+ Pdg_state.bottom
+ else
+ let new_state =
+ match from_table with
+ | Function_Froms.Memory.Top ->
+ process_out
+ Locations.Zone.top Function_Froms.DepsOrUnassigned.top state
+ | Function_Froms.Memory.Map m ->
+ Function_Froms.Memory.fold_fuse_same process_out m state
+ | Function_Froms.Memory.Bottom -> assert false (* checked above *)
+ in
+ if not (Kernel_function.returns_void pdg.fct) then begin
+ let from0 = froms.Function_Froms.deps_return in
+ let deps_ret = Function_Froms.Memory.collapse_return from0 in
+ let deps_ret = Function_Froms.Deps.to_zone deps_ret in
+ ignore
+ (create_fun_output_node pdg (Some new_state) deps_ret)
+ end;
+ new_state
+ in
+ Pdg_state.store_last_state pdg.states new_state);
+ let init_state = process_other_inputs pdg in
+ Pdg_state.store_init_state pdg.states init_state;
+ add_ctrl_dpds pdg ;
+ debug2 "finalize_pdg ok";
+ PdgTypes.Pdg.make pdg.fct pdg.graph pdg.states pdg.index
(*-----------------------------------------------------------------------*)
(** gives needed informations about [lval] :
- = location + exact + dependencies + declarations *)
+ = location + exact + dependencies + declarations *)
let get_lval_infos lval stmt =
let decl = Cil.extract_varinfos_from_lval lval in
let state = Db.Value.get_stmt_state stmt in
@@ -631,13 +631,13 @@ let process_args pdg st stmt argl =
let decl_dpds = Cil.extract_varinfos_from_exp arg in
(dpds, decl_dpds)
in let arg_dpds = List.map process_one_arg argl in
- process_call_args pdg st stmt arg_dpds
+ process_call_args pdg st stmt arg_dpds
(** Add nodes for the call outputs,
- and add the dependencies according to from_table.
- To avoid mixing inputs and outputs, [in_state] is the input state
- and [new_state] the state to modify.
-* Process call outputs (including returned value) *)
+ and add the dependencies according to from_table.
+ To avoid mixing inputs and outputs, [in_state] is the input state
+ and [new_state] the state to modify.
+ * Process call outputs (including returned value) *)
let call_outputs pdg state_before_call state_with_inputs stmt
lvaloption froms fct_dpds =
(* obtain inputs from state_with_inputs
@@ -665,35 +665,35 @@ let call_outputs pdg state_before_call state_with_inputs stmt
if Function_Froms.Memory.is_bottom from_table then
Pdg_state.bottom
else
- let state_with_outputs =
- let open Function_Froms in
- match from_table with
- | Memory.Top ->
- process_out
- Locations.Zone.top DepsOrUnassigned.top state_before_call
- | Memory.Bottom -> assert false (* checked above *)
- | Memory.Map m ->
- Memory.fold_fuse_same process_out m state_before_call
- in
+ let state_with_outputs =
+ let open Function_Froms in
+ match from_table with
+ | Memory.Top ->
+ process_out
+ Locations.Zone.top DepsOrUnassigned.top state_before_call
+ | Memory.Bottom -> assert false (* checked above *)
+ | Memory.Map m ->
+ Memory.fold_fuse_same process_out m state_before_call
+ in
match lvaloption with
- | None -> state_with_outputs
- | Some lval ->
- let r_dpds =
- Function_Froms.Memory.collapse_return froms_deps_return
- in
- let r_dpds = Function_Froms.Deps.to_zone r_dpds in
- let (l_loc, exact, l_dpds, l_decl) = get_lval_infos lval stmt in
- process_call_return
- pdg
- state_with_outputs
- state_with_inputs stmt
- ~l_loc ~exact ~l_dpds ~l_decl
- ~r_dpds fct_dpds
+ | None -> state_with_outputs
+ | Some lval ->
+ let r_dpds =
+ Function_Froms.Memory.collapse_return froms_deps_return
+ in
+ let r_dpds = Function_Froms.Deps.to_zone r_dpds in
+ let (l_loc, exact, l_dpds, l_decl) = get_lval_infos lval stmt in
+ process_call_return
+ pdg
+ state_with_outputs
+ state_with_inputs stmt
+ ~l_loc ~exact ~l_dpds ~l_decl
+ ~r_dpds fct_dpds
(** process call : {v lvaloption = funcexp (argl); v}
Use the state at ki (before the call)
and returns the new state (after the call).
- *)
+*)
let process_call pdg state stmt lvaloption funcexp argl _loc =
let state_before_call = state in
(** add a simple node for each call in order to have something in the PDG
@@ -711,17 +711,17 @@ let process_call pdg state stmt lvaloption funcexp argl _loc =
in
let process_simple_call called_kf acc =
let state_with_inputs =
- process_call_params pdg state_with_args stmt called_kf arg_nodes
+ process_call_params pdg state_with_args stmt called_kf arg_nodes
in
let r =
match mixed_froms with
- | Some _ -> state_with_inputs (* process outputs later *)
- | None -> (* don't have callwise analysis (-calldeps option) *)
- let froms = !Db.From.get called_kf in
- let state_for_this_call =
- call_outputs pdg state_before_call state_with_inputs
- stmt lvaloption froms funcexp_dpds
- in state_for_this_call
+ | Some _ -> state_with_inputs (* process outputs later *)
+ | None -> (* don't have callwise analysis (-calldeps option) *)
+ let froms = !Db.From.get called_kf in
+ let state_for_this_call =
+ call_outputs pdg state_before_call state_with_inputs
+ stmt lvaloption froms funcexp_dpds
+ in state_for_this_call
in r :: acc
in
let state_for_each_call =
@@ -730,27 +730,27 @@ let process_call pdg state stmt lvaloption funcexp argl _loc =
let new_state =
match state_for_each_call with
| [] ->
- let stmt_str = Format.asprintf "%a" Printer.pp_stmt stmt in
- Pdg_parameters.not_yet_implemented
- ~source:(fst (Cil_datatype.Stmt.loc stmt))
- "pdg with an unknown function call: %s" stmt_str
+ let stmt_str = Format.asprintf "%a" Printer.pp_stmt stmt in
+ Pdg_parameters.not_yet_implemented
+ ~source:(fst (Cil_datatype.Stmt.loc stmt))
+ "pdg with an unknown function call: %s" stmt_str
| st :: [] -> st
| st :: other_states ->
- let merge s1 s2 =
- let _,s = Pdg_state.test_and_merge ~old:s1 s2 in s
- in List.fold_left merge st other_states
+ let merge s1 s2 =
+ let _,s = Pdg_state.test_and_merge ~old:s1 s2 in s
+ in List.fold_left merge st other_states
in
let new_state = match mixed_froms with
| None -> new_state
| Some froms ->
- call_outputs pdg state_before_call new_state
- stmt lvaloption froms funcexp_dpds
+ call_outputs pdg state_before_call new_state
+ stmt lvaloption froms funcexp_dpds
in
new_state
(** Add a node in the PDG for the conditional statement,
* and register the statements that are control-dependent on it.
- *)
+*)
let process_condition ctrl_dpds_infos pdg state stmt condition =
let loc_cond = !Db.From.find_deps_no_transitivity stmt condition in
let decls_cond = Cil.extract_varinfos_from_exp condition in
@@ -758,44 +758,44 @@ let process_condition ctrl_dpds_infos pdg state stmt condition =
let controlled_stmts = CtrlDpds.get_if_controlled_stmts ctrl_dpds_infos stmt in
let go_then, go_else = Db.Value.condition_truth_value stmt in
let real = go_then && go_else (* real dpd if we can go in both branches *) in
- if not real then
- debug
- "[process_condition] stmt %d is not a real cond (never goes in '%s')@."
- stmt.sid (if go_then then "else" else "then");
- (* build a node for the condition and store de control dependencies *)
- process_jump_with_exp pdg stmt (real, controlled_stmts)
- state loc_cond decls_cond
+ if not real then
+ debug
+ "[process_condition] stmt %d is not a real cond (never goes in '%s')@."
+ stmt.sid (if go_then then "else" else "then");
+ (* build a node for the condition and store de control dependencies *)
+ process_jump_with_exp pdg stmt (real, controlled_stmts)
+ state loc_cond decls_cond
(** let's add a node for e jump statement (goto, break, continue)
- and find the statements which are depending on it.
- Returns are not handled here, but in {!Build.process_return}.
+ and find the statements which are depending on it.
+ Returns are not handled here, but in {!Build.process_return}.
*)
let process_jump_stmt pdg ctrl_dpds_infos jump =
let controlled_stmts =
CtrlDpds.get_jump_controlled_stmts ctrl_dpds_infos jump
in
let real = Db.Value.is_reachable_stmt jump in
- if not real then
- debug "[process_jump_stmt] stmt %d is not a real jump@." jump.sid;
- process_jump pdg jump (real, controlled_stmts)
+ if not real then
+ debug "[process_jump_stmt] stmt %d is not a real jump@." jump.sid;
+ process_jump pdg jump (real, controlled_stmts)
(** Loop are processed like gotos because CIL transforms them into
-* {v while(true) body; v} which is equivalent to {v L : body ; goto L; v}
-* There is a small difference because we have to detect the case where
-* the [goto L;] would be unreachable (no real loop).
-* This is important because it might lead to infinite loop (see bst#787)
+ * {v while(true) body; v} which is equivalent to {v L : body ; goto L; v}
+ * There is a small difference because we have to detect the case where
+ * the [goto L;] would be unreachable (no real loop).
+ * This is important because it might lead to infinite loop (see bst#787)
*)
let process_loop_stmt pdg ctrl_dpds_infos loop =
let _entry, back_edges = Stmts_graph.loop_preds loop in
- debug2 "[process_loop_stmt] for loop %d : back edges = {%a}@."
- loop.sid (Pretty_utils.pp_list Stmt.pretty_sid) back_edges;
+ debug2 "[process_loop_stmt] for loop %d : back edges = {%a}@."
+ loop.sid (Pretty_utils.pp_list Stmt.pretty_sid) back_edges;
let controlled_stmts =
CtrlDpds.get_loop_controlled_stmts ctrl_dpds_infos loop
in
let real_loop = List.exists (Db.Value.is_reachable_stmt) back_edges in
- if not real_loop then
- debug "[process_loop_stmt] stmt %d is not a real loop@." loop.sid;
- process_jump pdg loop (real_loop, controlled_stmts)
+ if not real_loop then
+ debug "[process_loop_stmt] stmt %d is not a real loop@." loop.sid;
+ process_jump pdg loop (real_loop, controlled_stmts)
(** [return ret_exp;] is equivalent to [out0 = ret_exp; goto END;]
* while a simple [return;] is only a [goto END;].
@@ -803,29 +803,29 @@ let process_loop_stmt pdg ctrl_dpds_infos loop =
* was used, ie. that it is the only return of the function
* and that it is the last statement. So, the [goto] is not useful,
* and the final state is stored to be used later on to compute the outputs.
- *)
+*)
let process_return _current_function pdg state stmt ret_exp =
let last_state =
- match ret_exp with
- | Some exp ->
- let loc_exp = !Db.From.find_deps_no_transitivity stmt exp in
- let decls_exp = Cil.extract_varinfos_from_exp exp in
- add_retres pdg state stmt loc_exp decls_exp
- | None ->
- let controlled_stmt = Cil_datatype.Stmt.Hptset.empty in
- let real = Db.Value.is_reachable_stmt stmt in
- process_jump pdg stmt (real, controlled_stmt);
- state
+ match ret_exp with
+ | Some exp ->
+ let loc_exp = !Db.From.find_deps_no_transitivity stmt exp in
+ let decls_exp = Cil.extract_varinfos_from_exp exp in
+ add_retres pdg state stmt loc_exp decls_exp
+ | None ->
+ let controlled_stmt = Cil_datatype.Stmt.Hptset.empty in
+ let real = Db.Value.is_reachable_stmt stmt in
+ process_jump pdg stmt (real, controlled_stmt);
+ state
in
- if Db.Value.is_reachable_stmt stmt then
- Pdg_state.store_last_state pdg.states last_state
+ if Db.Value.is_reachable_stmt stmt then
+ Pdg_state.store_last_state pdg.states last_state
module Computer
- (Initial:sig val initial: (stmt * PdgTypes.data_state) list end)
- (Fenv:Dataflows.FUNCTION_ENV)
- (Param:sig val current_pdg : pdg_build
- val ctrl_dpds_infos : CtrlDpds.t
- end) = struct
+ (Initial:sig val initial: (stmt * PdgTypes.data_state) list end)
+ (Fenv:Dataflows.FUNCTION_ENV)
+ (Param:sig val current_pdg : pdg_build
+ val ctrl_dpds_infos : CtrlDpds.t
+ end) = struct
let pdg_debug fmt = debug fmt
type t = PdgTypes.data_state
@@ -862,72 +862,72 @@ module Computer
state l
(** Compute the new state after 'instr' starting from state before 'state'.
- *)
+ *)
let doInstr stmt instr state =
Db.yield ();
pdg_debug "doInstr sid:%d : %a" stmt.sid Printer.pp_instr instr;
match instr with
- | _ when not (Db.Value.is_reachable_stmt stmt) ->
- pdg_debug "stmt sid:%d is unreachable : skip.@." stmt.sid ;
- Pdg_state.bottom
- | Local_init (v, AssignInit i, _) ->
- process_init current_pdg state stmt (Cil.var v) i
- | Local_init (v, ConsInit (f, args, kind), loc) ->
- Db.yield ();
- Cil.treat_constructor_as_func
- (process_call current_pdg state stmt) v f args kind loc
- | Set (lv, exp, _) -> process_asgn current_pdg state stmt lv exp
- | Call (lvaloption,funcexp,argl,loc) ->
- Db.yield ();
- process_call current_pdg state stmt lvaloption funcexp argl loc
- | Code_annot _
- | Skip _ -> process_skip current_pdg state stmt
- | Asm _ -> process_asm current_pdg state stmt
+ | _ when not (Db.Value.is_reachable_stmt stmt) ->
+ pdg_debug "stmt sid:%d is unreachable : skip.@." stmt.sid ;
+ Pdg_state.bottom
+ | Local_init (v, AssignInit i, _) ->
+ process_init current_pdg state stmt (Cil.var v) i
+ | Local_init (v, ConsInit (f, args, kind), loc) ->
+ Db.yield ();
+ Cil.treat_constructor_as_func
+ (process_call current_pdg state stmt) v f args kind loc
+ | Set (lv, exp, _) -> process_asgn current_pdg state stmt lv exp
+ | Call (lvaloption,funcexp,argl,loc) ->
+ Db.yield ();
+ process_call current_pdg state stmt lvaloption funcexp argl loc
+ | Code_annot _
+ | Skip _ -> process_skip current_pdg state stmt
+ | Asm _ -> process_asm current_pdg state stmt
(** Called before processing the successors of the statements.
- *)
+ *)
let transfer_stmt (stmt: Cil_types.stmt) (state: t) =
- pdg_debug "doStmt %d @." stmt.sid ;
+ pdg_debug "doStmt %d @." stmt.sid ;
let map_on_all_succs newstate =
List.map (fun x -> (x,newstate)) stmt.succs
in
(* Notice that the stmt labels are processed while processing the jumps. *)
process_stmt_labels current_pdg stmt;
match stmt.skind with
- | Instr i
- -> map_on_all_succs (doInstr stmt i state)
-
- | Block blk ->
- process_block current_pdg stmt blk;
- map_on_all_succs state
- | UnspecifiedSequence seq ->
- process_block current_pdg stmt
- (Cil.block_from_unspecified_sequence seq);
- map_on_all_succs state
-
- | Switch (exp,_,_,_)
- | If (exp,_,_,_) ->
- process_condition ctrl_dpds_infos current_pdg state stmt exp;
- map_on_all_succs state
-
- | Return (exp,_) ->
- process_return current_function current_pdg state stmt exp;
- []
-
- | Continue _
- | Break _
- | Goto _ ->
- process_jump_stmt current_pdg ctrl_dpds_infos stmt;
- map_on_all_succs state
-
- | Loop _ ->
- process_loop_stmt current_pdg ctrl_dpds_infos stmt;
- map_on_all_succs state
- | Throw _ | TryCatch _ ->
- Pdg_parameters.fatal "Exception node in the AST"
- | TryExcept (_, _, _, _)
- | TryFinally (_, _, _) ->
- map_on_all_succs state
+ | Instr i
+ -> map_on_all_succs (doInstr stmt i state)
+
+ | Block blk ->
+ process_block current_pdg stmt blk;
+ map_on_all_succs state
+ | UnspecifiedSequence seq ->
+ process_block current_pdg stmt
+ (Cil.block_from_unspecified_sequence seq);
+ map_on_all_succs state
+
+ | Switch (exp,_,_,_)
+ | If (exp,_,_,_) ->
+ process_condition ctrl_dpds_infos current_pdg state stmt exp;
+ map_on_all_succs state
+
+ | Return (exp,_) ->
+ process_return current_function current_pdg state stmt exp;
+ []
+
+ | Continue _
+ | Break _
+ | Goto _ ->
+ process_jump_stmt current_pdg ctrl_dpds_infos stmt;
+ map_on_all_succs state
+
+ | Loop _ ->
+ process_loop_stmt current_pdg ctrl_dpds_infos stmt;
+ map_on_all_succs state
+ | Throw _ | TryCatch _ ->
+ Pdg_parameters.fatal "Exception node in the AST"
+ | TryExcept (_, _, _, _)
+ | TryFinally (_, _, _) ->
+ map_on_all_succs state
end
@@ -951,39 +951,39 @@ let compute_pdg_for_f kf =
process_declarations pdg formals f_locals
in
let froms = match f_stmts with
- | [] ->
+ | [] ->
Pdg_state.store_last_state pdg.states init_state;
let froms = !Db.From.get kf in
- Some (froms)
- | start :: _ ->
+ Some (froms)
+ | start :: _ ->
let ctrl_dpds_infos = CtrlDpds.compute kf in
(* Put all statements in initial, so that they are processed and
- are in the worklist (even if they are dead). *)
+ are in the worklist (even if they are dead). *)
let allstmts = (Kernel_function.get_definition kf).sallstmts in
let allstmts_no_start =
- List.filter (fun s -> s.sid != start.sid) allstmts
+ List.filter (fun s -> s.sid != start.sid) allstmts
in
let initial_list =
- List.map (fun s -> (s, Pdg_state.bottom)) allstmts_no_start
+ List.map (fun s -> (s, Pdg_state.bottom)) allstmts_no_start
in
let module Initial = struct
- let initial = (start, init_state)::initial_list end
+ let initial = (start, init_state)::initial_list end
in
let module Fenv =
- (val Dataflows.function_env kf: Dataflows.FUNCTION_ENV)
+ (val Dataflows.function_env kf: Dataflows.FUNCTION_ENV)
in
let module Computer = Computer(Initial)(Fenv)(struct
- let current_pdg = pdg
- let ctrl_dpds_infos = ctrl_dpds_infos
- end)
+ let current_pdg = pdg
+ let ctrl_dpds_infos = ctrl_dpds_infos
+ end)
in
if Db.Value.is_reachable_stmt start then
begin
- let module Compute = Dataflows.Simple_forward(Fenv)(Computer) in
- Array.iteri (fun ord value ->
- let stmt = Fenv.to_stmt ord in
- Stmt.Hashtbl.replace pdg.states stmt value) Compute.before;
+ let module Compute = Dataflows.Simple_forward(Fenv)(Computer) in
+ Array.iteri (fun ord value ->
+ let stmt = Fenv.to_stmt ord in
+ Stmt.Hashtbl.replace pdg.states stmt value) Compute.before;
None
end
else
@@ -993,7 +993,7 @@ let compute_pdg_for_f kf =
start.sid (Kernel_function.get_name kf)))
in
let pdg = finalize_pdg pdg froms in
- pdg
+ pdg
let degenerated top kf =
Pdg_parameters.feedback "%s for function %a" (if top then "Top" else "Bottom")
@@ -1010,25 +1010,25 @@ let compute_pdg kf =
Pdg_parameters.feedback "done for function %a" Kernel_function.pretty kf;
pdg
with
- | Err_Bot what ->
- Pdg_parameters.warning "%s" what ;
- degenerated false kf
- | Value_State_Top -> degenerated true kf
- | Log.AbortFatal what ->
- (* [JS 2012/08/24] nobody should catch this exception *)
- Pdg_parameters.warning "internal error: %s" what ;
- degenerated true kf
- | Log.AbortError what ->
- (* [JS 2012/08/24] nobody should catch this exception *)
- Pdg_parameters.warning "user error: %s" what ;
- degenerated true kf
- | Pdg_state.Cannot_fold ->
- Pdg_parameters.warning "too imprecise value analysis : abort" ;
- degenerated true kf
- | Log.FeatureRequest (source, who, what) ->
- (* [JS 2012/08/24] nobody should catch this exception *)
- Pdg_parameters.warning ?source "not implemented by %s yet: %s" who what;
- degenerated true kf
+ | Err_Bot what ->
+ Pdg_parameters.warning "%s" what ;
+ degenerated false kf
+ | Value_State_Top -> degenerated true kf
+ | Log.AbortFatal what ->
+ (* [JS 2012/08/24] nobody should catch this exception *)
+ Pdg_parameters.warning "internal error: %s" what ;
+ degenerated true kf
+ | Log.AbortError what ->
+ (* [JS 2012/08/24] nobody should catch this exception *)
+ Pdg_parameters.warning "user error: %s" what ;
+ degenerated true kf
+ | Pdg_state.Cannot_fold ->
+ Pdg_parameters.warning "too imprecise value analysis : abort" ;
+ degenerated true kf
+ | Log.FeatureRequest (source, who, what) ->
+ (* [JS 2012/08/24] nobody should catch this exception *)
+ Pdg_parameters.warning ?source "not implemented by %s yet: %s" who what;
+ degenerated true kf
(*
Local Variables:
diff --git a/src/plugins/pdg/ctrlDpds.ml b/src/plugins/pdg/ctrlDpds.ml
index 68a40418a8d3a06c3dff03a20fa82144655243a1..cd219e608f816618f8a7d5eb69f2c280961b80d7 100644
--- a/src/plugins/pdg/ctrlDpds.ml
+++ b/src/plugins/pdg/ctrlDpds.ml
@@ -43,14 +43,14 @@ open Cil_datatype
(5) -> (6)
(7) -> (6)
- *)
+*)
module Lexical_successors : sig
type t
val compute : Cil_types.kernel_function -> t
(** @return the lexical successor of stmt in graph.
- @raise Not_found if 'stmt' has no successor in 'graph'
+ @raise Not_found if 'stmt' has no successor in 'graph'
*)
val find : t -> Cil_types.stmt -> Cil_types.stmt
end = struct
@@ -66,70 +66,70 @@ end = struct
let add_links graph prev_list next = match prev_list with
| [] -> ()
| _ ->
- let link prev =
- try ignore (Stmt.Hashtbl.find graph prev)
- with Not_found ->
- Pdg_parameters.debug ~dkey "add @[%a@,-> %a@]"
- pp_stmt prev pp_stmt next;
- Stmt.Hashtbl.add graph prev next
- in List.iter link prev_list
+ let link prev =
+ try ignore (Stmt.Hashtbl.find graph prev)
+ with Not_found ->
+ Pdg_parameters.debug ~dkey "add @[%a@,-> %a@]"
+ pp_stmt prev pp_stmt next;
+ Stmt.Hashtbl.add graph prev next
+ in List.iter link prev_list
(** Add links from [prev_list] to [stmt].
- * (ie. [stmt] is the lexical successor of every statements in [prev_list])
- * and build the links inside [stmt] (when it contains blocks)
- * @return a list of the last statements in [stmt] to continue processing
- * with the statement that follows.
+ * (ie. [stmt] is the lexical successor of every statements in [prev_list])
+ * and build the links inside [stmt] (when it contains blocks)
+ * @return a list of the last statements in [stmt] to continue processing
+ * with the statement that follows.
*)
let rec process_stmt graph ~prev_list ~stmt =
Pdg_parameters.debug ~dkey "computing for statement %a@."
pp_stmt stmt;
match stmt.skind with
- | If (_,bthen,belse,_) ->
- let _ = add_links graph prev_list stmt in
- let last_then = process_block graph bthen in
- let last_else = process_block graph belse in
- let prev_list = match last_then, last_else with
- | [], [] -> [ stmt ]
- | last, [] | [], last -> stmt::last
- | last_then, last_else -> last_then @ last_else
- in prev_list
-
- | Switch (_,blk,_,_)
- | Block blk ->
- let _ = add_links graph prev_list stmt in
- process_block graph blk
- | UnspecifiedSequence seq ->
- let _ = add_links graph prev_list stmt in
- process_block graph (Cil.block_from_unspecified_sequence seq)
-
- | Loop (_,body,_,_,_) ->
- let prev_list = match body.bstmts with
- | [] ->
- let _ = add_links graph prev_list stmt in [ stmt ]
- | head::_ ->
- let _ = add_links graph prev_list head in
- let last_list = process_block graph body in
- let _ = add_links graph last_list stmt in
- stmt::[]
- in prev_list
- | TryCatch _ -> Pdg_parameters.fatal "Try/Catch node in the AST"
- | Instr _
- | Return _ | Goto _ | Break _ | Continue _ | Throw _
- | TryFinally _ | TryExcept _
- -> let _ = add_links graph prev_list stmt in [stmt]
+ | If (_,bthen,belse,_) ->
+ let _ = add_links graph prev_list stmt in
+ let last_then = process_block graph bthen in
+ let last_else = process_block graph belse in
+ let prev_list = match last_then, last_else with
+ | [], [] -> [ stmt ]
+ | last, [] | [], last -> stmt::last
+ | last_then, last_else -> last_then @ last_else
+ in prev_list
+
+ | Switch (_,blk,_,_)
+ | Block blk ->
+ let _ = add_links graph prev_list stmt in
+ process_block graph blk
+ | UnspecifiedSequence seq ->
+ let _ = add_links graph prev_list stmt in
+ process_block graph (Cil.block_from_unspecified_sequence seq)
+
+ | Loop (_,body,_,_,_) ->
+ let prev_list = match body.bstmts with
+ | [] ->
+ let _ = add_links graph prev_list stmt in [ stmt ]
+ | head::_ ->
+ let _ = add_links graph prev_list head in
+ let last_list = process_block graph body in
+ let _ = add_links graph last_list stmt in
+ stmt::[]
+ in prev_list
+ | TryCatch _ -> Pdg_parameters.fatal "Try/Catch node in the AST"
+ | Instr _
+ | Return _ | Goto _ | Break _ | Continue _ | Throw _
+ | TryFinally _ | TryExcept _
+ -> let _ = add_links graph prev_list stmt in [stmt]
(** Process each statement in blk with no previous statement to begin with.
- * Then process each statement in the statement list
+ * Then process each statement in the statement list
* knowing that the first element of 'tail'
* is the successor of every statement in prev_list.
* @return a list of the last statements in tail or prev_list if tail=[].
- *)
- and process_block graph blk =
+ *)
+ and process_block graph blk =
let rec process_stmts prev_list stmts = match stmts with
- | [] -> prev_list
- | s :: tail ->
- let s_last_stmts = process_stmt graph prev_list s in
- process_stmts s_last_stmts tail
+ | [] -> prev_list
+ | s :: tail ->
+ let s_last_stmts = process_stmt graph prev_list s in
+ process_stmts s_last_stmts tail
in process_stmts [] blk.bstmts
(** Compute the lexical successor graph for function kf *)
@@ -138,14 +138,14 @@ end = struct
(Kernel_function.get_name kf);
if !Db.Value.use_spec_instead_of_definition kf then Stmt.Hashtbl.create 0
else let graph = Stmt.Hashtbl.create 17 in
- let f = Kernel_function.get_definition kf in
- let _ = process_block graph f.sbody in graph
+ let f = Kernel_function.get_definition kf in
+ let _ = process_block graph f.sbody in graph
(** @return the lexical successor of stmt in graph.
- @raise Not_found if 'stmt' has no successor in 'graph' ie when it is [return].
+ @raise Not_found if 'stmt' has no successor in 'graph' ie when it is [return].
*)
let find graph stmt =
- try Stmt.Hashtbl.find graph stmt
+ try Stmt.Hashtbl.find graph stmt
with Not_found ->
Pdg_parameters.debug ~dkey ~level:2 "not found for stmt:%d@." stmt.sid;
raise Not_found
@@ -160,17 +160,17 @@ end
The implementation is as follows:
- compute postdominators with an additional flag infinite loop/non-infinite
- loop. Every path that may terminate does not have the "infinite loop" flag
+ loop. Every path that may terminate does not have the "infinite loop" flag
- the implementation verifies property P only for Loop statements. To
- obtain the property, the cfg is locally rewritten. For statements
- --> p --> s:Loop --> h --> ... --> e
+ obtain the property, the cfg is locally rewritten. For statements
+ --> p --> s:Loop --> h --> ... --> e
^ |
| |
--------------------------
- the edges p --> s are transformed into p --> h, but _not_ the backward
- edges e --> s. This way, s post-dominates itself if and only if s is
- a syntactically infinite loop, but not if there is an outgoing edge. *)
+ the edges p --> s are transformed into p --> h, but _not_ the backward
+ edges e --> s. This way, s post-dominates itself if and only if s is
+ a syntactically infinite loop, but not if there is an outgoing edge. *)
module PdgPostdom : sig
type t
@@ -178,13 +178,13 @@ module PdgPostdom : sig
val compute : kernel_function -> t
(** @param with_s tells if the statement has to be added to its postdom.
- * The returned boolean tells if there is a path to [return] *)
+ * The returned boolean tells if there is a path to [return] *)
val get : t -> with_s:bool -> stmt -> bool * Stmt.Hptset.t
-end = struct
+end = struct
module State = struct
- type t =
+ type t =
| ToReturn of Stmt.Hptset.t
| ToInfinity of Stmt.Hptset.t
@@ -204,8 +204,8 @@ end = struct
let pretty fmt d =
match d with
- | ToReturn d -> Format.fprintf fmt "{%a}_ret" Stmt.Hptset.pretty d
- | ToInfinity d -> Format.fprintf fmt "{%a}_oo" Stmt.Hptset.pretty d
+ | ToReturn d -> Format.fprintf fmt "{%a}_ret" Stmt.Hptset.pretty d
+ | ToInfinity d -> Format.fprintf fmt "{%a}_oo" Stmt.Hptset.pretty d
end
type t = State.t Stmt.Hashtbl.t
@@ -220,49 +220,49 @@ end = struct
with Exit -> true
(** change [succs] so move the edges [entry -> loop] to [entry -> head] *)
- let succs stmt =
+ let succs stmt =
let modif acc s = match s.skind with
- | Loop _ ->
- let head = match s.succs with | [head] -> head | _ -> assert false in
- let entry, _back_edges = Stmts_graph.loop_preds s in
- if is_in_stmts List.iter stmt entry then head::acc else s::acc
+ | Loop _ ->
+ let head = match s.succs with | [head] -> head | _ -> assert false in
+ let entry, _back_edges = Stmts_graph.loop_preds s in
+ if is_in_stmts List.iter stmt entry then head::acc else s::acc
| _ -> s::acc
in List.fold_left modif [] stmt.succs
- (** change [preds] so remove the edges [entry <- loop]
- * and to add the edges [entry <- head] *)
+ (** change [preds] so remove the edges [entry <- loop]
+ * and to add the edges [entry <- head] *)
let preds stmt = match stmt.skind with
| Loop _ -> (* remove edges from entry to loop *)
- let _entry, back_edges = Stmts_graph.loop_preds stmt in back_edges
- | _ ->
- let modif acc s = match s.skind with
- | Loop _ ->
- let entry, _back_edges = Stmts_graph.loop_preds s in
- s::entry@acc
- | _ -> s::acc
- in List.fold_left modif [] stmt.preds
+ let _entry, back_edges = Stmts_graph.loop_preds stmt in back_edges
+ | _ ->
+ let modif acc s = match s.skind with
+ | Loop _ ->
+ let entry, _back_edges = Stmts_graph.loop_preds s in
+ s::entry@acc
+ | _ -> s::acc
+ in List.fold_left modif [] stmt.preds
let add_postdom infos start init =
let get s =
try Stmt.Hashtbl.find infos s
with Not_found -> State.ToInfinity Stmt.Hptset.empty
in
- let do_stmt stmt = match succs stmt with
- | [] when stmt.sid = start.sid ->
- Some (State.ToReturn (Stmt.Hptset.empty))
+ let do_stmt stmt = match succs stmt with
+ | [] when stmt.sid = start.sid ->
+ Some (State.ToReturn (Stmt.Hptset.empty))
| [] -> assert false
- | s::tl ->
- let add_get s = State.add s (get s) in
- let combineSuccessors st s = State.inter st (add_get s) in
- let st = List.fold_left combineSuccessors (add_get s) tl in
- let old = get stmt in
- let new_st = (* don't need to State.inter old *) st in
- if State.equal old new_st then None
- else Some new_st
- in
+ | s::tl ->
+ let add_get s = State.add s (get s) in
+ let combineSuccessors st s = State.inter st (add_get s) in
+ let st = List.fold_left combineSuccessors (add_get s) tl in
+ let old = get stmt in
+ let new_st = (* don't need to State.inter old *) st in
+ if State.equal old new_st then None
+ else Some new_st
+ in
let todo = Queue.create () in
- let add_todo p =
- if is_in_stmts Queue.iter p todo then () else Queue.add p todo
+ let add_todo p =
+ if is_in_stmts Queue.iter p todo then () else Queue.add p todo
in
let rec do_todo () =
let s = Queue.take todo in
@@ -270,14 +270,14 @@ end = struct
match do_stmt s with
| None -> (* finished with that one *) ()
| Some st -> (* store state and add preds *)
- Stmt.Hashtbl.add infos s st; List.iter add_todo (preds s)
+ Stmt.Hashtbl.add infos s st; List.iter add_todo (preds s)
end;
do_todo ()
in
try
let _ = Stmt.Hashtbl.add infos start init in
let _ = List.iter (fun p -> Queue.add p todo) (preds start) in
- do_todo ()
+ do_todo ()
with Queue.Empty -> ()
let compute kf =
@@ -287,7 +287,7 @@ end = struct
with Kernel_function.No_Statement ->
Pdg_parameters.fatal "No return statement for a function with body %a"
Kernel_function.pretty kf
- in
+ in
let _ = add_postdom infos return (State.ToReturn (Stmt.Hptset.empty)) in
let stmts =
if !Db.Value.use_spec_instead_of_definition kf then
@@ -296,12 +296,12 @@ end = struct
let f = Kernel_function.get_definition kf in f.sallstmts
in
let remove_top s =
- try ignore (Stmt.Hashtbl.find infos s) with Not_found ->
+ try ignore (Stmt.Hashtbl.find infos s) with Not_found ->
Pdg_parameters.debug ~dkey "compute infinite path to sid:%d" s.sid;
add_postdom infos s (State.ToInfinity (Stmt.Hptset.empty))
in
let _ = List.iter remove_top stmts in
- infos
+ infos
let get infos ~with_s stmt =
try
@@ -309,13 +309,13 @@ end = struct
| State.ToInfinity postdoms -> false, postdoms
| State.ToReturn postdoms -> true, postdoms
in let postdoms =
- if with_s then Stmt.Hptset.add stmt postdoms else postdoms
- in
- Pdg_parameters.debug ~dkey ~level:2
- "get_postdoms for sid:%d (%s) = %a (%spath to ret)@."
- stmt.sid (if with_s then "with" else "without")
- Stmt.Hptset.pretty postdoms (if stmt_to_ret then "" else "no ");
- stmt_to_ret, postdoms
+ if with_s then Stmt.Hptset.add stmt postdoms else postdoms
+ in
+ Pdg_parameters.debug ~dkey ~level:2
+ "get_postdoms for sid:%d (%s) = %a (%spath to ret)@."
+ stmt.sid (if with_s then "with" else "without")
+ Stmt.Hptset.pretty postdoms (if stmt_to_ret then "" else "no ");
+ stmt_to_ret, postdoms
with Not_found -> assert false
end
@@ -328,7 +328,7 @@ type t = Lexical_successors.t * PdgPostdom.t
let compute kf =
let lex_succ_graph = Lexical_successors.compute kf in
let ctrl_dpds_infos = PdgPostdom.compute kf in
- (lex_succ_graph, ctrl_dpds_infos)
+ (lex_succ_graph, ctrl_dpds_infos)
(** Compute the PDB(A,B) set used in the control dependencies algorithm.
* Roughly speaking, it gives {v (\{B\} U postdom(B))-postdom(A) v}.
@@ -336,8 +336,8 @@ let compute kf =
* As B is usually a successor of A, it means that S is reached if the B-branch
* is chosen, but not necessary for the other branches. Then, S should depend
* on A.
- (see the document to know more about the applied algorithm)
- *)
+ (see the document to know more about the applied algorithm)
+*)
let pd_b_but_not_a infos stmt_a stmt_b =
if stmt_a.sid = stmt_b.sid then Stmt.Hptset.empty
else begin
@@ -349,13 +349,13 @@ let pd_b_but_not_a infos stmt_a stmt_b =
| false, true -> (* no path [a, ret] but path [b, ret]
* possible when a there is a jump, because then we have
* either (A=G, B=S) or (A=S, B=L) *)
- Stmt.Hptset.empty (* because we don't want b postdoms
- to depend on the jump *)
+ Stmt.Hptset.empty (* because we don't want b postdoms
+ to depend on the jump *)
in
- Pdg_parameters.debug ~dkey ~level:2
- "pd_b_but_not_a for a=sid:%d b=sid:%d = %a"
- stmt_a.sid stmt_b.sid Stmt.Hptset.pretty res;
- res
+ Pdg_parameters.debug ~dkey ~level:2
+ "pd_b_but_not_a for a=sid:%d b=sid:%d = %a"
+ stmt_a.sid stmt_b.sid Stmt.Hptset.pretty res;
+ res
end
(*============================================================================*)
@@ -366,11 +366,11 @@ let pd_b_but_not_a infos stmt_a stmt_b =
*
* {v = U (PDB (if, succs(if)) v}
* (see the document to know more about the applied algorithm).
- *)
+*)
let get_if_controlled_stmts ctrl_dpds_infos stmt =
let _, infos = ctrl_dpds_infos in
let add_pdb_s set succ =
- Stmt.Hptset.union set (pd_b_but_not_a infos stmt succ)
+ Stmt.Hptset.union set (pd_b_but_not_a infos stmt succ)
in
let controlled_stmts = List.fold_left add_pdb_s Stmt.Hptset.empty stmt.succs in
Pdg_parameters.debug ~dkey "controlled_stmt for cond sid:%d = %a"
@@ -378,14 +378,14 @@ let get_if_controlled_stmts ctrl_dpds_infos stmt =
controlled_stmts
let jump_controlled_stmts infos jump label lex_suc =
- Pdg_parameters.debug ~dkey ~level:2
+ Pdg_parameters.debug ~dkey ~level:2
"lex_succ sid:%d = sid:%d" jump.sid lex_suc.sid;
- Pdg_parameters.debug ~dkey ~level:2
+ Pdg_parameters.debug ~dkey ~level:2
"jump succ sid:%d = sid:%d" jump.sid label.sid;
let controlled_stmts =
if lex_suc.sid = label.sid then begin
(* the label is the jump lexical successor: no dpds *)
- Pdg_parameters.debug ~dkey "useless jump sid:%d (label = lex_succ = %d)"
+ Pdg_parameters.debug ~dkey "useless jump sid:%d (label = lex_succ = %d)"
jump.sid lex_suc.sid;
Stmt.Hptset.empty
end else
@@ -395,16 +395,16 @@ let jump_controlled_stmts infos jump label lex_suc =
Stmt.Hptset.remove lex_suc pdb_lex_suc_label
in Stmt.Hptset.union pdb_jump_lex_suc pdb_lex_suc_label
in
- controlled_stmts
+ controlled_stmts
(** let's find the statements which are depending on
-* the jump statement (goto, break, continue) =
- {v PDB(jump,lex_suc) U (PDB(lex_suc,label) - lex_suc) v}
- (see the document to know more about the applied algorithm).
- *)
+ * the jump statement (goto, break, continue) =
+ {v PDB(jump,lex_suc) U (PDB(lex_suc,label) - lex_suc) v}
+ (see the document to know more about the applied algorithm).
+*)
let get_jump_controlled_stmts ctrl_dpds_infos jump =
let lex_succ_graph, infos = ctrl_dpds_infos in
- let lex_suc =
+ let lex_suc =
try Lexical_successors.find lex_succ_graph jump
with Not_found -> assert false
in
@@ -417,16 +417,16 @@ let get_jump_controlled_stmts ctrl_dpds_infos jump =
(** Try to process [while(1) S; LS: ] as [L: S; goto L; LS: ] *)
let get_loop_controlled_stmts ctrl_dpds_infos loop =
let lex_succ_graph, infos = ctrl_dpds_infos in
- let lex_suc =
- try Lexical_successors.find lex_succ_graph loop
+ let lex_suc =
+ try Lexical_successors.find lex_succ_graph loop
with Not_found -> (* must have at least a return *) assert false
in
let jump = loop in
let label = match loop.succs with [head] -> head | _ -> assert false in
let controlled_stmts = jump_controlled_stmts infos jump label lex_suc in
- Pdg_parameters.debug ~dkey "controlled_stmt for loop sid:%d = %a"
- loop.sid Stmt.Hptset.pretty controlled_stmts;
- controlled_stmts
+ Pdg_parameters.debug ~dkey "controlled_stmt for loop sid:%d = %a"
+ loop.sid Stmt.Hptset.pretty controlled_stmts;
+ controlled_stmts
(*============================================================================*)
(*
diff --git a/src/plugins/pdg/ctrlDpds.mli b/src/plugins/pdg/ctrlDpds.mli
index bb9ed13c5bb161676e3a06cf4ebcea1321624b31..9e034d845571a1bc2332ff95fb949d5f27c196fb 100644
--- a/src/plugins/pdg/ctrlDpds.mli
+++ b/src/plugins/pdg/ctrlDpds.mli
@@ -24,19 +24,19 @@
type t
(** Compute some information on the function in order to be able to compute
-* the control dependencies later on *)
+ * the control dependencies later on *)
val compute : Kernel_function.t -> t
(** Compute the list of the statements that should have a control dependency
-* on the given IF statement. *)
+ * on the given IF statement. *)
val get_if_controlled_stmts : t -> Cil_types.stmt -> Cil_datatype.Stmt.Hptset.t
(** Compute the list of the statements that should have a control dependency
-* on the given jump statement. This statement can be a [goto] of course,
-* but also a [break], a [continue], or even a loop because CIL transformations
- make them of the form {v while(true) body; v} which is equivalent to
- {v L : body ; goto L; v}
-* *)
+ * on the given jump statement. This statement can be a [goto] of course,
+ * but also a [break], a [continue], or even a loop because CIL transformations
+ make them of the form {v while(true) body; v} which is equivalent to
+ {v L : body ; goto L; v}
+ * *)
val get_jump_controlled_stmts : t -> Cil_types.stmt -> Cil_datatype.Stmt.Hptset.t
val get_loop_controlled_stmts : t -> Cil_types.stmt -> Cil_datatype.Stmt.Hptset.t
diff --git a/src/plugins/pdg/marks.ml b/src/plugins/pdg/marks.ml
index aa18138de6c3363b90bac91a67f588019fc1043e..d401a836a67caa42ee5ecae01066063d95290106 100644
--- a/src/plugins/pdg/marks.ml
+++ b/src/plugins/pdg/marks.ml
@@ -25,31 +25,31 @@ open Cil_datatype
(** compute the marks to propagate in the caller nodes from the marks of
* a function inputs [in_marks].
- *)
+*)
let in_marks_to_caller pdg call m2m ?(rqs=[]) in_marks =
let add_n_m acc n z_opt m =
let select = PdgMarks.mk_select_node ~z_opt n in
match m2m select m with
- | None -> acc
- | Some m -> PdgMarks.add_to_select acc select m
+ | None -> acc
+ | Some m -> PdgMarks.add_to_select acc select m
in
let build rqs (in_key, m) =
match in_key with
- | Signature.InCtrl ->
- add_n_m rqs (!Db.Pdg.find_call_ctrl_node pdg call) None m
- | Signature.InNum in_num ->
- add_n_m rqs (!Db.Pdg.find_call_input_node pdg call in_num) None m
- | Signature.InImpl zone ->
- let nodes, undef =
- !Db.Pdg.find_location_nodes_at_stmt pdg call ~before:true zone
- in
- let rqs =
- List.fold_left (fun acc (n,z) -> add_n_m acc n z m) rqs nodes in
- let rqs = match undef with None -> rqs
- | Some z ->
- match m2m (PdgMarks.mk_select_undef_zone z) m with None -> rqs
- | Some m -> PdgMarks.add_undef_in_to_select rqs undef m
- in rqs
+ | Signature.InCtrl ->
+ add_n_m rqs (!Db.Pdg.find_call_ctrl_node pdg call) None m
+ | Signature.InNum in_num ->
+ add_n_m rqs (!Db.Pdg.find_call_input_node pdg call in_num) None m
+ | Signature.InImpl zone ->
+ let nodes, undef =
+ !Db.Pdg.find_location_nodes_at_stmt pdg call ~before:true zone
+ in
+ let rqs =
+ List.fold_left (fun acc (n,z) -> add_n_m acc n z m) rqs nodes in
+ let rqs = match undef with None -> rqs
+ | Some z ->
+ match m2m (PdgMarks.mk_select_undef_zone z) m with None -> rqs
+ | Some m -> PdgMarks.add_undef_in_to_select rqs undef m
+ in rqs
in List.fold_left build rqs in_marks
(** some new input marks has been added in a called function.
@@ -58,27 +58,27 @@ let in_marks_to_caller pdg call m2m ?(rqs=[]) in_marks =
* returned (Beware that m2m has NOT been called in that case).
* *)
let translate_in_marks pdg_called in_new_marks
- ?(m2m=fun _ _ _ m -> Some m) other_rqs =
- let kf_called = PdgTypes.Pdg.get_kf pdg_called in
- let translate pdg rqs call =
- in_marks_to_caller pdg call (m2m (Some call) pdg) ~rqs in_new_marks
- in
- let build rqs (caller, _) =
- let pdg_caller = !Db.Pdg.get caller in
- let caller_rqs =
- try
+ ?(m2m=fun _ _ _ m -> Some m) other_rqs =
+ let kf_called = PdgTypes.Pdg.get_kf pdg_called in
+ let translate pdg rqs call =
+ in_marks_to_caller pdg call (m2m (Some call) pdg) ~rqs in_new_marks
+ in
+ let build rqs (caller, _) =
+ let pdg_caller = !Db.Pdg.get caller in
+ let caller_rqs =
+ try
let call_stmts = !Db.Pdg.find_call_stmts ~caller kf_called in
- (* TODO : more intelligent merge ? *)
+ (* TODO : more intelligent merge ? *)
let rqs = List.fold_left (translate pdg_caller) [] call_stmts in
- PdgMarks.SelList rqs
+ PdgMarks.SelList rqs
with PdgTypes.Pdg.Top ->
let marks = List.fold_left (fun acc (_, m) -> m::acc) [] in_new_marks
in PdgMarks.SelTopMarks marks (* #345 *)
in
- (pdg_caller, caller_rqs)::rqs
- in
- let res = List.fold_left build other_rqs (!Db.Value.callers kf_called) in
- res
+ (pdg_caller, caller_rqs)::rqs
+ in
+ let res = List.fold_left build other_rqs (!Db.Value.callers kf_called) in
+ res
let call_out_marks_to_called called_pdg m2m ?(rqs=[]) out_marks =
let build rqs (out_key, m) =
@@ -86,16 +86,16 @@ let call_out_marks_to_called called_pdg m2m ?(rqs=[]) out_marks =
let sel =
List.map (fun (n, _z_opt) -> PdgMarks.mk_select_node ~z_opt:None n) nodes in
let sel = match undef with None -> sel
- | Some undef -> (PdgMarks.mk_select_undef_zone undef)::sel
+ | Some undef -> (PdgMarks.mk_select_undef_zone undef)::sel
in
let add acc s = match m2m s m with
- | None -> acc
- | Some m -> (s, m)::acc
+ | None -> acc
+ | Some m -> (s, m)::acc
in
let rqs = List.fold_left add rqs sel in
- rqs
+ rqs
in
- List.fold_left build rqs out_marks
+ List.fold_left build rqs out_marks
let translate_out_mark _pdg m2m other_rqs (call, l) =
let add_list l_out_m called_kf rqs =
@@ -107,44 +107,44 @@ let translate_out_mark _pdg m2m other_rqs (call, l) =
in (called_pdg, PdgMarks.SelList node_marks)::rqs
with PdgTypes.Pdg.Top ->
(* no PDG for this function : forget the new marks
- * because anyway, the source function will be called.
- * *)
+ * because anyway, the source function will be called.
+ * *)
rqs
in
let all_called = Db.Value.call_to_kernel_function call in
Kernel_function.Hptset.fold (add_list l) all_called other_rqs
- (** [add_new_marks_to_rqs pdg new_marks other_rqs] translates [new_marks]
- * that were computed during intraprocedural propagation into requests,
- * and add them to [other_rqs].
- *
- * The functions [in_m2m] and [out_m2m] can be used to modify the marks during
- * propagation :
- *- [in_m2m call_stmt call_in_node mark] :
- provide the mark to propagate to the [call_in_node]
- knowing that the mark of the called function has been modify to [mark]
- *- [out_m2m out_node mark] :
- provide the mark to propagate to the [out_node]
- knowing that a call output mark has been modify to [mark].
- *)
- let translate_marks_to_prop pdg new_marks
- ?(in_m2m=fun _ _ _ m -> Some m)
- ?(out_m2m=fun _ _ _ m -> Some m)
- other_rqs =
- let in_marks, out_marks = new_marks in
- let other_rqs = translate_in_marks pdg in_marks ~m2m:in_m2m other_rqs in
- let rqs =
- List.fold_left (translate_out_mark pdg out_m2m) other_rqs out_marks
- in rqs
+(** [add_new_marks_to_rqs pdg new_marks other_rqs] translates [new_marks]
+ * that were computed during intraprocedural propagation into requests,
+ * and add them to [other_rqs].
+ *
+ * The functions [in_m2m] and [out_m2m] can be used to modify the marks during
+ * propagation :
+ *- [in_m2m call_stmt call_in_node mark] :
+ provide the mark to propagate to the [call_in_node]
+ knowing that the mark of the called function has been modify to [mark]
+ *- [out_m2m out_node mark] :
+ provide the mark to propagate to the [out_node]
+ knowing that a call output mark has been modify to [mark].
+*)
+let translate_marks_to_prop pdg new_marks
+ ?(in_m2m=fun _ _ _ m -> Some m)
+ ?(out_m2m=fun _ _ _ m -> Some m)
+ other_rqs =
+ let in_marks, out_marks = new_marks in
+ let other_rqs = translate_in_marks pdg in_marks ~m2m:in_m2m other_rqs in
+ let rqs =
+ List.fold_left (translate_out_mark pdg out_m2m) other_rqs out_marks
+ in rqs
(** To also use interprocedural propagation, the user can instantiate this
-* functor. This is, of course, not mandatory because one can want to use a more
-* complex propagation (like slicing for instance, that has more than one
-* version for a source function). *)
+ * functor. This is, of course, not mandatory because one can want to use a more
+ * complex propagation (like slicing for instance, that has more than one
+ * version for a source function). *)
module F_Proj (C : PdgMarks.Config) :
PdgMarks.Proj with type mark = C.M.t
- and type call_info = C.M.call_info
+ and type call_info = C.M.call_info
= struct
module F = PdgMarks.F_Fct (C.M)
@@ -172,34 +172,34 @@ module F_Proj (C : PdgMarks.Config) :
info
(** Add the marks to the pdg nodes.
- * @return a merge between the input [other_rqs] and the new requests produced.
- * *)
+ * @return a merge between the input [other_rqs] and the new requests produced.
+ * *)
let apply_fct_rqs proj (pdg, mark_list) other_rqs =
match mark_list with
- | PdgMarks.SelList []
- | PdgMarks.SelTopMarks [] ->
- (* don't want to build the marks when calling [get]
- if there is nothing to do... *)
- other_rqs
- | PdgMarks.SelList mark_list ->
- let fm = get proj pdg in
- let to_prop = F.mark_and_propagate fm mark_list in
- let rqs = translate_marks_to_prop pdg to_prop
- ~in_m2m:C.mark_to_prop_to_caller_input
- ~out_m2m:C.mark_to_prop_to_called_output
- other_rqs in
- rqs
- | PdgMarks.SelTopMarks _marks -> (* TODO #345 *)
- Pdg_parameters.not_yet_implemented "mark propagation in Top PDG"
+ | PdgMarks.SelList []
+ | PdgMarks.SelTopMarks [] ->
+ (* don't want to build the marks when calling [get]
+ if there is nothing to do... *)
+ other_rqs
+ | PdgMarks.SelList mark_list ->
+ let fm = get proj pdg in
+ let to_prop = F.mark_and_propagate fm mark_list in
+ let rqs = translate_marks_to_prop pdg to_prop
+ ~in_m2m:C.mark_to_prop_to_caller_input
+ ~out_m2m:C.mark_to_prop_to_called_output
+ other_rqs in
+ rqs
+ | PdgMarks.SelTopMarks _marks -> (* TODO #345 *)
+ Pdg_parameters.not_yet_implemented "mark propagation in Top PDG"
(** Add the marks to the pdg nodes and also apply all the produced requests
- * to do the interprocedural propagation. *)
+ * to do the interprocedural propagation. *)
let mark_and_propagate proj pdg node_marks =
let rec apply_all rqs = match rqs with
| [] -> ()
| rq :: tl_rqs ->
- let new_rqs = apply_fct_rqs proj rq tl_rqs in
- apply_all new_rqs
+ let new_rqs = apply_fct_rqs proj rq tl_rqs in
+ apply_all new_rqs
in apply_all [(pdg, PdgMarks.SelList node_marks)]
end
diff --git a/src/plugins/pdg/marks.mli b/src/plugins/pdg/marks.mli
index 04b0dbf66575cae3e65421866d6e38453e0fc9f1..13a1a60583d741774e9bbdec4149ee9b8c9902cc 100644
--- a/src/plugins/pdg/marks.mli
+++ b/src/plugins/pdg/marks.mli
@@ -70,7 +70,7 @@ val translate_marks_to_prop :
module F_Proj (C : Config) :
Proj with type mark = C.M.t
- and type call_info = C.M.call_info
+ and type call_info = C.M.call_info
(*
Local Variables:
diff --git a/src/plugins/pdg/pdg_parameters.ml b/src/plugins/pdg/pdg_parameters.ml
index e2ce648f9323faa61a35853d979872baafc51e0d..3cdf5bfa9345f27c0f1215f622ddadb2ae91524e 100644
--- a/src/plugins/pdg/pdg_parameters.ml
+++ b/src/plugins/pdg/pdg_parameters.ml
@@ -21,46 +21,46 @@
(**************************************************************************)
include Plugin.Register
- (struct
- let name = "pdg"
- let shortname = "pdg"
- let help = "Program Dependence Graph"
- end)
+ (struct
+ let name = "pdg"
+ let shortname = "pdg"
+ let help = "Program Dependence Graph"
+ end)
let output = add_group "Output"
module BuildAll =
WithOutput
(struct
- let option_name = "-pdg"
- let help =
- "build the dependence graph of each function"
- let output_by_default = false
- end)
+ let option_name = "-pdg"
+ let help =
+ "build the dependence graph of each function"
+ let output_by_default = false
+ end)
module BuildFct =
Kernel_function_set
(struct
- let option_name = "-fct-pdg"
- let arg_name = ""
- let help = "build the dependence graph for the specified function"
- end)
+ let option_name = "-fct-pdg"
+ let arg_name = ""
+ let help = "build the dependence graph for the specified function"
+ end)
let () = Parameter_customize.set_group output
module PrintBw =
False(struct
- let option_name = "-codpds"
- let help = "force option -pdg-print to show the co-dependencies rather than the dependencies"
- end)
+ let option_name = "-codpds"
+ let help = "force option -pdg-print to show the co-dependencies rather than the dependencies"
+ end)
let () = Parameter_customize.set_group output
module DotBasename =
Empty_string
(struct
- let option_name = "-pdg-dot"
- let arg_name = "basename"
- let help = "put the PDG of function <f> in basename.f.dot"
- end)
+ let option_name = "-pdg-dot"
+ let arg_name = "basename"
+ let help = "put the PDG of function <f> in basename.f.dot"
+ end)
(*
Local Variables:
diff --git a/src/plugins/pdg/pdg_state.ml b/src/plugins/pdg/pdg_state.ml
index 3ca4c8dd556f86318cfe76ba300571f6997cc3d8..a370827b1514c94f0d97f362ceeec2fac43274af 100644
--- a/src/plugins/pdg/pdg_state.ml
+++ b/src/plugins/pdg/pdg_state.ml
@@ -24,7 +24,7 @@
and provide the dependencies for the data,
ie. it stores for each location the nodes of the pdg where its value
was last defined.
- *)
+*)
let dkey = Pdg_parameters.register_category "state"
@@ -49,9 +49,9 @@ let pretty fmt state =
let add_loc_node state ~exact loc node =
P.debug ~dkey ~level:2 "add_loc_node (%s) : node %a -> %a@."
- (if exact then "exact" else "merge")
- PdgTypes.Node.pretty node
- Locations.Zone.pretty loc ;
+ (if exact then "exact" else "merge")
+ PdgTypes.Node.pretty node
+ Locations.Zone.pretty loc ;
if LocInfo.is_bottom state.loc_info then
(* Do not add anything to a bottom state (which comes from an unreachable
statement *)
@@ -68,20 +68,20 @@ let add_loc_node state ~exact loc node =
make new_loc_info new_outputs
(** this one is very similar to [add_loc_node] except that
-* we want to accumulate the nodes (exact = false) but nonetheless
-* define under_outputs like (exact = true) *)
+ * we want to accumulate the nodes (exact = false) but nonetheless
+ * define under_outputs like (exact = true) *)
let add_init_state_input state loc node =
match loc with
| Locations.Zone.Top(_p,_o) ->
- (* don't add top because it loses everything*)
- state
+ (* don't add top because it loses everything*)
+ state
| _ ->
- let new_info = NodeSetLattice.inject_singleton node in
- let new_loc_info =
- LocInfo.add_binding ~exact:false state.loc_info loc new_info
- in
- let new_outputs = Locations.Zone.link state.under_outputs loc in
- make new_loc_info new_outputs
+ let new_info = NodeSetLattice.inject_singleton node in
+ let new_loc_info =
+ LocInfo.add_binding ~exact:false state.loc_info loc new_info
+ in
+ let new_outputs = Locations.Zone.link state.under_outputs loc in
+ make new_loc_info new_outputs
let test_and_merge ~old new_ =
if LocInfo.is_included new_.loc_info old.loc_info
@@ -89,34 +89,34 @@ let test_and_merge ~old new_ =
then (false, old)
else
(* Catch Bottom states, as under_outputs get a special value *)
- if LocInfo.is_bottom old.loc_info then true, new_
- else if LocInfo.is_bottom new_.loc_info then true, old
- else
- let new_loc_info = LocInfo.join old.loc_info new_.loc_info in
- let new_outputs =
- Locations.Zone.meet old.under_outputs new_.under_outputs
- in
- let new_state =
- { loc_info = new_loc_info ; under_outputs = new_outputs }
- in
- true, new_state
+ if LocInfo.is_bottom old.loc_info then true, new_
+ else if LocInfo.is_bottom new_.loc_info then true, old
+ else
+ let new_loc_info = LocInfo.join old.loc_info new_.loc_info in
+ let new_outputs =
+ Locations.Zone.meet old.under_outputs new_.under_outputs
+ in
+ let new_state =
+ { loc_info = new_loc_info ; under_outputs = new_outputs }
+ in
+ true, new_state
(** returns pairs of (n, z_opt) where n is a node that computes a part of [loc]
-* and z is the intersection between [loc] and the zone computed by the node.
-* @raise Cannot_fold if the state is top (TODO : something better ?)
-* *)
+ * and z is the intersection between [loc] and the zone computed by the node.
+ * @raise Cannot_fold if the state is top (TODO : something better ?)
+ * *)
let get_loc_nodes_and_part state loc =
let process z nodes acc =
if Locations.Zone.intersects z loc then
let z =
if Locations.Zone.equal loc z
then Some loc
- (* Be careful not ot put None here, because if we have n_1 : (s1 =
- s2) and then n_2 : (s1.b = 3) the state looks like :
- s1.a -> n_1; s1.b -> n_2 ; s1.c -> n_1. And if we
- look for s1.a in that state, we get n_1 but this node
- represent more that s1.a even if it is so in the
- state... *)
+ (* Be careful not ot put None here, because if we have n_1 : (s1 =
+ s2) and then n_2 : (s1.b = 3) the state looks like :
+ s1.a -> n_1; s1.b -> n_2 ; s1.c -> n_1. And if we
+ look for s1.a in that state, we get n_1 but this node
+ represent more that s1.a even if it is so in the
+ state... *)
else Some (Locations.Zone.narrow z loc) in
let add n acc =
P.debug ~dkey ~level:2 "get_loc_nodes -> %a@."
diff --git a/src/plugins/pdg/pdg_state.mli b/src/plugins/pdg/pdg_state.mli
index 5e22c11b991e8285ee87698cb690e9f3785ac451..16d48b7222b1c2e90e871ae521c1c3239cfe737f 100644
--- a/src/plugins/pdg/pdg_state.mli
+++ b/src/plugins/pdg/pdg_state.mli
@@ -37,7 +37,7 @@ val add_init_state_input :
(** Kind of 'join' of the two states
but test before if the new state is included in ~old.
- @return (true, old U new) if the result is a new state,
+ @return (true, old U new) if the result is a new state,
(false, old) if new is included in old. *)
val test_and_merge :
old:data_state -> data_state -> bool * data_state
diff --git a/src/plugins/pdg/register.ml b/src/plugins/pdg/register.ml
index 85544202f3650b1e5772ea8205e46e6b9c89bb78..5add8915f1cf8f77a1573dab0f468e71c1755c6f 100644
--- a/src/plugins/pdg/register.ml
+++ b/src/plugins/pdg/register.ml
@@ -23,9 +23,9 @@
let compute = Build.compute_pdg
let pretty ?(bw=false) fmt pdg =
- let kf = PdgTypes.Pdg.get_kf pdg in
- Format.fprintf fmt "@[RESULT for %s:@]@\n@[ %a@]"
- (Kernel_function.get_name kf) (PdgTypes.Pdg.pretty_bw ~bw) pdg
+ let kf = PdgTypes.Pdg.get_kf pdg in
+ Format.fprintf fmt "@[RESULT for %s:@]@\n@[ %a@]"
+ (Kernel_function.get_name kf) (PdgTypes.Pdg.pretty_bw ~bw) pdg
let pretty_node short =
if short then PdgTypes.Node.pretty
@@ -39,10 +39,10 @@ module Tbl =
Kernel_function.Make_Table
(PdgTypes.Pdg)
(struct
- let name = "Pdg.State"
- let dependencies = [] (* postponed because !Db.From.self may
- not exist yet *)
- let size = 17
+ let name = "Pdg.State"
+ let dependencies = [] (* postponed because !Db.From.self may
+ not exist yet *)
+ let size = 17
end)
let () =
Cmdline.run_after_extended_stage
@@ -83,7 +83,7 @@ let () =
Db.Pdg.find_call_out_nodes_to_select := Sets.find_call_out_nodes_to_select;
Db.Pdg.find_in_nodes_to_select_for_this_call :=
- Sets.find_in_nodes_to_select_for_this_call;
+ Sets.find_in_nodes_to_select_for_this_call;
Db.Pdg.direct_dpds := Sets.direct_dpds;
Db.Pdg.direct_ctrl_dpds := Sets.direct_ctrl_dpds;
@@ -124,7 +124,7 @@ let () = Pdg_parameters.BuildAll.set_output_dependencies deps
let compute_for_kf kf =
let all = Pdg_parameters.BuildAll.get () in
(all && !Db.Value.is_called kf) ||
- Kernel_function.Set.mem kf (Pdg_parameters.BuildFct.get ())
+ Kernel_function.Set.mem kf (Pdg_parameters.BuildFct.get ())
let compute () =
!Db.Value.compute ();
@@ -140,7 +140,7 @@ let compute () =
let pp_sep fmt () = Format.pp_print_string fmt "," in
Pdg_parameters.(
debug "Logging keys : %a"
- (Format.pp_print_list ~pp_sep pp_category) (get_debug_keys ()));
+ (Format.pp_print_list ~pp_sep pp_category) (get_debug_keys ()));
if Pdg_parameters.BuildAll.get () then
Pdg_parameters.feedback "====== PDG GRAPH COMPUTED ======"
diff --git a/src/plugins/pdg/sets.ml b/src/plugins/pdg/sets.ml
index e353ca9ec7595607789f12573dc015fb94f653a5..dcc9b49c79593776b0b8b028e10a5a49ac805716 100644
--- a/src/plugins/pdg/sets.ml
+++ b/src/plugins/pdg/sets.ml
@@ -25,8 +25,8 @@
open Cil_types
open PdgIndex
-type nodes_and_undef =
- (PdgTypes.Node.t * Locations.Zone.t option) list * Locations.Zone.t option
+type nodes_and_undef =
+ (PdgTypes.Node.t * Locations.Zone.t option) list * Locations.Zone.t option
let get_init_state pdg =
try Pdg_state.get_init_state (PdgTypes.Pdg.get_states pdg)
@@ -43,21 +43,21 @@ let get_stmt_state pdg stmt =
let find_node pdg key = FctIndex.find_info (PdgTypes.Pdg.get_index pdg) key
(** notice that there can be several nodes if the statement is a call.
-* For If, Switch, ... the node represent only the condition
-* (see find_stmt_nodes below).
+ * For If, Switch, ... the node represent only the condition
+ * (see find_stmt_nodes below).
*)
let find_simple_stmt_nodes pdg stmt =
let idx = PdgTypes.Pdg.get_index pdg in
let key = Key.stmt_key stmt in
(* The call below can raise Not_found if the statement is unreachable *)
let nodes = FctIndex.find_all idx key in
- match stmt.skind with
- | Return _ -> (* also add OutRet *)
- (try
- let ret = FctIndex.find_all idx Key.output_key in
- ret @ nodes
- with Not_found -> nodes)
- | _ -> nodes
+ match stmt.skind with
+ | Return _ -> (* also add OutRet *)
+ (try
+ let ret = FctIndex.find_all idx Key.output_key in
+ ret @ nodes
+ with Not_found -> nodes)
+ | _ -> nodes
let rec add_stmt_nodes pdg nodes s =
let s_nodes =
@@ -76,21 +76,21 @@ let rec add_stmt_nodes pdg nodes s =
in
match s.skind with
| Switch (_,blk,_,_) | Loop (_, blk, _, _, _) | Block blk ->
- Pdg_parameters.debug ~level:2
- " select_stmt_computation on composed stmt %d@." s.sid;
- add_block_stmts_nodes nodes blk
+ Pdg_parameters.debug ~level:2
+ " select_stmt_computation on composed stmt %d@." s.sid;
+ add_block_stmts_nodes nodes blk
| UnspecifiedSequence seq ->
- Pdg_parameters.debug ~level:2
- " select_stmt_computation on composed stmt %d@." s.sid;
- add_block_stmts_nodes nodes (Cil.block_from_unspecified_sequence seq)
+ Pdg_parameters.debug ~level:2
+ " select_stmt_computation on composed stmt %d@." s.sid;
+ add_block_stmts_nodes nodes (Cil.block_from_unspecified_sequence seq)
| If (_,bthen,belse,_) ->
- let nodes = add_block_stmts_nodes nodes bthen in
- add_block_stmts_nodes nodes belse
+ let nodes = add_block_stmts_nodes nodes bthen in
+ add_block_stmts_nodes nodes belse
| _ -> nodes
(** notice that there can be several nodes if the statement is a call.
-* If the stmt is a composed instruction (block, etc), all the nodes of the
-* enclosed statements are considered.
+ * If the stmt is a composed instruction (block, etc), all the nodes of the
+ * enclosed statements are considered.
*)
let find_stmt_and_blocks_nodes pdg stmt =
add_stmt_nodes pdg [] stmt
@@ -111,14 +111,14 @@ let find_loc_nodes pdg state loc =
let init_nodes, init_undef = Pdg_state.get_loc_nodes state undef in
let init_nodes = match loc with
| Locations.Zone.Top(_,_) ->
- begin
- try (find_top_input_node pdg, None)::init_nodes
- with Not_found -> init_nodes
- end
+ begin
+ try (find_top_input_node pdg, None)::init_nodes
+ with Not_found -> init_nodes
+ end
| _ -> init_nodes
in
let nodes = List.fold_left (fun acc n -> n::acc) nodes init_nodes in
- nodes, init_undef
+ nodes, init_undef
| None -> nodes, undef
in
nodes, undef
@@ -143,17 +143,17 @@ let find_location_nodes_at_stmt pdg stmt ~before loc =
else match stmt.skind, stmt.succs with
| Return _, [] -> get_nodes (get_last_state pdg)
| _, [] -> (* no successors but not a return => unreachable *)
- raise Not_found
+ raise Not_found
| _, succs ->
- get_stmts_nodes succs
+ get_stmts_nodes succs
in nodes, undef_zone
let find_location_nodes_at_end pdg loc =
find_loc_nodes pdg (get_last_state pdg) loc
(* be careful that begin is different from init because
-* init_state only contains implicit inputs
-* while begin contains only formal arguments *)
+ * init_state only contains implicit inputs
+ * while begin contains only formal arguments *)
let find_location_nodes_at_begin pdg loc =
let kf = PdgTypes.Pdg.get_kf pdg in
let stmts =
@@ -241,8 +241,8 @@ let add_node_in_list node node_list =
else (node :: node_list), true
(** add the node to the list. It it wasn't already in the list,
-* recursively call the same function on the successors or/and predecessors
-* according to the flags. *)
+ * recursively call the same function on the successors or/and predecessors
+ * according to the flags. *)
let rec add_node_and_custom_dpds get_dpds node_list node =
let node_list, added = add_node_in_list node node_list in
if added
@@ -250,9 +250,9 @@ let rec add_node_and_custom_dpds get_dpds node_list node =
let is_block = match PdgTypes.Node.elem_key node with
| Key.SigKey (PdgIndex.Signature.In PdgIndex.Signature.InCtrl) -> true
| Key.Stmt stmt ->
- (match stmt.skind with
- Block _ | UnspecifiedSequence _ -> true
- | _ -> false)
+ (match stmt.skind with
+ Block _ | UnspecifiedSequence _ -> true
+ | _ -> false)
| _ -> false
in
if is_block
@@ -275,7 +275,7 @@ let filter_nodes l = List.map (fun (n,_) -> n) l
(** gives the list of nodes that the given node depends on,
without looking at the kind of dependency. *)
-let direct_dpds pdg node =
+let direct_dpds pdg node =
filter_nodes (PdgTypes.Pdg.get_all_direct_dpds pdg node)
(** gives the list of nodes that the given node depends on,
@@ -311,7 +311,7 @@ let find_nodes_all_addr_dpds = find_nodes_all_x_dpds PdgTypes.Dpd.Addr
(** {3 Forward} build sets of the nodes that depend on given nodes *)
(** @return the list of nodes that directly depend on the given node *)
-let direct_uses pdg node =
+let direct_uses pdg node =
filter_nodes (PdgTypes.Pdg.get_all_direct_codpds pdg node)
let direct_x_uses dpd_type pdg node =
@@ -343,7 +343,7 @@ let node_set_of_list l =
intersects [called_selected_nodes]. *)
let find_call_out_nodes_to_select
pdg_called called_selected_nodes pdg_caller call_stmt
- =
+ =
Pdg_parameters.debug ~level:2
"[pdg:find_call_out_nodes_to_select] for call sid:%d@."
call_stmt.sid;
@@ -385,7 +385,7 @@ let find_in_nodes_to_select_for_this_call
caller_nodes
in
if intersect then begin
- Pdg_parameters.debug ~level:2 "\t+ %a@."
+ Pdg_parameters.debug ~level:2 "\t+ %a@."
PdgTypes.Node.pretty in_node;
in_node::acc
end else
diff --git a/src/plugins/pdg/sets.mli b/src/plugins/pdg/sets.mli
index d7a883585ce39b77949f8ccbccf5b745272f06e3..254b115ecf0518dfc732bfbd78d52093c65e63bc 100644
--- a/src/plugins/pdg/sets.mli
+++ b/src/plugins/pdg/sets.mli
@@ -24,8 +24,8 @@
open Cil_types
-type nodes_and_undef =
- (PdgTypes.Node.t * Locations.Zone.t option) list * Locations.Zone.t option
+type nodes_and_undef =
+ (PdgTypes.Node.t * Locations.Zone.t option) list * Locations.Zone.t option
(** {2 PDG nodes for some elements} *)
@@ -34,9 +34,9 @@ val find_simple_stmt_nodes: PdgTypes.Pdg.t -> stmt -> PdgTypes.Node.t list
val find_stmt_and_blocks_nodes: PdgTypes.Pdg.t -> stmt -> PdgTypes.Node.t list
val find_location_nodes_at_stmt:
PdgTypes.Pdg.t -> stmt -> before:bool -> Locations.Zone.t -> nodes_and_undef
-val find_location_nodes_at_end:
+val find_location_nodes_at_end:
PdgTypes.Pdg.t -> Locations.Zone.t -> nodes_and_undef
-val find_location_nodes_at_begin:
+val find_location_nodes_at_begin:
PdgTypes.Pdg.t -> Locations.Zone.t -> nodes_and_undef
val find_label_node: PdgTypes.Pdg.t -> stmt -> label -> PdgTypes.Node.t
val find_decl_var_node: PdgTypes.Pdg.t -> varinfo -> PdgTypes.Node.t
@@ -45,7 +45,7 @@ val find_output_node: PdgTypes.Pdg.t -> PdgTypes.Node.t
val find_all_input_nodes: PdgTypes.Pdg.t -> PdgTypes.Node.t list
val find_entry_point_node: PdgTypes.Pdg.t -> PdgTypes.Node.t
val find_top_input_node: PdgTypes.Pdg.t -> PdgTypes.Node.t
-val find_output_nodes:
+val find_output_nodes:
PdgTypes.Pdg.t -> PdgIndex.Signature.out_key -> nodes_and_undef
@@ -58,11 +58,11 @@ val find_call_output_node: PdgTypes.Pdg.t -> stmt -> PdgTypes.Node.t
val find_call_stmts: kernel_function -> caller:kernel_function -> stmt list
val find_call_out_nodes_to_select:
- PdgTypes.Pdg.t -> PdgTypes.NodeSet.t -> PdgTypes.Pdg.t -> stmt ->
+ PdgTypes.Pdg.t -> PdgTypes.NodeSet.t -> PdgTypes.Pdg.t -> stmt ->
PdgTypes.Node.t list
val find_in_nodes_to_select_for_this_call:
- PdgTypes.Pdg.t -> PdgTypes.NodeSet.t -> stmt -> PdgTypes.Pdg.t ->
+ PdgTypes.Pdg.t -> PdgTypes.NodeSet.t -> stmt -> PdgTypes.Pdg.t ->
PdgTypes.Node.t list
(** direct dependencies only:
@@ -76,11 +76,11 @@ val direct_addr_dpds: PdgTypes.Pdg.t -> PdgTypes.Node.t -> PdgTypes.Node.t list
val find_nodes_all_dpds:
PdgTypes.Pdg.t -> PdgTypes.Node.t list -> PdgTypes.Node.t list
-val find_nodes_all_data_dpds:
+val find_nodes_all_data_dpds:
PdgTypes.Pdg.t -> PdgTypes.Node.t list -> PdgTypes.Node.t list
-val find_nodes_all_ctrl_dpds:
+val find_nodes_all_ctrl_dpds:
PdgTypes.Pdg.t -> PdgTypes.Node.t list -> PdgTypes.Node.t list
-val find_nodes_all_addr_dpds:
+val find_nodes_all_addr_dpds:
PdgTypes.Pdg.t -> PdgTypes.Node.t list -> PdgTypes.Node.t list
(** forward *)
@@ -94,6 +94,6 @@ val all_uses: PdgTypes.Pdg.t -> PdgTypes.Node.t list -> PdgTypes.Node.t list
(** others *)
-val custom_related_nodes:
- (PdgTypes.Node.t -> PdgTypes.Node.t list) -> PdgTypes.Node.t list ->
+val custom_related_nodes:
+ (PdgTypes.Node.t -> PdgTypes.Node.t list) -> PdgTypes.Node.t list ->
PdgTypes.Node.t list
diff --git a/src/plugins/pdg_types/pdgIndex.ml b/src/plugins/pdg_types/pdgIndex.ml
index bd2714e513f4da2552eb945ba9a9549984738741..5781074508a5f200a16c3431553b8c5268b42835 100644
--- a/src/plugins/pdg_types/pdgIndex.ml
+++ b/src/plugins/pdg_types/pdgIndex.ml
@@ -30,8 +30,8 @@ exception Not_equal
let is_call_stmt stmt =
match stmt.skind with
- | Instr (Call _|Local_init(_,ConsInit _,_)) -> true
- | _ -> false
+ | Instr (Call _|Local_init(_,ConsInit _,_)) -> true
+ | _ -> false
module Signature = struct
type in_key = InCtrl | InNum of int | InImpl of Locations.Zone.t
@@ -39,14 +39,14 @@ module Signature = struct
type key = In of in_key | Out of out_key
type 'info t =
- { in_ctrl : 'info option ;
- in_params : (int * 'info) list ;
- (** implicit inputs :
- Maybe we should use [Lmap_bitwise.Make_bitwise] ?
- but that would make things a lot more complicated... :-? *)
- in_implicits : (Locations.Zone.t * 'info) list ;
- out_ret : 'info option ;
- outputs : (Locations.Zone.t * 'info) list }
+ { in_ctrl : 'info option ;
+ in_params : (int * 'info) list ;
+ (** implicit inputs :
+ Maybe we should use [Lmap_bitwise.Make_bitwise] ?
+ but that would make things a lot more complicated... :-? *)
+ in_implicits : (Locations.Zone.t * 'info) list ;
+ out_ret : 'info option ;
+ outputs : (Locations.Zone.t * 'info) list }
module Str_descr = struct
open Structural_descr
@@ -55,14 +55,14 @@ module Signature = struct
let key = t_sum [| [| pack in_key |]; [| pack out_key |] |]
let t d_info = t_record
- [| pack (t_option d_info);
- pack (t_list (t_tuple [| p_int; pack d_info |]));
- pack (t_list (t_tuple [| Locations.Zone.packed_descr;
- pack d_info |]));
- pack (t_option d_info);
- pack (t_list (t_tuple [| Locations.Zone.packed_descr;
- pack d_info |]));
- |]
+ [| pack (t_option d_info);
+ pack (t_list (t_tuple [| p_int; pack d_info |]));
+ pack (t_list (t_tuple [| Locations.Zone.packed_descr;
+ pack d_info |]));
+ pack (t_option d_info);
+ pack (t_list (t_tuple [| Locations.Zone.packed_descr;
+ pack d_info |]));
+ |]
end
let empty = { in_ctrl = None ;
@@ -103,25 +103,25 @@ module Signature = struct
try (0 = cmp_out_key k1 k2) with Not_equal -> false
(** add a mapping between [num] and [info] in [lst].
- * if we already have something for [num], use function [merge] *)
+ * if we already have something for [num], use function [merge] *)
let add_in_list lst num info merge =
let new_e = (num, info) in
let rec add_to_l l =
match l with [] -> [new_e]
- | (ne, old_e) as e :: tl ->
- if ne = num then
- let e = merge old_e info in (num, e)::tl
- else if ne < num then e :: (add_to_l tl) else new_e :: l
+ | (ne, old_e) as e :: tl ->
+ if ne = num then
+ let e = merge old_e info in (num, e)::tl
+ else if ne < num then e :: (add_to_l tl) else new_e :: l
in add_to_l lst
let add_loc l_loc loc info merge =
let rec add lst = match lst with
| [] -> [(loc, info)]
| (l, e)::tl ->
- if Locations.Zone.equal l loc then
- let new_e = merge e info in (loc, new_e)::tl
- else
- begin
+ if Locations.Zone.equal l loc then
+ let new_e = merge e info in (loc, new_e)::tl
+ else
+ begin
(*
if (Locations.Zone.intersects l loc) then
begin
@@ -130,8 +130,8 @@ module Signature = struct
assert false
end;
*)
- (l, e)::(add tl)
- end
+ (l, e)::(add tl)
+ end
in add l_loc
let add_replace replace _old_e new_e =
@@ -139,33 +139,33 @@ module Signature = struct
let add_input sgn n info ~replace =
{ sgn with in_params =
- add_in_list sgn.in_params n info (add_replace replace) }
+ add_in_list sgn.in_params n info (add_replace replace) }
let add_impl_input sgn loc info ~replace =
{ sgn with in_implicits =
- add_loc sgn.in_implicits loc info (add_replace replace) }
+ add_loc sgn.in_implicits loc info (add_replace replace) }
let add_output sgn loc info ~replace =
{ sgn with outputs =
- add_loc sgn.outputs loc info (add_replace replace) }
+ add_loc sgn.outputs loc info (add_replace replace) }
let add_in_ctrl sgn info ~replace =
let new_info = match sgn.in_ctrl with None -> info
- | Some old -> add_replace replace old info
+ | Some old -> add_replace replace old info
in { sgn with in_ctrl = Some new_info }
let add_out_ret sgn info ~replace =
let new_info = match sgn.out_ret with None -> info
- | Some old -> add_replace replace old info
+ | Some old -> add_replace replace old info
in { sgn with out_ret = Some new_info }
let add_info sgn key info ~replace =
match key with
- | In InCtrl -> add_in_ctrl sgn info replace
- | In (InNum n) -> add_input sgn n info replace
- | In (InImpl loc) -> add_impl_input sgn loc info replace
- | Out OutRet -> add_out_ret sgn info replace
- | Out (OutLoc k) -> add_output sgn k info replace
+ | In InCtrl -> add_in_ctrl sgn info replace
+ | In (InNum n) -> add_input sgn n info replace
+ | In (InImpl loc) -> add_impl_input sgn loc info replace
+ | Out OutRet -> add_out_ret sgn info replace
+ | Out (OutLoc k) -> add_output sgn k info replace
let find_input sgn n =
try
@@ -178,10 +178,10 @@ module Signature = struct
let rec find l = match l with
| [] -> raise Not_found
| (loc, e)::tl ->
- if Locations.Zone.equal out_key loc then e
- else find tl
+ if Locations.Zone.equal out_key loc then e
+ else find tl
in
- find sgn.outputs
+ find sgn.outputs
let find_out_ret sgn = match sgn.out_ret with
| Some i -> i
@@ -192,13 +192,13 @@ module Signature = struct
| None -> raise Not_found
(** try to find an exact match with loc.
- * we shouldn't try to find a zone that we don't have... *)
+ * we shouldn't try to find a zone that we don't have... *)
let find_implicit_input sgn loc =
let rec find l = match l with
| [] -> raise Not_found
| (in_loc, e)::tl ->
- if Locations.Zone.equal in_loc loc then e
- else find tl
+ if Locations.Zone.equal in_loc loc then e
+ else find tl
in
find sgn.in_implicits
@@ -280,12 +280,12 @@ module Signature = struct
| (InNum n) -> Format.fprintf fmt "In%d" n
| InCtrl -> Format.fprintf fmt "InCtrl"
| InImpl loc ->
- Format.fprintf fmt "@[<hv 1>In(%a)@]" Locations.Zone.pretty loc
+ Format.fprintf fmt "@[<hv 1>In(%a)@]" Locations.Zone.pretty loc
let pretty_out_key fmt key = match key with
| OutRet -> Format.fprintf fmt "OutRet"
| OutLoc loc ->
- Format.fprintf fmt "@[<hv 1>Out(%a)@]" Locations.Zone.pretty loc
+ Format.fprintf fmt "@[<hv 1>Out(%a)@]" Locations.Zone.pretty loc
let pretty_key fmt key = match key with
| In in_key -> pretty_in_key fmt in_key
@@ -294,7 +294,7 @@ module Signature = struct
let pretty pp fmt sgn =
Pretty_utils.pp_iter ~pre:"@[<v>" ~suf:"@]" ~sep:"@," iter
(fun fmt (k,i) ->
- Format.fprintf fmt "@[<hv>(%a:@ %a)@]" pretty_key k pp i)
+ Format.fprintf fmt "@[<hv>(%a:@ %a)@]" pretty_key k pp i)
fmt sgn
end
@@ -303,18 +303,18 @@ module Key = struct
type key =
| SigKey of Signature.key
- (** input/output nodes of the function *)
+ (** input/output nodes of the function *)
| VarDecl of Cil_types.varinfo
- (** local, parameter or global variable definition *)
+ (** local, parameter or global variable definition *)
| Stmt of Cil_types.stmt
- (** simple statement (not call) excluding its label (stmt.id) *)
+ (** simple statement (not call) excluding its label (stmt.id) *)
| CallStmt of Cil_types.stmt
- (** call statement *)
+ (** call statement *)
| Label of stmt * Cil_types.label
- (** Labels are considered as function elements by themselves. *)
+ (** Labels are considered as function elements by themselves. *)
| SigCallKey of Cil_types.stmt * Signature.key
- (** Key for an element of a call (input or output).
- * The call is identified by the statement. *)
+ (** Key for an element of a call (input or output).
+ * The call is identified by the statement. *)
let entry_point = SigKey (Signature.in_ctrl_key)
let top_input = SigKey (Signature.in_top_key)
@@ -341,11 +341,11 @@ module Key = struct
let stmt key =
match key with
- | SigCallKey (call, _) -> Some call
- | CallStmt call -> Some call
- | Stmt stmt -> Some stmt
- | Label (stmt, _) -> Some stmt
- | _ -> None
+ | SigCallKey (call, _) -> Some call
+ | CallStmt call -> Some call
+ | Stmt stmt -> Some stmt
+ | Label (stmt, _) -> Some stmt
+ | _ -> None
(* see PrintPdg.pretty_key : can't be here because it uses Db... *)
let pretty_node fmt k =
@@ -357,7 +357,7 @@ module Key = struct
| Block _ -> Format.pp_print_string fmt "block"
| Goto _ | Break _ | Continue _ | Return _ | Instr _ | Throw _ ->
Format.fprintf fmt "@[<h 1>%a@]"
- (Printer.without_annot Printer.pp_stmt) s
+ (Printer.without_annot Printer.pp_stmt) s
| UnspecifiedSequence _ ->
Format.pp_print_string fmt "unspecified sequence"
| TryExcept _ | TryFinally _ | TryCatch _ ->
@@ -377,36 +377,36 @@ module Key = struct
call.sid Signature.pretty_key sgn print_stmt call
include Datatype.Make
- (struct
- include Datatype.Serializable_undefined
- type t = key
- let name = "PdgIndex.Key"
- open Cil_datatype
- let reprs =
- List.fold_left
- (fun acc v ->
- List.fold_left
- (fun acc s -> Stmt s :: acc)
- (VarDecl v :: acc)
- Stmt.reprs)
- []
- Varinfo.reprs
- open Structural_descr
- let structural_descr =
- let p_key = pack Signature.Str_descr.key in
- t_sum
- [|
- [| p_key |];
- [| Varinfo.packed_descr |];
- [| Stmt.packed_descr |];
- [| Cil_datatype.Stmt.packed_descr |];
- [| Cil_datatype.Stmt.packed_descr; Label.packed_descr |];
- [| Cil_datatype.Stmt.packed_descr; p_key |];
- |]
- let rehash = Datatype.identity
- let pretty = pretty_node
- let mem_project = Datatype.never_any_project
- end)
+ (struct
+ include Datatype.Serializable_undefined
+ type t = key
+ let name = "PdgIndex.Key"
+ open Cil_datatype
+ let reprs =
+ List.fold_left
+ (fun acc v ->
+ List.fold_left
+ (fun acc s -> Stmt s :: acc)
+ (VarDecl v :: acc)
+ Stmt.reprs)
+ []
+ Varinfo.reprs
+ open Structural_descr
+ let structural_descr =
+ let p_key = pack Signature.Str_descr.key in
+ t_sum
+ [|
+ [| p_key |];
+ [| Varinfo.packed_descr |];
+ [| Stmt.packed_descr |];
+ [| Cil_datatype.Stmt.packed_descr |];
+ [| Cil_datatype.Stmt.packed_descr; Label.packed_descr |];
+ [| Cil_datatype.Stmt.packed_descr; p_key |];
+ |]
+ let rehash = Datatype.identity
+ let pretty = pretty_node
+ let mem_project = Datatype.never_any_project
+ end)
end
@@ -425,14 +425,14 @@ module RKey = struct
There seems to be bug in the pdg, only one 'case :' per statement is
present. This avoids removing the other 'case' clauses
(see tests/slicing/switch.c *)
- 53 * Cil_datatype.Stmt.hash s (* 7 * Cil_datatype.Label.hash l *)
+ 53 * Cil_datatype.Stmt.hash s (* 7 * Cil_datatype.Label.hash l *)
| _ -> assert false
let equal k1 k2 = match k1, k2 with
| Key.VarDecl v1, Key.VarDecl v2 -> Cil_datatype.Varinfo.equal v1 v2
| Key.Stmt s1, Key.Stmt s2 -> Cil_datatype.Stmt.equal s1 s2
| Key.Label (s1, _l1), Key.Label (s2, _l2) ->
- (* See [hash] above *)
+ (* See [hash] above *)
Cil_datatype.Stmt.equal s1 s2 (* && Cil_datatype.Label.equal l1 l2 *)
| _ -> false
end
@@ -444,12 +444,12 @@ module H = struct
end
module FctIndex = struct
-
+
type ('node_info, 'call_info) t = {
(** inputs and outputs of the function *)
mutable sgn : 'node_info Signature.t ;
(** calls signatures *)
- mutable calls :
+ mutable calls :
(Cil_types.stmt * ('call_info option * 'node_info Signature.t)) list ;
(** everything else *)
other : 'node_info H.t
@@ -461,9 +461,9 @@ module FctIndex = struct
[| pack (Signature.Str_descr.t d_ninfo);
pack (t_list (t_tuple [| Cil_datatype.Stmt.packed_descr;
pack (t_tuple [|
- pack (t_option d_cinfo);
- pack (Signature.Str_descr.t d_ninfo);
- |])
+ pack (t_option d_cinfo);
+ pack (Signature.Str_descr.t d_ninfo);
+ |])
|]));
pack (H.structural_descr d_ninfo);
|]
@@ -479,22 +479,22 @@ module FctIndex = struct
let merge_info_calls calls1 calls2 merge_a merge_b =
let merge_info (b1, sgn1) (b2, sgn2) =
let b = match b1, b2 with None, _ -> b2 | _, None -> b1
- | Some b1, Some b2 -> Some (merge_b b1 b2)
+ | Some b1, Some b2 -> Some (merge_b b1 b2)
in let sgn = Signature.merge sgn1 sgn2 merge_a in
- (b, sgn)
+ (b, sgn)
in
let rec merge l1 l2 = match l1, l2 with
| [], _ -> l2
| _, [] -> l1
| ((call1, info1) as c1) :: tl1,
((call2, info2) as c2) :: tl2 ->
- let id1 = call1.sid in
- let id2 = call2.sid in
- if id1 = id2 then
- let info = merge_info info1 info2 in
- (call1, info) :: (merge tl1 tl2)
- else if id1 < id2 then c1 :: (merge tl1 l2)
- else c2 :: (merge l1 tl2)
+ let id1 = call1.sid in
+ let id2 = call2.sid in
+ if id1 = id2 then
+ let info = merge_info info1 info2 in
+ (call1, info) :: (merge tl1 tl2)
+ else if id1 < id2 then c1 :: (merge tl1 l2)
+ else c2 :: (merge l1 tl2)
in merge calls1 calls2
let merge idx1 idx2 merge_a merge_b =
@@ -507,60 +507,60 @@ module FctIndex = struct
in H.replace table k a
in H.iter add idx2.other;
let calls = merge_info_calls idx1.calls idx2.calls merge_a merge_b in
- {sgn = sgn; calls = calls; other = table}
+ {sgn = sgn; calls = calls; other = table}
let add_info_call idx call e ~replace =
let sid = call.sid in
let rec add l = match l with
| [] -> [(call, (Some e, Signature.empty))]
| ((call1, (_e1, sgn1)) as c1) :: tl ->
- let sid1 = call1.sid in
- if sid = sid1 then
- (if replace then (call, (Some e, sgn1)) :: tl else raise AddError)
- else if sid < sid1 then
- (call, (Some e, Signature.empty)) :: l
- else c1 :: (add tl)
+ let sid1 = call1.sid in
+ if sid = sid1 then
+ (if replace then (call, (Some e, sgn1)) :: tl else raise AddError)
+ else if sid < sid1 then
+ (call, (Some e, Signature.empty)) :: l
+ else c1 :: (add tl)
in idx.calls <- add idx.calls
let add_info_call_key idx key =
match key with
| Key.CallStmt call -> add_info_call idx call
- | _ -> assert false
+ | _ -> assert false
let add_info_sig_call calls call k e replace =
let new_sgn old = Signature.add_info old k e replace in
let rec add l = match l with
| [] -> [(call, (None, new_sgn Signature.empty))]
| ((call1, (e1, sgn1)) as c1) :: tl ->
- let sid = call.sid in
- let sid1 = call1.sid in
- if sid = sid1
- then (call, (e1, new_sgn sgn1)) :: tl
- else if sid < sid1
- then (call, (None, new_sgn Signature.empty)) :: l
- else (c1 :: (add tl))
+ let sid = call.sid in
+ let sid1 = call1.sid in
+ if sid = sid1
+ then (call, (e1, new_sgn sgn1)) :: tl
+ else if sid < sid1
+ then (call, (None, new_sgn Signature.empty)) :: l
+ else (c1 :: (add tl))
in add calls
let find_call idx call =
let rec find l = match l with
| [] -> raise Not_found
| (call1, e1) :: tl ->
- let sid = call.sid in
- let sid1 = call1.sid in
- if sid = sid1 then e1
- else if sid < sid1 then raise Not_found
- else find tl
+ let sid = call.sid in
+ let sid1 = call1.sid in
+ if sid = sid1 then e1
+ else if sid < sid1 then raise Not_found
+ else find tl
in
find idx.calls
let find_call_key idx key =
match key with
| Key.CallStmt call -> find_call idx call
- | _ -> assert false
+ | _ -> assert false
let find_info_call idx call =
let (e1, _sgn1) = find_call idx call in
- match e1 with Some e -> e | None -> raise Not_found
+ match e1 with Some e -> e | None -> raise Not_found
let find_info_call_key idx key =
match key with
@@ -569,21 +569,21 @@ module FctIndex = struct
let find_info_sig_call idx call k =
let (_e1, sgn1) = find_call idx call in
- Signature.find_info sgn1 k
+ Signature.find_info sgn1 k
let find_all_info_sig_call idx call =
- let (_e1, sgn1) = find_call idx call in
- Signature.fold (fun l (_k,i) -> i::l) [] sgn1
+ let (_e1, sgn1) = find_call idx call in
+ Signature.fold (fun l (_k,i) -> i::l) [] sgn1
let add_replace idx key e replace =
let hfct = if replace then H.replace else H.add in
match key with
- | Key.SigKey k ->
- idx.sgn <- Signature.add_info idx.sgn k e replace
- | Key.CallStmt _ -> raise CallStatement (* see add_info_call *)
- | Key.SigCallKey (call, k) ->
- idx.calls <- add_info_sig_call idx.calls call k e replace
- | Key.VarDecl _ | Key.Stmt _ | Key.Label _ -> hfct idx.other key e
+ | Key.SigKey k ->
+ idx.sgn <- Signature.add_info idx.sgn k e replace
+ | Key.CallStmt _ -> raise CallStatement (* see add_info_call *)
+ | Key.SigCallKey (call, k) ->
+ idx.calls <- add_info_sig_call idx.calls call k e replace
+ | Key.VarDecl _ | Key.Stmt _ | Key.Label _ -> hfct idx.other key e
let add idx key e = add_replace idx key e false
@@ -593,42 +593,42 @@ module FctIndex = struct
let find_info idx key =
match key with
- | Key.SigKey k -> Signature.find_info idx.sgn k
- | Key.CallStmt _ -> raise CallStatement (* see find_info_call *)
- | Key.SigCallKey (call, k) -> find_info_sig_call idx call k
- | Key.VarDecl _ | Key.Stmt _ | Key.Label _ ->
- (try H.find idx.other key
- with Not_found -> raise Not_found)
+ | Key.SigKey k -> Signature.find_info idx.sgn k
+ | Key.CallStmt _ -> raise CallStatement (* see find_info_call *)
+ | Key.SigCallKey (call, k) -> find_info_sig_call idx call k
+ | Key.VarDecl _ | Key.Stmt _ | Key.Label _ ->
+ (try H.find idx.other key
+ with Not_found -> raise Not_found)
let find_all idx key =
match key with
- | Key.CallStmt call -> find_all_info_sig_call idx call
- | _ -> let info = find_info idx key in [info]
+ | Key.CallStmt call -> find_all_info_sig_call idx call
+ | _ -> let info = find_info idx key in [info]
let find_label idx lab =
let collect k info res = match k with
- | Key.Label (_,k_lab) ->
- if Cil_datatype.Label.equal k_lab lab then info :: res else res
+ | Key.Label (_,k_lab) ->
+ if Cil_datatype.Label.equal k_lab lab then info :: res else res
| _ -> res
in
let infos = H.fold collect idx.other [] in
- match infos with
- info :: [] -> info | [] -> raise Not_found | _ -> assert false
+ match infos with
+ info :: [] -> info | [] -> raise Not_found | _ -> assert false
let fold_calls f idx acc =
let process acc (call, (_i, _sgn as i_sgn)) = f call i_sgn acc in
List.fold_left process acc idx.calls
let fold f idx acc =
- let acc = Signature.fold
- (fun acc (k, info) -> f (Key.SigKey k) info acc)
- acc idx.sgn in
+ let acc = Signature.fold
+ (fun acc (k, info) -> f (Key.SigKey k) info acc)
+ acc idx.sgn in
let acc = H.fold (fun k info acc -> f k info acc) idx.other acc in
- List.fold_left
- (fun acc (call, (_, sgn)) ->
- Signature.fold (fun acc (k, info) ->
- f (Key.SigCallKey (call, k)) info acc)
- acc sgn)
+ List.fold_left
+ (fun acc (call, (_, sgn)) ->
+ Signature.fold (fun acc (k, info) ->
+ f (Key.SigCallKey (call, k)) info acc)
+ acc sgn)
acc idx.calls
end
diff --git a/src/plugins/pdg_types/pdgIndex.mli b/src/plugins/pdg_types/pdgIndex.mli
index c210aad1e1b42b275b00cd9fe9eec9b57307d2c6..75eb698c74c0c31d1bb5e4362ace247876738475 100644
--- a/src/plugins/pdg_types/pdgIndex.mli
+++ b/src/plugins/pdg_types/pdgIndex.mli
@@ -46,7 +46,7 @@ exception Not_equal
(** What we call a [Signature] a mapping between keys that represent either a
* function input or output, and some information.
- *)
+*)
module Signature : sig
(** type of a signature where ['a] is the type of the information that we *
@@ -55,14 +55,14 @@ module Signature : sig
(** key for input elements *)
type in_key =
- private
+ private
| InCtrl (** input control point *)
| InNum of int (** parameters numbered from 1 *)
| InImpl of Locations.Zone.t (** key for implicit inputs.
Used in function signatures only *)
type out_key =
- private
+ private
| OutRet (** key for the output corresponding to the [return] *)
| OutLoc of Locations.Zone.t (** key for output locations.
used in call signatures only *)
@@ -109,7 +109,7 @@ end
module Key : sig
type key =
- private
+ private
| SigKey of Signature.key
(** key for an element of the function signature *)
| VarDecl of Cil_types.varinfo (** variable declaration *)
@@ -149,15 +149,15 @@ end
(** Mapping between the function elements we are interested in and some
* information. Used for instance to associate the nodes with the statements,
* or the marks in a slice.
- *)
+*)
module FctIndex : sig
(** this type is used to build indexes between program objects and some
information such as the PDG nodes or the slicing marks.
- ['ni] if the type of the information to store for each element,
- ['ci] if the type of the information that can be attached to call
- statements (calls are themselves composed of several elements, so ['ni]
- information stored for each of them (['ni Signature.t])) *)
+ statements (calls are themselves composed of several elements, so ['ni]
+ information stored for each of them (['ni Signature.t])) *)
type ('ni, 'ci) t
val create : int -> ('ni, 'ci) t
@@ -170,9 +170,9 @@ module FctIndex : sig
These function are _not_ called when an element is in one index,
but not the other. It is assumed that [merge_x x bot = x]. *)
val merge : ('ni, 'ci) t -> ('ni, 'ci) t ->
- ('ni -> 'ni -> 'ni) ->
- ('ci -> 'ci -> 'ci) ->
- ('ni, 'ci) t
+ ('ni -> 'ni -> 'ni) ->
+ ('ci -> 'ci -> 'ci) ->
+ ('ni, 'ci) t
(** get the information stored for the function signature *)
val sgn : ('ni, 'ci) t -> 'ni Signature.t
diff --git a/src/plugins/pdg_types/pdgMarks.ml b/src/plugins/pdg_types/pdgMarks.ml
index cd4cba14dc88af865db27da6e3b26c061bc49d7a..af704da395db0a6db39a2789e35c2fb7d6fb2410 100644
--- a/src/plugins/pdg_types/pdgMarks.ml
+++ b/src/plugins/pdg_types/pdgMarks.ml
@@ -21,17 +21,17 @@
(**************************************************************************)
(** This file provides useful things to help to associate an information
-* (called mark) to PDG elements and to propagate it across the
-* dependencies.
+ * (called mark) to PDG elements and to propagate it across the
+ * dependencies.
*)
open PdgIndex
type select_elem =
| SelNode of PdgTypes.Node.t * Locations.Zone.t option
- (** zone is [Some z] only for nodes that
- * represent call output in case we want to
- * select less than the whole OutCall *)
+ (** zone is [Some z] only for nodes that
+ * represent call output in case we want to
+ * select less than the whole OutCall *)
| SelIn of Locations.Zone.t
type 'tm select = (select_elem * 'tm) list
@@ -42,7 +42,7 @@ type 'tm pdg_select = (PdgTypes.Pdg.t * 'tm pdg_select_info) list
type 'tm info_caller_inputs = (Signature.in_key * 'tm) list
type 'tm info_called_outputs =
- (Cil_types.stmt * (Signature.out_key * 'tm) list) list
+ (Cil_types.stmt * (Signature.out_key * 'tm) list) list
type 'tm info_inter = 'tm info_caller_inputs * 'tm info_called_outputs
@@ -56,10 +56,10 @@ let add_node_to_select select (node,z_opt) m =
let add_undef_in_to_select select undef m =
match undef with
- | None -> select
- | Some loc ->
- if (Locations.Zone.equal Locations.Zone.bottom loc) then select
- else add_to_select select (mk_select_undef_zone loc) m
+ | None -> select
+ | Some loc ->
+ if (Locations.Zone.equal Locations.Zone.bottom loc) then select
+ else add_to_select select (mk_select_undef_zone loc) m
(** Type of the module that the user has to provide to describe the marks. *)
module type Mark = sig
@@ -96,19 +96,19 @@ end
(** If the marks provided by the user respect some constraints (see [Mark]),
-* we have that, after the marks propagation,
-* the mark of a node are always smaller than the sum of the marks of its
-* dependencies. It means that the mark of the statement [x = a + b;]
-* have to be smaller that the mark of [a] plus the mark of [b] at this point.
-*
-* If the marks are used for visibility for instance,
-* it means that if this statement is visible,
-* so must be the computation of [a] and [b], but [a] and/or [b] can be
-* visible while [x] is not.
+ * we have that, after the marks propagation,
+ * the mark of a node are always smaller than the sum of the marks of its
+ * dependencies. It means that the mark of the statement [x = a + b;]
+ * have to be smaller that the mark of [a] plus the mark of [b] at this point.
+ *
+ * If the marks are used for visibility for instance,
+ * it means that if this statement is visible,
+ * so must be the computation of [a] and [b], but [a] and/or [b] can be
+ * visible while [x] is not.
*)
module F_Fct (M : Mark)
: Fct with type mark = M.t
- and type call_info = M.call_info
+ and type call_info = M.call_info
= struct
@@ -128,9 +128,9 @@ module F_Fct (M : Mark)
let get_idx (_pdg, idx) = idx
(** add the given mark to the node.
- @return [Some m] if [m] has to be propagated in the node dependencies,
+ @return [Some m] if [m] has to be propagated in the node dependencies,
[None] otherwise.
- *)
+ *)
let add_mark _pdg fm node_key mark =
Kernel.debug
~level:2
@@ -155,80 +155,80 @@ module F_Fct (M : Mark)
let rec add marks = match marks with
| [] -> [(in_key, mark)]
| (k, m)::tl ->
- let cmp =
- try Signature.cmp_in_key in_key k
- with PdgIndex.Not_equal ->
- (* k and in_key are 2 different InImpl : look for in_key in tl *)
- (* TODO : we could try to group several InImpl... *)
- 1
- in
- if cmp = 0 then (in_key, M.merge m mark)::tl
- else if cmp < 0 then (in_key, mark) :: marks
- else (k, m)::(add tl)
+ let cmp =
+ try Signature.cmp_in_key in_key k
+ with PdgIndex.Not_equal ->
+ (* k and in_key are 2 different InImpl : look for in_key in tl *)
+ (* TODO : we could try to group several InImpl... *)
+ 1
+ in
+ if cmp = 0 then (in_key, M.merge m mark)::tl
+ else if cmp < 0 then (in_key, mark) :: marks
+ else (k, m)::(add tl)
in
let in_marks, out_marks = to_prop in
let new_in_marks = add in_marks in
new_in_marks, out_marks
(** the new marks [to_prop] are composed of two lists :
- * - one [(in_key, mark) list] means that the mark has been added in the input,
- * - one [call, (out_key, m) list] that means that [m] has been added
- * to the [out_key] output of the call.
- *
- * This function [add_to_to_prop] groups similar information,
- * and keep the list sorted.
+ * - one [(in_key, mark) list] means that the mark has been added in the input,
+ * - one [call, (out_key, m) list] that means that [m] has been added
+ * to the [out_key] output of the call.
+ *
+ * This function [add_to_to_prop] groups similar information,
+ * and keep the list sorted.
*)
let add_to_to_prop to_prop key mark =
let rec add_out_key l key = match l with
| [] -> [(key, mark)]
| (k, m) :: tl ->
- let cmp =
- match key, k with
- | Signature.OutLoc z, Signature.OutLoc zone ->
- if Locations.Zone.equal z zone then 0 else 1
- | _ -> Signature.cmp_out_key key k
- in
- if cmp = 0 then (key, M.merge m mark)::tl
- else if cmp < 0 then (key, mark) :: l
- else (k, m)::(add_out_key tl key)
+ let cmp =
+ match key, k with
+ | Signature.OutLoc z, Signature.OutLoc zone ->
+ if Locations.Zone.equal z zone then 0 else 1
+ | _ -> Signature.cmp_out_key key k
+ in
+ if cmp = 0 then (key, M.merge m mark)::tl
+ else if cmp < 0 then (key, mark) :: l
+ else (k, m)::(add_out_key tl key)
in
let rec add_out out_marks call out_key = match out_marks with
| [] -> [ (call, [(out_key, mark)]) ]
| (c, l)::tl ->
- if call.Cil_types.sid = c.Cil_types.sid
- then (c, add_out_key l out_key)::tl
- else (c, l)::(add_out tl call out_key)
+ if call.Cil_types.sid = c.Cil_types.sid
+ then (c, add_out_key l out_key)::tl
+ else (c, l)::(add_out tl call out_key)
in
- match key with
- | Key.SigCallKey (call, Signature.Out out_key) ->
- let in_marks, out_marks = to_prop in
- let call = Key.call_from_id call in
- let new_out_marks = add_out out_marks call out_key in
- (in_marks, new_out_marks)
- | Key.SigKey (Signature.In in_key) ->
- let to_prop = add_in_to_to_prop to_prop in_key mark in
- to_prop
- | _ -> (* nothing to do *) to_prop
+ match key with
+ | Key.SigCallKey (call, Signature.Out out_key) ->
+ let in_marks, out_marks = to_prop in
+ let call = Key.call_from_id call in
+ let new_out_marks = add_out out_marks call out_key in
+ (in_marks, new_out_marks)
+ | Key.SigKey (Signature.In in_key) ->
+ let to_prop = add_in_to_to_prop to_prop in_key mark in
+ to_prop
+ | _ -> (* nothing to do *) to_prop
(** mark the nodes and their dependencies with the given mark.
- * Stop when reach a node which is already marked with this mark.
- * @return the modified marks of the function inputs,
- * and of the call outputs for interprocedural propagation.
- * *)
+ * Stop when reach a node which is already marked with this mark.
+ * @return the modified marks of the function inputs,
+ * and of the call outputs for interprocedural propagation.
+ * *)
let rec add_node_mark_rec pdg fm node_marks to_prop =
let mark_node_and_dpds to_prop (node, z_opt, mark) =
Kernel.debug ~level:2
- "[pdgMark] add mark to node %a" PdgTypes.Node.pretty node;
+ "[pdgMark] add mark to node %a" PdgTypes.Node.pretty node;
let node_key = PdgTypes.Node.elem_key node in
let node_key = match z_opt with
| None -> node_key
| Some z ->
- match node_key with
- | Key.SigCallKey (call, Signature.Out (Signature.OutLoc out_z)) ->
- let z = Locations.Zone.narrow z out_z in
- Key.call_output_key (Key.call_from_id call) z
- | _ -> node_key
+ match node_key with
+ | Key.SigCallKey (call, Signature.Out (Signature.OutLoc out_z)) ->
+ let z = Locations.Zone.narrow z out_z in
+ Key.call_output_key (Key.call_from_id call) z
+ | _ -> node_key
in
let mark_to_prop = add_mark pdg fm node_key mark in
if (M.is_bottom mark_to_prop) then begin
@@ -252,18 +252,18 @@ module F_Fct (M : Mark)
let pdg, idx = fm in
let process to_prop (sel, mark) = match sel with
| SelNode (n, z_opt) ->
- Kernel.debug ~level:2
- "[pdgMark] mark_and_propagate start with %a@\n"
- PdgTypes.Node.pretty_with_part (n, z_opt);
- add_node_mark_rec pdg idx [(n, z_opt, mark)] to_prop
+ Kernel.debug ~level:2
+ "[pdgMark] mark_and_propagate start with %a@\n"
+ PdgTypes.Node.pretty_with_part (n, z_opt);
+ add_node_mark_rec pdg idx [(n, z_opt, mark)] to_prop
| SelIn loc ->
- let in_key = Key.implicit_in_key loc in
- Kernel.debug ~level:2
- "[pdgMark] mark_and_propagate start with %a@\n"
- Key.pretty in_key;
- let mark_to_prop = add_mark pdg idx in_key mark in
- if M.is_bottom mark_to_prop then to_prop
- else add_to_to_prop to_prop in_key mark_to_prop
+ let in_key = Key.implicit_in_key loc in
+ Kernel.debug ~level:2
+ "[pdgMark] mark_and_propagate start with %a@\n"
+ Key.pretty in_key;
+ let mark_to_prop = add_mark pdg idx in_key mark in
+ if M.is_bottom mark_to_prop then to_prop
+ else add_to_to_prop to_prop in_key mark_to_prop
in
List.fold_left process to_prop select
diff --git a/src/plugins/pdg_types/pdgMarks.mli b/src/plugins/pdg_types/pdgMarks.mli
index 1b7822dbbbfb716ebc997e05ad961c8b01f78a03..4c26b90f89fcb23cd889f8ae3d813607fdb2bdd3 100644
--- a/src/plugins/pdg_types/pdgMarks.mli
+++ b/src/plugins/pdg_types/pdgMarks.mli
@@ -21,11 +21,11 @@
(**************************************************************************)
(** This module provides elements to mapped information (here called 'marks')
-* to PDG elements and propagate it along the dependencies.
-*
-* Some more functions are defined in the PDG plugin itself
-* (in [pdg/marks]):
-* the signatures of these public functions can be found in file [Pdg.mli] *)
+ * to PDG elements and propagate it along the dependencies.
+ *
+ * Some more functions are defined in the PDG plugin itself
+ * (in [pdg/marks]):
+ * the signatures of these public functions can be found in file [Pdg.mli] *)
(** Signature of the module to use in order to instantiate the computation *)
module type Mark = sig
@@ -34,9 +34,9 @@ module type Mark = sig
type t
(** type of the information mapped to the function calls.
- * This can be [unit] if there is nothing to store for the calls.
- * (see {!PdgIndex.FctIndex} for more information)
- * *)
+ * This can be [unit] if there is nothing to store for the calls.
+ * (see {!PdgIndex.FctIndex} for more information)
+ * *)
type call_info
(** used to test [combine] result (see below) *)
@@ -46,11 +46,11 @@ module type Mark = sig
val merge : t -> t -> t
(** [combine] is used during propagation. It should return
- * [(new_mark, mark_to_prop) = combine old_mak new_mark]
- * where [new_mark] is the mark to associate with the node,
- * and [mark_to_prop] the mark to propagate to its dependencies.
- * If [is_bottom mark_to_prop], the propagation is stopped.
- * *)
+ * [(new_mark, mark_to_prop) = combine old_mak new_mark]
+ * where [new_mark] is the mark to associate with the node,
+ * and [mark_to_prop] the mark to propagate to its dependencies.
+ * If [is_bottom mark_to_prop], the propagation is stopped.
+ * *)
val combine : t -> t -> t * t
val pretty : Format.formatter -> t -> unit
@@ -58,10 +58,10 @@ module type Mark = sig
end
(** When selecting or propagating marks in a function,
-* the marks are most of the time associated to pdg nodes,
-* but we also need to associate marks to input locations
-* in order to propage information to the callers about undefined data.
-* *)
+ * the marks are most of the time associated to pdg nodes,
+ * but we also need to associate marks to input locations
+ * in order to propage information to the callers about undefined data.
+ * *)
type select_elem = private
| SelNode of PdgTypes.Node.t * Locations.Zone.t option
| SelIn of Locations.Zone.t
@@ -75,10 +75,10 @@ type 'tm select = (select_elem * 'tm) list
val add_to_select : 'tm select -> select_elem -> 'tm -> 'tm select
val add_node_to_select :
- 'tm select -> (PdgTypes.Node.t * Locations.Zone.t option) ->
- 'tm -> 'tm select
+ 'tm select -> (PdgTypes.Node.t * Locations.Zone.t option) ->
+ 'tm -> 'tm select
val add_undef_in_to_select :
- 'tm select -> Locations.Zone.t option -> 'tm -> 'tm select
+ 'tm select -> Locations.Zone.t option -> 'tm -> 'tm select
(** we sometime need a list of [t_select] associated with its pdg when dealing
with several functions at one time. *)
@@ -94,7 +94,7 @@ type 'tm info_caller_inputs = (PdgIndex.Signature.in_key * 'tm) list
(** Represent the information to propagate from a call outputs to the called
function. The [stmt] are the calls to consider. *)
type 'tm info_called_outputs =
- (Cil_types.stmt * (PdgIndex.Signature.out_key * 'tm) list) list
+ (Cil_types.stmt * (PdgIndex.Signature.out_key * 'tm) list) list
(** when some marks have been propagated in a function, there is some
information to propagate in the callers and called functions to have an
@@ -126,7 +126,7 @@ module F_Fct(M : Mark) :
type 't_mark m2m = select_elem -> 't_mark -> 't_mark option
type 't_mark call_m2m =
- Cil_types.stmt option -> PdgTypes.Pdg.t -> 't_mark m2m
+ Cil_types.stmt option -> PdgTypes.Pdg.t -> 't_mark m2m
(** this is the type of the functor dedicated to interprocedural propagation.
It is defined in PDG plugin *)
@@ -146,20 +146,20 @@ module type Config = sig
module M : Mark
(** define how to translate an input mark of a function into a mark
- * to propagate in the callers.
- * The statement specify to which call we are about to propagate,
- * and the pdg is the one of the caller in which the call is.
- * If it returns [None], the propagation is stopped.
- * A simple propagation can be done by returning [Some m].
- * The [call] parameter can be [None] when the caller has a Top PDG.
- * *)
+ * to propagate in the callers.
+ * The statement specify to which call we are about to propagate,
+ * and the pdg is the one of the caller in which the call is.
+ * If it returns [None], the propagation is stopped.
+ * A simple propagation can be done by returning [Some m].
+ * The [call] parameter can be [None] when the caller has a Top PDG.
+ * *)
val mark_to_prop_to_caller_input : M.t call_m2m
(** define how to translate a mark of a call output into a mark
- * to propagate in the called function.
- * The statement specify from which call we are about to propagate,
- * and the pdg is the one of the called function.
- * *)
+ * to propagate in the called function.
+ * The statement specify from which call we are about to propagate,
+ * and the pdg is the one of the called function.
+ * *)
val mark_to_prop_to_called_output : M.t call_m2m
end
diff --git a/src/plugins/pdg_types/pdgTypes.ml b/src/plugins/pdg_types/pdgTypes.ml
index 5e2b4bfa1985ecbcc60aaa1abdcec3eb32ff5021..765a543caf0c5917a91380e82ac39d0ebe45947d 100644
--- a/src/plugins/pdg_types/pdgTypes.ml
+++ b/src/plugins/pdg_types/pdgTypes.ml
@@ -57,33 +57,33 @@ end
(* BY: not sure it is a good idea to use (=) on keys, which contain
Cil structures. Disabled for now
- (** tells if the node represent the same thing that the given key. *)
- let equivalent n key = (elem_key n) = key
+ (** tells if the node represent the same thing that the given key. *)
+ let equivalent n key = (elem_key n) = key
*)
- let print_id fmt n =
+ let print_id fmt n =
Format.fprintf fmt "n:%a" print_id n
include
(Datatype.Make_with_collections
- (struct
- type node = t
- type t = node
- let name = "PdgTypes.Elem"
- let reprs = [ { id = -1; key = PdgIndex.Key.top_input } ]
- let structural_descr =
- Structural_descr.t_record
- [| Structural_descr.p_int; PdgIndex.Key.packed_descr |]
- let compare e1 e2 = Datatype.Int.compare e1.id e2.id
- let hash e = e.id
- let equal e1 e2 = e1.id = e2.id
- let pretty = print_id
- let rehash = Datatype.identity
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let varname = Datatype.undefined
- let mem_project = Datatype.never_any_project
- end)
+ (struct
+ type node = t
+ type t = node
+ let name = "PdgTypes.Elem"
+ let reprs = [ { id = -1; key = PdgIndex.Key.top_input } ]
+ let structural_descr =
+ Structural_descr.t_record
+ [| Structural_descr.p_int; PdgIndex.Key.packed_descr |]
+ let compare e1 e2 = Datatype.Int.compare e1.id e2.id
+ let hash e = e.id
+ let equal e1 e2 = e1.id = e2.id
+ let pretty = print_id
+ let rehash = Datatype.identity
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let varname = Datatype.undefined
+ let mem_project = Datatype.never_any_project
+ end)
: Datatype.S_with_collections with type t := t)
let pretty_list fmt l =
@@ -92,8 +92,8 @@ end
let pretty_with_part fmt (n, z_part) =
Format.fprintf fmt "%a" pretty n;
match z_part with None -> ()
- | Some z -> Format.fprintf fmt "(restrict to @[<h 1>%a@])"
- Locations.Zone.pretty z
+ | Some z -> Format.fprintf fmt "(restrict to @[<h 1>%a@])"
+ Locations.Zone.pretty z
let pretty_node fmt n =
Format.fprintf fmt "@[<hov 2>{n%d}:@ %a@]" (id n)
@@ -102,8 +102,8 @@ end
end
module NodeSet = Hptset.Make(Node)
- (struct let v = [ [ ] ] end)
- (struct let l = [ Ast.self ] end)
+ (struct let v = [ [ ] ] end)
+ (struct let l = [ Ast.self ] end)
(* Clear the (non-project compliant) internal caches each time the ast
is updated, which includes every time we switch project. *)
let () = Ast.add_hook_on_update NodeSet.clear_caches
@@ -117,11 +117,11 @@ end
module LocInfo = Lmap_bitwise.Make_bitwise (NodeSetLattice)
let () = Ast.add_hook_on_update LocInfo.clear_caches
- (* See comment on previous call to Ast.add_hook_on_update *)
+(* See comment on previous call to Ast.add_hook_on_update *)
(** Edges label for the Program Dependence Graph.
- *)
+*)
module Dpd : sig
include Datatype.S
@@ -152,13 +152,13 @@ module Dpd : sig
val pretty_td : Format.formatter -> td -> unit
val pretty : Format.formatter -> t -> unit
- end
- =
+end
+=
struct
type td = Ctrl | Addr | Data
- let pretty_td fmt td =
+ let pretty_td fmt td =
Format.fprintf fmt "%s"
(match td with Ctrl -> "c" | Addr -> "a" | Data -> "d")
@@ -169,14 +169,14 @@ struct
let make ?(a=false) ?(d=false) ?(c=false) _ =
match a,d,c with
- | false, false, false -> 0x000
- | true, false, false -> 0x100
- | false, true, false -> 0x010
- | false, false, true -> 0x001
- | true, true, false -> 0x110
- | true, false, true -> 0x101
- | false, true, true -> 0x011
- | true, true, true -> 0x111
+ | false, false, false -> 0x000
+ | true, false, false -> 0x100
+ | false, true, false -> 0x010
+ | false, false, true -> 0x001
+ | true, true, false -> 0x110
+ | true, false, true -> 0x101
+ | false, true, true -> 0x011
+ | true, true, true -> 0x111
let bottom = 0x000
let top = 0x111
@@ -208,9 +208,9 @@ struct
let minus adc1 adc2 = adc1 land (lnot adc2)
let pretty fmt d = Format.fprintf fmt "[%c%c%c]"
- (if is_addr d then 'a' else '-')
- (if is_ctrl d then 'c' else '-')
- (if is_data d then 'd' else '-')
+ (if is_addr d then 'a' else '-')
+ (if is_ctrl d then 'c' else '-')
+ (if is_data d then 'd' else '-')
end
@@ -228,7 +228,7 @@ module DpdZone : sig
end = struct
include Datatype.Pair(Dpd)(Datatype.Option(Locations.Zone))
- (* None == Locations.Zone.Top *)
+ (* None == Locations.Zone.Top *)
let pretty_debug = pretty
@@ -245,22 +245,22 @@ end = struct
| None, _ -> z1
| _, None -> z
| Some zz1, Some zz2 ->
- (* we are losing some precision here because for instance :
- * (zz1, addr) + (zz2, data) = (zz1 U zz2, data+addr) *)
- let zz = Locations.Zone.join zz1 zz2 in
- match zz with
- | Locations.Zone.Top(_p, _o) -> None
- | _ -> (* To share values as much as possible *)
- if (zz == zz1) then z1
- else if (zz == zz2) then z
- else Some zz
+ (* we are losing some precision here because for instance :
+ * (zz1, addr) + (zz2, data) = (zz1 U zz2, data+addr) *)
+ let zz = Locations.Zone.join zz1 zz2 in
+ match zz with
+ | Locations.Zone.Top(_p, _o) -> None
+ | _ -> (* To share values as much as possible *)
+ if (zz == zz1) then z1
+ else if (zz == zz2) then z
+ else Some zz
in if (d == d1) && (z == z1) then dpd else d, z
let pretty fmt dpd =
Dpd.pretty fmt (dpd_kind dpd);
match (dpd_zone dpd) with None -> ()
- | Some z ->
- Format.fprintf fmt "@[<h 1>(%a)@]" Locations.Zone.pretty z
+ | Some z ->
+ Format.fprintf fmt "@[<h 1>(%a)@]" Locations.Zone.pretty z
end
(** The graph itself. *)
@@ -277,9 +277,9 @@ module G = struct
end
module To = Hptmap.Make(Node)(DpdZone)(Hptmap.Comp_unused)
- (struct let v = [[]] end)(struct let l = [Ast.self] end)
+ (struct let v = [[]] end)(struct let l = [Ast.self] end)
let () = Ast.add_hook_on_update (fun _ -> To.clear_caches ())
- (* See comment on previous call to Ast.add_hook_on_update *)
+ (* See comment on previous call to Ast.add_hook_on_update *)
let () = Ast.add_monotonic_state To.self
@@ -310,7 +310,7 @@ module G = struct
let fold_e_one_dir ?(rev=false) f g v =
let to_ = Node.Hashtbl.find g v in
To.fold (fun v' lbl acc ->
- if rev then f v' lbl v acc else f v lbl v' acc) to_
+ if rev then f v' lbl v acc else f v lbl v' acc) to_
let fold_one_dir f g v =
let to_ = Node.Hashtbl.find g v in
To.fold (fun v' _ acc -> f v' acc) to_
@@ -322,18 +322,18 @@ module G = struct
}
include Datatype.Make
- (struct
- include Datatype.Undefined
- type t = g
- let name = "PdgTypes.G"
- let reprs = [ let h = Node.Hashtbl.create 0 in
- { d_graph = h; co_graph = h} ]
- let mem_project = Datatype.never_any_project
- let rehash = Datatype.identity
- open Structural_descr
- let structural_descr =
- t_record [| OneDir.packed_descr; OneDir.packed_descr |]
- end)
+ (struct
+ include Datatype.Undefined
+ type t = g
+ let name = "PdgTypes.G"
+ let reprs = [ let h = Node.Hashtbl.create 0 in
+ { d_graph = h; co_graph = h} ]
+ let mem_project = Datatype.never_any_project
+ let rehash = Datatype.identity
+ open Structural_descr
+ let structural_descr =
+ t_record [| OneDir.packed_descr; OneDir.packed_descr |]
+ end)
let add_node g v =
add_node_one_dir g.d_graph v;
@@ -405,7 +405,7 @@ end
ie. it stores for each location the nodes of the pdg where its value
was last defined.
Managed in src/pdg/state.ml
- *)
+*)
type data_state =
{ loc_info : LocInfo.t ; under_outputs : Locations.Zone.t }
@@ -418,10 +418,10 @@ module Data_state =
let reprs =
List.fold_left
(fun acc l ->
- List.fold_left
- (fun acc z -> { loc_info = l; under_outputs = z } :: acc)
- acc
- Locations.Zone.reprs)
+ List.fold_left
+ (fun acc z -> { loc_info = l; under_outputs = z } :: acc)
+ acc
+ Locations.Zone.reprs)
[]
LocInfo.reprs
let rehash = Datatype.identity
@@ -429,7 +429,7 @@ module Data_state =
Structural_descr.t_record
[| LocInfo.packed_descr; Locations.Zone.packed_descr |]
let mem_project = Datatype.never_any_project
- end)
+ end)
(** PDG for a function *)
@@ -463,29 +463,29 @@ module Pdg = struct
let rehash = Datatype.identity
open Structural_descr
let structural_descr =
- t_sum
- [| [|
+ t_sum
+ [| [|
pack
(t_record
- [| G.packed_descr;
+ [| G.packed_descr;
(let module H =
- Cil_datatype.Stmt.Hashtbl.Make(Data_state)
+ Cil_datatype.Stmt.Hashtbl.Make(Data_state)
in
H.packed_descr);
- pack fi_descr;
- |])
- |] |]
+ pack fi_descr;
+ |])
+ |] |]
let name = "body"
let mem_project = Datatype.never_any_project
- end)
+ end)
let () = Type.set_ml_name Body_datatype.ty None
include Datatype.Pair(Kernel_function)(Body_datatype)
let make kf graph states index =
let body = { graph = graph; states = states; index = index ; } in
- (kf, PdgDef body)
+ (kf, PdgDef body)
let top kf = (kf, PdgTop)
let bottom kf = (kf, PdgBottom)
@@ -516,7 +516,7 @@ module Pdg = struct
let fold_call_nodes f acc pdg call =
let _, call_pdg = PdgIndex.FctIndex.find_call (get_index pdg) call in
let do_it acc (_k, n) = f acc n in
- PdgIndex.Signature.fold do_it acc call_pdg
+ PdgIndex.Signature.fold do_it acc call_pdg
type dpd_info = (Node.t * Locations.Zone.t option)
@@ -526,7 +526,7 @@ module Pdg = struct
let get_x_direct_edges ~co ?dpd_type pdg node : dpd_info list =
let pdg = get_pdg_body pdg in
let is_dpd_ok dpd = match dpd_type with None -> true
- | Some k -> DpdZone.is_dpd k dpd
+ | Some k -> DpdZone.is_dpd k dpd
in
let filter n dpd n' nodes =
if is_dpd_ok dpd then
@@ -556,7 +556,7 @@ module Pdg = struct
f acc (DpdZone.kind_and_zone dpd) n
in
let fold = if co then G.fold_pred_e else G.fold_succ_e in
- fold do_e (get_graph pdg) node acc
+ fold do_e (get_graph pdg) node acc
let fold_direct_dpds pdg f acc node = fold_direct ~co:false pdg f acc node
let fold_direct_codpds pdg f acc node = fold_direct ~co:true pdg f acc node
@@ -609,9 +609,9 @@ module Pdg = struct
(* Skip InCtrl nodes, that hinder readability *)
let print_node n =
match Node.elem_key n with
- | Key.SigKey (Signature.In Signature.InCtrl)
- | Key.SigCallKey (_, Signature.In Signature.InCtrl) -> false
- | _ -> true
+ | Key.SigKey (Signature.In Signature.InCtrl)
+ | Key.SigCallKey (_, Signature.In Signature.InCtrl) -> false
+ | _ -> true
let iter_vertex f pdg =
try
@@ -639,7 +639,7 @@ module Pdg = struct
let color_out = (`Fillcolor 0x90EE90) in
let color_decl = (`Fillcolor 0xFFEFD5) in
let color_stmt = (`Fillcolor 0xCCCCCC) in
- (* let color_annot = (`Fillcolor 0x999999) in *)
+ (* let color_annot = (`Fillcolor 0x999999) in *)
let color_call = (`Fillcolor 0xFF8A0F) in
let color_elem_call = (`Fillcolor 0xFFCA6E) in
let sh_box = (`Shape `Box) in
@@ -650,9 +650,9 @@ module Pdg = struct
`Shape `Box, color_decl, txt
| Key.SigKey k ->
let txt = Format.asprintf "%a" Signature.pretty_key k in
- let color =
- match k with | Signature.Out _ -> color_out | _ -> color_in
- in
+ let color =
+ match k with | Signature.Out _ -> color_out | _ -> color_in
+ in
`Shape `Box, color, txt
| Key.Stmt s ->
let sh, txt = match s.skind with
@@ -664,26 +664,26 @@ module Pdg = struct
| Block _ | UnspecifiedSequence _ ->
`Shape `Doublecircle, "{}"
| Goto _ | Break _ | Continue _ ->
- let txt =
- Pretty_utils.to_string
- (Printer.without_annot Printer.pp_stmt) s
- in
- (`Shape `Doublecircle), txt
+ let txt =
+ Pretty_utils.to_string
+ (Printer.without_annot Printer.pp_stmt) s
+ in
+ (`Shape `Doublecircle), txt
| Return _ | Instr _ ->
- let txt =
- Pretty_utils.to_string
- (Printer.without_annot Printer.pp_stmt) s
- in
+ let txt =
+ Pretty_utils.to_string
+ (Printer.without_annot Printer.pp_stmt) s
+ in
sh_box, txt
| _ -> sh_box, "???"
in sh, color_stmt, txt
| Key.CallStmt call ->
let call_stmt = Key.call_from_id call in
- let txt =
- Pretty_utils.to_string
- (Printer.without_annot Printer.pp_stmt) call_stmt
- in
- sh_box, color_call, txt
+ let txt =
+ Pretty_utils.to_string
+ (Printer.without_annot Printer.pp_stmt) call_stmt
+ in
+ sh_box, color_call, txt
| Key.SigCallKey (_call, sgn) ->
let txt =
Pretty_utils.to_string Signature.pretty_key sgn
@@ -718,7 +718,7 @@ module Pdg = struct
let attrib =
if Dpd.is_addr d then (`Style `Dotted)::attrib else attrib
in
- attrib
+ attrib
let get_subgraph v =
let mk_subgraph name attrib =
diff --git a/src/plugins/pdg_types/pdgTypes.mli b/src/plugins/pdg_types/pdgTypes.mli
index f5ec0ab386a8a615a447d7cb155961d43f1aaa06..3e4a557b570aae37a6903d39d4accb42fbd8a9ce 100644
--- a/src/plugins/pdg_types/pdgTypes.mli
+++ b/src/plugins/pdg_types/pdgTypes.mli
@@ -31,37 +31,37 @@
* - data dependency.
* An edge can carry one or several kinds.
* A bottom edge means that there are no relation.
- *)
+*)
module Dpd :
- sig
- type t
+sig
+ type t
- type td = Ctrl | Addr | Data
+ type td = Ctrl | Addr | Data
- val make : ?a:bool -> ?d:bool -> ?c:bool -> unit -> t
- val top : t
- val bottom : t
+ val make : ?a:bool -> ?d:bool -> ?c:bool -> unit -> t
+ val top : t
+ val bottom : t
- val is_addr : t -> bool
- val is_ctrl : t -> bool
- val is_data : t -> bool
- val adc_value : t -> bool * bool * bool
- val is_dpd : td -> t -> bool
- val is_bottom : t -> bool
- val is_included : t -> t -> bool
+ val is_addr : t -> bool
+ val is_ctrl : t -> bool
+ val is_data : t -> bool
+ val adc_value : t -> bool * bool * bool
+ val is_dpd : td -> t -> bool
+ val is_bottom : t -> bool
+ val is_included : t -> t -> bool
- val compare : t -> t -> int
- val equal : t -> t -> bool
+ val compare : t -> t -> int
+ val equal : t -> t -> bool
- val combine : t -> t -> t
- val add : t -> td -> t
- val inter : t -> t -> t
- val intersect : t -> t -> bool
- val minus : t -> t -> t
+ val combine : t -> t -> t
+ val add : t -> td -> t
+ val inter : t -> t -> t
+ val intersect : t -> t -> bool
+ val minus : t -> t -> t
- val pretty_td : Format.formatter -> td -> unit
- val pretty : Format.formatter -> t -> unit
- end
+ val pretty_td : Format.formatter -> td -> unit
+ val pretty : Format.formatter -> t -> unit
+end
(** A node of the PDG : includes some information to know where it comes
from. *)
@@ -80,8 +80,8 @@ end
module NodeSet : Hptset.S with type elt = Node.t
(** Program dependence graph main part : the nodes of the graph represent
- computations, and the edges represent the dependencies between these
- computations. Only a few functions are exported, to build the graph
+ computations, and the edges represent the dependencies between these
+ computations. Only a few functions are exported, to build the graph
in [pdg/build.ml]. Iterating over the PDG should be done using the
functions in module [Pdg] below *)
module G : sig
@@ -97,7 +97,7 @@ module G : sig
val create : unit -> t
val add_elem : t -> PdgIndex.Key.t -> Node.t
- val add_dpd :
+ val add_dpd :
t -> Node.t -> Dpd.td -> Locations.Zone.t option -> Node.t -> unit
end
@@ -118,13 +118,13 @@ type data_state =
module Pdg : sig
exception Top
- (** can be raised by most of the functions when called with a Top PDG.
- Top means that we were not able to compute the PDG for this
- function. *)
+ (** can be raised by most of the functions when called with a Top PDG.
+ Top means that we were not able to compute the PDG for this
+ function. *)
exception Bottom
- (** exception raised when requiring the PDG of a function that is never
- called. *)
+ (** exception raised when requiring the PDG of a function that is never
+ called. *)
include Datatype.S
@@ -146,7 +146,7 @@ module Pdg : sig
val iter_direct_codpds : t -> (Node.t -> unit) -> Node.t -> unit
(** a dependency to another node. The dependency can be restricted to a zone.
- * (None means no restriction ie. total dependency) *)
+ * (None means no restriction ie. total dependency) *)
type dpd_info = (Node.t * Locations.Zone.t option)
val get_all_direct_dpds : t -> Node.t -> dpd_info list
@@ -156,12 +156,12 @@ module Pdg : sig
val get_x_direct_codpds : Dpd.td -> t -> Node.t -> dpd_info list
val fold_direct_dpds : t ->
- ('a -> Dpd.t * Locations.Zone.t option -> Node.t -> 'a) ->
- 'a -> Node.t -> 'a
+ ('a -> Dpd.t * Locations.Zone.t option -> Node.t -> 'a) ->
+ 'a -> Node.t -> 'a
val fold_direct_codpds : t ->
- ('a -> Dpd.t * Locations.Zone.t option -> Node.t -> 'a) ->
- 'a -> Node.t -> 'a
+ ('a -> Dpd.t * Locations.Zone.t option -> Node.t -> 'a) ->
+ 'a -> Node.t -> 'a
val pretty_bw : ?bw:bool -> Format.formatter -> t -> unit
val pretty_graph : ?bw:bool -> Format.formatter -> G.t -> unit
diff --git a/src/plugins/postdominators/compute.ml b/src/plugins/postdominators/compute.ml
index 2fc9cffe53925443c03a451393ece34559638b75..7f520a7255a731bc2537eaeb4cafaa1ad4eced79 100644
--- a/src/plugins/postdominators/compute.ml
+++ b/src/plugins/postdominators/compute.ml
@@ -73,7 +73,7 @@ module DomSet = struct
| Value v, Value v' -> Stmt.Hptset.equal v v'
let copy = map Cil_datatype.Stmt.Hptset.copy
let mem_project = Datatype.never_any_project
- end)
+ end)
end
@@ -97,10 +97,10 @@ struct
Cil_state_builder.Stmt_hashtbl
(DomSet)
(struct
- let name = "postdominator." ^ X.name
- let dependencies = Ast.self :: X.dependencies
- let size = 503
- end)
+ let name = "postdominator." ^ X.name
+ let dependencies = Ast.self :: X.dependencies
+ let size = 503
+ end)
module PostComputer = struct
@@ -121,8 +121,8 @@ struct
Db.yield ();
Postdominators_parameters.debug ~level:2 "doStmt: %d" stmt.sid;
match stmt.skind with
- | Return _ -> Dataflow2.Done (DomSet.Value (Stmt.Hptset.singleton stmt))
- | _ -> Dataflow2.Post (fun data -> DomSet.add stmt data)
+ | Return _ -> Dataflow2.Done (DomSet.Value (Stmt.Hptset.singleton stmt))
+ | _ -> Dataflow2.Post (fun data -> DomSet.add stmt data)
let doInstr _ _ _ = Dataflow2.Default
@@ -132,17 +132,17 @@ struct
the condition of the 'if' with always the same truth value *)
let filterIf ifstmt next = match ifstmt.skind with
| If (e, { bstmts = sthen :: _ }, { bstmts = [] }, _)
- when not (Stmt.equal sthen next) ->
- (* [next] is the syntactic successor of the 'if', ie the
- 'else' branch. If the condition is never false, then
- [sthen] postdominates [next]. We must not follow the edge
- from [ifstmt] to [next] *)
- snd (X.eval_cond ifstmt e)
+ when not (Stmt.equal sthen next) ->
+ (* [next] is the syntactic successor of the 'if', ie the
+ 'else' branch. If the condition is never false, then
+ [sthen] postdominates [next]. We must not follow the edge
+ from [ifstmt] to [next] *)
+ snd (X.eval_cond ifstmt e)
| If (e, { bstmts = [] }, { bstmts = selse :: _ }, _)
- when not (Stmt.equal selse next) ->
- (* dual case *)
- fst (X.eval_cond ifstmt e)
+ when not (Stmt.equal selse next) ->
+ (* dual case *)
+ fst (X.eval_cond ifstmt e)
| _ -> true
@@ -172,13 +172,13 @@ struct
Kernel_function.pretty kf;
let f = kf.fundec in
match f with
- | Definition (f,_) ->
- let stmts = f.sallstmts in
- List.iter (fun s -> PostDom.add s DomSet.Top) stmts;
- PostCompute.compute [return];
- Postdominators_parameters.feedback ~level:2 "done for function %a"
- Kernel_function.pretty kf
- | Declaration _ -> ()
+ | Definition (f,_) ->
+ let stmts = f.sallstmts in
+ List.iter (fun s -> PostDom.add s DomSet.Top) stmts;
+ PostCompute.compute [return];
+ Postdominators_parameters.feedback ~level:2 "done for function %a"
+ Kernel_function.pretty kf
+ | Declaration _ -> ()
let get_stmt_postdominators f stmt =
let do_it () = PostDom.find stmt in
@@ -186,15 +186,15 @@ struct
with Not_found -> compute_postdom f; do_it ()
(** @raise Db.PostdominatorsTypes.Top when the statement postdominators
- * have not been computed ie neither the return statement is reachable,
- * nor the statement is in a natural loop. *)
+ * have not been computed ie neither the return statement is reachable,
+ * nor the statement is in a natural loop. *)
let stmt_postdominators f stmt =
- match get_stmt_postdominators f stmt with
- | DomSet.Value s ->
- Postdominators_parameters.debug ~level:1 "Postdom for %d are %a"
- stmt.sid Stmt.Hptset.pretty s;
- s
- | DomSet.Top -> raise Db.PostdominatorsTypes.Top
+ match get_stmt_postdominators f stmt with
+ | DomSet.Value s ->
+ Postdominators_parameters.debug ~level:1 "Postdom for %d are %a"
+ stmt.sid Stmt.Hptset.pretty s;
+ s
+ | DomSet.Top -> raise Db.PostdominatorsTypes.Top
let is_postdominator f ~opening ~closing =
let open_postdominators = get_stmt_postdominators f opening in
@@ -204,7 +204,7 @@ struct
let disp_all fmt =
PostDom.iter
(fun k v -> Format.fprintf fmt "Stmt:%d -> @[%a@]\n"
- k.sid PostComputer.pretty v)
+ k.sid PostComputer.pretty v)
in Postdominators_parameters.result "%t" disp_all
let print_dot_postdom basename kf =
@@ -228,12 +228,12 @@ end
module PostDomBasic =
PostDomDb(
- struct
- let is_accessible _ = true
- let dependencies = []
- let name = "basic"
- let eval_cond _ _ = true, true
- end)
+ struct
+ let is_accessible _ = true
+ let dependencies = []
+ let name = "basic"
+ let eval_cond _ _ = true, true
+ end)
(Db.Postdominators)
@@ -242,26 +242,26 @@ let output () =
if dot_postdom <> "" then (
Ast.compute ();
Globals.Functions.iter (fun kf ->
- if Kernel_function.is_definition kf then
- !Db.Postdominators.print_dot dot_postdom kf)
+ if Kernel_function.is_definition kf then
+ !Db.Postdominators.print_dot dot_postdom kf)
)
let output, _ = State_builder.apply_once "Postdominators.Compute.output"
- [PostDomBasic.PostDom.self] output
+ [PostDomBasic.PostDom.self] output
let () = Db.Main.extend output
module PostDomVal =
PostDomDb(
- struct
- let is_accessible = Db.Value.is_reachable_stmt
- let dependencies = [ Db.Value.self ]
- let name = "value"
- let eval_cond stmt _e =
- Db.Value.condition_truth_value stmt
-
- end)
+ struct
+ let is_accessible = Db.Value.is_reachable_stmt
+ let dependencies = [ Db.Value.self ]
+ let name = "value"
+ let eval_cond stmt _e =
+ Db.Value.condition_truth_value stmt
+
+ end)
(Db.PostdominatorsValue)
(*
diff --git a/src/plugins/postdominators/postdominators_parameters.ml b/src/plugins/postdominators/postdominators_parameters.ml
index 66ab4e5328782845e6b2933e80348bceed65eb0c..2d5cbfc6b93dfb56b5c0f584eaf905337d13ab51 100644
--- a/src/plugins/postdominators/postdominators_parameters.ml
+++ b/src/plugins/postdominators/postdominators_parameters.ml
@@ -21,19 +21,19 @@
(**************************************************************************)
include Plugin.Register
- (struct
- let name = "postdominators"
- let shortname = "postdominators"
- let help = "computing postdominators of statements"
- end)
+ (struct
+ let name = "postdominators"
+ let shortname = "postdominators"
+ let help = "computing postdominators of statements"
+ end)
module DotPostdomBasename =
Empty_string
(struct
- let option_name = "-dot-postdom"
- let arg_name = "f"
- let help = "put the postdominators of function <f> in basename.f.dot"
- end)
+ let option_name = "-dot-postdom"
+ let arg_name = "f"
+ let help = "put the postdominators of function <f> in basename.f.dot"
+ end)
(*
Local Variables:
diff --git a/src/plugins/postdominators/print.ml b/src/plugins/postdominators/print.ml
index a2318de5f1660e200b2cf0fe0394293f8c64e366..1acb4f50052aeb7e1283f8006bdcdbfab97076c2 100644
--- a/src/plugins/postdominators/print.ml
+++ b/src/plugins/postdominators/print.ml
@@ -52,9 +52,9 @@ module Printer = struct
let do_s ki postdom =
let s = match ki with Kstmt s -> s | _ -> assert false in
match postdom with None -> ()
- | Some postdom ->
- let do_edge p = f ((s, true), (p, true)) in
- Stmt.Hptset.iter do_edge postdom
+ | Some postdom ->
+ let do_edge p = f ((s, true), (p, true)) in
+ Stmt.Hptset.iter do_edge postdom
in
Kinstr.Hashtbl.iter do_s graph
@@ -73,7 +73,7 @@ module Printer = struct
let color = if has_postdom then 0x7FFFD4 else 0xFF0000 in
let attrib = (`Shape `Box) :: attrib in
let attrib = (`Fillcolor color) :: attrib in
- attrib
+ attrib
let edge_attributes _s = []
@@ -88,20 +88,20 @@ let get_postdom kf graph s =
| None -> Stmt.Hptset.empty
| Some l -> l
with Not_found ->
- try
- let postdom = !Db.Postdominators.stmt_postdominators kf s in
- let postdom = Stmt.Hptset.remove s postdom in
- Postdominators_parameters.debug "postdom for %d:%a = %a\n"
- s.sid pretty_stmt s Stmt.Hptset.pretty postdom;
- Kinstr.Hashtbl.add graph (Kstmt s) (Some postdom); postdom
- with Db.PostdominatorsTypes.Top ->
- Kinstr.Hashtbl.add graph (Kstmt s) None;
- raise Db.PostdominatorsTypes.Top
+ try
+ let postdom = !Db.Postdominators.stmt_postdominators kf s in
+ let postdom = Stmt.Hptset.remove s postdom in
+ Postdominators_parameters.debug "postdom for %d:%a = %a\n"
+ s.sid pretty_stmt s Stmt.Hptset.pretty postdom;
+ Kinstr.Hashtbl.add graph (Kstmt s) (Some postdom); postdom
+ with Db.PostdominatorsTypes.Top ->
+ Kinstr.Hashtbl.add graph (Kstmt s) None;
+ raise Db.PostdominatorsTypes.Top
(** [s_postdom] are [s] postdominators, including [s].
-* We don't have to represent the relation between s and s.
-* And because the postdom relation is transitive, if [p] is in [s_postdom],
-* we can remove [p_postdom] from [s_postdom] in order to have a clearer graph.
+ * We don't have to represent the relation between s and s.
+ * And because the postdom relation is transitive, if [p] is in [s_postdom],
+ * we can remove [p_postdom] from [s_postdom] in order to have a clearer graph.
*)
let reduce kf graph s =
let remove p s_postdom =
@@ -112,7 +112,7 @@ let reduce kf graph s =
let s_postdom = Stmt.Hptset.diff s_postdom p_postdom
in s_postdom
with Db.PostdominatorsTypes.Top -> assert false
- (* p postdom s -> cannot be top *)
+ (* p postdom s -> cannot be top *)
else s_postdom (* p has already been removed from s_postdom *)
in
try
@@ -129,18 +129,18 @@ let build_reduced_graph kf graph stmts =
let build_dot filename kf =
match kf.fundec with
- | Definition (fct, _) ->
- let stmts = fct.sallstmts in
- let graph = Kinstr.Hashtbl.create (List.length stmts) in
- let _ = build_reduced_graph kf graph stmts in
- let name = Kernel_function.get_name kf in
- let title = "Postdominators for function " ^ name in
- let file = open_out filename in
- PostdomGraph.output_graph file (title, graph);
- close_out file
- | Declaration _ ->
- Kernel.error "cannot compute for a function without body %a"
- Kernel_function.pretty kf
+ | Definition (fct, _) ->
+ let stmts = fct.sallstmts in
+ let graph = Kinstr.Hashtbl.create (List.length stmts) in
+ let _ = build_reduced_graph kf graph stmts in
+ let name = Kernel_function.get_name kf in
+ let title = "Postdominators for function " ^ name in
+ let file = open_out filename in
+ PostdomGraph.output_graph file (title, graph);
+ close_out file
+ | Declaration _ ->
+ Kernel.error "cannot compute for a function without body %a"
+ Kernel_function.pretty kf
(*
Local Variables:
diff --git a/src/plugins/print_api/print_interface.ml b/src/plugins/print_api/print_interface.ml
index a6fc68dc4308cbc2ba14c482e0da1a6f0b9fe699..9867940e730e8dac41634f05b3d4d9a30e084060 100644
--- a/src/plugins/print_api/print_interface.ml
+++ b/src/plugins/print_api/print_interface.ml
@@ -23,31 +23,31 @@
(** Register the new plugin. *)
module Self =
Plugin.Register
- (struct
- let name = "Print interface"
- let shortname = "print_api"
- let help = "This plugin creates a file containing all \
- the registered signatures of the dynamic plugins"
- end)
+ (struct
+ let name = "Print interface"
+ let shortname = "print_api"
+ let help = "This plugin creates a file containing all \
+ the registered signatures of the dynamic plugins"
+ end)
(** Register the new Frama-C option "-print_api". *)
module Enabled =
Self.String
- (struct
- let option_name = "-print_api"
- let help = "creates a .mli file for the dynamic plugins inside the \
- supplied directory"
- let arg_name = "dir"
- let default = ""
- end)
+ (struct
+ let option_name = "-print_api"
+ let help = "creates a .mli file for the dynamic plugins inside the \
+ supplied directory"
+ let arg_name = "dir"
+ let default = ""
+ end)
-type function_element =
- { name: string;
- type_string: string;
- datatype_string: string }
+type function_element =
+ { name: string;
+ type_string: string;
+ datatype_string: string }
(** Each object of the table is going to be composed of :
- (function_name, type_string)
+ (function_name, type_string)
and its corresponding key is "plugin_name" *)
let functions_tbl = Hashtbl.create 97
@@ -56,7 +56,7 @@ let functions_tbl = Hashtbl.create 97
types of OCaml and the registered types of static plugins and kernel *)
let type_to_add: (string, string * string) Hashtbl.t = Hashtbl.create 97
-let clash_with_compilation_unit =
+let clash_with_compilation_unit =
let h = Hashtbl.create 97 in
List.iter (fun s -> Hashtbl.add h s ()) Fc_config.compilation_unit_names;
fun s ->
@@ -69,7 +69,7 @@ module Module_deps = Graph.Imperative.Digraph.Concrete(Datatype.String)
let module_deps = Module_deps.create ()
(** Comments are registered apart in the module Dynamic *)
-module Comment: sig
+module Comment: sig
val add: string -> string -> unit
val find: string -> string
end = struct
@@ -85,46 +85,46 @@ let get_name i s =
let li = split_dot s in
let rec get_name_aux i j l =
if i < j then match i, l with
- | _, [] -> ""
- | 0, h :: _ -> h
- | _ , _ :: q -> get_name_aux (i-1) (j-1) q
+ | _, [] -> ""
+ | 0, h :: _ -> h
+ | _ , _ :: q -> get_name_aux (i-1) (j-1) q
else
""
in
get_name_aux i (List.length li) li
-
-let sub_string_dot i s =
- let rec sub_string_dot_aux j =
+
+let sub_string_dot i s =
+ let rec sub_string_dot_aux j =
if j < i then get_name j s ^ "." ^ sub_string_dot_aux (j+1)
else get_name i s
in
sub_string_dot_aux 0
-
+
(** If s = "module1.module2 ... .fname", then [function_name s] = "fname" *)
-let function_name s =
+let function_name s =
let rec function_name_aux i s =
match i , get_name (i+2) s , get_name (i+1) s with
- | 0,"","" -> ""
- | _,"",f -> f
- | _,_,_ -> function_name_aux (i+1) s
+ | 0,"","" -> ""
+ | _,"",f -> f
+ | _,_,_ -> function_name_aux (i+1) s
in
function_name_aux 0 s
-
-(** If s = "module1.module2 ... .fname",
+
+(** If s = "module1.module2 ... .fname",
then [long_function_name s] = "module2 ... .fname" *)
-let long_function_name s =
+let long_function_name s =
let pt_idx = ref 0 in
try
for i = 0 to String.length s - 1 do
- if s.[i] = '.' then begin
- pt_idx := i;
- raise Exit
+ if s.[i] = '.' then begin
+ pt_idx := i;
+ raise Exit
end
done;
s
with Exit ->
Str.string_after s (!pt_idx + 1)
-
+
(** when considering s = "plugin_name_0.plugin_name_1.function_name",
[plugin_name s] ="plugin_name_0.plugin_name_1" *)
let plugin_name s =
@@ -135,7 +135,7 @@ let plugin_name s =
| _, _, _ -> plugin_name_aux (i+1) s
in
plugin_name_aux 0 s
-
+
let sub_string_dot_compare i s1 s2 = sub_string_dot i s1 = sub_string_dot i s2
let first_divergence m1 m2 =
@@ -154,7 +154,7 @@ let find_module_deps m1 =
let rec find_real_module m1 m =
let complete_name = m1 ^ "." ^ m in
if Hashtbl.mem type_to_add complete_name ||
- Hashtbl.mem functions_tbl complete_name
+ Hashtbl.mem functions_tbl complete_name
then complete_name
else
let pre_m1 = plugin_name m1 in
@@ -171,8 +171,8 @@ let is_submodule m1 m2 = let m1' = first_divergence m1 m2 in m1 = m1'
not already recorded in the [reference] list or creates the corresponding
type in the Hashtable [type_to add] where the key is the module name of this
type. *)
-let analyse_type name l =
- let add_type tbl name module_name typ =
+let analyse_type name l =
+ let add_type tbl name module_name typ =
let add_type_aux t s ty =
let temp = try Hashtbl.find_all t s with Not_found -> [] in
if not (List.mem ty temp) then Hashtbl.add t s ty
@@ -187,31 +187,31 @@ let analyse_type name l =
let analyse_type_aux s =
if not (String.contains s '>') && (String.contains s '.') then
if not (String.contains s ' ') then begin
- let s_name = get_name 0 s in
+ let s_name = get_name 0 s in
if not (clash_with_compilation_unit s_name) then
- let typ_n = function_name s in
- let module_name = plugin_name s in
- add_type type_to_add name module_name (typ_n, s)
+ let typ_n = function_name s in
+ let module_name = plugin_name s in
+ add_type type_to_add name module_name (typ_n, s)
end else
- let lexbuf = Lexing.from_string s in
- let param, type_name =
- let l =
- Str.split (Str.regexp_string " ") (Grammar.main Lexer.token lexbuf)
- in
- match l with
- | [ h ] -> "", h
- | [h1; h2 ] -> h1, h2
- | _ -> "", ""
- in
- let ty_name = get_name 0 type_name in
- if String.contains type_name '.'
- && not (clash_with_compilation_unit ty_name)
- then
- let typ_n = param ^ " " ^ function_name type_name in
- let module_name = plugin_name type_name in
- add_type type_to_add name module_name (typ_n, type_name)
+ let lexbuf = Lexing.from_string s in
+ let param, type_name =
+ let l =
+ Str.split (Str.regexp_string " ") (Grammar.main Lexer.token lexbuf)
+ in
+ match l with
+ | [ h ] -> "", h
+ | [h1; h2 ] -> h1, h2
+ | _ -> "", ""
+ in
+ let ty_name = get_name 0 type_name in
+ if String.contains type_name '.'
+ && not (clash_with_compilation_unit ty_name)
+ then
+ let typ_n = param ^ " " ^ function_name type_name in
+ let module_name = plugin_name type_name in
+ add_type type_to_add name module_name (typ_n, type_name)
in
- List.iter analyse_type_aux (List.rev l)
+ List.iter analyse_type_aux (List.rev l)
let is_option key = String.length key > 1 && String.rcontains_from key 1 '-'
@@ -223,62 +223,62 @@ let is_option key = String.length key > 1 && String.rcontains_from key 1 '-'
let fill_tbl key typ _ =
if not (is_option key || get_name 0 key = "Dynamic") then
let type_list = Type.get_embedded_type_names typ in
- let func_elem =
- { name = function_name key ;
- type_string = Type.name typ ;
- datatype_string = Type.ml_name typ }
+ let func_elem =
+ { name = function_name key ;
+ type_string = Type.name typ ;
+ datatype_string = Type.ml_name typ }
in
Hashtbl.add functions_tbl (plugin_name key) func_elem;
analyse_type (plugin_name key) type_list
-
+
(** It replaces the sub-strings "Plugin.type" of all the string [type_string]
used in the module named "Plugin" by "type".
It also removes the option structure (e.g. "~gid:string" is replaced by
- "string"). *)
+ "string"). *)
let repair_type module_name type_string =
let rec remove_param_name s =
try
let c = String.index s ':' in
let after = remove_param_name (Str.string_after s (c+1)) in
- try
- let n = String.index s '~' in
- if n < c then
- if n = 0 then after
- else remove_param_name (Str.string_before s n) ^ after
- else
- s
+ try
+ let n = String.index s '~' in
+ if n < c then
+ if n = 0 then after
+ else remove_param_name (Str.string_before s n) ^ after
+ else
+ s
with Not_found ->
- if c = 0 then after
- else
- let sp = String.rindex (Str.string_before s c) ' ' in
- remove_param_name (Str.string_before s (sp + 1)) ^ after
- with Not_found ->
- s
- in
+ if c = 0 then after
+ else
+ let sp = String.rindex (Str.string_before s c) ' ' in
+ remove_param_name (Str.string_before s (sp + 1)) ^ after
+ with Not_found ->
+ s
+ in
let remove_name_module s module_n =
Str.global_replace (Str.regexp (module_n ^ "\\.")) "" s
- in
+ in
match split_dot module_name with
| [] -> type_string
| l -> List.fold_left remove_name_module (remove_param_name type_string) l
-
-(** For each key of the table [functions_tbl], [print_plugin] takes all
+
+(** For each key of the table [functions_tbl], [print_plugin] takes all
the pieces of information found in the Hashtable [dynamic_values]
of the module Dynamic and stored in the 3 Hashtables
- ([functions_tb]l, [type_to_add], [comment_tbl]) and builds up a string
+ ([functions_tb]l, [type_to_add], [comment_tbl]) and builds up a string
in order to write the signature of this module in the .mli file *)
let print_plugin fmt =
let modules_list: (string, unit) Hashtbl.t = Hashtbl.create 7 in
- let rec space i = match i with
+ let rec space i = match i with
| 0 -> ""
- | _ -> space (i-1) ^ " "
+ | _ -> space (i-1) ^ " "
in
let rec print_types fmt sp = function
| [] -> ()
| (h, long_h) :: q ->
Format.fprintf fmt "@\n%stype %s@\n%s \
-(** @@call by writing [T.ty] where [T] has previously been defined by: \
-[module T = Type.Abstract(struct let name = %s end)]. Be careful to replace occurrences of %s by T.ty anywhere else in this doc. *)"
+ (** @@call by writing [T.ty] where [T] has previously been defined by: \
+ [module T = Type.Abstract(struct let name = %s end)]. Be careful to replace occurrences of %s by T.ty anywhere else in this doc. *)"
sp h sp long_h long_h;
print_types fmt sp q
in
@@ -286,7 +286,7 @@ let print_plugin fmt =
if not (get_name i key1 = "") then
let module_name = sub_string_dot i key1 in
if not (Hashtbl.mem modules_list module_name) then begin
- Hashtbl.add modules_list module_name ();
+ Hashtbl.add modules_list module_name ();
(* Check whether there are some modules to be treated before us. *)
let deps = find_module_deps key1 in
let extern, sub_modules = List.partition (is_submodule key1) deps in
@@ -294,72 +294,72 @@ let print_plugin fmt =
let short_module_name =
String.capitalize_ascii (get_name i key1)
in
- let space_i = space i in
- Format.fprintf fmt "\n \n%smodule %s:\n%ssig "
- space_i
- short_module_name
- space_i;
+ let space_i = space i in
+ Format.fprintf fmt "\n \n%smodule %s:\n%ssig "
+ space_i
+ short_module_name
+ space_i;
List.iter (print_one_plugin fmt (succ i)) sub_modules;
- let module_types =
- try Hashtbl.find_all type_to_add module_name
- with Not_found -> []
- in
- print_types fmt (space i) module_types ;
- let print_one_plugin_aux fmt key elem =
- if sub_string_dot i key = module_name then
- let succ_i = succ i in
- if get_name succ_i key = "" then begin
- let plugin_name = sub_string_dot 0 key1 in
- let found_comment = Comment.find (key ^ "." ^ elem.name) in
- Format.fprintf fmt
- "@\n%s@[ @[val %s:@ %s@]@\n%s@[ (** %s\n\
-@@call Dynamic.get ~plugin:\"%s\" \"%s\" %s *)@]@]@\n"
- space_i
- elem.name
- (repair_type module_name elem.type_string)
- space_i
- found_comment
- plugin_name
- (long_function_name (key ^ "." ^ elem.name))
- elem.datatype_string;
- Hashtbl.remove functions_tbl key
- end else
- print_one_plugin fmt succ_i key
- in
- Hashtbl.iter (print_one_plugin_aux fmt) functions_tbl ;
- Format.fprintf fmt "\n%send" (space i)
+ let module_types =
+ try Hashtbl.find_all type_to_add module_name
+ with Not_found -> []
+ in
+ print_types fmt (space i) module_types ;
+ let print_one_plugin_aux fmt key elem =
+ if sub_string_dot i key = module_name then
+ let succ_i = succ i in
+ if get_name succ_i key = "" then begin
+ let plugin_name = sub_string_dot 0 key1 in
+ let found_comment = Comment.find (key ^ "." ^ elem.name) in
+ Format.fprintf fmt
+ "@\n%s@[ @[val %s:@ %s@]@\n%s@[ (** %s\n\
+ @@call Dynamic.get ~plugin:\"%s\" \"%s\" %s *)@]@]@\n"
+ space_i
+ elem.name
+ (repair_type module_name elem.type_string)
+ space_i
+ found_comment
+ plugin_name
+ (long_function_name (key ^ "." ^ elem.name))
+ elem.datatype_string;
+ Hashtbl.remove functions_tbl key
+ end else
+ print_one_plugin fmt succ_i key
+ in
+ Hashtbl.iter (print_one_plugin_aux fmt) functions_tbl ;
+ Format.fprintf fmt "\n%send" (space i)
end
in
let print_all fmt i key _ = print_one_plugin fmt i key in
Format.fprintf fmt "@[%t@]"
(fun fmt -> Hashtbl.iter (print_all fmt 0) functions_tbl)
-
+
(** [print] is the main function of this module.
It takes one argument which is the path and opens the
file path/dynamic_plugins.mli. It fills [functions_tbl],
[comment_tbl] and [type_to_add]
- using the functions [fill_tbl] and [add_comment] and then
+ using the functions [fill_tbl] and [add_comment] and then
prints the plugins in the file with [print_plugin] *)
-let print path =
- try
- Dynamic.iter fill_tbl;
- Dynamic.iter_comment Comment.add;
- let channel = open_out (path ^ "/dynamic_plugins.mli") in
+let print path =
+ try
+ Dynamic.iter fill_tbl;
+ Dynamic.iter_comment Comment.add;
+ let channel = open_out (path ^ "/dynamic_plugins.mli") in
let fmt = Format.formatter_of_out_channel channel in
Format.fprintf fmt
"@[@[(** This@ module@ contains@ all@ the@ dynamically@ \
-registered@ plugins *)@]@ %t@]"
- print_plugin;
+ registered@ plugins *)@]@ %t@]"
+ print_plugin;
close_out channel
- with Sys_error _ as e ->
+ with Sys_error _ as e ->
Self.error "%s" (Printexc.to_string e)
(** register [print (path : string)] *)
let print =
Dynamic.register
~comment: "Create a .mli file used by 'make doc' \
-to generate the html documentation of dynamic plug-ins.\
- It takes the path where to create this file as an argument."
+ to generate the html documentation of dynamic plug-ins.\
+ It takes the path where to create this file as an argument."
~plugin:"Print_api"
"run"
~journalize:true
diff --git a/src/plugins/scope/Scope.mli b/src/plugins/scope/Scope.mli
index 91c4f01f1f0d94f274a4f423e305780a57470bce..4e54f4848889be85e43dbed4b2fe744ba6bf190b 100644
--- a/src/plugins/scope/Scope.mli
+++ b/src/plugins/scope/Scope.mli
@@ -30,22 +30,22 @@ open Cil_datatype
module Defs : sig
val get_defs :
Kernel_function.t -> stmt -> lval ->
- (Stmt.Hptset.t * Locations.Zone.t option) option
+ (Stmt.Hptset.t * Locations.Zone.t option) option
(** @return the set of statements that define [lval] before [stmt] in [kf].
Also returns the zone that is possibly not defined.
Can return [None] when the information is not available (Pdg missing). *)
val get_defs_with_type :
Kernel_function.t -> stmt -> lval ->
- ((bool * bool) Stmt.Map.t * Locations.Zone.t option) option
-(** @return a map from the statements that define [lval] before [stmt] in
- [kf]. The first boolean indicates the possibility of a direct
- modification at this statement, ie. [lval = ...] or [lval = f()].
- The second boolean indicates a possible indirect modification through
- a call.
- Also returns the zone that is possibly not defined.
- Can return [None] when the information is not available (Pdg missing).
- *)
+ ((bool * bool) Stmt.Map.t * Locations.Zone.t option) option
+ (** @return a map from the statements that define [lval] before [stmt] in
+ [kf]. The first boolean indicates the possibility of a direct
+ modification at this statement, ie. [lval = ...] or [lval = f()].
+ The second boolean indicates a possible indirect modification through
+ a call.
+ Also returns the zone that is possibly not defined.
+ Can return [None] when the information is not available (Pdg missing).
+ *)
end
module Datascope : sig
diff --git a/src/plugins/scope/datascope.ml b/src/plugins/scope/datascope.ml
index ea5c4fabe53a95c3963a27b73c003213933861a7..d4cab9e063d6590ddcd1586d9fafb89941ba01e1 100644
--- a/src/plugins/scope/datascope.ml
+++ b/src/plugins/scope/datascope.ml
@@ -21,7 +21,7 @@
(**************************************************************************)
(** The aim here is to select the statements where a data D
-* has the same value then a given starting program point L. *)
+ * has the same value then a given starting program point L. *)
open Cil_types
@@ -31,17 +31,17 @@ let () = Plugin.default_msg_keys [cat_rm_asserts_name]
module R =
Plugin.Register
(struct
- let name = "scope"
- let shortname = "scope"
- let help = "data dependencies higher level functions"
- end)
+ let name = "scope"
+ let shortname = "scope"
+ let help = "data dependencies higher level functions"
+ end)
let cat_rm_asserts = R.register_category cat_rm_asserts_name
(** {2 Computing a mapping between zones and modifying statements}
-We first go through all the function statements in other to build
-a mapping between each zone and the statements that are modifying it.
-**)
+ We first go through all the function statements in other to build
+ a mapping between each zone and the statements that are modifying it.
+ **)
(** Statement identifier *)
module StmtDefault = struct
@@ -87,8 +87,8 @@ let get_lval_zones ~for_writing stmt lval =
dpds, exact, zone
(** Add to [stmt] to [lmap] for all the locations modified by the statement.
-* Something to do only for calls and assignments.
-* *)
+ * Something to do only for calls and assignments.
+ * *)
let register_modified_zones lmap stmt =
let register lmap zone = InitSid.add_zone lmap zone stmt in
let aux_out kf out =
@@ -96,46 +96,46 @@ let register_modified_zones lmap stmt =
Locations.Zone.join out inout.Inout_type.over_outputs
in
match stmt.skind with
- | Instr (Set (lval, _, _)) ->
+ | Instr (Set (lval, _, _)) ->
+ let _dpds, _, zone =
+ get_lval_zones ~for_writing:true stmt lval
+ in
+ register lmap zone
+ | Instr (Local_init(v, i, _)) ->
+ let _, _, zone = get_lval_zones ~for_writing:true stmt (Cil.var v) in
+ let lmap_init = register lmap zone in
+ (match i with
+ | AssignInit _ -> lmap_init
+ | ConsInit(f,_,_) ->
+ let kf = Globals.Functions.get f in
+ let out = aux_out kf Locations.Zone.bottom in
+ register lmap_init out)
+ | Instr (Call (dst,funcexp,_args,_)) ->
+ begin
+ let lmap = match dst with
+ | None -> lmap
+ | Some lval ->
let _dpds, _, zone =
- get_lval_zones ~for_writing:true stmt lval
+ get_lval_zones ~for_writing:true stmt lval
in
register lmap zone
- | Instr (Local_init(v, i, _)) ->
- let _, _, zone = get_lval_zones ~for_writing:true stmt (Cil.var v) in
- let lmap_init = register lmap zone in
- (match i with
- | AssignInit _ -> lmap_init
- | ConsInit(f,_,_) ->
- let kf = Globals.Functions.get f in
- let out = aux_out kf Locations.Zone.bottom in
- register lmap_init out)
- | Instr (Call (dst,funcexp,_args,_)) ->
- begin
- let lmap = match dst with
- | None -> lmap
- | Some lval ->
- let _dpds, _, zone =
- get_lval_zones ~for_writing:true stmt lval
- in
- register lmap zone
- in
- let _, kfs =
- !Db.Value.expr_to_kernel_function ~deps:None (Kstmt stmt) funcexp
- in
- let out =
- Kernel_function.Hptset.fold aux_out kfs Locations.Zone.bottom
- in
- register lmap out
- end
- | _ -> lmap
+ in
+ let _, kfs =
+ !Db.Value.expr_to_kernel_function ~deps:None (Kstmt stmt) funcexp
+ in
+ let out =
+ Kernel_function.Hptset.fold aux_out kfs Locations.Zone.bottom
+ in
+ register lmap out
+ end
+ | _ -> lmap
(** compute the mapping for the function
* @raise Kernel_function.No_Definition if [kf] has no definition
- *)
+*)
let compute kf =
- R.debug ~level:1 "computing for function %a" Kernel_function.pretty kf;
+ R.debug ~level:1 "computing for function %a" Kernel_function.pretty kf;
let f = Kernel_function.get_definition kf in
let do_stmt lmap s =
Cil.CurrentLoc.set (Cil_datatype.Stmt.loc s);
@@ -145,7 +145,7 @@ let compute kf =
in
let f_datas = List.fold_left do_stmt InitSid.empty f.sallstmts in
R.debug ~level:2 "data init stmts : %a" InitSid.pretty f_datas;
- f.sallstmts, f_datas (* TODO : store it ! *)
+ f.sallstmts, f_datas (* TODO : store it ! *)
(** {2 Computing Scopes} *)
@@ -198,20 +198,20 @@ module State = struct
type t = Start | NotSeen | Modif | SameVal
let pretty fmt b = Format.fprintf fmt "%s" (match b with
- | Start -> "Start"
- | NotSeen -> "NotSeen"
- | Modif -> "Modif"
- | SameVal -> "SameVal")
+ | Start -> "Start"
+ | NotSeen -> "NotSeen"
+ | Modif -> "Modif"
+ | SameVal -> "SameVal")
let bottom = NotSeen
(* Just compute the "max" between elements of the lattice. *)
let merge b1 b2 =
let b = match b1, b2 with
- | Start, _ | _, Start -> Start
- | NotSeen, b | b, NotSeen -> b
- | Modif, _ | _, Modif -> Modif
- | SameVal, SameVal -> SameVal
+ | Start, _ | _, Start -> Start
+ | NotSeen, b | b, NotSeen -> b
+ | Modif, _ | _, Modif -> Modif
+ | SameVal, SameVal -> SameVal
in b
let join = merge;;
@@ -247,8 +247,8 @@ let backward_data_scope modif_stmts s kf =
let modified s = StmtSetLattice.mem s modif_stmts in
let module Fenv = (val Dataflows.function_env kf: Dataflows.FUNCTION_ENV) in
let module Arg = struct
- include BackwardScope(struct let modified = modified end)
- let init = [(s,State.Start)];;
+ include BackwardScope(struct let modified = modified end)
+ let init = [(s,State.Start)];;
end in
let module Compute = Dataflows.Simple_backward(Fenv)(Arg) in
Compute.pre_state
@@ -301,16 +301,16 @@ let forward_data_scope modif_stmts modif_edge s kf =
(* Add only 'simple' statements. *)
let add_s s acc =
match s.skind with
- | Instr _ | Return _ | Continue _ | Break _ | Goto _ | Throw _
- -> Cil_datatype.Stmt.Hptset.add s acc
- | Block _ | Switch _ | If _ | UnspecifiedSequence _ | Loop _
- | TryExcept _ | TryFinally _ | TryCatch _
- -> acc
+ | Instr _ | Return _ | Continue _ | Break _ | Goto _ | Throw _
+ -> Cil_datatype.Stmt.Hptset.add s acc
+ | Block _ | Switch _ | If _ | UnspecifiedSequence _ | Loop _
+ | TryExcept _ | TryFinally _ | TryCatch _
+ -> acc
(** Do backward and then forward propagations and compute the 3 statement sets :
-* - forward only,
-* - forward and backward,
-* - backward only.
+ * - forward only,
+ * - forward and backward,
+ * - backward only.
*)
let find_scope allstmts modif_stmts modif_edge s kf =
(* Add only statements for which the lvalue certainly did not change. *)
@@ -404,9 +404,9 @@ let is_modified_by_edge kf z s1 s2 =
Locations.Zone.intersects z (PairStmts.Hashtbl.find modifs_edge (s1, s2))
(** Try to find the statement set where [data] has the same value than
-* before [stmt].
+ * before [stmt].
* @raise Kernel_function.No_Definition if [kf] has no definition
- *)
+*)
let get_data_scope_at_stmt kf stmt lval =
let dpds, _, zone = get_lval_zones ~for_writing:false stmt lval in
(* TODO : is there something to do with 'exact' ? *)
@@ -419,15 +419,15 @@ let get_data_scope_at_stmt kf stmt lval =
in
R.debug
"@[<hv 4>get_data_scope_at_stmt %a at %d @\n\
- modified by = %a@\n\
- f = %a@\nfb = %a@\nb = %a@]"
- (* stmt at *)
+ modified by = %a@\n\
+ f = %a@\nfb = %a@\nb = %a@]"
+ (* stmt at *)
Locations.Zone.pretty zone stmt.sid
- (* modified by *)
+ (* modified by *)
(Pretty_utils.pp_iter
StmtSetLattice.iter ~sep:",@ " Cil_datatype.Stmt.pretty_sid)
modif_stmts
- (* scope *)
+ (* scope *)
Cil_datatype.Stmt.Hptset.pretty f_scope
Cil_datatype.Stmt.Hptset.pretty fb_scope
Cil_datatype.Stmt.Hptset.pretty b_scope;
@@ -436,27 +436,27 @@ let get_data_scope_at_stmt kf stmt lval =
exception ToDo
let get_annot_zone kf stmt annot =
- let add_zone z info =
- let s = info.Db.Properties.Interp.To_zone.ki in
- let before = info.Db.Properties.Interp.To_zone.before in
- let zone = info.Db.Properties.Interp.To_zone.zone in
- R.debug ~level:2 "[forward_prop_scope] need %a %s stmt %d@."
- Locations.Zone.pretty zone
- (if before then "before" else "after") s.sid;
- if before && stmt.sid = s.sid then
- Locations.Zone.join zone z
- else (* TODO *)
- raise ToDo
- in
- let (info, _), _ =
- !Db.Properties.Interp.To_zone.from_stmt_annot annot (stmt, kf)
- in
- match info with
- | None -> raise ToDo
- | Some info ->
- let zone = List.fold_left add_zone Locations.Zone.bottom info in
- R.debug "[get_annot_zone] need %a" Locations.Zone.pretty zone ;
- zone
+ let add_zone z info =
+ let s = info.Db.Properties.Interp.To_zone.ki in
+ let before = info.Db.Properties.Interp.To_zone.before in
+ let zone = info.Db.Properties.Interp.To_zone.zone in
+ R.debug ~level:2 "[forward_prop_scope] need %a %s stmt %d@."
+ Locations.Zone.pretty zone
+ (if before then "before" else "after") s.sid;
+ if before && stmt.sid = s.sid then
+ Locations.Zone.join zone z
+ else (* TODO *)
+ raise ToDo
+ in
+ let (info, _), _ =
+ !Db.Properties.Interp.To_zone.from_stmt_annot annot (stmt, kf)
+ in
+ match info with
+ | None -> raise ToDo
+ | Some info ->
+ let zone = List.fold_left add_zone Locations.Zone.bottom info in
+ R.debug "[get_annot_zone] need %a" Locations.Zone.pretty zone ;
+ zone
module CA_Map = Cil_datatype.Code_annotation.Map
@@ -525,8 +525,8 @@ let code_annot_is_volatile ca =
with VolatileFound -> true
(** Return the set of stmts ([scope]) where [annot] has the same value
- as at [stmt], and adds to [proven] the annotations that are identical to
- [annot] at statements that are both in [scope] and dominated by [stmt].
+ as at [stmt], and adds to [proven] the annotations that are identical to
+ [annot] at statements that are both in [scope] and dominated by [stmt].
[stmt] is not added to the set, and [annot] is not added to [proven]. *)
let get_prop_scope_at_stmt ~warn kf stmt ?(proven=CA_Map.empty) annot =
R.debug "[get_prop_scope_at_stmt] at stmt %d in %a : %a"
@@ -535,32 +535,32 @@ let get_prop_scope_at_stmt ~warn kf stmt ?(proven=CA_Map.empty) annot =
let acc = (Cil_datatype.Stmt.Hptset.empty, proven) in
if code_annot_is_volatile annot then acc
else
- try
- let zone = get_annot_zone kf stmt annot in
- let allstmts, info = compute kf in
- let modif_stmts = InitSid.find info zone in
- let modifs_edge = is_modified_by_edge kf zone in
- let pre_state, _ = forward_data_scope modif_stmts modifs_edge stmt kf in
- begin match annot.annot_content with
- | AAssert _ -> ()
- | _ -> R.abort "only 'assert' are handled by get_prop_scope_at_stmt"
- end;
- let add ((acc_scope, acc_to_be_rm) as acc) s = match pre_state s with
- | State.SameVal ->
- if Dominators.dominates stmt s && not (Cil_datatype.Stmt.equal stmt s)
- then
- let acc_scope = add_s s acc_scope in
- let acc_to_be_rm = check_stmt_annots (annot, stmt) s acc_to_be_rm in
- (acc_scope, acc_to_be_rm)
- else acc
- | _ -> acc
- in
- List.fold_left add acc allstmts
- with ToDo ->
- if warn then
- R.warning ~current:true ~once:true
- "[get_annot_zone] don't know how to compute zone: skip this annotation";
- acc
+ try
+ let zone = get_annot_zone kf stmt annot in
+ let allstmts, info = compute kf in
+ let modif_stmts = InitSid.find info zone in
+ let modifs_edge = is_modified_by_edge kf zone in
+ let pre_state, _ = forward_data_scope modif_stmts modifs_edge stmt kf in
+ begin match annot.annot_content with
+ | AAssert _ -> ()
+ | _ -> R.abort "only 'assert' are handled by get_prop_scope_at_stmt"
+ end;
+ let add ((acc_scope, acc_to_be_rm) as acc) s = match pre_state s with
+ | State.SameVal ->
+ if Dominators.dominates stmt s && not (Cil_datatype.Stmt.equal stmt s)
+ then
+ let acc_scope = add_s s acc_scope in
+ let acc_to_be_rm = check_stmt_annots (annot, stmt) s acc_to_be_rm in
+ (acc_scope, acc_to_be_rm)
+ else acc
+ | _ -> acc
+ in
+ List.fold_left add acc allstmts
+ with ToDo ->
+ if warn then
+ R.warning ~current:true ~once:true
+ "[get_annot_zone] don't know how to compute zone: skip this annotation";
+ acc
(** Collect the annotations that can be removed because they are redundant. *)
class check_annot_visitor = object(self)
@@ -594,7 +594,7 @@ class check_annot_visitor = object(self)
| GFun (fdec, _loc) when
!Db.Value.is_called (Option.get self#current_kf) &&
not (!Db.Value.no_results fdec)
- ->
+ ->
Cil.DoChildren
| _ -> Cil.SkipChildren
@@ -613,8 +613,8 @@ let check_asserts () =
R.feedback "check if there are some redundant assertions...";
let to_be_removed = redundant_assertions () in
let n = CA_Map.cardinal to_be_removed in
- R.result "[check_asserts] %d assertion(s) could be removed@." n;
- (list_proven to_be_removed)
+ R.result "[check_asserts] %d assertion(s) could be removed@." n;
+ (list_proven to_be_removed)
(* erasing optional arguments, plus return a list*)
let get_prop_scope_at_stmt kf stmt annot =
@@ -655,13 +655,13 @@ let get_data_scope_at_stmt =
Journal.register
"Scope.Datascope.get_data_scope_at_stmt"
(Datatype.func3
- Kernel_function.ty
- Cil_datatype.Stmt.ty
- Cil_datatype.Lval.ty
- (Datatype.pair
- Cil_datatype.Stmt.Hptset.ty
- (Datatype.pair Cil_datatype.Stmt.Hptset.ty
- Cil_datatype.Stmt.Hptset.ty)))
+ Kernel_function.ty
+ Cil_datatype.Stmt.ty
+ Cil_datatype.Lval.ty
+ (Datatype.pair
+ Cil_datatype.Stmt.Hptset.ty
+ (Datatype.pair Cil_datatype.Stmt.Hptset.ty
+ Cil_datatype.Stmt.Hptset.ty)))
get_data_scope_at_stmt
let get_prop_scope_at_stmt =
diff --git a/src/plugins/scope/defs.ml b/src/plugins/scope/defs.ml
index 15fd69d4199dcd1e5004f43bb91aaaf309eb6f2f..565500c763b879c05749244de1dfb148edbbf699 100644
--- a/src/plugins/scope/defs.ml
+++ b/src/plugins/scope/defs.ml
@@ -21,8 +21,8 @@
(**************************************************************************)
(** Find the statements that defines a given data at a program point,
-* ie. in each backward path starting from this point, find the statement
-* the the data has been assigned for the last time. *)
+ * ie. in each backward path starting from this point, find the statement
+ * the the data has been assigned for the last time. *)
open Cil_datatype
open Cil_types
@@ -30,10 +30,10 @@ open Cil_types
let debug1 fmt = Datascope.R.debug ~level:1 fmt
module Interproc =
- Datascope.R.True(struct
- let option_name = "-scope-defs-interproc"
- let help = "interprocedural defs computation"
- end)
+ Datascope.R.True(struct
+ let option_name = "-scope-defs-interproc"
+ let help = "interprocedural defs computation"
+ end)
module NSet = PdgTypes.Node.Set
@@ -43,11 +43,11 @@ let add_list_to_set l s = List.fold_left (fun r n -> NSet.add n r) s l
let _pp_list_node_underout prefix fmt =
Pretty_utils.pp_list ~pre:(prefix ^^ " @[") ~suf:"@]@." ~sep:"@ "
(fun fmt (n, undef) ->
- match undef with
- | None -> PdgTypes.Node.pretty fmt n
- | Some undef ->
- Format.fprintf fmt "%a {underout %a}"
- PdgTypes.Node.pretty n Locations.Zone.pretty undef)
+ match undef with
+ | None -> PdgTypes.Node.pretty fmt n
+ | Some undef ->
+ Format.fprintf fmt "%a {underout %a}"
+ PdgTypes.Node.pretty n Locations.Zone.pretty undef)
fmt
let _pp_set prefix fmt =
@@ -59,30 +59,30 @@ let _pp_set prefix fmt =
to functions, go inside those calls, and find which nodes are relevant. *)
let rec add_callee_nodes z acc nodes =
let new_nodes, acc = NSet.fold
- (fun node acc2 ->
- match !Db.Pdg.node_key node with
- | PdgIndex.Key.SigCallKey (cid, PdgIndex.Signature.Out out_key) ->
- let callees =
- Db.Value.call_to_kernel_function (PdgIndex.Key.call_from_id cid)
- in
- Kernel_function.Hptset.fold (fun kf (new_nodes, acc) ->
- let callee_pdg = !Db.Pdg.get kf in
- let outputs = match out_key with
- | PdgIndex.Signature.OutLoc out ->
- (* [out] might be an over-approximation of the location
- we are searching for. We refine the search if needed. *)
- let z = Locations.Zone.narrow out z in
- fst (!Db.Pdg.find_location_nodes_at_end callee_pdg z)
- | PdgIndex.Signature.OutRet -> (* probably never occurs *)
- fst (!Db.Pdg.find_output_nodes callee_pdg out_key)
- in
- let outputs = List.map fst outputs in
- add_list_to_set outputs new_nodes, add_list_to_set outputs acc)
- callees
- acc2
- | _ -> acc2)
- nodes
- (NSet.empty, acc)
+ (fun node acc2 ->
+ match !Db.Pdg.node_key node with
+ | PdgIndex.Key.SigCallKey (cid, PdgIndex.Signature.Out out_key) ->
+ let callees =
+ Db.Value.call_to_kernel_function (PdgIndex.Key.call_from_id cid)
+ in
+ Kernel_function.Hptset.fold (fun kf (new_nodes, acc) ->
+ let callee_pdg = !Db.Pdg.get kf in
+ let outputs = match out_key with
+ | PdgIndex.Signature.OutLoc out ->
+ (* [out] might be an over-approximation of the location
+ we are searching for. We refine the search if needed. *)
+ let z = Locations.Zone.narrow out z in
+ fst (!Db.Pdg.find_location_nodes_at_end callee_pdg z)
+ | PdgIndex.Signature.OutRet -> (* probably never occurs *)
+ fst (!Db.Pdg.find_output_nodes callee_pdg out_key)
+ in
+ let outputs = List.map fst outputs in
+ add_list_to_set outputs new_nodes, add_list_to_set outputs acc)
+ callees
+ acc2
+ | _ -> acc2)
+ nodes
+ (NSet.empty, acc)
in if NSet.is_empty new_nodes then acc else add_callee_nodes z acc new_nodes
(** [kf] doesn't define all the data that we are looking for: the [undef]
@@ -100,34 +100,34 @@ let rec add_caller_nodes z kf acc (undef, nodes) =
let acc_undef, acc = match undef with
| None -> acc_undef, acc
| Some undef ->
- let nodes_for_undef, undef' =
- !Db.Pdg.find_location_nodes_at_stmt pdg stmt ~before:true undef
- in
- let acc_undef = join_undef acc_undef undef' in
- let acc = add_list_to_set (List.map fst nodes_for_undef) acc in
- acc_undef, acc
+ let nodes_for_undef, undef' =
+ !Db.Pdg.find_location_nodes_at_stmt pdg stmt ~before:true undef
+ in
+ let acc_undef = join_undef acc_undef undef' in
+ let acc = add_list_to_set (List.map fst nodes_for_undef) acc in
+ acc_undef, acc
in
let add_call_input_nodes node (acc_undef, acc) =
match !Db.Pdg.node_key node with
- | PdgIndex.Key.SigKey (PdgIndex.Signature.In in_key) ->
- begin match in_key with
- | PdgIndex.Signature.InCtrl ->
- (* We only look for the values *)
- acc_undef, acc
- | PdgIndex.Signature.InNum n_param ->
- let n = !Db.Pdg.find_call_input_node pdg stmt n_param in
- acc_undef, NSet.add n acc
- | PdgIndex.Signature.InImpl z' ->
- let z = Locations.Zone.narrow z z' in
- let nodes, undef'= !Db.Pdg.find_location_nodes_at_stmt
- pdg stmt ~before:true z
- in
- let acc_undef = join_undef acc_undef undef' in
- acc_undef, add_list_to_set (List.map fst nodes) acc
- end
- | _ -> acc_undef, acc
+ | PdgIndex.Key.SigKey (PdgIndex.Signature.In in_key) ->
+ begin match in_key with
+ | PdgIndex.Signature.InCtrl ->
+ (* We only look for the values *)
+ acc_undef, acc
+ | PdgIndex.Signature.InNum n_param ->
+ let n = !Db.Pdg.find_call_input_node pdg stmt n_param in
+ acc_undef, NSet.add n acc
+ | PdgIndex.Signature.InImpl z' ->
+ let z = Locations.Zone.narrow z z' in
+ let nodes, undef'= !Db.Pdg.find_location_nodes_at_stmt
+ pdg stmt ~before:true z
+ in
+ let acc_undef = join_undef acc_undef undef' in
+ acc_undef, add_list_to_set (List.map fst nodes) acc
+ end
+ | _ -> acc_undef, acc
in
- NSet.fold add_call_input_nodes nodes (acc_undef, acc)
+ NSet.fold add_call_input_nodes nodes (acc_undef, acc)
in
let add_one_caller_nodes acc (kf, stmts) =
let pdg = !Db.Pdg.get kf in
@@ -149,7 +149,7 @@ let compute_aux kf stmt zone =
if Interproc.get () then
begin
let caller_nodes = add_caller_nodes zone kf nodes (undef, nodes) in
- add_callee_nodes zone caller_nodes caller_nodes
+ add_callee_nodes zone caller_nodes caller_nodes
end
else nodes
in
@@ -161,8 +161,8 @@ let compute kf stmt lval =
let extract (nodes, undef) =
let add_node node defs =
match PdgIndex.Key.stmt (!Db.Pdg.node_key node) with
- | None -> defs
- | Some s -> Stmt.Hptset.add s defs
+ | None -> defs
+ | Some s -> Stmt.Hptset.add s defs
in
(* select corresponding stmts *)
let defs = NSet.fold add_node nodes Stmt.Hptset.empty in
@@ -188,30 +188,30 @@ let compute_with_def_type_zone kf stmt zone =
Stmt.Map.add stmt after acc
in
match !Db.Pdg.node_key node with
- | PdgIndex.Key.Stmt s -> change s (true, false)
- | PdgIndex.Key.CallStmt _ -> assert false
- | PdgIndex.Key.SigCallKey (s, sign) ->
- (match sign with
- | PdgIndex.Signature.Out (PdgIndex.Signature.OutRet) ->
- change s (true, false) (* defined by affectation in 'v = f()' *)
- | PdgIndex.Signature.In _ ->
- change s (true, false) (* defined by formal v in 'f(v)' *)
- | PdgIndex.Signature.Out (PdgIndex.Signature.OutLoc _) -> begin
- match s.skind with
- | Instr (Call (_, { enode = Lval (Var vi, NoOffset)}, _, _)
- | Local_init (_, ConsInit(vi,_,_),_))
- when let kf = Globals.Functions.get vi in
- !Db.Value.use_spec_instead_of_definition kf
- ->
- (* defined through a call, but function has no body *)
- change s (true, false)
- | _ ->
- (* defined within call to a function with a body*)
- change s (false, true)
- end
- )
- | PdgIndex.Key.SigKey _ -> acc
- | s -> Format.printf "## %a@." PdgIndex.Key.pretty s; acc
+ | PdgIndex.Key.Stmt s -> change s (true, false)
+ | PdgIndex.Key.CallStmt _ -> assert false
+ | PdgIndex.Key.SigCallKey (s, sign) ->
+ (match sign with
+ | PdgIndex.Signature.Out (PdgIndex.Signature.OutRet) ->
+ change s (true, false) (* defined by affectation in 'v = f()' *)
+ | PdgIndex.Signature.In _ ->
+ change s (true, false) (* defined by formal v in 'f(v)' *)
+ | PdgIndex.Signature.Out (PdgIndex.Signature.OutLoc _) -> begin
+ match s.skind with
+ | Instr (Call (_, { enode = Lval (Var vi, NoOffset)}, _, _)
+ | Local_init (_, ConsInit(vi,_,_),_))
+ when let kf = Globals.Functions.get vi in
+ !Db.Value.use_spec_instead_of_definition kf
+ ->
+ (* defined through a call, but function has no body *)
+ change s (true, false)
+ | _ ->
+ (* defined within call to a function with a body*)
+ change s (false, true)
+ end
+ )
+ | PdgIndex.Key.SigKey _ -> acc
+ | s -> Format.printf "## %a@." PdgIndex.Key.pretty s; acc
in
let stmts = NSet.fold add_node nodes Stmt.Map.empty in
(stmts, undef)
@@ -226,12 +226,12 @@ let compute_with_def_type kf stmt lval =
(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
module D = Datatype.Option
- (Datatype.Pair(Stmt.Hptset)(Datatype.Option(Locations.Zone)))
+ (Datatype.Pair(Stmt.Hptset)(Datatype.Option(Locations.Zone)))
module DT = Datatype.Option
- (Datatype.Pair
- (Stmt.Map.Make(Datatype.Pair(Datatype.Bool)(Datatype.Bool)))
- (Datatype.Option(Locations.Zone)))
+ (Datatype.Pair
+ (Stmt.Map.Make(Datatype.Pair(Datatype.Bool)(Datatype.Bool)))
+ (Datatype.Option(Locations.Zone)))
let get_defs =
Journal.register
diff --git a/src/plugins/scope/zones.ml b/src/plugins/scope/zones.ml
index c31538198cd8bfb24dc050a52ebe36b32180f70a..9a9e18e7c26c5060b93725f7bbc5c1ca7964ea13 100644
--- a/src/plugins/scope/zones.ml
+++ b/src/plugins/scope/zones.ml
@@ -61,7 +61,7 @@ let compute_new_data old_zone l_zone l_dpds exact r_dpds =
let zone = if exact then Data.diff old_zone l_zone else old_zone in
let zone = Data.merge zone l_dpds in
let zone = Data.merge zone r_dpds in
- (true, zone)
+ (true, zone)
else (false, old_zone)
(* the call result can be processed like a normal assignment *)
@@ -69,18 +69,18 @@ let process_call_res data stmt lvaloption froms =
let data = match lvaloption with
| None -> false, data
| Some lval ->
- let ret_dpds = froms.Function_Froms.deps_return in
- let r_dpds = Function_Froms.Memory.collapse_return ret_dpds in
- let r_dpds = Function_Froms.Deps.to_zone r_dpds in
- let l_dpds, exact, l_zone =
- Datascope.get_lval_zones ~for_writing:true stmt lval in
- compute_new_data data l_zone l_dpds exact r_dpds
+ let ret_dpds = froms.Function_Froms.deps_return in
+ let r_dpds = Function_Froms.Memory.collapse_return ret_dpds in
+ let r_dpds = Function_Froms.Deps.to_zone r_dpds in
+ let l_dpds, exact, l_zone =
+ Datascope.get_lval_zones ~for_writing:true stmt lval in
+ compute_new_data data l_zone l_dpds exact r_dpds
in data
(* we need [data_after] zone after the call, so we need to add the dpds
-* of each output that intersects this zone.
-* Moreover, we need to add the part of [data_after] that has not been
-* modified for sure. *)
+ * of each output that intersects this zone.
+ * Moreover, we need to add the part of [data_after] that has not been
+ * modified for sure. *)
let process_froms data_after froms =
let from_table = froms.Function_Froms.deps_table in
let process_out_call out deps (to_prop, used, new_data) =
@@ -91,13 +91,13 @@ let process_froms data_after froms =
if (Data.intersects data_after out) then
let to_prop = if exact then Data.diff to_prop out else to_prop in
let new_data = Data.merge new_data out_dpds in
- (to_prop, true, new_data)
+ (to_prop, true, new_data)
else (to_prop, used, new_data)
in
let to_prop =
(* part of data_after that we need to compute before call :
- * = data_after minus all exact outputs.
- * Don't use [data_after - (merge out)] to avoid approximation in merge *)
+ * = data_after minus all exact outputs.
+ * Don't use [data_after - (merge out)] to avoid approximation in merge *)
data_after in
let new_data = Data.bottom in (* add out_dpds when out intersects data_after*)
let used = false in (* is the call needed ? *)
@@ -110,7 +110,7 @@ let process_froms data_after froms =
| Function_Froms.Memory.Map m ->
Function_Froms.Memory.fold process_out_call m (to_prop, used, new_data)
in let data = Data.merge to_prop new_data in
- (used, data)
+ (used, data)
let process_call_args data called_kf stmt args =
let param_list = Kernel_function.get_formals called_kf in
@@ -120,28 +120,28 @@ let process_call_args data called_kf stmt args =
let exact = true in (* param is always a variable so asgn is exact *)
let _used, data =
compute_new_data data param_zone Data.bottom exact arg_dpds in
- (* can ignore 'used' because if we need param, we already know that the
- * call is needed *)
- data
+ (* can ignore 'used' because if we need param, we already know that the
+ * call is needed *)
+ data
in
let rec do_param_arg data param_list args =
match param_list, args with
- | [], [] -> data
- | p :: param_list, a :: args ->
- let data = asgn_arg_to_param data p a in
- do_param_arg data param_list args
- | [], _ -> (* call to a variadic function *)
- (* warning already sent during 'from' computation. *)
- (* TODO : merge the remaining args in data ?... *)
- data
- | _, [] -> R.abort "call to a function with to few arguments"
+ | [], [] -> data
+ | p :: param_list, a :: args ->
+ let data = asgn_arg_to_param data p a in
+ do_param_arg data param_list args
+ | [], _ -> (* call to a variadic function *)
+ (* warning already sent during 'from' computation. *)
+ (* TODO : merge the remaining args in data ?... *)
+ data
+ | _, [] -> R.abort "call to a function with to few arguments"
in do_param_arg data param_list args
let process_one_call data stmt lvaloption froms =
let res_used, data = process_call_res data stmt lvaloption froms in
let out_used, data = process_froms data froms in
let used = res_used || out_used in
- used, data
+ used, data
let process_call data_after stmt lvaloption funcexp args _loc =
let funcexp_dpds, called_functions =
@@ -151,14 +151,14 @@ let process_call data_after stmt lvaloption funcexp args _loc =
let used, data =
try
let froms = !Db.From.Callwise.find (Kstmt stmt) in
- process_one_call data_after stmt lvaloption froms
+ process_one_call data_after stmt lvaloption froms
with Not_found -> (* don't have callwise (-calldeps option) *)
let do_call kf acc =
(* notice that we use the same old data for each possible call *)
(process_one_call data_after stmt lvaloption (!Db.From.get kf))::acc
in
let l = Kernel_function.Hptset.fold do_call called_functions [] in
- (* in l, we have one result for each possible function called *)
+ (* in l, we have one result for each possible function called *)
List.fold_left
(fun (acc_u,acc_d) (u,d) -> (acc_u || u), Data.merge acc_d d)
(false, Data.bottom)
@@ -173,7 +173,7 @@ let process_call data_after stmt lvaloption funcexp args _loc =
data
in
let data = Data.merge funcexp_dpds data in
- used, data
+ used, data
else begin
assert (R.verify (Data.equal data data_after)
"if statement not used, data doesn't change !");
@@ -221,28 +221,28 @@ module Computer (Param:sig val states : Ctx.t end) = struct
let doInstr stmt instr data =
match instr with
- | Set (lval, exp, _) -> Dataflow2.Done (do_assign stmt lval exp data)
- | Local_init (v, AssignInit i, _) ->
- let rec aux lv i acc =
- match i with
- | SingleInit e -> do_assign stmt lv e data
- | CompoundInit(ct, initl) ->
- let implicit = true in
- let doinit o i _ data = aux (Cil.addOffsetLval o lv) i data in
- Cil.foldLeftCompound ~implicit ~doinit ~ct ~initl ~acc
- in
- Dataflow2.Done (aux (Cil.var v) i data)
- | Call (lvaloption,funcexp,args,loc) ->
- let used, data = process_call data stmt lvaloption funcexp args loc in
- let _ = if used then add_used_stmt stmt in
- Dataflow2.Done data
- | Local_init(v, ConsInit(f, args, k), l) ->
- let used, data =
- Cil.treat_constructor_as_func (process_call data stmt) v f args k l
- in
- if used then add_used_stmt stmt;
- Dataflow2.Done data
- | Skip _ | Code_annot _ | Asm _ -> Dataflow2.Default
+ | Set (lval, exp, _) -> Dataflow2.Done (do_assign stmt lval exp data)
+ | Local_init (v, AssignInit i, _) ->
+ let rec aux lv i acc =
+ match i with
+ | SingleInit e -> do_assign stmt lv e data
+ | CompoundInit(ct, initl) ->
+ let implicit = true in
+ let doinit o i _ data = aux (Cil.addOffsetLval o lv) i data in
+ Cil.foldLeftCompound ~implicit ~doinit ~ct ~initl ~acc
+ in
+ Dataflow2.Done (aux (Cil.var v) i data)
+ | Call (lvaloption,funcexp,args,loc) ->
+ let used, data = process_call data stmt lvaloption funcexp args loc in
+ let _ = if used then add_used_stmt stmt in
+ Dataflow2.Done data
+ | Local_init(v, ConsInit(f, args, k), l) ->
+ let used, data =
+ Cil.treat_constructor_as_func (process_call data stmt) v f args k l
+ in
+ if used then add_used_stmt stmt;
+ Dataflow2.Done data
+ | Skip _ | Code_annot _ | Asm _ -> Dataflow2.Default
let filterStmt _stmt _next = true
@@ -256,53 +256,53 @@ let compute_ctrl_info pdg ctrl_part used_stmts =
let seen = Stmt.Hashtbl.create 50 in
let rec add_node_ctrl_nodes new_stmts node =
let ctrl_nodes = !Db.Pdg.direct_ctrl_dpds pdg node in
- List.fold_left add_ctrl_node new_stmts ctrl_nodes
+ List.fold_left add_ctrl_node new_stmts ctrl_nodes
and add_ctrl_node new_stmts ctrl_node =
debug2 "[zones] add ctrl node %a@." PdgTypes.Node.pretty ctrl_node;
match PdgTypes.Node.stmt ctrl_node with
- | None -> (* node without stmt : add its ctrl_dpds *)
- add_node_ctrl_nodes new_stmts ctrl_node
- | Some stmt ->
- debug2 "[zones] node %a is stmt %d@."
- PdgTypes.Node.pretty ctrl_node stmt.sid;
- if Stmt.Hashtbl.mem seen stmt then new_stmts
- else
- let ctrl_zone = match stmt.skind with
- | Switch (exp,_,_,_) | If (exp,_,_,_) -> Data.exp_zone stmt exp
- | _ -> Data.bottom
- in Ctx.add ctrl_part stmt ctrl_zone;
- Stmt.Hashtbl.add seen stmt ();
- debug2 "[zones] add ctrl zone %a at stmt %d@."
- Data.pretty ctrl_zone stmt.sid;
- stmt::new_stmts
+ | None -> (* node without stmt : add its ctrl_dpds *)
+ add_node_ctrl_nodes new_stmts ctrl_node
+ | Some stmt ->
+ debug2 "[zones] node %a is stmt %d@."
+ PdgTypes.Node.pretty ctrl_node stmt.sid;
+ if Stmt.Hashtbl.mem seen stmt then new_stmts
+ else
+ let ctrl_zone = match stmt.skind with
+ | Switch (exp,_,_,_) | If (exp,_,_,_) -> Data.exp_zone stmt exp
+ | _ -> Data.bottom
+ in Ctx.add ctrl_part stmt ctrl_zone;
+ Stmt.Hashtbl.add seen stmt ();
+ debug2 "[zones] add ctrl zone %a at stmt %d@."
+ Data.pretty ctrl_zone stmt.sid;
+ stmt::new_stmts
and add_stmt_ctrl new_stmts stmt =
debug1 "[zones] add ctrl of stmt %d@." stmt.sid;
if Stmt.Hashtbl.mem seen stmt then new_stmts
else begin
Stmt.Hashtbl.add seen stmt ();
match !Db.Pdg.find_simple_stmt_nodes pdg stmt with
- | [] -> []
- | n::_ -> add_node_ctrl_nodes new_stmts n
+ | [] -> []
+ | n::_ -> add_node_ctrl_nodes new_stmts n
end
in
let rec add_stmts_ctrl stmts all_used_stmts =
let all_used_stmts = stmts @ all_used_stmts in
let new_stmts = List.fold_left add_stmt_ctrl [] stmts in
let preds = List.fold_left (fun acc s -> s.preds @ acc) [] new_stmts in
- if preds <> [] then CtrlCompute.compute preds;
+ if preds <> [] then CtrlCompute.compute preds;
let used_stmts = CtrlComputer.get_and_reset_used_stmts () in
- if used_stmts = [] then all_used_stmts
- else add_stmts_ctrl used_stmts all_used_stmts
+ if used_stmts = [] then all_used_stmts
+ else add_stmts_ctrl used_stmts all_used_stmts
in
- add_stmts_ctrl used_stmts []
+ add_stmts_ctrl used_stmts []
let compute kf stmt lval =
let f = Kernel_function.get_definition kf in
let dpds, _exact, zone =
Datascope.get_lval_zones ~for_writing:false stmt lval in
let zone = Data.merge dpds zone in
- debug1 "[zones] build for %a before %d in %a@\n"
- Data.pretty zone stmt.sid Kernel_function.pretty kf;
+ debug1 "[zones] build for %a before %d in %a@\n"
+ Data.pretty zone stmt.sid Kernel_function.pretty kf;
let data_part = Ctx.create 50 in
List.iter (fun s -> Ctx.add data_part s Data.bottom) f.sallstmts;
let _ = Ctx.add data_part stmt zone in
@@ -310,9 +310,9 @@ let compute kf stmt lval =
let module DataCompute = Dataflow2.Backwards(DataComputer) in
let _ = DataCompute.compute stmt.preds in
let ctrl_part = data_part (* Ctx.create 50 *) in
- (* it is confusing to have 2 part in the provided information,
- * because in fact, it means nothing to separate them.
- * So let's put everything in the same object *)
+ (* it is confusing to have 2 part in the provided information,
+ * because in fact, it means nothing to separate them.
+ * So let's put everything in the same object *)
let used_stmts = DataComputer.get_and_reset_used_stmts () in
let all_used_stmts =
if used_stmts = [] then []
@@ -331,7 +331,7 @@ let pretty fmt stmt_zones =
let pp s d = Format.fprintf fmt "Stmt:%d -> %a@." s.sid Data.pretty d in
Stmt.Hashtbl.iter_sorted pp stmt_zones
- (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
+(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
let build_zones kf stmt lval =
(* TODO: Journal.register *)
@@ -339,14 +339,14 @@ let build_zones kf stmt lval =
(Datatype.func Kernel_type.stmt
(Datatype.func Kernel_type.lval
(Datatype.couple Kernel_type.stmt_set zones_ty)))))
- *)
+ *)
if stmt.preds = []
then Stmt.Hptset.empty, Ctx.create 0
else compute kf stmt lval
let get_zones =
(* TODO: Journal.register *)
- (*(Datatype.func zones_ty (Datatype.func Kernel_type.stmt data_ty)))*)
+ (*(Datatype.func zones_ty (Datatype.func Kernel_type.stmt data_ty)))*)
get
let pretty_zones =
diff --git a/src/plugins/security_slicing/components.ml b/src/plugins/security_slicing/components.ml
index 371eadc8fb7d157cd6f8cd053325fdf6ad0aa620..af605036f174476ed91396a80eb74727be868928 100644
--- a/src/plugins/security_slicing/components.ml
+++ b/src/plugins/security_slicing/components.ml
@@ -103,31 +103,31 @@ let get_node_stmt node = Key.stmt (!Db.Pdg.node_key node)
module NodeKf = Datatype.Pair(PdgTypes.Node)(Kernel_function)
(* type bwd_kind = Direct | Indirect
-type fwd_kind = Impact | Security
-type kind =
- | Backward of bwd_kind
- | Forward of fwd_kind
-
-(** Debugging purpose only *)
-let pretty_kind fmt = function
- | Backward Direct -> Format.fprintf fmt "backward direct"
- | Backward Indirect -> Format.fprintf fmt "backward indirect"
- | Forward Security -> Format.fprintf fmt "forward"
- | Forward Impact -> Format.fprintf fmt "impact"
+ type fwd_kind = Impact | Security
+ type kind =
+ | Backward of bwd_kind
+ | Forward of fwd_kind
+
+ (** Debugging purpose only *)
+ let pretty_kind fmt = function
+ | Backward Direct -> Format.fprintf fmt "backward direct"
+ | Backward Indirect -> Format.fprintf fmt "backward indirect"
+ | Forward Security -> Format.fprintf fmt "forward"
+ | Forward Impact -> Format.fprintf fmt "impact"
*)
(* Never plugged in. To be tested.
-module Memo : sig
- val init: kind -> kernel_function -> unit
- val push_function: stmt -> kernel_function -> unit
- val pop_function: unit -> unit
- val memo:
+ module Memo : sig
+ val init: kind -> kernel_function -> unit
+ val push_function: stmt -> kernel_function -> unit
+ val pop_function: unit -> unit
+ val memo:
Pdg.t_node ->
(unit -> (Pdg.t_node * kernel_function) list) ->
(Pdg.t_node * kernel_function) list
-end = struct
+ end = struct
- module Callstack = struct
+ module Callstack = struct
type t =
{ mutable stack: (stmt * kernel_function) list;
@@ -157,21 +157,21 @@ end = struct
let hash = Hashtbl.hash
- end
+ end
- (* *********************************************************************** *)
- (* state: kind -> callstack -> (node * kf) -> (node * kf) list *)
+ (* *********************************************************************** *)
+ (* state: kind -> callstack -> (node * kf) -> (node * kf) list *)
- module Nodekfs = Hashtbl.Make(NodeKf) (* (node * kf) -> (node * kf) list *)
+ module Nodekfs = Hashtbl.Make(NodeKf) (* (node * kf) -> (node * kf) list *)
- module Callstacks = struct
+ module Callstacks = struct
include Hashtbl.Make(Callstack) (* callstack -> nodekfs *)
let memo tbl c =
try find tbl c
with Not_found -> let t = Nodekfs.create 7 in replace tbl c t; t
- end
+ end
- module Memo = struct
+ module Memo = struct
include Hashtbl
let memo tbl k callstack =
try
@@ -183,18 +183,18 @@ end = struct
Callstacks.replace callstacks callstack t;
replace tbl k callstacks;
t
- end
+ end
- type local_tbl = (Pdg.t_node * kernel_function) list Nodekfs.t
+ type local_tbl = (Pdg.t_node * kernel_function) list Nodekfs.t
- type state =
+ type state =
{ mutable kind: kind;
mutable callstack: Callstack.t;
mutable local_tbl: local_tbl;
memo_tbl: (kind, local_tbl Callstacks.t) Memo.t; }
- (* *********************************************************************** *)
+ (* *********************************************************************** *)
- let state =
+ let state =
let spec = Cil.empty_funspec () in
{ kind = Backward Direct;
callstack =
@@ -213,23 +213,23 @@ end = struct
local_tbl = Nodekfs.create 0;
memo_tbl = Hashtbl.create 5 }
- let update () =
+ let update () =
state.local_tbl <- Memo.memo state.memo_tbl state.kind state.callstack
- let init k kf =
+ let init k kf =
state.kind <- k;
Callstack.init kf state.callstack;
update ()
- let push_function stmt kf =
+ let push_function stmt kf =
Callstack.push stmt kf state.callstack;
update ()
- let pop_function () =
+ let pop_function () =
Callstack.pop state.callstack;
update ()
- let memo node f =
+ let memo node f =
let key = node, state.callstack.Callstack.current_kf in
try
Nodekfs.find state.local_tbl key
@@ -238,49 +238,49 @@ end = struct
Nodekfs.replace state.local_tbl key value;
value
-end
+ end
*)
(* used to enforce an invariant on [add] *)
module Todolist : sig
type todo = private
- { node: PdgTypes.Node.t;
- kf: kernel_function;
- pdg: Db.Pdg.t;
- callstack_length: int;
- from_deep: bool }
+ { node: PdgTypes.Node.t;
+ kf: kernel_function;
+ pdg: Db.Pdg.t;
+ callstack_length: int;
+ from_deep: bool }
type t = todo list
val mk_init: kernel_function -> Db.Pdg.t -> PdgTypes.Node.t list -> todo list
- val add:
+ val add:
PdgTypes.Node.t -> kernel_function -> Db.Pdg.t -> int -> bool -> t -> t
end = struct
type todo =
- { node: PdgTypes.Node.t;
- kf: kernel_function;
- pdg: Db.Pdg.t;
- callstack_length: int;
- from_deep: bool }
+ { node: PdgTypes.Node.t;
+ kf: kernel_function;
+ pdg: Db.Pdg.t;
+ callstack_length: int;
+ from_deep: bool }
type t = todo list
let add n kf pdg len fd list =
match !Db.Pdg.node_key n with
| Key.SigKey (Signature.In Signature.InCtrl) ->
- (* do not consider node [InCtrl] *)
- list
+ (* do not consider node [InCtrl] *)
+ list
| Key.VarDecl vi when not (Kernel.LibEntry.get () && vi.vglob) ->
- (* do not consider variable declaration,
- except if libEntry is set and they are globals
- (i.e. we could have no further info about them) *)
- list
+ (* do not consider variable declaration,
+ except if libEntry is set and they are globals
+ (i.e. we could have no further info about them) *)
+ list
| _ ->
- Security_slicing_parameters.debug ~level:2 "adding node %a (in %s)"
- (!Db.Pdg.pretty_node false) n
- (Kernel_function.get_name kf);
- { node = n; kf = kf; pdg = pdg;
- callstack_length = len; from_deep = fd }
- :: list
+ Security_slicing_parameters.debug ~level:2 "adding node %a (in %s)"
+ (!Db.Pdg.pretty_node false) n
+ (Kernel_function.get_name kf);
+ { node = n; kf = kf; pdg = pdg;
+ callstack_length = len; from_deep = fd }
+ :: list
let mk_init kf pdg =
List.fold_left (fun acc n -> add n kf pdg 0 false acc) []
@@ -301,11 +301,11 @@ module Component = struct
| Forward of fwd_kind
type value =
- { pdg: Db.Pdg.t;
- mutable callstack_length: int;
- mutable direct: bool;
- mutable indirect_backward: bool;
- mutable forward: bool }
+ { pdg: Db.Pdg.t;
+ mutable callstack_length: int;
+ mutable direct: bool;
+ mutable indirect_backward: bool;
+ mutable forward: bool }
type t = value M.t
@@ -316,7 +316,7 @@ module Component = struct
(** Returns [found, new_already] with:
- [found] is [true] iff [elt] was previously added for [kind]
- [new_already] is [already] updated with [elt] and its (new) associated
- value. *)
+ value. *)
let check_and_add first elt kind pdg len (already: t) =
try
(* Format.printf "[security] check node %a (in %s, kind %a)@."
@@ -361,19 +361,19 @@ module Component = struct
| Direct -> direct node
| Indirect_Backward -> direct node @ !Db.Pdg.direct_ctrl_dpds pdg node
| Forward Security ->
- !Db.Pdg.direct_data_uses pdg node @ !Db.Pdg.direct_ctrl_uses pdg node
+ !Db.Pdg.direct_data_uses pdg node @ !Db.Pdg.direct_ctrl_uses pdg node
| Forward Impact ->
- !Db.Pdg.direct_data_uses pdg node @ !Db.Pdg.direct_ctrl_uses pdg node
- @ !Db.Pdg.direct_addr_uses pdg node
+ !Db.Pdg.direct_data_uses pdg node @ !Db.Pdg.direct_ctrl_uses pdg node
+ @ !Db.Pdg.direct_addr_uses pdg node
let search_input kind kf lazy_l =
try
match kind with
| Forward _ -> Lazy.force lazy_l
| Direct | Indirect_Backward ->
- if !Db.Value.use_spec_instead_of_definition kf
- then Lazy.force lazy_l
- else []
+ if !Db.Value.use_spec_instead_of_definition kf
+ then Lazy.force lazy_l
+ else []
with Not_found ->
[]
@@ -410,169 +410,169 @@ module Component = struct
callstack_length = callstack_length; from_deep = from_deep }
:: todolist
->
- let elt = node, kf in
- let found, result =
- check_and_add first elt kind pdg callstack_length result
- in
- let todolist =
- if found then begin
- todolist
- end else begin
- Security_slicing_parameters.debug
- ~level:2 "considering node %a (in %s)"
- (!Db.Pdg.pretty_node false) node
- (Kernel_function.get_name kf);
- (* intraprocedural related_nodes *)
- let related_nodes = one_step_related_nodes kind pdg node in
- Security_slicing_parameters.debug ~level:3
- "intraprocedural part done";
- let todolist =
- List.fold_left
- (fun todo n ->
- Todolist.add n kf pdg callstack_length false todo)
- todolist
- related_nodes
- in
- (* interprocedural part *)
- let backward_from_deep compute_nodes =
- (* [TODO optimisation:]
- en fait, regarder from_deep:
- si vrai, faire pour chaque caller
- sinon, faire uniquement pour le caller d'où on vient *)
- match kind, callstack_length with
- | (Direct | Indirect_Backward), 0 ->
- (* input of a deep security annotation: foreach call
- to [kf], compute its related nodes *)
- let do_caller todolist (caller, callsites) =
- (* Format.printf "[security of %s] search callers in %s
- for zone %a@." (Kernel_function.get_name kf)
- (Kernel_function.get_name caller)
- Locations.Zone.pretty zone;*)
- let pdg_caller = !Db.Pdg.get caller in
- let do_call todolist callsite =
- match kind with
- | Direct | Indirect_Backward ->
- let nodes = compute_nodes pdg_caller callsite in
- List.fold_left
- (add_from_deep caller) todolist nodes
- | Forward _ ->
- todolist (* not considered here, see at end *)
- in
- List.fold_left do_call todolist callsites
- in
- List.fold_left do_caller todolist (!Db.Value.callers kf)
- | _ ->
- todolist
- in
- let todolist =
- match !Db.Pdg.node_key node with
- | Key.SigKey (Signature.In Signature.InCtrl) ->
- assert false
- | Key.SigKey (Signature.In (Signature.InImpl zone)) ->
- let compute_nodes pdg_caller callsite =
- let nodes, _undef_zone =
- !Db.Pdg.find_location_nodes_at_stmt
- pdg_caller callsite ~before:true zone
- (* TODO : use undef_zone (see FS#201)? *)
- in
- let nodes = List.map (fun (n, _z_part) -> n) nodes in
- (* TODO : use _z_part ? *)
- nodes
- in
- backward_from_deep compute_nodes
- | Key.SigKey key ->
- let compute_nodes pdg_caller callsite =
- [ match key with
- | Signature.In (Signature.InNum n) ->
- !Db.Pdg.find_call_input_node pdg_caller callsite n
- | Signature.Out Signature.OutRet ->
- !Db.Pdg.find_call_output_node pdg_caller callsite
- | Signature.In
- (Signature.InCtrl | Signature.InImpl _)
- | Signature.Out _ ->
- assert false ]
- in
- backward_from_deep compute_nodes
- | Key.SigCallKey(id, key) ->
- (* the node is a call: search the related nodes inside the
- called function (see FS#155) *)
- if from_deep then
- (* already come from a deeper annotation:
- do not go again inside it *)
- todolist
- else
- let stmt = Key.call_from_id id in
- let called_kfs =
- Kernel_function.Hptset.elements
- (try Db.Value.call_to_kernel_function stmt
- with Db.Value.Not_a_call -> assert false)
- in
- let todolist =
+ let elt = node, kf in
+ let found, result =
+ check_and_add first elt kind pdg callstack_length result
+ in
+ let todolist =
+ if found then begin
+ todolist
+ end else begin
+ Security_slicing_parameters.debug
+ ~level:2 "considering node %a (in %s)"
+ (!Db.Pdg.pretty_node false) node
+ (Kernel_function.get_name kf);
+ (* intraprocedural related_nodes *)
+ let related_nodes = one_step_related_nodes kind pdg node in
+ Security_slicing_parameters.debug ~level:3
+ "intraprocedural part done";
+ let todolist =
+ List.fold_left
+ (fun todo n ->
+ Todolist.add n kf pdg callstack_length false todo)
+ todolist
+ related_nodes
+ in
+ (* interprocedural part *)
+ let backward_from_deep compute_nodes =
+ (* [TODO optimisation:]
+ en fait, regarder from_deep:
+ si vrai, faire pour chaque caller
+ sinon, faire uniquement pour le caller d'où on vient *)
+ match kind, callstack_length with
+ | (Direct | Indirect_Backward), 0 ->
+ (* input of a deep security annotation: foreach call
+ to [kf], compute its related nodes *)
+ let do_caller todolist (caller, callsites) =
+ (* Format.printf "[security of %s] search callers in %s
+ for zone %a@." (Kernel_function.get_name kf)
+ (Kernel_function.get_name caller)
+ Locations.Zone.pretty zone;*)
+ let pdg_caller = !Db.Pdg.get caller in
+ let do_call todolist callsite =
+ match kind with
+ | Direct | Indirect_Backward ->
+ let nodes = compute_nodes pdg_caller callsite in
List.fold_left
- (fun todolist called_kf ->
- (* foreach called kf *)
- (*Format.printf
- "[security] search inside %s (from %s)@."
- (Kernel_function.get_name called_kf)
- (Kernel_function.get_name kf);*)
- let called_pdg = !Db.Pdg.get called_kf in
- let nodes =
- try
- match kind, key with
- | (Direct | Indirect_Backward),
- Signature.Out out_key ->
- let nodes, _undef_zone =
- !Db.Pdg.find_output_nodes called_pdg out_key
- (* TODO: use undef_zone (see FS#201) *)
- in
- let nodes =
- List.map (fun (n, _z_part) -> n) nodes in
- (* TODO : use _z_part ? *)
- nodes
- | _, Signature.In (Signature.InNum n) ->
- search_input kind called_kf
- (lazy [!Db.Pdg.find_input_node called_pdg n])
- | _, Signature.In Signature.InCtrl ->
- search_input kind called_kf
- (lazy
- [!Db.Pdg.find_entry_point_node called_pdg])
- | _, Signature.In (Signature.InImpl _) ->
- assert false
- | Forward _, Signature.Out _ ->
- []
- with
- | Db.Pdg.Top ->
- Security_slicing_parameters.warning
- "no precise pdg for function %s. \n\
-Ignoring this function in the analysis (potentially incorrect results)."
- (Kernel_function.get_name called_kf);
- []
- | Db.Pdg.Bottom | Not_found -> assert false
- in
- List.fold_left
- (fun todo n ->
- (*Format.printf "node %a inside %s@."
- (!Db.Pdg.pretty_node false) n
- (Kernel_function.get_name called_kf);*)
+ (add_from_deep caller) todolist nodes
+ | Forward _ ->
+ todolist (* not considered here, see at end *)
+ in
+ List.fold_left do_call todolist callsites
+ in
+ List.fold_left do_caller todolist (!Db.Value.callers kf)
+ | _ ->
+ todolist
+ in
+ let todolist =
+ match !Db.Pdg.node_key node with
+ | Key.SigKey (Signature.In Signature.InCtrl) ->
+ assert false
+ | Key.SigKey (Signature.In (Signature.InImpl zone)) ->
+ let compute_nodes pdg_caller callsite =
+ let nodes, _undef_zone =
+ !Db.Pdg.find_location_nodes_at_stmt
+ pdg_caller callsite ~before:true zone
+ (* TODO : use undef_zone (see FS#201)? *)
+ in
+ let nodes = List.map (fun (n, _z_part) -> n) nodes in
+ (* TODO : use _z_part ? *)
+ nodes
+ in
+ backward_from_deep compute_nodes
+ | Key.SigKey key ->
+ let compute_nodes pdg_caller callsite =
+ [ match key with
+ | Signature.In (Signature.InNum n) ->
+ !Db.Pdg.find_call_input_node pdg_caller callsite n
+ | Signature.Out Signature.OutRet ->
+ !Db.Pdg.find_call_output_node pdg_caller callsite
+ | Signature.In
+ (Signature.InCtrl | Signature.InImpl _)
+ | Signature.Out _ ->
+ assert false ]
+ in
+ backward_from_deep compute_nodes
+ | Key.SigCallKey(id, key) ->
+ (* the node is a call: search the related nodes inside the
+ called function (see FS#155) *)
+ if from_deep then
+ (* already come from a deeper annotation:
+ do not go again inside it *)
+ todolist
+ else
+ let stmt = Key.call_from_id id in
+ let called_kfs =
+ Kernel_function.Hptset.elements
+ (try Db.Value.call_to_kernel_function stmt
+ with Db.Value.Not_a_call -> assert false)
+ in
+ let todolist =
+ List.fold_left
+ (fun todolist called_kf ->
+ (* foreach called kf *)
+ (*Format.printf
+ "[security] search inside %s (from %s)@."
+ (Kernel_function.get_name called_kf)
+ (Kernel_function.get_name kf);*)
+ let called_pdg = !Db.Pdg.get called_kf in
+ let nodes =
+ try
+ match kind, key with
+ | (Direct | Indirect_Backward),
+ Signature.Out out_key ->
+ let nodes, _undef_zone =
+ !Db.Pdg.find_output_nodes called_pdg out_key
+ (* TODO: use undef_zone (see FS#201) *)
+ in
+ let nodes =
+ List.map (fun (n, _z_part) -> n) nodes in
+ (* TODO : use _z_part ? *)
+ nodes
+ | _, Signature.In (Signature.InNum n) ->
+ search_input kind called_kf
+ (lazy [!Db.Pdg.find_input_node called_pdg n])
+ | _, Signature.In Signature.InCtrl ->
+ search_input kind called_kf
+ (lazy
+ [!Db.Pdg.find_entry_point_node called_pdg])
+ | _, Signature.In (Signature.InImpl _) ->
+ assert false
+ | Forward _, Signature.Out _ ->
+ []
+ with
+ | Db.Pdg.Top ->
+ Security_slicing_parameters.warning
+ "no precise pdg for function %s. \n\
+ Ignoring this function in the analysis (potentially incorrect results)."
+ (Kernel_function.get_name called_kf);
+ []
+ | Db.Pdg.Bottom | Not_found -> assert false
+ in
+ List.fold_left
+ (fun todo n ->
+ (*Format.printf "node %a inside %s@."
+ (!Db.Pdg.pretty_node false) n
+ (Kernel_function.get_name called_kf);*)
Todolist.add
n called_kf called_pdg
(callstack_length + 1) false todo)
- todolist
- nodes)
- todolist
- called_kfs
- in
- (match kind with
- | Direct | Indirect_Backward ->
+ todolist
+ nodes)
todolist
- | Forward _ ->
- List.fold_left
- (fun todolist called_kf ->
+ called_kfs
+ in
+ (match kind with
+ | Direct | Indirect_Backward ->
+ todolist
+ | Forward _ ->
+ List.fold_left
+ (fun todolist called_kf ->
let compute_from_stmt fold =
fold
(fun (n, kfn) _ acc ->
- if Kernel_function.equal kfn kf then n :: acc
- else acc)
+ if Kernel_function.equal kfn kf then n :: acc
+ else acc)
in
let from_stmt =
compute_from_stmt M.fold result [] in
@@ -580,14 +580,14 @@ Ignoring this function in the analysis (potentially incorrect results)."
(* initial nodes may be not in results *)
compute_from_stmt
(fun f e acc ->
- List.fold_left
- (fun acc e -> f e [] acc) acc e)
+ List.fold_left
+ (fun acc e -> f e [] acc) acc e)
initial_nodes
from_stmt
in
let from_stmt = List.fold_left
- (fun s n -> PdgTypes.NodeSet.add n s)
- PdgTypes.NodeSet.empty from_stmt in
+ (fun s n -> PdgTypes.NodeSet.add n s)
+ PdgTypes.NodeSet.empty from_stmt in
let called_pdg = !Db.Pdg.get called_kf in
let nodes =
try
@@ -601,26 +601,26 @@ Ignoring this function in the analysis (potentially incorrect results)."
in
List.fold_left
(fun todo n ->
- Todolist.add
- n called_kf called_pdg
- (callstack_length + 1) false todo)
+ Todolist.add
+ n called_kf called_pdg
+ (callstack_length + 1) false todo)
todolist
nodes)
- todolist
- called_kfs)
- | Key.CallStmt _ | Key.VarDecl _ ->
- assert false
- | Key.Stmt _ | Key.Label _ ->
- todolist
- in
- (* [TODO optimisation:] voir commentaire plus haut *)
- match kind with
- | (Direct | Indirect_Backward) -> todolist
- | Forward _ -> forward_caller kf node todolist
- end
- in
- (* recursive call *)
- aux false result todolist
+ todolist
+ called_kfs)
+ | Key.CallStmt _ | Key.VarDecl _ ->
+ assert false
+ | Key.Stmt _ | Key.Label _ ->
+ todolist
+ in
+ (* [TODO optimisation:] voir commentaire plus haut *)
+ match kind with
+ | (Direct | Indirect_Backward) -> todolist
+ | Forward _ -> forward_caller kf node todolist
+ end
+ in
+ (* recursive call *)
+ aux false result todolist
in
aux true result nodes
@@ -726,10 +726,10 @@ Ignoring this function in the analysis (potentially incorrect results)."
in
Stmt.Set.elements set
-(* let iter use_ctrl_dpds f kf stmt =
- let action = if use_ctrl_dpds then whole else direct in
- M.iter (fun elt _ -> f elt) (action kf stmt)
-*)
+ (* let iter use_ctrl_dpds f kf stmt =
+ let action = if use_ctrl_dpds then whole else direct in
+ M.iter (fun elt _ -> f elt) (action kf stmt)
+ *)
end
(* ************************************************************************ *)
@@ -750,7 +750,7 @@ let get_indirect_backward_component =
register "get_indirect_backward_component" Component.Indirect_Backward
let get_forward_component = register "get_forward_component"
- (Component.Forward Component.Security)
+ (Component.Forward Component.Security)
let impact_analysis =
Dynamic.register
diff --git a/src/plugins/security_slicing/register_gui.ml b/src/plugins/security_slicing/register_gui.ml
index e7722b7cce1e9ce022488f01eb187c4c95be3136..5b70164c595fd4a818acf8f9dcccce3c02c6adcd 100644
--- a/src/plugins/security_slicing/register_gui.ml
+++ b/src/plugins/security_slicing/register_gui.ml
@@ -28,9 +28,9 @@ module Make_HighlighterState(Info:sig val name: string end) =
State_builder.List_ref
(Cil_datatype.Stmt)
(struct
- let name = Info.name
- let dependencies = [ Ast.self ]
- end)
+ let name = Info.name
+ let dependencies = [ Ast.self ]
+ end)
module ForwardHighlighterState =
Make_HighlighterState(struct let name = "Security_gui.Forward" end)
@@ -45,18 +45,18 @@ let security_highlighter buffer loc ~start ~stop =
let buffer = buffer#buffer in
match loc with
| PStmt (_,s) ->
- let f = ForwardHighlighterState.get () in
- if List.exists (fun k -> k.sid=s.sid) f then begin
- let tag = make_tag buffer"forward" [`BACKGROUND "orange" ] in
- apply_tag buffer tag start stop end;
- let i = IndirectBackwardHighlighterState.get () in
- if List.exists (fun k -> k.sid=s.sid) i then begin
- let tag = make_tag buffer"indirect_backward" [`BACKGROUND "cyan" ] in
- apply_tag buffer tag start stop end;
- let d = DirectHighlighterState.get () in
- if List.exists (fun k -> k.sid=s.sid) d then begin
- let tag = make_tag buffer"direct" [`BACKGROUND "green" ] in
- apply_tag buffer tag start stop end
+ let f = ForwardHighlighterState.get () in
+ if List.exists (fun k -> k.sid=s.sid) f then begin
+ let tag = make_tag buffer"forward" [`BACKGROUND "orange" ] in
+ apply_tag buffer tag start stop end;
+ let i = IndirectBackwardHighlighterState.get () in
+ if List.exists (fun k -> k.sid=s.sid) i then begin
+ let tag = make_tag buffer"indirect_backward" [`BACKGROUND "cyan" ] in
+ apply_tag buffer tag start stop end;
+ let d = DirectHighlighterState.get () in
+ if List.exists (fun k -> k.sid=s.sid) d then begin
+ let tag = make_tag buffer"direct" [`BACKGROUND "green" ] in
+ apply_tag buffer tag start stop end
| PStmtStart _
| PExp _ | PVDecl _ | PTermLval _ | PLval _ | PGlobal _ | PIP _ -> ()
@@ -65,9 +65,9 @@ let security_selector
if button = 3 && Security_slicing_parameters.Slicing.get () then
match localizable with
| PStmt (_kf, ki) ->
- ignore
- (popup_factory#add_item "_Security component"
- ~callback:
+ ignore
+ (popup_factory#add_item "_Security component"
+ ~callback:
(fun () ->
ForwardHighlighterState.set
(Components.get_forward_component ki);
diff --git a/src/plugins/security_slicing/security_slicing_parameters.ml b/src/plugins/security_slicing/security_slicing_parameters.ml
index 30d9d101f9ff76e0ca53c906e6396c2653de3bfd..9f13e3272dc0b7d0662c6e21bf689a8b80facfe7 100644
--- a/src/plugins/security_slicing/security_slicing_parameters.ml
+++ b/src/plugins/security_slicing/security_slicing_parameters.ml
@@ -21,18 +21,18 @@
(**************************************************************************)
include Plugin.Register
- (struct
- let name = "security-slicing"
- let shortname = "security-slicing"
- let help = "security slicing (experimental, undocumented)"
- end)
+ (struct
+ let name = "security-slicing"
+ let shortname = "security-slicing"
+ let help = "security slicing (experimental, undocumented)"
+ end)
module Slicing =
False
(struct
- let option_name = "-security-slicing"
- let help = "perform the security slicing analysis"
- end)
+ let option_name = "-security-slicing"
+ let help = "perform the security slicing analysis"
+ end)
(*
Local Variables:
diff --git a/src/plugins/security_slicing/security_slicing_parameters.mli b/src/plugins/security_slicing/security_slicing_parameters.mli
index 7e5d03019d434b66556c1d2b9d54890007a57c94..7d111ec8d2e15bae30dde531d54b0cea3a262cc8 100644
--- a/src/plugins/security_slicing/security_slicing_parameters.mli
+++ b/src/plugins/security_slicing/security_slicing_parameters.mli
@@ -27,7 +27,7 @@
include Plugin.S
module Slicing: Parameter_sig.Bool
- (** Perform the security slicing pre-analysis. *)
+(** Perform the security slicing pre-analysis. *)
(*
Local Variables:
diff --git a/src/plugins/slicing/Slicing.mli b/src/plugins/slicing/Slicing.mli
index 5cd8c31e3ce95837ff49eaf5768bcc6aefe40b69..0fb6e01cee2dcdbf5907a4b38bfd9889c5bfd3ec 100644
--- a/src/plugins/slicing/Slicing.mli
+++ b/src/plugins/slicing/Slicing.mli
@@ -70,7 +70,7 @@ module Api:sig
[extract] function. *)
val extract : ?f_slice_names:(kernel_function -> bool -> int -> string) ->
- string -> Project.t
+ string -> Project.t
(** Build a new [Db.Project.t] from all [Slice.t] of a project.
The string argument is used for naming the new project.
Can optionally specify how to name the sliced functions
@@ -80,10 +80,10 @@ module Api:sig
- [src_visi] tells if the source function name is used
(if not, it can be used for a slice)
- [num_slice] gives the number of the slice to name.
- The entry point function is only exported once :
- it is VERY recommended to give to it its original name,
- even if it is sliced.
- @modify Sulfur-20171101 argument order and arity. *)
+ The entry point function is only exported once :
+ it is VERY recommended to give to it its original name,
+ even if it is sliced.
+ @modify Sulfur-20171101 argument order and arity. *)
(** {3 Not for casual users} *)
@@ -92,7 +92,7 @@ module Api:sig
function) called from a [Slice.t]. *)
val print_dot : filename:string -> title:string -> unit
- (** May be used to for debugging...
+ (** May be used to for debugging...
Pretty print a representation of the slicing project (call graph)
in a dot file which name is the given string. *)
@@ -167,7 +167,7 @@ module Api:sig
val dyn_t : t Type.t
(** For dynamic type checking and journalization. *)
- type set
+ type set
(** Set of colored selections. *)
val dyn_set : set Type.t
@@ -206,7 +206,7 @@ module Api:sig
val select_stmt_lval :
(set -> Mark.t -> Datatype.String.Set.t -> before:bool -> stmt ->
- eval:stmt -> kernel_function -> set)
+ eval:stmt -> kernel_function -> set)
(** To select lvalues (given as string) related to a statement.
Variable names used in the sets of strings [~rd] and [~wr] are relative
to the function scope.
@@ -219,14 +219,14 @@ module Api:sig
val select_stmt_annots :
(set -> Mark.t -> spare:bool -> threat:bool -> user_assert:bool ->
- slicing_pragma:bool -> loop_inv:bool -> loop_var:bool ->
- stmt -> kernel_function -> set)
+ slicing_pragma:bool -> loop_inv:bool -> loop_var:bool ->
+ stmt -> kernel_function -> set)
(** To select the annotations related to a statement.
Note: add also a transparent selection on the whole statement. *)
val select_func_lval_rw :
(set -> Mark.t -> rd:Datatype.String.Set.t -> wr:Datatype.String.Set.t ->
- eval:stmt -> kernel_function -> set)
+ eval:stmt -> kernel_function -> set)
(** To select rw accesses to lvalues (given as a string) related to a
function.
Variable names used in the sets of strings [~rd] and [~wr] are relative
@@ -260,8 +260,8 @@ module Api:sig
val select_func_annots :
(set -> Mark.t -> spare:bool -> threat:bool -> user_assert:bool ->
- slicing_pragma:bool -> loop_inv:bool -> loop_var:bool ->
- kernel_function -> set)
+ slicing_pragma:bool -> loop_inv:bool -> loop_var:bool ->
+ kernel_function -> set)
(** To select the annotations related to a function. *)
(** {3 Selectors that are not journalized} *)
@@ -278,13 +278,13 @@ module Api:sig
val select_stmt_term :
(set -> Mark.t -> term -> stmt ->
- kernel_function -> set)
+ kernel_function -> set)
(** To select a predicate value related to a statement.
Note: add also a transparent selection on the whole statement. *)
val select_stmt_pred :
(set -> Mark.t -> predicate -> stmt ->
- kernel_function -> set)
+ kernel_function -> set)
(** To select a predicate value related to a statement.
Note: add also a transparent selection on the whole statement. *)
@@ -297,14 +297,14 @@ module Api:sig
val select_pdg_nodes :
(set -> Mark.t -> PdgTypes.Node.t list -> kernel_function -> set)
(** To select nodes of the PDG
- - if [is_ctrl_mark m],
- propagate ctrl_mark on ctrl dependencies
- - if [is_addr_mark m],
- propagate addr_mark on addr dependencies
- - if [is_data_mark m],
- propagate data_mark on data dependencies
- - mark the node with a spare_mark and propagate so that
- the dependencies that were not selected yet will be marked spare. *)
+ - if [is_ctrl_mark m],
+ propagate ctrl_mark on ctrl dependencies
+ - if [is_addr_mark m],
+ propagate addr_mark on addr dependencies
+ - if [is_data_mark m],
+ propagate data_mark on data dependencies
+ - mark the node with a spare_mark and propagate so that
+ the dependencies that were not selected yet will be marked spare. *)
(** {3 Not for casual users and not journalized} *)
@@ -315,7 +315,7 @@ module Api:sig
val add_to_selects_internal : t -> set -> set
val iter_selects_internal : (t -> unit) -> set -> unit
val fold_selects_internal : ('a -> t -> 'a) -> 'a -> set -> 'a
-
+
val select_stmt_internal : (kernel_function -> ?select:t ->
stmt -> Mark.t -> t)
(** May be used to select a statement :
@@ -327,11 +327,11 @@ module Api:sig
propagates data_mark on data dependencies of the statement
- otherwise, marks the node with a spare_mark and propagate so that
the dependencies that were not selected yet will be marked spare.
- When the statement is a call, its functional inputs/outputs are
- also selected (The call is still selected even it has no output).
- When the statement is a composed one (block, if, etc...),
- all the sub-statements are selected.
- @raise SlicingTypes.NoPdg when there is no PDG for the
+ When the statement is a call, its functional inputs/outputs are
+ also selected (The call is still selected even it has no output).
+ When the statement is a composed one (block, if, etc...),
+ all the sub-statements are selected.
+ @raise SlicingTypes.NoPdg when there is no PDG for the
[kernel_function] (related to [PdgTypes.Pdg.is_top]). *)
val select_label_internal : (kernel_function -> ?select:t ->
@@ -422,7 +422,7 @@ module Api:sig
val remove_uncalled : unit -> unit
(** Remove the uncalled slice from the project. *)
- (** {3 Getters} *)
+ (** {3 Getters} *)
val get_all: kernel_function -> t list
(** Get all slices related to a function. *)
@@ -482,13 +482,13 @@ module Api:sig
(** {3 Applying the added requests} *)
val apply_all: propagate_to_callers:bool -> unit
- (** Apply all slicing requests. *)
+ (** Apply all slicing requests. *)
(** {3 Adding slicing requests} *)
val add_selection: Select.set -> unit
- (** Add a selection request to all (existing) slices
- of a function to the project requests. *)
+ (** Add a selection request to all (existing) slices
+ of a function to the project requests. *)
val add_persistent_selection: Select.set -> unit
(** Add a persistent selection request to all slices (already existing or
@@ -538,13 +538,13 @@ module Api:sig
For example, new requests may be added to the list. *)
val merge_slices: Slice.t -> Slice.t -> replace:bool -> Slice.t
- (** May be used to build a new slice which marks is a merge of the two given slices.
- [choose_call] requests are added to the project in order to choose
- the called functions for this new slice.
- If [replace] is true, more requests are added to call this new
- slice instead of the two original slices. When these requests will
- be applied, the user will be able to remove those two slices using
- [Db.Slicing.Slice.remove]. *)
+ (** May be used to build a new slice which marks is a merge of the two given slices.
+ [choose_call] requests are added to the project in order to choose
+ the called functions for this new slice.
+ If [replace] is true, more requests are added to call this new
+ slice instead of the two original slices. When these requests will
+ be applied, the user will be able to remove those two slices using
+ [Db.Slicing.Slice.remove]. *)
val copy_slice: Slice.t -> Slice.t
(** May be used to copy the input slice. The new slice is not called, so it is the user
diff --git a/src/plugins/slicing/api.ml b/src/plugins/slicing/api.ml
index 7765c1ef09cceead21e7ed56178dec8fbbe5d405..d7271052fe2c434ac969950bb34ef490e72d6879 100644
--- a/src/plugins/slicing/api.ml
+++ b/src/plugins/slicing/api.ml
@@ -45,7 +45,7 @@ let self = SlicingState.self
(* ---------------------------------------------------------------------- *)
- (** {2 Functions with journalized side effects } *)
+(** {2 Functions with journalized side effects } *)
let set_modes calls callers sliceUndef keepAnnotations () =
SlicingParameters.Mode.Calls.set calls ;
@@ -77,7 +77,7 @@ module Project = struct
(** {2 Values } *)
- let default_slice_names = SlicingTransform.default_slice_names
+ let default_slice_names = SlicingTransform.default_slice_names
let () =
Journal.Binding.add
(Datatype.func3
@@ -176,11 +176,11 @@ module Select = struct
let select_stmt set spare = SlicingCmds.select_stmt set ~spare
let select_stmt = Journal.register "Slicing.Api.Select.select_stmt"
(Datatype.func4
- dyn_set
- ~label2:("spare", None) Datatype.bool
- Stmt.ty
- Kernel_function.ty
- dyn_set)
+ dyn_set
+ ~label2:("spare", None) Datatype.bool
+ Stmt.ty
+ Kernel_function.ty
+ dyn_set)
select_stmt
let select_stmt set ~spare =
select_stmt set spare
@@ -219,38 +219,38 @@ module Select = struct
SlicingCmds.select_stmt_lval set mark lval ~before stmt ~eval
let select_stmt_lval = Journal.register "Slicing.Api.Select.select_stmt_lval"
(Datatype.func4
- dyn_set
- Mark.dyn_t
- Datatype.String.Set.ty
- ~label4:("before", None) Datatype.bool
- (Datatype.func3
- Stmt.ty
- ~label2:("eval", None) Stmt.ty
- Kernel_function.ty
- dyn_set))
- select_stmt_lval
+ dyn_set
+ Mark.dyn_t
+ Datatype.String.Set.ty
+ ~label4:("before", None) Datatype.bool
+ (Datatype.func3
+ Stmt.ty
+ ~label2:("eval", None) Stmt.ty
+ Kernel_function.ty
+ dyn_set))
+ select_stmt_lval
let select_stmt_lval set mark lval ~before stmt ~eval =
select_stmt_lval set mark lval before stmt eval
let select_stmt_annots set mark spare threat user_assert slicing_pragma loop_inv loop_var =
SlicingCmds.select_stmt_annots set mark ~spare ~threat ~user_assert ~slicing_pragma ~loop_inv ~loop_var
let select_stmt_annots = Journal.register
- "Slicing.Api.Select.select_stmt_annots"
- (Datatype.func4
- dyn_set
- Mark.dyn_t
- ~label3:("spare", None) Datatype.bool
- ~label4:("threat", None) Datatype.bool
- (Datatype.func4
- ~label1:("user_assert", None) Datatype.bool
- ~label2:("slicing_pragma", None) Datatype.bool
- ~label3:("loop_inv", None) Datatype.bool
- ~label4:("loop_var", None) Datatype.bool
- (Datatype.func2
- Stmt.ty
- Kernel_function.ty
- dyn_set)))
- select_stmt_annots
+ "Slicing.Api.Select.select_stmt_annots"
+ (Datatype.func4
+ dyn_set
+ Mark.dyn_t
+ ~label3:("spare", None) Datatype.bool
+ ~label4:("threat", None) Datatype.bool
+ (Datatype.func4
+ ~label1:("user_assert", None) Datatype.bool
+ ~label2:("slicing_pragma", None) Datatype.bool
+ ~label3:("loop_inv", None) Datatype.bool
+ ~label4:("loop_var", None) Datatype.bool
+ (Datatype.func2
+ Stmt.ty
+ Kernel_function.ty
+ dyn_set)))
+ select_stmt_annots
let select_stmt_annots set mark ~spare ~threat ~user_assert ~slicing_pragma ~loop_inv ~loop_var =
select_stmt_annots set mark spare threat user_assert slicing_pragma loop_inv loop_var
@@ -266,30 +266,30 @@ module Select = struct
let select_func_lval_rw set mark rd wr eval =
SlicingCmds.select_func_lval_rw set mark ~rd ~wr ~eval
let select_func_lval_rw = Journal.register
- "Slicing.Api.Select.select_func_lval_rw"
- (Datatype.func4
- dyn_set
- Mark.dyn_t
- ~label3:("rd", None) Datatype.String.Set.ty
- ~label4:("wr", None) Datatype.String.Set.ty
- (Datatype.func2
- ~label1:("eval", None) Stmt.ty
- Kernel_function.ty
- dyn_set))
- select_func_lval_rw
+ "Slicing.Api.Select.select_func_lval_rw"
+ (Datatype.func4
+ dyn_set
+ Mark.dyn_t
+ ~label3:("rd", None) Datatype.String.Set.ty
+ ~label4:("wr", None) Datatype.String.Set.ty
+ (Datatype.func2
+ ~label1:("eval", None) Stmt.ty
+ Kernel_function.ty
+ dyn_set))
+ select_func_lval_rw
let select_func_lval_rw set mark ~rd ~wr ~eval =
- select_func_lval_rw set mark rd wr eval
+ select_func_lval_rw set mark rd wr eval
let select_func_return set spare =
SlicingCmds.select_func_return set ~spare
let select_func_return = Journal.register
- "Slicing.Api.Select.select_func_return"
- (Datatype.func3
- dyn_set
- ~label2:("spare", None) Datatype.bool
- Kernel_function.ty
- dyn_set)
- select_func_return
+ "Slicing.Api.Select.select_func_return"
+ (Datatype.func3
+ dyn_set
+ ~label2:("spare", None) Datatype.bool
+ Kernel_function.ty
+ dyn_set)
+ select_func_return
let select_func_return set ~spare = select_func_return set spare
let select_func_calls_to set spare =
@@ -481,7 +481,7 @@ module Request = struct
let propagate_user_marks =
Journal.register "Slicing.Api.Request.propagate_user_marks"
(Datatype.func Datatype.unit Datatype.unit)
- SlicingCmds.topologic_propagation
+ SlicingCmds.topologic_propagation
let copy_slice = Journal.register "Slicing.Api.Request.copy_slice"
(Datatype.func
@@ -546,7 +546,7 @@ module Request = struct
let add_selection = Journal.register "Slicing.Request.add_selection"
(Datatype.func
Select.dyn_set Datatype.unit)
- SlicingCmds.add_selection
+ SlicingCmds.add_selection
let add_persistent_selection =
Journal.register "Slicing.Request.add_persistent_selection"
@@ -557,7 +557,7 @@ module Request = struct
let add_persistent_cmdline =
Journal.register "Slicing.Request.add_persistent_cmdline"
(Datatype.func Datatype.unit Datatype.unit)
- SlicingCmds.add_persistent_cmdline
+ SlicingCmds.add_persistent_cmdline
(** {2 No needs of Journalization} *)
diff --git a/src/plugins/slicing/fct_slice.ml b/src/plugins/slicing/fct_slice.ml
index 16ace53c0ec8ce6f7bc36a53cfb8da478e4fed80..47d922e5bb064d78c4ae8b3c1baacae9bf839769 100644
--- a/src/plugins/slicing/fct_slice.ml
+++ b/src/plugins/slicing/fct_slice.ml
@@ -49,15 +49,15 @@ let exists_fun_callers fpred kf =
let rec exists_fun_callers kf =
if fpred kf
then true
- else
- if Kernel_function.Set.mem kf !table
- then false (* no way to call the initial [kf]. *)
- else begin
- table := Kernel_function.Set.add kf !table ;
- List.exists
- (fun (kf,_) -> exists_fun_callers kf)
- (!Db.Value.callers kf)
- end
+ else
+ if Kernel_function.Set.mem kf !table
+ then false (* no way to call the initial [kf]. *)
+ else begin
+ table := Kernel_function.Set.add kf !table ;
+ List.exists
+ (fun (kf,_) -> exists_fun_callers kf)
+ (!Db.Value.callers kf)
+ end
in
exists_fun_callers kf
@@ -72,8 +72,8 @@ let is_src_fun_called kf =
in exists_fun_callers fpred kf
(** Manage the information related to a function call in a slice.
-* It is composed of the called function if it has been established yet,
-* and the call signature. Also deals with the [called_by] information. *)
+ * It is composed of the called function if it has been established yet,
+ * and the call signature. Also deals with the [called_by] information. *)
module CallInfo : sig
type call_id = SlicingInternals.fct_slice * Cil_types.stmt
type t
@@ -92,7 +92,7 @@ module CallInfo : sig
val remove_called_by : call_id -> t -> unit
val is_call_to_change : t -> SlicingInternals.called_fct option -> bool
val change_call : SlicingInternals.marks_index -> call_id ->
- SlicingInternals.called_fct option -> unit
+ SlicingInternals.called_fct option -> unit
end = struct
@@ -124,8 +124,8 @@ end = struct
let fold_calls f ff ff_marks acc =
let do_it call (c_opt,sgn) a =
let info = match c_opt with
- | None | Some (None) -> ((ff, call), None, sgn)
- | Some (Some f) -> ((ff, call), Some f, sgn)
+ | None | Some (None) -> ((ff, call), None, sgn)
+ | Some (Some f) -> ((ff, call), Some f, sgn)
in f call info a
in
PdgIndex.FctIndex.fold_calls do_it ff_marks acc
@@ -135,14 +135,14 @@ end = struct
let is_call_to_change ci f_to_call =
let old_called = get_f_called ci in
match old_called, f_to_call with
- | None, None -> false
- | None, _ -> true
- | Some (SlicingInternals.CallSrc _), Some (SlicingInternals.CallSrc _) -> false
- | Some (SlicingInternals.CallSrc _), _ -> true
- | Some (SlicingInternals.CallSlice _), Some (SlicingInternals.CallSrc _) -> true
- | Some (SlicingInternals.CallSlice _), None -> true
- | Some (SlicingInternals.CallSlice ff_called), Some (SlicingInternals.CallSlice ff_to_call) ->
- if (SlicingMacros.equal_ff ff_called ff_to_call) then false else true
+ | None, None -> false
+ | None, _ -> true
+ | Some (SlicingInternals.CallSrc _), Some (SlicingInternals.CallSrc _) -> false
+ | Some (SlicingInternals.CallSrc _), _ -> true
+ | Some (SlicingInternals.CallSlice _), Some (SlicingInternals.CallSrc _) -> true
+ | Some (SlicingInternals.CallSlice _), None -> true
+ | Some (SlicingInternals.CallSlice ff_called), Some (SlicingInternals.CallSlice ff_to_call) ->
+ if (SlicingMacros.equal_ff ff_called ff_to_call) then false else true
let indirectly_called_src_functions call_id =
let _, stmt = call_id in
@@ -158,34 +158,34 @@ end = struct
Kernel_function.Hptset.elements called_functions
(** [call_id] is a call to [g] in [f].
- * we don't want [f] to call [g] anymore, so we have to update [g] [called_by]
- * field.
- * *)
+ * we don't want [f] to call [g] anymore, so we have to update [g] [called_by]
+ * field.
+ * *)
let remove_called_by call_id call_info =
let rec remove called_by = match called_by with
| [] -> []
| e :: called_by -> if (SlicingMacros.same_ff_call call_id e) then called_by
else e::(remove called_by)
in
- SlicingParameters.debug ~level:2 "[Fct_Slice.CallInfo.remove_called_by] -> remove old_called";
- let old_called = get_f_called call_info in
- match old_called with
- | None -> ()
- | Some (SlicingInternals.CallSlice g) ->
- g.SlicingInternals.ff_called_by <- remove g.SlicingInternals.ff_called_by
- | Some (SlicingInternals.CallSrc (Some old_fi)) ->
- old_fi.SlicingInternals.f_called_by <- remove old_fi.SlicingInternals.f_called_by
- | Some (SlicingInternals.CallSrc (None)) ->
- let called = indirectly_called_src_functions call_id in
- let update kf =
- let old_fi = SlicingMacros.get_kf_fi kf in
- old_fi.SlicingInternals.f_called_by <- remove old_fi.SlicingInternals.f_called_by
- in List.iter update called
+ SlicingParameters.debug ~level:2 "[Fct_Slice.CallInfo.remove_called_by] -> remove old_called";
+ let old_called = get_f_called call_info in
+ match old_called with
+ | None -> ()
+ | Some (SlicingInternals.CallSlice g) ->
+ g.SlicingInternals.ff_called_by <- remove g.SlicingInternals.ff_called_by
+ | Some (SlicingInternals.CallSrc (Some old_fi)) ->
+ old_fi.SlicingInternals.f_called_by <- remove old_fi.SlicingInternals.f_called_by
+ | Some (SlicingInternals.CallSrc (None)) ->
+ let called = indirectly_called_src_functions call_id in
+ let update kf =
+ let old_fi = SlicingMacros.get_kf_fi kf in
+ old_fi.SlicingInternals.f_called_by <- remove old_fi.SlicingInternals.f_called_by
+ in List.iter update called
(** very low level function to change information of a call :
- * no checks at all (they must have been done before).
- * [call] in [ff] is changed in order to call [to_call]. If some function was
- * previously called, update its [called_by] information. *)
+ * no checks at all (they must have been done before).
+ * [call] in [ff] is changed in order to call [to_call]. If some function was
+ * previously called, update its [called_by] information. *)
let change_call ff_marks call_id to_call =
SlicingParameters.debug ~level:2 "[Fct_Slice.CallInfo.change_call]";
let call_info = get_info_call call_id in
@@ -196,18 +196,18 @@ end = struct
remove_called_by call_id call_info;
SlicingParameters.debug ~level:2 " -> add new_called";
begin match to_call with
- | None -> () (* nothing to do *)
- | Some f ->
+ | None -> () (* nothing to do *)
+ | Some f ->
begin match f with
- | (SlicingInternals.CallSrc None) ->
+ | (SlicingInternals.CallSrc None) ->
let called = indirectly_called_src_functions call_id in
let update kf =
let fi = SlicingMacros.get_kf_fi kf in
- fi.SlicingInternals.f_called_by <- call_id :: fi.SlicingInternals.f_called_by
+ fi.SlicingInternals.f_called_by <- call_id :: fi.SlicingInternals.f_called_by
in List.iter update called
- | (SlicingInternals.CallSlice g) ->
+ | (SlicingInternals.CallSlice g) ->
g.SlicingInternals.ff_called_by <- call_id :: g.SlicingInternals.ff_called_by
- | (SlicingInternals.CallSrc (Some fi)) ->
+ | (SlicingInternals.CallSrc (Some fi)) ->
fi.SlicingInternals.f_called_by <- call_id :: fi.SlicingInternals.f_called_by
end
end;
@@ -219,7 +219,7 @@ end = struct
end
(** [FctMarks] manages the mapping between a function elements and their
-* marks. See {!module:PdgIndex.FctIndex} to know what an element is.
+ * marks. See {!module:PdgIndex.FctIndex} to know what an element is.
*)
module FctMarks : sig
type t (* = SlicingInternals.marks_index *)
@@ -238,13 +238,13 @@ module FctMarks : sig
(** build a new, slice for the function with some initial marks (they will be
- * copied)*)
+ * copied)*)
val new_init_slice : SlicingInternals.fct_info -> SlicingInternals.ff_marks -> SlicingInternals.fct_slice
val get_ff_marks : SlicingInternals.fct_slice -> t
(** merge the marks and clear all the calls :
- * they will have to be processed by examine_calls. *)
+ * they will have to be processed by examine_calls. *)
val merge : SlicingInternals.fct_slice -> SlicingInternals.fct_slice -> SlicingInternals.ff_marks
val get_node_mark : SlicingInternals.fct_slice -> PdgIndex.Key.t -> SlicingTypes.sl_mark
@@ -253,14 +253,14 @@ module FctMarks : sig
val get_sgn : SlicingInternals.fct_slice -> SlicingMarks.sig_marks option
val get_new_marks: SlicingInternals.fct_slice -> SlicingTypes.sl_mark PdgMarks.select ->
- SlicingTypes.sl_mark PdgMarks.select
+ SlicingTypes.sl_mark PdgMarks.select
val get_all_input_marks : t -> to_prop
val get_matching_input_marks : t -> Locations.Zone.t -> to_prop
(** add the given mark to the node, and propagate to its dependencies *)
val mark_and_propagate : t -> ?to_prop:to_prop ->
- SlicingTypes.sl_mark PdgMarks.select -> to_prop
+ SlicingTypes.sl_mark PdgMarks.select -> to_prop
(** add a [Spare] mark to all the input nodes of the call and propagate *)
val mark_spare_call_nodes : SlicingInternals.fct_slice -> Cil_types.stmt -> to_prop
@@ -271,41 +271,41 @@ module FctMarks : sig
val mark_visible_output : t -> unit
(** Some inputs must be visible when a parameter is used as a local variable.
- * ie. its input value is not used.
- * TODO : handle the difference between input value/decl in [Signature] *)
+ * ie. its input value is not used.
+ * TODO : handle the difference between input value/decl in [Signature] *)
val mark_visible_inputs : t -> to_prop -> to_prop
val marks_for_caller_inputs :
PdgTypes.Pdg.t -> t -> Cil_types.stmt -> to_prop -> SlicingInternals.fct_info
- -> (SlicingTypes.sl_mark PdgMarks.select) * bool
+ -> (SlicingTypes.sl_mark PdgMarks.select) * bool
val marks_for_call_outputs : to_prop ->
(Cil_types.stmt * (PdgIndex.Signature.out_key * SlicingTypes.sl_mark) list) list
val get_call_output_marks :
- ?spare_info:CallInfo.call_id option ->
- CallInfo.t -> (PdgIndex.Signature.out_key * SlicingTypes.sl_mark) list
+ ?spare_info:CallInfo.call_id option ->
+ CallInfo.t -> (PdgIndex.Signature.out_key * SlicingTypes.sl_mark) list
val persistent_in_marks_to_prop : SlicingInternals.fct_info -> to_prop ->
SlicingTypes.sl_mark PdgMarks.pdg_select
(** [f] calls [g] and the call marks have been modified in [f].
- * Compute the marks that should be propagated in [g].
- *
- * This function is also use to choose the slice of [g] to call :
- * in that case, the first parameter holds the call output marks
- * that can be given by [get_call_output_marks].
- * *)
+ * Compute the marks that should be propagated in [g].
+ *
+ * This function is also use to choose the slice of [g] to call :
+ * in that case, the first parameter holds the call output marks
+ * that can be given by [get_call_output_marks].
+ * *)
val check_called_marks :
- (PdgIndex.Signature.out_key * SlicingTypes.sl_mark) list -> SlicingInternals.fct_slice ->
+ (PdgIndex.Signature.out_key * SlicingTypes.sl_mark) list -> SlicingInternals.fct_slice ->
(SlicingTypes.sl_mark PdgMarks.select) * bool
val fold_calls : (Cil_types.stmt -> CallInfo.t -> 'a -> 'a) ->
- SlicingInternals.fct_slice -> 'a -> 'a
+ SlicingInternals.fct_slice -> 'a -> 'a
val change_call : SlicingInternals.fct_slice -> Cil_types.stmt ->
- SlicingInternals.called_fct option -> unit
+ SlicingInternals.called_fct option -> unit
val debug_marked_ff : Format.formatter -> SlicingInternals.fct_slice -> unit
@@ -328,24 +328,24 @@ end = struct
let empty_to_prop = PropMark.empty_to_prop
(** @raise SlicingTypes.NoPdg when the function PDG couldn't have been
- * computed. *)
+ * computed. *)
let new_slice fi marks =
let ff_num = fi.SlicingInternals.fi_next_ff_num in
let pdg = SlicingMacros.get_fi_pdg fi in
- if (PdgTypes.Pdg.is_top pdg) then raise SlicingTypes.NoPdg;
- let marks = match marks with None -> PropMark.create pdg
- | Some (pdg, marks) -> (pdg, PdgIndex.FctIndex.copy marks)
- in
- let ff = { SlicingInternals.ff_fct = fi ; SlicingInternals.ff_id = ff_num ;
- SlicingInternals.ff_marks = marks ; SlicingInternals.ff_called_by = [] } in
- fi.SlicingInternals.fi_slices <- ff :: fi.SlicingInternals.fi_slices ;
- fi.SlicingInternals.fi_next_ff_num <- ff_num + 1;
- ff
+ if (PdgTypes.Pdg.is_top pdg) then raise SlicingTypes.NoPdg;
+ let marks = match marks with None -> PropMark.create pdg
+ | Some (pdg, marks) -> (pdg, PdgIndex.FctIndex.copy marks)
+ in
+ let ff = { SlicingInternals.ff_fct = fi ; SlicingInternals.ff_id = ff_num ;
+ SlicingInternals.ff_marks = marks ; SlicingInternals.ff_called_by = [] } in
+ fi.SlicingInternals.fi_slices <- ff :: fi.SlicingInternals.fi_slices ;
+ fi.SlicingInternals.fi_next_ff_num <- ff_num + 1;
+ ff
let new_copied_slice ff =
try
let fi = ff.SlicingInternals.ff_fct in
- new_slice fi (Some ff.SlicingInternals.ff_marks)
+ new_slice fi (Some ff.SlicingInternals.ff_marks)
with SlicingTypes.NoPdg -> assert false
(** @raise SlicingTypes.NoPdg (see [new_slice]) *)
@@ -367,11 +367,11 @@ end = struct
let merge ff1 ff2 =
let pdg1, fm1 = ff1.SlicingInternals.ff_marks in
let pdg2, fm2 = ff2.SlicingInternals.ff_marks in
- assert (Db.Pdg.from_same_fun pdg1 pdg2) ;
+ assert (Db.Pdg.from_same_fun pdg1 pdg2) ;
let merge_marks m1 m2 = SlicingMarks.merge_marks [m1; m2] in
let merge_call_info _c1 _c2 = None in
let fm = PdgIndex.FctIndex.merge fm1 fm2 merge_marks merge_call_info in
- (pdg1, fm)
+ (pdg1, fm)
let get_mark fm node_key =
try PdgIndex.FctIndex.find_info (get_marks fm) node_key
@@ -382,7 +382,7 @@ end = struct
let get_fi_node_mark fi node_key =
match fi_marks fi with None -> SlicingMarks.bottom_mark
- | Some fm -> get_mark fm node_key
+ | Some fm -> get_mark fm node_key
let get_node_marks ff node_key =
let fm = ff.SlicingInternals.ff_marks in
@@ -415,14 +415,14 @@ end = struct
(** mark the node with the given mark and propagate it to its dependencies *)
let mark_and_propagate (fct_marks:t)
- ?(to_prop=PropMark.empty_to_prop) to_select =
+ ?(to_prop=PropMark.empty_to_prop) to_select =
PropMark.mark_and_propagate fct_marks ~to_prop to_select
(** compute the marks to propagate in [pdg_caller] when the called function
- * have the [to_prop] marks.
- * @param fi_to_call is used to compute [more_inputs] only :
- * a persistent input mark is not considered as a new input.
- * *)
+ * have the [to_prop] marks.
+ * @param fi_to_call is used to compute [more_inputs] only :
+ * a persistent input mark is not considered as a new input.
+ * *)
let marks_for_caller_inputs pdg_caller old_marks call (in_info,_ as _to_prop) fi_to_call =
assert (not (PdgTypes.Pdg.is_top pdg_caller));
let new_input = ref false in
@@ -438,25 +438,25 @@ end = struct
!Db.Operational_inputs.get_internal_precise ~stmt:call kf in
let z = op_inputs.Inout_type.over_inputs in
match s with
- | PdgMarks.SelNode (_, None) -> true
- | PdgMarks.SelIn z' | PdgMarks.SelNode (_,Some z') ->
- Locations.Zone.intersects z z'
+ | PdgMarks.SelNode (_, None) -> true
+ | PdgMarks.SelIn z' | PdgMarks.SelNode (_,Some z') ->
+ Locations.Zone.intersects z z'
in
if add_mark then
let new_m = SlicingMarks.missing_input_mark ~call:old_m ~called:m in
SlicingParameters.debug ~level:2
"[Fct_Slice.FctMarks.marks_for_caller_inputs] for %a : \
- old=%a new=%a -> %a"
+ old=%a new=%a -> %a"
!Db.Pdg.pretty_key key SlicingMarks.pretty_mark old_m
SlicingMarks.pretty_mark m
SlicingMarks.pretty_mark
(match new_m with None -> SlicingMarks.bottom_mark | Some m -> m);
begin
match new_m with
- | Some _new_m when SlicingMarks.is_bottom_mark old_m ->
- let init_m = get_fi_node_mark fi_to_call key in
- if SlicingMarks.is_bottom_mark init_m then new_input := true
- | _ -> ()
+ | Some _new_m when SlicingMarks.is_bottom_mark old_m ->
+ let init_m = get_fi_node_mark fi_to_call key in
+ if SlicingMarks.is_bottom_mark init_m then new_input := true
+ | _ -> ()
end;
new_m
else
@@ -472,29 +472,29 @@ end = struct
let sig_call = CallInfo.get_call_sig call_info in
let add1 acc (k,m) = (k,m)::acc in
let call_out_marks = PdgIndex.Signature.fold_all_outputs add1 [] sig_call in
- match spare_info with
- | None -> call_out_marks
- | Some (ff_call, call) ->
- let pdg = SlicingMacros.get_ff_pdg ff_call in
- let spare = SlicingMarks.mk_gen_spare in
- let rec add2 marks n =
- match !Db.Pdg.node_key n with
- | PdgIndex.Key.SigCallKey (_, (PdgIndex.Signature.In _)) ->
- marks
- | PdgIndex.Key.SigCallKey (_, (PdgIndex.Signature.Out key)) ->
- begin
- match marks with
- | [] -> [(key, spare)]
- | (k, m):: marks ->
- if PdgIndex.Signature.equal_out_key k key then
- let m =
- if SlicingMarks.is_bottom_mark m then spare else m
- in (k, m):: marks
- else (k, m)::(add2 marks n)
- end
- | _ -> assert false
- in
- PdgTypes.Pdg.fold_call_nodes add2 call_out_marks pdg call
+ match spare_info with
+ | None -> call_out_marks
+ | Some (ff_call, call) ->
+ let pdg = SlicingMacros.get_ff_pdg ff_call in
+ let spare = SlicingMarks.mk_gen_spare in
+ let rec add2 marks n =
+ match !Db.Pdg.node_key n with
+ | PdgIndex.Key.SigCallKey (_, (PdgIndex.Signature.In _)) ->
+ marks
+ | PdgIndex.Key.SigCallKey (_, (PdgIndex.Signature.Out key)) ->
+ begin
+ match marks with
+ | [] -> [(key, spare)]
+ | (k, m):: marks ->
+ if PdgIndex.Signature.equal_out_key k key then
+ let m =
+ if SlicingMarks.is_bottom_mark m then spare else m
+ in (k, m):: marks
+ else (k, m)::(add2 marks n)
+ end
+ | _ -> assert false
+ in
+ PdgTypes.Pdg.fold_call_nodes add2 call_out_marks pdg call
let check_called_marks new_call_marks ff_called =
let ff_marks = get_ff_marks ff_called in
@@ -502,13 +502,13 @@ end = struct
let new_output = ref false in
let m2m s m = match s with
| PdgMarks.SelIn _ ->
- (* let nkey = PdgIndex.Key.implicit_in_key l in *)
- (* As we are looking for some call output node,
- * even if the data is not entirely defined by the function,
- * it has already been taken into account in the "from". *)
- None
+ (* let nkey = PdgIndex.Key.implicit_in_key l in *)
+ (* As we are looking for some call output node,
+ * even if the data is not entirely defined by the function,
+ * it has already been taken into account in the "from". *)
+ None
| PdgMarks.SelNode (n, _z_opt) ->
- let nkey = !Db.Pdg.node_key n in
+ let nkey = !Db.Pdg.node_key n in
(*
let nkey = match z_opt with None -> nkey
| Some z -> match nkey with
@@ -519,23 +519,23 @@ end = struct
| _ -> nkey
in
*)
- let old_m = get_mark ff_marks nkey in
- let m_opt = SlicingMarks.missing_output_mark ~call:m ~called:old_m in
- let new_out = match m_opt with
- | Some _new_m when SlicingMarks.is_bottom_mark old_m ->
- new_output := true; true
- | _ -> (); false
- in
- SlicingParameters.debug ~level:2 "[Fct_Slice.FctMarks.check_called_marks] for %a : old=%a new=%a -> %a %s"
- !Db.Pdg.pretty_key nkey
- SlicingMarks.pretty_mark old_m
- SlicingMarks.pretty_mark m
- SlicingMarks.pretty_mark
- (match m_opt with None -> SlicingMarks.bottom_mark | Some m -> m)
- (if new_out then "(new out)" else "");
- m_opt
+ let old_m = get_mark ff_marks nkey in
+ let m_opt = SlicingMarks.missing_output_mark ~call:m ~called:old_m in
+ let new_out = match m_opt with
+ | Some _new_m when SlicingMarks.is_bottom_mark old_m ->
+ new_output := true; true
+ | _ -> (); false
+ in
+ SlicingParameters.debug ~level:2 "[Fct_Slice.FctMarks.check_called_marks] for %a : old=%a new=%a -> %a %s"
+ !Db.Pdg.pretty_key nkey
+ SlicingMarks.pretty_mark old_m
+ SlicingMarks.pretty_mark m
+ SlicingMarks.pretty_mark
+ (match m_opt with None -> SlicingMarks.bottom_mark | Some m -> m)
+ (if new_out then "(new out)" else "");
+ m_opt
in let new_called_marks =
- Pdg.Register.call_out_marks_to_called ff_pdg m2m new_call_marks
+ Pdg.Register.call_out_marks_to_called ff_pdg m2m new_call_marks
in new_called_marks, !new_output
let persistent_in_marks_to_prop fi to_prop =
@@ -549,28 +549,28 @@ end = struct
let pdg = SlicingMacros.get_fi_pdg fi in
let pdg_node_marks =
Pdg.Register.translate_in_marks pdg ~m2m in_info [] in
- pdg_node_marks
+ pdg_node_marks
let get_new_marks ff nodes_marks =
let fm = get_ff_marks ff in
let add_if_new acc (n, m) =
let nkey = match n with
| PdgMarks.SelNode (n, _z_opt) ->
- (* TODO : something to do for z_opt ? *)
- !Db.Pdg.node_key n
+ (* TODO : something to do for z_opt ? *)
+ !Db.Pdg.node_key n
| PdgMarks.SelIn l -> PdgIndex.Key.implicit_in_key l
in
let oldm = get_mark fm nkey in
let newm = SlicingMarks.minus_marks m oldm in
(* Format.printf "get_new_marks for %a : old=%a new=%a -> %a@."
- !Db.Pdg.pretty_key nkey SlicingMarks.pretty_mark oldm
- SlicingMarks.pretty_mark m SlicingMarks.pretty_mark newm; *)
+ !Db.Pdg.pretty_key nkey SlicingMarks.pretty_mark oldm
+ SlicingMarks.pretty_mark m SlicingMarks.pretty_mark newm; *)
if not (SlicingMarks.is_bottom_mark newm) then (n, newm)::acc else acc
in List.fold_left add_if_new [] nodes_marks
(** We know that the 'call' element is visible.
- * We have to check that all the associated nodes and
- * the dependencies of these nodes are, at least, marked as 'spare'.
+ * We have to check that all the associated nodes and
+ * the dependencies of these nodes are, at least, marked as 'spare'.
*)
let mark_spare_nodes ff nodes =
let ff_marks = get_ff_marks ff in
@@ -578,14 +578,14 @@ end = struct
let node_marks =
List.map (fun n -> (PdgMarks.mk_select_node n, m_spare)) nodes in
let to_prop = mark_and_propagate ff_marks node_marks in
- to_prop
+ to_prop
let mark_spare_call_nodes ff call =
let pdg = SlicingMacros.get_ff_pdg ff in
let nodes = !Db.Pdg.find_simple_stmt_nodes pdg call in
mark_spare_nodes ff nodes
- (** TODO :
+ (** TODO :
* this function should disappear when the parameter declarations will
* be handled...
* See TODO in Pdg.Build.do_param
@@ -676,12 +676,12 @@ let _pretty_node_marks fmt marks =
let print fmt (n, m) =
(!Db.Pdg.pretty_node true) fmt n; SlicingMarks.pretty_mark fmt m
in
- Format.fprintf fmt "%a" (fun fmt x -> List.iter (print fmt) x) marks
+ Format.fprintf fmt "%a" (fun fmt x -> List.iter (print fmt) x) marks
let check_outputs call_id called_ff add_spare =
let (ff_call, call) = call_id in
SlicingParameters.debug ~level:2 "[Fct_Slice.check_outputs] %s outputs for call %d in %s"
- (SlicingMacros.ff_name called_ff) call.sid (SlicingMacros.ff_name ff_call);
+ (SlicingMacros.ff_name called_ff) call.sid (SlicingMacros.ff_name ff_call);
let call_info = CallInfo.get_info_call call_id in
let spare_info = if add_spare then Some call_id else None in
let out_call = FctMarks.get_call_output_marks ~spare_info call_info in
@@ -700,54 +700,54 @@ let check_ff_called ff call new_marks_in_call_outputs ff_called =
try
let _, new_call_marks =
List.find is_this_call new_marks_in_call_outputs in
- new_call_marks
+ new_call_marks
with Not_found -> (* no new marks for this call *) []
in
let missing_outputs =
match new_call_marks with
| [] -> (* why do we check this if there is no new mark ??? *)
- check_outputs call_id ff_called false
+ check_outputs call_id ff_called false
| _ ->
- FctMarks.check_called_marks new_call_marks ff_called
+ FctMarks.check_called_marks new_call_marks ff_called
in match missing_outputs with
- | ([], false) -> None
- | _ ->
- let missing_out_act =
- SlicingActions.mk_crit_missing_outputs ff call missing_outputs
- in Some missing_out_act
+ | ([], false) -> None
+ | _ ->
+ let missing_out_act =
+ SlicingActions.mk_crit_missing_outputs ff call missing_outputs
+ in Some missing_out_act
(** Examine the call statements after the modification of [ff] marks.
* If one node is visible we have to choose which function to call,
* or to check if it is ok is something is called already.
*
* @return a list of actions if needed.
- *)
+*)
let examine_calls ff new_marks_in_call_outputs =
SlicingParameters.debug ~level:2 "[Fct_Slice.examine_calls]";
let process_this_call call call_info filter_list =
if CallInfo.something_visible call_info then
begin
- SlicingParameters.debug ~level:2 " examine visible call %d" call.sid;
- let f_called = CallInfo.get_f_called call_info in
- let filter_list = match f_called with
- | None ->
+ SlicingParameters.debug ~level:2 " examine visible call %d" call.sid;
+ let f_called = CallInfo.get_f_called call_info in
+ let filter_list = match f_called with
+ | None ->
(* have to chose a function to call here *)
SlicingParameters.debug ~level:2 " -> add choose_call";
(SlicingActions.mk_crit_choose_call ff call) :: filter_list
- | Some (SlicingInternals.CallSrc _) ->
+ | Some (SlicingInternals.CallSrc _) ->
(* the source function compute every outputs, so nothing to do *)
SlicingParameters.debug ~level:2 " -> source called : nothing to do";
filter_list
- | Some (SlicingInternals.CallSlice ff_called) ->
+ | Some (SlicingInternals.CallSlice ff_called) ->
(* call to a sliced function : check if it's still ok,
- * or create new [missing_output] action *)
+ * or create new [missing_output] action *)
SlicingParameters.debug ~level:2 " -> slice called -> check";
let new_filter =
check_ff_called ff call new_marks_in_call_outputs ff_called
in match new_filter with None -> filter_list
- | Some f -> f :: filter_list
- in filter_list
+ | Some f -> f :: filter_list
+ in filter_list
end
else (* the call is not visible : nothing to do *)
begin
@@ -757,13 +757,13 @@ let examine_calls ff new_marks_in_call_outputs =
in FctMarks.fold_calls process_this_call ff []
(** build a new empty slice in the given [fct_info].
-* If the function has some persistent selection, let's copy it in the new slice.
-* Notice that there can be at most one slice for the application entry point
-* (main), but we allow to have several slice for a library entry point.
-* @param build_actions (bool) is useful if the function has some persistent
-* selection : if the new slice marks will be modified just after that,
-* it is not useful to do [examine_calls], but if it is finished,
-* we must generate those actions to choose the calls.
+ * If the function has some persistent selection, let's copy it in the new slice.
+ * Notice that there can be at most one slice for the application entry point
+ * (main), but we allow to have several slice for a library entry point.
+ * @param build_actions (bool) is useful if the function has some persistent
+ * selection : if the new slice marks will be modified just after that,
+ * it is not useful to do [examine_calls], but if it is finished,
+ * we must generate those actions to choose the calls.
@raise SlicingTypes.NoPdg (see [new_slice])
*)
let make_new_ff fi build_actions =
@@ -775,18 +775,18 @@ let make_new_ff fi build_actions =
let new_filters =
(if build_actions && some_marks then examine_calls ff [] else [])
in
- SlicingParameters.debug ~level:1 "[Fct_Slice.make_new_ff] = %s@." (SlicingMacros.ff_name ff);
- (ff, new_filters)
+ SlicingParameters.debug ~level:1 "[Fct_Slice.make_new_ff] = %s@." (SlicingMacros.ff_name ff);
+ (ff, new_filters)
in
let fname = SlicingMacros.fi_name fi in
let kf_entry, _ = Globals.entry_point () in
- if fname = Kernel_function.get_name kf_entry then
- match fi.SlicingInternals.fi_slices with
- | [] -> new_ff fi
- | ff :: [] -> ff, []
- | _ -> assert false (* Entry point shouldn't have several slices *)
- else
- new_ff fi
+ if fname = Kernel_function.get_name kf_entry then
+ match fi.SlicingInternals.fi_slices with
+ | [] -> new_ff fi
+ | ff :: [] -> ff, []
+ | _ -> assert false (* Entry point shouldn't have several slices *)
+ else
+ new_ff fi
let copy_slice ff =
let kf_entry, _ = Globals.entry_point () in
@@ -796,8 +796,8 @@ let copy_slice ff =
FctMarks.new_copied_slice ff
(** [ff] marks have just been modified :
-* check if the [calls] to [ff] compute enough inputs,
-* and create [MissingInputs] actions if not. *)
+ * check if the [calls] to [ff] compute enough inputs,
+ * and create [MissingInputs] actions if not. *)
let add_missing_inputs_actions ff calls to_prop actions =
let fi = ff.SlicingInternals.ff_fct in
let check_call actions (ff_call, call as call_id) =
@@ -808,27 +808,27 @@ let add_missing_inputs_actions ff calls to_prop actions =
| _ -> assert false
in
let pdg_caller = SlicingMacros.get_ff_pdg ff_call in
- assert (not (PdgTypes.Pdg.is_top pdg_caller));
- (* we cannot have a top pdg here, because it is a sliced pdg *)
+ assert (not (PdgTypes.Pdg.is_top pdg_caller));
+ (* we cannot have a top pdg here, because it is a sliced pdg *)
let old_marks = FctMarks.get_ff_marks ff_call in
let missing_inputs =
FctMarks.marks_for_caller_inputs pdg_caller old_marks call to_prop fi
in
- match missing_inputs with
- | ([], false) ->
- SlicingParameters.debug ~level:2
- "[Fct_Slice.add_missing_inputs_actions] call %a, \
- no missing inputs@."
- Printer.pp_location (Cil_datatype.Stmt.loc call);
- actions
- | _ ->
- SlicingParameters.debug ~level:2
- "[Fct_Slice.add_missing_inputs_actions] call %a, \
- missing inputs@."
- Printer.pp_location (Cil_datatype.Stmt.loc call);
- let new_action = SlicingActions.mk_crit_missing_inputs
- ff_call call missing_inputs in
- new_action :: actions
+ match missing_inputs with
+ | ([], false) ->
+ SlicingParameters.debug ~level:2
+ "[Fct_Slice.add_missing_inputs_actions] call %a, \
+ no missing inputs@."
+ Printer.pp_location (Cil_datatype.Stmt.loc call);
+ actions
+ | _ ->
+ SlicingParameters.debug ~level:2
+ "[Fct_Slice.add_missing_inputs_actions] call %a, \
+ missing inputs@."
+ Printer.pp_location (Cil_datatype.Stmt.loc call);
+ let new_action = SlicingActions.mk_crit_missing_inputs
+ ff_call call missing_inputs in
+ new_action :: actions
in
SlicingParameters.debug ~level:2
"[Fct_Slice.add_missing_inputs_actions] Called, calls %a"
@@ -836,19 +836,19 @@ let add_missing_inputs_actions ff calls to_prop actions =
(fun fmt (_, s) -> Printer.pp_location fmt (Cil_datatype.Stmt.loc s)))
calls;
let actions = List.fold_left check_call actions calls in
- SlicingParameters.debug ~level:2 "[Fct_Slice.add_missing_inputs_actions] %s"
- (match actions with
- | [] -> " -> no missing input"
- | _ -> " -> add missing inputs actions");
- actions
+ SlicingParameters.debug ~level:2 "[Fct_Slice.add_missing_inputs_actions] %s"
+ (match actions with
+ | [] -> " -> no missing input"
+ | _ -> " -> add missing inputs actions");
+ actions
(** {2 Adding marks} *)
(** [ff] marks have been modified : we have to check if the calls and the
-* callers are ok. Create new actions if there is something to do.
-* Notice that the action creations are independent from the options.
-* They will by used during the applications.
-* *)
+ * callers are ok. Create new actions if there is something to do.
+ * Notice that the action creations are independent from the options.
+ * They will by used during the applications.
+ * *)
let after_marks_modifications ff to_prop =
SlicingParameters.debug ~level:2 "[Fct_Slice.after_marks_modifications] before: %a"
FctMarks.debug_marked_ff ff;
@@ -857,17 +857,17 @@ let after_marks_modifications ff to_prop =
let new_filters = add_missing_inputs_actions ff calls to_prop new_filters in
let call_outputs = FctMarks.marks_for_call_outputs to_prop in
let new_filters = (SlicingActions.mk_crit_examines_calls ff call_outputs)::new_filters in
- SlicingParameters.debug ~level:2 "[Fct_Slice.after_marks_modifications] after: %s new filters"
- (match new_filters with
- | [] -> "no"
- | _ -> "some");
- new_filters
+ SlicingParameters.debug ~level:2 "[Fct_Slice.after_marks_modifications] after: %s new filters"
+ (match new_filters with
+ | [] -> "no"
+ | _ -> "some");
+ new_filters
let apply_examine_calls ff call_outputs = examine_calls ff call_outputs
(** quite internal function that only computes the marks.
-* Don't use it alone because it doesn't take care of the calls and so on.
-* See [apply_add_marks] or [add_marks_to_fi] for higher level functions. *)
+ * Don't use it alone because it doesn't take care of the calls and so on.
+ * See [apply_add_marks] or [add_marks_to_fi] for higher level functions. *)
let add_marks fct_marks nodes_marks =
SlicingParameters.debug ~level:2 "add_marks@.";
let to_prop = FctMarks.mark_and_propagate fct_marks nodes_marks in
@@ -886,18 +886,18 @@ let apply_add_marks ff nodes_marks =
new_filters
(** a function that doesn't modify anything but test if the [nodes_marks]
-* are already in the slice or not.
-* @return the [nodes_marks] that are not already in.
+ * are already in the slice or not.
+ * @return the [nodes_marks] that are not already in.
*)
let filter_already_in ff selection =
FctMarks.get_new_marks ff selection
(** when the user adds persistent marks to a function,
-* he might want to propagate them to the callers,
-* but, anyway, we don't want to propagate persistent marks to the calls
-* for the same reason (if we mark [x = g ();] in [f], we don't necessarily want
-* all versions of [g] to have a visible [return] for instance).
-**)
+ * he might want to propagate them to the callers,
+ * but, anyway, we don't want to propagate persistent marks to the calls
+ * for the same reason (if we mark [x = g ();] in [f], we don't necessarily want
+ * all versions of [g] to have a visible [return] for instance).
+ **)
let prop_persistent_marks fi to_prop actions =
let pdg_node_marks = FctMarks.persistent_in_marks_to_prop fi to_prop in
let add_act acc (pdg, node_marks) =
@@ -905,34 +905,34 @@ let prop_persistent_marks fi to_prop actions =
let fi = SlicingMacros.get_kf_fi kf in
let a =
match node_marks with
- | PdgMarks.SelList node_marks ->
- SlicingActions.mk_crit_prop_persit_marks fi node_marks
- | PdgMarks.SelTopMarks marks ->
- assert (PdgTypes.Pdg.is_top pdg);
- let m = SlicingMarks.merge_marks marks in
- SlicingActions.mk_crit_fct_top fi m
+ | PdgMarks.SelList node_marks ->
+ SlicingActions.mk_crit_prop_persit_marks fi node_marks
+ | PdgMarks.SelTopMarks marks ->
+ assert (PdgTypes.Pdg.is_top pdg);
+ let m = SlicingMarks.merge_marks marks in
+ SlicingActions.mk_crit_fct_top fi m
in a::acc
in List.fold_left add_act actions pdg_node_marks
(** add the marks to the persistent marks to be used when new slices will be
-* created. The actions to add the marks to the existing slices are generated
-* in slicingProject.
-* If it is the first persistent selection for this function,
-* and [propagate=true], also generates the actions to make every calls to this
-* function visible. *)
+ * created. The actions to add the marks to the existing slices are generated
+ * in slicingProject.
+ * If it is the first persistent selection for this function,
+ * and [propagate=true], also generates the actions to make every calls to this
+ * function visible. *)
let add_marks_to_fi fi nodes_marks propagate actions =
SlicingParameters.debug ~level:2 "[Fct_Slice.add_marks_to_fi] (persistent)";
let marks, are_new_marks =
match FctMarks.fi_marks fi with
- | Some m -> m, false
- | None ->
- let init_marks = FctMarks.new_empty_fi_marks fi in
- init_marks, true
+ | Some m -> m, false
+ | None ->
+ let init_marks = FctMarks.new_empty_fi_marks fi in
+ init_marks, true
in
let to_prop = add_marks marks nodes_marks in
let actions = if propagate
- then prop_persistent_marks fi to_prop actions
- else actions
+ then prop_persistent_marks fi to_prop actions
+ else actions
in are_new_marks, actions
let add_top_mark_to_fi fi m propagate actions =
@@ -941,7 +941,7 @@ let add_top_mark_to_fi fi m propagate actions =
| Some old_m -> fi.SlicingInternals.fi_top <- Some (SlicingMarks.merge_marks [old_m; m]); false
in
let actions = if propagate && new_top then
- (SlicingActions.mk_appli_select_calls fi)::actions else actions
+ (SlicingActions.mk_appli_select_calls fi)::actions else actions
in actions
(** {3 Choosing the function to call} *)
@@ -952,17 +952,17 @@ let add_change_call_action ff call call_info f_to_call actions =
let add_change_call =
CallInfo.is_call_to_change call_info (Some f_to_call)
in
- if add_change_call then
- begin
- let change_call_action = SlicingActions.mk_crit_change_call ff call f_to_call in
- SlicingParameters.debug ~level:2 " -> %a" SlicingActions.print_crit change_call_action;
- change_call_action :: actions
- end
- else
- begin
- SlicingParameters.debug ~level:2 " -> not needed";
- actions
- end
+ if add_change_call then
+ begin
+ let change_call_action = SlicingActions.mk_crit_change_call ff call f_to_call in
+ SlicingParameters.debug ~level:2 " -> %a" SlicingActions.print_crit change_call_action;
+ change_call_action :: actions
+ end
+ else
+ begin
+ SlicingParameters.debug ~level:2 " -> not needed";
+ actions
+ end
(*
(** This function doesn't use the PDG call dependencies on purpose !
* See explanations in [add_spare_call_inputs] *)
@@ -1047,31 +1047,31 @@ let add_spare_call_inputs called_kf call_info =
*)
(** choose among the already computed slice if there is a function that computes
-* just enough outputs (what ever their marks are). If not, create a new one *)
+ * just enough outputs (what ever their marks are). If not, create a new one *)
let choose_precise_slice fi_to_call call_info =
let out_call = FctMarks.get_call_output_marks call_info in
let rec find slices = match slices with
| [] ->
- let ff, actions = make_new_ff fi_to_call true in
+ let ff, actions = make_new_ff fi_to_call true in
(*
let called_kf = SlicingMacros.get_fi_kf fi_to_call in
let new_actions = add_spare_call_inputs called_kf call_info in
let actions = new_actions @ actions in
*)
- ff, actions
+ ff, actions
| ff :: slices ->
- let _missing_outputs, more_outputs =
- FctMarks.check_called_marks out_call ff
- in
- if more_outputs
- then (* not enough outputs in [ff] *)
- begin
- SlicingParameters.debug ~level:2 "[Fct_Slice.choose_precise_slice] %s ? not enough outputs"
- (SlicingMacros.ff_name ff);
- find slices
- end
- else
- begin
+ let _missing_outputs, more_outputs =
+ FctMarks.check_called_marks out_call ff
+ in
+ if more_outputs
+ then (* not enough outputs in [ff] *)
+ begin
+ SlicingParameters.debug ~level:2 "[Fct_Slice.choose_precise_slice] %s ? not enough outputs"
+ (SlicingMacros.ff_name ff);
+ find slices
+ end
+ else
+ begin
(*
let ff_marks = FctMarks.get_ff_marks ff in
let input_marks = FctMarks.get_all_input_marks ff_marks in
@@ -1091,14 +1091,14 @@ let choose_precise_slice fi_to_call call_info =
end
else
*)
- begin
- SlicingParameters.debug ~level:2 "[Fct_Slice.choose_precise_slice] %s ? ok" (SlicingMacros.ff_name ff);
- ff , []
- end
- end
+ begin
+ SlicingParameters.debug ~level:2 "[Fct_Slice.choose_precise_slice] %s ? ok" (SlicingMacros.ff_name ff);
+ ff , []
+ end
+ end
in
let slices = SlicingMacros.fi_slices fi_to_call in
- find slices
+ find slices
(** choose the function to call according to the slicing level of the function
* to call *)
@@ -1112,25 +1112,25 @@ let choose_f_to_call fbase_to_call call_info =
| ff :: [] -> ff, []
| _ -> (* TODO : choose a slice *)
SlicingParameters.not_yet_implemented
- "choose_min_slice with several slices"
+ "choose_min_slice with several slices"
in
let choose_full_slice fi_to_call =
SlicingParameters.debug ~level:2 "PropagateMarksOnly -> choose_full_slice";
match SlicingMacros.fi_slices fi_to_call with
| [] -> make_new_ff fi_to_call true
- (* the signature is computed in [apply_choose_call]
- * (missing_outputs) *)
+ (* the signature is computed in [apply_choose_call]
+ * (missing_outputs) *)
| ff :: [] -> ff, []
| _ -> (* TODO : choose a slice *)
SlicingParameters.not_yet_implemented
- "choose_full_slice with several slices"
+ "choose_full_slice with several slices"
in
let to_call, new_filters = match fbase_to_call with
| None ->
- (* if we don't know the called function :
- either it is a call through a pointer or an external or
- variadic function
- => we don't try to slice it, so we keep the source call *)
+ (* if we don't know the called function :
+ either it is a call through a pointer or an external or
+ variadic function
+ => we don't try to slice it, so we keep the source call *)
SlicingParameters.debug ~level:1 "unknown called function -> keep src";
SlicingInternals.CallSrc None, []
| Some fi_to_call ->
@@ -1160,7 +1160,7 @@ let choose_f_to_call fbase_to_call call_info =
in to_call, new_filters
(** we are about to call [ff] for [sig_call] : let's first add some more output
-* marks in [ff] if needed. *)
+ * marks in [ff] if needed. *)
let check_called_outputs call_id ff actions =
let level = SlicingMacros.ff_slicing_level ff in
let add_spare = (level = SlicingInternals.DontSliceButComputeMarks) in
@@ -1169,47 +1169,47 @@ let check_called_outputs call_id ff actions =
match missing_outputs with
| [] -> actions
| _ ->
- let add_outputs = SlicingActions.mk_crit_add_output_marks ff missing_outputs in
- add_outputs :: actions
+ let add_outputs = SlicingActions.mk_crit_add_output_marks ff missing_outputs in
+ add_outputs :: actions
in actions
(** Choose the function (slice or source) to call according to the
-* slicing level of the called function.
-* Does nothing if there is already a called function :
-* this is useful because we can sometime generate several [choose_call]
-* for the same call, and we want to do something only the first time.
-* Build an action [change_call] to really call it.
-* If the chosen function doesn't compute enough output,
-* build an action to add outputs to it.
-* *)
+ * slicing level of the called function.
+ * Does nothing if there is already a called function :
+ * this is useful because we can sometime generate several [choose_call]
+ * for the same call, and we want to do something only the first time.
+ * Build an action [change_call] to really call it.
+ * If the chosen function doesn't compute enough output,
+ * build an action to add outputs to it.
+ * *)
let apply_choose_call ff call =
SlicingParameters.debug ~level:2 "[Fct_Slice.apply_choose_call] for call-%d" call.sid;
let call_id = ff, call in
let call_info = CallInfo.get_info_call (ff, call) in
- if ((CallInfo.get_f_called call_info) = None) then
- begin
- if CallInfo.something_visible call_info then
- let fbase_to_call = SlicingMacros.get_fi_call call in
- let f_to_call, actions =
- choose_f_to_call fbase_to_call call_info in
- let actions =
- add_change_call_action ff call call_info f_to_call actions in
- let actions = match f_to_call with
- | SlicingInternals.CallSrc _ -> actions
- | SlicingInternals.CallSlice ff ->
- check_called_outputs call_id ff actions
- in actions
- else
- begin
- SlicingParameters.debug ~level:2 " -> invisible call : nothing to do";
- []
- end
- end
- else
- begin
- SlicingParameters.debug ~level:2 " -> already call something : nothing to do";
- []
- end
+ if ((CallInfo.get_f_called call_info) = None) then
+ begin
+ if CallInfo.something_visible call_info then
+ let fbase_to_call = SlicingMacros.get_fi_call call in
+ let f_to_call, actions =
+ choose_f_to_call fbase_to_call call_info in
+ let actions =
+ add_change_call_action ff call call_info f_to_call actions in
+ let actions = match f_to_call with
+ | SlicingInternals.CallSrc _ -> actions
+ | SlicingInternals.CallSlice ff ->
+ check_called_outputs call_id ff actions
+ in actions
+ else
+ begin
+ SlicingParameters.debug ~level:2 " -> invisible call : nothing to do";
+ []
+ end
+ end
+ else
+ begin
+ SlicingParameters.debug ~level:2 " -> already call something : nothing to do";
+ []
+ end
(** {4 Calls input/output marks} *)
@@ -1227,15 +1227,15 @@ let apply_modif_call_inputs ff call missing_inputs =
let input_marks, _more_inputs = missing_inputs in
let to_prop = modif_call_inputs ff call input_marks in
let new_filters = after_marks_modifications ff to_prop in
- new_filters
+ new_filters
(** [ff] calls a slice [g] that needs more inputs than those computed by [ff].
-* The slicing level of [ff] is used in order to know if we have to modify [ff]
-* or to call another function. *)
+ * The slicing level of [ff] is used in order to know if we have to modify [ff]
+ * or to call another function. *)
let apply_missing_inputs ff call missing_inputs =
let _input_marks, more_inputs = missing_inputs in
SlicingParameters.debug ~level:1 "[Fct_Slice.apply_missing_inputs] (%s)"
- (if more_inputs then "more" else "marks");
+ (if more_inputs then "more" else "marks");
(*
let rec visible_top in_marks = match in_marks with
| [] -> false
@@ -1248,38 +1248,38 @@ let apply_missing_inputs ff call missing_inputs =
in let is_top_visible = visible_top input_marks in
*)
let level = SlicingMacros.ff_slicing_level ff in
- if more_inputs && level = SlicingInternals.MaxNbSlice then
- (* if adding marks doesn't change the visibility of the inputs,
- * let's keep the same called function. If it adds visible inputs,
- * let's choose another one *)
- begin
- FctMarks.change_call ff call None;
- apply_choose_call ff call
- end
- else
- apply_modif_call_inputs ff call missing_inputs
+ if more_inputs && level = SlicingInternals.MaxNbSlice then
+ (* if adding marks doesn't change the visibility of the inputs,
+ * let's keep the same called function. If it adds visible inputs,
+ * let's choose another one *)
+ begin
+ FctMarks.change_call ff call None;
+ apply_choose_call ff call
+ end
+ else
+ apply_modif_call_inputs ff call missing_inputs
(** [ff] calls a slice [g] that doesn't compute enough outputs for the [call].
-* The missing marks are [output_marks].
-* The slicing level has to be used to choose either to modify the called
-* function [g] or to change it.
+ * The missing marks are [output_marks].
+ * The slicing level has to be used to choose either to modify the called
+ * function [g] or to change it.
*)
let apply_missing_outputs ff call output_marks more_outputs =
SlicingParameters.debug ~level:2 "[Fct_Slice.apply_missing_outputs]";
let ff_g = match CallInfo.get_call_f_called (ff, call) with
- | Some (SlicingInternals.CallSlice g) -> g
- | _ -> (* we shouldn't be here *) assert false
+ | Some (SlicingInternals.CallSlice g) -> g
+ | _ -> (* we shouldn't be here *) assert false
in
let g_slicing_level = SlicingMacros.ff_slicing_level ff_g in
- if more_outputs && g_slicing_level = SlicingInternals.MaxNbSlice then
- begin
- (* the easiest way is to ignore the called function and to use
- * [choose_call] *)
- FctMarks.change_call ff call None;
- apply_choose_call ff call
- end
- else
- apply_add_marks ff_g output_marks
+ if more_outputs && g_slicing_level = SlicingInternals.MaxNbSlice then
+ begin
+ (* the easiest way is to ignore the called function and to use
+ * [choose_call] *)
+ FctMarks.change_call ff call None;
+ apply_choose_call ff call
+ end
+ else
+ apply_add_marks ff_g output_marks
@@ -1287,67 +1287,67 @@ let apply_missing_outputs ff call output_marks more_outputs =
(** check if [f_to_call] is ok for this call, and if so,
-* change the function call and propagate missing marks in the inputs
-* if needed.
-* @raise ChangeCallErr if [f_to_call] doesn't compute enough outputs.
+ * change the function call and propagate missing marks in the inputs
+ * if needed.
+ * @raise ChangeCallErr if [f_to_call] doesn't compute enough outputs.
*)
let apply_change_call ff call f_to_call =
SlicingParameters.debug ~level:1 "[Fct_Slice.apply_change_call]";
let pdg = SlicingMacros.get_ff_pdg ff in
let to_call, to_prop =
match f_to_call with
- | SlicingInternals.CallSlice ff_to_call ->
- (* let to_call_sig = FctMarks.get_sgn ff_to_call in
- let top = match to_call_sig with None -> false
- | Some to_call_sig -> SlicingMarks.is_topin_visible to_call_sig
- in
- if top then begin
- Cil.log "[slicing] top input in %s -> call source function"
- (SlicingMacros.ff_name ff_to_call);
- let to_prop = FctMarks.mark_spare_call_nodes ff call in
- SlicingInternals.CallSrc (Some (SlicingMacros.ff_fi ff_to_call)), to_prop
- end
- else *) begin
- let f = match check_outputs (ff, call) ff_to_call false with
- | ([], false) -> f_to_call
- | _ -> raise (SlicingTypes.ChangeCallErr
- "not enough computed output")
- in
- (* find [f_to_call] input marks *)
- let marks = FctMarks.get_ff_marks ff_to_call in
- let input_marks =
- try
- let kf = ff_to_call.SlicingInternals.ff_fct.SlicingInternals.fi_kf in
- let op_inputs =
- !Db.Operational_inputs.get_internal_precise ~stmt:call kf in
- let z = op_inputs.Inout_type.over_inputs in
- (*Format.printf "##Call at %a,@ kf %a,@ @[Z %a@]@."
- Cil.d_loc (Cil_datatype.Stmt.loc call)
- Kernel_function.pretty kf Locations.Zone.pretty z; *)
- FctMarks.get_matching_input_marks marks z
- with Not_found ->
- FctMarks.get_all_input_marks marks
- in
- let ff_marks = FctMarks.get_ff_marks ff in
- let missing_inputs, _more =
- FctMarks.marks_for_caller_inputs pdg ff_marks call input_marks
- ff_to_call.SlicingInternals.ff_fct
- in
- let to_prop = modif_call_inputs ff call missing_inputs in
- f, to_prop
- end
- | SlicingInternals.CallSrc _ ->
- let to_prop = FctMarks.mark_spare_call_nodes ff call in
- f_to_call, to_prop
+ | SlicingInternals.CallSlice ff_to_call ->
+ (* let to_call_sig = FctMarks.get_sgn ff_to_call in
+ let top = match to_call_sig with None -> false
+ | Some to_call_sig -> SlicingMarks.is_topin_visible to_call_sig
+ in
+ if top then begin
+ Cil.log "[slicing] top input in %s -> call source function"
+ (SlicingMacros.ff_name ff_to_call);
+ let to_prop = FctMarks.mark_spare_call_nodes ff call in
+ SlicingInternals.CallSrc (Some (SlicingMacros.ff_fi ff_to_call)), to_prop
+ end
+ else *) begin
+ let f = match check_outputs (ff, call) ff_to_call false with
+ | ([], false) -> f_to_call
+ | _ -> raise (SlicingTypes.ChangeCallErr
+ "not enough computed output")
+ in
+ (* find [f_to_call] input marks *)
+ let marks = FctMarks.get_ff_marks ff_to_call in
+ let input_marks =
+ try
+ let kf = ff_to_call.SlicingInternals.ff_fct.SlicingInternals.fi_kf in
+ let op_inputs =
+ !Db.Operational_inputs.get_internal_precise ~stmt:call kf in
+ let z = op_inputs.Inout_type.over_inputs in
+ (*Format.printf "##Call at %a,@ kf %a,@ @[Z %a@]@."
+ Cil.d_loc (Cil_datatype.Stmt.loc call)
+ Kernel_function.pretty kf Locations.Zone.pretty z; *)
+ FctMarks.get_matching_input_marks marks z
+ with Not_found ->
+ FctMarks.get_all_input_marks marks
+ in
+ let ff_marks = FctMarks.get_ff_marks ff in
+ let missing_inputs, _more =
+ FctMarks.marks_for_caller_inputs pdg ff_marks call input_marks
+ ff_to_call.SlicingInternals.ff_fct
+ in
+ let to_prop = modif_call_inputs ff call missing_inputs in
+ f, to_prop
+ end
+ | SlicingInternals.CallSrc _ ->
+ let to_prop = FctMarks.mark_spare_call_nodes ff call in
+ f_to_call, to_prop
in
- FctMarks.change_call ff call (Some to_call);
- let new_filters = after_marks_modifications ff to_prop in
- new_filters
+ FctMarks.change_call ff call (Some to_call);
+ let new_filters = after_marks_modifications ff to_prop in
+ new_filters
(** When the user wants to make a [change_call] to a function that doesn't
* compute enough outputs, he can call [check_outputs_before_change_call] in
-* order to build the action the add those outputs. *)
+ * order to build the action the add those outputs. *)
let check_outputs_before_change_call caller call ff_to_call =
let call_id = caller, call in
let actions = [] in
@@ -1358,35 +1358,35 @@ let check_outputs_before_change_call caller call ff_to_call =
(** {2 Merge, remove, ...} *)
(** Build a new slice which marks are a join between [ff1] marks and [ff2]
-* marks. The result [ff] is not called at the end of this action.
-* [examine_calls] is called to generate the actions to choose the calls. *)
+ * marks. The result [ff] is not called at the end of this action.
+ * [examine_calls] is called to generate the actions to choose the calls. *)
let merge_slices ff1 ff2 =
let fi = ff1.SlicingInternals.ff_fct in
- assert (SlicingMacros.equal_fi fi ff2.SlicingInternals.ff_fct); (* TODO : raise exception *)
+ assert (SlicingMacros.equal_fi fi ff2.SlicingInternals.ff_fct); (* TODO : raise exception *)
let ff, _ =
try make_new_ff fi false
- (* [ff] can already have some persistent selection,
- * but we can safely forget then because they then have to also be in
- * [ff1] and [ff2]. *)
+ (* [ff] can already have some persistent selection,
+ * but we can safely forget then because they then have to also be in
+ * [ff1] and [ff2]. *)
with SlicingTypes.NoPdg -> assert false
in
ff.SlicingInternals.ff_marks <- FctMarks.merge ff1 ff2;
let to_prop = FctMarks.empty_to_prop (* ff is new, so it isn't called,
- and all its calls are reset to None... *) in
+ and all its calls are reset to None... *) in
let new_filters = after_marks_modifications ff to_prop in
ff, new_filters
(** [ff] has to be removed. We have to check if it is not called
-* and to remove the called function in [ff].
-* @raise SlicingTypes.CantRemoveCalledFf if the slice is called.
-* *)
+ * and to remove the called function in [ff].
+ * @raise SlicingTypes.CantRemoveCalledFf if the slice is called.
+ * *)
let clear_ff ff =
let clear_call call_stmt call_info _ =
CallInfo.remove_called_by (ff, call_stmt) call_info in
match ff.SlicingInternals.ff_called_by with
- | [] ->
- FctMarks.fold_calls clear_call ff ()
- | _ -> raise SlicingTypes.CantRemoveCalledFf
+ | [] ->
+ FctMarks.fold_calls clear_call ff ()
+ | _ -> raise SlicingTypes.CantRemoveCalledFf
(*-----------------------------------------------------------------------*)
(** {2 Getting the slice marks} *)
@@ -1402,14 +1402,14 @@ let get_local_var_mark ff var =
get_node_key_mark ff (PdgIndex.Key.decl_var_key var)
let get_param_mark ff n =
- try
- match FctMarks.get_sgn ff with None -> SlicingMarks.bottom_mark
- | Some sgn -> SlicingMarks.get_input_mark sgn n
- with Not_found -> SlicingMarks.bottom_mark
+ try
+ match FctMarks.get_sgn ff with None -> SlicingMarks.bottom_mark
+ | Some sgn -> SlicingMarks.get_input_mark sgn n
+ with Not_found -> SlicingMarks.bottom_mark
let get_label_mark ff label_stmt label =
let key = PdgIndex.Key.label_key label_stmt label in
- get_node_key_mark ff key
+ get_node_key_mark ff key
let get_stmt_mark ff stmt =
try
@@ -1422,11 +1422,11 @@ let get_stmt_mark ff stmt =
in
SlicingMarks.merge_marks marks
with Not_found ->
- match stmt.Cil_types.skind with
- | Cil_types.Block _ | Cil_types.UnspecifiedSequence _ ->
- (* block are always visible for syntactic reasons *)
- SlicingMarks.mk_gen_spare
- | _ -> SlicingMarks.bottom_mark
+ match stmt.Cil_types.skind with
+ | Cil_types.Block _ | Cil_types.UnspecifiedSequence _ ->
+ (* block are always visible for syntactic reasons *)
+ SlicingMarks.mk_gen_spare
+ | _ -> SlicingMarks.bottom_mark
let get_top_input_mark fi =
try
@@ -1437,13 +1437,13 @@ let get_top_input_mark fi =
let merge_inputs_m1_mark ff =
let ff_sig =
match FctMarks.get_sgn ff with Some s -> s
- | None -> assert false (* "Should have a signature !" *)
+ | None -> assert false (* "Should have a signature !" *)
in SlicingMarks.merge_inputs_m1_mark ff_sig
let get_input_loc_under_mark ff loc =
let ff_sig =
match FctMarks.get_sgn ff with Some s -> s
- | None -> assert false (* "Should have a signature !" *)
+ | None -> assert false (* "Should have a signature !" *)
in SlicingMarks.get_input_loc_under_mark ff_sig loc
(*-----------------------------------------------------------------------*)
@@ -1456,42 +1456,42 @@ let merge_fun_callers get_list get_value merge is_top acc kf =
else begin
let acc = ref acc in
let table = ref Cil_datatype.Varinfo.Set.empty in
- try
- let merge m =
- acc := merge m !acc ;
- if is_top !acc then
- raise StopMerging (* acceleration when top is reached *)
- in
- let rec merge_fun_callers kf =
- let merge_fun_caller (kf,_) = merge_fun_callers kf in
- let vf = Kernel_function.get_vi kf in
- if not (Cil_datatype.Varinfo.Set.mem vf !table) then begin
- table := Cil_datatype.Varinfo.Set.add vf !table ;
- List.iter (fun x -> merge (get_value x)) (get_list kf) ;
- List.iter merge_fun_caller (!Db.Value.callers kf)
- end
+ try
+ let merge m =
+ acc := merge m !acc ;
+ if is_top !acc then
+ raise StopMerging (* acceleration when top is reached *)
+ in
+ let rec merge_fun_callers kf =
+ let merge_fun_caller (kf,_) = merge_fun_callers kf in
+ let vf = Kernel_function.get_vi kf in
+ if not (Cil_datatype.Varinfo.Set.mem vf !table) then begin
+ table := Cil_datatype.Varinfo.Set.add vf !table ;
+ List.iter (fun x -> merge (get_value x)) (get_list kf) ;
+ List.iter merge_fun_caller (!Db.Value.callers kf)
+ end
(* else no way to add something, the [kf] contribution is already
accumulated. *)
- in
- merge_fun_callers kf;
- !acc
- with StopMerging ->
- !acc
+ in
+ merge_fun_callers kf;
+ !acc
+ with StopMerging ->
+ !acc
end
(** The mark [m] related to all statements of a source function [kf].
Property : [is_bottom (get_from_func kf) = not (is_src_fun_called kf) ] *)
let get_mark_from_src_fun kf =
let kf_entry, _library = Globals.entry_point () in
- if is_src_fun_called kf_entry then
- SlicingMarks.mk_user_mark ~data:true ~addr:true ~ctrl:true
- else
- let directly_called kf = (SlicingMacros.get_kf_fi kf).SlicingInternals.f_called_by in
- let get_call_mark (ff,stmt) = get_stmt_mark ff stmt in
- let merge m1 m2 = SlicingMarks.merge_marks [m1 ; m2] in
- let is_top = SlicingMarks.is_top_mark in
- let bottom = SlicingMarks.bottom_mark in
- merge_fun_callers directly_called get_call_mark merge is_top bottom kf
+ if is_src_fun_called kf_entry then
+ SlicingMarks.mk_user_mark ~data:true ~addr:true ~ctrl:true
+ else
+ let directly_called kf = (SlicingMacros.get_kf_fi kf).SlicingInternals.f_called_by in
+ let get_call_mark (ff,stmt) = get_stmt_mark ff stmt in
+ let merge m1 m2 = SlicingMarks.merge_marks [m1 ; m2] in
+ let is_top = SlicingMarks.is_top_mark in
+ let bottom = SlicingMarks.bottom_mark in
+ merge_fun_callers directly_called get_call_mark merge is_top bottom kf
(*-----------------------------------------------------------------------*)
(** {2 Printing} (see also {!PrintSlice}) *)
@@ -1499,8 +1499,8 @@ let get_mark_from_src_fun kf =
let print_ff_sig fmt ff =
Format.fprintf fmt "%s:@ " (SlicingMacros.ff_name ff);
match FctMarks.get_sgn ff with
- | None -> Format.fprintf fmt "<not computed>"
- | Some s -> SlicingMarks.pretty_sig fmt s
+ | None -> Format.fprintf fmt "<not computed>"
+ | Some s -> SlicingMarks.pretty_sig fmt s
(*-----------------------------------------------------------------------*)
(*
diff --git a/src/plugins/slicing/fct_slice.mli b/src/plugins/slicing/fct_slice.mli
index b7081df617ff412450f9c5bb5d276ce23857cfbe..cf3ca168fa1edb532107207c9b8a0d2bfb7577e8 100644
--- a/src/plugins/slicing/fct_slice.mli
+++ b/src/plugins/slicing/fct_slice.mli
@@ -24,17 +24,17 @@ open SlicingInternals
open Cil_types
(** Return [true] if the source function is called
-* (even indirectly via transitivity) from a [Slice.t]. *)
+ * (even indirectly via transitivity) from a [Slice.t]. *)
val is_src_fun_called :
- Cil_types.kernel_function -> bool
+ Cil_types.kernel_function -> bool
(** Return [true] if the source function is visible
-* (even indirectly via transitivity) from a [Slice.t]. *)
+ * (even indirectly via transitivity) from a [Slice.t]. *)
val is_src_fun_visible :
- Cil_types.kernel_function -> bool
+ Cil_types.kernel_function -> bool
(**
-* @raise SlicingTypes.ExternalFunction if the function has no source code,
-* because there cannot be any slice for it.
+ * @raise SlicingTypes.ExternalFunction if the function has no source code,
+ * because there cannot be any slice for it.
* @raise SlicingTypes.NoPdg when there is no PDG for the function.
*)
val make_new_ff : fct_info -> bool -> fct_slice * criterion list
diff --git a/src/plugins/slicing/printSlice.ml b/src/plugins/slicing/printSlice.ml
index 648e2c13f10efe11e93a0d97791876a88538061b..63986e183ebb85760f6c4a16023d4139946f9927 100644
--- a/src/plugins/slicing/printSlice.ml
+++ b/src/plugins/slicing/printSlice.ml
@@ -29,12 +29,12 @@ open Cil_types
(**/**)
let find_sub_stmts st = match st.skind with
-| If(_,bl1,bl2,_) | TryExcept (bl1, _, bl2, _)
-| TryFinally (bl1, bl2, _) -> bl1.bstmts@bl2.bstmts
-| Block bl | Loop (_,bl, _, _, _) | Switch (_, bl, _, _) -> bl.bstmts
-| UnspecifiedSequence seq -> List.map (fun (x,_,_,_,_) -> x) seq
-| TryCatch(t,c,_) -> List.fold_left (fun acc (_,b) -> acc @ b.bstmts) t.bstmts c
-| Continue _|Break _|Goto (_, _)|Return (_, _)|Instr _|Throw _ -> []
+ | If(_,bl1,bl2,_) | TryExcept (bl1, _, bl2, _)
+ | TryFinally (bl1, bl2, _) -> bl1.bstmts@bl2.bstmts
+ | Block bl | Loop (_,bl, _, _, _) | Switch (_, bl, _, _) -> bl.bstmts
+ | UnspecifiedSequence seq -> List.map (fun (x,_,_,_,_) -> x) seq
+ | TryCatch(t,c,_) -> List.fold_left (fun acc (_,b) -> acc @ b.bstmts) t.bstmts c
+ | Continue _|Break _|Goto (_, _)|Return (_, _)|Instr _|Throw _ -> []
let str_call_sig ff call fmt =
try
@@ -51,7 +51,7 @@ let str_call_sig ff call fmt =
in
Format.fprintf fmt "@[<v>@[<hov 2>/* sig call:@ %a */@]@ %t@]"
SlicingMarks.pretty_sig sgn print_called
- with Not_found ->
+ with Not_found ->
Format.fprintf fmt "@[/* invisible call */@]"
class printerClass optional_ff = object(self)
@@ -62,40 +62,40 @@ class printerClass optional_ff = object(self)
match opt_ff with
| None -> super#vdecl fmt var
| Some ff ->
- if var.vglob then
- Format.fprintf fmt "@[/**/%a@]" super#vdecl var
- else
- let str_m =
- try
- let m = Fct_slice.get_local_var_mark ff var in
- SlicingMarks.mark_to_string m
- with Not_found -> "[---]"
- in
- Format.fprintf fmt "@[<hv>/* %s */@ %a@]"
- str_m
- super#vdecl var
+ if var.vglob then
+ Format.fprintf fmt "@[/**/%a@]" super#vdecl var
+ else
+ let str_m =
+ try
+ let m = Fct_slice.get_local_var_mark ff var in
+ SlicingMarks.mark_to_string m
+ with Not_found -> "[---]"
+ in
+ Format.fprintf fmt "@[<hv>/* %s */@ %a@]"
+ str_m
+ super#vdecl var
method! stmtkind sattr next fmt kind =
let stmt_info fmt stmt = match opt_ff with
| None -> Format.fprintf fmt "@[/* %d */@]" stmt.Cil_types.sid
| Some ff ->
- let str_m = try
+ let str_m = try
let m = Fct_slice.get_stmt_mark ff stmt in
SlicingMarks.mark_to_string m
with Not_found -> "[---]"
- in
- if (SlicingMacros.is_call_stmt stmt)then
- Format.fprintf fmt "@[<hv>%t@ /* %s */@]"
- (str_call_sig ff stmt) str_m
- else
- Format.fprintf fmt "@[/* %s */@]" str_m
+ in
+ if (SlicingMacros.is_call_stmt stmt)then
+ Format.fprintf fmt "@[<hv>%t@ /* %s */@]"
+ (str_call_sig ff stmt) str_m
+ else
+ Format.fprintf fmt "@[/* %s */@]" str_m
in
let s = Option.get self#current_stmt in
try
Format.fprintf fmt "@[<v>%a@ %a@]"
stmt_info s
(fun fmt -> super#stmtkind sattr next fmt) kind
- with Not_found ->
+ with Not_found ->
(* some sub statements may be visible *)
let sub_stmts = find_sub_stmts s in
List.iter (self#stmt fmt) sub_stmts
@@ -123,8 +123,8 @@ let print_fct_from_pdg fmt ?ff pdg =
printer#global fmt glob
let print_marked_ff fmt ff =
- let pdg = SlicingMacros.get_ff_pdg ff in
- Format.fprintf fmt "@[<v>@[<hv>Print slice =@ %a@]@ @ %a@]"
+ let pdg = SlicingMacros.get_ff_pdg ff in
+ Format.fprintf fmt "@[<v>@[<hv>Print slice =@ %a@]@ @ %a@]"
Fct_slice.print_ff_sig ff
(print_fct_from_pdg ~ff) pdg
@@ -157,11 +157,11 @@ module PrintProject = struct
type tfi = Undef | PersistSelect | Other
let fi_type fi = match fi.SlicingInternals.fi_def with
- | Some _f ->
- if SlicingMacros.fi_has_persistent_selection fi
- then PersistSelect
- else Other
- | None -> Undef
+ | Some _f ->
+ if SlicingMacros.fi_has_persistent_selection fi
+ then PersistSelect
+ else Other
+ | None -> Undef
let node_slice_callers () =
(OptSliceCallers (SlicingParameters.Mode.Callers.get ()))
@@ -177,10 +177,10 @@ module PrintProject = struct
let do_kf kf =
let fi = SlicingMacros.get_kf_fi kf in
let slices = SlicingMacros.fi_slices fi in
- List.iter (fun ff -> f (Slice ff)) slices;
- f (Src fi)
+ List.iter (fun ff -> f (Slice ff)) slices;
+ f (Src fi)
in
- Globals.Functions.iter do_kf
+ Globals.Functions.iter do_kf
let iter_edges_slices f proj =
let do_edge dest (ff_caller, call) =
@@ -197,8 +197,8 @@ module PrintProject = struct
| [] -> ()
| _ :: [] -> ()
| rq1 :: rq2 :: rq_list ->
- f (((Action (n, rq1)), (Action (n+1, rq2))), None);
- do_act_edge (n+1) (rq2 :: rq_list)
+ f (((Action (n, rq1)), (Action (n+1, rq2))), None);
+ do_act_edge (n+1) (rq2 :: rq_list)
in do_act_edge 1 proj.SlicingInternals.actions
let iter_edges_src_fun f =
@@ -206,17 +206,17 @@ module PrintProject = struct
let fi = SlicingMacros.get_kf_fi kf in
let doit (kf_caller,_) =
let fi_caller = SlicingMacros.get_kf_fi kf_caller in
- f ((Src fi_caller, Src fi), None)
+ f ((Src fi_caller, Src fi), None)
in List.iter doit (!Db.Value.callers kf)
in
- Globals.Functions.iter do_kf_calls
+ Globals.Functions.iter do_kf_calls
let iter_edges_e f (_, proj) =
match proj.SlicingInternals.actions with [] -> ()
- | rq :: _ -> f ((node_slice_callers (), (Action (1, rq))), None);
- iter_edges_slices f proj;
- iter_edges_actions f proj;
- iter_edges_src_fun f
+ | rq :: _ -> f ((node_slice_callers (), (Action (1, rq))), None);
+ iter_edges_slices f proj;
+ iter_edges_actions f proj;
+ iter_edges_src_fun f
let color_soft_green = (0x7FFFD4)
let color_medium_green = (0x00E598)
@@ -244,61 +244,61 @@ module PrintProject = struct
let vertex_attributes v = match v with
| Src fi ->
- let color = match fi_type fi with
- | Undef -> (`Fillcolor color_soft_yellow)
- | PersistSelect -> (`Fillcolor color_soft_orange)
- | Other -> (`Fillcolor color_soft_green)
- in color::[`Shape `Plaintext]
+ let color = match fi_type fi with
+ | Undef -> (`Fillcolor color_soft_yellow)
+ | PersistSelect -> (`Fillcolor color_soft_orange)
+ | Other -> (`Fillcolor color_soft_green)
+ in color::[`Shape `Plaintext]
| Slice ff ->
- let color = match fi_type ff.SlicingInternals.ff_fct with
- | Undef -> assert false
- | PersistSelect -> (`Fillcolor color_soft_orange)
- | Other -> (`Fillcolor color_soft_green)
- in color ::[`Shape `Ellipse]
+ let color = match fi_type ff.SlicingInternals.ff_fct with
+ | Undef -> assert false
+ | PersistSelect -> (`Fillcolor color_soft_orange)
+ | Other -> (`Fillcolor color_soft_green)
+ in color ::[`Shape `Ellipse]
| Action (_, crit) ->
- let label = Format.asprintf "%a" SlicingActions.print_crit crit in
- let attrib = [] in
- let attrib = (`Label label)::attrib in
- let attrib = (`Fillcolor color_soft_pink)::attrib in
- let attrib = (`Shape `Box)::attrib in
- attrib
+ let label = Format.asprintf "%a" SlicingActions.print_crit crit in
+ let attrib = [] in
+ let attrib = (`Label label)::attrib in
+ let attrib = (`Fillcolor color_soft_pink)::attrib in
+ let attrib = (`Shape `Box)::attrib in
+ attrib
| OptSlicingLevel mode ->
- let label = ("SliceCalls = "^(SlicingMacros.str_level_option mode)) in
- let attrib = [] in
- let attrib = (`Label label)::attrib in
- let attrib = (`Fillcolor color_soft_purple)::attrib in
- let attrib = (`Shape `Ellipse)::attrib in
- let attrib = (`Fontsize 10)::attrib in
- attrib
+ let label = ("SliceCalls = "^(SlicingMacros.str_level_option mode)) in
+ let attrib = [] in
+ let attrib = (`Label label)::attrib in
+ let attrib = (`Fillcolor color_soft_purple)::attrib in
+ let attrib = (`Shape `Ellipse)::attrib in
+ let attrib = (`Fontsize 10)::attrib in
+ attrib
| OptSliceCallers b ->
- let label = ("SliceCallers = "^(if b then "true" else "false")) in
- let attrib = [] in
- let attrib = (`Label label)::attrib in
- let attrib = (`Fillcolor color_soft_purple)::attrib in
- let attrib = (`Shape `Ellipse)::attrib in
- let attrib = (`Fontsize 10)::attrib in
- attrib
+ let label = ("SliceCallers = "^(if b then "true" else "false")) in
+ let attrib = [] in
+ let attrib = (`Label label)::attrib in
+ let attrib = (`Fillcolor color_soft_purple)::attrib in
+ let attrib = (`Shape `Ellipse)::attrib in
+ let attrib = (`Fontsize 10)::attrib in
+ attrib
let default_edge_attributes _ =
let attrib = [] in
let attrib = (`Fontsize 10)::attrib in
- attrib
+ attrib
let edge_attributes (e, call) =
let attrib = match e with
- | (Src _, Src _) -> [`Style `Invis]
- | (OptSliceCallers _, _) -> [`Style `Invis]
- | (_, OptSliceCallers _) -> [`Style `Invis]
- | _ -> []
+ | (Src _, Src _) -> [`Style `Invis]
+ | (OptSliceCallers _, _) -> [`Style `Invis]
+ | (_, OptSliceCallers _) -> [`Style `Invis]
+ | _ -> []
in match call with None -> attrib
- | Some call -> (`Label (string_of_int call.sid)):: attrib
+ | Some call -> (`Label (string_of_int call.sid)):: attrib
let get_subgraph v =
let mk_subgraph name attrib =
let attrib = (*(`Label name) ::*) (`Style `Filled) :: attrib in
- Some { Graph.Graphviz.DotAttributes.sg_name= name;
- sg_parent = None;
- sg_attributes = attrib }
+ Some { Graph.Graphviz.DotAttributes.sg_name= name;
+ sg_parent = None;
+ sg_attributes = attrib }
in
let f_subgraph fi =
let name = SlicingMacros.fi_name fi in
@@ -308,19 +308,19 @@ module PrintProject = struct
| PersistSelect -> (`Fillcolor color_medium_orange)
| Other -> (`Fillcolor color_medium_green)
in let attrib = color :: attrib in
- mk_subgraph name attrib
+ mk_subgraph name attrib
in
let rq_subgraph =
let name = "Requests" in
let attrib = [] in
let attrib = (`Fillcolor color_medium_pink) :: attrib in
let attrib = (`Label name) :: attrib in
- mk_subgraph name attrib
+ mk_subgraph name attrib
in match v with
- | Src fi -> f_subgraph fi
- | Slice ff -> f_subgraph ff.SlicingInternals.ff_fct
- | Action _ -> rq_subgraph
- | OptSlicingLevel _ | OptSliceCallers _ -> rq_subgraph
+ | Src fi -> f_subgraph fi
+ | Slice ff -> f_subgraph ff.SlicingInternals.ff_fct
+ | Action _ -> rq_subgraph
+ | OptSlicingLevel _ | OptSliceCallers _ -> rq_subgraph
end
diff --git a/src/plugins/slicing/register.ml b/src/plugins/slicing/register.ml
index e5c2ea11b52c99b3e44bac298f015c168b21dfc0..3f32606a217928ce557bfcc06f7d7b5c98c0dbea 100644
--- a/src/plugins/slicing/register.ml
+++ b/src/plugins/slicing/register.ml
@@ -32,16 +32,16 @@ let main () =
let project_name = SlicingParameters.ProjectName.get () in
Api.Project.reset_slicing ();
Api.Request.add_persistent_cmdline ();
- (* Apply all pending requests. *)
+ (* Apply all pending requests. *)
if Api.Request.is_request_empty_internal () then
begin
- SlicingParameters.warning "No internal slicing request from the command line." ;
- if SlicingParameters.Mode.Callers.get () then
+ SlicingParameters.warning "No internal slicing request from the command line." ;
+ if SlicingParameters.Mode.Callers.get () then
let kf_entry, _library = Globals.entry_point () in
- SlicingParameters.warning "Adding an extra request on the entry point of function: %a." Kernel_function.pretty kf_entry;
- let set = Api.Select.empty_selects in
- let set = Api.Select.select_func_calls_into set true kf_entry in
- Api.Request.add_persistent_selection set
+ SlicingParameters.warning "Adding an extra request on the entry point of function: %a." Kernel_function.pretty kf_entry;
+ let set = Api.Select.empty_selects in
+ let set = Api.Select.select_func_calls_into set true kf_entry in
+ Api.Request.add_persistent_selection set
end;
Api.Request.apply_all_internal ();
diff --git a/src/plugins/slicing/register_gui.ml b/src/plugins/slicing/register_gui.ml
index 0ae02753447e6cab4259bbc5fc6394bf9a2d4130..0650a8a5d7d4ec67b06399f6dc4e4f0420060acc 100644
--- a/src/plugins/slicing/register_gui.ml
+++ b/src/plugins/slicing/register_gui.ml
@@ -28,12 +28,12 @@ let update_column = ref (fun _ -> ())
(* Are results shown? *)
module Enabled = struct
include State_builder.Ref
- (Datatype.Bool)
- (struct
- let name = "Slicing_gui.State"
- let dependencies = [Api.self]
- let default () = false
- end)
+ (Datatype.Bool)
+ (struct
+ let name = "Slicing_gui.State"
+ let dependencies = [Api.self]
+ let default () = false
+ end)
end
(* for slicing callback *)
@@ -83,31 +83,31 @@ let gui_mk_slice (main_ui:Design.main_window_extension_points) selection ~info =
let new_project = mk_slice selection in (* ... slicing computation *)
gui_annot_info main_ui
(fun fmt -> Format.fprintf fmt "Slice exported to project: %s"
- (Project.get_unique_name new_project));
+ (Project.get_unique_name new_project));
main_ui#rehighlight ()
let msg_help_enable_gui = "Enables/Disables the Slicing GUI."
let msg_help_libraries =
"Allows/Disallows the use of the -slicing-level option for calls to \
-undefined functions."
+ undefined functions."
let check_value_computed (main_ui:Design.main_window_extension_points) =
if Db.Value.is_computed () then true
else
let answer = GToolbox.question_box
- ~title:("Eva Needed")
- ~buttons:[ "Run"; "Cancel" ]
- ("Eva has to be run first.\nThis can take some time and may \
- require some special settings.\n"
- ^"Do you want to run Eva with its current settings now?")
+ ~title:("Eva Needed")
+ ~buttons:[ "Run"; "Cancel" ]
+ ("Eva has to be run first.\nThis can take some time and may \
+ require some special settings.\n"
+ ^"Do you want to run Eva with its current settings now?")
in
- if answer = 1 then
- match main_ui#full_protect ~cancelable:true !Db.Value.compute with
- | Some _ ->
- main_ui#redisplay (); (* New alarms *)
- true
- | None -> false
- else false
+ if answer = 1 then
+ match main_ui#full_protect ~cancelable:true !Db.Value.compute with
+ | Some _ ->
+ main_ui#redisplay (); (* New alarms *)
+ true
+ | None -> false
+ else false
(* To do an action and inform the user. *)
let gui_apply_action (main_ui:Design.main_window_extension_points) f x ~info =
@@ -121,19 +121,19 @@ let slicing_selector (popup_factory:GMenu.menu GMenu.factory)
ignore
(popup_factory#add_item "Enable _slicing"
~callback:
- (fun () ->
- let enable () =
- Enabled.set true;
- !update_column `Visibility
- in
- if (not (Db.Value.is_computed ())) then begin
- if check_value_computed main_ui then enable ()
- end
- else enable ()
- ))
+ (fun () ->
+ let enable () =
+ Enabled.set true;
+ !update_column `Visibility
+ in
+ if (not (Db.Value.is_computed ())) then begin
+ if check_value_computed main_ui then enable ()
+ end
+ else enable ()
+ ))
else
- if button = 1 then
- begin let level = 1 in
+ if button = 1 then
+ begin let level = 1 in
let slicing_view () =
gui_annot_info main_ui ~level
(fun fmt -> Format.fprintf fmt "Highlighting.")
@@ -144,29 +144,29 @@ let slicing_selector (popup_factory:GMenu.menu GMenu.factory)
let slicing_mark kf get_mark =
(* use -slicing-debug -verbose to get slicing mark information *)
let add_mark_info txt = gui_annot_info ~level main_ui
- (fun fmt -> Format.fprintf fmt "Tag: %s" (txt ()))
+ (fun fmt -> Format.fprintf fmt "Tag: %s" (txt ()))
in
let slices = Api.Slice.get_all kf in
match slices with
| [] -> (* No slice for this kf *)
- add_mark_info (fun () ->
- if Api.Project.is_called kf
- then (* but the source function is called *)
- (Format.asprintf "<src>%a"
- Api.Mark.pretty (Api.Mark.get_from_src_func kf))
- else
- "< >< >")
+ add_mark_info (fun () ->
+ if Api.Project.is_called kf
+ then (* but the source function is called *)
+ (Format.asprintf "<src>%a"
+ Api.Mark.pretty (Api.Mark.get_from_src_func kf))
+ else
+ "< >< >")
| slices ->
- if Api.Project.is_called kf
- then begin (* The source function is also called *)
- assert (not (kf == fst (Globals.entry_point ()))) ;
- add_mark_info (fun () ->
- Format.asprintf "<src>%a"
- Api.Mark.pretty (Api.Mark.get_from_src_func kf))
- end ;
- let mark_slice slice =
- add_mark_info (fun () -> Format.asprintf "%a" Api.Mark.pretty (get_mark slice))
- in List.iter mark_slice slices
+ if Api.Project.is_called kf
+ then begin (* The source function is also called *)
+ assert (not (kf == fst (Globals.entry_point ()))) ;
+ add_mark_info (fun () ->
+ Format.asprintf "<src>%a"
+ Api.Mark.pretty (Api.Mark.get_from_src_func kf))
+ end ;
+ let mark_slice slice =
+ add_mark_info (fun () -> Format.asprintf "%a" Api.Mark.pretty (get_mark slice))
+ in List.iter mark_slice slices
in match localizable with
| Pretty_source.PTermLval(Some kf,(Kstmt ki),_,_)
| Pretty_source.PLval (Some kf,(Kstmt ki),_)
@@ -180,205 +180,205 @@ let slicing_selector (popup_factory:GMenu.menu GMenu.factory)
in
SlicingState.may slicing_mark
end
- end
- else if button = 3 then begin
- let submenu = popup_factory#add_submenu "Slicing" in
- let slicing_factory =
- new Design.protected_menu_factory (main_ui:>Gtk_helper.host) submenu
+ end
+ else if button = 3 then begin
+ let submenu = popup_factory#add_submenu "Slicing" in
+ let slicing_factory =
+ new Design.protected_menu_factory (main_ui:>Gtk_helper.host) submenu
+ in
+ (* definitions for slicing plug-in *)
+ let add_slicing_item name ~callback v =
+ let callback v =
+ callback v;
+ !update_column `Contents
in
- (* definitions for slicing plug-in *)
- let add_slicing_item name ~callback v =
- let callback v =
- callback v;
- !update_column `Contents
- in
- add_item slicing_factory name ~callback v
- in
- let mk_slice = gui_mk_slice main_ui in
- let add_slice_menu kf_opt kf_ki_lv_opt =
- (let callback kf =
- mk_slice
- ~info:(fun fmt ->
+ add_item slicing_factory name ~callback v
+ in
+ let mk_slice = gui_mk_slice main_ui in
+ let add_slice_menu kf_opt kf_ki_lv_opt =
+ (let callback kf =
+ mk_slice
+ ~info:(fun fmt ->
Format.fprintf fmt
"Request for slicing effects of function %a"
Kernel_function.pretty kf)
- (mk_selection_all Api.Select.select_func_calls_to kf)
- in
- add_slicing_item "Slice calls to" kf_opt ~callback);
+ (mk_selection_all Api.Select.select_func_calls_to kf)
+ in
+ add_slicing_item "Slice calls to" kf_opt ~callback);
- (let callback kf =
- mk_slice
- ~info:(fun fmt ->
+ (let callback kf =
+ mk_slice
+ ~info:(fun fmt ->
Format.fprintf fmt
"Request for slicing entrance into function %a"
Kernel_function.pretty kf)
- (mk_selection_all Api.Select.select_func_calls_into kf)
- in
- add_slicing_item "Slice calls into" kf_opt ~callback);
+ (mk_selection_all Api.Select.select_func_calls_into kf)
+ in
+ add_slicing_item "Slice calls into" kf_opt ~callback);
- (let callback kf =
- mk_slice
- ~info:(fun fmt ->
+ (let callback kf =
+ mk_slice
+ ~info:(fun fmt ->
Format.fprintf fmt
"Request for returned value of function %a"
Kernel_function.pretty kf)
- (mk_selection_all Api.Select.select_func_return kf)
- in
- add_slicing_item "Slice result"
- (Extlib.opt_filter
- (fun kf ->
- let is_not_void_kf x =
- match x.Cil_types.vtype with
- | Cil_types.TFun (Cil_types.TVoid (_),_,_,_) -> false
- | _ -> true
- in is_not_void_kf (Kernel_function.get_vi kf))
- kf_opt)
- ~callback);
-
- (let callback (kf, ki, _) =
- mk_slice
- ~info:(fun fmt ->
+ (mk_selection_all Api.Select.select_func_return kf)
+ in
+ add_slicing_item "Slice result"
+ (Extlib.opt_filter
+ (fun kf ->
+ let is_not_void_kf x =
+ match x.Cil_types.vtype with
+ | Cil_types.TFun (Cil_types.TVoid (_),_,_,_) -> false
+ | _ -> true
+ in is_not_void_kf (Kernel_function.get_vi kf))
+ kf_opt)
+ ~callback);
+
+ (let callback (kf, ki, _) =
+ mk_slice
+ ~info:(fun fmt ->
Format.fprintf fmt
"Request for slicing effects of statement %d"
ki.sid)
- (mk_selection_all Api.Select.select_stmt ki kf)
+ (mk_selection_all Api.Select.select_stmt ki kf)
+ in
+ add_slicing_item "Slice stmt" kf_ki_lv_opt ~callback);
+
+ let get_lv lvopt text =
+ match lvopt with
+ | None ->
+ Gtk_helper.input_string
+ ~parent:main_ui#main_window ~title:"Enter an lvalue" text
+ | Some lv ->
+ (* For probably dubious reasons, the functions in Api.Select
+ require strings instead of directly a lvalue. Thus, we convert
+ our shiny lvalue to string, so that it may be parsed back... *)
+ Some (Pretty_utils.to_string Printer.pp_lval lv)
+ in
+ (let callback (kf, ki, lvopt) =
+ let do_with_txt txt =
+ try
+ let lval_str =
+ Datatype.String.Set.add txt Datatype.String.Set.empty
+ in
+ mk_slice
+ ~info:(fun fmt ->
+ Format.fprintf fmt
+ "Request for slicing lvalue %s before statement %d"
+ txt
+ ki.sid)
+ (mk_selection_cad Api.Select.select_stmt_lval
+ lval_str ~before:true ki ~eval:ki kf)
+ with e ->
+ main_ui#error "Invalid expression: %s" (Printexc.to_string e)
in
- add_slicing_item "Slice stmt" kf_ki_lv_opt ~callback);
-
- let get_lv lvopt text =
- match lvopt with
- | None ->
- Gtk_helper.input_string
- ~parent:main_ui#main_window ~title:"Enter an lvalue" text
- | Some lv ->
- (* For probably dubious reasons, the functions in Api.Select
- require strings instead of directly a lvalue. Thus, we convert
- our shiny lvalue to string, so that it may be parsed back... *)
- Some (Pretty_utils.to_string Printer.pp_lval lv)
- in
- (let callback (kf, ki, lvopt) =
- let do_with_txt txt =
- try
- let lval_str =
- Datatype.String.Set.add txt Datatype.String.Set.empty
- in
- mk_slice
- ~info:(fun fmt ->
- Format.fprintf fmt
- "Request for slicing lvalue %s before statement %d"
- txt
- ki.sid)
- (mk_selection_cad Api.Select.select_stmt_lval
- lval_str ~before:true ki ~eval:ki kf)
- with e ->
- main_ui#error "Invalid expression: %s" (Printexc.to_string e)
- in
- let txt = get_lv lvopt
- "Input a lvalue to slice on its value before the current statement."
- in
- Option.iter do_with_txt txt
- in
- add_slicing_item "Slice lval" kf_ki_lv_opt ~callback);
-
- (let callback (kf, ki, lvopt) =
- let do_with_txt txt =
- try
- let lval_str =
- Datatype.String.Set.add txt Datatype.String.Set.empty
- in
- mk_slice
- ~info:(fun fmt ->
+ let txt = get_lv lvopt
+ "Input a lvalue to slice on its value before the current statement."
+ in
+ Option.iter do_with_txt txt
+ in
+ add_slicing_item "Slice lval" kf_ki_lv_opt ~callback);
+
+ (let callback (kf, ki, lvopt) =
+ let do_with_txt txt =
+ try
+ let lval_str =
+ Datatype.String.Set.add txt Datatype.String.Set.empty
+ in
+ mk_slice
+ ~info:(fun fmt ->
Format.fprintf fmt
"Request for slicing read accesses to lvalue %s"
txt)
- (mk_selection_cad
- Api.Select.select_func_lval_rw
- ~rd:lval_str
- ~wr:Datatype.String.Set.empty
- ~eval:ki kf)
- with e ->
- main_ui#error "Invalid expression: %s" (Printexc.to_string e)
- in
- let txt = get_lv lvopt
+ (mk_selection_cad
+ Api.Select.select_func_lval_rw
+ ~rd:lval_str
+ ~wr:Datatype.String.Set.empty
+ ~eval:ki kf)
+ with e ->
+ main_ui#error "Invalid expression: %s" (Printexc.to_string e)
+ in
+ let txt = get_lv lvopt
"Input a lvalue to slice on its read accesses."
- in
- Option.iter do_with_txt txt
in
- add_slicing_item "Slice rd" kf_ki_lv_opt ~callback);
-
- (let callback (kf, ki, lvopt) =
- let do_with_txt txt =
- try
- let lval_str =
- Datatype.String.Set.add txt Datatype.String.Set.empty
- in
- mk_slice
- ~info:(fun fmt ->
+ Option.iter do_with_txt txt
+ in
+ add_slicing_item "Slice rd" kf_ki_lv_opt ~callback);
+
+ (let callback (kf, ki, lvopt) =
+ let do_with_txt txt =
+ try
+ let lval_str =
+ Datatype.String.Set.add txt Datatype.String.Set.empty
+ in
+ mk_slice
+ ~info:(fun fmt ->
Format.fprintf fmt
"Request for slicing written accesses to lvalue %s"
txt)
- (mk_selection_cad
- Api.Select.select_func_lval_rw
- ~rd:Datatype.String.Set.empty
- ~wr:lval_str
- ~eval:ki kf)
- with e ->
- main_ui#error "Invalid expression: %s" (Printexc.to_string e)
- in
- let txt = get_lv lvopt
+ (mk_selection_cad
+ Api.Select.select_func_lval_rw
+ ~rd:Datatype.String.Set.empty
+ ~wr:lval_str
+ ~eval:ki kf)
+ with e ->
+ main_ui#error "Invalid expression: %s" (Printexc.to_string e)
+ in
+ let txt = get_lv lvopt
"Input a lvalue to slice on its write accesses."
- in
- Option.iter do_with_txt txt
in
- add_slicing_item "Slice wr" kf_ki_lv_opt ~callback);
+ Option.iter do_with_txt txt
+ in
+ add_slicing_item "Slice wr" kf_ki_lv_opt ~callback);
- let callback (kf, ki, _) =
- mk_slice
- ~info:(fun fmt ->
+ let callback (kf, ki, _) =
+ mk_slice
+ ~info:(fun fmt ->
Format.fprintf fmt
"Request for slicing accessibility to statement %d"
ki.sid)
- (mk_selection_all Api.Select.select_stmt_ctrl ki kf)
- in
- add_slicing_item "Slice ctrl" kf_ki_lv_opt ~callback
+ (mk_selection_all Api.Select.select_stmt_ctrl ki kf)
in
- let some_kf_from_vi vi =
- try let kf = Globals.Functions.get vi in
+ add_slicing_item "Slice ctrl" kf_ki_lv_opt ~callback
+ in
+ let some_kf_from_vi vi =
+ try let kf = Globals.Functions.get vi in
if !Db.Value.is_called kf then Some kf else None
- with Not_found -> None in
- let some_kf_from_lv lv =
- match lv with
- | Var vi,_ -> some_kf_from_vi vi
- | _ -> None
- in
- let some_kf_ki_lv kf stmt lvopt =
- if !Db.Value.is_called kf && Db.Value.is_reachable_stmt stmt
- then Some (kf, stmt, lvopt) else None
- in
- begin (* add menu for slicing and scope plug-in *)
- match localizable with
- | Pretty_source.PLval (Some kf,(Kstmt stmt),lv)->
- add_slice_menu
- (some_kf_from_lv lv) (some_kf_ki_lv kf stmt (Some lv))
+ with Not_found -> None in
+ let some_kf_from_lv lv =
+ match lv with
+ | Var vi,_ -> some_kf_from_vi vi
+ | _ -> None
+ in
+ let some_kf_ki_lv kf stmt lvopt =
+ if !Db.Value.is_called kf && Db.Value.is_reachable_stmt stmt
+ then Some (kf, stmt, lvopt) else None
+ in
+ begin (* add menu for slicing and scope plug-in *)
+ match localizable with
+ | Pretty_source.PLval (Some kf,(Kstmt stmt),lv)->
+ add_slice_menu
+ (some_kf_from_lv lv) (some_kf_ki_lv kf stmt (Some lv))
(*
| Pretty_source.PTermLval(Some kf,_,Kstmt ki,_)
(* as for 'statement' localizable. We currently ignore the
term-lval *)
*)
- | Pretty_source.PStmt (kf, stmt) ->
+ | Pretty_source.PStmt (kf, stmt) ->
+ add_slice_menu None (some_kf_ki_lv kf stmt None)
+ | Pretty_source.PVDecl (kfopt,ki,vi) -> begin
+ add_slice_menu (some_kf_from_vi vi) None;
+ match kfopt, ki with
+ | Some kf, Kstmt stmt ->
add_slice_menu None (some_kf_ki_lv kf stmt None)
- | Pretty_source.PVDecl (kfopt,ki,vi) -> begin
- add_slice_menu (some_kf_from_vi vi) None;
- match kfopt, ki with
- | Some kf, Kstmt stmt ->
- add_slice_menu None (some_kf_ki_lv kf stmt None)
- | _ -> ()
- end
- | _ ->
- add_slice_menu None None
- end;
- ignore (slicing_factory#add_separator ());
- end
+ | _ -> ()
+ end
+ | _ ->
+ add_slice_menu None None
+ end;
+ ignore (slicing_factory#add_separator ());
+ end
let slicing_highlighter(buffer:Design.reactive_buffer) localizable ~start ~stop=
if Enabled.get () then begin
@@ -416,30 +416,30 @@ let slicing_highlighter(buffer:Design.reactive_buffer) localizable ~start ~stop=
begin
match slices with
| [] ->
- (* No slice for this kf *)
- if Api.Project.is_called kf
- then begin
- SlicingParameters.debug "Got source code@." ;
- apply_mark (Api.Mark.get_from_src_func kf)
- end
- else
- Gtk_helper.apply_tag buffer unused_code_area pb pe
+ (* No slice for this kf *)
+ if Api.Project.is_called kf
+ then begin
+ SlicingParameters.debug "Got source code@." ;
+ apply_mark (Api.Mark.get_from_src_func kf)
+ end
+ else
+ Gtk_helper.apply_tag buffer unused_code_area pb pe
| slices ->
- if Api.Project.is_called kf
- then begin
- assert (not (kf == fst (Globals.entry_point ()))) ;
- SlicingParameters.debug "Got source code" ;
- apply_mark (Api.Mark.get_from_src_func kf)
- end ;
- if SlicingParameters.debug_atleast 1 then begin
- let l = List.length slices in
- if l >=2 then
- SlicingParameters.debug "Got %d slices" (List.length slices)
- end;
- let mark_slice slice =
- let mark = mark_of_slice slice in
- apply_mark mark
- in List.iter mark_slice slices
+ if Api.Project.is_called kf
+ then begin
+ assert (not (kf == fst (Globals.entry_point ()))) ;
+ SlicingParameters.debug "Got source code" ;
+ apply_mark (Api.Mark.get_from_src_func kf)
+ end ;
+ if SlicingParameters.debug_atleast 1 then begin
+ let l = List.length slices in
+ if l >=2 then
+ SlicingParameters.debug "Got %d slices" (List.length slices)
+ end;
+ let mark_slice slice =
+ let mark = mark_of_slice slice in
+ apply_mark mark
+ in List.iter mark_slice slices
end
in
let tag_stmt kf stmt pb pe =
@@ -481,25 +481,25 @@ let pretty_setting_option fmt =
let gui_set_slicing_debug (main_ui:Design.main_window_extension_points) v =
let old = SlicingParameters.Verbose.get () in
- if v <> old then (* Otherwise set is done at every refreshing *)
- gui_apply_action main_ui SlicingParameters.Verbose.set v
- ~info:(fun fmt ->
+ if v <> old then (* Otherwise set is done at every refreshing *)
+ gui_apply_action main_ui SlicingParameters.Verbose.set v
+ ~info:(fun fmt ->
pretty_setting_option fmt "-slicing-verbose" (string_of_int v))
let gui_set_slicing_level (main_ui:Design.main_window_extension_points) v =
let old = SlicingParameters.Mode.Calls.get () in
- if v != old then (* Otherwise set is done at every refreshing *)
- gui_apply_action main_ui SlicingParameters.Mode.Calls.set v
- ~info:(fun fmt ->
+ if v != old then (* Otherwise set is done at every refreshing *)
+ gui_apply_action main_ui SlicingParameters.Mode.Calls.set v
+ ~info:(fun fmt ->
pretty_setting_option fmt "-slicing-level" (string_of_int v))
let gui_set_slicing_undef_functions (main_ui:Design.main_window_extension_points) v =
let old = SlicingParameters.Mode.SliceUndef.get () in
- if v != old then (* Otherwise set is done at every refreshing *)
- gui_apply_action main_ui SlicingParameters.Mode.SliceUndef.set v
- ~info:(fun fmt ->
+ if v != old then (* Otherwise set is done at every refreshing *)
+ gui_apply_action main_ui SlicingParameters.Mode.SliceUndef.set v
+ ~info:(fun fmt ->
pretty_setting_option fmt
- (if v then "-slice-undef-functions" else "-no-slice-undef-functions")
+ (if v then "-slice-undef-functions" else "-no-slice-undef-functions")
"")
let slicing_panel (main_ui:Design.main_window_extension_points) =
@@ -516,81 +516,81 @@ let slicing_panel (main_ui:Design.main_window_extension_points) =
in
let enabled_button =
let b = GButton.check_button
- ~label:"Enable"
- ~active:(Enabled.get ())
- ~packing:(table#attach ~left:0 ~top:0) () in
- main_ui#help_message b "%s" msg_help_enable_gui ;
- ignore (b#connect#toggled
- ~callback:(fun () ->
- Enabled.set b#active;
- do_refresh b#active));
- b
+ ~label:"Enable"
+ ~active:(Enabled.get ())
+ ~packing:(table#attach ~left:0 ~top:0) () in
+ main_ui#help_message b "%s" msg_help_enable_gui ;
+ ignore (b#connect#toggled
+ ~callback:(fun () ->
+ Enabled.set b#active;
+ do_refresh b#active));
+ b
in
let verbose_refresh = Gtk_helper.on_int ~lower:0 ~upper:3
- hbox2
- "Verbosity"
- ~sensitive:Enabled.get
- SlicingParameters.Verbose.get
- (gui_set_slicing_debug main_ui)
+ hbox2
+ "Verbosity"
+ ~sensitive:Enabled.get
+ SlicingParameters.Verbose.get
+ (gui_set_slicing_debug main_ui)
in
let hbox3 = GPack.hbox ~packing:(table#attach ~left:1 ~top:1) () in
- (* [slice_undef_button] related to -slice-undef option *)
+ (* [slice_undef_button] related to -slice-undef option *)
let slice_undef_button =
let b = GButton.check_button
- ~label:"Libraries"
- ~active:(Enabled.get ())
- ~packing:(table#attach ~left:0 ~top:1) () in
- main_ui#help_message b "%s" msg_help_libraries ;
- ignore (b#connect#toggled
- (fun () ->
- gui_set_slicing_undef_functions main_ui b#active));
- b
+ ~label:"Libraries"
+ ~active:(Enabled.get ())
+ ~packing:(table#attach ~left:0 ~top:1) () in
+ main_ui#help_message b "%s" msg_help_libraries ;
+ ignore (b#connect#toggled
+ (fun () ->
+ gui_set_slicing_undef_functions main_ui b#active));
+ b
in
let level_refresh = Gtk_helper.on_int ~lower:0 ~upper:3
- hbox3
- "Level"
- ~sensitive:Enabled.get
- SlicingParameters.Mode.Calls.get
- (gui_set_slicing_level main_ui)
+ hbox3
+ "Level"
+ ~sensitive:Enabled.get
+ SlicingParameters.Mode.Calls.get
+ (gui_set_slicing_level main_ui)
in
- let refresh () =
- let value_is_computed = Db.Value.is_computed () in
- let enabled = Enabled.get () in
- enabled_button#misc#set_sensitive value_is_computed ;
- slice_undef_button#misc#set_sensitive enabled ;
- verbose_refresh ();
- level_refresh ();
- if Enabled.get () <> enabled_button#active then (
- enabled_button#set_active (Enabled.get ());
- !update_column `Contents;
- );
- slice_undef_button#set_active (SlicingParameters.Mode.SliceUndef.get());
- in
- refresh () ;
- "Slicing",w#coerce,Some refresh
+ let refresh () =
+ let value_is_computed = Db.Value.is_computed () in
+ let enabled = Enabled.get () in
+ enabled_button#misc#set_sensitive value_is_computed ;
+ slice_undef_button#misc#set_sensitive enabled ;
+ verbose_refresh ();
+ level_refresh ();
+ if Enabled.get () <> enabled_button#active then (
+ enabled_button#set_active (Enabled.get ());
+ !update_column `Contents;
+ );
+ slice_undef_button#set_active (SlicingParameters.Mode.SliceUndef.get());
+ in
+ refresh () ;
+ "Slicing",w#coerce,Some refresh
let file_tree_decorate (file_tree:Filetree.t) =
update_column :=
file_tree#append_pixbuf_column
~title:"Slicing"
(fun globs ->
- SlicingState.may_map
- ~none:[`STOCK_ID ""]
- (fun () ->
- if List.exists
- (fun glob -> match glob with
- | GFun ({svar = vi},_ ) ->
- begin
- try
- let kf = Globals.Functions.get vi
- in (Api.Project.is_called kf)
- || ( [] != (Api.Slice.get_all kf))
- with Not_found -> false
- end
- | _ -> false)
- globs
- then [`STOCK_ID "gtk-apply"]
- else [`STOCK_ID ""]))
+ SlicingState.may_map
+ ~none:[`STOCK_ID ""]
+ (fun () ->
+ if List.exists
+ (fun glob -> match glob with
+ | GFun ({svar = vi},_ ) ->
+ begin
+ try
+ let kf = Globals.Functions.get vi
+ in (Api.Project.is_called kf)
+ || ( [] != (Api.Slice.get_all kf))
+ with Not_found -> false
+ end
+ | _ -> false)
+ globs
+ then [`STOCK_ID "gtk-apply"]
+ else [`STOCK_ID ""]))
(fun () -> Enabled.get ());
!update_column `Visibility
diff --git a/src/plugins/slicing/slicingActions.ml b/src/plugins/slicing/slicingActions.ml
index 65f7db4a109668d8872ecd8553e2510807a97d07..e0d957a04c7220889769d2bb7fd1877320cb2134 100644
--- a/src/plugins/slicing/slicingActions.ml
+++ b/src/plugins/slicing/slicingActions.ml
@@ -23,7 +23,7 @@
(** This module deals with the action management.
* It consists of the definitions of the different kinds of actions,
* and the management of the action list.
- *)
+*)
(**/**)
@@ -38,8 +38,8 @@ type n_or_d_marks = (SlicingInternals.node_or_dpds * SlicingInternals.pdg_mark)
(** {3 How the elements will be selected} *)
(** Build a description to tell that the associated nodes have to be marked
-* with the given mark, and than the same one will be propagated through
-* their dependencies. (see also {!build_node_and_dpds_selection}) *)
+ * with the given mark, and than the same one will be propagated through
+ * their dependencies. (see also {!build_node_and_dpds_selection}) *)
let build_simple_node_selection ?(nd_marks=[]) mark =
(SlicingInternals.CwNode, mark)::nd_marks
@@ -56,13 +56,13 @@ let build_ctrl_dpds_selection ?(nd_marks=[]) mark =
(SlicingInternals.CwCtrlDpds, mark)::nd_marks
(** Build a description to tell how the selected PDG nodes and their
-* dependencies will have to be marked
-* (see {!type:SlicingTypes.Internals.node_or_dpds}).
-* This description depend on the mark that has been asked for.
-* First of all, whatever the mark is, the node is selected as [spare],
-* so that it will be visible, and so will its dependencies. Then,
-* if [is_ctrl mark] propagate a m1 control mark through the control dependencies
-* and do a similar thing for [addr] and [data] *)
+ * dependencies will have to be marked
+ * (see {!type:SlicingTypes.Internals.node_or_dpds}).
+ * This description depend on the mark that has been asked for.
+ * First of all, whatever the mark is, the node is selected as [spare],
+ * so that it will be visible, and so will its dependencies. Then,
+ * if [is_ctrl mark] propagate a m1 control mark through the control dependencies
+ * and do a similar thing for [addr] and [data] *)
let build_node_and_dpds_selection ?(nd_marks=[]) mark =
let m_spare = SlicingMarks.mk_user_spare in
let nd_marks = build_simple_node_selection ~nd_marks:nd_marks m_spare in
@@ -70,24 +70,24 @@ let build_node_and_dpds_selection ?(nd_marks=[]) mark =
if SlicingMarks.is_ctrl_mark mark
then
let m_ctrl = SlicingMarks.mk_user_mark ~ctrl:true ~data:false ~addr:false in
- build_ctrl_dpds_selection ~nd_marks:nd_marks m_ctrl
+ build_ctrl_dpds_selection ~nd_marks:nd_marks m_ctrl
else nd_marks
in
let nd_marks =
if SlicingMarks.is_addr_mark mark
then
let m_addr = SlicingMarks.mk_user_mark ~ctrl:false ~data:false ~addr:true in
- build_addr_dpds_selection ~nd_marks:nd_marks m_addr
+ build_addr_dpds_selection ~nd_marks:nd_marks m_addr
else nd_marks
in
let nd_marks =
if SlicingMarks.is_data_mark mark
then
let m_data = SlicingMarks.mk_user_mark ~ctrl:false ~data:true ~addr:false in
- build_data_dpds_selection ~nd_marks:nd_marks m_data
+ build_data_dpds_selection ~nd_marks:nd_marks m_data
else nd_marks
in
- nd_marks
+ nd_marks
(** {3 Translations to a mapping between marks and program elements} *)
@@ -98,7 +98,7 @@ let translate_crit_to_select pdg ?(to_select=[]) list_crit =
let add m acc nodepart =
PdgMarks.add_node_to_select acc nodepart m
in
- List.fold_left (add m) acc nodes
+ List.fold_left (add m) acc nodes
in
let add_node_dpds dpd_mark f_dpds acc (node, _node_z_part) =
let nodes = f_dpds node in
@@ -107,11 +107,11 @@ let translate_crit_to_select pdg ?(to_select=[]) list_crit =
let acc = match nd with
| SlicingInternals.CwNode -> add_nodes mark acc nodes
| SlicingInternals.CwAddrDpds -> let f = PdgTypes.Pdg.get_x_direct_dpds PdgTypes.Dpd.Addr pdg in
- List.fold_left (add_node_dpds mark f) acc nodes
+ List.fold_left (add_node_dpds mark f) acc nodes
| SlicingInternals.CwCtrlDpds -> let f = PdgTypes.Pdg.get_x_direct_dpds PdgTypes.Dpd.Ctrl pdg in
- List.fold_left (add_node_dpds mark f) acc nodes
+ List.fold_left (add_node_dpds mark f) acc nodes
| SlicingInternals.CwDataDpds -> let f = PdgTypes.Pdg.get_x_direct_dpds PdgTypes.Dpd.Data pdg in
- List.fold_left (add_node_dpds mark f) acc nodes
+ List.fold_left (add_node_dpds mark f) acc nodes
in acc
in List.fold_left add_pdg_mark acc nd_mark
in List.fold_left translate to_select list_crit
@@ -121,7 +121,7 @@ let translate_crit_to_select pdg ?(to_select=[]) list_crit =
(** build an action to apply the criteria to the persistent selection of the
-* function. It means that it will be applied to all slices. *)
+ * function. It means that it will be applied to all slices. *)
let mk_fct_crit fi crit =
SlicingInternals.CrFct { SlicingInternals.cf_fct = SlicingInternals.FctSrc fi ; SlicingInternals.cf_info = crit }
@@ -147,7 +147,7 @@ let mk_crit_missing_inputs ff call (input_marks, more_inputs) =
let mk_crit_missing_outputs ff call (output_marks, more_outputs) =
mk_ff_crit ff (SlicingInternals.CcMissingOutputs (call, output_marks, more_outputs))
let mk_crit_examines_calls ff call_out_marks =
- mk_ff_crit ff (SlicingInternals.CcExamineCalls call_out_marks)
+ mk_ff_crit ff (SlicingInternals.CcExamineCalls call_out_marks)
let mk_appli_select_calls fi = SlicingInternals.CrAppli (SlicingInternals.CaCall fi)
@@ -155,18 +155,18 @@ let mk_appli_select_calls fi = SlicingInternals.CrAppli (SlicingInternals.CaCall
let mk_crit_mark_calls fi_caller to_call mark =
let select = try
- let caller = SlicingMacros.get_fi_kf fi_caller in
- let pdg_caller = !Db.Pdg.get caller in
- let call_stmts = !Db.Pdg.find_call_stmts ~caller to_call in
- let stmt_mark stmt =
- let stmt_ctrl_node = !Db.Pdg.find_call_ctrl_node pdg_caller stmt in
+ let caller = SlicingMacros.get_fi_kf fi_caller in
+ let pdg_caller = !Db.Pdg.get caller in
+ let call_stmts = !Db.Pdg.find_call_stmts ~caller to_call in
+ let stmt_mark stmt =
+ let stmt_ctrl_node = !Db.Pdg.find_call_ctrl_node pdg_caller stmt in
(PdgMarks.mk_select_node stmt_ctrl_node, mark)
- in
- let select = List.map stmt_mark call_stmts in
+ in
+ let select = List.map stmt_mark call_stmts in
SlicingInternals.CuSelect select
- with PdgTypes.Pdg.Top -> SlicingInternals.CuTop mark
+ with PdgTypes.Pdg.Top -> SlicingInternals.CuTop mark
in
- mk_fct_user_crit fi_caller select
+ mk_fct_user_crit fi_caller select
let mk_crit_add_output_marks ff select =
(*
@@ -193,21 +193,21 @@ let mk_crit_add_all_outputs_mark ff mark =
let print_nd_and_mark f (nd, m) =
let str = match nd with
- | SlicingInternals.CwNode -> ""
- | SlicingInternals.CwAddrDpds -> "addr->"
- | SlicingInternals.CwDataDpds -> "data->"
- | SlicingInternals.CwCtrlDpds -> "ctrl->"
+ | SlicingInternals.CwNode -> ""
+ | SlicingInternals.CwAddrDpds -> "addr->"
+ | SlicingInternals.CwDataDpds -> "data->"
+ | SlicingInternals.CwCtrlDpds -> "ctrl->"
in Format.fprintf f "%s%a" str SlicingMarks.pretty_mark m
let rec print_nd_and_mark_list fmt ndm_list =
match ndm_list with
| [] -> ()
| x :: ndm_list ->
- print_nd_and_mark fmt x; print_nd_and_mark_list fmt ndm_list
+ print_nd_and_mark fmt x; print_nd_and_mark_list fmt ndm_list
let print_nodes fmt nodes =
let print n = Format.fprintf fmt "%a " (!Db.Pdg.pretty_node true) n in
- List.iter print nodes
+ List.iter print nodes
let print_node_mark fmt n z m =
Format.fprintf fmt "(%a ,%a)"
@@ -217,10 +217,10 @@ let print_sel_marks_list fmt to_select =
let print_sel (s, m) = match s with
| PdgMarks.SelNode (n, z) -> print_node_mark fmt n z m
| PdgMarks.SelIn l ->
- Format.fprintf fmt "(UndefIn %a:%a)"
- Locations.Zone.pretty l SlicingMarks.pretty_mark m
+ Format.fprintf fmt "(UndefIn %a:%a)"
+ Locations.Zone.pretty l SlicingMarks.pretty_mark m
in match to_select with [] -> Format.fprintf fmt "<empty>"
- | _ -> List.iter print_sel to_select
+ | _ -> List.iter print_sel to_select
let _print_ndm fmt (nodes, ndm_list) =
Format.fprintf fmt "(%a,%a)" print_nodes nodes
@@ -228,15 +228,15 @@ let _print_ndm fmt (nodes, ndm_list) =
let print_f_crit fmt f_crit =
match f_crit with
- | SlicingInternals.CuTop m -> Format.fprintf fmt "top(%a)" SlicingMarks.pretty_mark m
- | SlicingInternals.CuSelect to_select -> print_sel_marks_list fmt to_select
+ | SlicingInternals.CuTop m -> Format.fprintf fmt "top(%a)" SlicingMarks.pretty_mark m
+ | SlicingInternals.CuSelect to_select -> print_sel_marks_list fmt to_select
let print_crit fmt crit =
match crit with
| SlicingInternals.CrFct fct_crit ->
- let fct = fct_crit.SlicingInternals.cf_fct in
- let name = SlicingMacros.f_name fct in
- Format.fprintf fmt "[%s = " name;
+ let fct = fct_crit.SlicingInternals.cf_fct in
+ let name = SlicingMacros.f_name fct in
+ Format.fprintf fmt "[%s = " name;
let _ = match fct_crit.SlicingInternals.cf_info with
| SlicingInternals.CcUserMark info -> print_f_crit fmt info
| SlicingInternals.CcMissingInputs (call, _input_marks, more_inputs)
@@ -251,19 +251,19 @@ let print_crit fmt crit =
-> Format.fprintf fmt "choose_call for call %d" call.Cil_types.sid
| SlicingInternals.CcChangeCall (call,f)
-> let fname = match f with
- | SlicingInternals.CallSlice ff -> SlicingMacros.ff_name ff
- | SlicingInternals.CallSrc (Some fi) -> ("(src:"^( SlicingMacros.fi_name fi)^")")
- | SlicingInternals.CallSrc None -> "(src)"
+ | SlicingInternals.CallSlice ff -> SlicingMacros.ff_name ff
+ | SlicingInternals.CallSrc (Some fi) -> ("(src:"^( SlicingMacros.fi_name fi)^")")
+ | SlicingInternals.CallSrc None -> "(src)"
in Format.fprintf fmt "change_call for call %d -> %s"
- call.Cil_types.sid fname
+ call.Cil_types.sid fname
| SlicingInternals.CcPropagate nl ->
- Format.fprintf fmt "propagate %a"
- print_sel_marks_list nl
+ Format.fprintf fmt "propagate %a"
+ print_sel_marks_list nl
| SlicingInternals.CcExamineCalls _ -> Format.fprintf fmt "examine_calls"
in Format.fprintf fmt "]"
| SlicingInternals.CrAppli (SlicingInternals.CaCall fi) ->
- let name = SlicingMacros.fi_name fi in
- Format.fprintf fmt "[Appli : calls to %s]" name
+ let name = SlicingMacros.fi_name fi in
+ Format.fprintf fmt "[Appli : calls to %s]" name
| _ ->
SlicingParameters.not_yet_implemented "Printing this slicing criterion "
diff --git a/src/plugins/slicing/slicingCmds.ml b/src/plugins/slicing/slicingCmds.ml
index baf6611fd150ab641bc6d75cd3d76324cd700fdd..79b59cc0fd5ac7c7124e56e0f1517303def29d20 100644
--- a/src/plugins/slicing/slicingCmds.ml
+++ b/src/plugins/slicing/slicingCmds.ml
@@ -35,8 +35,8 @@ let apply_all_actions () =
SlicingParameters.debug ~level:2 "pending requests:@\n %t@\n"
SlicingProject.print_proj_worklist;
let r = SlicingProject.apply_all_actions () in
- SlicingParameters.feedback ~level:2 "done (applying all slicing requests).";
- r
+ SlicingParameters.feedback ~level:2 "done (applying all slicing requests).";
+ r
let apply_next_action () =
SlicingParameters.debug ~level:1 "[Api.apply_next_internal]";
@@ -47,10 +47,10 @@ let apply_all ~propagate_to_callers =
assert (not propagate_to_callers) ;
try
while (true)
- do
- (* Format.printf "@\napply_next_internal@."; *)
- apply_next_action ()
- done
+ do
+ (* Format.printf "@\napply_next_internal@."; *)
+ apply_next_action ()
+ done
with Not_found -> ()
let get_select_kf (fvar, _select) = Globals.Functions.get fvar
@@ -59,8 +59,8 @@ let get_select_kf (fvar, _select) = Globals.Functions.get fvar
module Kinstr: sig
val iter_from_func : (stmt -> unit) -> kernel_function -> unit
val is_rw_zone : (Locations.Zone.t option * Locations.Zone.t option) -> stmt -> Locations.Zone.t option * Locations.Zone.t option
- end
- =
+end
+=
struct
(** Iter on statements of a kernel function *)
let iter_from_func f kf =
@@ -97,30 +97,30 @@ struct
in read_zone,write_zone
in
match stmt.skind with
- | Switch (exp,_,_,_)
- | If (exp,_,_,_) ->
- (* returns [Zone.t read] by condition [exp], [Zone.bottom] *)
- !Db.From.find_deps_no_transitivity stmt exp, Locations.Zone.bottom
- | Instr (Set (lv,exp,_)) ->
- (* returns [Zone.t read] by [exp, lv], [Zone.t written] by [lv] *)
- let read_zone = !Db.From.find_deps_no_transitivity stmt exp in
- lval_process read_zone stmt lv
- | Instr (Local_init (v, AssignInit i, _)) ->
- let rec collect zone i =
- match i with
- | SingleInit e ->
- Locations.Zone.join zone (!Db.From.find_deps_no_transitivity stmt e)
- | CompoundInit (_,l) ->
- List.fold_left
- (fun acc (_,i) -> collect acc i) zone l
- in
- let read_zone = collect Locations.Zone.bottom i in
- lval_process read_zone stmt (Cil.var v)
- | Instr (Call (lvaloption,funcexp,argl,l)) ->
- call_process lvaloption funcexp argl l
- | Instr (Local_init(v, ConsInit(f, args, k),l)) ->
- Cil.treat_constructor_as_func call_process v f args k l
- | _ -> Locations.Zone.bottom, Locations.Zone.bottom
+ | Switch (exp,_,_,_)
+ | If (exp,_,_,_) ->
+ (* returns [Zone.t read] by condition [exp], [Zone.bottom] *)
+ !Db.From.find_deps_no_transitivity stmt exp, Locations.Zone.bottom
+ | Instr (Set (lv,exp,_)) ->
+ (* returns [Zone.t read] by [exp, lv], [Zone.t written] by [lv] *)
+ let read_zone = !Db.From.find_deps_no_transitivity stmt exp in
+ lval_process read_zone stmt lv
+ | Instr (Local_init (v, AssignInit i, _)) ->
+ let rec collect zone i =
+ match i with
+ | SingleInit e ->
+ Locations.Zone.join zone (!Db.From.find_deps_no_transitivity stmt e)
+ | CompoundInit (_,l) ->
+ List.fold_left
+ (fun acc (_,i) -> collect acc i) zone l
+ in
+ let read_zone = collect Locations.Zone.bottom i in
+ lval_process read_zone stmt (Cil.var v)
+ | Instr (Call (lvaloption,funcexp,argl,l)) ->
+ call_process lvaloption funcexp argl l
+ | Instr (Local_init(v, ConsInit(f, args, k),l)) ->
+ Cil.treat_constructor_as_func call_process v f args k l
+ | _ -> Locations.Zone.bottom, Locations.Zone.bottom
(** Look at intersection of [rd_zone_opt]/[wr_zone_opt] with the
directly read/written [Zone.t] by the statement.
@@ -130,12 +130,12 @@ struct
let rd_zone, wr_zone = get_rw_zone stmt in
let inter_zone zone_opt zone =
match zone_opt with
- | None -> zone_opt
- | Some zone_requested ->
- if Locations.Zone.intersects zone_requested zone
- then let inter = Locations.Zone.narrow zone_requested zone
- in Some inter
- else None
+ | None -> zone_opt
+ | Some zone_requested ->
+ if Locations.Zone.intersects zone_requested zone
+ then let inter = Locations.Zone.narrow zone_requested zone
+ in Some inter
+ else None
in inter_zone rd_zone_opt rd_zone, inter_zone wr_zone_opt wr_zone
end
@@ -162,7 +162,7 @@ let select_pdg_nodes set mark nodes kf =
Add a selection of the statement. *)
let select_stmt set ~spare stmt kf =
let stmt_mark = SlicingMarks.mk_user_mark
- ~data:(not spare) ~addr:(not spare) ~ctrl:(not spare) in
+ ~data:(not spare) ~addr:(not spare) ~ctrl:(not spare) in
let selection = SlicingSelect.select_stmt_computation kf stmt stmt_mark
in add_to_selection set selection
@@ -177,35 +177,35 @@ let select_entry_point_and_some_inputs_outputs set ~mark kf ~return ~outputs ~in
let set = let selection = SlicingSelect.select_entry_point kf mark in
add_to_selection set selection
in
- let set =
+ let set =
if (Locations.Zone.equal Locations.Zone.bottom inputs)
then set
else let selection = SlicingSelect.select_zone_at_entry kf inputs mark in
add_to_selection set selection
in if ((Locations.Zone.equal Locations.Zone.bottom outputs) && not return) ||
- (try
- let ki = Kernel_function.find_return kf
- in if Db.Value.is_reachable_stmt ki then
- false
- else
- begin
- SlicingParameters.feedback
- "@[Nothing to select for unreachable return stmt of %a@]"
- Kernel_function.pretty kf;
- true
- end
- with Kernel_function.No_Statement -> false)
- then set
- else
- let set =
- if (Locations.Zone.equal Locations.Zone.bottom outputs)
- then set
- else let selection = SlicingSelect.select_modified_output_zone kf outputs mark in
- add_to_selection set selection
- in if return
- then let selection = SlicingSelect.select_return kf mark in
- add_to_selection set selection
- else set
+ (try
+ let ki = Kernel_function.find_return kf
+ in if Db.Value.is_reachable_stmt ki then
+ false
+ else
+ begin
+ SlicingParameters.feedback
+ "@[Nothing to select for unreachable return stmt of %a@]"
+ Kernel_function.pretty kf;
+ true
+ end
+ with Kernel_function.No_Statement -> false)
+ then set
+ else
+ let set =
+ if (Locations.Zone.equal Locations.Zone.bottom outputs)
+ then set
+ else let selection = SlicingSelect.select_modified_output_zone kf outputs mark in
+ add_to_selection set selection
+ in if return
+ then let selection = SlicingSelect.select_return kf mark in
+ add_to_selection set selection
+ else set
(* apply [select ~spare] on each callsite of [kf] and add the returned selection
to [set]. *)
@@ -231,26 +231,26 @@ let select_func_calls_into set ~spare kf =
add_to_select set ~spare (SlicingSelect.select_entry_point kf)
else
let select_min_call set ~spare ki kf =
- add_to_select set ~spare (SlicingSelect.select_minimal_call kf ki)
+ add_to_select set ~spare (SlicingSelect.select_minimal_call kf ki)
in
generic_select_func_calls select_min_call set ~spare kf
(** Registered as a slicing selection function:
Add a selection of calls to a [kf]. *)
-let select_func_calls_to set ~spare kf =
+let select_func_calls_to set ~spare kf =
let kf_entry, _library = Globals.entry_point () in
if Kernel_function.equal kf_entry kf then
begin
let mark =
- let nspare = not spare in
- SlicingMarks.mk_user_mark ~data:nspare ~addr:nspare ~ctrl:nspare
+ let nspare = not spare in
+ SlicingMarks.mk_user_mark ~data:nspare ~addr:nspare ~ctrl:nspare
in
assert (Db.Value.is_computed ());
let outputs = !Db.Outputs.get_external kf in
select_entry_point_and_some_inputs_outputs set ~mark kf
- ~return:true
- ~outputs
- ~inputs:Locations.Zone.bottom
+ ~return:true
+ ~outputs
+ ~inputs:Locations.Zone.bottom
end
else
generic_select_func_calls select_stmt set ~spare kf
@@ -337,13 +337,13 @@ let select_stmt_lval set mark lval_str ~before ki ~eval kf =
relatively to the whole scope of the function [kf].
- The interpretation of the address of the lvalues is
done just before the execution of the statement [~eval].
- Find read/write accesses from the whole project if [ki_opt]=None.
- Otherwise, restrict the research among the direct effect of [ki_opt] statement.
- i.e. when [ki_opt] is a call, the selection doesn't look at the assigns clause
- of a call. *)
+ Find read/write accesses from the whole project if [ki_opt]=None.
+ Otherwise, restrict the research among the direct effect of [ki_opt] statement.
+ i.e. when [ki_opt] is a call, the selection doesn't look at the assigns clause
+ of a call. *)
let select_lval_rw set mark ~rd ~wr ~eval kf ki_opt=
assert (Db.Value.is_computed ());
- let zone_option ~for_writing lval_str =
+ let zone_option ~for_writing lval_str =
if Datatype.String.Set.is_empty lval_str
then None
else
@@ -360,65 +360,65 @@ let select_lval_rw set mark ~rd ~wr ~eval kf ki_opt=
Locations.Zone.join zone acc)
lval_str Locations.Zone.bottom
in SlicingParameters.debug ~level:3
- "select_lval_rw %a zone=%a"
- Kernel_function.pretty kf
- Locations.Zone.pretty zone;
- Some zone
- in
- let zone_rd_opt = zone_option ~for_writing:false rd in
- let zone_wr_opt = zone_option ~for_writing:true wr in
- match zone_rd_opt, zone_wr_opt with
- | None, None -> set
- | (_, _) as zone_option_rw ->
- let ac = ref set in
- let select_rw_from_stmt kf ki =
- let rd_zone_opt, wr_zone_opt = Kinstr.is_rw_zone zone_option_rw ki in
- let select_zone ~before zone_opt =
- match zone_opt with
- | None -> !ac
- | Some zone ->
- SlicingParameters.debug ~level:3
- "select_lval_rw sid=%d before=%b zone=%a"
- ki.sid before Locations.Zone.pretty zone;
- select_stmt_zone !ac mark zone ~before ki kf ;
- in
- ac := select_zone ~before:true rd_zone_opt ;
- ac := select_zone ~before:false wr_zone_opt
- in (match ki_opt with
- | Some ki -> select_rw_from_stmt kf ki
- | None ->
- Globals.Functions.iter
- (fun kf ->
- if !Db.Value.is_called kf then
- if not (!Db.Value.use_spec_instead_of_definition kf)
- then (* Called function with source code: just looks at its stmt *)
- Kinstr.iter_from_func (select_rw_from_stmt kf) kf
- else begin (* Called function without source code: looks at its effect *)
- let select_inter_zone fsel zone_opt zone =
- match zone_opt with
- | None -> ()
- | Some zone_requested ->
- (* Format.printf "@\nselect_lval_rw zone_req=%a zone=%a@."
- Locations.Zone.pretty zone_requested
- Locations.Zone.pretty zone; *)
- if Locations.Zone.intersects zone_requested zone
- then let inter = Locations.Zone.narrow zone_requested zone
- in fsel inter
- else () in
- let select_wr outputs =
- ac := select_entry_point_and_some_inputs_outputs !ac ~mark kf
- ~return:false ~outputs ~inputs:Locations.Zone.bottom
- and select_rd inputs =
- ac := select_entry_point_and_some_inputs_outputs !ac ~mark kf
- ~return:false ~inputs ~outputs:Locations.Zone.bottom
-
- in
- assert (!Db.Value.is_called kf) ; (* otherwise [!Db.Outputs.get_external kf] gives weird results *)
- select_inter_zone select_wr zone_wr_opt (!Db.Outputs.get_external kf) ;
- select_inter_zone select_rd zone_rd_opt (!Db.Inputs.get_external kf)
- end
- ));
- !ac
+ "select_lval_rw %a zone=%a"
+ Kernel_function.pretty kf
+ Locations.Zone.pretty zone;
+ Some zone
+ in
+ let zone_rd_opt = zone_option ~for_writing:false rd in
+ let zone_wr_opt = zone_option ~for_writing:true wr in
+ match zone_rd_opt, zone_wr_opt with
+ | None, None -> set
+ | (_, _) as zone_option_rw ->
+ let ac = ref set in
+ let select_rw_from_stmt kf ki =
+ let rd_zone_opt, wr_zone_opt = Kinstr.is_rw_zone zone_option_rw ki in
+ let select_zone ~before zone_opt =
+ match zone_opt with
+ | None -> !ac
+ | Some zone ->
+ SlicingParameters.debug ~level:3
+ "select_lval_rw sid=%d before=%b zone=%a"
+ ki.sid before Locations.Zone.pretty zone;
+ select_stmt_zone !ac mark zone ~before ki kf ;
+ in
+ ac := select_zone ~before:true rd_zone_opt ;
+ ac := select_zone ~before:false wr_zone_opt
+ in (match ki_opt with
+ | Some ki -> select_rw_from_stmt kf ki
+ | None ->
+ Globals.Functions.iter
+ (fun kf ->
+ if !Db.Value.is_called kf then
+ if not (!Db.Value.use_spec_instead_of_definition kf)
+ then (* Called function with source code: just looks at its stmt *)
+ Kinstr.iter_from_func (select_rw_from_stmt kf) kf
+ else begin (* Called function without source code: looks at its effect *)
+ let select_inter_zone fsel zone_opt zone =
+ match zone_opt with
+ | None -> ()
+ | Some zone_requested ->
+ (* Format.printf "@\nselect_lval_rw zone_req=%a zone=%a@."
+ Locations.Zone.pretty zone_requested
+ Locations.Zone.pretty zone; *)
+ if Locations.Zone.intersects zone_requested zone
+ then let inter = Locations.Zone.narrow zone_requested zone
+ in fsel inter
+ else () in
+ let select_wr outputs =
+ ac := select_entry_point_and_some_inputs_outputs !ac ~mark kf
+ ~return:false ~outputs ~inputs:Locations.Zone.bottom
+ and select_rd inputs =
+ ac := select_entry_point_and_some_inputs_outputs !ac ~mark kf
+ ~return:false ~inputs ~outputs:Locations.Zone.bottom
+
+ in
+ assert (!Db.Value.is_called kf) ; (* otherwise [!Db.Outputs.get_external kf] gives weird results *)
+ select_inter_zone select_wr zone_wr_opt (!Db.Outputs.get_external kf) ;
+ select_inter_zone select_rd zone_rd_opt (!Db.Inputs.get_external kf)
+ end
+ ));
+ !ac
(** Registered as a slicing selection function:
Add a selection of rw accesses to lvalues relative to a statement.
@@ -437,7 +437,7 @@ let select_stmt_lval_rw set mark ~rd ~wr ki ~eval kf =
(** Add a selection of the declaration of [vi]. *)
let select_decl_var set mark vi kf =
let selection = SlicingSelect.select_decl_var kf vi mark in
- add_to_selection set selection
+ add_to_selection set selection
let select_ZoneAnnot_pragmas set ~spare pragmas kf =
let set =
@@ -461,27 +461,27 @@ let select_ZoneAnnot_zones_decl_vars set mark (zones,decl_vars) kf =
in
let set =
Cil_datatype.Logic_label.Set.fold
- (fun l acc ->
- let selection = SlicingSelect.select_label kf l mark
- in add_to_selection acc selection)
+ (fun l acc ->
+ let selection = SlicingSelect.select_label kf l mark
+ in add_to_selection acc selection)
decl_vars.Db.Properties.Interp.To_zone.lbl
set
in
- List.fold_right
+ List.fold_right
(fun z acc ->
- (* selection related to the parsing/compilation of the annotation *)
- select_stmt_zone acc mark
- z.Db.Properties.Interp.To_zone.zone
- ~before:z.Db.Properties.Interp.To_zone.before
- z.Db.Properties.Interp.To_zone.ki
- kf)
+ (* selection related to the parsing/compilation of the annotation *)
+ select_stmt_zone acc mark
+ z.Db.Properties.Interp.To_zone.zone
+ ~before:z.Db.Properties.Interp.To_zone.before
+ z.Db.Properties.Interp.To_zone.ki
+ kf)
zones set
let get_or_raise (info_data_opt, info_decl) = match info_data_opt with
| None ->
- (* TODO: maybe we can know how to use [info_decl] ? *)
- SlicingParameters.not_yet_implemented
- "%s" !Logic_interp.To_zone.not_yet_implemented
+ (* TODO: maybe we can know how to use [info_decl] ? *)
+ SlicingParameters.not_yet_implemented
+ "%s" !Logic_interp.To_zone.not_yet_implemented
| Some info_data -> info_data, info_decl
(** Registered as a slicing selection function:
@@ -498,10 +498,10 @@ let select_stmt_pred set mark pred ki kf =
Add selection of the annotations related to a statement.
Note: add also a transparent selection on the whole statement. *)
let select_stmt_term set mark term ki kf =
- let zones_decl_vars =
+ let zones_decl_vars =
!Db.Properties.Interp.To_zone.from_term term
(!Db.Properties.Interp.To_zone.mk_ctx_stmt_annot kf ki)
- in
+ in
select_ZoneAnnot_zones_decl_vars set mark (get_or_raise zones_decl_vars) kf
(** Registered as a slicing selection function:
@@ -530,15 +530,15 @@ let select_stmt_annots set mark ~spare ~threat ~user_assert ~slicing_pragma ~lo
Add a selection of the annotations related to a function. *)
let select_func_annots set mark ~spare ~threat ~user_assert ~slicing_pragma ~loop_inv ~loop_var kf =
try
- let zones_decl_vars,pragmas =
- !Db.Properties.Interp.To_zone.from_func_annots Kinstr.iter_from_func
- (Some
- (!Db.Properties.Interp.To_zone.code_annot_filter
- ~threat ~user_assert ~slicing_pragma ~loop_inv
- ~loop_var ~others:false))
- kf
- in let set = select_ZoneAnnot_pragmas set ~spare pragmas kf
- in select_ZoneAnnot_zones_decl_vars set mark (get_or_raise zones_decl_vars) kf
+ let zones_decl_vars,pragmas =
+ !Db.Properties.Interp.To_zone.from_func_annots Kinstr.iter_from_func
+ (Some
+ (!Db.Properties.Interp.To_zone.code_annot_filter
+ ~threat ~user_assert ~slicing_pragma ~loop_inv
+ ~loop_var ~others:false))
+ kf
+ in let set = select_ZoneAnnot_pragmas set ~spare pragmas kf
+ in select_ZoneAnnot_zones_decl_vars set mark (get_or_raise zones_decl_vars) kf
with Kernel_function.No_Definition ->
SlicingParameters.warning ~wkey:SlicingParameters.wkey_cmdline
"No definition for function '%a'. \
@@ -569,13 +569,13 @@ let select_func_lval set mark lval_str kf =
(** Registered as a slicing selection function:
Add a selection of data relative to read/write accesses.
- Interpret the [~rd] lvalues and the [~wr] lvalues from [~eval]
+ Interpret the [~rd] lvalues and the [~wr] lvalues from [~eval]
statements of [kf]:
- Variables of [lval_str] string are bounded
relatively to the whole scope of the function [kf].
- The interpretation of the address of the lvalues is
done just before the execution of the statement [~eval].
- Find read/write accesses from the whole project if [ki_opt]=None. *)
+ Find read/write accesses from the whole project if [ki_opt]=None. *)
let select_func_lval_rw set mark ~rd ~wr ~eval kf =
if Datatype.String.Set.is_empty rd && Datatype.String.Set.is_empty wr
then set
@@ -599,7 +599,7 @@ let add_selection set =
let slices = SlicingProject.get_slices kf
in if slices = [] then [SlicingProject.create_slice kf] else slices
in List.iter make_request slices ;
- r
+ r
in ignore (SlicingSelect.Selections.fold_selects_internal add_selection None set)
(** Registered as a slicing request function:
@@ -628,73 +628,73 @@ let add_persistent_cmdline () =
SlicingParameters.feedback ~level:1
"interpreting slicing requests from the command line...";
begin try
- let selection = ref Cil_datatype.Varinfo.Map.empty in
- let top_mark = SlicingMarks.mk_user_mark ~addr:true ~ctrl:true ~data:true in
+ let selection = ref Cil_datatype.Varinfo.Map.empty in
+ let top_mark = SlicingMarks.mk_user_mark ~addr:true ~ctrl:true ~data:true in
Globals.Functions.iter
(fun kf ->
let add_selection opt select =
if Kernel_function.Set.mem kf (opt ()) then
selection := select !selection ~spare:false kf
in
- add_selection
- SlicingParameters.Select.Return.get
- select_func_return;
- add_selection
- SlicingParameters.Select.Calls.get
- select_func_calls_to;
- add_selection
- SlicingParameters.Select.Pragma.get
- (fun s -> select_func_annots s top_mark
- ~threat:false ~user_assert:false ~slicing_pragma:true
- ~loop_inv:false ~loop_var:false);
- add_selection
- SlicingParameters.Select.Threat.get
- (fun s -> select_func_annots s top_mark
- ~threat:true ~user_assert:false ~slicing_pragma:false
- ~loop_inv:false ~loop_var:false);
- add_selection
- SlicingParameters.Select.Assert.get
- (fun s -> select_func_annots s top_mark
- ~threat:false ~user_assert:true ~slicing_pragma:false
- ~loop_inv:false ~loop_var:false);
- add_selection
- SlicingParameters.Select.LoopInv.get
- (fun s -> select_func_annots s top_mark
- ~threat:false ~user_assert:false ~slicing_pragma:false
- ~loop_inv:true ~loop_var:false);
- add_selection
- SlicingParameters.Select.LoopVar.get
- (fun s -> select_func_annots s top_mark
- ~threat:false ~user_assert:false ~slicing_pragma:false
- ~loop_inv:false ~loop_var:true);
+ add_selection
+ SlicingParameters.Select.Return.get
+ select_func_return;
+ add_selection
+ SlicingParameters.Select.Calls.get
+ select_func_calls_to;
+ add_selection
+ SlicingParameters.Select.Pragma.get
+ (fun s -> select_func_annots s top_mark
+ ~threat:false ~user_assert:false ~slicing_pragma:true
+ ~loop_inv:false ~loop_var:false);
+ add_selection
+ SlicingParameters.Select.Threat.get
+ (fun s -> select_func_annots s top_mark
+ ~threat:true ~user_assert:false ~slicing_pragma:false
+ ~loop_inv:false ~loop_var:false);
+ add_selection
+ SlicingParameters.Select.Assert.get
+ (fun s -> select_func_annots s top_mark
+ ~threat:false ~user_assert:true ~slicing_pragma:false
+ ~loop_inv:false ~loop_var:false);
+ add_selection
+ SlicingParameters.Select.LoopInv.get
+ (fun s -> select_func_annots s top_mark
+ ~threat:false ~user_assert:false ~slicing_pragma:false
+ ~loop_inv:true ~loop_var:false);
+ add_selection
+ SlicingParameters.Select.LoopVar.get
+ (fun s -> select_func_annots s top_mark
+ ~threat:false ~user_assert:false ~slicing_pragma:false
+ ~loop_inv:false ~loop_var:true);
);
if not (Datatype.String.Set.is_empty
(SlicingParameters.Select.Value.get ()))
- ||
- not (Datatype.String.Set.is_empty
- (SlicingParameters.Select.RdAccess.get ()))
- ||
- not (Datatype.String.Set.is_empty
- (SlicingParameters.Select.WrAccess.get ()))
+ ||
+ not (Datatype.String.Set.is_empty
+ (SlicingParameters.Select.RdAccess.get ()))
+ ||
+ not (Datatype.String.Set.is_empty
+ (SlicingParameters.Select.WrAccess.get ()))
then begin
(* fprintf fmt "@\n[-slice-value] Select %s at end of the entry point %a@."
lval_str Db.pretty_name kf; *)
let kf = fst (Globals.entry_point ()) in
let ki_scope_eval = Kernel_function.find_first_stmt kf in
- selection := select_func_lval !selection top_mark
+ selection := select_func_lval !selection top_mark
(SlicingParameters.Select.Value.get ()) kf;
- selection := select_func_lval_rw !selection top_mark
+ selection := select_func_lval_rw !selection top_mark
~rd:(SlicingParameters.Select.RdAccess.get ())
~wr:(SlicingParameters.Select.WrAccess.get ())
~eval:ki_scope_eval kf ;
- SlicingParameters.Select.Value.clear () ;
- SlicingParameters.Select.RdAccess.clear () ;
- SlicingParameters.Select.WrAccess.clear () ;
+ SlicingParameters.Select.Value.clear () ;
+ SlicingParameters.Select.RdAccess.clear () ;
+ SlicingParameters.Select.WrAccess.clear () ;
end;
add_persistent_selection !selection;
- with Logic_interp.Error(_loc,msg) ->
- SlicingParameters.warning ~wkey:SlicingParameters.wkey_cmdline
- "%s. Slicing requests from the command line are ignored." msg
+ with Logic_interp.Error(_loc,msg) ->
+ SlicingParameters.warning ~wkey:SlicingParameters.wkey_cmdline
+ "%s. Slicing requests from the command line are ignored." msg
end;
SlicingParameters.feedback ~level:2
"done (interpreting slicing requests from the command line)."
diff --git a/src/plugins/slicing/slicingInternals.ml b/src/plugins/slicing/slicingInternals.ml
index 9560cb8fa714de00cf901193035484ca159700fe..a31533ab3da5d65f348c4ce8b408bc7a0fc2c03d 100644
--- a/src/plugins/slicing/slicingInternals.ml
+++ b/src/plugins/slicing/slicingInternals.ml
@@ -30,15 +30,15 @@ open Cil_datatype
(** {3 About options} *)
(** associate a level to each function in order to control how it will be
-* specialized. This is only a hint used when the tool has to make a choice,
-* but it doesn't forbid to the user to do whatever he wants
-* (like building slices for a [DontSlice] function). *)
+ * specialized. This is only a hint used when the tool has to make a choice,
+ * but it doesn't forbid to the user to do whatever he wants
+ * (like building slices for a [DontSlice] function). *)
type level_option =
| DontSlice (** don't build slice for the function :
ie. always call the source function. *)
| DontSliceButComputeMarks
- (** don't slice the called functions,
- * but compute the marks for them *)
+ (** don't slice the called functions,
+ * but compute the marks for them *)
| MinNbSlice (** try to use existing slices, create at most one *)
| MaxNbSlice (** most precise slices
(but merge slices with the same visibility,
@@ -48,7 +48,7 @@ type level_option =
(** Kinds of elementary marks. *)
type mark = Cav of PdgTypes.Dpd.t
- | Spare
+ | Spare
let compare_mark m1 m2 =
if m1 == m2 then 0
@@ -63,7 +63,7 @@ let compare_mark m1 m2 =
type pdg_mark = {m1 : mark ; m2 : mark }
let pdg_mark_packed_descr = Structural_descr.p_abstract
- (* Ok: Dpd.t is in fact int *)
+(* Ok: Dpd.t is in fact int *)
let compare_pdg_mark p1 p2 =
if p1 == p2 then 0
@@ -72,22 +72,22 @@ let compare_pdg_mark p1 p2 =
if r = 0 then compare_mark p1.m2 p2.m2 else r
(** Type for all the informations related to any function,
-* even if we don't have its definition. *)
+ * even if we don't have its definition. *)
type fct_info = {
fi_kf : Cil_types.kernel_function;
fi_def : Cil_types.fundec option;
mutable fi_top : pdg_mark option;
- (** indicates if the function is marked top (=> src visible) *)
+ (** indicates if the function is marked top (=> src visible) *)
mutable fi_level_option : level_option;
- (** level of specialisation for this function *)
+ (** level of specialisation for this function *)
mutable fi_init_marks : ff_marks option;
- (** the marks that must be in every slices of that function *)
+ (** the marks that must be in every slices of that function *)
mutable fi_slices : fct_slice list ;
- (** the list of the slices already computed for this function. *)
+ (** the list of the slices already computed for this function. *)
mutable fi_next_ff_num : int;
- (** the number to assign to the next slice. *)
+ (** the number to assign to the next slice. *)
mutable f_called_by : called_by;
- (** calls in slices that call source fct *)
+ (** calls in slices that call source fct *)
}
and
@@ -95,19 +95,19 @@ and
called_by = (fct_slice * Cil_types.stmt) list
and
-(** Function slice :
- created as soon as there is a criterion to compute it,
- even if the slice itself hasn't been computed yet.
+ (** Function slice :
+ created as soon as there is a criterion to compute it,
+ even if the slice itself hasn't been computed yet.
*)
- fct_slice = {
- ff_fct : fct_info ;
- ff_id : int ;
- mutable ff_marks : ff_marks;
- mutable ff_called_by : called_by
- }
+ fct_slice = {
+ ff_fct : fct_info ;
+ ff_id : int ;
+ mutable ff_marks : ff_marks;
+ mutable ff_called_by : called_by
+}
and
-(** [fct_id] is used to identify either a source function or a sliced one.*)
+ (** [fct_id] is used to identify either a source function or a sliced one.*)
fct_id =
| FctSrc of fct_info (** source function *)
| FctSliced of fct_slice (** sliced function *)
@@ -115,7 +115,7 @@ and
and
called_fct =
| CallSrc of fct_info option
- (** call the source function (might be unknown if the call uses pointer) *)
+ (** call the source function (might be unknown if the call uses pointer) *)
| CallSlice of fct_slice
and
@@ -123,8 +123,8 @@ and
call_info = called_fct option
and
-(** main part of a slice = mapping between the function elements
- * and information about them in the slice. *)
+ (** main part of a slice = mapping between the function elements
+ * and information about them in the slice. *)
marks_index = (pdg_mark, call_info) PdgIndex.FctIndex.t
and
@@ -133,28 +133,28 @@ and
and
project = { functions : fct_info Varinfo.Hashtbl.t;
mutable actions : criterion list;
- }
+ }
and
-(** Slicing criterion at the application level.
- When applied, they are translated into [fct_criterion]
-*)
- appli_criterion =
+ (** Slicing criterion at the application level.
+ When applied, they are translated into [fct_criterion]
+ *)
+ appli_criterion =
| CaGlobalData of Locations.Zone.t
- (** select all that is necessary to compute the given location. *)
+ (** select all that is necessary to compute the given location. *)
| CaCall of fct_info
- (** select all that is necessary to call the given function.
- * Its application generates requests to add persistent selection
- * to all the function callers. *)
+ (** select all that is necessary to call the given function.
+ * Its application generates requests to add persistent selection
+ * to all the function callers. *)
| CaOther
and
-(** Base criterion for the functions. These are the only one that can
- really generate function slices. All the other criteria are
- translated in more basic ones.
- Note that to build such a base criterion, the PDG has to be already
- computed.
-*)
+ (** Base criterion for the functions. These are the only one that can
+ really generate function slices. All the other criteria are
+ translated in more basic ones.
+ Note that to build such a base criterion, the PDG has to be already
+ computed.
+ *)
fct_base_criterion = pdg_mark PdgMarks.select
and
@@ -171,54 +171,54 @@ and
node_or_dpds = CwNode | CwAddrDpds | CwDataDpds | CwCtrlDpds
and
-(** Tells which marks we want to put in the slice of a function *)
- fct_user_crit =
+ (** Tells which marks we want to put in the slice of a function *)
+ fct_user_crit =
(* | CuNodes of (pdg_node list * (node_or_dpds * pdg_mark) list) list *)
| CuSelect of pdg_mark PdgMarks.select
| CuTop of pdg_mark (** the function has probably no PDG,
but we nonetheless give a mark to propagate *)
and
-(** kinds of actions that can be apply to a function *)
+ (** kinds of actions that can be apply to a function *)
fct_crit =
| CcUserMark of fct_user_crit
- (** add marks to a slice *)
+ (** add marks to a slice *)
| CcChooseCall of Cil_types.stmt
- (** have to choose what function to call here. *)
+ (** have to choose what function to call here. *)
| CcChangeCall of Cil_types.stmt * called_fct
- (** call the [called_fct] for the given call [Cil_types.stmt] *)
+ (** call the [called_fct] for the given call [Cil_types.stmt] *)
| CcMissingOutputs of Cil_types.stmt * (pdg_mark PdgMarks.select) * bool
- (** this call is affected to a function that doesn't compute enough
- * outputs : we will have to choose between adding outputs to that slice,
- * or call another one. The boolean tells if the modifications would
- * change the visibility of some outputs. *)
+ (** this call is affected to a function that doesn't compute enough
+ * outputs : we will have to choose between adding outputs to that slice,
+ * or call another one. The boolean tells if the modifications would
+ * change the visibility of some outputs. *)
| CcMissingInputs of Cil_types.stmt * (pdg_mark PdgMarks.select) * bool
- (** the function calls a slice that has been modified :
- * and doesn't compute not enough inputs.
- * We will have to choose between adding marks to this function,
- * and call another slice.
- * The boolean tells if the modifications would
- * change the visibility of some inputs. *)
+ (** the function calls a slice that has been modified :
+ * and doesn't compute not enough inputs.
+ * We will have to choose between adding marks to this function,
+ * and call another slice.
+ * The boolean tells if the modifications would
+ * change the visibility of some inputs. *)
| CcPropagate of (pdg_mark PdgMarks.select)
- (** simply propagate the given marks *)
+ (** simply propagate the given marks *)
| CcExamineCalls of pdg_mark PdgMarks.info_called_outputs
and
-(** Slicing criterion for a function. *)
+ (** Slicing criterion for a function. *)
fct_criterion = {
cf_fct : fct_id ;
- (** Identification of the {b RESULT} of this filter.
- * When it a a slice, it might be an existing slice that will be modified,
- * or a new one will be created during application.
- * When it is the source function, it means what the criterion has to be
- * applied on each existing slice, and stored into the initial marks of
- * the function.
- *)
+ (** Identification of the {b RESULT} of this filter.
+ * When it a a slice, it might be an existing slice that will be modified,
+ * or a new one will be created during application.
+ * When it is the source function, it means what the criterion has to be
+ * applied on each existing slice, and stored into the initial marks of
+ * the function.
+ *)
cf_info : fct_crit
}
and
-(** A slicing criterion is either an application level criterion,
- * or a function level one. *)
+ (** A slicing criterion is either an application level criterion,
+ * or a function level one. *)
criterion =
- CrAppli of appli_criterion | CrFct of fct_criterion
+ CrAppli of appli_criterion | CrFct of fct_criterion
(** {2 Internals values} *)
@@ -244,7 +244,7 @@ let dummy_fct_info = {
let dummy_marks_index = PdgIndex.FctIndex.create 0
let dummy_ff_marks = (PdgTypes.Pdg.top (Kernel_function.dummy ()),
- dummy_marks_index)
+ dummy_marks_index)
let dummy_fct_slice = {
ff_fct = dummy_fct_info ;
diff --git a/src/plugins/slicing/slicingMacros.ml b/src/plugins/slicing/slicingMacros.ml
index 28963bcf6e87a3ac9516d0cfe0f95316df91389d..d49a3f596c1632a67974dc3aefcfe1553699c28d 100644
--- a/src/plugins/slicing/slicingMacros.ml
+++ b/src/plugins/slicing/slicingMacros.ml
@@ -21,7 +21,7 @@
(**************************************************************************)
(** Slicing module public macros that should be used to avoid using the type
-* concrete definition from other modules.
+ * concrete definition from other modules.
*)
(**/**)
@@ -29,7 +29,7 @@
open Cil_types
(**/**)
-
+
(** {2 Options} *)
let str_level_option opt = match opt with
@@ -40,11 +40,11 @@ let str_level_option opt = match opt with
let translate_num_to_slicing_level n =
match n with
- | 0 -> SlicingInternals.DontSlice
- | 1 -> SlicingInternals.DontSliceButComputeMarks
- | 2 -> SlicingInternals.MinNbSlice
- | 3 -> SlicingInternals.MaxNbSlice
- | _ -> raise SlicingTypes.WrongSlicingLevel
+ | 0 -> SlicingInternals.DontSlice
+ | 1 -> SlicingInternals.DontSliceButComputeMarks
+ | 2 -> SlicingInternals.MinNbSlice
+ | 3 -> SlicingInternals.MaxNbSlice
+ | _ -> raise SlicingTypes.WrongSlicingLevel
let get_default_level_option defined_function =
if defined_function || (SlicingParameters.Mode.SliceUndef.get ()) then
@@ -70,10 +70,10 @@ let get_kf_fi kf =
with Not_found ->
let fi_def, is_def =
match kf.fundec with
- | Declaration _ -> None, false
- | Definition _ when !Db.Value.use_spec_instead_of_definition kf ->
- None, false
- | Definition (def, _) -> Some def, true
+ | Declaration _ -> None, false
+ | Definition _ when !Db.Value.use_spec_instead_of_definition kf ->
+ None, false
+ | Definition (def, _) -> Some def, true
in
let new_fi = {
SlicingInternals.fi_kf = kf;
@@ -109,7 +109,7 @@ let ff_name ff =
let fi = ff.SlicingInternals.ff_fct in
let ff_id = get_ff_id ff in
let fct_name = fi_name fi in
- (fct_name ^ "_slice_" ^ (string_of_int (ff_id)))
+ (fct_name ^ "_slice_" ^ (string_of_int (ff_id)))
let f_name f = match f with
| SlicingInternals.FctSrc fct -> fi_name fct
@@ -137,14 +137,14 @@ let get_ff_pdg ff = get_fi_pdg ff.SlicingInternals.ff_fct
let ff_slicing_level ff = ff.SlicingInternals.ff_fct.SlicingInternals.fi_level_option
let change_fi_slicing_level fi slicing_level =
- fi.SlicingInternals.fi_level_option <- slicing_level
+ fi.SlicingInternals.fi_level_option <- slicing_level
(** @raise SlicingTypes.WrongSlicingLevel if [n] is not valid.
-* *)
+ * *)
let change_slicing_level kf n =
let slicing_level = translate_num_to_slicing_level n in
let fi = get_kf_fi kf in (* build if if it doesn't exist *)
- change_fi_slicing_level fi slicing_level
+ change_fi_slicing_level fi slicing_level
(** {2 functions and slices} *)
@@ -155,7 +155,7 @@ let fi_slices fi = fi.SlicingInternals.fi_slices
let equal_fi fi1 fi2 =
let v1 = fi_svar fi1 in
let v2 = fi_svar fi2 in
- Cil_datatype.Varinfo.equal v1 v2
+ Cil_datatype.Varinfo.equal v1 v2
let equal_ff ff1 ff2 = (equal_fi ff1.SlicingInternals.ff_fct ff2.SlicingInternals.ff_fct) &&
((get_ff_id ff1) = (get_ff_id ff2))
@@ -170,7 +170,7 @@ let same_ff_call (f1,c1) (f2,c2) =
let is_call_stmt stmt =
match stmt.skind with
- | Instr (Call _ | Local_init(_, ConsInit _,_)) -> true | _ -> false
+ | Instr (Call _ | Local_init(_, ConsInit _,_)) -> true | _ -> false
let get_called_kf call_stmt = match call_stmt.skind with
| Instr (Call (_, funcexp,_,_)) ->
@@ -193,10 +193,10 @@ let is_variadic kf =
let get_fi_call call =
try
let kf = get_called_kf call in
- if is_variadic kf then None
- else
- let fct_info = get_kf_fi kf in
- Some fct_info
+ if is_variadic kf then None
+ else
+ let fct_info = get_kf_fi kf in
+ Some fct_info
with SlicingTypes.PtrCallExpr -> None
let is_src_fun_called kf =
@@ -208,11 +208,11 @@ let is_src_fun_visible kf =
in is_src_fun_called kf || is_fi_top (get_kf_fi kf)
let fi_has_persistent_selection fi =
- (match fi.SlicingInternals.fi_init_marks with None -> false | _ -> true)
+ (match fi.SlicingInternals.fi_init_marks with None -> false | _ -> true)
let has_persistent_selection kf =
let fi = get_kf_fi kf in
- fi_has_persistent_selection fi
+ fi_has_persistent_selection fi
(*
diff --git a/src/plugins/slicing/slicingMarks.ml b/src/plugins/slicing/slicingMarks.ml
index a227088653198fe59914c3251c72b2a843ee3e48..d443d72d48db66488bf72656decab3f562a59a80 100644
--- a/src/plugins/slicing/slicingMarks.ml
+++ b/src/plugins/slicing/slicingMarks.ml
@@ -30,7 +30,7 @@ let debug = false
(** a [Mark] is used to represent some information about the status of
* a PDG element in a slice.
- *)
+*)
module Mark : sig
val bottom : SlicingInternals.mark
val spare : SlicingInternals.mark
@@ -43,9 +43,9 @@ module Mark : sig
val is_top : SlicingInternals.mark -> bool
val is_included : SlicingInternals.mark -> SlicingInternals.mark -> bool
- (** this operation has to be commutative.
- It is used to merge two slices into one.
- *)
+ (** this operation has to be commutative.
+ It is used to merge two slices into one.
+ *)
val merge : SlicingInternals.mark -> SlicingInternals.mark -> SlicingInternals.mark
val inter : SlicingInternals.mark -> SlicingInternals.mark -> SlicingInternals.mark
@@ -53,7 +53,7 @@ module Mark : sig
(** this operation add a new information to the old value.
* @return (new_mark, is_new)
where is_new=true if the new_mark is not included in the old one.
- *)
+ *)
val combine : old:SlicingInternals.mark -> SlicingInternals.mark -> bool * SlicingInternals.mark
(** [minus m1 m2] provides the mark [m] that you have to merge with [m2] to
@@ -84,14 +84,14 @@ end = struct
let create adc =
match adc with
- | false, false, false -> bottom
- | true, false, false -> addr
- | false, true, false -> data
- | false, false, true -> ctrl
- | true, true, false -> m_ad
- | true, false, true -> m_ac
- | false, true, true -> m_dc
- | true, true, true -> top
+ | false, false, false -> bottom
+ | true, false, false -> addr
+ | false, true, false -> data
+ | false, false, true -> ctrl
+ | true, true, false -> m_ad
+ | true, false, true -> m_ac
+ | false, true, true -> m_dc
+ | true, true, true -> top
(* External constructor sharing same values *)
let mk_adc a d c = create (a, d, c)
@@ -101,47 +101,47 @@ end = struct
let is_top m = (m = top)
let is_included m1 m2 =
- match m1,m2 with
- | SlicingInternals.Spare, SlicingInternals.Spare -> true
- | SlicingInternals.Spare, SlicingInternals.Cav _ -> not (is_bottom m2)
- | SlicingInternals.Cav _, SlicingInternals.Spare -> is_bottom m1
- | SlicingInternals.Cav d1, SlicingInternals.Cav d2 -> PdgTypes.Dpd.is_included d1 d2
-
- let merge m1 m2 =
- match m1,m2 with
- | SlicingInternals.Spare, SlicingInternals.Spare -> m1
- | SlicingInternals.Spare, SlicingInternals.Cav _ -> if is_bottom m2 then m1 else m2
- | SlicingInternals.Cav _, SlicingInternals.Spare -> if is_bottom m1 then m2 else m1
- | SlicingInternals.Cav d1, SlicingInternals.Cav d2 -> mk_mark (PdgTypes.Dpd.combine d1 d2)
+ match m1,m2 with
+ | SlicingInternals.Spare, SlicingInternals.Spare -> true
+ | SlicingInternals.Spare, SlicingInternals.Cav _ -> not (is_bottom m2)
+ | SlicingInternals.Cav _, SlicingInternals.Spare -> is_bottom m1
+ | SlicingInternals.Cav d1, SlicingInternals.Cav d2 -> PdgTypes.Dpd.is_included d1 d2
+
+ let merge m1 m2 =
+ match m1,m2 with
+ | SlicingInternals.Spare, SlicingInternals.Spare -> m1
+ | SlicingInternals.Spare, SlicingInternals.Cav _ -> if is_bottom m2 then m1 else m2
+ | SlicingInternals.Cav _, SlicingInternals.Spare -> if is_bottom m1 then m2 else m1
+ | SlicingInternals.Cav d1, SlicingInternals.Cav d2 -> mk_mark (PdgTypes.Dpd.combine d1 d2)
let inter m1 m2 =
if is_bottom m1 then m1
else if is_bottom m2 then m2
else (* m1 and m2 are not bottom => the result cannot be bottom *)
match m1,m2 with
- | SlicingInternals.Spare, _ -> m1
- | _, SlicingInternals.Spare -> m2
- | SlicingInternals.Cav d1, SlicingInternals.Cav d2 ->
- let m = mk_mark (PdgTypes.Dpd.inter d1 d2) in
- if is_bottom m then spare else m
-
- let combine ~old m =
- match old, m with
- | SlicingInternals.Spare, SlicingInternals.Spare -> (false, old)
- | SlicingInternals.Cav old_d, SlicingInternals.Spare ->
- if PdgTypes.Dpd.is_bottom old_d then (true, m) else (false, old)
- | SlicingInternals.Spare, SlicingInternals.Cav new_d ->
- if PdgTypes.Dpd.is_bottom new_d then (false, old) else (true, m)
- | SlicingInternals.Cav old_d, SlicingInternals.Cav new_d ->
- let new_d = PdgTypes.Dpd.combine old_d new_d in
- if old_d = new_d then (false, old) else (true, mk_mark new_d)
+ | SlicingInternals.Spare, _ -> m1
+ | _, SlicingInternals.Spare -> m2
+ | SlicingInternals.Cav d1, SlicingInternals.Cav d2 ->
+ let m = mk_mark (PdgTypes.Dpd.inter d1 d2) in
+ if is_bottom m then spare else m
+
+ let combine ~old m =
+ match old, m with
+ | SlicingInternals.Spare, SlicingInternals.Spare -> (false, old)
+ | SlicingInternals.Cav old_d, SlicingInternals.Spare ->
+ if PdgTypes.Dpd.is_bottom old_d then (true, m) else (false, old)
+ | SlicingInternals.Spare, SlicingInternals.Cav new_d ->
+ if PdgTypes.Dpd.is_bottom new_d then (false, old) else (true, m)
+ | SlicingInternals.Cav old_d, SlicingInternals.Cav new_d ->
+ let new_d = PdgTypes.Dpd.combine old_d new_d in
+ if old_d = new_d then (false, old) else (true, mk_mark new_d)
let minus m1 m2 =
- match m1,m2 with
- | SlicingInternals.Spare, SlicingInternals.Spare -> bottom
- | SlicingInternals.Spare, SlicingInternals.Cav d2 -> if PdgTypes.Dpd.is_bottom d2 then m1 else bottom
- | SlicingInternals.Cav _, SlicingInternals.Spare -> m1 (* even if [PdgTypes.Dpd.is_bottom d1] because m1 = bot *)
- | SlicingInternals.Cav d1, SlicingInternals.Cav d2 -> mk_mark (PdgTypes.Dpd.minus d1 d2)
+ match m1,m2 with
+ | SlicingInternals.Spare, SlicingInternals.Spare -> bottom
+ | SlicingInternals.Spare, SlicingInternals.Cav d2 -> if PdgTypes.Dpd.is_bottom d2 then m1 else bottom
+ | SlicingInternals.Cav _, SlicingInternals.Spare -> m1 (* even if [PdgTypes.Dpd.is_bottom d1] because m1 = bot *)
+ | SlicingInternals.Cav d1, SlicingInternals.Cav d2 -> mk_mark (PdgTypes.Dpd.minus d1 d2)
let pretty fmt m =
match m with
@@ -153,13 +153,13 @@ end
(** a [SlicingInternals.pdg_mark] is associated with each element of the PDG in a slice.
* The first component gives the mark propagated from a user request, while
* the second one is used to propagate informations to the called functions.
- *)
+*)
-let mk_m1 m1 = { SlicingInternals.m1 = m1 ; m2 = Mark.bottom }
+let mk_m1 m1 = { SlicingInternals.m1 = m1 ; m2 = Mark.bottom }
-let mk_m2 m2 = { SlicingInternals.m1 = Mark.bottom ; m2 = m2}
+let mk_m2 m2 = { SlicingInternals.m1 = Mark.bottom ; m2 = m2}
-let bottom_mark = { SlicingInternals.m1 = Mark.bottom ; m2 = Mark.bottom }
+let bottom_mark = { SlicingInternals.m1 = Mark.bottom ; m2 = Mark.bottom }
let user_mark m = Mark.merge m.SlicingInternals.m1 m.SlicingInternals.m2
let is_bottom_mark m = (Mark.is_bottom (user_mark m))
@@ -183,7 +183,7 @@ module MarkPair = struct
&& Mark.is_included ma.SlicingInternals.m2 mb.SlicingInternals.m2
let pretty fmt m =
- Format.fprintf fmt "@[<hv><%a,@ %a>@]"
+ Format.fprintf fmt "@[<hv><%a,@ %a>@]"
Mark.pretty m.SlicingInternals.m1 Mark.pretty m.SlicingInternals.m2
let to_string m =
@@ -197,59 +197,59 @@ module MarkPair = struct
let merge ma mb =
let m1 = Mark.merge ma.SlicingInternals.m1 mb.SlicingInternals.m1 in
let m2 = Mark.merge ma.SlicingInternals.m2 mb.SlicingInternals.m2 in
- { SlicingInternals.m1 = m1 ; m2 = m2 }
+ { SlicingInternals.m1 = m1 ; m2 = m2 }
(** merge only ma_1 et mb_1, m_2 is always bottom *)
let merge_user_marks ma mb =
let m1 = Mark.merge ma.SlicingInternals.m1 mb.SlicingInternals.m1 in
- { SlicingInternals.m1 = m1 ; m2 = Mark.bottom }
+ { SlicingInternals.m1 = m1 ; m2 = Mark.bottom }
let rec merge_all marks =
match marks with
- | [] -> bottom_mark
- | m :: [] -> m (* to avoid merging with bottom every time ! *)
- | m :: tl -> merge m (merge_all tl)
+ | [] -> bottom_mark
+ | m :: [] -> m (* to avoid merging with bottom every time ! *)
+ | m :: tl -> merge m (merge_all tl)
let inter ma mb =
let m1 = Mark.inter ma.SlicingInternals.m1 mb.SlicingInternals.m1 in
let m2 = Mark.inter ma.SlicingInternals.m2 mb.SlicingInternals.m2 in
- { SlicingInternals.m1 = m1 ; m2 = m2 }
+ { SlicingInternals.m1 = m1 ; m2 = m2 }
let rec inter_all marks =
match marks with
- | [] -> bottom_mark
- | m :: [] -> m
- | m :: tl -> inter m (inter_all tl)
+ | [] -> bottom_mark
+ | m :: [] -> m
+ | m :: tl -> inter m (inter_all tl)
(** [combine ma mb] is used to add the [mb] to the [ma].
* @return two marks : the first one is the new mark (= merge),
* and the second is the one to propagate.
* Notice that if the mark to propagate is bottom,
* it means that [mb] was included in [ma].
- *)
+ *)
let combine ma mb =
let combine_m ma mb =
let is_new, mr = Mark.combine ma mb in
let m_to_prop = if is_new then mr else Mark.bottom in
- mr, m_to_prop
+ mr, m_to_prop
in
let new_m1, prop1 = combine_m ma.SlicingInternals.m1 mb.SlicingInternals.m1 in
let new_m2, prop2 = combine_m ma.SlicingInternals.m2 mb.SlicingInternals.m2 in
- { SlicingInternals.m1 = new_m1 ; m2 = new_m2 },
+ { SlicingInternals.m1 = new_m1 ; m2 = new_m2 },
{ SlicingInternals.m1 = prop1 ; m2 = prop2 }
(** we want to know if the called function [g] with output marks
- * [m_out_called] compute enough things to be used in [f] call
- * with output marks [m_out_call].
- * Remember the [mf1] marks propagates as [mg2] and the marks to add
- * can only be [m2] marks.
- * TODO : write this down in the specification
- * and check with Patrick if it is ok.
- * *)
+ * [m_out_called] compute enough things to be used in [f] call
+ * with output marks [m_out_call].
+ * Remember the [mf1] marks propagates as [mg2] and the marks to add
+ * can only be [m2] marks.
+ * TODO : write this down in the specification
+ * and check with Patrick if it is ok.
+ * *)
let missing_output ~call:m_out_call ~called:m_out_called =
if debug then
Format.printf "check_out : call=%a called=%a\n" pretty m_out_call
- pretty m_out_called;
+ pretty m_out_called;
let mf1 = m_out_call.SlicingInternals.m1 in
let mf2 = m_out_call.SlicingInternals.m2 in
let mg1 = m_out_called.SlicingInternals.m1 in
@@ -265,8 +265,8 @@ module MarkPair = struct
(Some m2)
(** tells if the caller ([f]) computes enough inputs for the callee ([g]).
- * Remember that [mg1] has to be propagated as [mf1],
- * but [mg2] has to be propagated as [mf2=spare] *)
+ * Remember that [mg1] has to be propagated as [mf1],
+ * but [mg2] has to be propagated as [mf2=spare] *)
let missing_input ~call:m_in_call ~called:m_in_called =
let mf1 = m_in_call.SlicingInternals.m1 in
let mf2 = m_in_call.SlicingInternals.m2 in
@@ -278,12 +278,12 @@ module MarkPair = struct
Mark.spare
else Mark.bottom
in let new_m = { SlicingInternals.m1 = new_mf1 ; m2 = new_mf2 } in
- if is_bottom_mark new_m then None else Some new_m
+ if is_bottom_mark new_m then None else Some new_m
end
(** [SigMarks] works on the marks in function signatures.
- *)
+*)
module SigMarks = struct
open PdgIndex
@@ -302,11 +302,11 @@ module SigMarks = struct
let get_matching_input_marks (sgn:t) z =
Signature.fold_all_inputs
(fun acc (k, m) ->
- match k with
- | PdgIndex.Signature.InCtrl | PdgIndex.Signature.InNum _ ->
- (k, m) :: acc
- | PdgIndex.Signature.InImpl z' ->
- if Locations.Zone.intersects z z' then (k, m) :: acc else acc
+ match k with
+ | PdgIndex.Signature.InCtrl | PdgIndex.Signature.InNum _ ->
+ (k, m) :: acc
+ | PdgIndex.Signature.InImpl z' ->
+ if Locations.Zone.intersects z z' then (k, m) :: acc else acc
) [] sgn
exception Visible
@@ -320,13 +320,13 @@ module SigMarks = struct
let is_topin_visible cm =
try
let m = get_in_top_mark cm in
- not (is_bottom_mark m)
+ not (is_bottom_mark m)
with Not_found -> false
let ctrl_visible cm =
try
let ctrl_m = get_in_ctrl_mark cm in
- not (is_bottom_mark ctrl_m)
+ not (is_bottom_mark ctrl_m)
with Not_found -> false
let some_visible_in cm =
@@ -335,12 +335,12 @@ module SigMarks = struct
let merge_inputs_m1_mark cm =
Signature.fold_all_inputs (fun acc (_, m) -> MarkPair.merge_user_marks acc m)
- bottom_mark cm
+ bottom_mark cm
(** @return an under-approximation of the mark for the given location.
- * If the location is not included in the union of the implicit inputs,
- * it returns bottom.
- * Else, it returns the intersection of the inputs that intersect the location.
+ * If the location is not included in the union of the implicit inputs,
+ * it returns bottom.
+ * Else, it returns the intersection of the inputs that intersect the location.
*)
let get_input_loc_under_mark cm loc =
if debug then
@@ -353,9 +353,9 @@ module SigMarks = struct
then
let marked_inputs = Locations.Zone.link marked_inputs in_loc in
let marks = m::marks in
- (marked_inputs, marks)
+ (marked_inputs, marks)
else
- (marked_inputs, marks)
+ (marked_inputs, marks)
in
let marked_inputs = Locations.Zone.bottom in
let marked_inputs, marks =
@@ -365,10 +365,10 @@ module SigMarks = struct
then MarkPair.inter_all marks
else bottom_mark
in
- if debug then
- Format.printf "get_input_loc_under_mark : m = %a"
- MarkPair.pretty m;
- m
+ if debug then
+ Format.printf "get_input_loc_under_mark : m = %a"
+ MarkPair.pretty m;
+ m
let something_visible cm =
some_visible_out cm || some_visible_in cm || ctrl_visible cm
@@ -377,9 +377,9 @@ module SigMarks = struct
let add (out0, out_zone) (out_key, m_out) =
if is_bottom_mark m_out then (out0, out_zone)
else match out_key with
- | PdgIndex.Signature.OutRet -> true, out_zone
- | PdgIndex.Signature.OutLoc z ->
- out0, Locations.Zone.join out_zone z
+ | PdgIndex.Signature.OutRet -> true, out_zone
+ | PdgIndex.Signature.OutLoc z ->
+ out0, Locations.Zone.join out_zone z
in Signature.fold_all_outputs add (false, Locations.Zone.bottom) call_marks
diff --git a/src/plugins/slicing/slicingMarks.mli b/src/plugins/slicing/slicingMarks.mli
index 42cbaf3cb8a28db4470e7f17068e631412f2a270..32d38782e45cc93835fbbbe7fb8316ec09d64156 100644
--- a/src/plugins/slicing/slicingMarks.mli
+++ b/src/plugins/slicing/slicingMarks.mli
@@ -40,7 +40,7 @@ val merge_marks : sl_mark list -> sl_mark
val inter_marks : sl_mark list -> sl_mark
(** [combine_marks] add a new information to the old value.
-* @return (new_mark, is_new)
+ * @return (new_mark, is_new)
where [is_new=true] if the new mark is not included in the old one.
*)
val combine_marks : sl_mark -> sl_mark -> (sl_mark * sl_mark)
diff --git a/src/plugins/slicing/slicingParameters.ml b/src/plugins/slicing/slicingParameters.ml
index 0c0249ec4f27130faa706c0578a844c0a728c0cc..4cd56dac0125117390b82dee93e1ac5d774c744e 100644
--- a/src/plugins/slicing/slicingParameters.ml
+++ b/src/plugins/slicing/slicingParameters.ml
@@ -25,11 +25,11 @@
(* ************************************************************************* *)
include Plugin.Register
- (struct
- let name = "slicing"
- let shortname = "slicing"
- let help = "code slicer"
- end)
+ (struct
+ let name = "slicing"
+ let shortname = "slicing"
+ let help = "code slicer"
+ end)
module Select = struct
@@ -37,68 +37,68 @@ module Select = struct
module Calls =
Kernel_function_set
(struct
- let option_name = "-slice-calls"
- let arg_name = "f1, ..., fn"
- let help =
- "select every calls to functions f1,...,fn, and all their effect"
- end)
+ let option_name = "-slice-calls"
+ let arg_name = "f1, ..., fn"
+ let help =
+ "select every calls to functions f1,...,fn, and all their effect"
+ end)
let () = Parameter_customize.argument_may_be_fundecl ()
module Return =
Kernel_function_set
(struct
- let option_name = "-slice-return"
- let arg_name = "f1, ..., fn"
- let help =
- "select the result (returned value) of functions f1,...,fn"
- end)
+ let option_name = "-slice-return"
+ let arg_name = "f1, ..., fn"
+ let help =
+ "select the result (returned value) of functions f1,...,fn"
+ end)
let () = Parameter_customize.argument_may_be_fundecl ()
module Threat =
Kernel_function_set
(struct
- let option_name = "-slice-threat"
- let arg_name = "f1, ..., fn"
- let help = "select the threats of functions f1,...,fn"
- end)
+ let option_name = "-slice-threat"
+ let arg_name = "f1, ..., fn"
+ let help = "select the threats of functions f1,...,fn"
+ end)
module Assert =
Kernel_function_set
(struct
- let option_name = "-slice-assert"
- let arg_name = "f1, ..., fn"
- let help = "select the assertions of functions f1,...,fn"
- end)
+ let option_name = "-slice-assert"
+ let arg_name = "f1, ..., fn"
+ let help = "select the assertions of functions f1,...,fn"
+ end)
module LoopInv =
Kernel_function_set
(struct
- let option_name = "-slice-loop-inv"
- let arg_name = "f1, ..., fn"
- let help = "select the loop invariants of functions f1,...,fn"
- end)
+ let option_name = "-slice-loop-inv"
+ let arg_name = "f1, ..., fn"
+ let help = "select the loop invariants of functions f1,...,fn"
+ end)
module LoopVar =
Kernel_function_set
(struct
- let option_name = "-slice-loop-var"
- let arg_name = "f1, ..., fn"
- let help = "select the loop variants of functions f1,...,fn"
- end)
+ let option_name = "-slice-loop-var"
+ let arg_name = "f1, ..., fn"
+ let help = "select the loop variants of functions f1,...,fn"
+ end)
module Pragma =
Kernel_function_set
(struct
- let option_name = "-slice-pragma"
- let arg_name = "f1, ..., fn"
- let help =
- "use the slicing pragmas in the code of functions f1,...,fn as \
-slicing criteria:\n\
-//@ slice pragma ctrl; to reach this control-flow point\n\
-//@ slice pragma expr <expr_desc;> to preserve the value of an expression at \
-this control-flow point\n\
-//@ slice pragma stmt; to preserve the effect of the next statement"
- end)
+ let option_name = "-slice-pragma"
+ let arg_name = "f1, ..., fn"
+ let help =
+ "use the slicing pragmas in the code of functions f1,...,fn as \
+ slicing criteria:\n\
+ //@ slice pragma ctrl; to reach this control-flow point\n\
+ //@ slice pragma expr <expr_desc;> to preserve the value of an expression at \
+ this control-flow point\n\
+ //@ slice pragma stmt; to preserve the effect of the next statement"
+ end)
module RdAccess =
String_set
@@ -107,9 +107,9 @@ this control-flow point\n\
let arg_name = "v1, ..., vn"
let help =
"select the read accesses to left-values v1,...,vn \
- (addresses are evaluated at the beginning of the function given as \
-entry point)"
- end)
+ (addresses are evaluated at the beginning of the function given as \
+ entry point)"
+ end)
module WrAccess =
String_set
@@ -118,9 +118,9 @@ entry point)"
let arg_name = "v1, ..., vn"
let help =
"select the write accesses to left-values v1,...,vn \
- (addresses are evaluated at the beginning of the function given as\
- entry point)"
- end)
+ (addresses are evaluated at the beginning of the function given as\
+ entry point)"
+ end)
module Value =
String_set
@@ -129,9 +129,9 @@ entry point)"
let arg_name = "v1, ..., vn"
let help =
"select the result of left-values v1,...,vn at the end of the \
-function given as entry point (addresses are evaluated at the beginning of \
-the function given as entry point)"
- end)
+ function given as entry point (addresses are evaluated at the beginning of \
+ the function given as entry point)"
+ end)
end
@@ -139,76 +139,76 @@ module Mode = struct
module Callers =
True(struct
- let option_name = "-slice-callers"
- let help = "propagate the slicing to the function callers"
- end)
+ let option_name = "-slice-callers"
+ let help = "propagate the slicing to the function callers"
+ end)
module Calls =
Int
(struct
- let option_name = "-slicing-level"
- let default = 2
- let arg_name = ""
- let help = "set the default level of slicing used to propagate to \
-the calls\n\
- 0 : don't slice the called functions\n\
- 1 : don't slice the called functions but propagate the marks anyway\n\
- 2 : try to use existing slices, create at most one\n\
- 3 : most precise slices\n\
- note: this value (defaults to 2) is not used for calls to undefined \
-functions\n\
- except when '-slice-undef-functions' option is set"
- end)
+ let option_name = "-slicing-level"
+ let default = 2
+ let arg_name = ""
+ let help = "set the default level of slicing used to propagate to \
+ the calls\n\
+ 0 : don't slice the called functions\n\
+ 1 : don't slice the called functions but propagate the marks anyway\n\
+ 2 : try to use existing slices, create at most one\n\
+ 3 : most precise slices\n\
+ note: this value (defaults to 2) is not used for calls to undefined \
+ functions\n\
+ except when '-slice-undef-functions' option is set"
+ end)
let () = Calls.set_range ~min:0 ~max:3
module SliceUndef =
False(struct
- let option_name = "-slice-undef-functions"
- let help = "allow the use of the -slicing-level option for calls \
-to undefined functions"
- end)
+ let option_name = "-slice-undef-functions"
+ let help = "allow the use of the -slicing-level option for calls \
+ to undefined functions"
+ end)
module KeepAnnotations =
False(struct
- let option_name = "-slicing-keep-annotations"
- let help = "keep annotations as long as the used variables are \
-declared and the accessibility of the program point is preserved (even if the \
-value of the data is not preserved)"
- end)
+ let option_name = "-slicing-keep-annotations"
+ let help = "keep annotations as long as the used variables are \
+ declared and the accessibility of the program point is preserved (even if the \
+ value of the data is not preserved)"
+ end)
end
module ProjectName =
String(struct
- let option_name = "-slicing-project-name"
- let arg_name = "ident"
- let help = "name of the slicing project (defaults to \"Slicing\").\
-This name is used as basename when building the name of the exported project (see -slicing-exported-project-postfix option)"
- let default = "Slicing"
- end)
+ let option_name = "-slicing-project-name"
+ let arg_name = "ident"
+ let help = "name of the slicing project (defaults to \"Slicing\").\
+ This name is used as basename when building the name of the exported project (see -slicing-exported-project-postfix option)"
+ let default = "Slicing"
+ end)
module ExportedProjectPostfix =
String(struct
- let option_name = "-slicing-exported-project-postfix"
- let arg_name = "postfix"
- let help = "postfix added to the slicing project name for building \
-the name of the exported project (defaults to \" export\")"
- let default = " export"
- end)
+ let option_name = "-slicing-exported-project-postfix"
+ let arg_name = "postfix"
+ let help = "postfix added to the slicing project name for building \
+ the name of the exported project (defaults to \" export\")"
+ let default = " export"
+ end)
module Force =
True(struct
- let option_name = "-slice-force"
- let help = "force slicing"
- end)
+ let option_name = "-slice-force"
+ let help = "force slicing"
+ end)
module OptionModified =
State_builder.Ref
(Datatype.Bool)
(struct
- let name = "Slicing.OptionModified"
- let dependencies = []
- let default () = true
- end)
+ let name = "Slicing.OptionModified"
+ let dependencies = []
+ let default () = true
+ end)
let wkey_cmdline = register_warn_category "cmdline"
let () = set_warn_status wkey_cmdline Log.Wabort
@@ -234,16 +234,16 @@ let () =
let is_on () =
(Force.get () || OptionModified.get ())
&&
- (not (Select.Calls.is_empty ()
- && Select.Return.is_empty ()
- && Select.Threat.is_empty ()
- && Select.Assert.is_empty ()
- && Select.LoopInv.is_empty ()
- && Select.LoopVar.is_empty ()
- && Select.Pragma.is_empty ()
- && Select.RdAccess.is_empty ()
- && Select.WrAccess.is_empty ()
- && Select.Value.is_empty ()))
+ (not (Select.Calls.is_empty ()
+ && Select.Return.is_empty ()
+ && Select.Threat.is_empty ()
+ && Select.Assert.is_empty ()
+ && Select.LoopInv.is_empty ()
+ && Select.LoopVar.is_empty ()
+ && Select.Pragma.is_empty ()
+ && Select.RdAccess.is_empty ()
+ && Select.WrAccess.is_empty ()
+ && Select.Value.is_empty ()))
let set_off () =
diff --git a/src/plugins/slicing/slicingProject.ml b/src/plugins/slicing/slicingProject.ml
index 7e419edaac8d1745e5801609aa4b017d6b32bb72..73532548cc680d1e25e1d22b8fa9a079ccb49a9b 100644
--- a/src/plugins/slicing/slicingProject.ml
+++ b/src/plugins/slicing/slicingProject.ml
@@ -37,27 +37,27 @@ let add_proj_actions actions =
proj.T.actions <- actions @ proj.T.actions
(** Add a new slice for the function. It can be the case that it create actions
-* if the function has some persistent selection, that make function calls to
-* choose.
-* @raise SlicingTypes.NoPdg when the function has no PDG.
-* *)
+ * if the function has some persistent selection, that make function calls to
+ * choose.
+ * @raise SlicingTypes.NoPdg when the function has no PDG.
+ * *)
let create_slice kf =
let ff, actions = Fct_slice.make_new_ff (M.get_kf_fi kf) true in
add_proj_actions actions; ff
(** Delete [ff_to_remove] if it is not called.
-* @raise T.CantRemoveCalledFf if it is.
+ * @raise T.CantRemoveCalledFf if it is.
*)
let remove_ff ff_to_remove =
let rec remove ff_list ff_num = match ff_list with
| [] -> raise Not_found
| ff :: tail ->
- if ff.T.ff_id = ff_num then (Fct_slice.clear_ff ff; tail)
- else ff :: (remove tail ff_num)
+ if ff.T.ff_id = ff_num then (Fct_slice.clear_ff ff; tail)
+ else ff :: (remove tail ff_num)
in let fi = ff_to_remove.T.ff_fct in
let ff_num = ff_to_remove.T.ff_id in
let new_ff_list = remove fi.T.fi_slices ff_num in
- fi.T.fi_slices <- new_ff_list
+ fi.T.fi_slices <- new_ff_list
let call_src_and_remove_all_ff fi =
let do_call actions (ff_caller, call_id) =
@@ -68,8 +68,8 @@ let call_src_and_remove_all_ff fi =
let do_ff actions ff =
let calls = ff.SlicingInternals.ff_called_by in
let actions = List.fold_left do_call actions calls in
- remove_ff ff;
- actions
+ remove_ff ff;
+ actions
in
List.fold_left do_ff [] fi.T.fi_slices
@@ -79,42 +79,42 @@ let rec remove_uncalled_slices () =
let check_ff changes ff =
match ff.T.ff_called_by with [] -> remove_ff ff; true | _ -> changes
in let check_fi changes fi =
- if (M.fi_name fi) <> entry_name then
- List.fold_left check_ff changes (M.fi_slices fi)
- else changes
+ if (M.fi_name fi) <> entry_name then
+ List.fold_left check_ff changes (M.fi_slices fi)
+ else changes
in let changes = M.fold_fi check_fi false in
- if changes then remove_uncalled_slices () else ()
+ if changes then remove_uncalled_slices () else ()
(** Build a new slice [ff] which contains the marks of [ff1] and [ff2]
-* and generate everything that is needed to choose the calls in [ff].
-* If [replace] also generate requests call [ff] instead of [ff1] and [ff2]. *)
+ * and generate everything that is needed to choose the calls in [ff].
+ * If [replace] also generate requests call [ff] instead of [ff1] and [ff2]. *)
let merge_slices ff1 ff2 replace =
let ff, ff_actions = Fct_slice.merge_slices ff1 ff2 in
- if replace then
- begin
- let add actions (caller, call) =
- let rq = SlicingActions.mk_crit_change_call caller call
- (T.CallSlice ff) in
- rq :: actions
- in
- let actions = List.fold_left add [] ff2.T.ff_called_by in
- let actions = List.fold_left add actions ff1.T.ff_called_by in
- add_proj_actions actions
- end;
- add_proj_actions ff_actions;
- ff
+ if replace then
+ begin
+ let add actions (caller, call) =
+ let rq = SlicingActions.mk_crit_change_call caller call
+ (T.CallSlice ff) in
+ rq :: actions
+ in
+ let actions = List.fold_left add [] ff2.T.ff_called_by in
+ let actions = List.fold_left add actions ff1.T.ff_called_by in
+ add_proj_actions actions
+ end;
+ add_proj_actions ff_actions;
+ ff
let split_slice ff =
let add (actions, slices) (caller, call) =
let new_ff = Fct_slice.copy_slice ff in
let rq = SlicingActions.mk_crit_change_call caller call
- (T.CallSlice new_ff) in
- rq::actions, new_ff::slices
+ (T.CallSlice new_ff) in
+ rq::actions, new_ff::slices
in
let calls = List.tl ff.T.ff_called_by in (* keep ff for the first call *)
let actions, slices = List.fold_left add ([], [ff]) calls in
- add_proj_actions actions;
- slices
+ add_proj_actions actions;
+ slices
(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
(** {2 Getting information } *)
@@ -142,20 +142,20 @@ let add_fct_filter proj f_id criterion =
*)
(** Add an action to the action list to filter the function [fct_id] with
- the given criterion. The filter gives a name to the result of the filter
- which is a new slice if the function to filter is the source one,
- or the given slice otherwise.
- *)
+ the given criterion. The filter gives a name to the result of the filter
+ which is a new slice if the function to filter is the source one,
+ or the given slice otherwise.
+*)
let add_fct_src_filter fi to_select =
match to_select with
- (* T.CuSelect [] : don't ignore empty selection because
- the input control node has to be selected anyway... *)
- | T.CuSelect select ->
- let filter = SlicingActions.mk_crit_fct_user_select fi select in
- add_filter filter
- | T.CuTop m ->
- let filter = SlicingActions.mk_crit_fct_top fi m in
- add_filter filter
+ (* T.CuSelect [] : don't ignore empty selection because
+ the input control node has to be selected anyway... *)
+ | T.CuSelect select ->
+ let filter = SlicingActions.mk_crit_fct_user_select fi select in
+ add_filter filter
+ | T.CuTop m ->
+ let filter = SlicingActions.mk_crit_fct_top fi m in
+ add_filter filter
(*
let add_fct_src_filters proj fi actions =
@@ -164,13 +164,13 @@ let add_fct_src_filters proj fi actions =
let add_fct_ff_filter ff to_select =
match to_select with
- | T.CuSelect [] ->
- SlicingParameters.debug ~level:1
- "[SlicingProject.add_fct_ff_filter] (ignored empty selection)"
- | T.CuSelect select ->
- let filter = SlicingActions.mk_ff_user_select ff select in
- add_filter filter
- | T.CuTop _ -> assert false
+ | T.CuSelect [] ->
+ SlicingParameters.debug ~level:1
+ "[SlicingProject.add_fct_ff_filter] (ignored empty selection)"
+ | T.CuSelect select ->
+ let filter = SlicingActions.mk_ff_user_select ff select in
+ add_filter filter
+ | T.CuTop _ -> assert false
(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
(** {2 Print} *)
@@ -186,8 +186,8 @@ let print_project fmt =
| Cil_types.GFun (func, _) -> (* function definition *)
let slices = get_slices func.Cil_types.svar in
List.iter (PrintSlice.print_marked_ff fmt) slices
- (* TODO see if we have to print the original function *)
- | _ ->
+ (* TODO see if we have to print the original function *)
+ | _ ->
PrintSlice.print_original_glob fmt glob
in
let source = Ast.get () in
@@ -216,7 +216,7 @@ let pretty_slice fmt ff =
add to the project worklist. *)
let apply_fct_crit ff to_select =
let actions = Fct_slice.apply_add_marks ff to_select in
- actions
+ actions
let apply_appli_crit appli_crit =
match appli_crit with
@@ -234,34 +234,34 @@ let apply_appli_crit appli_crit =
"This slicing criterion on application"
(** Add persistent the marks [node_marks] in [fi] and also add the marks
-* to existing slices if any.
-* If the propagation is ON, some actions are generated to propagate the
-* persistent marks to the callers, and other actions are generated to
-* make all the calls to [fi] visible.
-* If there is no slice for [fi] we create a new one
-* if it is the original request.
-* It will be automatically created with the persistent marks.
-* If it is a propagation, no need to create a new slice
-* because it will be created when the call will be selected anyway.
-* *)
+ * to existing slices if any.
+ * If the propagation is ON, some actions are generated to propagate the
+ * persistent marks to the callers, and other actions are generated to
+ * make all the calls to [fi] visible.
+ * If there is no slice for [fi] we create a new one
+ * if it is the original request.
+ * It will be automatically created with the persistent marks.
+ * If it is a propagation, no need to create a new slice
+ * because it will be created when the call will be selected anyway.
+ * *)
let add_persistent_marks fi node_marks orig propagate actions =
let new_fi_marks, actions =
Fct_slice.add_marks_to_fi fi node_marks propagate actions
in
let actions = match M.fi_slices fi with
| [] -> (* no slice *)
- let actions =
- if orig then
- let _ff, new_actions = Fct_slice.make_new_ff fi true in
- (* TODO catch NoPdg and mark fi as Top *)
- new_actions @ actions
- else actions
- in actions
+ let actions =
+ if orig then
+ let _ff, new_actions = Fct_slice.make_new_ff fi true in
+ (* TODO catch NoPdg and mark fi as Top *)
+ new_actions @ actions
+ else actions
+ in actions
| slices ->
- let add_filter acc ff =
- let a = SlicingActions.mk_ff_user_select ff node_marks in a::acc
- in
- List.fold_left add_filter actions slices
+ let add_filter acc ff =
+ let a = SlicingActions.mk_ff_user_select ff node_marks in a::acc
+ in
+ List.fold_left add_filter actions slices
in
let actions =
if propagate && new_fi_marks then
@@ -325,29 +325,29 @@ let apply_action filter =
let new_filters =
try match filter with
| T.CrFct fct_crit ->
- begin
- try (apply_fct_action fct_crit)
- with PdgTypes.Pdg.Bottom ->
- SlicingParameters.debug ~level:1 " -> action ABORTED (PDG is bottom)" ;
- []
- end
- | T.CrAppli appli_crit ->
- apply_appli_crit appli_crit
+ begin
+ try (apply_fct_action fct_crit)
+ with PdgTypes.Pdg.Bottom ->
+ SlicingParameters.debug ~level:1 " -> action ABORTED (PDG is bottom)" ;
+ []
+ end
+ | T.CrAppli appli_crit ->
+ apply_appli_crit appli_crit
with Not_found -> (* catch unprocessed Not_found here *) assert false
in
- SlicingParameters.debug ~level:1 " -> %d generated filters : %a@."
- (List.length new_filters)
- SlicingActions.print_list_crit new_filters;
- new_filters
+ SlicingParameters.debug ~level:1 " -> %d generated filters : %a@."
+ (List.length new_filters)
+ SlicingActions.print_list_crit new_filters;
+ new_filters
let get_next_filter () =
let proj = SlicingState.get () in
match proj.T.actions with
- | [] ->
- SlicingParameters.debug ~level:2
- "[SlicingProject.get_next_filter] No more filter";
- raise Not_found
- | f :: tail -> proj.T.actions <- tail; f
+ | [] ->
+ SlicingParameters.debug ~level:2
+ "[SlicingProject.get_next_filter] No more filter";
+ raise Not_found
+ | f :: tail -> proj.T.actions <- tail; f
let apply_next_action () =
SlicingParameters.debug ~level:2 "[SlicingProject.apply_next_action]";
@@ -364,11 +364,11 @@ let apply_all_actions () =
let proj = SlicingState.get () in
let nb_actions = List.length proj.T.actions in
let rec apply actions = match actions with [] -> ()
- | a::actions ->
- SlicingParameters.feedback ~level:2 "applying sub action...";
- let new_filters = apply_action a in
- apply new_filters;
- apply actions
+ | a::actions ->
+ SlicingParameters.feedback ~level:2 "applying sub action...";
+ let new_filters = apply_action a in
+ apply new_filters;
+ apply actions
in
SlicingParameters.feedback ~level:1 "applying %d actions..." nb_actions;
let rec apply_user n =
diff --git a/src/plugins/slicing/slicingSelect.ml b/src/plugins/slicing/slicingSelect.ml
index 2917260339a3c0c826200f3cc302640583d74282..5775c6ecbe4f45d9c3540775f6a1062325efd5a6 100644
--- a/src/plugins/slicing/slicingSelect.ml
+++ b/src/plugins/slicing/slicingSelect.ml
@@ -31,16 +31,16 @@ let check_call stmt is_call =
| Instr (Call _ | Local_init(_, ConsInit _,_)) -> not is_call
| _ -> is_call
in
- if err then
- let str = if is_call then "not" else "" in
- let msg = "This statement is "^str^" a call" in
- raise (Invalid_argument msg)
- else stmt
+ if err then
+ let str = if is_call then "not" else "" in
+ let msg = "This statement is "^str^" a call" in
+ raise (Invalid_argument msg)
+ else stmt
let print_select fmt db_select =
let db_fvar, select = db_select in
- Format.fprintf fmt "In %a : %a"
- Varinfo.pretty db_fvar SlicingActions.print_f_crit select
+ Format.fprintf fmt "In %a : %a"
+ Varinfo.pretty db_fvar SlicingActions.print_f_crit select
let get_select_kf (fvar, _select) = Globals.Functions.get fvar
@@ -70,27 +70,27 @@ let bottom_msg kf =
let basic_add_select kf select nodes ?(undef) nd_marks =
let fvar, sel = check_kf_db_select kf select in
match sel with
- | SlicingInternals.CuTop _ -> select
- | SlicingInternals.CuSelect sel ->
- let pdg = !Db.Pdg.get kf in
- let nodes =
- List.map (fun n -> (n, None) (*TODO: add z_part ? *)) nodes in
- (* let nd_marks = SlicingActions.build_node_and_dpds_selection mark in *)
- (* let nd_marks = SlicingActions.build_simple_node_selection mark in *)
- let crit = [(nodes, nd_marks)] in
- let sel = SlicingActions.translate_crit_to_select pdg ~to_select:sel crit in
- let sel = match undef with None -> sel
- | Some (undef, mark) ->
- PdgMarks.add_undef_in_to_select sel undef mark in
- let sel = SlicingInternals.CuSelect sel in
- (fvar, sel)
+ | SlicingInternals.CuTop _ -> select
+ | SlicingInternals.CuSelect sel ->
+ let pdg = !Db.Pdg.get kf in
+ let nodes =
+ List.map (fun n -> (n, None) (*TODO: add z_part ? *)) nodes in
+ (* let nd_marks = SlicingActions.build_node_and_dpds_selection mark in *)
+ (* let nd_marks = SlicingActions.build_simple_node_selection mark in *)
+ let crit = [(nodes, nd_marks)] in
+ let sel = SlicingActions.translate_crit_to_select pdg ~to_select:sel crit in
+ let sel = match undef with None -> sel
+ | Some (undef, mark) ->
+ PdgMarks.add_undef_in_to_select sel undef mark in
+ let sel = SlicingInternals.CuSelect sel in
+ (fvar, sel)
let select_pdg_nodes kf ?(select=empty_db_select kf) nodes mark =
SlicingParameters.debug ~level:1 "[Register.select_pdg_nodes]" ;
let nd_marks = SlicingActions.build_node_and_dpds_selection mark in
try basic_add_select kf select nodes nd_marks
with Db.Pdg.Top | Db.Pdg.Bottom ->
- assert false (* if we have node, we must have a pdg somewhere ! *)
+ assert false (* if we have node, we must have a pdg somewhere ! *)
let mk_select pdg sel nodes undef mark =
let nd_marks = SlicingActions.build_simple_node_selection mark in
@@ -98,52 +98,52 @@ let mk_select pdg sel nodes undef mark =
let sel = SlicingActions.translate_crit_to_select pdg ~to_select:sel crit in
let sel = PdgMarks.add_undef_in_to_select sel undef mark in
let sel = SlicingInternals.CuSelect sel in
- sel
+ sel
let select_stmt_zone kf ?(select=empty_db_select kf) stmt ~before loc mark =
SlicingParameters.debug ~level:1 "[Register.select_stmt_zone] %a %s stmt %d (m=%a)"
- Locations.Zone.pretty loc
- (if before then "before" else "after") stmt.sid
- SlicingMarks.pretty_mark mark;
- if not (Db.Value.is_reachable_stmt stmt) then
+ Locations.Zone.pretty loc
+ (if before then "before" else "after") stmt.sid
+ SlicingMarks.pretty_mark mark;
+ if not (Db.Value.is_reachable_stmt stmt) then
begin
SlicingParameters.feedback
- "@[Nothing to select for @[%a@]@ %s unreachable stmt of %a@]"
+ "@[Nothing to select for @[%a@]@ %s unreachable stmt of %a@]"
Locations.Zone.pretty loc
(if before then "before" else "after")
- Kernel_function.pretty kf;
+ Kernel_function.pretty kf;
select
end
else
- let fvar, sel = check_kf_db_select kf select in
- match sel with
+ let fvar, sel = check_kf_db_select kf select in
+ match sel with
| SlicingInternals.CuTop _ -> select
| SlicingInternals.CuSelect sel ->
- try
- let pdg = !Db.Pdg.get kf in
- let nodes, undef =
- !Db.Pdg.find_location_nodes_at_stmt pdg stmt before loc in
- let sel = mk_select pdg sel nodes undef mark in
- (fvar, sel)
- with
- | Not_found -> (* stmt probably unreachable *)
- SlicingParameters.feedback
- "@[Nothing to select for @[%a@]@ %s required stmt in %a@]"
- Locations.Zone.pretty loc
- (if before then "before" else "after")
- Kernel_function.pretty kf;
- SlicingParameters.debug
- "@[Nothing to select for @[%a@]@ %s stmt %d in %a@]"
- Locations.Zone.pretty loc
- (if before then "before" else "after") stmt.sid
- Kernel_function.pretty kf;
- select
- | Db.Pdg.Top -> top_db_select kf mark
- | Db.Pdg.Bottom -> bottom_msg kf; select
+ try
+ let pdg = !Db.Pdg.get kf in
+ let nodes, undef =
+ !Db.Pdg.find_location_nodes_at_stmt pdg stmt before loc in
+ let sel = mk_select pdg sel nodes undef mark in
+ (fvar, sel)
+ with
+ | Not_found -> (* stmt probably unreachable *)
+ SlicingParameters.feedback
+ "@[Nothing to select for @[%a@]@ %s required stmt in %a@]"
+ Locations.Zone.pretty loc
+ (if before then "before" else "after")
+ Kernel_function.pretty kf;
+ SlicingParameters.debug
+ "@[Nothing to select for @[%a@]@ %s stmt %d in %a@]"
+ Locations.Zone.pretty loc
+ (if before then "before" else "after") stmt.sid
+ Kernel_function.pretty kf;
+ select
+ | Db.Pdg.Top -> top_db_select kf mark
+ | Db.Pdg.Bottom -> bottom_msg kf; select
(** this one is similar to [select_stmt_zone] with the return statement
-* when the function is defined, but it can also be used for undefined functions. *)
+ * when the function is defined, but it can also be used for undefined functions. *)
let select_in_out_zone ~at_end ~use_undef kf select loc mark =
SlicingParameters.debug
"[Register.select_in_out_zone] select zone %a (m=%a) at %s of %a"
@@ -151,26 +151,26 @@ let select_in_out_zone ~at_end ~use_undef kf select loc mark =
(if at_end then "end" else "begin") Kernel_function.pretty kf;
let fvar, sel = check_kf_db_select kf select in
match sel with
- | SlicingInternals.CuTop _ -> select
- | SlicingInternals.CuSelect sel ->
- try
- let pdg = !Db.Pdg.get kf in
- let find =
- if at_end then !Db.Pdg.find_location_nodes_at_end
- else !Db.Pdg.find_location_nodes_at_begin in
- let nodes, undef = find pdg loc in
- let undef = if use_undef then undef else None in
- let sel = mk_select pdg sel nodes undef mark in
- (fvar, sel)
- with
- | Not_found -> (* in or out unreachable ? *)
- SlicingParameters.feedback
- "@[Nothing to select for zone %a (m=%a) at %s of %a@]"
- Locations.Zone.pretty loc SlicingMarks.pretty_mark mark
- (if at_end then "end" else "begin") Kernel_function.pretty kf;
- select
- | Db.Pdg.Top -> top_db_select kf mark
- | Db.Pdg.Bottom -> bottom_msg kf; select
+ | SlicingInternals.CuTop _ -> select
+ | SlicingInternals.CuSelect sel ->
+ try
+ let pdg = !Db.Pdg.get kf in
+ let find =
+ if at_end then !Db.Pdg.find_location_nodes_at_end
+ else !Db.Pdg.find_location_nodes_at_begin in
+ let nodes, undef = find pdg loc in
+ let undef = if use_undef then undef else None in
+ let sel = mk_select pdg sel nodes undef mark in
+ (fvar, sel)
+ with
+ | Not_found -> (* in or out unreachable ? *)
+ SlicingParameters.feedback
+ "@[Nothing to select for zone %a (m=%a) at %s of %a@]"
+ Locations.Zone.pretty loc SlicingMarks.pretty_mark mark
+ (if at_end then "end" else "begin") Kernel_function.pretty kf;
+ select
+ | Db.Pdg.Top -> top_db_select kf mark
+ | Db.Pdg.Bottom -> bottom_msg kf; select
let select_zone_at_end kf ?(select=empty_db_select kf) loc mark =
select_in_out_zone ~at_end:true ~use_undef:true kf select loc mark
@@ -197,8 +197,8 @@ let select_stmt_computation kf ?(select=empty_db_select kf) stmt mark =
if not (Db.Value.is_reachable_stmt stmt) then
begin
SlicingParameters.feedback
- "@[Nothing to select for an unreachable stmt of %a@]"
- Kernel_function.pretty kf;
+ "@[Nothing to select for an unreachable stmt of %a@]"
+ Kernel_function.pretty kf;
select
end
else
@@ -206,46 +206,46 @@ let select_stmt_computation kf ?(select=empty_db_select kf) stmt mark =
let pdg = !Db.Pdg.get kf in
let stmt_nodes = stmt_nodes_to_select pdg stmt in
let nd_marks = SlicingActions.build_node_and_dpds_selection mark in
- basic_add_select kf select stmt_nodes nd_marks
+ basic_add_select kf select stmt_nodes nd_marks
with Db.Pdg.Top -> top_db_select kf mark
- | Db.Pdg.Bottom -> bottom_msg kf; select
+ | Db.Pdg.Bottom -> bottom_msg kf; select
let select_label kf ?(select=empty_db_select kf) label mark =
SlicingParameters.debug ~level:1 "[Register.select_label] on label "
- (* Logic_label.pretty label *);
- try
- let pdg = !Db.Pdg.get kf in
- let nodes =
- let add_label_nodes l acc = match l with
- | StmtLabel stmt ->
- let add acc l =
- try !Db.Pdg.find_label_node pdg !stmt l :: acc
- with Not_found -> acc
- in
- List.fold_left add acc (!stmt).labels
- | FormalLabel _ | BuiltinLabel _ -> acc
- in
- (* Logic_label.Set.fold add_label_nodes labels [] *)
- add_label_nodes label []
+ (* Logic_label.pretty label *);
+ try
+ let pdg = !Db.Pdg.get kf in
+ let nodes =
+ let add_label_nodes l acc = match l with
+ | StmtLabel stmt ->
+ let add acc l =
+ try !Db.Pdg.find_label_node pdg !stmt l :: acc
+ with Not_found -> acc
+ in
+ List.fold_left add acc (!stmt).labels
+ | FormalLabel _ | BuiltinLabel _ -> acc
in
- let nd_marks = SlicingActions.build_node_and_dpds_selection mark in
- basic_add_select kf select nodes nd_marks
- with Db.Pdg.Top -> top_db_select kf mark
- | Db.Pdg.Bottom -> bottom_msg kf; select
+ (* Logic_label.Set.fold add_label_nodes labels [] *)
+ add_label_nodes label []
+ in
+ let nd_marks = SlicingActions.build_node_and_dpds_selection mark in
+ basic_add_select kf select nodes nd_marks
+ with Db.Pdg.Top -> top_db_select kf mark
+ | Db.Pdg.Bottom -> bottom_msg kf; select
(** marking a call node means that a [choose_call] will have to decide that to
* call according to the slicing-level, but anyway, the call will be visible.
- *)
+*)
let select_minimal_call kf ?(select=empty_db_select kf) stmt m =
SlicingParameters.debug ~level:1 "[Register.select_minimal_call]";
- try
- let pdg = !Db.Pdg.get kf in
- let call = check_call stmt true in
- let call_node = !Db.Pdg.find_call_ctrl_node pdg call in
- let nd_marks = SlicingActions.build_simple_node_selection m in
- basic_add_select kf select [call_node] nd_marks
- with Db.Pdg.Top -> top_db_select kf m
- | Db.Pdg.Bottom -> bottom_msg kf; select
+ try
+ let pdg = !Db.Pdg.get kf in
+ let call = check_call stmt true in
+ let call_node = !Db.Pdg.find_call_ctrl_node pdg call in
+ let nd_marks = SlicingActions.build_simple_node_selection m in
+ basic_add_select kf select [call_node] nd_marks
+ with Db.Pdg.Top -> top_db_select kf m
+ | Db.Pdg.Bottom -> bottom_msg kf; select
let select_stmt_ctrl kf ?(select=empty_db_select kf) stmt =
SlicingParameters.debug ~level:1 "[Register.select_stmt_ctrl] of sid:%d" stmt.sid;
@@ -254,37 +254,37 @@ let select_stmt_ctrl kf ?(select=empty_db_select kf) stmt =
let pdg = !Db.Pdg.get kf in
let stmt_nodes = !Db.Pdg.find_simple_stmt_nodes pdg stmt in
let nd_marks = SlicingActions.build_ctrl_dpds_selection mark in
- basic_add_select kf select stmt_nodes nd_marks
+ basic_add_select kf select stmt_nodes nd_marks
with Db.Pdg.Top -> top_db_select kf mark
- | Db.Pdg.Bottom -> bottom_msg kf; empty_db_select kf
+ | Db.Pdg.Bottom -> bottom_msg kf; empty_db_select kf
let select_entry_point kf ?(select=empty_db_select kf) mark =
SlicingParameters.debug ~level:1 "[Register.select_entry_point] of %a"
- Kernel_function.pretty kf;
+ Kernel_function.pretty kf;
try
let pdg = !Db.Pdg.get kf in
let node = !Db.Pdg.find_entry_point_node pdg in
let nd_marks = SlicingActions.build_simple_node_selection mark in
- basic_add_select kf select [node] nd_marks
+ basic_add_select kf select [node] nd_marks
with Db.Pdg.Top -> top_db_select kf mark
- | Db.Pdg.Bottom -> bottom_msg kf; empty_db_select kf
+ | Db.Pdg.Bottom -> bottom_msg kf; empty_db_select kf
let select_return kf ?(select=empty_db_select kf) mark =
SlicingParameters.debug ~level:1 "[Register.select_return] of %a"
- Kernel_function.pretty kf;
+ Kernel_function.pretty kf;
try
let pdg = !Db.Pdg.get kf in
let node = !Db.Pdg.find_ret_output_node pdg in
let nd_marks = SlicingActions.build_simple_node_selection mark in
- basic_add_select kf select [node] nd_marks
+ basic_add_select kf select [node] nd_marks
with
- | Not_found -> (* unreachable ? *)
- SlicingParameters.feedback
- "@[Nothing to select for return stmt of %a@]"
- Kernel_function.pretty kf;
- select
- | Db.Pdg.Top -> top_db_select kf mark
- | Db.Pdg.Bottom -> bottom_msg kf; empty_db_select kf
+ | Not_found -> (* unreachable ? *)
+ SlicingParameters.feedback
+ "@[Nothing to select for return stmt of %a@]"
+ Kernel_function.pretty kf;
+ select
+ | Db.Pdg.Top -> top_db_select kf mark
+ | Db.Pdg.Bottom -> bottom_msg kf; empty_db_select kf
let select_decl_var kf ?(select=empty_db_select kf) vi mark =
SlicingParameters.debug ~level:1 "[Register.select_decl_var] of %s in %a@."
@@ -292,33 +292,33 @@ let select_decl_var kf ?(select=empty_db_select kf) vi mark =
if vi.Cil_types.vglob (* no slicing request on globals *)
then select
else try
- let pdg = !Db.Pdg.get kf in
- let node = !Db.Pdg.find_decl_var_node pdg vi in
- let nd_marks = SlicingActions.build_simple_node_selection mark in
+ let pdg = !Db.Pdg.get kf in
+ let node = !Db.Pdg.find_decl_var_node pdg vi in
+ let nd_marks = SlicingActions.build_simple_node_selection mark in
basic_add_select kf select [node] nd_marks
- with
+ with
| Not_found ->
- SlicingParameters.feedback
- "@[Nothing to select for %s declarationin %a@]"
- vi.Cil_types.vname Kernel_function.pretty kf;
- select
+ SlicingParameters.feedback
+ "@[Nothing to select for %s declarationin %a@]"
+ vi.Cil_types.vname Kernel_function.pretty kf;
+ select
| Db.Pdg.Top -> top_db_select kf mark
| Db.Pdg.Bottom -> bottom_msg kf; empty_db_select kf
let merge_select select1 select2 =
let select = match select1, select2 with
- | SlicingInternals.CuTop m, _ | _, SlicingInternals.CuTop m -> SlicingInternals.CuTop m
- | SlicingInternals.CuSelect select1, SlicingInternals.CuSelect select2 ->
- (* TODO : we can probably do better...*)
- SlicingInternals.CuSelect (select1 @ select2)
+ | SlicingInternals.CuTop m, _ | _, SlicingInternals.CuTop m -> SlicingInternals.CuTop m
+ | SlicingInternals.CuSelect select1, SlicingInternals.CuSelect select2 ->
+ (* TODO : we can probably do better...*)
+ SlicingInternals.CuSelect (select1 @ select2)
in select
let merge_db_select db_select1 db_select2 =
let fvar, select1 = db_select1 in
let _, select2 = check_db_select fvar db_select2 in
let select = merge_select select1 select2 in
- (fvar, select)
+ (fvar, select)
module Selections = struct
@@ -341,13 +341,13 @@ end
let add_crit_ff_change_call ff_caller call f_to_call =
let crit = SlicingActions.mk_crit_change_call ff_caller call f_to_call in
- SlicingProject.add_filter crit
+ SlicingProject.add_filter crit
(** change the call to call the given slice.
* This is a user request, so it might be the case that
* the new function doesn't compute enough outputs :
* in that case, add outputs first.
- *)
+*)
let call_ff_in_caller ~caller ~to_call =
let kf_caller = SlicingMacros.get_ff_kf caller in
let kf_to_call = SlicingMacros.get_ff_kf to_call in
@@ -356,10 +356,10 @@ let call_ff_in_caller ~caller ~to_call =
let add_change_call stmt =
add_crit_ff_change_call caller stmt ff_to_call ;
match Fct_slice.check_outputs_before_change_call caller
- stmt to_call with
- | [] -> ()
- | [c] -> SlicingProject.add_filter c
- | _ -> assert false
+ stmt to_call with
+ | [] -> ()
+ | [c] -> SlicingProject.add_filter c
+ | _ -> assert false
in List.iter add_change_call call_stmts
@@ -382,47 +382,46 @@ let call_min_f_in_caller ~caller ~to_call =
let m = SlicingMarks.mk_user_spare in
let nd_marks = SlicingActions.build_simple_node_selection m in
let select = SlicingActions.translate_crit_to_select pdg [(call_nodes, nd_marks)] in
- SlicingProject.add_fct_ff_filter caller (SlicingInternals.CuSelect select)
+ SlicingProject.add_fct_ff_filter caller (SlicingInternals.CuSelect select)
let is_already_selected ff db_select =
let _, select = check_ff_db_select ff db_select in
- match select with
- | SlicingInternals.CuTop _ -> assert false
- | SlicingInternals.CuSelect to_select ->
- (* let pdg = !Db.Pdg.get (Globals.Functions.get fvar) in *)
- let new_marks = Fct_slice.filter_already_in ff to_select in
- let ok = if new_marks = [] then true else false in
- if ok then
- SlicingParameters.debug ~level:1
- "[Api.is_already_selected] %a ?\t--> yes"
- print_select db_select
- else SlicingParameters.debug ~level:1
- "[Api.is_already_selected] %a ?\t--> no (missing %a)"
- print_select db_select
- SlicingActions.print_sel_marks_list new_marks;
- ok
+ match select with
+ | SlicingInternals.CuTop _ -> assert false
+ | SlicingInternals.CuSelect to_select ->
+ (* let pdg = !Db.Pdg.get (Globals.Functions.get fvar) in *)
+ let new_marks = Fct_slice.filter_already_in ff to_select in
+ let ok = if new_marks = [] then true else false in
+ if ok then
+ SlicingParameters.debug ~level:1
+ "[Api.is_already_selected] %a ?\t--> yes"
+ print_select db_select
+ else SlicingParameters.debug ~level:1
+ "[Api.is_already_selected] %a ?\t--> no (missing %a)"
+ print_select db_select
+ SlicingActions.print_sel_marks_list new_marks;
+ ok
let add_ff_selection ff db_select =
SlicingParameters.debug ~level:1 "[Api.add_ff_selection] %a to %s"
print_select db_select (SlicingMacros.ff_name ff);
let _, select = check_ff_db_select ff db_select in
- SlicingProject.add_fct_ff_filter ff select
+ SlicingProject.add_fct_ff_filter ff select
(** add a persistent selection to the function.
-* This might change its slicing level in order to call slices later on. *)
+ * This might change its slicing level in order to call slices later on. *)
let add_fi_selection db_select =
SlicingParameters.debug ~level:1 "[Api.add_fi_selection] %a"
print_select db_select;
let kf = get_select_kf db_select in
let fi = SlicingMacros.get_kf_fi kf in
let _, select = db_select in
- SlicingProject.add_fct_src_filter fi select;
- match fi.SlicingInternals.fi_level_option with
- | SlicingInternals.DontSlice | SlicingInternals.DontSliceButComputeMarks ->
- SlicingMacros.change_fi_slicing_level fi SlicingInternals.MinNbSlice;
- SlicingParameters.debug ~level:1 "[Register.add_fi_selection] changing %s slicing level to %s@."
- (SlicingMacros.fi_name fi)
- (SlicingMacros.str_level_option fi.SlicingInternals.fi_level_option)
-
- | SlicingInternals.MinNbSlice | SlicingInternals.MaxNbSlice -> ()
-
+ SlicingProject.add_fct_src_filter fi select;
+ match fi.SlicingInternals.fi_level_option with
+ | SlicingInternals.DontSlice | SlicingInternals.DontSliceButComputeMarks ->
+ SlicingMacros.change_fi_slicing_level fi SlicingInternals.MinNbSlice;
+ SlicingParameters.debug ~level:1 "[Register.add_fi_selection] changing %s slicing level to %s@."
+ (SlicingMacros.fi_name fi)
+ (SlicingMacros.str_level_option fi.SlicingInternals.fi_level_option)
+
+ | SlicingInternals.MinNbSlice | SlicingInternals.MaxNbSlice -> ()
diff --git a/src/plugins/slicing/slicingState.ml b/src/plugins/slicing/slicingState.ml
index 6c8a30151c5aec4448b8fc57e1ed906e64623547..93a4ad676a17dfd508df128dec7f32b16c2fe1b8 100644
--- a/src/plugins/slicing/slicingState.ml
+++ b/src/plugins/slicing/slicingState.ml
@@ -32,9 +32,9 @@ let self = P.self
let () =
Cmdline.run_after_extended_stage
(fun () ->
- State_dependency_graph.add_codependencies
- ~onto:self
- [ !Db.Pdg.self; !Db.Inputs.self_external; !Db.Outputs.self_external ])
+ State_dependency_graph.add_codependencies
+ ~onto:self
+ [ !Db.Pdg.self; !Db.Inputs.self_external; !Db.Outputs.self_external ])
let get () =
try P.get ()
diff --git a/src/plugins/slicing/slicingTransform.ml b/src/plugins/slicing/slicingTransform.ml
index 293395efa39b1531298c927f2911c2dc1fd05364..c27b8a15e3be1be8bb12135b32ffba67d21e6533 100644
--- a/src/plugins/slicing/slicingTransform.ml
+++ b/src/plugins/slicing/slicingTransform.ml
@@ -29,8 +29,8 @@ open Cil
(**/**)
module Visibility (SliceName : sig
- val get : kernel_function -> bool -> int -> string
- end) = struct
+ val get : kernel_function -> bool -> int -> string
+ end) = struct
exception EraseAssigns
exception EraseAllocation
@@ -48,9 +48,9 @@ module Visibility (SliceName : sig
| Isrc of bool (* same meaning as keep_body *)
| Iproto
- let keep_body kf =
+ let keep_body kf =
Kernel_function.is_definition kf &&
- not (!Db.Value.use_spec_instead_of_definition kf)
+ not (!Db.Value.use_spec_instead_of_definition kf)
(* _project is left to comply with a module signature defined outside
the slicing module (in filter) *)
@@ -58,9 +58,9 @@ module Visibility (SliceName : sig
let fi = SlicingMacros.get_kf_fi kf in
let slices = SlicingMacros.fi_slices fi in
let src_visible = Fct_slice.is_src_fun_visible kf in
- SlicingParameters.debug ~level:1 "[SlicingTransform.Visibility.fct_info] processing %a (%d slices/src %svisible)"
- Kernel_function.pretty kf (List.length slices)
- (if src_visible then "" else "not ");
+ SlicingParameters.debug ~level:1 "[SlicingTransform.Visibility.fct_info] processing %a (%d slices/src %svisible)"
+ Kernel_function.pretty kf (List.length slices)
+ (if src_visible then "" else "not ");
let need_addr = (Kernel_function.get_vi kf).vaddrof in
let src_name_used = src_visible || need_addr in
let keep_body = keep_body kf in
@@ -69,25 +69,25 @@ module Visibility (SliceName : sig
(fun ff -> Iff {slice = ff; src_visible = src_name_used; keep_body})
slices
in
- if src_visible then Isrc keep_body :: info_list
- else if need_addr then Iproto :: info_list (* TODO for #344 *)
- else info_list
+ if src_visible then Isrc keep_body :: info_list
+ else if need_addr then Iproto :: info_list (* TODO for #344 *)
+ else info_list
let fct_name svar ff =
let name = match ff with
- | Isrc _ | Iproto ->
- let kf_entry,_ = Globals.entry_point () in
- let vi_entry = Kernel_function.get_vi kf_entry in
- if Cil_datatype.Varinfo.equal svar vi_entry then
- svar.vname ^ "_orig"
- else svar.vname
- | Iff {slice = ff; src_visible} ->
+ | Isrc _ | Iproto ->
+ let kf_entry,_ = Globals.entry_point () in
+ let vi_entry = Kernel_function.get_vi kf_entry in
+ if Cil_datatype.Varinfo.equal svar vi_entry then
+ svar.vname ^ "_orig"
+ else svar.vname
+ | Iff {slice = ff; src_visible} ->
let kf = SlicingMacros.get_ff_kf ff in
let ff_num = ff.SlicingInternals.ff_id in
SliceName.get kf src_visible ff_num
in
- SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fct_name] get fct_name = %s" name;
- name
+ SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fct_name] get fct_name = %s" name;
+ name
let visible_mark m = not (SlicingMarks.is_bottom_mark m)
@@ -104,88 +104,88 @@ module Visibility (SliceName : sig
| Isrc _ -> true
| Iproto -> false
| Iff {slice = ff} ->
- let m = Fct_slice.get_stmt_mark ff inst in
- visible_mark m
+ let m = Fct_slice.get_stmt_mark ff inst in
+ visible_mark m
let label_visible ff_opt inst label = match ff_opt with
| Isrc _ -> true
| Iproto -> false
| Iff {slice = ff} ->
- let m = Fct_slice.get_label_mark ff inst label in
- let v = visible_mark m in
- SlicingParameters.debug ~level:2
- "[SlicingTransform.Visibility.label_visible] label %a is %svisible"
- Printer.pp_label label (if v then "" else "in");
- v
+ let m = Fct_slice.get_label_mark ff inst label in
+ let v = visible_mark m in
+ SlicingParameters.debug ~level:2
+ "[SlicingTransform.Visibility.label_visible] label %a is %svisible"
+ Printer.pp_label label (if v then "" else "in");
+ v
let data_in_visible ff data_in = match data_in with
| None -> true
| Some data_in ->
- (* it is too difficult to know if the callers of this slice
- * compute [data_in] or not, but let's see if, by chance,
- * some data have been selected manually... *)
- let m = Fct_slice.get_input_loc_under_mark ff data_in in
- let v = visible_mark m in
- SlicingParameters.debug ~level:2
- "[SlicingTransform.Visibility.data_in_visible] data %a is %svisible"
- Locations.Zone.pretty data_in (if v then "" else "in");
- v
-
- let all_nodes_visible ff nodes =
- let is_visible visi n =
- let m = Fct_slice.get_node_mark ff n in
- if SlicingMarks.is_bottom_mark m then
- begin
- SlicingParameters.debug ~level:3
- "[SlicingTransform.Visibility.all_nodes_visible] node %a invisible"
- (!Db.Pdg.pretty_node true) n;
- false
- end
- else visi
- in List.fold_left is_visible true nodes
+ (* it is too difficult to know if the callers of this slice
+ * compute [data_in] or not, but let's see if, by chance,
+ * some data have been selected manually... *)
+ let m = Fct_slice.get_input_loc_under_mark ff data_in in
+ let v = visible_mark m in
+ SlicingParameters.debug ~level:2
+ "[SlicingTransform.Visibility.data_in_visible] data %a is %svisible"
+ Locations.Zone.pretty data_in (if v then "" else "in");
+ v
+
+ let all_nodes_visible ff nodes =
+ let is_visible visi n =
+ let m = Fct_slice.get_node_mark ff n in
+ if SlicingMarks.is_bottom_mark m then
+ begin
+ SlicingParameters.debug ~level:3
+ "[SlicingTransform.Visibility.all_nodes_visible] node %a invisible"
+ (!Db.Pdg.pretty_node true) n;
+ false
+ end
+ else visi
+ in List.fold_left is_visible true nodes
exception NoDataInfo
let data_nodes_visible ff (decl_nodes, data_info) =
let keep_annots = SlicingParameters.Mode.KeepAnnotations.get () in
SlicingParameters.debug ~level:2
- "[SlicingTransform.Visibility.data_nodes_visible (with keep_annots = %s)] ?"
+ "[SlicingTransform.Visibility.data_nodes_visible (with keep_annots = %s)] ?"
(if keep_annots then "true" else "false");
let decls_visible = all_nodes_visible ff decl_nodes in
- if keep_annots then decls_visible
- else
- match data_info with
- | None -> raise NoDataInfo
- | Some (data_nodes, data_in) ->
+ if keep_annots then decls_visible
+ else
+ match data_info with
+ | None -> raise NoDataInfo
+ | Some (data_nodes, data_in) ->
let is_data_visible visi (n,z) =
let key = PdgTypes.Node.elem_key n in
let key = match z, key with
| Some z, PdgIndex.Key.SigCallKey
- (call, PdgIndex.Signature.Out
- (PdgIndex.Signature.OutLoc out_z)) ->
- let z = Locations.Zone.narrow z out_z in
- PdgIndex.Key.call_output_key (PdgIndex.Key.call_from_id call) z
+ (call, PdgIndex.Signature.Out
+ (PdgIndex.Signature.OutLoc out_z)) ->
+ let z = Locations.Zone.narrow z out_z in
+ PdgIndex.Key.call_output_key (PdgIndex.Key.call_from_id call) z
| _, _ -> key
in
let m = Fct_slice.get_node_key_mark ff key in
- if SlicingMarks.is_bottom_mark m then
- begin
- SlicingParameters.debug ~level:2
- "[SlicingTransform.Visibility.data_nodes_visible]@\n\
- node %a invisible"
- (!Db.Pdg.pretty_node true) n;
- false
- end
- else visi
+ if SlicingMarks.is_bottom_mark m then
+ begin
+ SlicingParameters.debug ~level:2
+ "[SlicingTransform.Visibility.data_nodes_visible]@\n\
+ node %a invisible"
+ (!Db.Pdg.pretty_node true) n;
+ false
+ end
+ else visi
in
let visible = decls_visible && data_in_visible ff data_in in
let data_visible = List.fold_left is_data_visible visible data_nodes in
- data_visible
+ data_visible
-(* work-around to avoid outputting annotations with type errors:
- in case we end up with NotImplemented somewhere, we keep the annotation
- iff all C variables occurring in there are visible.
- *)
+ (* work-around to avoid outputting annotations with type errors:
+ in case we end up with NotImplemented somewhere, we keep the annotation
+ iff all C variables occurring in there are visible.
+ *)
let all_logic_var_visible, all_logic_var_visible_identified_term, all_logic_var_visible_term,
all_logic_var_visible_assigns, all_logic_var_visible_deps =
let module Exn = struct exception Invisible end in
@@ -193,43 +193,43 @@ module Visibility (SliceName : sig
inherit Visitor.frama_c_inplace
method! vlogic_var_use v =
match v.lv_origin with
- None -> DoChildren
- | Some v when
- v.vformal &&
- not
- (visible_mark
- (Fct_slice.get_param_mark ff
- (Kernel_function.get_formal_position v
- (SlicingMacros.get_ff_kf ff)+1)))
- (* For some reason, pdg counts parameters starting
- from 1 *)
- -> raise Exn.Invisible
- | Some v when
- not v.vglob &&
- not (visible_mark (Fct_slice.get_local_var_mark ff v)) ->
- raise Exn.Invisible
- | Some _ -> DoChildren
+ None -> DoChildren
+ | Some v when
+ v.vformal &&
+ not
+ (visible_mark
+ (Fct_slice.get_param_mark ff
+ (Kernel_function.get_formal_position v
+ (SlicingMacros.get_ff_kf ff)+1)))
+ (* For some reason, pdg counts parameters starting
+ from 1 *)
+ -> raise Exn.Invisible
+ | Some v when
+ not v.vglob &&
+ not (visible_mark (Fct_slice.get_local_var_mark ff v)) ->
+ raise Exn.Invisible
+ | Some _ -> DoChildren
end
in (fun ff pred ->
- try
- ignore (Visitor.visitFramacPredicate (vis ff) pred); true
- with Exn.Invisible -> false),
- (fun ff term ->
+ try
+ ignore (Visitor.visitFramacPredicate (vis ff) pred); true
+ with Exn.Invisible -> false),
+ (fun ff term ->
try
ignore (Visitor.visitFramacIdTerm (vis ff) term); true
with Exn.Invisible -> false),
- (fun ff term ->
+ (fun ff term ->
try
ignore (Visitor.visitFramacTerm (vis ff) term); true
with Exn.Invisible -> false),
- (fun ff (b,_) ->
- try
- ignore (Visitor.visitFramacTerm (vis ff) b.it_content); true
- with Exn.Invisible -> false),
- (fun ff d ->
- try
- ignore (Visitor.visitFramacTerm (vis ff) d.it_content); true
- with Exn.Invisible -> false)
+ (fun ff (b,_) ->
+ try
+ ignore (Visitor.visitFramacTerm (vis ff) b.it_content); true
+ with Exn.Invisible -> false),
+ (fun ff d ->
+ try
+ ignore (Visitor.visitFramacTerm (vis ff) d.it_content); true
+ with Exn.Invisible -> false)
let annotation_visible ff_opt stmt annot =
SlicingParameters.debug ~current:true ~level:2
@@ -241,30 +241,30 @@ module Visibility (SliceName : sig
| Isrc _ -> true
| Iproto -> false
| Iff {slice = ff} ->
- let kf = SlicingMacros.get_ff_kf ff in
- let pdg = !Db.Pdg.get kf in
- try
+ let kf = SlicingMacros.get_ff_kf ff in
+ let pdg = !Db.Pdg.get kf in
+ try
let ctrl_nodes, decl_nodes, data_info =
!Db.Pdg.find_code_annot_nodes pdg stmt annot
in
let data_visible = data_nodes_visible ff (decl_nodes, data_info) in
let visible = ((all_nodes_visible ff ctrl_nodes) && data_visible) in
- SlicingParameters.debug ~level:2
- "[SlicingTransform.Visibility.annotation_visible] -> %s"
- (if visible then "yes" else "no");
- visible
- with
- | NoDataInfo ->
- SlicingParameters.debug ~level:2
- "[SlicingTransform.Visibility.annotation_visible] \
- not implemented -> invisible"; false
- | Logic_interp.To_zone.NYI msg ->
- SlicingParameters.warning ~current:true ~once:true
- "Dropping unsupported ACSL annotation";
- SlicingParameters.debug ~level:2
- "[SlicingTransform.Visibility.annotation_visible] \
- %s -> invisible" msg;
- false
+ SlicingParameters.debug ~level:2
+ "[SlicingTransform.Visibility.annotation_visible] -> %s"
+ (if visible then "yes" else "no");
+ visible
+ with
+ | NoDataInfo ->
+ SlicingParameters.debug ~level:2
+ "[SlicingTransform.Visibility.annotation_visible] \
+ not implemented -> invisible"; false
+ | Logic_interp.To_zone.NYI msg ->
+ SlicingParameters.warning ~current:true ~once:true
+ "Dropping unsupported ACSL annotation";
+ SlicingParameters.debug ~level:2
+ "[SlicingTransform.Visibility.annotation_visible] \
+ %s -> invisible" msg;
+ false
let fun_precond_visible ff_opt p =
@@ -275,17 +275,17 @@ module Visibility (SliceName : sig
| Isrc _ -> true
| Iproto -> true
| Iff {slice = ff} ->
- let kf = SlicingMacros.get_ff_kf ff in
- let pdg = !Db.Pdg.get kf in
- try
- let nodes = !Db.Pdg.find_fun_precond_nodes pdg p in
- data_nodes_visible ff nodes
- with NoDataInfo ->
- all_logic_var_visible ff p
+ let kf = SlicingMacros.get_ff_kf ff in
+ let pdg = !Db.Pdg.get kf in
+ try
+ let nodes = !Db.Pdg.find_fun_precond_nodes pdg p in
+ data_nodes_visible ff nodes
+ with NoDataInfo ->
+ all_logic_var_visible ff p
in SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.precond_visible] -> %s"
- (if visible then "yes" else "no");
- visible
+ (if visible then "yes" else "no");
+ visible
let fun_postcond_visible ff_opt p =
SlicingParameters.debug ~level:2
@@ -295,17 +295,17 @@ module Visibility (SliceName : sig
| Isrc _ -> true
| Iproto -> true
| Iff {slice = ff} ->
- let kf = SlicingMacros.get_ff_kf ff in
- let pdg = !Db.Pdg.get kf in
- try
- let nodes = !Db.Pdg.find_fun_postcond_nodes pdg p in
- data_nodes_visible ff nodes
- with NoDataInfo -> all_logic_var_visible ff p
+ let kf = SlicingMacros.get_ff_kf ff in
+ let pdg = !Db.Pdg.get kf in
+ try
+ let nodes = !Db.Pdg.find_fun_postcond_nodes pdg p in
+ data_nodes_visible ff nodes
+ with NoDataInfo -> all_logic_var_visible ff p
in SlicingParameters.debug ~level:2
- "[SlicingTransform.Visibility.fun_postcond_visible] -> %s"
- (if visible then "yes" else "no");
- visible
+ "[SlicingTransform.Visibility.fun_postcond_visible] -> %s"
+ (if visible then "yes" else "no");
+ visible
let fun_variant_visible ff_opt v =
SlicingParameters.debug ~level:2
@@ -315,15 +315,15 @@ module Visibility (SliceName : sig
| Isrc _ -> true
| Iproto -> true
| Iff {slice = ff} ->
- let kf = SlicingMacros.get_ff_kf ff in
- let pdg = !Db.Pdg.get kf in
- try
- let nodes = !Db.Pdg.find_fun_variant_nodes pdg v in
- data_nodes_visible ff nodes
- with NoDataInfo -> all_logic_var_visible_term ff v
+ let kf = SlicingMacros.get_ff_kf ff in
+ let pdg = !Db.Pdg.get kf in
+ try
+ let nodes = !Db.Pdg.find_fun_variant_nodes pdg v in
+ data_nodes_visible ff nodes
+ with NoDataInfo -> all_logic_var_visible_term ff v
in SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fun_variant_visible] -> %s"
- (if visible then "yes" else "no");
- visible
+ (if visible then "yes" else "no");
+ visible
let fun_frees_visible ff_opt v =
let keep_annots = SlicingParameters.Mode.KeepAnnotations.get () in
@@ -334,12 +334,12 @@ module Visibility (SliceName : sig
if not keep_annots then raise EraseAllocation;
let visible =
match ff_opt with
- | Isrc _ -> true
- | Iproto -> true
- | Iff {slice = ff} -> all_logic_var_visible_identified_term ff v
+ | Isrc _ -> true
+ | Iproto -> true
+ | Iff {slice = ff} -> all_logic_var_visible_identified_term ff v
in SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fun_frees_visible] -> %s"
- (if visible then "yes" else "no");
- visible
+ (if visible then "yes" else "no");
+ visible
let fun_allocates_visible ff_opt v =
let keep_annots = SlicingParameters.Mode.KeepAnnotations.get () in
@@ -350,12 +350,12 @@ module Visibility (SliceName : sig
if not keep_annots then raise EraseAllocation;
let visible =
match ff_opt with
- | Isrc _ -> true
- | Iproto -> true
- | Iff {slice = ff} -> all_logic_var_visible_identified_term ff v
+ | Isrc _ -> true
+ | Iproto -> true
+ | Iff {slice = ff} -> all_logic_var_visible_identified_term ff v
in SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fun_allocates_visible] -> %s"
- (if visible then "yes" else "no");
- visible
+ (if visible then "yes" else "no");
+ visible
let fun_assign_visible ff_opt v =
let keep_annots = SlicingParameters.Mode.KeepAnnotations.get () in
@@ -366,12 +366,12 @@ module Visibility (SliceName : sig
if not keep_annots then raise EraseAssigns;
let visible =
match ff_opt with
- | Isrc _ -> true
- | Iproto -> true
- | Iff {slice = ff} -> all_logic_var_visible_assigns ff v
+ | Isrc _ -> true
+ | Iproto -> true
+ | Iff {slice = ff} -> all_logic_var_visible_assigns ff v
in SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fun_assign_visible] -> %s"
- (if visible then "yes" else "no");
- visible
+ (if visible then "yes" else "no");
+ visible
let fun_deps_visible ff_opt v =
let keep_annots = SlicingParameters.Mode.KeepAnnotations.get () in
@@ -381,9 +381,9 @@ module Visibility (SliceName : sig
keep_annots;
let visible =
match ff_opt with
- | Isrc _ -> true
- | Iproto -> true
- | Iff {slice = ff} -> all_logic_var_visible_deps ff v
+ | Isrc _ -> true
+ | Iproto -> true
+ | Iff {slice = ff} -> all_logic_var_visible_deps ff v
in
SlicingParameters.debug ~level:2
"[SlicingTransform.Visibility.fun_deps_visible] -> %s"
@@ -394,29 +394,29 @@ module Visibility (SliceName : sig
| Isrc _ -> true
| Iproto -> false
| Iff {slice = ff} ->
- let m = Fct_slice.get_local_var_mark ff var in
- visible_mark m
+ let m = Fct_slice.get_local_var_mark ff var in
+ visible_mark m
let res_call_visible ff call_stmt = match ff with
| Isrc _ -> true
| Iproto -> false
| Iff {slice = ff} ->
- let key = PdgIndex.Key.call_outret_key call_stmt in
- let _, ff_marks = ff.SlicingInternals.ff_marks in
- try
- let m = PdgIndex.FctIndex.find_info ff_marks key in
- visible_mark m
- with Not_found -> false
+ let key = PdgIndex.Key.call_outret_key call_stmt in
+ let _, ff_marks = ff.SlicingInternals.ff_marks in
+ try
+ let m = PdgIndex.FctIndex.find_info ff_marks key in
+ visible_mark m
+ with Not_found -> false
let result_visible _kf ff = match ff with
| Isrc _ | Iproto -> true
| Iff {slice = ff} ->
- let key = PdgIndex.Key.output_key in
- let _, ff_marks = ff.SlicingInternals.ff_marks in
- try
- let m = PdgIndex.FctIndex.find_info ff_marks key in
- visible_mark m
- with Not_found -> false
+ let key = PdgIndex.Key.output_key in
+ let _, ff_marks = ff.SlicingInternals.ff_marks in
+ try
+ let m = PdgIndex.FctIndex.find_info ff_marks key in
+ visible_mark m
+ with Not_found -> false
(* _project is left to comply with a module signature defined outside
the slicing module (in filter) *)
@@ -424,28 +424,28 @@ module Visibility (SliceName : sig
let info = match ff with
| Isrc _ | Iproto -> None
| Iff {slice = ff} ->
- try
- let _, ff_marks = ff.SlicingInternals.ff_marks in
- let called, _ =
- PdgIndex.FctIndex.find_call ff_marks call_stmt in
+ try
+ let _, ff_marks = ff.SlicingInternals.ff_marks in
+ let called, _ =
+ PdgIndex.FctIndex.find_call ff_marks call_stmt in
match called with
- | None | Some (None) ->
- SlicingParameters.error "Undefined called function call-%d\n"
- call_stmt.sid;
- assert false
- | Some (Some (SlicingInternals.CallSrc _)) -> None
- | Some (Some (SlicingInternals.CallSlice ff)) ->
- let kf_ff = SlicingMacros.get_ff_kf ff in
- (* BY: no idea why this is not the same code as in fct_info *)
- let src_visible = Fct_slice.is_src_fun_visible kf_ff in
- let keep_body = keep_body kf_ff in
- Some (kf_ff, Iff { slice = ff; src_visible; keep_body})
- with Not_found ->
- (* the functor should call [called_info] only for visible calls *)
+ | None | Some (None) ->
+ SlicingParameters.error "Undefined called function call-%d\n"
+ call_stmt.sid;
assert false
+ | Some (Some (SlicingInternals.CallSrc _)) -> None
+ | Some (Some (SlicingInternals.CallSlice ff)) ->
+ let kf_ff = SlicingMacros.get_ff_kf ff in
+ (* BY: no idea why this is not the same code as in fct_info *)
+ let src_visible = Fct_slice.is_src_fun_visible kf_ff in
+ let keep_body = keep_body kf_ff in
+ Some (kf_ff, Iff { slice = ff; src_visible; keep_body})
+ with Not_found ->
+ (* the functor should call [called_info] only for visible calls *)
+ assert false
in
- SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.called_info] called_info stmt %d -> %s@."
- call_stmt.sid (if info = None then "src" else "some slice");
+ SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.called_info] called_info stmt %d -> %s@."
+ call_stmt.sid (if info = None then "src" else "some slice");
info
let cond_edge_visible _ff_opt s =
diff --git a/src/plugins/slicing/slicingTransform.mli b/src/plugins/slicing/slicingTransform.mli
index 1b6ff238d48e778fdd8368b177a29827d2635c29..f39b707cb3bef95c91dde341bb5da0dbc777656f 100644
--- a/src/plugins/slicing/slicingTransform.mli
+++ b/src/plugins/slicing/slicingTransform.mli
@@ -25,11 +25,10 @@
val default_slice_names:(Cil_types.kernel_function -> bool -> int -> string)
(** Apply the actions still waiting in the project
-* and transform the program (CIL AST) using slicing results
-* Can optionally specify how to name the sliced functions using [f_slice_names].
-* (see db.mli)
+ * and transform the program (CIL AST) using slicing results
+ * Can optionally specify how to name the sliced functions using [f_slice_names].
+ * (see db.mli)
*)
val extract :
f_slice_names:(Cil_types.kernel_function -> bool -> int -> string)
-> string -> Project.t
-
diff --git a/src/plugins/slicing/slicingTypes.ml b/src/plugins/slicing/slicingTypes.ml
index 6ca13c15e24af00e6e0db7017d09f2aeb349e8bd..a96c1f5562c7d4361129af0d258466650975633b 100644
--- a/src/plugins/slicing/slicingTypes.ml
+++ b/src/plugins/slicing/slicingTypes.ml
@@ -29,11 +29,11 @@ exception CantRemoveCalledFf
exception WrongSlicingLevel
(** raised when someone tries to build more than one slice for the entry point.
-* *)
+ * *)
exception OnlyOneEntryPointSlice
(** raised when one tries to select something in a function where we are not
-* able to compute the Pdg. *)
+ * able to compute the Pdg. *)
exception NoPdg
(** {2 Public types}
@@ -42,19 +42,19 @@ exception NoPdg
* but it is not really possible to have abstract types since Slicing has to
* use Db.Slicing functions... So, it is up to the user of this module to use
* only this public part.
- *)
+*)
(** contains global things that has been computed so far
- for the slicing project.
- This includes :
- - the slices of the functions,
- - and the queue of actions to be applied.
- *)
+ for the slicing project.
+ This includes :
+ - the slices of the functions,
+ - and the queue of actions to be applied.
+*)
type sl_project = SlicingInternals.project
(** Type of the selections
-* (we store the varinfo because we cannot use the kernel_function in this file)
-* *)
+ * (we store the varinfo because we cannot use the kernel_function in this file)
+ * *)
type sl_select = Cil_types.varinfo * SlicingInternals.fct_user_crit
module Fct_user_crit =
@@ -66,7 +66,7 @@ module Fct_user_crit =
let name = "SlicingTypes.Fct_user_crit"
let mem_project = Datatype.never_any_project
let varname _ = "user_criteria"
- end)
+ end)
(** Function slice *)
type sl_fct_slice = SlicingInternals.fct_slice
@@ -93,7 +93,7 @@ module Sl_project =
let internal_pretty_code = pp_sl_project
let varname _s = "sl_project_"
let mem_project = Datatype.never_any_project
- end)
+ end)
module Sl_select =
Datatype.Make
@@ -107,7 +107,7 @@ module Sl_select =
let name = "SlicingTypes.Sl_select"
let varname _s = "sl_select"
let mem_project = Datatype.never_any_project
- end)
+ end)
let pp_sl_fct_slice p_caller fmt ff =
let pp fmt =
@@ -129,7 +129,7 @@ module Sl_fct_slice =
let reprs = [ dummy_fct_slice ]
let internal_pretty_code = pp_sl_fct_slice
let mem_project = Datatype.never_any_project
- end)
+ end)
let dyn_sl_fct_slice = Sl_fct_slice.ty
@@ -138,31 +138,31 @@ let pp_sl_mark p fmt m =
| SlicingInternals.Spare, _ -> None
| _, SlicingInternals.Spare -> None
| SlicingInternals.Cav mark1, SlicingInternals.Cav mark2 ->
- if (PdgTypes.Dpd.is_bottom mark2) then
- (* use [!Db.Slicing.Mark.make] constructor *)
- Some (fun fmt ->
- Format.fprintf fmt "@[<hv 2>!Db.Slicing.Mark.make@;~addr:%b@;~data:%b@;~ctrl:%b@]"
- (PdgTypes.Dpd.is_addr mark1)
- (PdgTypes.Dpd.is_data mark1)
- (PdgTypes.Dpd.is_ctrl mark1))
- else
- None
+ if (PdgTypes.Dpd.is_bottom mark2) then
+ (* use [!Db.Slicing.Mark.make] constructor *)
+ Some (fun fmt ->
+ Format.fprintf fmt "@[<hv 2>!Db.Slicing.Mark.make@;~addr:%b@;~data:%b@;~ctrl:%b@]"
+ (PdgTypes.Dpd.is_addr mark1)
+ (PdgTypes.Dpd.is_data mark1)
+ (PdgTypes.Dpd.is_ctrl mark1))
+ else
+ None
in
let pp = match pp with
| Some pp -> pp
| None ->
- let pp fmt sub_m = match sub_m with
- (* use internals constructors *)
- | SlicingInternals.Spare -> Format.fprintf fmt "SlicingInternals.Spare"
- | SlicingInternals.Cav pdg_m -> Format.fprintf fmt
- "@[<hv 2>(SlicingInternals.Cav@;@[<hv 2>(PdgTypes.Dpd.make@;~a:%b@;~d:%b@;~c:%b@;())@])@]"
- (PdgTypes.Dpd.is_addr pdg_m)
- (PdgTypes.Dpd.is_data pdg_m)
- (PdgTypes.Dpd.is_ctrl pdg_m)
- in
- fun fmt ->
- Format.fprintf fmt "@[<hv 2>SlicingInternals.create_sl_mark@;~m1:%a@;~m2:%a@]"
- pp m.SlicingInternals.m1 pp m.SlicingInternals.m2
+ let pp fmt sub_m = match sub_m with
+ (* use internals constructors *)
+ | SlicingInternals.Spare -> Format.fprintf fmt "SlicingInternals.Spare"
+ | SlicingInternals.Cav pdg_m -> Format.fprintf fmt
+ "@[<hv 2>(SlicingInternals.Cav@;@[<hv 2>(PdgTypes.Dpd.make@;~a:%b@;~d:%b@;~c:%b@;())@])@]"
+ (PdgTypes.Dpd.is_addr pdg_m)
+ (PdgTypes.Dpd.is_data pdg_m)
+ (PdgTypes.Dpd.is_ctrl pdg_m)
+ in
+ fun fmt ->
+ Format.fprintf fmt "@[<hv 2>SlicingInternals.create_sl_mark@;~m1:%a@;~m2:%a@]"
+ pp m.SlicingInternals.m1 pp m.SlicingInternals.m2
in Type.par p Type.Call fmt pp
module Sl_mark =
@@ -181,7 +181,7 @@ module Sl_mark =
let pretty = Datatype.from_pretty_code
let mem_project = Datatype.never_any_project
let varname = Datatype.undefined
- end)
+ end)
let dyn_sl_mark = Sl_mark.ty
diff --git a/src/plugins/sparecode/globs.ml b/src/plugins/sparecode/globs.ml
index 90e6bc0f738e8566a4900cf2a537cb85653c118a..bdbc159416ca3a3968a8000726061e9c79f48cf4 100644
--- a/src/plugins/sparecode/globs.ml
+++ b/src/plugins/sparecode/globs.ml
@@ -47,32 +47,32 @@ class collect_visitor = object (self)
method! vtype t = match t with
| TNamed(ti,_) ->
- (* we use the type name because direct typeinfo comparison
- * doesn't wok. Anyway, CIL renames types if several type have the same
- * name... *)
- if Hashtbl.mem used_typeinfo ti.tname then SkipChildren
- else begin
- debug "add used typedef %s@." ti.tname;
- Hashtbl.add used_typeinfo ti.tname ();
- ignore (visitCilType (self:>Cil.cilVisitor) ti.ttype);
- DoChildren
- end
+ (* we use the type name because direct typeinfo comparison
+ * doesn't wok. Anyway, CIL renames types if several type have the same
+ * name... *)
+ if Hashtbl.mem used_typeinfo ti.tname then SkipChildren
+ else begin
+ debug "add used typedef %s@." ti.tname;
+ Hashtbl.add used_typeinfo ti.tname ();
+ ignore (visitCilType (self:>Cil.cilVisitor) ti.ttype);
+ DoChildren
+ end
| TEnum(ei,_) ->
- if Hashtbl.mem used_enuminfo ei.ename then SkipChildren
- else begin
- debug "add used enum %s@." ei.ename;
- Hashtbl.add used_enuminfo ei.ename (); DoChildren
- end
+ if Hashtbl.mem used_enuminfo ei.ename then SkipChildren
+ else begin
+ debug "add used enum %s@." ei.ename;
+ Hashtbl.add used_enuminfo ei.ename (); DoChildren
+ end
| TComp(ci,_,_) ->
- if Hashtbl.mem used_compinfo ci.cname then SkipChildren
- else begin
- debug "add used comp %s@." ci.cname;
- Hashtbl.add used_compinfo ci.cname ();
- List.iter
- (fun f -> ignore (visitCilType (self:>Cil.cilVisitor) f.ftype))
- (Option.value ~default:[] ci.cfields);
- DoChildren
- end
+ if Hashtbl.mem used_compinfo ci.cname then SkipChildren
+ else begin
+ debug "add used comp %s@." ci.cname;
+ Hashtbl.add used_compinfo ci.cname ();
+ List.iter
+ (fun f -> ignore (visitCilType (self:>Cil.cilVisitor) f.ftype))
+ (Option.value ~default:[] ci.cfields);
+ DoChildren
+ end
| _ -> DoChildren
method! vvrbl v =
@@ -82,27 +82,27 @@ class collect_visitor = object (self)
ignore (visitCilType (self:>Cil.cilVisitor) v.vtype);
try
let init = Hashtbl.find var_init v in
- ignore (visitCilInit (self:>Cil.cilVisitor) v NoOffset init)
+ ignore (visitCilInit (self:>Cil.cilVisitor) v NoOffset init)
with Not_found -> ()
end;
DoChildren
method! vglob_aux g = match g with
| GFun (f, _) ->
- debug "add function %s@." f.svar.vname;
- Hashtbl.add used_variables f.svar ();
- Cil.DoChildren
+ debug "add function %s@." f.svar.vname;
+ Hashtbl.add used_variables f.svar ();
+ Cil.DoChildren
| GAnnot _ -> Cil.DoChildren
| GVar (v, init, _) ->
- let _ = match init.init with | None -> ()
- | Some init ->
- begin
- Hashtbl.add var_init v init;
- if Hashtbl.mem used_variables v then
- (* already used before its initialization (see bug #758) *)
- ignore (visitCilInit (self:>Cil.cilVisitor) v NoOffset init)
- end
- in Cil.SkipChildren
+ let _ = match init.init with | None -> ()
+ | Some init ->
+ begin
+ Hashtbl.add var_init v init;
+ if Hashtbl.mem used_variables v then
+ (* already used before its initialization (see bug #758) *)
+ ignore (visitCilInit (self:>Cil.cilVisitor) v NoOffset init)
+ end
+ in Cil.SkipChildren
| GFunDecl _ -> DoChildren
| _ -> Cil.SkipChildren
@@ -114,47 +114,47 @@ class filter_visitor prj = object
method! vglob_aux g =
match g with
- | GFun (_f, _loc) (* function definition *)
- -> Cil.DoChildren (* keep everything *)
- | GVar (v, _, _) (* variable definition *)
- | GVarDecl (v, _) | GFunDecl (_, v, _) -> (* variable/function declaration *)
- if Hashtbl.mem used_variables v then DoChildren
- else begin
- debug "remove var %s@." v.vname;
- ChangeTo []
- end
- | GType (ti, _loc) (* typedef *) ->
- if Hashtbl.mem used_typeinfo ti.tname then DoChildren
- else begin
- debug "remove typedef %s@." ti.tname;
- ChangeTo []
- end
- | GCompTag (ci, _loc) (* struct/union definition *)
- | GCompTagDecl (ci, _loc) (* struct/union declaration *) ->
- if Hashtbl.mem used_compinfo ci.cname then DoChildren
- else begin
- debug "remove comp %s@." ci.cname;
- ChangeTo []
- end
- | GEnumTag (ei, _loc) (* enum definition *)
- | GEnumTagDecl (ei, _loc) (* enum declaration *) ->
- if Hashtbl.mem used_enuminfo ei.ename then DoChildren
- else begin
- debug "remove enum %s@." ei.ename;
- DoChildren (* ChangeTo [] *)
- end
- | _ -> Cil.DoChildren
- end
+ | GFun (_f, _loc) (* function definition *)
+ -> Cil.DoChildren (* keep everything *)
+ | GVar (v, _, _) (* variable definition *)
+ | GVarDecl (v, _) | GFunDecl (_, v, _) -> (* variable/function declaration *)
+ if Hashtbl.mem used_variables v then DoChildren
+ else begin
+ debug "remove var %s@." v.vname;
+ ChangeTo []
+ end
+ | GType (ti, _loc) (* typedef *) ->
+ if Hashtbl.mem used_typeinfo ti.tname then DoChildren
+ else begin
+ debug "remove typedef %s@." ti.tname;
+ ChangeTo []
+ end
+ | GCompTag (ci, _loc) (* struct/union definition *)
+ | GCompTagDecl (ci, _loc) (* struct/union declaration *) ->
+ if Hashtbl.mem used_compinfo ci.cname then DoChildren
+ else begin
+ debug "remove comp %s@." ci.cname;
+ ChangeTo []
+ end
+ | GEnumTag (ei, _loc) (* enum definition *)
+ | GEnumTagDecl (ei, _loc) (* enum declaration *) ->
+ if Hashtbl.mem used_enuminfo ei.ename then DoChildren
+ else begin
+ debug "remove enum %s@." ei.ename;
+ DoChildren (* ChangeTo [] *)
+ end
+ | _ -> Cil.DoChildren
+end
module Result =
State_builder.Hashtbl
(Datatype.String.Hashtbl)
(Project.Datatype)
(struct
- let name = "Sparecode without unused globals"
- let size = 7
- let dependencies = [ Ast.self ] (* delayed, see below *)
- end)
+ let name = "Sparecode without unused globals"
+ let size = 7
+ let dependencies = [ Ast.self ] (* delayed, see below *)
+ end)
let () =
Cmdline.run_after_extended_stage
diff --git a/src/plugins/sparecode/register.ml b/src/plugins/sparecode/register.ml
index f6fb81585c6a57262e084a0530863fb3f7a815e7..a6c985c0dc8ebfa6dc8f75311a28460c62ad48b9 100644
--- a/src/plugins/sparecode/register.ml
+++ b/src/plugins/sparecode/register.ml
@@ -33,10 +33,10 @@ module Result =
(struct let module_name = "Sparecode" end))
(Project.Datatype)
(struct
- let name = "Sparecode"
- let size = 7
- let dependencies = [ Ast.self; Db.Value.self ] (* delayed, see below *)
- end)
+ let name = "Sparecode"
+ let size = 7
+ let dependencies = [ Ast.self; Db.Value.self ] (* delayed, see below *)
+ end)
let () =
Cmdline.run_after_extended_stage
@@ -65,10 +65,10 @@ let journalized_rm_unused_globals =
unjournalized_rm_unused_globals
let rm_unused_globals ?new_proj_name ?(project=Project.current ()) () =
- let new_proj_name =
- match new_proj_name with
- | Some name -> name
- | None -> (Project.get_name project)^ " (without unused globals)"
+ let new_proj_name =
+ match new_proj_name with
+ | Some name -> name
+ | None -> (Project.get_name project)^ " (without unused globals)"
in
journalized_rm_unused_globals new_proj_name project
@@ -101,9 +101,9 @@ let journalized_get =
~label2:("select_slice_pragma", None) Datatype.bool
Project.ty)
(fun select_annot select_slice_pragma ->
- Result.memo
- (fun _ -> run select_annot select_slice_pragma)
- (select_annot, select_slice_pragma))
+ Result.memo
+ (fun _ -> run select_annot select_slice_pragma)
+ (select_annot, select_slice_pragma))
(* add labels *)
let get ~select_annot ~select_slice_pragma =
diff --git a/src/plugins/sparecode/spare_marks.ml b/src/plugins/sparecode/spare_marks.ml
index c72ff8e7b3bb5f80585c69eb56751c9cc6e5003d..fb2c42242722a2fdf9e0ae9363a5cdd0ee081abb 100644
--- a/src/plugins/sparecode/spare_marks.ml
+++ b/src/plugins/sparecode/spare_marks.ml
@@ -25,8 +25,8 @@ let fatal fmt = Sparecode_params.fatal fmt
(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
(** The project is composed of [FctIndex] marked with [BoolMark]
-* to be used by [Pdg.Register.F_Proj], and another table to store if a function
-* is visible (useful for Top PDG). *)
+ * to be used by [Pdg.Register.F_Proj], and another table to store if a function
+ * is visible (useful for Top PDG). *)
(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
module BoolMark = struct
@@ -53,14 +53,14 @@ module BoolMark = struct
let combine old_m new_m =
let new_m = merge old_m new_m in
let m_to_prop = if equal old_m new_m then bottom else new_m in
- (new_m, m_to_prop)
+ (new_m, m_to_prop)
let is_bottom b = (b = bottom)
let pretty fmt (b,p) =
Format.fprintf fmt "%s(%s)"
- (if b then "true" else "false")
- (match p with Glob -> "Glob" | Loc -> "Loc")
+ (if b then "true" else "false")
+ (match p with Glob -> "Glob" | Loc -> "Loc")
end
module KfTopVisi = struct
@@ -71,50 +71,50 @@ module KfTopVisi = struct
let find proj kf = find (snd proj) kf
(** as soon as a TOP function is called, all its callees are called. *)
- let rec set proj kf =
+ let rec set proj kf =
try find proj kf
with Not_found ->
add proj kf ();
debug 1 "select '%a' as fully visible (top or called by top)"
Kernel_function.pretty kf;
let callees = Users.Users_register.get kf in
- Kernel_function.Hptset.iter (set proj) callees
+ Kernel_function.Hptset.iter (set proj) callees
let get proj kf = try find proj kf; true with Not_found -> false
end
(** when we first compute marks to select outputs,
-* we don't immediately propagate input marks to the calls,
-* because some calls may be useless and we don't want to compute
-* their inputs. We will check calls later on.
-* But when we select annotations, we want to preserve all the calls that can
-* lead to them : so, we propagate...
-* *)
+ * we don't immediately propagate input marks to the calls,
+ * because some calls may be useless and we don't want to compute
+ * their inputs. We will check calls later on.
+ * But when we select annotations, we want to preserve all the calls that can
+ * lead to them : so, we propagate...
+ * *)
let call_in_to_check = ref []
let called_top = ref []
module Config = struct
module M = BoolMark
- let mark_to_prop_to_caller_input call_opt pdg_caller sel_elem m =
- match m with
- | true, M.Glob -> Some m
- | true, M.Loc ->
- call_in_to_check :=
- (pdg_caller, call_opt, sel_elem, m) :: !call_in_to_check;
- None
- | _ -> fatal "cannot propagate invisible mark@."
-
- let mark_to_prop_to_called_output _call called_pdg =
- if PdgTypes.Pdg.is_top called_pdg then
- begin
- let kf = PdgTypes.Pdg.get_kf called_pdg in
- called_top := kf :: !called_top;
- debug 1 "memo call to TOP '%a'" Kernel_function.pretty kf;
- (fun _ _ -> None)
- end
- else
- fun _n m -> match m with
+ let mark_to_prop_to_caller_input call_opt pdg_caller sel_elem m =
+ match m with
+ | true, M.Glob -> Some m
+ | true, M.Loc ->
+ call_in_to_check :=
+ (pdg_caller, call_opt, sel_elem, m) :: !call_in_to_check;
+ None
+ | _ -> fatal "cannot propagate invisible mark@."
+
+ let mark_to_prop_to_called_output _call called_pdg =
+ if PdgTypes.Pdg.is_top called_pdg then
+ begin
+ let kf = PdgTypes.Pdg.get_kf called_pdg in
+ called_top := kf :: !called_top;
+ debug 1 "memo call to TOP '%a'" Kernel_function.pretty kf;
+ (fun _ _ -> None)
+ end
+ else
+ fun _n m -> match m with
| true, M.Glob -> Some (true, M.Loc)
| true, M.Loc -> Some m
| _ -> fatal "cannot propagate invisible mark of called function '%a'@."
@@ -136,137 +136,137 @@ let new_project () = (ProjBoolMarks.empty (), KfTopVisi.create 10)
let proj_marks proj = fst proj
(** @raise Not_found when the function is not marked. It might be the case
-* that it is nonetheless visible, but has no marks because of a Top PDG. *)
+ * that it is nonetheless visible, but has no marks because of a Top PDG. *)
let get_marks proj kf =
try KfTopVisi.find proj kf ; None
with Not_found ->
ProjBoolMarks.find_marks (proj_marks proj) (Kernel_function.get_vi kf)
(** Useful only if there has been some Pdg.Top *)
-let kf_visible proj kf =
+let kf_visible proj kf =
try KfTopVisi.find proj kf ; true
with Not_found -> get_marks proj kf <> None
let rec key_visible fm key =
try
match key with
- | PdgIndex.Key.CallStmt call_id ->
- let call = PdgIndex.Key.call_from_id call_id in
- call_visible fm call
- | _ -> let m = PdgIndex.FctIndex.find_info fm key in
- BoolMark.visible m
+ | PdgIndex.Key.CallStmt call_id ->
+ let call = PdgIndex.Key.call_from_id call_id in
+ call_visible fm call
+ | _ -> let m = PdgIndex.FctIndex.find_info fm key in
+ BoolMark.visible m
with Not_found -> false
and
(** the call is visible if its control node is visible *)
call_visible fm call =
let key = PdgIndex.Key.call_ctrl_key call in
- key_visible fm key
+ key_visible fm key
(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
(** Build selections and propagate. *)
(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
(** Doesn't mark yet, but add what has to be marked in the selection,
-* and keep things sorted. *)
+ * and keep things sorted. *)
let rec add_pdg_selection to_select pdg sel_mark = match to_select with
- | [] ->
- let l = match sel_mark with None -> [] | Some m -> [m] in [(pdg, l)]
+ | [] ->
+ let l = match sel_mark with None -> [] | Some m -> [m] in [(pdg, l)]
| (p, ln) :: tl ->
- if Db.Pdg.from_same_fun p pdg
- then
- let ln = match sel_mark with None -> ln
- | Some sel_mark -> sel_mark::ln
- in (p, ln)::tl
- else (p, ln)::(add_pdg_selection tl pdg sel_mark)
+ if Db.Pdg.from_same_fun p pdg
+ then
+ let ln = match sel_mark with None -> ln
+ | Some sel_mark -> sel_mark::ln
+ in (p, ln)::tl
+ else (p, ln)::(add_pdg_selection tl pdg sel_mark)
let add_node_to_select glob to_select z_opt node =
PdgMarks.add_node_to_select to_select (node, z_opt) (BoolMark.mk glob)
let add_nodes_and_undef_to_select
- glob (ctrl_nodes, decl_nodes, data_info) to_select =
+ glob (ctrl_nodes, decl_nodes, data_info) to_select =
match data_info with
- | None -> to_select (* don't select anything (computation failed) *)
- | Some (data_nodes, undef) ->
- let to_select =
- List.fold_left (fun s n -> add_node_to_select glob s None n)
- to_select ctrl_nodes
- in
- let to_select =
- List.fold_left (fun s n -> add_node_to_select glob s None n)
- to_select decl_nodes
- in
- let to_select =
- List.fold_left (fun s (n,z_opt) -> add_node_to_select glob s z_opt n)
- to_select data_nodes
- in
- let m = (BoolMark.mk glob) in
- let to_select = PdgMarks.add_undef_in_to_select to_select undef m in
- to_select
-
-(** Mark the function as visible
-* and add the marks according to the selection.
- Notice that if the function has been marked as called by a visible top,
- we can skip the selection since the function has to be fully visible anyway.
-**)
+ | None -> to_select (* don't select anything (computation failed) *)
+ | Some (data_nodes, undef) ->
+ let to_select =
+ List.fold_left (fun s n -> add_node_to_select glob s None n)
+ to_select ctrl_nodes
+ in
+ let to_select =
+ List.fold_left (fun s n -> add_node_to_select glob s None n)
+ to_select decl_nodes
+ in
+ let to_select =
+ List.fold_left (fun s (n,z_opt) -> add_node_to_select glob s z_opt n)
+ to_select data_nodes
+ in
+ let m = (BoolMark.mk glob) in
+ let to_select = PdgMarks.add_undef_in_to_select to_select undef m in
+ to_select
+
+(** Mark the function as visible
+ * and add the marks according to the selection.
+ Notice that if the function has been marked as called by a visible top,
+ we can skip the selection since the function has to be fully visible anyway.
+ **)
let select_pdg_elements proj pdg to_select =
let kf = PdgTypes.Pdg.get_kf pdg in
- try KfTopVisi.find proj kf;
- debug 1 "function '%a' selected for top: skip selection"
- Kernel_function.pretty kf
- with Not_found ->
- debug 1 "add selection in function '%a'@." Kernel_function.pretty kf;
- ProjBoolMarks.mark_and_propagate (proj_marks proj) pdg to_select;
- List.iter (KfTopVisi.set proj) !called_top;
- called_top := []
+ try KfTopVisi.find proj kf;
+ debug 1 "function '%a' selected for top: skip selection"
+ Kernel_function.pretty kf
+ with Not_found ->
+ debug 1 "add selection in function '%a'@." Kernel_function.pretty kf;
+ ProjBoolMarks.mark_and_propagate (proj_marks proj) pdg to_select;
+ List.iter (KfTopVisi.set proj) !called_top;
+ called_top := []
(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
(** First step is finished: propagate in the calls. *)
(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
(** [proj] contains some function marks and [!call_in_to_check]
-* is a list of call input marks to propagate when the call is visible.
-* These marks come from the called function selection,
-* but they are not automatically propagated because when a function is visible
-* it doesn't mean that all the calls to that function are visible.
-*
-* So we first split the todo list ([!call_in_to_check]) into the nodes to mark
-* which correspond to inputs of visible calls
-* and the others that do not yet correspond to visible call
-* but we keep them because it can happen later *)
+ * is a list of call input marks to propagate when the call is visible.
+ * These marks come from the called function selection,
+ * but they are not automatically propagated because when a function is visible
+ * it doesn't mean that all the calls to that function are visible.
+ *
+ * So we first split the todo list ([!call_in_to_check]) into the nodes to mark
+ * which correspond to inputs of visible calls
+ * and the others that do not yet correspond to visible call
+ * but we keep them because it can happen later *)
let rec process_call_inputs proj =
let rec process (to_select, unused) todo = match todo with
| [] -> (to_select, unused)
| (pdg_caller, call, sel, m) as e :: calls ->
- let kf_caller = PdgTypes.Pdg.get_kf pdg_caller in
- let visible, select = match call with
- | Some call ->
-
- let visible = match get_marks proj kf_caller with
- | None -> (* the caller have no marks! *)
- debug 1 "the caller '%a' is a spare function"
- Kernel_function.pretty kf_caller;
- false
- | Some fm -> call_visible fm call
- in visible, Some (sel, m)
- | None -> (* let see if the function is visible or not *)
- assert (PdgTypes.Pdg.is_top pdg_caller);
- KfTopVisi.get proj kf_caller, None
- in
- let res = if visible then
- let to_select = add_pdg_selection to_select pdg_caller select
- in (to_select, unused)
- else (to_select, e::unused)
- in process res calls
+ let kf_caller = PdgTypes.Pdg.get_kf pdg_caller in
+ let visible, select = match call with
+ | Some call ->
+
+ let visible = match get_marks proj kf_caller with
+ | None -> (* the caller have no marks! *)
+ debug 1 "the caller '%a' is a spare function"
+ Kernel_function.pretty kf_caller;
+ false
+ | Some fm -> call_visible fm call
+ in visible, Some (sel, m)
+ | None -> (* let see if the function is visible or not *)
+ assert (PdgTypes.Pdg.is_top pdg_caller);
+ KfTopVisi.get proj kf_caller, None
+ in
+ let res = if visible then
+ let to_select = add_pdg_selection to_select pdg_caller select
+ in (to_select, unused)
+ else (to_select, e::unused)
+ in process res calls
in
let to_select, new_list = process ([], []) !call_in_to_check in
- match to_select with
- | [] -> call_in_to_check := []
- (* nothing more to mark : finished ! we can forget [new_list] *)
- | _ ->
- call_in_to_check := new_list;
- List.iter (fun (pdg, sel) -> select_pdg_elements proj pdg sel)
- to_select;
- process_call_inputs proj
+ match to_select with
+ | [] -> call_in_to_check := []
+ (* nothing more to mark : finished ! we can forget [new_list] *)
+ | _ ->
+ call_in_to_check := new_list;
+ List.iter (fun (pdg, sel) -> select_pdg_elements proj pdg sel)
+ to_select;
+ process_call_inputs proj
(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
(** Main selection: select starting points and propagate. *)
@@ -275,11 +275,11 @@ let rec process_call_inputs proj =
let select_entry_point proj _kf pdg =
let ctrl = !Db.Pdg.find_entry_point_node pdg in
let to_select = add_node_to_select true [] None ctrl in
- select_pdg_elements proj pdg to_select
+ select_pdg_elements proj pdg to_select
let select_all_outputs proj kf pdg =
let outputs = !Db.Outputs.get_external kf in
- debug 1 "@[selecting output zones %a@]" Locations.Zone.pretty outputs;
+ debug 1 "@[selecting output zones %a@]" Locations.Zone.pretty outputs;
try
let nodes, undef = !Db.Pdg.find_location_nodes_at_end pdg outputs in
let nodes =
@@ -288,7 +288,7 @@ let select_all_outputs proj kf pdg =
in
let nodes_and_co = ([], [], Some (nodes, undef)) in
let to_select = add_nodes_and_undef_to_select false nodes_and_co [] in
- select_pdg_elements proj pdg to_select
+ select_pdg_elements proj pdg to_select
with Not_found -> (* end is unreachable *) ()
(** used to visit all the annotations of a given function
@@ -304,18 +304,18 @@ class annot_visitor ~filter pdg = object (self)
method! vcode_annot annot =
let () =
if filter annot then
- try
- let stmt = Option.get self#current_stmt in
- debug 1 "selecting annotation : %a @."
- Printer.pp_code_annotation annot;
- let info = !Db.Pdg.find_code_annot_nodes pdg stmt annot in
+ try
+ let stmt = Option.get self#current_stmt in
+ debug 1 "selecting annotation : %a @."
+ Printer.pp_code_annotation annot;
+ let info = !Db.Pdg.find_code_annot_nodes pdg stmt annot in
to_select <- add_nodes_and_undef_to_select true info to_select
- with
- Not_found -> () (* unreachable *)
- | Logic_interp.To_zone.NYI _ ->
- Sparecode_params.warning ~current:true ~once:true
- "Dropping annotation";
- ()
+ with
+ Not_found -> () (* unreachable *)
+ | Logic_interp.To_zone.NYI _ ->
+ Sparecode_params.warning ~current:true ~once:true
+ "Dropping annotation";
+ ()
in Cil.SkipChildren
end
@@ -323,29 +323,29 @@ let select_annotations ~select_annot ~select_slice_pragma proj =
let visit_fun kf =
debug 1 "look for annotations in function %a@." Kernel_function.pretty kf;
let pdg = !Db.Pdg.get kf in
- if PdgTypes.Pdg.is_top pdg then debug 1 "pdg top: skip annotations"
- else if PdgTypes.Pdg.is_bottom pdg
- then debug 1 "pdg bottom: skip annotations"
- else begin
- let filter annot = match annot.Cil_types.annot_content with
- | Cil_types.APragma (Cil_types.Slice_pragma _) -> select_slice_pragma
- | Cil_types.AAssert _-> (* Never select alarms, they are not useful *)
- (match Alarms.find annot with
- | None -> select_annot
- | Some _ -> false)
- | _ -> select_annot
- in
- try
- let f = Kernel_function.get_definition kf in
- let visit = new annot_visitor ~filter pdg in
- let fc_visit = (visit:>Visitor.frama_c_visitor) in
- let _ = Visitor.visitFramacFunction fc_visit f in
- let to_select = visit#get_select in
- if to_select <> [] then select_pdg_elements proj pdg to_select
- with Kernel_function.No_Definition -> () (* nothing to do *)
- end
+ if PdgTypes.Pdg.is_top pdg then debug 1 "pdg top: skip annotations"
+ else if PdgTypes.Pdg.is_bottom pdg
+ then debug 1 "pdg bottom: skip annotations"
+ else begin
+ let filter annot = match annot.Cil_types.annot_content with
+ | Cil_types.APragma (Cil_types.Slice_pragma _) -> select_slice_pragma
+ | Cil_types.AAssert _-> (* Never select alarms, they are not useful *)
+ (match Alarms.find annot with
+ | None -> select_annot
+ | Some _ -> false)
+ | _ -> select_annot
+ in
+ try
+ let f = Kernel_function.get_definition kf in
+ let visit = new annot_visitor ~filter pdg in
+ let fc_visit = (visit:>Visitor.frama_c_visitor) in
+ let _ = Visitor.visitFramacFunction fc_visit f in
+ let to_select = visit#get_select in
+ if to_select <> [] then select_pdg_elements proj pdg to_select
+ with Kernel_function.No_Definition -> () (* nothing to do *)
+ end
in
- Globals.Functions.iter visit_fun
+ Globals.Functions.iter visit_fun
let finalize proj =
debug 1 "finalize call input propagation@.";
@@ -355,20 +355,20 @@ let finalize proj =
let select_useful_things ~select_annot ~select_slice_pragma kf_entry =
let proj = new_project () in
assert (!call_in_to_check = []);
- debug 1 "selecting function %a outputs and entry point@."
- Kernel_function.pretty kf_entry;
+ debug 1 "selecting function %a outputs and entry point@."
+ Kernel_function.pretty kf_entry;
let pdg = !Db.Pdg.get kf_entry in
- if PdgTypes.Pdg.is_top pdg
- then KfTopVisi.set proj kf_entry
- else if PdgTypes.Pdg.is_bottom pdg
- then debug 1 "unreachable entry point ?"
- else begin
- select_entry_point proj kf_entry pdg;
- select_all_outputs proj kf_entry pdg;
- if (select_annot || select_slice_pragma) then
- select_annotations ~select_annot ~select_slice_pragma proj;
- finalize proj
- end;
+ if PdgTypes.Pdg.is_top pdg
+ then KfTopVisi.set proj kf_entry
+ else if PdgTypes.Pdg.is_bottom pdg
+ then debug 1 "unreachable entry point ?"
+ else begin
+ select_entry_point proj kf_entry pdg;
+ select_all_outputs proj kf_entry pdg;
+ if (select_annot || select_slice_pragma) then
+ select_annotations ~select_annot ~select_slice_pragma proj;
+ finalize proj
+ end;
proj
(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
diff --git a/src/plugins/sparecode/sparecode_params.ml b/src/plugins/sparecode/sparecode_params.ml
index cc9393966663c1f80bb1860db002930f5f7dd336..ab502a62b9b45ae5b75e004c6c64fa9ae63a87b2 100644
--- a/src/plugins/sparecode/sparecode_params.ml
+++ b/src/plugins/sparecode/sparecode_params.ml
@@ -21,24 +21,24 @@
(**************************************************************************)
include Plugin.Register
- (struct
- let name = "sparecode"
- let shortname = "sparecode"
- let help = "code cleaner"
- end)
+ (struct
+ let name = "sparecode"
+ let shortname = "sparecode"
+ let help = "code cleaner"
+ end)
module Analysis =
False(struct
- let option_name = "-sparecode"
- let help = "perform a spare code analysis"
- end)
+ let option_name = "-sparecode"
+ let help = "perform a spare code analysis"
+ end)
let () = Analysis.add_aliases ["-sparecode-analysis"]
module Annot =
True(struct
- let option_name = "-sparecode-annot"
- let help = "select more things to keep every reachable annotation"
- end)
+ let option_name = "-sparecode-annot"
+ let help = "select more things to keep every reachable annotation"
+ end)
module GlobDecl =
False(struct
diff --git a/src/plugins/sparecode/sparecode_params.mli b/src/plugins/sparecode/sparecode_params.mli
index 8e71b62d80d9adf1c337240de3accf787aa6334d..05bce525f11c5f4d48ddefa2a3b7a3411d47f517 100644
--- a/src/plugins/sparecode/sparecode_params.mli
+++ b/src/plugins/sparecode/sparecode_params.mli
@@ -29,7 +29,7 @@ module Annot : Parameter_sig.Bool
(** keep more things to keep all reachable annotations. *)
module GlobDecl : Parameter_sig.Bool
- (** remove unused global types and variables *)
+(** remove unused global types and variables *)
(*
Local Variables:
diff --git a/src/plugins/sparecode/transform.ml b/src/plugins/sparecode/transform.ml
index 4faf0e40d73832051a4b22f871e3fb642ab426df..ce447c3fb94eecd147f1fd0adf0f111c4854a471 100644
--- a/src/plugins/sparecode/transform.ml
+++ b/src/plugins/sparecode/transform.ml
@@ -32,25 +32,25 @@ module BoolInfo = struct
let fct_info project kf =
match Spare_marks.get_marks project kf with
- | None ->
- if Spare_marks.kf_visible project kf then [None, kf] else []
- | Some fm -> [Some fm, kf]
+ | None ->
+ if Spare_marks.kf_visible project kf then [None, kf] else []
+ | Some fm -> [Some fm, kf]
let key_visible txt fm key =
let visible = match fm with None -> true
- | Some fm -> Spare_marks.key_visible fm key
+ | Some fm -> Spare_marks.key_visible fm key
in
- Sparecode_params.debug ~level:3 "%s : %a -> %b"
+ Sparecode_params.debug ~level:3 "%s : %a -> %b"
txt !Db.Pdg.pretty_key key visible;
visible
let param_visible (fm,_) n =
let key = PdgIndex.Key.param_key n in
- key_visible "param_visible" fm key
+ key_visible "param_visible" fm key
let loc_var_visible (fm,_) var =
let key = PdgIndex.Key.decl_var_key var in
- key_visible "loc_var_visible" fm key
+ key_visible "loc_var_visible" fm key
let term_visible (fm,kf) t =
let module M = struct exception Invisible end in
@@ -58,59 +58,59 @@ module BoolInfo = struct
inherit Visitor.frama_c_inplace
method! vlogic_var_use v =
match v.lv_origin with
- | None -> DoChildren
- | Some v when v.vformal ->
- let n_param = Kernel_function.get_formal_position v kf + 1 in
- if not (param_visible (fm,kf) n_param)
- then raise M.Invisible
- else DoChildren
- | Some v when not v.vglob ->
- if not (loc_var_visible (fm, kf) v)
- then raise M.Invisible
- else DoChildren
- | Some _ -> DoChildren
+ | None -> DoChildren
+ | Some v when v.vformal ->
+ let n_param = Kernel_function.get_formal_position v kf + 1 in
+ if not (param_visible (fm,kf) n_param)
+ then raise M.Invisible
+ else DoChildren
+ | Some v when not v.vglob ->
+ if not (loc_var_visible (fm, kf) v)
+ then raise M.Invisible
+ else DoChildren
+ | Some _ -> DoChildren
end
in
- try ignore (Visitor.visitFramacTerm visitor t); true
- with M.Invisible -> false
+ try ignore (Visitor.visitFramacTerm visitor t); true
+ with M.Invisible -> false
let body_visible _fm = true
let label_visible (fm,_) stmt label =
let lab_key = PdgIndex.Key.label_key stmt label in
- key_visible "label_visible" fm lab_key
+ key_visible "label_visible" fm lab_key
let annotation_visible _ stmt annot =
Db.Value.is_reachable_stmt stmt && Alarms.find annot = None
- (* Keep annotations on reachable, but not alarms: they can be resynthesized,
- and the alarms table is not synchronized in the new project anyway *)
- (* TODO: does not seem really coherent with the fact that almost everything
- else in the logic is cleared... *)
+ (* Keep annotations on reachable, but not alarms: they can be resynthesized,
+ and the alarms table is not synchronized in the new project anyway *)
+ (* TODO: does not seem really coherent with the fact that almost everything
+ else in the logic is cleared... *)
let fun_precond_visible _ _p =
(* TODO : we say that they are removed in order to get correct results,
- * but in fact, we should select them ! *)
+ * but in fact, we should select them ! *)
false
let fun_postcond_visible _ _p =
(* TODO : we say that they are removed in order to get correct results,
- * but in fact, we should select them ! *)
+ * but in fact, we should select them ! *)
false
let fun_variant_visible _ _p =
(* TODO : we say that they are removed in order to get correct results,
- * but in fact, we should select them ! *)
+ * but in fact, we should select them ! *)
false
- let fun_frees_visible _ _b =
+ let fun_frees_visible _ _b =
(* TODO : we say that they are removed in order to get correct results,
- * but in fact, we should select them ! *)
+ * but in fact, we should select them ! *)
false
let fun_allocates_visible _ _b =
(* TODO : we say that they are removed in order to get correct results,
- * but in fact, we should select them ! *)
+ * but in fact, we should select them ! *)
false
-
+
let fun_assign_visible fm_kf (b,_) =
(* [VP 2011-02-01] Removing all assigns is incorrect! this would lead
to say assigns \nothing for all functions. *)
@@ -120,35 +120,35 @@ module BoolInfo = struct
let res_call_visible (fm,_) call_stmt =
let key = PdgIndex.Key.call_outret_key call_stmt in
- key_visible "res_call_visible" fm key
+ key_visible "res_call_visible" fm key
- let called_info (project, _fm) call_stmt =
+ let called_info (project, _fm) call_stmt =
match call_stmt.skind with
- | Instr (Call (_, _, _, _) | Local_init(_, ConsInit _, _)) ->
- let called_functions = Db.Value.call_to_kernel_function call_stmt in
- let call_info =
- match
- Kernel_function.Hptset.contains_single_elt called_functions
- with
- | None -> None
- | Some kf ->
- match Spare_marks.get_marks project kf with
- | None ->
- if Spare_marks.kf_visible project kf
- then Some (kf, (None,kf))
- else None
- | Some fm -> Some (kf, (Some fm,kf))
- in call_info
- | _ -> Sparecode_params.fatal "this call is not a call"
+ | Instr (Call (_, _, _, _) | Local_init(_, ConsInit _, _)) ->
+ let called_functions = Db.Value.call_to_kernel_function call_stmt in
+ let call_info =
+ match
+ Kernel_function.Hptset.contains_single_elt called_functions
+ with
+ | None -> None
+ | Some kf ->
+ match Spare_marks.get_marks project kf with
+ | None ->
+ if Spare_marks.kf_visible project kf
+ then Some (kf, (None,kf))
+ else None
+ | Some fm -> Some (kf, (Some fm,kf))
+ in call_info
+ | _ -> Sparecode_params.fatal "this call is not a call"
let inst_visible (fm,_) stmt =
match stmt.Cil_types.skind with
| Cil_types.Block _ -> (* block are always visible for syntactic reasons *)
- true
- | _ ->
- let stmt_key = PdgIndex.Key.stmt_key stmt in
- key_visible "inst_visible" fm stmt_key
+ true
+ | _ ->
+ let stmt_key = PdgIndex.Key.stmt_key stmt in
+ key_visible "inst_visible" fm stmt_key
let fct_name v _fm = v.Cil_types.vname
diff --git a/src/plugins/studia/Studia.mli b/src/plugins/studia/Studia.mli
index 0a60a3dc63668b1c97a0f3b1973a413bcc6cc80b..e0ad49e5f26e6cf2e74051d101183f8075ebfd05 100644
--- a/src/plugins/studia/Studia.mli
+++ b/src/plugins/studia/Studia.mli
@@ -28,7 +28,7 @@ module Writes: sig
indirectly (through the effects of a call) otherwise. *)
type effects = {
direct: bool (** Direct affectation [lv = ...], or modification through
- a call to a leaf function. *);
+ a call to a leaf function. *);
indirect: bool (** Modification inside the body of called function
[f(...)]*);
}
diff --git a/src/plugins/studia/options.ml b/src/plugins/studia/options.ml
index fe49c4960b64c529f6b15715b262ad646ebe674d..bf6b7f86d04df637d8264e03ac4df2125b498280 100644
--- a/src/plugins/studia/options.ml
+++ b/src/plugins/studia/options.ml
@@ -23,10 +23,10 @@
include
Plugin.Register
(struct
- let name = "Studia"
- let shortname = "studia"
- let help = "Tools for Eva case studies"
- end)
+ let name = "Studia"
+ let shortname = "studia"
+ let help = "Tools for Eva case studies"
+ end)
diff --git a/src/plugins/studia/studia_gui.ml b/src/plugins/studia/studia_gui.ml
index c5b4df28f3b23c8d82aa47f1fbafc3e2b9ca52fb..9008db351027fc01dcfd385aba799782e8a4f718 100644
--- a/src/plugins/studia/studia_gui.ml
+++ b/src/plugins/studia/studia_gui.ml
@@ -40,14 +40,14 @@ let ask_for_lval (main_ui:Design.main_window_extension_points) kf =
~title:"Input lvalue expression" ""
in
match txt with None | Some "" -> None
- | Some txt ->
- try
- let term_lval = !Db.Properties.Interp.term_lval kf txt in
- Some (txt, term_lval)
- with e ->
- main_ui#error "[ask for lval] '%s' invalid expression: %s@."
- txt (Printexc.to_string e);
- None
+ | Some txt ->
+ try
+ let term_lval = !Db.Properties.Interp.term_lval kf txt in
+ Some (txt, term_lval)
+ with e ->
+ main_ui#error "[ask for lval] '%s' invalid expression: %s@."
+ txt (Printexc.to_string e);
+ None
(** [kf_stmt_opt] is used if we want to ask the lval to the user in a popup *)
let get_lval_opt main_ui kf localizable =
@@ -71,45 +71,45 @@ let eval_tlval =
module Kfs_containing_highlighted_stmt =
Kernel_function.Make_Table
- (Datatype.String.Set)
- (struct
- let name = "Studia.Kf_containing_highlighted_stmt"
- let size = 7
- let dependencies =
- [ (*Dependencies are managed manually by Make_StmtSetState*) ]
- end)
+ (Datatype.String.Set)
+ (struct
+ let name = "Studia.Kf_containing_highlighted_stmt"
+ let size = 7
+ let dependencies =
+ [ (*Dependencies are managed manually by Make_StmtSetState*) ]
+ end)
let default_icon_name = "gtk-apply"
let default_icon = Datatype.String.Set.singleton default_icon_name
module Make_StmtMapState (Info:sig val name: string end) =
- struct
- module D = Datatype
- include State_builder.Ref
- (Stmt.Map.Make(Datatype.String.Set))
- (struct
- let name = Info.name
- let dependencies = [ Db.Value.self ]
- let default () = Stmt.Map.empty
- end)
-
- let set s =
- set s;
- Kfs_containing_highlighted_stmt.clear ();
- Stmt.Map.iter
- (fun stmt s ->
+struct
+ module D = Datatype
+ include State_builder.Ref
+ (Stmt.Map.Make(Datatype.String.Set))
+ (struct
+ let name = Info.name
+ let dependencies = [ Db.Value.self ]
+ let default () = Stmt.Map.empty
+ end)
+
+ let set s =
+ set s;
+ Kfs_containing_highlighted_stmt.clear ();
+ Stmt.Map.iter
+ (fun stmt s ->
let kf = Kernel_function.find_englobing_kf stmt in
let prev =
try Kfs_containing_highlighted_stmt.find kf
with Not_found -> D.String.Set.empty
in
let union = D.String.Set.union prev s in
- Kfs_containing_highlighted_stmt.replace kf union)
- s;
- !update_column `Contents
+ Kfs_containing_highlighted_stmt.replace kf union)
+ s;
+ !update_column `Contents
- end
+end
(*
module type StudiaCmdSig = sig
@@ -134,11 +134,11 @@ struct
let clear () = State.clear()
let help_writes = ("[writes] "
- ^"highlight the statements that writes to the location pointed to \
- by D at L")
+ ^"highlight the statements that writes to the location pointed to \
+ by D at L")
let help_reads = ("[reads] "
- ^"highlight the statements that reads the location pointed to \
- by D at L")
+ ^"highlight the statements that reads the location pointed to \
+ by D at L")
let indirect_icon = Datatype.String.Set.singleton "gtk-jump-to"
@@ -161,8 +161,8 @@ struct
in
Options.feedback "%s computed" s;
match r with
- | [] -> clear (); s ^ " computed; no statement found."
- | defs -> State.set (conv defs); s ^ " computed"
+ | [] -> clear (); s ^ " computed; no statement found."
+ | defs -> State.set (conv defs); s ^ " computed"
let tag_stmt stmt =
try
@@ -183,9 +183,9 @@ module StudiaState =
State_builder.Option_ref
(Stmt)
(struct
- let name = "Studia.Highlighter.StudiaState"
- let dependencies = [ Db.Value.self ]
- end)
+ let name = "Studia.Highlighter.StudiaState"
+ let dependencies = [ Db.Value.self ]
+ end)
let reset () =
StudiaState.clear ();
@@ -227,23 +227,23 @@ let highlighter (buffer:Design.reactive_buffer) localizable ~start ~stop =
let check_value (main_ui:Design.main_window_extension_points) =
Db.Value.is_computed () ||
- let answer = GToolbox.question_box
+ let answer = GToolbox.question_box
~title:("Eva Needed")
~buttons:[ "Run"; "Cancel" ]
("Eva has to be run first.\nThis can take some time.\n"
^"Do you want to run Eva now ?")
- in
- answer = 1 &&
- match main_ui#full_protect ~cancelable:true !Db.Value.compute with
- | Some _ -> true
- | None -> false
+ in
+ answer = 1 &&
+ match main_ui#full_protect ~cancelable:true !Db.Value.compute with
+ | Some _ -> true
+ | None -> false
(** To add a sensitive/unsensitive menu item to a [factory].
The menu item is insensitive when [arg_opt = None],
else, when the item is selected, the callback is called with the argument.
If [uses_value] is true, check if the value analysis has been computed.
- *)
+*)
let add_item (main_ui:Design.main_window_extension_points) ~uses_value menu name arg_opt callback =
(* add the menu item *)
let item = GMenu.menu_item ~label:name () in
@@ -276,8 +276,8 @@ let add_item (main_ui:Design.main_window_extension_points) ~uses_value menu name
else false))
let selector (popup_factory:GMenu.menu GMenu.factory)
- (main_ui:Design.main_window_extension_points)
- ~button localizable =
+ (main_ui:Design.main_window_extension_points)
+ ~button localizable =
if button = 3 then begin
let submenu = popup_factory#add_submenu "Studia" in
let submenu_factory = new GMenu.factory submenu in
@@ -290,7 +290,7 @@ let selector (popup_factory:GMenu.menu GMenu.factory)
let add_menu_item name callback =
add_item main_ui ~uses_value:true submenu name arg
(fun arg ->
- main_ui#protect ~cancelable:true (fun () -> callback main_ui arg))
+ main_ui#protect ~cancelable:true (fun () -> callback main_ui arg))
in
add_menu_item "Writes" (callback `Writes);
add_menu_item "Reads" (callback `Reads);
@@ -302,42 +302,42 @@ let selector (popup_factory:GMenu.menu GMenu.factory)
"Help" (Some()) (fun _ -> help main_ui) ;
end
-let filetree_decorate main_ui =
+let filetree_decorate main_ui =
main_ui#file_tree#append_pixbuf_column
~title:"Studia"
(fun globs ->
- let icons = function
- | GFun ({svar = v }, _) ->
- (try Kfs_containing_highlighted_stmt.find (Globals.Functions.get v)
- with Not_found -> Datatype.String.Set.empty)
- | _ -> Datatype.String.Set.empty
- in
- let ids =
- if Kfs_containing_highlighted_stmt.length () <> 0 then
- let icons = List.fold_left
- (fun acc glob -> Datatype.String.Set.union (icons glob) acc)
- Datatype.String.Set.empty globs
- in
- if Datatype.String.Set.is_empty icons
- then Datatype.String.Set.singleton ""
- else icons
- else
- Datatype.String.Set.singleton ""
- in
- let icons =
- if Datatype.String.Set.mem default_icon_name ids then
- [default_icon_name]
- else
- Datatype.String.Set.elements
- (Datatype.String.Set.remove default_icon_name ids)
- in
- List.map (fun icon -> `STOCK_ID icon) icons
+ let icons = function
+ | GFun ({svar = v }, _) ->
+ (try Kfs_containing_highlighted_stmt.find (Globals.Functions.get v)
+ with Not_found -> Datatype.String.Set.empty)
+ | _ -> Datatype.String.Set.empty
+ in
+ let ids =
+ if Kfs_containing_highlighted_stmt.length () <> 0 then
+ let icons = List.fold_left
+ (fun acc glob -> Datatype.String.Set.union (icons glob) acc)
+ Datatype.String.Set.empty globs
+ in
+ if Datatype.String.Set.is_empty icons
+ then Datatype.String.Set.singleton ""
+ else icons
+ else
+ Datatype.String.Set.singleton ""
+ in
+ let icons =
+ if Datatype.String.Set.mem default_icon_name ids then
+ [default_icon_name]
+ else
+ Datatype.String.Set.elements
+ (Datatype.String.Set.remove default_icon_name ids)
+ in
+ List.map (fun icon -> `STOCK_ID icon) icons
)
(fun _ -> Kfs_containing_highlighted_stmt.length () <> 0)
-
+
let main main_ui =
main_ui#register_source_selector selector;
main_ui#register_source_highlighter highlighter;
update_column := (filetree_decorate main_ui)
-
+
let () = Design.register_extension main
diff --git a/src/plugins/studia/studia_gui.mli b/src/plugins/studia/studia_gui.mli
index 676dc9b6fa4483a8132c3939540f520efd3df9dc..cce51dc83ef23f10bb7ed95d5a93dfc632b91896 100644
--- a/src/plugins/studia/studia_gui.mli
+++ b/src/plugins/studia/studia_gui.mli
@@ -19,4 +19,3 @@
(* for more details (enclosed in the file licenses/LGPLv2.1). *)
(* *)
(**************************************************************************)
-
diff --git a/src/plugins/users/users_register.ml b/src/plugins/users/users_register.ml
index 665ad85911ef9816a572ba93daefd5867ae6949e..f556af9526d47558f4ee79c364b2a0db5cb08162 100644
--- a/src/plugins/users/users_register.ml
+++ b/src/plugins/users/users_register.ml
@@ -25,46 +25,46 @@
include
Plugin.Register
(struct
- let name = "users"
- let shortname = "users"
- let help = "function callees"
- end)
+ let name = "users"
+ let shortname = "users"
+ let help = "function callees"
+ end)
(** @plugin development guide *)
module ForceUsers =
False
(struct
- let option_name = "-users"
- let help = "compute function callees"
- end)
+ let option_name = "-users"
+ let help = "compute function callees"
+ end)
module Users =
Kernel_function.Make_Table
(Kernel_function.Hptset)
(struct
- let name = "Users"
- let size = 17
- let dependencies = [ Db.Value.self; ForceUsers.self ]
- end)
+ let name = "Users"
+ let size = 17
+ let dependencies = [ Db.Value.self; ForceUsers.self ]
+ end)
let call_for_users (_state, call_stack) =
match call_stack with
| [] -> assert false
| (current_function, _call_site) :: tail ->
- if tail = [] then begin
- (* End of Value analysis, we record that Users has run. We should not
- do this after the explicit call to Db.Value.compute later in this
- file, as Value can run on its own and execute Users while doing so.*)
- Users.mark_as_computed ()
- end;
- let treat_element (user, _call_site) =
- ignore
- (Users.memo
- ~change:(Kernel_function.Hptset.add current_function)
- (fun _ -> Kernel_function.Hptset.singleton current_function)
- user)
- in
- List.iter treat_element tail
+ if tail = [] then begin
+ (* End of Value analysis, we record that Users has run. We should not
+ do this after the explicit call to Db.Value.compute later in this
+ file, as Value can run on its own and execute Users while doing so.*)
+ Users.mark_as_computed ()
+ end;
+ let treat_element (user, _call_site) =
+ ignore
+ (Users.memo
+ ~change:(Kernel_function.Hptset.add current_function)
+ (fun _ -> Kernel_function.Hptset.singleton current_function)
+ user)
+ in
+ List.iter treat_element tail
let add_value_hook () = Db.Value.Call_Value_Callbacks.extend_once call_for_users
@@ -82,7 +82,7 @@ let get kf =
if Db.Value.is_computed () then begin
feedback "requiring again the computation of the value analysis";
Project.clear
- ~selection:(State_selection.with_dependencies Db.Value.self)
+ ~selection:(State_selection.with_dependencies Db.Value.self)
()
end else
feedback ~level:2 "requiring the computation of the value analysis";
@@ -99,19 +99,19 @@ let get =
let print () =
if ForceUsers.get () then
- result "@[<v>====== DISPLAYING USERS ======@ %t\
- ====== END OF USERS =========="
- (fun fmt ->
- Callgraph.Uses.iter_in_rev_order
- (fun kf ->
- let callees = get kf in
- if not (Kernel_function.Hptset.is_empty callees) then
- Format.fprintf fmt "@[<hov 4>%a: %a@]@ "
- Kernel_function.pretty kf
- (Pretty_utils.pp_iter
- ~pre:"" ~sep:"@ " ~suf:"" Kernel_function.Hptset.iter
- Kernel_function.pretty)
- callees))
+ result "@[<v>====== DISPLAYING USERS ======@ %t\
+ ====== END OF USERS =========="
+ (fun fmt ->
+ Callgraph.Uses.iter_in_rev_order
+ (fun kf ->
+ let callees = get kf in
+ if not (Kernel_function.Hptset.is_empty callees) then
+ Format.fprintf fmt "@[<hov 4>%a: %a@]@ "
+ Kernel_function.pretty kf
+ (Pretty_utils.pp_iter
+ ~pre:"" ~sep:"@ " ~suf:"" Kernel_function.Hptset.iter
+ Kernel_function.pretty)
+ callees))
let print_once, _self_print =
State_builder.apply_once "Users_register.print" [ Users.self ] print
diff --git a/src/plugins/value_types/cilE.mli b/src/plugins/value_types/cilE.mli
index f649b3afaec0933f38dca69a78d1c427d9ec9f27..95228912315e94e32ea5f51013b56057a735e113 100644
--- a/src/plugins/value_types/cilE.mli
+++ b/src/plugins/value_types/cilE.mli
@@ -33,20 +33,20 @@ type alarm_behavior = unit -> unit
val a_ignore: alarm_behavior
type warn_mode =
- { defined_logic: alarm_behavior
- (** operations that raise an error only in the C, not in the logic *);
- unspecified: alarm_behavior (** defined but unspecified behaviors *);
- others: alarm_behavior (** all the remaining undefined behaviors *);
- }
- (** An argument of type [warn_mode] can be supplied to some of the access
- functions in {!Db.Value} (the interface to the value analysis).
- Each field of {!warn_mode} indicates the action to perform
- for each category of alarm. These fields are not completely fixed
- yet. However, you can use the value {!warn_none_mode} below
- when you have to provide an argument of type [warn_mode]. *)
+ { defined_logic: alarm_behavior
+ (** operations that raise an error only in the C, not in the logic *);
+ unspecified: alarm_behavior (** defined but unspecified behaviors *);
+ others: alarm_behavior (** all the remaining undefined behaviors *);
+ }
+(** An argument of type [warn_mode] can be supplied to some of the access
+ functions in {!Db.Value} (the interface to the value analysis).
+ Each field of {!warn_mode} indicates the action to perform
+ for each category of alarm. These fields are not completely fixed
+ yet. However, you can use the value {!warn_none_mode} below
+ when you have to provide an argument of type [warn_mode]. *)
val warn_none_mode : warn_mode
- (** Do not emit any message. *)
+(** Do not emit any message. *)
(*
Local Variables:
diff --git a/src/plugins/value_types/function_Froms.ml b/src/plugins/value_types/function_Froms.ml
index 1828c61c02b8a292deb31a79b03a486f8d06ec1a..143f5fb48cbb60662b290dd563ecc815db6454ce 100644
--- a/src/plugins/value_types/function_Froms.ml
+++ b/src/plugins/value_types/function_Froms.ml
@@ -22,7 +22,7 @@
open Locations
-module Deps =
+module Deps =
struct
type deps = {
@@ -33,35 +33,35 @@ struct
let to_zone {data; indirect} = Zone.join data indirect
module DatatypeFromDeps = Datatype.Make(struct
- type t = deps
+ type t = deps
- let name = "Function_Froms.Deps.from_deps"
+ let name = "Function_Froms.Deps.from_deps"
- let hash fd =
- Zone.hash fd.data + 37 * Zone.hash fd.indirect
+ let hash fd =
+ Zone.hash fd.data + 37 * Zone.hash fd.indirect
- let compare fd1 fd2 =
- let c = Zone.compare fd1.data fd2.data in
- if c <> 0 then c
- else Zone.compare fd1.indirect fd2.indirect
+ let compare fd1 fd2 =
+ let c = Zone.compare fd1.data fd2.data in
+ if c <> 0 then c
+ else Zone.compare fd1.indirect fd2.indirect
- let equal = Datatype.from_compare
+ let equal = Datatype.from_compare
- let pretty fmt d = Zone.pretty fmt (to_zone d)
+ let pretty fmt d = Zone.pretty fmt (to_zone d)
- let reprs =
- List.map (fun z -> {data = z; indirect = z}) Zone.reprs
+ let reprs =
+ List.map (fun z -> {data = z; indirect = z}) Zone.reprs
- let structural_descr =
- Structural_descr.t_record [| Zone.packed_descr; Zone.packed_descr; |]
- let rehash = Datatype.identity
+ let structural_descr =
+ Structural_descr.t_record [| Zone.packed_descr; Zone.packed_descr; |]
+ let rehash = Datatype.identity
- let mem_project = Datatype.never_any_project
- let varname _ = "da"
+ let mem_project = Datatype.never_any_project
+ let varname _ = "da"
- let internal_pretty_code = Datatype.undefined
- let copy = Datatype.undefined
- end)
+ let internal_pretty_code = Datatype.undefined
+ let copy = Datatype.undefined
+ end)
include DatatypeFromDeps
@@ -73,14 +73,14 @@ struct
Format.fprintf fmt "\\nothing"
| true, false ->
Format.fprintf fmt "direct: %a"
- Zone.pretty data
+ Zone.pretty data
| false, true ->
Format.fprintf fmt "indirect: %a"
- Zone.pretty indirect
+ Zone.pretty indirect
| false, false ->
Format.fprintf fmt "indirect: %a; direct: %a"
- Zone.pretty indirect
- Zone.pretty data
+ Zone.pretty indirect
+ Zone.pretty data
let from_data_deps z = { data = z; indirect = Zone.bottom }
let from_indirect_deps z = { data = Zone.bottom; indirect = z }
@@ -128,62 +128,62 @@ end
module DepsOrUnassigned = struct
type deps_or_unassigned =
- | DepsBottom
- | Unassigned
- | AssignedFrom of Deps.t
- | MaybeAssignedFrom of Deps.t
+ | DepsBottom
+ | Unassigned
+ | AssignedFrom of Deps.t
+ | MaybeAssignedFrom of Deps.t
module DatatypeDeps = Datatype.Make(struct
- type t = deps_or_unassigned
-
- let name = "Function_Froms.Deps.deps"
-
- let pretty fmt = function
- | DepsBottom -> Format.pp_print_string fmt "DEPS_BOTTOM"
- | Unassigned -> Format.pp_print_string fmt "UNASSIGNED"
- | AssignedFrom fd -> Deps.pretty_precise fmt fd
- | MaybeAssignedFrom fd ->
- (* '(or UNASSIGNED)' would be a better pretty-printer, we use
- '(and SELF)' only for compatibility reasons *)
- Format.fprintf fmt "%a (and SELF)" Deps.pretty_precise fd
-
- let hash = function
- | DepsBottom -> 3
- | Unassigned -> 17
- | AssignedFrom fd -> 37 + 13 * Deps.hash fd
- | MaybeAssignedFrom fd -> 57 + 123 * Deps.hash fd
-
- let compare d1 d2 = match d1, d2 with
- | DepsBottom, DepsBottom
- | Unassigned, Unassigned -> 0
- | AssignedFrom fd1, AssignedFrom fd2
- | MaybeAssignedFrom fd1, MaybeAssignedFrom fd2 ->
- Deps.compare fd1 fd2
- | DepsBottom, (Unassigned | AssignedFrom _ | MaybeAssignedFrom _)
- | Unassigned, (AssignedFrom _ | MaybeAssignedFrom _)
- | AssignedFrom _, MaybeAssignedFrom _ ->
- -1
- | (Unassigned | AssignedFrom _ | MaybeAssignedFrom _), DepsBottom
- | (AssignedFrom _ | MaybeAssignedFrom _), Unassigned
- | MaybeAssignedFrom _, AssignedFrom _ ->
- 1
-
- let equal = Datatype.from_compare
-
- let reprs = Unassigned :: List.map (fun r -> AssignedFrom r) Deps.reprs
-
- let structural_descr =
- let d = Deps.packed_descr in
- Structural_descr.t_sum [| [| d |]; [| d |] |]
- let rehash = Datatype.identity
-
- let mem_project = Datatype.never_any_project
- let varname _ = "d"
-
- let internal_pretty_code = Datatype.undefined
- let copy = Datatype.undefined
-
- end)
+ type t = deps_or_unassigned
+
+ let name = "Function_Froms.Deps.deps"
+
+ let pretty fmt = function
+ | DepsBottom -> Format.pp_print_string fmt "DEPS_BOTTOM"
+ | Unassigned -> Format.pp_print_string fmt "UNASSIGNED"
+ | AssignedFrom fd -> Deps.pretty_precise fmt fd
+ | MaybeAssignedFrom fd ->
+ (* '(or UNASSIGNED)' would be a better pretty-printer, we use
+ '(and SELF)' only for compatibility reasons *)
+ Format.fprintf fmt "%a (and SELF)" Deps.pretty_precise fd
+
+ let hash = function
+ | DepsBottom -> 3
+ | Unassigned -> 17
+ | AssignedFrom fd -> 37 + 13 * Deps.hash fd
+ | MaybeAssignedFrom fd -> 57 + 123 * Deps.hash fd
+
+ let compare d1 d2 = match d1, d2 with
+ | DepsBottom, DepsBottom
+ | Unassigned, Unassigned -> 0
+ | AssignedFrom fd1, AssignedFrom fd2
+ | MaybeAssignedFrom fd1, MaybeAssignedFrom fd2 ->
+ Deps.compare fd1 fd2
+ | DepsBottom, (Unassigned | AssignedFrom _ | MaybeAssignedFrom _)
+ | Unassigned, (AssignedFrom _ | MaybeAssignedFrom _)
+ | AssignedFrom _, MaybeAssignedFrom _ ->
+ -1
+ | (Unassigned | AssignedFrom _ | MaybeAssignedFrom _), DepsBottom
+ | (AssignedFrom _ | MaybeAssignedFrom _), Unassigned
+ | MaybeAssignedFrom _, AssignedFrom _ ->
+ 1
+
+ let equal = Datatype.from_compare
+
+ let reprs = Unassigned :: List.map (fun r -> AssignedFrom r) Deps.reprs
+
+ let structural_descr =
+ let d = Deps.packed_descr in
+ Structural_descr.t_sum [| [| d |]; [| d |] |]
+ let rehash = Datatype.identity
+
+ let mem_project = Datatype.never_any_project
+ let varname _ = "d"
+
+ let internal_pretty_code = Datatype.undefined
+ let copy = Datatype.undefined
+
+ end)
let join d1 d2 = match d1, d2 with
| DepsBottom, d | d, DepsBottom -> d
@@ -275,7 +275,7 @@ module DepsOrUnassigned = struct
Format.fprintf fmt "%a (and SELF)" Zone.pretty (Deps.to_zone d)
end
-module Memory = struct
+module Memory = struct
(** A From table is internally represented as a Lmap of [DepsOrUnassigned].
However, the API mostly hides this fact, and exports access functions
that take or return [Deps.t] values. This way, the user needs not
@@ -478,7 +478,7 @@ module Memory = struct
let open Deps in
let { data; indirect } = deps in
(* depending directly on an indirect dependency -> indirect,
- depending indirectly on a direct dependency -> indirect *)
+ depending indirectly on a direct dependency -> indirect *)
let dirdeps = substitute_data_deps call_site_froms data in
let inddeps = substitute_indirect_deps call_site_froms indirect in
let dir = dirdeps.data in
@@ -510,8 +510,8 @@ module Memory = struct
end
type froms =
- { deps_return : Memory.return;
- deps_table : Memory.t }
+ { deps_return : Memory.return;
+ deps_table : Memory.t }
let top = {
deps_return = Memory.top_return;
@@ -529,23 +529,23 @@ let outputs { deps_table = t } =
| Memory.Map(m) ->
Memory.fold
(fun z v acc ->
- let open DepsOrUnassigned in
- match v with
- | DepsBottom | Unassigned -> acc
- | AssignedFrom _ | MaybeAssignedFrom _ -> Locations.Zone.join z acc)
+ let open DepsOrUnassigned in
+ match v with
+ | DepsBottom | Unassigned -> acc
+ | AssignedFrom _ | MaybeAssignedFrom _ -> Locations.Zone.join z acc)
m Locations.Zone.bottom
let inputs ?(include_self=false) t =
let aux b offm acc =
Memory.LOffset.fold
(fun itvs deps acc ->
- let z = DepsOrUnassigned.to_zone deps in
- let self = DepsOrUnassigned.may_be_unassigned deps in
- let acc = Zone.join z acc in
- match include_self, self, b with
- | true, true, Some b ->
- Zone.join acc (Zone.inject b itvs)
- | _ -> acc
+ let z = DepsOrUnassigned.to_zone deps in
+ let self = DepsOrUnassigned.may_be_unassigned deps in
+ let acc = Zone.join z acc in
+ match include_self, self, b with
+ | true, true, Some b ->
+ Zone.join acc (Zone.inject b itvs)
+ | _ -> acc
)
offm
acc
@@ -566,19 +566,19 @@ let pretty fmt { deps_return = r ; deps_table = t } =
(** same as pretty, but uses the type of the function to output more
precise information.
@raise Error if the given type is not a function type
- *)
+*)
let pretty_with_type ~indirect typ fmt { deps_return = r; deps_table = t } =
let (rt_typ,_,_,_) = Cil.splitFunctionType typ in
if Memory.is_bottom t
then Format.fprintf fmt
- "@[NON TERMINATING - NO EFFECTS@]"
+ "@[NON TERMINATING - NO EFFECTS@]"
else
let map_pretty =
- if indirect
+ if indirect
then Memory.pretty_ind_data
- else Memory.pretty
+ else Memory.pretty
in
- if Cil.isVoidType rt_typ
+ if Cil.isVoidType rt_typ
then begin
if Memory.is_empty t
then Format.fprintf fmt "@[NO EFFECTS@]"
@@ -610,27 +610,27 @@ include Datatype.Make
let reprs =
List.fold_left
(fun acc o ->
- List.fold_left
- (fun acc m -> { deps_return = o; deps_table = m } :: acc)
- acc
- Memory.reprs)
+ List.fold_left
+ (fun acc m -> { deps_return = o; deps_table = m } :: acc)
+ acc
+ Memory.reprs)
[]
Deps.reprs
let structural_descr =
Structural_descr.t_record
[| Deps.packed_descr;
Memory.packed_descr |]
- let name = "Function_Froms"
- let hash = hash
- let compare = Datatype.undefined
- let equal = equal
- let pretty = pretty
- let internal_pretty_code = Datatype.undefined
- let rehash = Datatype.identity
- let copy = Datatype.undefined
- let varname = Datatype.undefined
- let mem_project = Datatype.never_any_project
- end)
+ let name = "Function_Froms"
+ let hash = hash
+ let compare = Datatype.undefined
+ let equal = equal
+ let pretty = pretty
+ let internal_pretty_code = Datatype.undefined
+ let rehash = Datatype.identity
+ let copy = Datatype.undefined
+ let varname = Datatype.undefined
+ let mem_project = Datatype.never_any_project
+ end)
(*
Local Variables:
diff --git a/src/plugins/value_types/function_Froms.mli b/src/plugins/value_types/function_Froms.mli
index 5ee9b0da8b699c87ca022627a010fddeb5a2f788..d9d30e91dd971dec507fe312b0b3b640e1011a3f 100644
--- a/src/plugins/value_types/function_Froms.mli
+++ b/src/plugins/value_types/function_Froms.mli
@@ -52,14 +52,14 @@ end
module DepsOrUnassigned : sig
type deps_or_unassigned =
- | DepsBottom (** Bottom of the lattice, never bound inside a memory state
- at a valid location. (May appear for bases for which the
- validity does not start at 0, currently only NULL.) *)
- | Unassigned (** Location has never been assigned *)
- | AssignedFrom of Deps.t (** Location guaranteed to have been overwritten,
- its contents depend on the [Deps.t] value *)
- | MaybeAssignedFrom of Deps.t (** Location may or may not have been
- overwritten *)
+ | DepsBottom (** Bottom of the lattice, never bound inside a memory state
+ at a valid location. (May appear for bases for which the
+ validity does not start at 0, currently only NULL.) *)
+ | Unassigned (** Location has never been assigned *)
+ | AssignedFrom of Deps.t (** Location guaranteed to have been overwritten,
+ its contents depend on the [Deps.t] value *)
+ | MaybeAssignedFrom of Deps.t (** Location may or may not have been
+ overwritten *)
(** The lattice is [DepsBottom <= Unassigned], [DepsBottom <= AssignedFrom z],
[Unassigned <= MaybeAssignedFrom] and
[AssignedFrom z <= MaybeAssignedFrom z]. *)
@@ -149,9 +149,9 @@ end
type froms = {
deps_return : Memory.return
- (** Dependencies for the returned value *);
+(** Dependencies for the returned value *);
deps_table : Memory.t
- (** Dependencies on all the zones modified by the function *);
+(** Dependencies on all the zones modified by the function *);
}
include Datatype.S with type t = froms
@@ -160,10 +160,10 @@ val join: froms -> froms -> froms
val top: froms
(** Display dependencies of a function, using the function's type to improve
-readability *)
+ readability *)
val pretty_with_type: Cil_types.typ -> froms Pretty_utils.formatter
(** Display dependencies of a function, using the function's type to improve
-readability, separating direct and indirect dependencies *)
+ readability, separating direct and indirect dependencies *)
val pretty_with_type_indirect: Cil_types.typ -> froms Pretty_utils.formatter
(** Extract the left part of a from result, ie. the zones that are written *)
diff --git a/src/plugins/value_types/inout_type.ml b/src/plugins/value_types/inout_type.ml
index 195934ed5d122f0c65f4f7588937b01c82ac3a2f..532f6b67fb9a1dc26c06a25423a359ef9655ba3c 100644
--- a/src/plugins/value_types/inout_type.ml
+++ b/src/plugins/value_types/inout_type.ml
@@ -56,69 +56,69 @@ let pretty_outputs = wrap_vbox pretty_outputs_aux
open Locations
include
-(Datatype.Make
- (struct
- include Datatype.Serializable_undefined
- type inout_t = t
- type t = inout_t
- let pretty fmt x =
- Format.fprintf fmt "@[<v>";
- pretty_operational_inputs_aux fmt x;
- pretty_outputs_aux fmt x;
- Format.fprintf fmt "@]"
+ (Datatype.Make
+ (struct
+ include Datatype.Serializable_undefined
+ type inout_t = t
+ type t = inout_t
+ let pretty fmt x =
+ Format.fprintf fmt "@[<v>";
+ pretty_operational_inputs_aux fmt x;
+ pretty_outputs_aux fmt x;
+ Format.fprintf fmt "@]"
- let structural_descr =
- let z = Locations.Zone.packed_descr in
- Structural_descr.t_record [| z; z; z; z; z; z |]
- let reprs =
- List.map
- (fun z ->
- { over_inputs_if_termination = z;
- under_outputs_if_termination = z;
- over_inputs = z;
- over_logic_inputs = z;
- over_outputs = z;
- over_outputs_if_termination = z;
- }) Locations.Zone.reprs
- let name = "Full.tt"
- let hash
- { over_inputs_if_termination = a;
- under_outputs_if_termination = b;
- over_inputs = c;
- over_outputs = d;
- over_outputs_if_termination = e;
- over_logic_inputs = f;
- } =
- Zone.hash a +
- 17 * Zone.hash b +
- 587 * Zone.hash c +
- 1077 * Zone.hash d +
- 13119 * Zone.hash e +
- 15823 * Zone.hash f
- let equal
- { over_inputs_if_termination = a;
- under_outputs_if_termination = b;
- over_inputs = c;
- over_outputs = d;
- over_outputs_if_termination = e;
- over_logic_inputs = f;
- }
- { over_inputs_if_termination = a';
- under_outputs_if_termination = b';
- over_inputs = c';
- over_outputs = d';
- over_outputs_if_termination = e';
- over_logic_inputs = f';
- } =
- Zone.equal a a'
- && Zone.equal b b'
- && Zone.equal c c'
- && Zone.equal d d'
- && Zone.equal e e'
- && Zone.equal f f'
- let mem_project = Datatype.never_any_project
- end)
- : Datatype.S with type t := t)
+ let structural_descr =
+ let z = Locations.Zone.packed_descr in
+ Structural_descr.t_record [| z; z; z; z; z; z |]
+ let reprs =
+ List.map
+ (fun z ->
+ { over_inputs_if_termination = z;
+ under_outputs_if_termination = z;
+ over_inputs = z;
+ over_logic_inputs = z;
+ over_outputs = z;
+ over_outputs_if_termination = z;
+ }) Locations.Zone.reprs
+ let name = "Full.tt"
+ let hash
+ { over_inputs_if_termination = a;
+ under_outputs_if_termination = b;
+ over_inputs = c;
+ over_outputs = d;
+ over_outputs_if_termination = e;
+ over_logic_inputs = f;
+ } =
+ Zone.hash a +
+ 17 * Zone.hash b +
+ 587 * Zone.hash c +
+ 1077 * Zone.hash d +
+ 13119 * Zone.hash e +
+ 15823 * Zone.hash f
+ let equal
+ { over_inputs_if_termination = a;
+ under_outputs_if_termination = b;
+ over_inputs = c;
+ over_outputs = d;
+ over_outputs_if_termination = e;
+ over_logic_inputs = f;
+ }
+ { over_inputs_if_termination = a';
+ under_outputs_if_termination = b';
+ over_inputs = c';
+ over_outputs = d';
+ over_outputs_if_termination = e';
+ over_logic_inputs = f';
+ } =
+ Zone.equal a a'
+ && Zone.equal b b'
+ && Zone.equal c c'
+ && Zone.equal d d'
+ && Zone.equal e e'
+ && Zone.equal f f'
+ let mem_project = Datatype.never_any_project
+ end)
+ : Datatype.S with type t := t)
let map f v = {
over_inputs_if_termination = f v.over_inputs_if_termination;
diff --git a/src/plugins/value_types/precise_locs.ml b/src/plugins/value_types/precise_locs.ml
index 905339d0fd2bde08242a5848f8285700b8fff543..f1224ab956fbc2b73c3d14a48c98543de56c4745 100644
--- a/src/plugins/value_types/precise_locs.ml
+++ b/src/plugins/value_types/precise_locs.ml
@@ -28,7 +28,7 @@ type precise_offset =
| POZero (* Offset zero *)
| POSingleton of Int.t (* Single offset *)
| POPrecise of Ival.t * (Int.t (* cardinal *))
- (* Offset exactly represented by an ival *)
+ (* Offset exactly represented by an ival *)
| POImprecise of Ival.t (* Offset that could not be represented precisely *)
| POShift of (* Shifted offset *)
Ival.t (* number of bits/bytes to shift *) *
@@ -92,26 +92,26 @@ let rec imprecise_offset = function
let rec _scale_offset scale po =
assert (Int.gt scale Int.zero);
match po with
- | POBottom -> POBottom
- | POZero -> POZero
- | POSingleton i -> POSingleton (Int.mul i scale)
- | POPrecise (i, c) -> POPrecise (Ival.scale scale i, c)
- | POImprecise i -> POImprecise (Ival.scale scale i)
- | POShift (shift, po, c) ->
- POShift (Ival.scale scale shift, _scale_offset scale po, c)
+ | POBottom -> POBottom
+ | POZero -> POZero
+ | POSingleton i -> POSingleton (Int.mul i scale)
+ | POPrecise (i, c) -> POPrecise (Ival.scale scale i, c)
+ | POImprecise i -> POImprecise (Ival.scale scale i)
+ | POShift (shift, po, c) ->
+ POShift (Ival.scale scale shift, _scale_offset scale po, c)
let shift_offset_by_singleton shift po =
if Int.is_zero shift then
po
else
match po with
- | POBottom -> POBottom
- | POZero -> POSingleton shift
- | POSingleton i -> POSingleton (Int.add i shift)
- | POPrecise (i, c) -> POPrecise (Ival.add_singleton_int shift i, c)
- | POImprecise i -> POImprecise (Ival.add_singleton_int shift i)
- | POShift (shift', po, c) ->
- POShift (Ival.add_singleton_int shift shift', po, c)
+ | POBottom -> POBottom
+ | POZero -> POSingleton shift
+ | POSingleton i -> POSingleton (Int.add i shift)
+ | POPrecise (i, c) -> POPrecise (Ival.add_singleton_int shift i, c)
+ | POImprecise i -> POImprecise (Ival.add_singleton_int shift i)
+ | POShift (shift', po, c) ->
+ POShift (Ival.add_singleton_int shift shift', po, c)
let inject_ival ival =
if Ival.is_bottom ival then POBottom
@@ -130,44 +130,44 @@ let shift_offset shift po =
POBottom
else
match po with
- | POBottom -> POBottom
-
- | POZero -> inject_ival shift
-
- | POImprecise i -> POImprecise (Ival.add_int shift i)
-
- | POSingleton i ->
- (match Ival.cardinal shift with
- | Some c when small_cardinal c ->
- if Int.equal c Int.one then
- POSingleton (Int.add (Ival.project_int shift) i)
- else
- POPrecise (Ival.add_singleton_int i shift, c)
- | _ -> POImprecise (Ival.add_int shift (imprecise_offset po)))
-
- | POPrecise (_i, cpo) ->
- (match Ival.cardinal shift with
- | Some cs ->
- let new_card = Int.mul cs cpo in
- if small_cardinal new_card then
- POShift (shift, po, new_card) (* may be a POPrecise depending
- on ilevel *)
- else
- POImprecise (Ival.add_int shift (imprecise_offset po))
- | None ->
- POImprecise (Ival.add_int shift (imprecise_offset po)))
-
- | POShift (_shift', _po', cpo) ->
- (match Ival.cardinal shift with
- | Some cs ->
- let new_card = Int.mul cs cpo in
- if small_cardinal new_card then
- POShift (shift, po, new_card) (* may be a single POShift depending
- on the cardinals of shift/shift'*)
- else
- POImprecise (Ival.add_int shift (imprecise_offset po))
- | None ->
- POImprecise (Ival.add_int shift (imprecise_offset po)))
+ | POBottom -> POBottom
+
+ | POZero -> inject_ival shift
+
+ | POImprecise i -> POImprecise (Ival.add_int shift i)
+
+ | POSingleton i ->
+ (match Ival.cardinal shift with
+ | Some c when small_cardinal c ->
+ if Int.equal c Int.one then
+ POSingleton (Int.add (Ival.project_int shift) i)
+ else
+ POPrecise (Ival.add_singleton_int i shift, c)
+ | _ -> POImprecise (Ival.add_int shift (imprecise_offset po)))
+
+ | POPrecise (_i, cpo) ->
+ (match Ival.cardinal shift with
+ | Some cs ->
+ let new_card = Int.mul cs cpo in
+ if small_cardinal new_card then
+ POShift (shift, po, new_card) (* may be a POPrecise depending
+ on ilevel *)
+ else
+ POImprecise (Ival.add_int shift (imprecise_offset po))
+ | None ->
+ POImprecise (Ival.add_int shift (imprecise_offset po)))
+
+ | POShift (_shift', _po', cpo) ->
+ (match Ival.cardinal shift with
+ | Some cs ->
+ let new_card = Int.mul cs cpo in
+ if small_cardinal new_card then
+ POShift (shift, po, new_card) (* may be a single POShift depending
+ on the cardinals of shift/shift'*)
+ else
+ POImprecise (Ival.add_int shift (imprecise_offset po))
+ | None ->
+ POImprecise (Ival.add_int shift (imprecise_offset po)))
type precise_location_bits =
| PLBottom
@@ -206,8 +206,8 @@ let inject_location_bits loc =
let combine_base_precise_offset base po =
match po with
- | POBottom -> PLBottom
- | _ -> PLVarOffset (base, po)
+ | POBottom -> PLBottom
+ | _ -> PLVarOffset (base, po)
let combine_loc_precise_offset loc po =
try
@@ -284,45 +284,45 @@ let replace_base substitution po =
let rec fold_offset f po acc =
match po with
- | POBottom -> f Ival.bottom acc
- | POZero -> f Ival.zero acc
- | POSingleton i -> f (Ival.inject_singleton i) acc
- | POPrecise (iv, _) | POImprecise iv -> f iv acc
- | POShift (shift, po', _) ->
- let aux_po ival acc =
- let aux_ival shift_i acc =
- let ival' = Ival.add_singleton_int shift_i ival in
- f ival' acc
- in
- Ival.fold_int aux_ival shift acc
+ | POBottom -> f Ival.bottom acc
+ | POZero -> f Ival.zero acc
+ | POSingleton i -> f (Ival.inject_singleton i) acc
+ | POPrecise (iv, _) | POImprecise iv -> f iv acc
+ | POShift (shift, po', _) ->
+ let aux_po ival acc =
+ let aux_ival shift_i acc =
+ let ival' = Ival.add_singleton_int shift_i ival in
+ f ival' acc
in
- fold_offset aux_po po' acc
+ Ival.fold_int aux_ival shift acc
+ in
+ fold_offset aux_po po' acc
let fold f pl acc =
match pl.loc with
- | PLBottom -> acc
- | PLLoc l -> f (make_loc l pl.size) acc
- | PLVarOffset (b, po) ->
- let aux_po ival acc =
- let loc_b = Location_Bits.inject b ival in
- let loc = make_loc loc_b pl.size in
- f loc acc
- in
- fold_offset aux_po po acc
- | PLLocOffset (loc, po) ->
- let aux_po ival_po acc =
- let aux_loc b ival_loc acc =
- let aux_ival_loc i acc =
- let ival = Ival.add_singleton_int i ival_po in
- let loc_b = Location_Bits.inject b ival in
- let loc = make_loc loc_b pl.size in
- f loc acc
- in
- Ival.fold_int aux_ival_loc ival_loc acc
+ | PLBottom -> acc
+ | PLLoc l -> f (make_loc l pl.size) acc
+ | PLVarOffset (b, po) ->
+ let aux_po ival acc =
+ let loc_b = Location_Bits.inject b ival in
+ let loc = make_loc loc_b pl.size in
+ f loc acc
+ in
+ fold_offset aux_po po acc
+ | PLLocOffset (loc, po) ->
+ let aux_po ival_po acc =
+ let aux_loc b ival_loc acc =
+ let aux_ival_loc i acc =
+ let ival = Ival.add_singleton_int i ival_po in
+ let loc_b = Location_Bits.inject b ival in
+ let loc = make_loc loc_b pl.size in
+ f loc acc
in
- Location_Bits.fold_i aux_loc loc acc
+ Ival.fold_int aux_ival_loc ival_loc acc
in
- fold_offset aux_po po acc
+ Location_Bits.fold_i aux_loc loc acc
+ in
+ fold_offset aux_po po acc
let enumerate_valid_bits access loc =
let aux loc z = Zone.join z (enumerate_valid_bits access loc) in
@@ -333,25 +333,25 @@ let cardinal_zero_or_one pl =
not (Int_Base.is_top pl.size) && cardinal_zero_or_one_location_bits pl.loc
let valid_cardinal_zero_or_one ~for_writing pl =
- match pl.loc with
- | PLBottom -> true
- | PLLoc lb ->
- let loc = make_loc lb pl.size in
- Locations.valid_cardinal_zero_or_one ~for_writing loc
- | _ ->
- try
- ignore
- (fold (fun loc found_one ->
- let access = if for_writing then Write else Read in
- let valid = Locations.valid_part access loc in
- if Locations.is_bottom_loc loc then found_one
- else
- if Locations.cardinal_zero_or_one valid then
- if found_one then raise Exit else true
- else raise Exit
- ) pl false);
- true
- with Exit -> false
+ match pl.loc with
+ | PLBottom -> true
+ | PLLoc lb ->
+ let loc = make_loc lb pl.size in
+ Locations.valid_cardinal_zero_or_one ~for_writing loc
+ | _ ->
+ try
+ ignore
+ (fold (fun loc found_one ->
+ let access = if for_writing then Write else Read in
+ let valid = Locations.valid_part access loc in
+ if Locations.is_bottom_loc loc then found_one
+ else
+ if Locations.cardinal_zero_or_one valid then
+ if found_one then raise Exit else true
+ else raise Exit
+ ) pl false);
+ true
+ with Exit -> false
let pretty_loc fmt loc =
Format.fprintf fmt "%a (size:%a)"
diff --git a/src/plugins/value_types/value_types.ml b/src/plugins/value_types/value_types.ml
index b115bc2ce41b7ea3f80a549a13432a606852a64e..651fc255b780baef0d1d5dc653ee803da37186ce 100644
--- a/src/plugins/value_types/value_types.ml
+++ b/src/plugins/value_types/value_types.ml
@@ -27,14 +27,14 @@ type call_site = kernel_function * kinstr
module Callsite = struct
include Datatype.Pair_with_collections(Kernel_function)(Cil_datatype.Kinstr)
- (struct let module_name = "Value_callbacks.Callpoint" end)
+ (struct let module_name = "Value_callbacks.Callpoint" end)
let pretty fmt (kf, ki) =
Format.fprintf fmt "%a@@%t" Kernel_function.pretty kf
(fun fmt ->
- match ki with
- | Kglobal -> Format.pp_print_string fmt "<main>"
- | Kstmt stmt -> Format.pp_print_int fmt stmt.sid
+ match ki with
+ | Kglobal -> Format.pp_print_string fmt "<main>"
+ | Kstmt stmt -> Format.pp_print_int fmt stmt.sid
)
end
@@ -123,4 +123,3 @@ Local Variables:
compile-command: "make -C ../../.."
End:
*)
-
diff --git a/src/plugins/value_types/value_types.mli b/src/plugins/value_types/value_types.mli
index 6d5ebf1fa8704d196ec5cf2ab5f9156c590b01c2..b47d82513039ca5b1c9ab0a48c7e25da8a432a20 100644
--- a/src/plugins/value_types/value_types.mli
+++ b/src/plugins/value_types/value_types.mli
@@ -43,7 +43,7 @@ type callstack = call_site list
Moreover, given two consecutive call-sites […(_,p);(g,_)…] in a callstack,
program point [p] is then expected to live in function [g].
- *)
+*)
module Callsite: Datatype.S_with_collections with type t = call_site
module Callstack: sig
@@ -77,4 +77,3 @@ Local Variables:
compile-command: "make -C ../../.."
End:
*)
-
diff --git a/src/plugins/value_types/widen_type.ml b/src/plugins/value_types/widen_type.ml
index b08263306f6a9d8ac5964789283e2a0c0a50cf63..803b9a411dc6e535efaf6df345143c8c99a00bff 100644
--- a/src/plugins/value_types/widen_type.ml
+++ b/src/plugins/value_types/widen_type.ml
@@ -56,35 +56,35 @@ let empty = {
}
include Datatype.Make(struct
- include Datatype.Serializable_undefined
- type t = widen_hints
- let name = "Widen_type.widen_hints"
- let structural_descr =
- Structural_descr.t_tuple
- [| Priority_bases_stmt.packed_descr;
- Ival.Widen_Hints.packed_descr;
- Fc_float.Widen_Hints.packed_descr;
- Num_hints_stmt.packed_descr;
- Float_hints_stmt.packed_descr;
- Num_hints_bases.packed_descr;
- Float_hints_bases.packed_descr;
- Num_hints_bases_stmt.packed_descr;
- Float_hints_bases_stmt.packed_descr |]
- let reprs =
- Extlib.product
- (fun wh fh ->
- { priority_bases = Stmt.Map.empty;
- default_hints = wh;
- default_float_hints = fh;
- default_hints_by_stmt = Stmt.Map.empty;
- default_float_hints_by_stmt = Stmt.Map.empty;
- hints_by_addr = Base.Map.empty;
- float_hints_by_addr = Base.Map.empty;
- float_hints_by_addr_by_stmt = Stmt.Map.empty;
- hints_by_addr_by_stmt = Stmt.Map.empty
- })
- Ival.Widen_Hints.reprs Fc_float.Widen_Hints.reprs
- let mem_project = Datatype.never_any_project
+ include Datatype.Serializable_undefined
+ type t = widen_hints
+ let name = "Widen_type.widen_hints"
+ let structural_descr =
+ Structural_descr.t_tuple
+ [| Priority_bases_stmt.packed_descr;
+ Ival.Widen_Hints.packed_descr;
+ Fc_float.Widen_Hints.packed_descr;
+ Num_hints_stmt.packed_descr;
+ Float_hints_stmt.packed_descr;
+ Num_hints_bases.packed_descr;
+ Float_hints_bases.packed_descr;
+ Num_hints_bases_stmt.packed_descr;
+ Float_hints_bases_stmt.packed_descr |]
+ let reprs =
+ Extlib.product
+ (fun wh fh ->
+ { priority_bases = Stmt.Map.empty;
+ default_hints = wh;
+ default_float_hints = fh;
+ default_hints_by_stmt = Stmt.Map.empty;
+ default_float_hints_by_stmt = Stmt.Map.empty;
+ hints_by_addr = Base.Map.empty;
+ float_hints_by_addr = Base.Map.empty;
+ float_hints_by_addr_by_stmt = Stmt.Map.empty;
+ hints_by_addr_by_stmt = Stmt.Map.empty
+ })
+ Ival.Widen_Hints.reprs Fc_float.Widen_Hints.reprs
+ let mem_project = Datatype.never_any_project
end)
let join wh1 wh2 =
@@ -174,15 +174,15 @@ let hints_for_base default_hints hints_by_base b =
| b ->
let validity = Base.validity b in
match validity with
- | Base.Known (_, m)
- | Base.Unknown (_, _, m)
- | Base.Variable { Base.max_alloc = m } ->
- (* Try the frontier of the block: further accesses are invalid
- anyway. This also works great for constant strings (this computes
- the offset of the null terminator). *)
- let bound = Integer.(pred (e_div (succ m) eight)) in
- Ival.Widen_Hints.add bound widen_zero
- | Base.Empty | Base.Invalid -> widen_zero
+ | Base.Known (_, m)
+ | Base.Unknown (_, _, m)
+ | Base.Variable { Base.max_alloc = m } ->
+ (* Try the frontier of the block: further accesses are invalid
+ anyway. This also works great for constant strings (this computes
+ the offset of the null terminator). *)
+ let bound = Integer.(pred (e_div (succ m) eight)) in
+ Ival.Widen_Hints.add bound widen_zero
+ | Base.Empty | Base.Invalid -> widen_zero
)
let hints_from_keys stmt h =