From 75d9c2de0e8475bb26ea4e21c25525bbcf395bb6 Mon Sep 17 00:00:00 2001
From: Virgile Robles <virgile.robles@protonmail.ch>
Date: Mon, 22 Jul 2019 10:42:26 +0200
Subject: [PATCH] Indent several files (with ocp-indent.1.6.1 instead of 1.7)
---
.Makefile.lint | 19 -
src/kernel_internals/typing/mergecil.ml | 3098 ++---
src/kernel_services/ast_data/cil_types.mli | 446 +-
src/kernel_services/ast_data/property.ml | 82 +-
src/kernel_services/ast_data/property.mli | 22 +-
.../ast_data/property_status.ml | 1518 +--
.../ast_data/statuses_by_call.ml | 16 +-
.../ast_printing/cil_printer.ml | 18 +-
src/kernel_services/ast_queries/cil.ml | 10386 ++++++++--------
.../ast_queries/cil_datatype.ml | 2388 ++--
src/kernel_services/ast_queries/file.ml | 1118 +-
src/kernel_services/ast_queries/filecheck.ml | 2496 ++--
.../ast_queries/logic_const.ml | 58 +-
.../ast_queries/logic_utils.ml | 2 +-
src/plugins/gui/design.ml | 848 +-
src/plugins/gui/filetree.ml | 188 +-
src/plugins/gui/pretty_source.ml | 98 +-
src/plugins/gui/property_navigator.ml | 210 +-
src/plugins/metrics/metrics_cilast.ml | 324 +-
src/plugins/scope/dpds_gui.ml | 368 +-
src/plugins/wp/dyncall.ml | 80 +-
src/plugins/wp/wpPropId.ml | 12 +-
22 files changed, 11888 insertions(+), 11907 deletions(-)
diff --git a/.Makefile.lint b/.Makefile.lint
index 435f216117e..4f672d370c1 100644
--- a/.Makefile.lint
+++ b/.Makefile.lint
@@ -17,7 +17,6 @@ ML_LINT_KO+=src/kernel_internals/typing/cfg.mli
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/logic_builtin.ml
-ML_LINT_KO+=src/kernel_internals/typing/mergecil.ml
ML_LINT_KO+=src/kernel_internals/typing/mergecil.mli
ML_LINT_KO+=src/kernel_internals/typing/oneret.ml
ML_LINT_KO+=src/kernel_internals/typing/oneret.mli
@@ -79,21 +78,14 @@ 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/cil_types.mli
ML_LINT_KO+=src/kernel_services/ast_data/globals.ml
ML_LINT_KO+=src/kernel_services/ast_data/globals.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.ml
-ML_LINT_KO+=src/kernel_services/ast_data/property.mli
-ML_LINT_KO+=src/kernel_services/ast_data/property_status.ml
ML_LINT_KO+=src/kernel_services/ast_data/property_status.mli
-ML_LINT_KO+=src/kernel_services/ast_data/statuses_by_call.ml
ML_LINT_KO+=src/kernel_services/ast_printing/cabs_debug.ml
ML_LINT_KO+=src/kernel_services/ast_printing/cil_descriptive_printer.ml
-ML_LINT_KO+=src/kernel_services/ast_printing/cil_printer.ml
ML_LINT_KO+=src/kernel_services/ast_printing/cil_printer.mli
-ML_LINT_KO+=src/kernel_services/ast_printing/cil_types_debug.ml
ML_LINT_KO+=src/kernel_services/ast_printing/cil_types_debug.mli
ML_LINT_KO+=src/kernel_services/ast_printing/cprint.ml
ML_LINT_KO+=src/kernel_services/ast_printing/cprint.mli
@@ -104,17 +96,12 @@ ML_LINT_KO+=src/kernel_services/ast_printing/printer_builder.ml
ML_LINT_KO+=src/kernel_services/ast_printing/printer_builder.mli
ML_LINT_KO+=src/kernel_services/ast_queries/ast_info.ml
ML_LINT_KO+=src/kernel_services/ast_queries/ast_info.mli
-ML_LINT_KO+=src/kernel_services/ast_queries/cil.ml
ML_LINT_KO+=src/kernel_services/ast_queries/cil.mli
ML_LINT_KO+=src/kernel_services/ast_queries/cil_const.ml
ML_LINT_KO+=src/kernel_services/ast_queries/cil_const.mli
-ML_LINT_KO+=src/kernel_services/ast_queries/cil_datatype.ml
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/file.ml
ML_LINT_KO+=src/kernel_services/ast_queries/file.mli
-ML_LINT_KO+=src/kernel_services/ast_queries/filecheck.ml
-ML_LINT_KO+=src/kernel_services/ast_queries/logic_const.ml
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
@@ -260,10 +247,8 @@ 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.ml
ML_LINT_KO+=src/plugins/gui/design.mli
ML_LINT_KO+=src/plugins/gui/file_manager.ml
-ML_LINT_KO+=src/plugins/gui/filetree.ml
ML_LINT_KO+=src/plugins/gui/filetree.mli
ML_LINT_KO+=src/plugins/gui/gtk_form.ml
ML_LINT_KO+=src/plugins/gui/gtk_form.mli
@@ -275,10 +260,8 @@ 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/pretty_source.ml
ML_LINT_KO+=src/plugins/gui/project_manager.ml
ML_LINT_KO+=src/plugins/gui/project_manager.mli
-ML_LINT_KO+=src/plugins/gui/property_navigator.ml
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
@@ -317,7 +300,6 @@ ML_LINT_KO+=src/plugins/metrics/metrics_acsl.ml
ML_LINT_KO+=src/plugins/metrics/metrics_base.ml
ML_LINT_KO+=src/plugins/metrics/metrics_base.mli
ML_LINT_KO+=src/plugins/metrics/metrics_cabs.ml
-ML_LINT_KO+=src/plugins/metrics/metrics_cilast.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
@@ -354,7 +336,6 @@ 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/dpds_gui.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
diff --git a/src/kernel_internals/typing/mergecil.ml b/src/kernel_internals/typing/mergecil.ml
index adef0ac0916..7db861b0dbd 100644
--- a/src/kernel_internals/typing/mergecil.ml
+++ b/src/kernel_internals/typing/mergecil.ml
@@ -73,7 +73,7 @@ let mergeInlinesRepeat = mergeInlines && true
(* The default value has been changed to false after Boron to fix bts#524.
But this behavior is very convenient to parse the Linux kernel. *)
-let mergeInlinesWithAlphaConvert () =
+let mergeInlinesWithAlphaConvert () =
mergeInlines && Kernel.AggressiveMerging.get ()
@@ -91,285 +91,285 @@ let prefix p s =
let d_nloc fmt (lo: (location * int) option) =
match lo with
None -> Format.fprintf fmt "None"
- | Some (l, idx) ->
+ | Some (l, idx) ->
Format.fprintf fmt "Some(%d at %a)" idx Cil_printer.pp_location l
type ('a, 'b) node =
- { nname: 'a; (* The actual name *)
- nfidx: int; (* The file index *)
- ndata: 'b; (* Data associated with the node *)
- mutable nloc: (location * int) option;
- (* location where defined and index within the file of the definition.
- * If None then it means that this node actually DOES NOT appear in the
- * given file. In rare occasions we need to talk in a given file about
- * types that are not defined in that file. This happens with undefined
- * structures but also due to cross-contamination of types in a few of
- * the cases of combineType (see the definition of combineTypes). We
- * try never to choose as representatives nodes without a definition.
- * We also choose as representative the one that appears earliest *)
- mutable nrep: ('a, 'b) node;
- (* A pointer to another node in its class (one
- * closer to the representative). The nrep node
- * is always in an earlier file, except for the
- * case where a name is undefined in one file
- * and defined in a later file. If this pointer
- * points to the node itself then this is the
- * representative. *)
- mutable nmergedSyns: bool (* Whether we have merged the synonyms for
- * the node of this name *)
- }
+ { nname: 'a; (* The actual name *)
+ nfidx: int; (* The file index *)
+ ndata: 'b; (* Data associated with the node *)
+ mutable nloc: (location * int) option;
+ (* location where defined and index within the file of the definition.
+ * If None then it means that this node actually DOES NOT appear in the
+ * given file. In rare occasions we need to talk in a given file about
+ * types that are not defined in that file. This happens with undefined
+ * structures but also due to cross-contamination of types in a few of
+ * the cases of combineType (see the definition of combineTypes). We
+ * try never to choose as representatives nodes without a definition.
+ * We also choose as representative the one that appears earliest *)
+ mutable nrep: ('a, 'b) node;
+ (* A pointer to another node in its class (one
+ * closer to the representative). The nrep node
+ * is always in an earlier file, except for the
+ * case where a name is undefined in one file
+ * and defined in a later file. If this pointer
+ * points to the node itself then this is the
+ * representative. *)
+ mutable nmergedSyns: bool (* Whether we have merged the synonyms for
+ * the node of this name *)
+ }
module Merging
- (H:
- sig
- include Hashtbl.HashedType
- val merge_synonym: t -> bool (* whether this name should be considered
- for merging or not.
+ (H:
+ sig
+ include Hashtbl.HashedType
+ val merge_synonym: t -> bool (* whether this name should be considered
+ for merging or not.
*)
- val compare: t -> t -> int
- val output: Format.formatter -> t -> unit
- end
- ):
+ val compare: t -> t -> int
+ val output: Format.formatter -> t -> unit
+ end
+ ):
sig
-type 'a eq_table
-type 'a syn_table
-val create_eq_table: int -> 'a eq_table
-val find_eq_table: 'a eq_table -> (int * H.t) -> (H.t, 'a) node
-val add_eq_table: 'a eq_table -> (int * H.t) -> (H.t,'a) node -> unit
-val iter_eq_table:
- ((int * H.t) -> (H.t,'a) node -> unit) -> 'a eq_table -> unit
-val clear_eq: 'a eq_table -> unit
-val create_syn_table: int -> 'a syn_table
-val clear_syn: 'a syn_table -> unit
-val mkSelfNode:
- 'a eq_table -> 'a syn_table -> int -> H.t -> 'a ->
- (location * int) option -> (H.t, 'a) node
-val find: bool -> (H.t, 'a) node -> (H.t, 'a) node
-val union: (H.t, 'a) node -> (H.t,'a) node -> (H.t, 'a) node * (unit -> unit)
-val findReplacement:
- bool -> 'a eq_table -> int -> H.t -> ('a * int) option
-val getNode: 'a eq_table -> 'a syn_table -> int ->
- H.t -> 'a -> (location * int) option -> (H.t, 'a) node
-(* [doMergeSynonyms eq compare]
- tries to merge synonyms. Do not give an error if they fail to merge
- compare is a comparison function that throws Failure if no match *)
-val doMergeSynonyms: 'a syn_table -> (int -> 'a -> int -> 'a -> unit) -> unit
-val dumpGraph: string -> 'a eq_table -> unit
+ type 'a eq_table
+ type 'a syn_table
+ val create_eq_table: int -> 'a eq_table
+ val find_eq_table: 'a eq_table -> (int * H.t) -> (H.t, 'a) node
+ val add_eq_table: 'a eq_table -> (int * H.t) -> (H.t,'a) node -> unit
+ val iter_eq_table:
+ ((int * H.t) -> (H.t,'a) node -> unit) -> 'a eq_table -> unit
+ val clear_eq: 'a eq_table -> unit
+ val create_syn_table: int -> 'a syn_table
+ val clear_syn: 'a syn_table -> unit
+ val mkSelfNode:
+ 'a eq_table -> 'a syn_table -> int -> H.t -> 'a ->
+ (location * int) option -> (H.t, 'a) node
+ val find: bool -> (H.t, 'a) node -> (H.t, 'a) node
+ val union: (H.t, 'a) node -> (H.t,'a) node -> (H.t, 'a) node * (unit -> unit)
+ val findReplacement:
+ bool -> 'a eq_table -> int -> H.t -> ('a * int) option
+ val getNode: 'a eq_table -> 'a syn_table -> int ->
+ H.t -> 'a -> (location * int) option -> (H.t, 'a) node
+ (* [doMergeSynonyms eq compare]
+ tries to merge synonyms. Do not give an error if they fail to merge
+ compare is a comparison function that throws Failure if no match *)
+ val doMergeSynonyms: 'a syn_table -> (int -> 'a -> int -> 'a -> unit) -> unit
+ val dumpGraph: string -> 'a eq_table -> unit
end
=
struct
module Elts =
- struct
- type t = int * H.t
- let hash (d,x) = 19 * d + H.hash x
- let equal (d1,x1) (d2,x2) = d1 = d2 && H.equal x1 x2
- let compare (d1,x1) (d2,x2) =
- let res = compare d1 d2 in
- if res = 0 then H.compare x1 x2 else res
- end
-
-(* Find the representative for a node and compress the paths in the process *)
-module Heq = Hashtbl.Make (Elts)
+ struct
+ type t = int * H.t
+ let hash (d,x) = 19 * d + H.hash x
+ let equal (d1,x1) (d2,x2) = d1 = d2 && H.equal x1 x2
+ let compare (d1,x1) (d2,x2) =
+ let res = compare d1 d2 in
+ if res = 0 then H.compare x1 x2 else res
+ end
-module Iter_sorted = FCMap.Make(Elts)
+ (* Find the representative for a node and compress the paths in the process *)
+ module Heq = Hashtbl.Make (Elts)
-module Hsyn = Hashtbl.Make(H)
+ module Iter_sorted = FCMap.Make(Elts)
-type 'a eq_table = (H.t,'a) node Heq.t
-type 'a syn_table = (H.t,'a) node Hsyn.t
+ module Hsyn = Hashtbl.Make(H)
-let create_eq_table x = Heq.create x
-let create_syn_table x = Hsyn.create x
+ type 'a eq_table = (H.t,'a) node Heq.t
+ type 'a syn_table = (H.t,'a) node Hsyn.t
-let clear_eq = Heq.clear
-let clear_syn = Hsyn.clear
+ let create_eq_table x = Heq.create x
+ let create_syn_table x = Hsyn.create x
-let find_eq_table = Heq.find
+ let clear_eq = Heq.clear
+ let clear_syn = Hsyn.clear
-let add_eq_table = Heq.add
+ let find_eq_table = Heq.find
-let iter_eq_table f t =
- let sorted = Heq.fold Iter_sorted.add t Iter_sorted.empty in
- Iter_sorted.iter f sorted
+ let add_eq_table = Heq.add
-(* Make a node with a self loop. This is quite tricky. *)
-let mkSelfNode eq syn fidx name data l =
- let rec res = { nname = name; nfidx = fidx; ndata = data; nloc = l;
- nrep = res; nmergedSyns = false; }
- in
- Heq.add eq (fidx, name) res; (* Add it to the proper table *)
- (* mergeSynonyms is not active for anonymous types, probably because it is
- licit to have two distinct anonymous types in two different files
- (which should not be merged). However, for anonymous enums, they
- can, and are, in fact merged by CIL. Hence, we permit the merging of
- anonymous enums with the same base name *)
- if mergeSynonyms && H.merge_synonym name
- then Hsyn.add syn name res;
- res
+ let iter_eq_table f t =
+ let sorted = Heq.fold Iter_sorted.add t Iter_sorted.empty in
+ Iter_sorted.iter f sorted
-(* Find the representative with or without path compression *)
-let rec find pathcomp nd =
- let dkey = Kernel.dkey_linker_find in
- Kernel.debug ~dkey "find %a(%d)" H.output nd.nname nd.nfidx ;
- if nd.nrep == nd then begin
- Kernel.debug ~dkey "= %a(%d)" H.output nd.nname nd.nfidx ;
- nd
- end else begin
- let res = find pathcomp nd.nrep in
- if usePathCompression && pathcomp && nd.nrep != res then
- nd.nrep <- res; (* Compress the paths *)
+ (* Make a node with a self loop. This is quite tricky. *)
+ let mkSelfNode eq syn fidx name data l =
+ let rec res = { nname = name; nfidx = fidx; ndata = data; nloc = l;
+ nrep = res; nmergedSyns = false; }
+ in
+ Heq.add eq (fidx, name) res; (* Add it to the proper table *)
+ (* mergeSynonyms is not active for anonymous types, probably because it is
+ licit to have two distinct anonymous types in two different files
+ (which should not be merged). However, for anonymous enums, they
+ can, and are, in fact merged by CIL. Hence, we permit the merging of
+ anonymous enums with the same base name *)
+ if mergeSynonyms && H.merge_synonym name
+ then Hsyn.add syn name res;
res
- end
+
+ (* Find the representative with or without path compression *)
+ let rec find pathcomp nd =
+ let dkey = Kernel.dkey_linker_find in
+ Kernel.debug ~dkey "find %a(%d)" H.output nd.nname nd.nfidx ;
+ if nd.nrep == nd then begin
+ Kernel.debug ~dkey "= %a(%d)" H.output nd.nname nd.nfidx ;
+ nd
+ end else begin
+ let res = find pathcomp nd.nrep in
+ if usePathCompression && pathcomp && nd.nrep != res then
+ nd.nrep <- res; (* Compress the paths *)
+ res
+ end
-(* Union two nodes and return the new representative. We prefer as the
- * representative a node defined earlier. We try not to use as
- * representatives nodes that are not defined in their files. We return a
- * function for undoing the union. Make sure that between the union and the
- * undo you do not do path compression *)
-let union nd1 nd2 =
- (* Move to the representatives *)
- let nd1 = find true nd1 in
- let nd2 = find true nd2 in
- if nd1 == nd2 then begin
- (* It can happen that we are trying to union two nodes that are already
- * equivalent. This is because between the time we check that two nodes
- * are not already equivalent and the time we invoke the union operation
- * we check type isomorphism which might change the equivalence classes *)
+ (* Union two nodes and return the new representative. We prefer as the
+ * representative a node defined earlier. We try not to use as
+ * representatives nodes that are not defined in their files. We return a
+ * function for undoing the union. Make sure that between the union and the
+ * undo you do not do path compression *)
+ let union nd1 nd2 =
+ (* Move to the representatives *)
+ let nd1 = find true nd1 in
+ let nd2 = find true nd2 in
+ if nd1 == nd2 then begin
+ (* It can happen that we are trying to union two nodes that are already
+ * equivalent. This is because between the time we check that two nodes
+ * are not already equivalent and the time we invoke the union operation
+ * we check type isomorphism which might change the equivalence classes *)
(*
ignore (warn "unioning already equivalent nodes for %s(%d)"
nd1.nname nd1.nfidx);
*)
- nd1, fun x -> x
- end else begin
- let rep, norep = (* Choose the representative *)
- if (nd1.nloc != None) = (nd2.nloc != None) then
- (* They have the same defined status. Choose the earliest *)
- if nd1.nfidx < nd2.nfidx then nd1, nd2
- else if nd1.nfidx > nd2.nfidx then nd2, nd1
- else (* In the same file. Choose the one with the earliest index *)
- begin
- match nd1.nloc, nd2.nloc with
+ nd1, fun x -> x
+ end else begin
+ let rep, norep = (* Choose the representative *)
+ if (nd1.nloc != None) = (nd2.nloc != None) then
+ (* They have the same defined status. Choose the earliest *)
+ if nd1.nfidx < nd2.nfidx then nd1, nd2
+ else if nd1.nfidx > nd2.nfidx then nd2, nd1
+ else (* In the same file. Choose the one with the earliest index *)
+ begin
+ match nd1.nloc, nd2.nloc with
Some (_, didx1), Some (_, didx2) ->
- if didx1 < didx2 then nd1, nd2 else
- if didx1 > didx2 then nd2, nd1
- else begin
- Kernel.warning
- "Merging two elements (%a and %a) \
- in the same file (%d) \
- with the same idx (%d) within the file"
- H.output nd1.nname H.output nd2.nname nd1.nfidx didx1 ;
- nd1, nd2
- end
+ if didx1 < didx2 then nd1, nd2 else
+ if didx1 > didx2 then nd2, nd1
+ else begin
+ Kernel.warning
+ "Merging two elements (%a and %a) \
+ in the same file (%d) \
+ with the same idx (%d) within the file"
+ H.output nd1.nname H.output nd2.nname nd1.nfidx didx1 ;
+ nd1, nd2
+ end
| _, _ ->
- (* both none. Does not matter which one we choose. Should not happen
- though. *)
- (* sm: it does happen quite a bit when, e.g. merging STLport with
- some client source; I'm disabling the warning since it supposedly
- is harmless anyway, so is useless noise *)
- (* sm: re-enabling on claim it now will probably not happen *)
+ (* both none. Does not matter which one we choose. Should not happen
+ though. *)
+ (* sm: it does happen quite a bit when, e.g. merging STLport with
+ some client source; I'm disabling the warning since it supposedly
+ is harmless anyway, so is useless noise *)
+ (* sm: re-enabling on claim it now will probably not happen *)
Kernel.warning ~current:true
- "Merging two undefined elements in the same file: %a and %a"
- H.output nd1.nname H.output nd2.nname ;
+ "Merging two undefined elements in the same file: %a and %a"
+ H.output nd1.nname H.output nd2.nname ;
nd1, nd2
- end
+ end
else (* One is defined, the other is not. Choose the defined one *)
- if nd1.nloc != None then nd1, nd2 else nd2, nd1
- in
- let oldrep = norep.nrep in
- norep.nrep <- rep;
- rep, (fun () -> norep.nrep <- oldrep)
- end
+ if nd1.nloc != None then nd1, nd2 else nd2, nd1
+ in
+ let oldrep = norep.nrep in
+ norep.nrep <- rep;
+ rep, (fun () -> norep.nrep <- oldrep)
+ end
-let findReplacement pathcomp eq fidx name =
- let dkey = Kernel.dkey_linker_find in
+ let findReplacement pathcomp eq fidx name =
+ let dkey = Kernel.dkey_linker_find in
Kernel.debug ~dkey "findReplacement for %a(%d)" H.output name fidx;
- try
- let nd = Heq.find eq (fidx, name) in
- if nd.nrep == nd then begin
- Kernel.debug ~dkey "is a representative";
- None (* No replacement if this is the representative of its class *)
- end else
- let rep = find pathcomp nd in
- if rep != rep.nrep then
- Kernel.abort "find does not return the representative" ;
- Kernel.debug ~dkey "RES = %a(%d)" H.output rep.nname rep.nfidx;
- Some (rep.ndata, rep.nfidx)
- with Not_found -> begin
- Kernel.debug ~dkey "not found in the map";
- None
- end
+ try
+ let nd = Heq.find eq (fidx, name) in
+ if nd.nrep == nd then begin
+ Kernel.debug ~dkey "is a representative";
+ None (* No replacement if this is the representative of its class *)
+ end else
+ let rep = find pathcomp nd in
+ if rep != rep.nrep then
+ Kernel.abort "find does not return the representative" ;
+ Kernel.debug ~dkey "RES = %a(%d)" H.output rep.nname rep.nfidx;
+ Some (rep.ndata, rep.nfidx)
+ with Not_found -> begin
+ Kernel.debug ~dkey "not found in the map";
+ None
+ end
-(* Make a node if one does not already exist. Otherwise return the
- * representative *)
-let getNode eq syn fidx name data l =
- let dkey = Kernel.dkey_linker_find in
- Kernel.debug ~dkey "getNode(%a(%d), %a)" H.output name fidx d_nloc l;
- try
- let res = Heq.find eq (fidx, name) in
-
- (match res.nloc, l with
- (* Maybe we have a better location now *)
- None, Some _ -> res.nloc <- l
- | Some (old_l, old_idx), Some (l, idx) ->
- if old_idx != idx then
- Kernel.warning ~current:true
- "Duplicate definition of node %a(%d) at indices %d(%a) and %d(%a)"
- H.output name fidx old_idx
- Cil_printer.pp_location old_l idx
- Cil_printer.pp_location l
- | _, _ -> ());
- Kernel.debug ~dkey "node already found";
- find false res (* No path compression *)
- with Not_found -> begin
- let res = mkSelfNode eq syn fidx name data l in
- Kernel.debug ~dkey "made a new one";
- res
- end
+ (* Make a node if one does not already exist. Otherwise return the
+ * representative *)
+ let getNode eq syn fidx name data l =
+ let dkey = Kernel.dkey_linker_find in
+ Kernel.debug ~dkey "getNode(%a(%d), %a)" H.output name fidx d_nloc l;
+ try
+ let res = Heq.find eq (fidx, name) in
+
+ (match res.nloc, l with
+ (* Maybe we have a better location now *)
+ None, Some _ -> res.nloc <- l
+ | Some (old_l, old_idx), Some (l, idx) ->
+ if old_idx != idx then
+ Kernel.warning ~current:true
+ "Duplicate definition of node %a(%d) at indices %d(%a) and %d(%a)"
+ H.output name fidx old_idx
+ Cil_printer.pp_location old_l idx
+ Cil_printer.pp_location l
+ | _, _ -> ());
+ Kernel.debug ~dkey "node already found";
+ find false res (* No path compression *)
+ with Not_found -> begin
+ let res = mkSelfNode eq syn fidx name data l in
+ Kernel.debug ~dkey "made a new one";
+ res
+ end
-let doMergeSynonyms syn compare =
- Hsyn.iter
- (fun n node ->
- if not node.nmergedSyns then begin
- (* find all the nodes for the same name *)
- let all = Hsyn.find_all syn n in
- (* classes are a list of representative for the nd name.
- We'll select an appropriate one according to the comparison
- function. *)
- let tryone classes nd =
- nd.nmergedSyns <- true;
- (* Compare in turn with all the classes we have so far *)
- let rec compareWithClasses = function
- | [] -> [nd] (* No more classes. Add this as a new class *)
- | c :: restc ->
- try
- compare c.nfidx c.ndata nd.nfidx nd.ndata;
- (* Success. Stop here the comparison *)
- c :: restc
- with Failure _ -> (* Failed. Try next class *)
- c :: (compareWithClasses restc)
- in
- compareWithClasses classes
- in
- (* Start with an empty set of classes for this name *)
- let _ = List.fold_left tryone [] all in
- ()
- end)
- syn
-
-(* Dump a graph. No need to use ~dkey, this function is never called unless
- we are in proper debug mode. *)
-let dumpGraph what eq : unit =
- Kernel.debug "Equivalence graph for %s is:" what;
- iter_eq_table
- (fun (fidx, name) nd ->
- Kernel.debug " %a(%d) %s-> "
- H.output name fidx (if nd.nloc = None then "(undef)" else "");
- if nd.nrep == nd then
- Kernel.debug "*"
- else
- Kernel.debug " %a(%d)" H.output nd.nrep.nname nd.nrep.nfidx
- ) eq
+ let doMergeSynonyms syn compare =
+ Hsyn.iter
+ (fun n node ->
+ if not node.nmergedSyns then begin
+ (* find all the nodes for the same name *)
+ let all = Hsyn.find_all syn n in
+ (* classes are a list of representative for the nd name.
+ We'll select an appropriate one according to the comparison
+ function. *)
+ let tryone classes nd =
+ nd.nmergedSyns <- true;
+ (* Compare in turn with all the classes we have so far *)
+ let rec compareWithClasses = function
+ | [] -> [nd] (* No more classes. Add this as a new class *)
+ | c :: restc ->
+ try
+ compare c.nfidx c.ndata nd.nfidx nd.ndata;
+ (* Success. Stop here the comparison *)
+ c :: restc
+ with Failure _ -> (* Failed. Try next class *)
+ c :: (compareWithClasses restc)
+ in
+ compareWithClasses classes
+ in
+ (* Start with an empty set of classes for this name *)
+ let _ = List.fold_left tryone [] all in
+ ()
+ end)
+ syn
+
+ (* Dump a graph. No need to use ~dkey, this function is never called unless
+ we are in proper debug mode. *)
+ let dumpGraph what eq : unit =
+ Kernel.debug "Equivalence graph for %s is:" what;
+ iter_eq_table
+ (fun (fidx, name) nd ->
+ Kernel.debug " %a(%d) %s-> "
+ H.output name fidx (if nd.nloc = None then "(undef)" else "");
+ if nd.nrep == nd then
+ Kernel.debug "*"
+ else
+ Kernel.debug " %a(%d)" H.output nd.nrep.nname nd.nrep.nfidx
+ ) eq
end
@@ -378,20 +378,20 @@ end
* names must be different from variable names!! We one alpha table both for
* variables and types. *)
let vtAlpha: location Alpha.alphaTable
- = H.create 57 (* Variables and
- * types *)
+ = H.create 57 (* Variables and
+ * types *)
let sAlpha: location Alpha.alphaTable
- = H.create 57 (* Structures and
- * unions have
- * the same name
- * space *)
+ = H.create 57 (* Structures and
+ * unions have
+ * the same name
+ * space *)
let eAlpha: location Alpha.alphaTable
- = H.create 57 (* Enumerations *)
+ = H.create 57 (* Enumerations *)
let aeAlpha = H.create 57 (* Anonymous enums. *)
(* The original mergecil uses plain old Hashtbl for everything. *)
-module PlainMerging =
+module PlainMerging =
Merging
(struct
type t = string
@@ -400,7 +400,7 @@ module PlainMerging =
let compare = compare
let merge_synonym name = not (prefix "__anon" name)
let output = Format.pp_print_string
- end)
+ end)
module LogicMerging =
Merging
@@ -501,25 +501,25 @@ let pretty_volatile_kind fmt v =
module VolatileMerging =
Merging
(struct
- type t = identified_term * volatile_kind
- let hash_term it = Logic_utils.hash_term it.it_content
- let hash = function
- | ts,R -> 1 + 5 * hash_term ts
- | ts,W -> 2 + 5 * hash_term ts
- let equal (t1,v1) (t2,v2) =
- equal_volatile_kind v1 v2 &&
- Logic_utils.is_same_identified_term t1 t2
- let compare (t1,v1) (t2,v2) =
- let cmp = compare_volatile_kind v1 v2 in
- if cmp <> 0 then cmp else
- Logic_utils.compare_term t1.it_content t2.it_content
-
- let merge_synonym _ = true
- let output fmt (hs,kind) =
- Format.fprintf fmt "%a function for %a volatile location"
- pretty_volatile_kind kind
- Cil_printer.pp_identified_term hs
- end)
+ type t = identified_term * volatile_kind
+ let hash_term it = Logic_utils.hash_term it.it_content
+ let hash = function
+ | ts,R -> 1 + 5 * hash_term ts
+ | ts,W -> 2 + 5 * hash_term ts
+ let equal (t1,v1) (t2,v2) =
+ equal_volatile_kind v1 v2 &&
+ Logic_utils.is_same_identified_term t1 t2
+ let compare (t1,v1) (t2,v2) =
+ let cmp = compare_volatile_kind v1 v2 in
+ if cmp <> 0 then cmp else
+ Logic_utils.compare_term t1.it_content t2.it_content
+
+ let merge_synonym _ = true
+ let output fmt (hs,kind) =
+ Format.fprintf fmt "%a function for %a volatile location"
+ pretty_volatile_kind kind
+ Cil_printer.pp_identified_term hs
+ end)
let hash_type t =
let rec aux acc depth = function
@@ -555,19 +555,19 @@ module ModelMerging =
let merge_synonym _ = true
let output fmt (s,t) =
Format.fprintf fmt "model@ %a@ { %s }" Cil_printer.pp_typ t s
- end)
+ end)
let same_int64 e1 e2 =
match constFoldToInt e1, constFoldToInt e2 with
- | Some i, Some i' -> Integer.equal i i'
- | _ -> false
+ | Some i, Some i' -> Integer.equal i i'
+ | _ -> false
let compare_int e1 e2 =
match (constFold true e1), (constFold true e2) with
- | {enode = Const(CInt64(i, _, _))}, {enode = Const(CInt64(i', _, _))} ->
- Integer.compare i i'
+ | {enode = Const(CInt64(i, _, _))}, {enode = Const(CInt64(i', _, _))} ->
+ Integer.compare i i'
| e1,e2 -> Cil_datatype.Exp.compare e1 e2
- (* not strictly accurate, but should do the trick anyway *)
+(* not strictly accurate, but should do the trick anyway *)
let have_same_enum_items oldei ei =
if List.length oldei.eitems <> List.length ei.eitems then
@@ -576,11 +576,11 @@ let have_same_enum_items oldei ei =
* conservative check. *)
List.iter2
(fun old_item item ->
- if old_item.einame <> item.einame then
- raise (Failure
- "different names for enumeration items");
- if not (same_int64 old_item.eival item.eival) then
- raise (Failure "different values for enumeration items"))
+ if old_item.einame <> item.einame then
+ raise (Failure
+ "different names for enumeration items");
+ if not (same_int64 old_item.eival item.eival) then
+ raise (Failure "different values for enumeration items"))
oldei.eitems ei.eitems
let compare_enum_item e1 e2 =
@@ -606,15 +606,15 @@ module EnumMerging =
Datatype.String.hash key
let equal e1 e2 =
(is_anonymous_enum e1 && is_anonymous_enum e2 &&
- (same_enum_items e1 e2 ||
- (e1.ename = e2.ename &&
- (e2.ename <-
- fst
- (Alpha.newAlphaName
- aeAlpha e2.ename Cil_datatype.Location.unknown);
- Kernel.debug ~dkey:Kernel.dkey_linker
- "new anonymous name %s" e2.ename;
- false))))
+ (same_enum_items e1 e2 ||
+ (e1.ename = e2.ename &&
+ (e2.ename <-
+ fst
+ (Alpha.newAlphaName
+ aeAlpha e2.ename Cil_datatype.Location.unknown);
+ Kernel.debug ~dkey:Kernel.dkey_linker
+ "new anonymous name %s" e2.ename;
+ false))))
|| e1.ename = e2.ename
let compare e1 e2 =
if is_anonymous_enum e1 then
@@ -626,7 +626,7 @@ module EnumMerging =
let merge_synonym _ = true
let output fmt e =
Cil_printer.pp_global fmt (GEnumTag (e, Cil_datatype.Location.unknown))
- end)
+ end)
open PlainMerging
@@ -687,12 +687,12 @@ let theFile = ref []
(* we keep only one declaration for each function. The other ones are simply
discarded, but we need to merge their spec. This is done at the end
of the 2nd pass, to avoid going through theFile too many times.
- *)
+*)
let spec_to_merge = Cil_datatype.Varinfo.Hashtbl.create 59;;
(* renaming to be performed in spec found in declarations when there is
a definition for the given function. Similar to spec_to_merge table.
- *)
+*)
let formals_renaming = Cil_datatype.Varinfo.Hashtbl.create 59;;
(* add 'g' to the merged file *)
@@ -727,12 +727,12 @@ let mergeSpec vi_ref vi_disc spec =
my_vars
(Pretty_utils.pp_list ~sep:",@ " Cil_datatype.Varinfo.pretty)
to_rename;
- let alpha = Cil.create_alpha_renaming my_vars to_rename in
+ let alpha = Cil.create_alpha_renaming my_vars to_rename in
Kernel.debug ~dkey:Kernel.dkey_linker
"Renaming spec of function %a" Cil_datatype.Varinfo.pretty vi_disc;
Kernel.debug ~dkey:Kernel.dkey_linker
"original spec is %a" Cil_printer.pp_funspec spec;
- try
+ try
let res = Cil.visitCilFunspec alpha spec in
Kernel.debug ~dkey:Kernel.dkey_linker
"renamed spec is %a" Cil_printer.pp_funspec spec;
@@ -741,7 +741,7 @@ let mergeSpec vi_ref vi_disc spec =
with Not_found -> spec
in
let spec =
- try
+ try
let alpha = Cil_datatype.Varinfo.Hashtbl.find formals_renaming vi_ref in
let res = Cil.visitCilFunspec alpha spec in
Kernel.debug ~dkey:Kernel.dkey_linker
@@ -751,7 +751,7 @@ let mergeSpec vi_ref vi_disc spec =
with Not_found -> spec
in
add_to_merge_spec vi_ref spec
-end (* else no need to keep empty specs *)
+ end (* else no need to keep empty specs *)
(* The index of the current file being scanned *)
let currentFidx = ref 0
@@ -895,29 +895,29 @@ let rec global_annot_pass1 g = match g with
CurrentLoc.set l;
ignore (PlainMerging.getNode laEq laSyn !currentFidx id (id,decls)
(Some (l,!currentDeclIdx)));
- List.iter global_annot_pass1 decls
+ List.iter global_annot_pass1 decls
| Dfun_or_pred (li,l) ->
CurrentLoc.set l;
- let mynode =
- LogicMerging.getNode
- lfEq lfSyn !currentFidx li li None
+ let mynode =
+ LogicMerging.getNode
+ lfEq lfSyn !currentFidx li li None
in
(* NB: in case of mix decl/def it is the decl location that is taken. *)
if mynode.nloc = None then
- ignore
+ ignore
(LogicMerging.getNode lfEq lfSyn !currentFidx li li
(Some (l, !currentDeclIdx)))
| Dtype_annot (pi,l) ->
CurrentLoc.set l;
- ignore (LogicMerging.getNode
+ ignore (LogicMerging.getNode
lfEq lfSyn !currentFidx pi pi
(Some (l, !currentDeclIdx)))
- | Dmodel_annot (mfi,l) ->
+ | Dmodel_annot (mfi,l) ->
CurrentLoc.set l;
- ignore (ModelMerging.getNode
+ ignore (ModelMerging.getNode
mfEq mfSyn !currentFidx (mfi.mi_name,mfi.mi_base_type) mfi
(Some (l, !currentDeclIdx)))
- | Dcustom_annot (c, n, _, l) ->
+ | Dcustom_annot (c, n, _, l) ->
Format.eprintf "Mergecil : custom@.";
CurrentLoc.set l;
ignore (PlainMerging.getNode
@@ -925,7 +925,7 @@ let rec global_annot_pass1 g = match g with
(Some (l, !currentDeclIdx)))
| Dinvariant (pi,l) ->
CurrentLoc.set l;
- ignore (LogicMerging.getNode
+ ignore (LogicMerging.getNode
lfEq lfSyn !currentFidx pi pi
(Some (l, !currentDeclIdx)))
| Dtype (info,l) ->
@@ -949,7 +949,7 @@ let rec global_annot_pass1 g = match g with
* an integer *)
let intEnumInfo =
let name = "!!!intEnumInfo!!!"
- (* invalid C name. Can't clash with anything. *)
+ (* invalid C name. Can't clash with anything. *)
in
{ eorig_name = name;
ename = name;
@@ -963,8 +963,8 @@ let intEnumInfoNode =
EnumMerging.getNode eEq eSyn 0 intEnumInfo intEnumInfo
(Some (Cil_datatype.Location.unknown, 0))
- (* Combine the types. Raises the Failure exception with an error message.
- * isdef says whether the new type is for a definition *)
+(* Combine the types. Raises the Failure exception with an error message.
+ * isdef says whether the new type is for a definition *)
type combineWhat =
CombineFundef (* The new definition is for a function definition. The old
* is for a prototype *)
@@ -984,45 +984,45 @@ let rec combineTypes (what: combineWhat)
if oldk == k
then oldk
else
- if bytesSizeOfInt oldk=bytesSizeOfInt k && isSigned oldk=isSigned k
- then
- (* the types contain the same sort of values but are not equal.
- For example on x86_16 machdep unsigned short and unsigned int. *)
- if rank oldk<rank k then k else oldk
- else
- (* GCC allows a function definition to have a more precise integer
- * type than a prototype that says "int" *)
- if Cil.gccMode () && oldk = IInt && bitsSizeOf t <= 32
- && (what = CombineFunarg || what = CombineFunret)
- then
- k
- else (
- let msg =
- Format.asprintf
- "different integer types %a and %a"
- Cil_printer.pp_typ oldt Cil_printer.pp_typ t
- in
- raise (Failure msg))
+ if bytesSizeOfInt oldk=bytesSizeOfInt k && isSigned oldk=isSigned k
+ then
+ (* the types contain the same sort of values but are not equal.
+ For example on x86_16 machdep unsigned short and unsigned int. *)
+ if rank oldk<rank k then k else oldk
+ else
+ (* GCC allows a function definition to have a more precise integer
+ * type than a prototype that says "int" *)
+ if Cil.gccMode () && oldk = IInt && bitsSizeOf t <= 32
+ && (what = CombineFunarg || what = CombineFunret)
+ then
+ k
+ else (
+ let msg =
+ Format.asprintf
+ "different integer types %a and %a"
+ Cil_printer.pp_typ oldt Cil_printer.pp_typ t
+ in
+ raise (Failure msg))
in
TInt (combineIK oldik ik, addAttributes olda a)
| TFloat (oldfk, olda), TFloat (fk, a) ->
let combineFK oldk k =
if oldk == k then oldk else
- (* GCC allows a function definition to have a more precise integer
- * type than a prototype that says "double" *)
- if Cil.gccMode () && oldk = FDouble && k = FFloat &&
- (what = CombineFunarg || what = CombineFunret)
- then
- k
- else
- raise (Failure "different floating point types")
+ (* GCC allows a function definition to have a more precise integer
+ * type than a prototype that says "double" *)
+ if Cil.gccMode () && oldk = FDouble && k = FFloat &&
+ (what = CombineFunarg || what = CombineFunret)
+ then
+ k
+ else
+ raise (Failure "different floating point types")
in
TFloat (combineFK oldfk fk, addAttributes olda a)
| TEnum (oldei, olda), TEnum (ei, a) ->
- (* Matching enumerations always succeeds. But sometimes it maps both
- * enumerations to integers *)
+ (* Matching enumerations always succeeds. But sometimes it maps both
+ * enumerations to integers *)
matchEnumInfo oldfidx oldei fidx ei;
TEnum (oldei, addAttributes olda a)
@@ -1037,7 +1037,7 @@ let rec combineTypes (what: combineWhat)
| TComp (oldci, _, olda) , TComp (ci, _, a) ->
matchCompInfo oldfidx oldci fidx ci;
- (* If we get here we were successful *)
+ (* If we get here we were successful *)
TComp (oldci, empty_size_cache (), addAttributes olda a)
| TArray (oldbt, oldsz, _, olda), TArray (bt, sz, _, a) ->
@@ -1065,32 +1065,32 @@ let rec combineTypes (what: combineWhat)
in
if oldva != va then
raise (Failure "different vararg specifiers");
- (* If one does not have arguments, believe the one with the
- * arguments *)
+ (* If one does not have arguments, believe the one with the
+ * arguments *)
let newargs =
if oldargs = None then args else
- if args = None then oldargs else
- let oldargslist = argsToList oldargs in
- let argslist = argsToList args in
- if List.length oldargslist <> List.length argslist then
- raise (Failure "different number of arguments")
- else begin
- (* Go over the arguments and update the old ones with the
- * adjusted types *)
- Some
- (List.map2
- (fun (on, ot, oa) (an, at, aa) ->
- let n = if an <> "" then an else on in
- let t =
- combineTypes
- (if what = CombineFundef then CombineFunarg
- else CombineOther)
- oldfidx ot fidx at
- in
- let a = addAttributes oa aa in
- (n, t, a))
- oldargslist argslist)
- end
+ if args = None then oldargs else
+ let oldargslist = argsToList oldargs in
+ let argslist = argsToList args in
+ if List.length oldargslist <> List.length argslist then
+ raise (Failure "different number of arguments")
+ else begin
+ (* Go over the arguments and update the old ones with the
+ * adjusted types *)
+ Some
+ (List.map2
+ (fun (on, ot, oa) (an, at, aa) ->
+ let n = if an <> "" then an else on in
+ let t =
+ combineTypes
+ (if what = CombineFundef then CombineFunarg
+ else CombineOther)
+ oldfidx ot fidx at
+ in
+ let a = addAttributes oa aa in
+ (n, t, a))
+ oldargslist argslist)
+ end
in
let olda =
if Cil.hasAttribute "missingproto" a then olda
@@ -1107,7 +1107,7 @@ let rec combineTypes (what: combineWhat)
| TNamed (oldt, olda), TNamed (t, a) ->
matchTypeInfo oldfidx oldt fidx t;
- (* If we get here we were able to match *)
+ (* If we get here we were able to match *)
TNamed(oldt, addAttributes olda a)
(* Unroll first the new type *)
@@ -1122,12 +1122,12 @@ let rec combineTypes (what: combineWhat)
| _ -> (
(* raise (Failure "different type constructors") *)
- let msg:string =
- Format.asprintf
- "different type constructors: %a vs. %a"
- Cil_printer.pp_typ oldt Cil_printer.pp_typ t
- in
- raise (Failure msg))
+ let msg:string =
+ Format.asprintf
+ "different type constructors: %a vs. %a"
+ Cil_printer.pp_typ oldt Cil_printer.pp_typ t
+ in
+ raise (Failure msg))
(* When comparing composite types for equality, we tolerate
some differences related to packed/aligned attributes:
@@ -1183,8 +1183,8 @@ and matchCompInfo (oldfidx: int) (oldci: compinfo)
(* See if we have a mapping already *)
(* Make the nodes if not already made. Actually return the
* representatives *)
- let oldcinode =
- PlainMerging.getNode sEq sSyn oldfidx oldci.cname oldci None
+ let oldcinode =
+ PlainMerging.getNode sEq sSyn oldfidx oldci.cname oldci None
in
let cinode = PlainMerging.getNode sEq sSyn fidx ci.cname ci None in
if oldcinode == cinode then (* We already know they are the same *)
@@ -1209,9 +1209,9 @@ and matchCompInfo (oldfidx: int) (oldci: compinfo)
CurrentLoc.set curLoc;
let aggregate_name = if cstruct then "struct" else "union" in
let msg = Printf.sprintf
- "different number of fields in %s %s and %s %s: %d != %d."
- aggregate_name oldci.cname aggregate_name ci.cname
- old_len len
+ "different number of fields in %s %s and %s %s: %d != %d."
+ aggregate_name oldci.cname aggregate_name ci.cname
+ old_len len
in
raise (Failure msg)
end;
@@ -1254,49 +1254,49 @@ and matchCompInfo (oldfidx: int) (oldci: compinfo)
(* Make sure the types are compatible *)
(* Note: 6.2.7 §1 states that the names of the fields should be the
same. We do not force this for now, but could do it. *)
- let newtype =
- combineTypes CombineOther oldfidx oldf.ftype fidx f.ftype
- in
+ let newtype =
+ combineTypes CombineOther oldfidx oldf.ftype fidx f.ftype
+ in
(* Change the type in the representative *)
- oldf.ftype <- newtype)
+ oldf.ftype <- newtype)
oldci.cfields ci.cfields
with Failure reason ->
(* Our assumption was wrong. Forget the isomorphism *)
undo ();
- let fields_old =
+ let fields_old =
Format.asprintf "%a"
- Cil_printer.pp_global
- (GCompTag(oldci, Cil_datatype.Location.unknown))
- in
- let fields =
+ Cil_printer.pp_global
+ (GCompTag(oldci, Cil_datatype.Location.unknown))
+ in
+ let fields =
Format.asprintf "%a"
Cil_printer.pp_global (GCompTag(ci, Cil_datatype.Location.unknown))
- in
- let fullname_old = compFullName oldci in
- let fullname = compFullName ci in
+ in
+ let fullname_old = compFullName oldci in
+ let fullname = compFullName ci in
let msg =
- match fullname_old = fullname,
- fields_old = fields (* Could also use a special comparison *)
- with
- true, true ->
- Format.asprintf
- "Definitions of %s are not isomorphic. Reason follows:@\n@?%s"
- fullname_old reason
- | false, true ->
- Format.asprintf
- "%s and %s are not isomorphic. Reason follows:@\n@?%s"
- fullname_old fullname reason
- | true, false ->
- Format.asprintf
- "Definitions of %s are not isomorphic. \
- Reason follows:@\n@?%s@\n@?%s@?%s"
- fullname_old reason
- fields_old fields
- | false, false ->
- Format.asprintf
- "%s and %s are not isomorphic. Reason follows:@\n@?%s@\n@?%s@?%s"
- fullname_old fullname reason
- fields_old fields
+ match fullname_old = fullname,
+ fields_old = fields (* Could also use a special comparison *)
+ with
+ true, true ->
+ Format.asprintf
+ "Definitions of %s are not isomorphic. Reason follows:@\n@?%s"
+ fullname_old reason
+ | false, true ->
+ Format.asprintf
+ "%s and %s are not isomorphic. Reason follows:@\n@?%s"
+ fullname_old fullname reason
+ | true, false ->
+ Format.asprintf
+ "Definitions of %s are not isomorphic. \
+ Reason follows:@\n@?%s@\n@?%s@?%s"
+ fullname_old reason
+ fields_old fields
+ | false, false ->
+ Format.asprintf
+ "%s and %s are not isomorphic. Reason follows:@\n@?%s@\n@?%s@?%s"
+ fullname_old fullname reason
+ fields_old fields
in
@@ -1317,7 +1317,7 @@ and matchCompInfo (oldfidx: int) (oldci: compinfo)
and matchEnumInfo (oldfidx: int) (oldei: enuminfo)
(fidx: int) (ei: enuminfo) : unit =
(* Find the node for this enum, no path compression. *)
- let oldeinode = EnumMerging.getNode eEq eSyn oldfidx oldei oldei None
+ let oldeinode = EnumMerging.getNode eEq eSyn oldfidx oldei oldei None
in
let einode = EnumMerging.getNode eEq eSyn fidx ei ei None in
if oldeinode == einode then (* We already know they are the same *)
@@ -1335,24 +1335,24 @@ and matchEnumInfo (oldfidx: int) (oldei: enuminfo)
newrep.ndata.eattr <- addAttributes oldei.eattr ei.eattr;
()
with Failure msg -> begin
- let pp_items = Pretty_utils.pp_list ~pre:"{" ~suf:"}" ~sep:",@ "
- (fun fmt item ->
- Format.fprintf fmt "%s=%a" item.eiorig_name
- Cil_printer.pp_exp item.eival)
- in
- if oldeinode != intEnumInfoNode && einode != intEnumInfoNode then
- Kernel.warning
- "@[merging definitions of enum %s using int type@ (%s);@ items %a and@ %a@]"
- oldei.ename msg
- pp_items oldei.eitems pp_items ei.eitems;
- (* Get here if you cannot merge two enumeration nodes *)
- if oldeinode != intEnumInfoNode then begin
- let _ = EnumMerging.union oldeinode intEnumInfoNode in ()
- end;
- if einode != intEnumInfoNode then begin
- let _ = EnumMerging.union einode intEnumInfoNode in ()
- end;
- end
+ let pp_items = Pretty_utils.pp_list ~pre:"{" ~suf:"}" ~sep:",@ "
+ (fun fmt item ->
+ Format.fprintf fmt "%s=%a" item.eiorig_name
+ Cil_printer.pp_exp item.eival)
+ in
+ if oldeinode != intEnumInfoNode && einode != intEnumInfoNode then
+ Kernel.warning
+ "@[merging definitions of enum %s using int type@ (%s);@ items %a and@ %a@]"
+ oldei.ename msg
+ pp_items oldei.eitems pp_items ei.eitems;
+ (* Get here if you cannot merge two enumeration nodes *)
+ if oldeinode != intEnumInfoNode then begin
+ let _ = EnumMerging.union oldeinode intEnumInfoNode in ()
+ end;
+ if einode != intEnumInfoNode then begin
+ let _ = EnumMerging.union einode intEnumInfoNode in ()
+ end;
+ end
end
@@ -1376,22 +1376,22 @@ and matchTypeInfo (oldfidx: int) (oldti: typeinfo)
(try
ignore (combineTypes CombineOther oldfidx oldti.ttype fidx ti.ttype);
with Failure reason -> begin
- let msg =
- let oldname = oldti.tname in
- let name = ti.tname in
- if oldname = name
- then
- Format.sprintf
- "Definitions of type %s are not isomorphic. \
- Reason follows:@\n@?%s"
- oldname reason
- else
- Format.sprintf
- "Types %s and %s are not isomorphic. Reason follows:@\n@?%s"
- oldname name reason
- in
- raise (Failure msg)
- end);
+ let msg =
+ let oldname = oldti.tname in
+ let name = ti.tname in
+ if oldname = name
+ then
+ Format.sprintf
+ "Definitions of type %s are not isomorphic. \
+ Reason follows:@\n@?%s"
+ oldname reason
+ else
+ Format.sprintf
+ "Types %s and %s are not isomorphic. Reason follows:@\n@?%s"
+ oldname name reason
+ in
+ raise (Failure msg)
+ end);
let _ = union oldtnode tnode in
()
end
@@ -1472,9 +1472,9 @@ let rec update_type_repr t =
| _ -> t
let static_var_visitor = object
- inherit Cil.nopCilVisitor
- method! vvrbl vi = if vi.vstorage = Static then raise Exit; DoChildren
- end
+ inherit Cil.nopCilVisitor
+ method! vvrbl vi = if vi.vstorage = Static then raise Exit; DoChildren
+end
(*
let has_static_ref_predicate pred_info =
@@ -1489,11 +1489,11 @@ let has_static_ref_logic_function lf_info =
with Exit -> true
let matchLogicInfo oldfidx oldpi fidx pi =
- let oldtnode =
+ let oldtnode =
LogicMerging.getNode lfEq lfSyn oldfidx oldpi oldpi None
in
- let tnode =
- LogicMerging.getNode lfEq lfSyn fidx pi pi None
+ let tnode =
+ LogicMerging.getNode lfEq lfSyn fidx pi pi None
in
if oldtnode == tnode then (* We already know they are the same *)
()
@@ -1517,7 +1517,7 @@ let matchLogicInfo oldfidx oldpi fidx pi =
let matchLogicType oldfidx oldnode fidx node =
let oldtnode =
- PlainMerging.getNode ltEq ltSyn oldfidx oldnode.lt_name oldnode None
+ PlainMerging.getNode ltEq ltSyn oldfidx oldnode.lt_name oldnode None
in
let tnode = PlainMerging.getNode ltEq ltSyn fidx oldnode.lt_name node None in
if oldtnode == tnode then (* We already know they are the same *)
@@ -1536,12 +1536,12 @@ let matchLogicType oldfidx oldnode fidx node =
oldtnode.nrep <- tnode.nrep
end else
Kernel.error ~current:true
- "invalid multiple logic type declarations %s" node.lt_name
+ "invalid multiple logic type declarations %s" node.lt_name
end
let matchLogicCtor oldfidx oldpi fidx pi =
- let oldtnode =
- PlainMerging.getNode lcEq lcSyn oldfidx oldpi.ctor_name oldpi None
+ let oldtnode =
+ PlainMerging.getNode lcEq lcSyn oldfidx oldpi.ctor_name oldpi None
in
let tnode = PlainMerging.getNode lcEq lcSyn fidx pi.ctor_name pi None in
if oldtnode != tnode then
@@ -1566,7 +1566,7 @@ let matchLogicAxiomatic oldfidx (oldid,_ as oldnode) fidx (id,_ as node) =
oldanode.nrep <- anode.nrep
end else
Kernel.error ~current:true
- "invalid multiple axiomatic declarations %s" id
+ "invalid multiple axiomatic declarations %s" id
end
let matchLogicLemma oldfidx (oldid, _ as oldnode) fidx (id, _ as node) =
@@ -1580,8 +1580,8 @@ let matchLogicLemma oldfidx (oldid, _ as oldnode) fidx (id, _ as node) =
let oldattr = drop_attributes_for_merge oldattr in
let attr = drop_attributes_for_merge attr in
if Logic_utils.is_same_global_annotation
- (Dlemma (oldid,oldax,oldlabs,oldtyps,oldst,oldattr,oldloc))
- (Dlemma (id,ax,labs,typs,st,attr,loc))
+ (Dlemma (oldid,oldax,oldlabs,oldtyps,oldst,oldattr,oldloc))
+ (Dlemma (id,ax,labs,typs,st,attr,loc))
then begin
if oldfidx < fidx then
lnode.nrep <- oldlnode.nrep
@@ -1589,7 +1589,7 @@ let matchLogicLemma oldfidx (oldid, _ as oldnode) fidx (id, _ as node) =
oldlnode.nrep <- lnode.nrep
end else
Kernel.error ~current:true
- "invalid multiple lemmas or axioms declarations for %s" id
+ "invalid multiple lemmas or axioms declarations for %s" id
end
let matchVolatileClause
@@ -1617,10 +1617,10 @@ let matchVolatileClause
Cil_printer.pp_identified_term loc
end
-let matchModelField
- oldfidx ({ mi_name = oldname; mi_base_type = oldtyp } as oldnode)
+let matchModelField
+ oldfidx ({ mi_name = oldname; mi_base_type = oldtyp } as oldnode)
fidx ({mi_name = name; mi_base_type = typ } as node)
- =
+ =
let oldlnode =
ModelMerging.getNode mfEq mfSyn oldfidx (oldname,oldtyp) oldnode None
in
@@ -1638,12 +1638,12 @@ let matchModelField
oldlnode.nrep <- lnode.nrep
end
else
- Kernel.error ~current:true
+ Kernel.error ~current:true
"Model field %s of type %a is declared with different logic type: \
%a and %a"
mf.mi_name Cil_printer.pp_typ mf.mi_base_type
- Cil_printer.pp_logic_type mf.mi_field_type
- Cil_printer.pp_logic_type oldmf.mi_field_type
+ Cil_printer.pp_logic_type mf.mi_field_type
+ Cil_printer.pp_logic_type oldmf.mi_field_type
end
(* Scan all files and do two things *)
@@ -1686,8 +1686,8 @@ let oneFilePass1 (f:file) : unit =
let matchVarinfo (vi: varinfo) (loc, _ as l) =
ignore (Alpha.registerAlphaName vtAlpha vi.vname (CurrentLoc.get ()));
(* Make a node for it and put it in vEq *)
- let vinode =
- PlainMerging.mkSelfNode vEq vSyn !currentFidx vi.vname vi (Some l)
+ let vinode =
+ PlainMerging.mkSelfNode vEq vSyn !currentFidx vi.vname vi (Some l)
in
try
let oldvinode = PlainMerging.find true (H.find vEnv vi.vname) in
@@ -1714,14 +1714,14 @@ let oneFilePass1 (f:file) : unit =
Format.asprintf
"@[<hov>Incompatible declaration for %s:@ %s@\n\
First declaration was at %a@\nCurrent declaration is at %a@]"
- vi.vname reason
- Cil_printer.pp_location oldloc
- Cil_printer.pp_location loc
+ vi.vname reason
+ Cil_printer.pp_location oldloc
+ Cil_printer.pp_location loc
in
(* If the new variable is unused, ignore it, unless it is defined
while the old variable was also unused but not defined. *)
if not vi.vreferenced
- && (oldvi.vreferenced || oldvi.vdefined || not vi.vdefined)
+ && (oldvi.vreferenced || oldvi.vdefined || not vi.vdefined)
then begin
Kernel.warning ~wkey:Kernel.wkey_drop_unused
"%s@\nCurrent declaration is unused, silently removing it"
@@ -1739,7 +1739,7 @@ let oneFilePass1 (f:file) : unit =
oldvinode.nrep <- vinode;
vi.vtype, vinode
end else Kernel.abort "%s" msg (* Fail if both variables are used. *)
- end
+ end
in
if Cil.hasAttribute "fc_stdlib" oldvi.vattr then begin
let attrprm = Cil.findAttribute "fc_stdlib" oldvi.vattr in
@@ -1758,10 +1758,10 @@ let oneFilePass1 (f:file) : unit =
* can happen if one file declares the variable a non-const while
* others declare it as "const". *)
if typeHasAttribute "const" vi.vtype !=
- typeHasAttribute "const" oldvi.vtype then begin
- Cil.update_var_type
- newrep.ndata (typeRemoveAttributes ["const"] newtype);
- end else Cil.update_var_type newrep.ndata newtype;
+ typeHasAttribute "const" oldvi.vtype then begin
+ Cil.update_var_type
+ newrep.ndata (typeRemoveAttributes ["const"] newtype);
+ end else Cil.update_var_type newrep.ndata newtype;
(* clean up the storage. also update the location of the variable
declaration, but only if the new one should be preferred. *)
let newstorage, newdecl =
@@ -1789,86 +1789,86 @@ let oneFilePass1 (f:file) : unit =
in
List.iter
(function
- | GVarDecl (vi, l) | GVar (vi, _, l) | GFunDecl (_, vi, l)->
- CurrentLoc.set l;
- incr currentDeclIdx;
- if vi.vstorage <> Static then begin
- matchVarinfo vi (l, !currentDeclIdx);
- end
-
- | GFun (fdec, l) ->
- CurrentLoc.set l;
- incr currentDeclIdx;
- (* Save the names of the formal arguments *)
- let _, args, _, _ = splitFunctionTypeVI fdec.svar in
- H.add formalNames (!currentFidx, fdec.svar.vname)
- (List.map (fun (n,_,_) -> n) (argsToList args));
- (* Force inline functions to be static. *)
- (* GN: This turns out to be wrong. inline functions are external,
- * unless specified to be static. *)
+ | GVarDecl (vi, l) | GVar (vi, _, l) | GFunDecl (_, vi, l)->
+ CurrentLoc.set l;
+ incr currentDeclIdx;
+ if vi.vstorage <> Static then begin
+ matchVarinfo vi (l, !currentDeclIdx);
+ end
+
+ | GFun (fdec, l) ->
+ CurrentLoc.set l;
+ incr currentDeclIdx;
+ (* Save the names of the formal arguments *)
+ let _, args, _, _ = splitFunctionTypeVI fdec.svar in
+ H.add formalNames (!currentFidx, fdec.svar.vname)
+ (List.map (fun (n,_,_) -> n) (argsToList args));
+ (* Force inline functions to be static. *)
+ (* GN: This turns out to be wrong. inline functions are external,
+ * unless specified to be static. *)
(*
if fdec.svar.vinline && fdec.svar.vstorage = NoStorage then
fdec.svar.vstorage <- Static;
*)
- if fdec.svar.vstorage <> Static then begin
- matchVarinfo fdec.svar (l, !currentDeclIdx)
- end else begin
- if fdec.svar.vinline && mergeInlines then
- (* Just create the nodes for inline functions *)
- ignore (PlainMerging.getNode iEq iSyn !currentFidx
- fdec.svar.vname fdec.svar (Some (l, !currentDeclIdx)))
- end
- (* Make nodes for the defined type and structure tags *)
- | GType (t, l) ->
- incr currentDeclIdx;
- t.treferenced <- false;
- if t.tname <> "" then (* The empty names are just for introducing
- * undefined comp tags *)
- ignore (PlainMerging.getNode tEq tSyn !currentFidx t.tname t
- (Some (l, !currentDeclIdx)))
- else begin (* Go inside and clean the referenced flag for the
- * declared tags *)
- match t.ttype with
- TComp (ci, _, _ ) ->
- ci.creferenced <- false;
- (* Create a node for it *)
- ignore
- (PlainMerging.getNode sEq sSyn !currentFidx ci.cname ci None)
-
- | TEnum (ei, _) ->
- ei.ereferenced <- false;
- ignore
- (EnumMerging.getNode eEq eSyn !currentFidx ei ei None)
-
- | _ -> (Kernel.fatal "Anonymous Gtype is not TComp")
- end
-
- | GCompTag (ci, l) ->
- incr currentDeclIdx;
- ci.creferenced <- false;
- ignore (PlainMerging.getNode sEq sSyn !currentFidx ci.cname ci
- (Some (l, !currentDeclIdx)))
- | GCompTagDecl (ci,_) -> ci.creferenced <- false
- | GEnumTagDecl (ei,_) -> ei.ereferenced <- false
- | GEnumTag (ei, l) ->
- incr currentDeclIdx;
- let orig_name =
- if ei.eorig_name = "" then ei.ename else ei.eorig_name
- in
- ignore (Alpha.newAlphaName aeAlpha orig_name l);
- ei.ereferenced <- false;
- ignore
- (EnumMerging.getNode eEq eSyn !currentFidx ei ei
- (Some (l, !currentDeclIdx)))
- | GAnnot (gannot,l) ->
- CurrentLoc.set l;
- incr currentDeclIdx;
- global_annot_pass1 gannot
- | GText _ | GPragma _ | GAsm _ -> ())
+ if fdec.svar.vstorage <> Static then begin
+ matchVarinfo fdec.svar (l, !currentDeclIdx)
+ end else begin
+ if fdec.svar.vinline && mergeInlines then
+ (* Just create the nodes for inline functions *)
+ ignore (PlainMerging.getNode iEq iSyn !currentFidx
+ fdec.svar.vname fdec.svar (Some (l, !currentDeclIdx)))
+ end
+ (* Make nodes for the defined type and structure tags *)
+ | GType (t, l) ->
+ incr currentDeclIdx;
+ t.treferenced <- false;
+ if t.tname <> "" then (* The empty names are just for introducing
+ * undefined comp tags *)
+ ignore (PlainMerging.getNode tEq tSyn !currentFidx t.tname t
+ (Some (l, !currentDeclIdx)))
+ else begin (* Go inside and clean the referenced flag for the
+ * declared tags *)
+ match t.ttype with
+ TComp (ci, _, _ ) ->
+ ci.creferenced <- false;
+ (* Create a node for it *)
+ ignore
+ (PlainMerging.getNode sEq sSyn !currentFidx ci.cname ci None)
+
+ | TEnum (ei, _) ->
+ ei.ereferenced <- false;
+ ignore
+ (EnumMerging.getNode eEq eSyn !currentFidx ei ei None)
+
+ | _ -> (Kernel.fatal "Anonymous Gtype is not TComp")
+ end
+
+ | GCompTag (ci, l) ->
+ incr currentDeclIdx;
+ ci.creferenced <- false;
+ ignore (PlainMerging.getNode sEq sSyn !currentFidx ci.cname ci
+ (Some (l, !currentDeclIdx)))
+ | GCompTagDecl (ci,_) -> ci.creferenced <- false
+ | GEnumTagDecl (ei,_) -> ei.ereferenced <- false
+ | GEnumTag (ei, l) ->
+ incr currentDeclIdx;
+ let orig_name =
+ if ei.eorig_name = "" then ei.ename else ei.eorig_name
+ in
+ ignore (Alpha.newAlphaName aeAlpha orig_name l);
+ ei.ereferenced <- false;
+ ignore
+ (EnumMerging.getNode eEq eSyn !currentFidx ei ei
+ (Some (l, !currentDeclIdx)))
+ | GAnnot (gannot,l) ->
+ CurrentLoc.set l;
+ incr currentDeclIdx;
+ global_annot_pass1 gannot
+ | GText _ | GPragma _ | GAsm _ -> ())
f.globals
let matchInlines (oldfidx: int) (oldi: varinfo)
- (fidx: int) (i: varinfo) =
+ (fidx: int) (i: varinfo) =
let oldinode = PlainMerging.getNode iEq iSyn oldfidx oldi.vname oldi None in
let inode = PlainMerging.getNode iEq iSyn fidx i.vname i None in
if oldinode != inode then begin
@@ -1933,313 +1933,313 @@ let logic_info_of_logic_var lv =
(** A visitor that renames uses of variables and types *)
class renameVisitorClass =
-let rename_associated_logic_var lv =
+ let rename_associated_logic_var lv =
match lv.lv_kind with
- | LVGlobal ->
- let li = logic_info_of_logic_var lv in
- (match LogicMerging.findReplacement true lfEq !currentFidx li
- with
- | None -> DoChildren
- | Some (li,_) ->
- let lv' = li.l_var_info in
- if lv == lv' then DoChildren (* Replacement already done... *)
- else ChangeTo lv')
- | LVC ->
- let vi = Extlib.the lv.lv_origin in
- if not vi.vglob then DoChildren
- else begin
- match PlainMerging.findReplacement true vEq !currentFidx vi.vname
- with
- | None -> DoChildren
- | Some (vi',_) ->
- vi'.vreferenced <- true;
- if vi == vi' then DoChildren (* replacement was done already*)
- else begin
- (match vi'.vlogic_var_assoc with
- None ->
- vi'.vlogic_var_assoc <- Some lv; DoChildren
- | Some lv' -> ChangeTo lv')
- end
- end
- | LVFormal | LVQuant | LVLocal -> DoChildren
-in
-let find_enumitem_replacement ei =
- match EnumMerging.findReplacement true eEq !currentFidx ei.eihost with
+ | LVGlobal ->
+ let li = logic_info_of_logic_var lv in
+ (match LogicMerging.findReplacement true lfEq !currentFidx li
+ with
+ | None -> DoChildren
+ | Some (li,_) ->
+ let lv' = li.l_var_info in
+ if lv == lv' then DoChildren (* Replacement already done... *)
+ else ChangeTo lv')
+ | LVC ->
+ let vi = Extlib.the lv.lv_origin in
+ if not vi.vglob then DoChildren
+ else begin
+ match PlainMerging.findReplacement true vEq !currentFidx vi.vname
+ with
+ | None -> DoChildren
+ | Some (vi',_) ->
+ vi'.vreferenced <- true;
+ if vi == vi' then DoChildren (* replacement was done already*)
+ else begin
+ (match vi'.vlogic_var_assoc with
+ None ->
+ vi'.vlogic_var_assoc <- Some lv; DoChildren
+ | Some lv' -> ChangeTo lv')
+ end
+ end
+ | LVFormal | LVQuant | LVLocal -> DoChildren
+ in
+ let find_enumitem_replacement ei =
+ match EnumMerging.findReplacement true eEq !currentFidx ei.eihost with
None -> None
| Some (enum,_) ->
- if enum == intEnumInfo then begin
- (* Two different enums have been merged into an int type.
- Switch to an integer constant. *)
- match (constFold true ei.eival).enode with
- | Const c -> Some c
- | _ ->
- Kernel.fatal ~current:true "non constant value for an enum item"
- end else begin
- (* Merged with an isomorphic type. Find the appropriate enumitem *)
- let n = Extlib.find_index (fun e -> e.einame = ei.einame)
+ if enum == intEnumInfo then begin
+ (* Two different enums have been merged into an int type.
+ Switch to an integer constant. *)
+ match (constFold true ei.eival).enode with
+ | Const c -> Some c
+ | _ ->
+ Kernel.fatal ~current:true "non constant value for an enum item"
+ end else begin
+ (* Merged with an isomorphic type. Find the appropriate enumitem *)
+ let n = Extlib.find_index (fun e -> e.einame = ei.einame)
ei.eihost.eitems in
- let ei' = List.nth enum.eitems n in
- assert (same_int64 ei.eival ei'.eival);
- Some (CEnum ei')
- end
-in
-object (self)
- inherit nopCilVisitor
+ let ei' = List.nth enum.eitems n in
+ assert (same_int64 ei.eival ei'.eival);
+ Some (CEnum ei')
+ end
+ in
+ object (self)
+ inherit nopCilVisitor
- method! vvdec (_vi: varinfo) = DoChildren
+ method! vvdec (_vi: varinfo) = DoChildren
- (* This is a variable use. See if we must change it *)
- method! vvrbl (vi: varinfo) : varinfo visitAction =
- if not vi.vglob then DoChildren
- else begin
- match PlainMerging.findReplacement true vEq !currentFidx vi.vname with
- None -> DoChildren
- | Some (vi', oldfidx) ->
+ (* This is a variable use. See if we must change it *)
+ method! vvrbl (vi: varinfo) : varinfo visitAction =
+ if not vi.vglob then DoChildren
+ else begin
+ match PlainMerging.findReplacement true vEq !currentFidx vi.vname with
+ None -> DoChildren
+ | Some (vi', oldfidx) ->
Kernel.debug ~dkey:Kernel.dkey_linker
"Renaming use of var %s(%d) to %s(%d)"
vi.vname !currentFidx vi'.vname oldfidx;
H.add varUsedAlready vi'.vname ();
ChangeTo vi'
- end
+ end
- method! vlogic_var_decl lv = rename_associated_logic_var lv
+ method! vlogic_var_decl lv = rename_associated_logic_var lv
- method! vlogic_var_use lv = rename_associated_logic_var lv
+ method! vlogic_var_use lv = rename_associated_logic_var lv
- method! vlogic_info_use li =
- match LogicMerging.findReplacement true lfEq !currentFidx li with
- | None ->
- Kernel.debug ~dkey:Kernel.dkey_linker "Using logic function %s(%a)(%d)"
- li.l_var_info.lv_name
- (Pretty_utils.pp_list ~sep:",@ " Cil_printer.pp_logic_type)
- (List.map (fun v -> v.lv_type) li.l_profile)
- !currentFidx;
- DoChildren
+ method! vlogic_info_use li =
+ match LogicMerging.findReplacement true lfEq !currentFidx li with
+ | None ->
+ Kernel.debug ~dkey:Kernel.dkey_linker "Using logic function %s(%a)(%d)"
+ li.l_var_info.lv_name
+ (Pretty_utils.pp_list ~sep:",@ " Cil_printer.pp_logic_type)
+ (List.map (fun v -> v.lv_type) li.l_profile)
+ !currentFidx;
+ DoChildren
| Some(li',oldfidx) ->
- Kernel.debug ~dkey:Kernel.dkey_linker
- "Renaming use of logic function %s(%a)(%d) to %s(%a)(%d)"
- li.l_var_info.lv_name pp_profiles li !currentFidx
- li'.l_var_info.lv_name pp_profiles li' oldfidx;
+ Kernel.debug ~dkey:Kernel.dkey_linker
+ "Renaming use of logic function %s(%a)(%d) to %s(%a)(%d)"
+ li.l_var_info.lv_name pp_profiles li !currentFidx
+ li'.l_var_info.lv_name pp_profiles li' oldfidx;
ChangeTo li'
- method! vlogic_info_decl li =
- match LogicMerging.findReplacement true lfEq !currentFidx li with
+ method! vlogic_info_decl li =
+ match LogicMerging.findReplacement true lfEq !currentFidx li with
None ->
- Kernel.debug ~dkey:Kernel.dkey_linker "Using logic function %s(%a)(%d)"
- li.l_var_info.lv_name pp_profiles li !currentFidx;
- DoChildren
+ Kernel.debug ~dkey:Kernel.dkey_linker "Using logic function %s(%a)(%d)"
+ li.l_var_info.lv_name pp_profiles li !currentFidx;
+ DoChildren
| Some(li',oldfidx) ->
- Kernel.debug ~dkey:Kernel.dkey_linker
- "Renaming use of logic function %s(%a)(%d) to %s(%a)(%d)"
- li.l_var_info.lv_name pp_profiles li !currentFidx
- li'.l_var_info.lv_name pp_profiles li' oldfidx;
- ChangeTo li'
+ Kernel.debug ~dkey:Kernel.dkey_linker
+ "Renaming use of logic function %s(%a)(%d) to %s(%a)(%d)"
+ li.l_var_info.lv_name pp_profiles li !currentFidx
+ li'.l_var_info.lv_name pp_profiles li' oldfidx;
+ ChangeTo li'
- method! vlogic_type_info_use lt =
- match PlainMerging.findReplacement true ltEq !currentFidx lt.lt_name with
+ method! vlogic_type_info_use lt =
+ match PlainMerging.findReplacement true ltEq !currentFidx lt.lt_name with
None ->
- Kernel.debug ~dkey:Kernel.dkey_linker
- "Using logic type %s(%d)" lt.lt_name !currentFidx;
- DoChildren
+ Kernel.debug ~dkey:Kernel.dkey_linker
+ "Using logic type %s(%d)" lt.lt_name !currentFidx;
+ DoChildren
| Some(lt',oldfidx) ->
Kernel.debug ~dkey:Kernel.dkey_linker
"Renaming use of logic type %s(%d) to %s(%d)"
lt.lt_name !currentFidx lt'.lt_name oldfidx;
ChangeTo lt'
- method! vlogic_type_info_decl lt =
- match PlainMerging.findReplacement true ltEq !currentFidx lt.lt_name with
+ method! vlogic_type_info_decl lt =
+ match PlainMerging.findReplacement true ltEq !currentFidx lt.lt_name with
| None ->
- Kernel.debug ~dkey:Kernel.dkey_linker
- "Using logic type %s(%d)" lt.lt_name !currentFidx;
- DoChildren
+ Kernel.debug ~dkey:Kernel.dkey_linker
+ "Using logic type %s(%d)" lt.lt_name !currentFidx;
+ DoChildren
| Some(lt',oldfidx) ->
- Kernel.debug ~dkey:Kernel.dkey_linker
- "Renaming use of logic function %s(%d) to %s(%d)"
- lt.lt_name !currentFidx lt'.lt_name oldfidx;
- ChangeTo lt'
+ Kernel.debug ~dkey:Kernel.dkey_linker
+ "Renaming use of logic function %s(%d) to %s(%d)"
+ lt.lt_name !currentFidx lt'.lt_name oldfidx;
+ ChangeTo lt'
- method! vlogic_ctor_info_use lc =
- match PlainMerging.findReplacement true lcEq !currentFidx lc.ctor_name with
+ method! vlogic_ctor_info_use lc =
+ match PlainMerging.findReplacement true lcEq !currentFidx lc.ctor_name with
None ->
- Kernel.debug ~dkey:Kernel.dkey_linker "Using logic constructor %s(%d)"
- lc.ctor_name !currentFidx;
- DoChildren
+ Kernel.debug ~dkey:Kernel.dkey_linker "Using logic constructor %s(%d)"
+ lc.ctor_name !currentFidx;
+ DoChildren
| Some(lc',oldfidx) ->
- Kernel.debug ~dkey:Kernel.dkey_linker
- "Renaming use of logic type %s(%d) to %s(%d)"
- lc.ctor_name !currentFidx lc'.ctor_name oldfidx;
- ChangeTo lc'
+ Kernel.debug ~dkey:Kernel.dkey_linker
+ "Renaming use of logic type %s(%d) to %s(%d)"
+ lc.ctor_name !currentFidx lc'.ctor_name oldfidx;
+ ChangeTo lc'
- method! vlogic_ctor_info_decl lc =
- match PlainMerging.findReplacement true lcEq !currentFidx lc.ctor_name with
+ method! vlogic_ctor_info_decl lc =
+ match PlainMerging.findReplacement true lcEq !currentFidx lc.ctor_name with
None ->
- Kernel.debug ~dkey:Kernel.dkey_linker "Using logic constructor %s(%d)"
- lc.ctor_name !currentFidx;
- DoChildren
+ Kernel.debug ~dkey:Kernel.dkey_linker "Using logic constructor %s(%d)"
+ lc.ctor_name !currentFidx;
+ DoChildren
| Some(lc',oldfidx) ->
- Kernel.debug ~dkey:Kernel.dkey_linker
- "Renaming use of logic function %s(%d) to %s(%d)"
- lc.ctor_name !currentFidx lc'.ctor_name oldfidx;
- ChangeTo lc'
-
- (* The use of a type. Change only those types whose underlying info
- * is not a root. *)
- method! vtype (t: typ) =
- match t with
- TComp (ci, _, a) when not ci.creferenced -> begin
- match PlainMerging.findReplacement true sEq !currentFidx ci.cname with
- None ->
- Kernel.debug ~dkey:Kernel.dkey_linker "No renaming needed %s(%d)"
- ci.cname !currentFidx;
+ Kernel.debug ~dkey:Kernel.dkey_linker
+ "Renaming use of logic function %s(%d) to %s(%d)"
+ lc.ctor_name !currentFidx lc'.ctor_name oldfidx;
+ ChangeTo lc'
+
+ (* The use of a type. Change only those types whose underlying info
+ * is not a root. *)
+ method! vtype (t: typ) =
+ match t with
+ TComp (ci, _, a) when not ci.creferenced -> begin
+ match PlainMerging.findReplacement true sEq !currentFidx ci.cname with
+ None ->
+ Kernel.debug ~dkey:Kernel.dkey_linker "No renaming needed %s(%d)"
+ ci.cname !currentFidx;
DoChildren
- | Some (ci', oldfidx) ->
+ | Some (ci', oldfidx) ->
Kernel.debug ~dkey:Kernel.dkey_linker
"Renaming use of %s(%d) to %s(%d)"
ci.cname !currentFidx ci'.cname oldfidx;
ChangeTo (TComp (ci',
empty_size_cache (),
visitCilAttributes (self :> cilVisitor) a))
- end
- | TComp(ci,_,_) ->
+ end
+ | TComp(ci,_,_) ->
Kernel.debug ~dkey:Kernel.dkey_linker
"%s(%d) referenced. No change" ci.cname !currentFidx;
DoChildren
- | TEnum (ei, a) when not ei.ereferenced -> begin
- match EnumMerging.findReplacement true eEq !currentFidx ei with
- None -> DoChildren
- | Some (ei', _) ->
+ | TEnum (ei, a) when not ei.ereferenced -> begin
+ match EnumMerging.findReplacement true eEq !currentFidx ei with
+ None -> DoChildren
+ | Some (ei', _) ->
if ei' == intEnumInfo then
(* This is actually our friend intEnumInfo *)
ChangeTo (TInt(IInt, visitCilAttributes (self :> cilVisitor) a))
else
ChangeTo (TEnum (ei', visitCilAttributes (self :> cilVisitor) a))
- end
+ end
- | TNamed (ti, a) when not ti.treferenced -> begin
- match PlainMerging.findReplacement true tEq !currentFidx ti.tname with
- None -> DoChildren
- | Some (ti', _) ->
+ | TNamed (ti, a) when not ti.treferenced -> begin
+ match PlainMerging.findReplacement true tEq !currentFidx ti.tname with
+ None -> DoChildren
+ | Some (ti', _) ->
ChangeTo (TNamed (ti', visitCilAttributes (self :> cilVisitor) a))
- end
+ end
- | _ -> DoChildren
+ | _ -> DoChildren
- method! vexpr e =
- match e.enode with
+ method! vexpr e =
+ match e.enode with
| Const (CEnum ei) ->
- (match find_enumitem_replacement ei with
- None -> DoChildren
- | Some c ->
- ChangeTo { e with enode = Const c })
- | CastE _ ->
+ (match find_enumitem_replacement ei with
+ None -> DoChildren
+ | Some c ->
+ ChangeTo { e with enode = Const c })
+ | CastE _ ->
(* Maybe the cast is no longer necessary if an enum has been replaced
by an integer type. *)
let post_action e = match e.enode with
- | CastE(typ,exp) when
- Cil_datatype.TypByName.equal (typeOf exp) typ ->
- exp
- | _ -> e
+ | CastE(typ,exp) when
+ Cil_datatype.TypByName.equal (typeOf exp) typ ->
+ exp
+ | _ -> e
in
ChangeDoChildrenPost (e,post_action)
| _ -> DoChildren
- method! vterm e =
- match e.term_node with
+ method! vterm e =
+ match e.term_node with
| TConst(LEnum ei) ->
- (match find_enumitem_replacement ei with
- None -> DoChildren
- | Some c ->
- let t = visitCilLogicType (self:>cilVisitor) e.term_type in
- ChangeTo
- { e with
- term_node = TConst (Logic_utils.constant_to_lconstant c);
- term_type = t
- })
+ (match find_enumitem_replacement ei with
+ None -> DoChildren
+ | Some c ->
+ let t = visitCilLogicType (self:>cilVisitor) e.term_type in
+ ChangeTo
+ { e with
+ term_node = TConst (Logic_utils.constant_to_lconstant c);
+ term_type = t
+ })
| _ -> DoChildren
- (* The Field offset might need to be changed to use new compinfo *)
- method! voffs = function
- Field (f, o) -> begin
- (* See if the compinfo was changed *)
- if f.fcomp.creferenced then
- DoChildren
- else begin
- match
- PlainMerging.findReplacement true sEq !currentFidx f.fcomp.cname
- with
- None -> DoChildren (* We did not replace it *)
- | Some (ci', _oldfidx) -> begin
- (* First, find out the index of the original field *)
- let rec indexOf (i: int) = function
- [] -> Kernel.fatal "Cannot find field %s in %s"
- f.fname (compFullName f.fcomp)
- | f' :: _ when f' == f -> i
- | _ :: rest -> indexOf (i + 1) rest
- in
- let index = indexOf 0 f.fcomp.cfields in
- if List.length ci'.cfields <= index then
- Kernel.fatal "Too few fields in replacement %s for %s"
- (compFullName ci')
- (compFullName f.fcomp);
- let f' = List.nth ci'.cfields index in
- ChangeDoChildrenPost (Field (f', o), fun x -> x)
+ (* The Field offset might need to be changed to use new compinfo *)
+ method! voffs = function
+ Field (f, o) -> begin
+ (* See if the compinfo was changed *)
+ if f.fcomp.creferenced then
+ DoChildren
+ else begin
+ match
+ PlainMerging.findReplacement true sEq !currentFidx f.fcomp.cname
+ with
+ None -> DoChildren (* We did not replace it *)
+ | Some (ci', _oldfidx) -> begin
+ (* First, find out the index of the original field *)
+ let rec indexOf (i: int) = function
+ [] -> Kernel.fatal "Cannot find field %s in %s"
+ f.fname (compFullName f.fcomp)
+ | f' :: _ when f' == f -> i
+ | _ :: rest -> indexOf (i + 1) rest
+ in
+ let index = indexOf 0 f.fcomp.cfields in
+ if List.length ci'.cfields <= index then
+ Kernel.fatal "Too few fields in replacement %s for %s"
+ (compFullName ci')
+ (compFullName f.fcomp);
+ let f' = List.nth ci'.cfields index in
+ ChangeDoChildrenPost (Field (f', o), fun x -> x)
+ end
end
end
- end
- | _ -> DoChildren
+ | _ -> DoChildren
- method! vterm_offset = function
- TField (f, o) -> begin
- (* See if the compinfo was changed *)
- if f.fcomp.creferenced then
- DoChildren
- else begin
- match
- PlainMerging.findReplacement true sEq !currentFidx f.fcomp.cname
- with
- None -> DoChildren (* We did not replace it *)
- | Some (ci', _oldfidx) -> begin
- (* First, find out the index of the original field *)
- let rec indexOf (i: int) = function
- [] -> Kernel.fatal "Cannot find field %s in %s"
- f.fname (compFullName f.fcomp)
- | f' :: _ when f' == f -> i
- | _ :: rest -> indexOf (i + 1) rest
- in
- let index = indexOf 0 f.fcomp.cfields in
- if List.length ci'.cfields <= index then
- Kernel.fatal "Too few fields in replacement %s for %s"
- (compFullName ci')
- (compFullName f.fcomp);
- let f' = List.nth ci'.cfields index in
- ChangeDoChildrenPost (TField (f', o), fun x -> x)
+ method! vterm_offset = function
+ TField (f, o) -> begin
+ (* See if the compinfo was changed *)
+ if f.fcomp.creferenced then
+ DoChildren
+ else begin
+ match
+ PlainMerging.findReplacement true sEq !currentFidx f.fcomp.cname
+ with
+ None -> DoChildren (* We did not replace it *)
+ | Some (ci', _oldfidx) -> begin
+ (* First, find out the index of the original field *)
+ let rec indexOf (i: int) = function
+ [] -> Kernel.fatal "Cannot find field %s in %s"
+ f.fname (compFullName f.fcomp)
+ | f' :: _ when f' == f -> i
+ | _ :: rest -> indexOf (i + 1) rest
+ in
+ let index = indexOf 0 f.fcomp.cfields in
+ if List.length ci'.cfields <= index then
+ Kernel.fatal "Too few fields in replacement %s for %s"
+ (compFullName ci')
+ (compFullName f.fcomp);
+ let f' = List.nth ci'.cfields index in
+ ChangeDoChildrenPost (TField (f', o), fun x -> x)
+ end
end
end
- end
- | TModel(f,o) ->
- (match
- ModelMerging.findReplacement
- true mfEq !currentFidx (f.mi_name, f.mi_base_type)
+ | TModel(f,o) ->
+ (match
+ ModelMerging.findReplacement
+ true mfEq !currentFidx (f.mi_name, f.mi_base_type)
with
- | None ->
- (* We might have changed the field before choosing it as
- representative. Check that. *)
- let f' =
- (ModelMerging.find_eq_table
- mfEq (!currentFidx,(f.mi_name, f.mi_base_type))).ndata
- in
- if f == f' then DoChildren (* already the representative. *)
- else ChangeDoChildrenPost (TModel(f',o),fun x -> x)
- | Some (f',_) ->
- ChangeDoChildrenPost (TModel(f',o), fun x -> x))
+ | None ->
+ (* We might have changed the field before choosing it as
+ representative. Check that. *)
+ let f' =
+ (ModelMerging.find_eq_table
+ mfEq (!currentFidx,(f.mi_name, f.mi_base_type))).ndata
+ in
+ if f == f' then DoChildren (* already the representative. *)
+ else ChangeDoChildrenPost (TModel(f',o),fun x -> x)
+ | Some (f',_) ->
+ ChangeDoChildrenPost (TModel(f',o), fun x -> x))
- | _ -> DoChildren
+ | _ -> DoChildren
- method! vinitoffs o =
- (self#voffs o) (* treat initializer offsets same as lvalue offsets *)
+ method! vinitoffs o =
+ (self#voffs o) (* treat initializer offsets same as lvalue offsets *)
-end
+ end
let renameVisitor = new renameVisitorClass
@@ -2257,17 +2257,17 @@ class renameInlineVisitorClass = object(self)
method private visit vi =
visited <- Cil_datatype.Varinfo.Set.add vi visited
- (* This is a variable use. See if we must change it *)
+ (* This is a variable use. See if we must change it *)
method! vvrbl (vi: varinfo) : varinfo visitAction =
if not vi.vglob || Cil_datatype.Varinfo.Set.mem vi visited then DoChildren
else begin
match PlainMerging.findReplacement true vEq !currentFidx vi.vname with
None -> self#visit vi; DoChildren
| Some (vi', oldfidx) ->
- Kernel.debug ~dkey:Kernel.dkey_linker "Renaming var %s(%d) to %s(%d)"
- vi.vname !currentFidx vi'.vname oldfidx;
- self#visit vi';
- ChangeTo vi'
+ Kernel.debug ~dkey:Kernel.dkey_linker "Renaming var %s(%d) to %s(%d)"
+ vi.vname !currentFidx vi'.vname oldfidx;
+ self#visit vi';
+ ChangeTo vi'
end
(* And rename some declarations of inlines to remove. We cannot drop this
@@ -2283,197 +2283,197 @@ class renameInlineVisitorClass = object(self)
match PlainMerging.findReplacement true vEq !currentFidx origname with
None -> self#visit vi; DoChildren
| Some (vi', _) ->
- (*TODO: visit the spec to change references to formals *)
- self#visit vi';
- ChangeTo [GFunDecl (spec,vi', l)]
+ (*TODO: visit the spec to change references to formals *)
+ self#visit vi';
+ ChangeTo [GFunDecl (spec,vi', l)]
end
| _ -> DoChildren
end
let renameInlinesVisitor = new renameInlineVisitorClass
-let rec logic_annot_pass2 ~in_axiomatic g a =
+let rec logic_annot_pass2 ~in_axiomatic g a =
match a with
- | Dfun_or_pred (li,l) ->
- begin
- CurrentLoc.set l;
- match LogicMerging.findReplacement true lfEq !currentFidx li with
- | None ->
- if not in_axiomatic then
- mergePushGlobals (visitCilGlobal renameVisitor g);
- Logic_utils.add_logic_function li;
- | Some _ -> ()
- (* FIXME: should we perform same actions
- as the case Dlogic_reads above ? *)
- end
- | Dtype (t,l) ->
- begin
- CurrentLoc.set l;
- match PlainMerging.findReplacement true ltEq !currentFidx t.lt_name with
- | None ->
- if not in_axiomatic then
- mergePushGlobals (visitCilGlobal renameVisitor g);
- let def =
- (PlainMerging.find_eq_table ltEq (!currentFidx,t.lt_name)).ndata
- in
- Logic_env.add_logic_type t.lt_name def;
- (match def.lt_def with
- | Some (LTsum l) ->
- List.iter (fun c -> Logic_env.add_logic_ctor c.ctor_name c) l
- | Some (LTsyn _)
- | None -> ()
- )
- | Some _ -> ()
- end
- | Dinvariant (li,l) ->
- begin
- CurrentLoc.set l;
- match LogicMerging.findReplacement true lfEq !currentFidx li with
- | None ->
- if in_axiomatic then Kernel.abort ~current:true
- "nested axiomatics are not allowed in ACSL";
- mergePushGlobals (visitCilGlobal renameVisitor g);
- Logic_utils.add_logic_function
- (LogicMerging.find_eq_table lfEq (!currentFidx,li)).ndata
- | Some _ -> ()
- end
- | Dtype_annot (n,l) ->
- begin
- CurrentLoc.set l;
- match LogicMerging.findReplacement true lfEq !currentFidx n with
- | None ->
- let g = visitCilGlobal renameVisitor g in
- if not in_axiomatic then
- mergePushGlobals g;
- Logic_utils.add_logic_function
- (LogicMerging.find_eq_table lfEq (!currentFidx,n)).ndata
- | Some _ -> ()
- end
- | Dmodel_annot (mf,l) ->
- begin
- CurrentLoc.set l;
- match
- ModelMerging.findReplacement
- true mfEq !currentFidx (mf.mi_name,mf.mi_base_type)
- with
- | None ->
- let mf' = visitCilModelInfo renameVisitor mf in
- if mf' != mf then begin
- let my_node =
- ModelMerging.find_eq_table
- mfEq (!currentFidx,(mf'.mi_name,mf'.mi_base_type))
- in
- (* Adds a new representative. Do not replace directly
- my_node, as there might be some pointers to it from
- other files.
- *)
- let my_node' = { my_node with ndata = mf' } in
- my_node.nrep <- my_node'; (* my_node' represents my_node *)
- my_node'.nrep <- my_node';
- (* my_node' is the canonical representative. *)
- ModelMerging.add_eq_table
- mfEq
- (!currentFidx,(mf'.mi_name,mf'.mi_base_type))
- my_node';
- end;
- if not in_axiomatic then begin
- mergePushGlobals [GAnnot (Dmodel_annot(mf',l),l)];
- end;
- Logic_env.add_model_field
- (ModelMerging.find_eq_table
- mfEq (!currentFidx,(mf'.mi_name,mf'.mi_base_type))).ndata;
- | Some _ -> ()
- end
- | Dcustom_annot (_c, n, _, l) ->
- begin
- CurrentLoc.set l;
- match
- PlainMerging.findReplacement
- true lcusEq !currentFidx n
- with
- | None ->
- let g = visitCilGlobal renameVisitor g in
- if not in_axiomatic then
- mergePushGlobals g
- | Some _ -> ()
- end
- | Dlemma (n,_,_,_,_,_,l) ->
- begin
- CurrentLoc.set l;
- match PlainMerging.findReplacement true llEq !currentFidx n with
- None ->
- if not in_axiomatic then
- mergePushGlobals (visitCilGlobal renameVisitor g)
- | Some _ -> ()
- end
- | Dvolatile(vi,rd,wr,attr,loc) ->
- let is_representative id =
- not
- (Extlib.has_some
- (VolatileMerging.findReplacement true lvEq !currentFidx id))
- in
- let push_volatile l rd wr =
- match l with
- | [] -> ()
- | _ ->
- let annot = Dvolatile(l,rd,wr,attr,loc) in
- mergePushGlobals
- (visitCilGlobal renameVisitor (GAnnot (annot,loc)))
- in
- CurrentLoc.set loc;
- (* check whether some volatile location clashes with a previous
- annotation. Warnings about that have been generated during pass 1
- *)
- let check_one_location
- (no_drop, full_representative, only_reads, only_writes) v =
- (* if there's only one function, only full_representative list will
- be filled. If both are provided, we maintain three lists of volatile
- locations:
- - the ones which take both their reads and writes function from
- current annotation
- - the ones which only use rd
- - the ones which only use wr
+ | Dfun_or_pred (li,l) ->
+ begin
+ CurrentLoc.set l;
+ match LogicMerging.findReplacement true lfEq !currentFidx li with
+ | None ->
+ if not in_axiomatic then
+ mergePushGlobals (visitCilGlobal renameVisitor g);
+ Logic_utils.add_logic_function li;
+ | Some _ -> ()
+ (* FIXME: should we perform same actions
+ as the case Dlogic_reads above ? *)
+ end
+ | Dtype (t,l) ->
+ begin
+ CurrentLoc.set l;
+ match PlainMerging.findReplacement true ltEq !currentFidx t.lt_name with
+ | None ->
+ if not in_axiomatic then
+ mergePushGlobals (visitCilGlobal renameVisitor g);
+ let def =
+ (PlainMerging.find_eq_table ltEq (!currentFidx,t.lt_name)).ndata
+ in
+ Logic_env.add_logic_type t.lt_name def;
+ (match def.lt_def with
+ | Some (LTsum l) ->
+ List.iter (fun c -> Logic_env.add_logic_ctor c.ctor_name c) l
+ | Some (LTsyn _)
+ | None -> ()
+ )
+ | Some _ -> ()
+ end
+ | Dinvariant (li,l) ->
+ begin
+ CurrentLoc.set l;
+ match LogicMerging.findReplacement true lfEq !currentFidx li with
+ | None ->
+ if in_axiomatic then Kernel.abort ~current:true
+ "nested axiomatics are not allowed in ACSL";
+ mergePushGlobals (visitCilGlobal renameVisitor g);
+ Logic_utils.add_logic_function
+ (LogicMerging.find_eq_table lfEq (!currentFidx,li)).ndata
+ | Some _ -> ()
+ end
+ | Dtype_annot (n,l) ->
+ begin
+ CurrentLoc.set l;
+ match LogicMerging.findReplacement true lfEq !currentFidx n with
+ | None ->
+ let g = visitCilGlobal renameVisitor g in
+ if not in_axiomatic then
+ mergePushGlobals g;
+ Logic_utils.add_logic_function
+ (LogicMerging.find_eq_table lfEq (!currentFidx,n)).ndata
+ | Some _ -> ()
+ end
+ | Dmodel_annot (mf,l) ->
+ begin
+ CurrentLoc.set l;
+ match
+ ModelMerging.findReplacement
+ true mfEq !currentFidx (mf.mi_name,mf.mi_base_type)
+ with
+ | None ->
+ let mf' = visitCilModelInfo renameVisitor mf in
+ if mf' != mf then begin
+ let my_node =
+ ModelMerging.find_eq_table
+ mfEq (!currentFidx,(mf'.mi_name,mf'.mi_base_type))
+ in
+ (* Adds a new representative. Do not replace directly
+ my_node, as there might be some pointers to it from
+ other files.
+ *)
+ let my_node' = { my_node with ndata = mf' } in
+ my_node.nrep <- my_node'; (* my_node' represents my_node *)
+ my_node'.nrep <- my_node';
+ (* my_node' is the canonical representative. *)
+ ModelMerging.add_eq_table
+ mfEq
+ (!currentFidx,(mf'.mi_name,mf'.mi_base_type))
+ my_node';
+ end;
+ if not in_axiomatic then begin
+ mergePushGlobals [GAnnot (Dmodel_annot(mf',l),l)];
+ end;
+ Logic_env.add_model_field
+ (ModelMerging.find_eq_table
+ mfEq (!currentFidx,(mf'.mi_name,mf'.mi_base_type))).ndata;
+ | Some _ -> ()
+ end
+ | Dcustom_annot (_c, n, _, l) ->
+ begin
+ CurrentLoc.set l;
+ match
+ PlainMerging.findReplacement
+ true lcusEq !currentFidx n
+ with
+ | None ->
+ let g = visitCilGlobal renameVisitor g in
+ if not in_axiomatic then
+ mergePushGlobals g
+ | Some _ -> ()
+ end
+ | Dlemma (n,_,_,_,_,_,l) ->
+ begin
+ CurrentLoc.set l;
+ match PlainMerging.findReplacement true llEq !currentFidx n with
+ None ->
+ if not in_axiomatic then
+ mergePushGlobals (visitCilGlobal renameVisitor g)
+ | Some _ -> ()
+ end
+ | Dvolatile(vi,rd,wr,attr,loc) ->
+ let is_representative id =
+ not
+ (Extlib.has_some
+ (VolatileMerging.findReplacement true lvEq !currentFidx id))
+ in
+ let push_volatile l rd wr =
+ match l with
+ | [] -> ()
+ | _ ->
+ let annot = Dvolatile(l,rd,wr,attr,loc) in
+ mergePushGlobals
+ (visitCilGlobal renameVisitor (GAnnot (annot,loc)))
+ in
+ CurrentLoc.set loc;
+ (* check whether some volatile location clashes with a previous
+ annotation. Warnings about that have been generated during pass 1
+ *)
+ let check_one_location
+ (no_drop, full_representative, only_reads, only_writes) v =
+ (* if there's only one function, only full_representative list will
+ be filled. If both are provided, we maintain three lists of volatile
+ locations:
+ - the ones which take both their reads and writes function from
+ current annotation
+ - the ones which only use rd
+ - the ones which only use wr
Additionally, we maintain a boolean flag indicating whether the
annotation can be used as is (i.e. does not overlap with a
preceding annotation.
- *)
- let reads = not (Extlib.has_some rd) || is_representative (v,R) in
- let writes = not (Extlib.has_some wr) || is_representative (v,W) in
- if reads then
- if writes then
- no_drop, v::full_representative, only_reads, only_writes
- else
- false, full_representative, v::only_reads, only_writes
- else if writes then
- false, full_representative, only_reads, v::only_writes
+ *)
+ let reads = not (Extlib.has_some rd) || is_representative (v,R) in
+ let writes = not (Extlib.has_some wr) || is_representative (v,W) in
+ if reads then
+ if writes then
+ no_drop, v::full_representative, only_reads, only_writes
else
- false, full_representative, only_reads, only_writes
- in
- let no_drop, full_representative, only_reads, only_writes =
- List.fold_left check_one_location (true,[],[],[]) vi
- in
- if no_drop then mergePushGlobals (visitCilGlobal renameVisitor g)
- else begin
- push_volatile full_representative rd wr;
- if Extlib.has_some rd then push_volatile only_reads rd None;
- if Extlib.has_some wr then push_volatile only_writes None wr
- end
- | Daxiomatic(n,l,_,loc) ->
- begin
- CurrentLoc.set loc;
- match PlainMerging.findReplacement true laEq !currentFidx n with
- None ->
- if in_axiomatic then Kernel.abort ~current:true
- "nested axiomatics are not allowed in ACSL";
- mergePushGlobals (visitCilGlobal renameVisitor g);
- List.iter (logic_annot_pass2 ~in_axiomatic:true g) l
- | Some _ -> ()
- end
- | Dextended(ext,_,loc) ->
- (CurrentLoc.set loc;
- match ExtMerging.findReplacement true extEq !currentFidx ext with
- | None -> mergePushGlobals (visitCilGlobal renameVisitor g);
- | Some _ -> ())
+ false, full_representative, v::only_reads, only_writes
+ else if writes then
+ false, full_representative, only_reads, v::only_writes
+ else
+ false, full_representative, only_reads, only_writes
+ in
+ let no_drop, full_representative, only_reads, only_writes =
+ List.fold_left check_one_location (true,[],[],[]) vi
+ in
+ if no_drop then mergePushGlobals (visitCilGlobal renameVisitor g)
+ else begin
+ push_volatile full_representative rd wr;
+ if Extlib.has_some rd then push_volatile only_reads rd None;
+ if Extlib.has_some wr then push_volatile only_writes None wr
+ end
+ | Daxiomatic(n,l,_,loc) ->
+ begin
+ CurrentLoc.set loc;
+ match PlainMerging.findReplacement true laEq !currentFidx n with
+ None ->
+ if in_axiomatic then Kernel.abort ~current:true
+ "nested axiomatics are not allowed in ACSL";
+ mergePushGlobals (visitCilGlobal renameVisitor g);
+ List.iter (logic_annot_pass2 ~in_axiomatic:true g) l
+ | Some _ -> ()
+ end
+ | Dextended(ext,_,loc) ->
+ (CurrentLoc.set loc;
+ match ExtMerging.findReplacement true extEq !currentFidx ext with
+ | None -> mergePushGlobals (visitCilGlobal renameVisitor g);
+ | Some _ -> ())
let global_annot_pass2 g a = logic_annot_pass2 ~in_axiomatic:false g a
@@ -2484,50 +2484,50 @@ let global_annot_pass2 g a = logic_annot_pass2 ~in_axiomatic:false g a
* purpose I have in mind, which is doing duplicate removal of
* multiply-instantiated template functions. *)
let functionChecksum (dec: fundec) : int =
-begin
- (* checksum the structure of the statements (only) *)
- let rec stmtListSum (lst : stmt list) : int =
- (List.fold_left (fun acc s -> acc + (stmtSum s)) 0 lst)
- and stmtSum (s: stmt) : int =
- (* strategy is to just throw a lot of prime numbers into the
- * computation in hopes of avoiding accidental collision.. *)
- match s.skind with
- | UnspecifiedSequence seq ->
+ begin
+ (* checksum the structure of the statements (only) *)
+ let rec stmtListSum (lst : stmt list) : int =
+ (List.fold_left (fun acc s -> acc + (stmtSum s)) 0 lst)
+ and stmtSum (s: stmt) : int =
+ (* strategy is to just throw a lot of prime numbers into the
+ * computation in hopes of avoiding accidental collision.. *)
+ match s.skind with
+ | UnspecifiedSequence seq ->
131*(stmtListSum (List.map (fun (x,_,_,_,_) -> x) seq)) + 127
- | Instr _ -> 13 + 67
- | Return(_) -> 17
- | Goto(_) -> 19
- | Break(_) -> 23
- | Continue(_) -> 29
- | If(_,b1,b2,_) -> 31 + 37*(stmtListSum b1.bstmts)
- + 41*(stmtListSum b2.bstmts)
- | Switch(_,b,_,_) -> 43 + 47*(stmtListSum b.bstmts)
- (* don't look at stmt list b/c is not part of tree *)
- | Loop(_,b,_,_,_) -> 49 + 53*(stmtListSum b.bstmts)
- | Block(b) -> 59 + 61*(stmtListSum b.bstmts)
- | TryExcept (b, (_, _), h, _) ->
+ | Instr _ -> 13 + 67
+ | Return(_) -> 17
+ | Goto(_) -> 19
+ | Break(_) -> 23
+ | Continue(_) -> 29
+ | If(_,b1,b2,_) -> 31 + 37*(stmtListSum b1.bstmts)
+ + 41*(stmtListSum b2.bstmts)
+ | Switch(_,b,_,_) -> 43 + 47*(stmtListSum b.bstmts)
+ (* don't look at stmt list b/c is not part of tree *)
+ | Loop(_,b,_,_,_) -> 49 + 53*(stmtListSum b.bstmts)
+ | Block(b) -> 59 + 61*(stmtListSum b.bstmts)
+ | TryExcept (b, (_, _), h, _) ->
67 + 83*(stmtListSum b.bstmts) + 97*(stmtListSum h.bstmts)
- | TryFinally (b, h, _) ->
+ | TryFinally (b, h, _) ->
103 + 113*(stmtListSum b.bstmts) + 119*(stmtListSum h.bstmts)
- | Throw(_,_) -> 137
- | TryCatch (b,l,_) ->
- 139 + 149*(stmtListSum b.bstmts) +
+ | Throw(_,_) -> 137
+ | TryCatch (b,l,_) ->
+ 139 + 149*(stmtListSum b.bstmts) +
151 *
(List.fold_left (fun acc (_,b) -> acc + stmtListSum b.bstmts) 0 l)
- in
+ in
- (* disabled 2nd and 3rd measure because they appear to get different
- * values, for the same code, depending on whether the code was just
- * parsed into CIL or had previously been parsed into CIL, printed
- * out, then re-parsed into CIL *)
- let a,b,c,d,e =
- (List.length dec.sformals), (* # formals *)
- 0 (*(List.length dec.slocals)*), (* # locals *)
- 0 (*dec.smaxid*), (* estimate of internal statement count *)
- (List.length dec.sbody.bstmts), (* number of statements at outer level *)
- (stmtListSum dec.sbody.bstmts) in (* checksum of statement structure *)
- 2*a + 3*b + 5*c + 7*d + 11*e
-end
+ (* disabled 2nd and 3rd measure because they appear to get different
+ * values, for the same code, depending on whether the code was just
+ * parsed into CIL or had previously been parsed into CIL, printed
+ * out, then re-parsed into CIL *)
+ let a,b,c,d,e =
+ (List.length dec.sformals), (* # formals *)
+ 0 (*(List.length dec.slocals)*), (* # locals *)
+ 0 (*dec.smaxid*), (* estimate of internal statement count *)
+ (List.length dec.sbody.bstmts), (* number of statements at outer level *)
+ (stmtListSum dec.sbody.bstmts) in (* checksum of statement structure *)
+ 2*a + 3*b + 5*c + 7*d + 11*e
+ end
(* sm: equality for initializers, etc.; this is like '=', except
@@ -2539,109 +2539,109 @@ end
* so these functions are not now checking proper equality..
* places where equality is not complete are marked "INC" *)
let rec equalInits (x: init) (y: init) : bool =
-begin
- match x,y with
- | SingleInit(xe), SingleInit(ye) -> (equalExps xe ye)
- | CompoundInit(_xt, xoil), CompoundInit(_yt, yoil) ->
+ begin
+ match x,y with
+ | SingleInit(xe), SingleInit(ye) -> (equalExps xe ye)
+ | CompoundInit(_xt, xoil), CompoundInit(_yt, yoil) ->
(*(xt == yt) &&*) (* INC *) (* types need to be identically equal *)
let rec equalLists xoil yoil : bool =
match xoil,yoil with
| ((xo,xi) :: xrest), ((yo,yi) :: yrest) ->
- (equalOffsets xo yo) &&
- (equalInits xi yi) &&
- (equalLists xrest yrest)
+ (equalOffsets xo yo) &&
+ (equalInits xi yi) &&
+ (equalLists xrest yrest)
| [], [] -> true
| _, _ -> false
in
(equalLists xoil yoil)
- | _, _ -> false
-end
+ | _, _ -> false
+ end
and equalOffsets (x: offset) (y: offset) : bool =
-begin
- match x,y with
- | NoOffset, NoOffset -> true
- | Field(xfi,xo), Field(yfi,yo) ->
+ begin
+ match x,y with
+ | NoOffset, NoOffset -> true
+ | Field(xfi,xo), Field(yfi,yo) ->
(xfi.fname = yfi.fname) && (* INC: same fieldinfo name.. *)
(equalOffsets xo yo)
- | Index(xe,xo), Index(ye,yo) ->
+ | Index(xe,xo), Index(ye,yo) ->
(equalExps xe ye) &&
(equalOffsets xo yo)
- | _,_ -> false
-end
+ | _,_ -> false
+ end
and equalExps (x: exp) (y: exp) : bool =
-begin
- match x.enode,y.enode with
- | Const(xc), Const(yc) ->
+ begin
+ match x.enode,y.enode with
+ | Const(xc), Const(yc) ->
Cil.compareConstant xc yc ||
- ((* CIL changes (unsigned)0 into 0U during printing.. *)
- match xc,yc with
- | CInt64(xv,_,_),CInt64(yv,_,_) ->
- (Integer.equal xv Integer.zero)
- && (* ok if they're both 0 *)
- (Integer.equal yv Integer.zero)
- | _,_ -> false
- )
- | Lval(xl), Lval(yl) -> (equalLvals xl yl)
- | SizeOf(_xt), SizeOf(_yt) -> true (*INC: xt == yt*) (* identical types *)
- | SizeOfE(xe), SizeOfE(ye) -> (equalExps xe ye)
- | AlignOf(_xt), AlignOf(_yt) -> true (*INC: xt == yt*)
- | AlignOfE(xe), AlignOfE(ye) -> (equalExps xe ye)
- | UnOp(xop,xe,_xt), UnOp(yop,ye,_yt) ->
+ ((* CIL changes (unsigned)0 into 0U during printing.. *)
+ match xc,yc with
+ | CInt64(xv,_,_),CInt64(yv,_,_) ->
+ (Integer.equal xv Integer.zero)
+ && (* ok if they're both 0 *)
+ (Integer.equal yv Integer.zero)
+ | _,_ -> false
+ )
+ | Lval(xl), Lval(yl) -> (equalLvals xl yl)
+ | SizeOf(_xt), SizeOf(_yt) -> true (*INC: xt == yt*) (* identical types *)
+ | SizeOfE(xe), SizeOfE(ye) -> (equalExps xe ye)
+ | AlignOf(_xt), AlignOf(_yt) -> true (*INC: xt == yt*)
+ | AlignOfE(xe), AlignOfE(ye) -> (equalExps xe ye)
+ | UnOp(xop,xe,_xt), UnOp(yop,ye,_yt) ->
xop = yop &&
(equalExps xe ye) &&
true (*INC: xt == yt*)
- | BinOp(xop,xe1,xe2,_xt), BinOp(yop,ye1,ye2,_yt) ->
+ | BinOp(xop,xe1,xe2,_xt), BinOp(yop,ye1,ye2,_yt) ->
xop = yop &&
(equalExps xe1 ye1) &&
(equalExps xe2 ye2) &&
true (*INC: xt == yt*)
- | CastE(_xt,xe), CastE(_yt,ye) ->
+ | CastE(_xt,xe), CastE(_yt,ye) ->
(*INC: xt == yt &&*)
(equalExps xe ye)
- | AddrOf(xl), AddrOf(yl) -> (equalLvals xl yl)
- | StartOf(xl), StartOf(yl) -> (equalLvals xl yl)
+ | AddrOf(xl), AddrOf(yl) -> (equalLvals xl yl)
+ | StartOf(xl), StartOf(yl) -> (equalLvals xl yl)
- (* initializers that go through CIL multiple times sometimes lose casts they
- * had the first time; so allow a different of a cast *)
- | CastE(_xt,xe),_ ->
+ (* initializers that go through CIL multiple times sometimes lose casts they
+ * had the first time; so allow a different of a cast *)
+ | CastE(_xt,xe),_ ->
(equalExps xe y)
- | _, CastE(_yt,ye) ->
+ | _, CastE(_yt,ye) ->
(equalExps x ye)
- | _,_ -> false
-end
+ | _,_ -> false
+ end
and equalLvals (x: lval) (y: lval) : bool =
-begin
- match x,y with
- | (Var _xv,xo), (Var _yv,yo) ->
+ begin
+ match x,y with
+ | (Var _xv,xo), (Var _yv,yo) ->
(* I tried, I really did.. the problem is I see these names
* before merging collapses them, so __T123 != __T456,
* so whatever *)
(*(xv.vname = vy.vname) && (* INC: same varinfo names.. *)*)
(equalOffsets xo yo)
- | (Mem(xe),xo), (Mem(ye),yo) ->
+ | (Mem(xe),xo), (Mem(ye),yo) ->
(equalExps xe ye) &&
(equalOffsets xo yo)
- | _,_ -> false
-end
+ | _,_ -> false
+ end
let equalInitOpts (x: init option) (y: init option) : bool =
-begin
- match x,y with
- | None,None -> true
- | Some(xi), Some(yi) -> (equalInits xi yi)
- | _,_ -> false
-end
+ begin
+ match x,y with
+ | None,None -> true
+ | Some(xi), Some(yi) -> (equalInits xi yi)
+ | _,_ -> false
+ end
- (* Now we go once more through the file and we rename the globals that we
- * keep. We also scan the entire body and we replace references to the
- * representative types or variables. We set the referenced flags once we
- * have replaced the names. *)
+(* Now we go once more through the file and we rename the globals that we
+ * keep. We also scan the entire body and we replace references to the
+ * representative types or variables. We set the referenced flags once we
+ * have replaced the names. *)
let oneFilePass2 (f: file) =
Kernel.feedback ~level:2 "Final merging phase: %a"
Datatype.Filepath.pretty f.fileName;
@@ -2655,7 +2655,7 @@ let oneFilePass2 (f: file) =
(* set to true if we need to make an additional path for changing tentative
definition into plain declaration because a real definition has been found.
- *)
+ *)
let replaceTentativeDefn = ref false in
(* Keep a pointer to the contents of the file so far *)
@@ -2676,7 +2676,7 @@ let oneFilePass2 (f: file) =
try Some (Cil.getFormalsDecl vi)
with Not_found -> None
in
- (* Remember the original name *)
+ (* Remember the original name *)
H.add originalVarNames newName vi.vname;
Kernel.debug ~dkey:Kernel.dkey_linker "renaming %s at %a to %s"
vi.vname Cil_printer.pp_location vloc newName;
@@ -2686,454 +2686,454 @@ let oneFilePass2 (f: file) =
(match formals_decl with
| Some formals -> Cil.unsafeSetFormalsDecl vi formals
| None -> ());
- vi
+ vi
end else begin
(* Find the representative *)
match PlainMerging.findReplacement true vEq !currentFidx vi.vname with
None -> visit vi; vi (* This is the representative *)
| Some (vi', _) -> (* Reuse some previous one *)
- visit vi';
- vi'.vaddrof <- vi.vaddrof || vi'.vaddrof;
- vi'.vdefined <- vi.vdefined || vi'.vdefined;
- if Extlib.xor vi'.vghost vi.vghost then
- Kernel.abort
- "Cannot merge: Global %a has both ghost and non-ghost status"
- Cil_printer.pp_varinfo vi';
- (* If vi has a logic binding, add one to
- the representative if needed. *)
- (match vi'.vlogic_var_assoc, vi.vlogic_var_assoc with
- | _, None -> ()
- | Some _, _ -> ()
- | None, Some _ -> ignore (Cil.cvar_to_lvar vi'));
- vi'
+ visit vi';
+ vi'.vaddrof <- vi.vaddrof || vi'.vaddrof;
+ vi'.vdefined <- vi.vdefined || vi'.vdefined;
+ if Extlib.xor vi'.vghost vi.vghost then
+ Kernel.abort
+ "Cannot merge: Global %a has both ghost and non-ghost status"
+ Cil_printer.pp_varinfo vi';
+ (* If vi has a logic binding, add one to
+ the representative if needed. *)
+ (match vi'.vlogic_var_assoc, vi.vlogic_var_assoc with
+ | _, None -> ()
+ | Some _, _ -> ()
+ | None, Some _ -> ignore (Cil.cvar_to_lvar vi'));
+ vi'
end
end
in
match g with
- | GVarDecl (vi, l) as g ->
- CurrentLoc.set l;
- incr currentDeclIdx;
- let vi' = processVarinfo vi l in
- if vi == vi' && not (H.mem emittedVarDecls vi'.vname) then begin
- H.add emittedVarDecls vi'.vname true; (* Remember that we emitted
- * it *)
- mergePushGlobals (visitCilGlobal renameVisitor g)
- end
+ | GVarDecl (vi, l) as g ->
+ CurrentLoc.set l;
+ incr currentDeclIdx;
+ let vi' = processVarinfo vi l in
+ if vi == vi' && not (H.mem emittedVarDecls vi'.vname) then begin
+ H.add emittedVarDecls vi'.vname true; (* Remember that we emitted
+ * it *)
+ mergePushGlobals (visitCilGlobal renameVisitor g)
+ end
- | GFunDecl (spec,vi, l) as g ->
- CurrentLoc.set l;
- incr currentDeclIdx;
- let vi' = processVarinfo vi l in
- let spec' = visitCilFunspec renameVisitor spec in
- if vi != vi' then begin
- (* if vi is supposed to be ignored, do nothing. *)
- if not (is_ignored_vi vi) then begin
- (* Drop the decl, keep the spec *)
- mergeSpec vi' vi spec';
- (try
- (* if the reference varinfo already has formals, everything
- is renamed accordingly. *)
- ignore (Cil.getFormalsDecl vi')
- with Not_found ->
- (* Otherwise, if we have formals here, register them with
- the reference varinfo *)
- try
- let my_formals = Cil.getFormalsDecl vi in
- Cil.unsafeSetFormalsDecl vi' my_formals
- with Not_found -> ()
- (* Neither decl has formals. Do nothing. *));
- end;
- Cil.removeFormalsDecl vi
- end
- else if H.mem emittedVarDecls vi'.vname then begin
- mergeSpec vi' vi spec'
- end else begin
- H.add emittedVarDecls vi'.vname true; (* Remember that we emitted
- * it *)
- mergePushGlobals (visitCilGlobal renameVisitor g)
- end
+ | GFunDecl (spec,vi, l) as g ->
+ CurrentLoc.set l;
+ incr currentDeclIdx;
+ let vi' = processVarinfo vi l in
+ let spec' = visitCilFunspec renameVisitor spec in
+ if vi != vi' then begin
+ (* if vi is supposed to be ignored, do nothing. *)
+ if not (is_ignored_vi vi) then begin
+ (* Drop the decl, keep the spec *)
+ mergeSpec vi' vi spec';
+ (try
+ (* if the reference varinfo already has formals, everything
+ is renamed accordingly. *)
+ ignore (Cil.getFormalsDecl vi')
+ with Not_found ->
+ (* Otherwise, if we have formals here, register them with
+ the reference varinfo *)
+ try
+ let my_formals = Cil.getFormalsDecl vi in
+ Cil.unsafeSetFormalsDecl vi' my_formals
+ with Not_found -> ()
+ (* Neither decl has formals. Do nothing. *));
+ end;
+ Cil.removeFormalsDecl vi
+ end
+ else if H.mem emittedVarDecls vi'.vname then begin
+ mergeSpec vi' vi spec'
+ end else begin
+ H.add emittedVarDecls vi'.vname true; (* Remember that we emitted
+ * it *)
+ mergePushGlobals (visitCilGlobal renameVisitor g)
+ end
- | GVar (vi, init, l) ->
- CurrentLoc.set l;
- incr currentDeclIdx;
- if not (is_ignored_vi vi) then begin
- let vi' = processVarinfo vi l in
- (* We must keep this definition even if we reuse this varinfo,
- * because maybe the previous one was a declaration *)
- H.add emittedVarDecls vi.vname true;
- (* Remember that we emitted it*)
-
- let emitIt:bool =
- (not mergeGlobals) ||
- try
- let _prevVar, prevInitOpt, prevLoc =
- (H.find emittedVarDefn vi'.vname) in
- (* previously defined; same initializer? *)
- if (equalInitOpts prevInitOpt init.init)
- || (init.init = None) then (
- false (* do not emit *)
- )
- else if prevInitOpt = None then (
- (* The previous occurrence was only a tentative defn. Now,
- we have a real one. Set the correct value in the table,
- and tell that we need to change the previous into GVarDecl
- *)
- H.replace emittedVarDefn vi'.vname(vi',init.init,l);
- replaceTentativeDefn:=true;
- true
- )
- else (
- (* Both GVars have initializers. *)
- Kernel.error ~current:true
- "global var %s at %a has different initializer than %a"
- vi'.vname
- Cil_printer.pp_location l Cil_printer.pp_location prevLoc;
- false
- )
- with Not_found -> begin
- (* no previous definition *)
- H.add emittedVarDefn vi'.vname (vi', init.init, l);
- true (* emit it *)
- end
- in
+ | GVar (vi, init, l) ->
+ CurrentLoc.set l;
+ incr currentDeclIdx;
+ if not (is_ignored_vi vi) then begin
+ let vi' = processVarinfo vi l in
+ (* We must keep this definition even if we reuse this varinfo,
+ * because maybe the previous one was a declaration *)
+ H.add emittedVarDecls vi.vname true;
+ (* Remember that we emitted it*)
+
+ let emitIt:bool =
+ (not mergeGlobals) ||
+ try
+ let _prevVar, prevInitOpt, prevLoc =
+ (H.find emittedVarDefn vi'.vname) in
+ (* previously defined; same initializer? *)
+ if (equalInitOpts prevInitOpt init.init)
+ || (init.init = None) then (
+ false (* do not emit *)
+ )
+ else if prevInitOpt = None then (
+ (* The previous occurrence was only a tentative defn. Now,
+ we have a real one. Set the correct value in the table,
+ and tell that we need to change the previous into GVarDecl
+ *)
+ H.replace emittedVarDefn vi'.vname(vi',init.init,l);
+ replaceTentativeDefn:=true;
+ true
+ )
+ else (
+ (* Both GVars have initializers. *)
+ Kernel.error ~current:true
+ "global var %s at %a has different initializer than %a"
+ vi'.vname
+ Cil_printer.pp_location l Cil_printer.pp_location prevLoc;
+ false
+ )
+ with Not_found -> begin
+ (* no previous definition *)
+ H.add emittedVarDefn vi'.vname (vi', init.init, l);
+ true (* emit it *)
+ end
+ in
- if emitIt then
- mergePushGlobals
- (visitCilGlobal renameVisitor (GVar(vi', init, l)))
- end
+ if emitIt then
+ mergePushGlobals
+ (visitCilGlobal renameVisitor (GVar(vi', init, l)))
+ end
- | GFun (fdec, l) as g ->
- CurrentLoc.set l;
- incr currentDeclIdx;
- if not (is_ignored_vi fdec.svar) then begin
- (* We apply the renaming *)
- let vi = processVarinfo fdec.svar l in
- if fdec.svar != vi then begin
- Kernel.debug ~dkey:Kernel.dkey_linker
- "%s: %d -> %d" vi.vname fdec.svar.vid vi.vid;
- (try add_alpha_renaming vi (Cil.getFormalsDecl vi) fdec.sformals
- with Not_found -> ());
- fdec.svar <- vi
- end;
- (* Get the original name. *)
- let origname =
- try H.find originalVarNames fdec.svar.vname
- with Not_found -> fdec.svar.vname
- in
- (* Go in there and rename everything as needed *)
- let fdec' =
- match visitCilGlobal renameVisitor g with
- | [ GFun(fdec', _) ] -> fdec'
- | _ ->
- Kernel.fatal "renameVisitor for GFun returned something else"
- in
- let g' = GFun(fdec', l) in
- (* Now restore the parameter names *)
- let _, args, _, _ = splitFunctionTypeVI fdec'.svar in
- let oldnames, foundthem =
- try H.find formalNames (!currentFidx, origname), true
- with Not_found -> begin
- [], false
- end
+ | GFun (fdec, l) as g ->
+ CurrentLoc.set l;
+ incr currentDeclIdx;
+ if not (is_ignored_vi fdec.svar) then begin
+ (* We apply the renaming *)
+ let vi = processVarinfo fdec.svar l in
+ if fdec.svar != vi then begin
+ Kernel.debug ~dkey:Kernel.dkey_linker
+ "%s: %d -> %d" vi.vname fdec.svar.vid vi.vid;
+ (try add_alpha_renaming vi (Cil.getFormalsDecl vi) fdec.sformals
+ with Not_found -> ());
+ fdec.svar <- vi
+ end;
+ (* Get the original name. *)
+ let origname =
+ try H.find originalVarNames fdec.svar.vname
+ with Not_found -> fdec.svar.vname
+ in
+ (* Go in there and rename everything as needed *)
+ let fdec' =
+ match visitCilGlobal renameVisitor g with
+ | [ GFun(fdec', _) ] -> fdec'
+ | _ ->
+ Kernel.fatal "renameVisitor for GFun returned something else"
+ in
+ let g' = GFun(fdec', l) in
+ (* Now restore the parameter names *)
+ let _, args, _, _ = splitFunctionTypeVI fdec'.svar in
+ let oldnames, foundthem =
+ try H.find formalNames (!currentFidx, origname), true
+ with Not_found -> begin
+ [], false
+ end
+ in
+ let defn_formals =
+ try Some (Cil.getFormalsDecl fdec.svar)
+ with Not_found -> None
+ in
+ if foundthem then begin
+ let _argl = argsToList args in
+ if List.length oldnames <> List.length fdec.sformals then
+ Kernel.fatal ~current:true
+ "After merging the function has different arguments";
+ List.iter2
+ (fun oldn a -> if oldn <> "" then a.vname <- oldn)
+ oldnames fdec.sformals;
+ (* Reflect them in the type *)
+ setFormals fdec fdec.sformals
+ end;
+ (** See if we can remove this inline function *)
+ if fdec'.svar.vinline && mergeInlines then begin
+ let mergeInlinesWithAlphaConvert =
+ mergeInlinesWithAlphaConvert ()
+ in
+ let printout =
+ (* Temporarily turn of printing of lines *)
+ let oldprintln =
+ Cil_printer.state.Printer_api.line_directive_style in
+ Cil_printer.state.Printer_api.line_directive_style <- None;
+ (* Temporarily set the name to all functions in the same way *)
+ let newname = fdec'.svar.vname in
+ (* If we must do alpha conversion then temporarily set the
+ * names of the function, local variables and formals in a
+ * standard way *)
+ if mergeInlinesWithAlphaConvert then
+ fdec'.svar.vname <- "@@alphaname@@";
+ let nameId = ref 0 in
+ let oldNames : string list ref = ref [] in
+ let renameOne (v: varinfo) =
+ oldNames := v.vname :: !oldNames;
+ incr nameId;
+ v.vname <- "___alpha" ^ string_of_int !nameId
in
- let defn_formals =
- try Some (Cil.getFormalsDecl fdec.svar)
- with Not_found -> None
+ let undoRenameOne (v: varinfo) =
+ match !oldNames with
+ n :: rest ->
+ oldNames := rest;
+ v.vname <- n
+ | _ -> Kernel.fatal "undoRenameOne"
in
- if foundthem then begin
- let _argl = argsToList args in
- if List.length oldnames <> List.length fdec.sformals then
- Kernel.fatal ~current:true
- "After merging the function has different arguments";
- List.iter2
- (fun oldn a -> if oldn <> "" then a.vname <- oldn)
- oldnames fdec.sformals;
- (* Reflect them in the type *)
- setFormals fdec fdec.sformals
+ (* Remember the original type *)
+ let origType = fdec'.svar.vtype in
+ if mergeInlinesWithAlphaConvert then begin
+ (* Rename the formals *)
+ List.iter renameOne fdec'.sformals;
+ (* Reflect in the type *)
+ setFormals fdec' fdec'.sformals;
+ (* Now do the locals *)
+ List.iter renameOne fdec'.slocals
end;
- (** See if we can remove this inline function *)
- if fdec'.svar.vinline && mergeInlines then begin
- let mergeInlinesWithAlphaConvert =
- mergeInlinesWithAlphaConvert ()
- in
- let printout =
- (* Temporarily turn of printing of lines *)
- let oldprintln =
- Cil_printer.state.Printer_api.line_directive_style in
- Cil_printer.state.Printer_api.line_directive_style <- None;
- (* Temporarily set the name to all functions in the same way *)
- let newname = fdec'.svar.vname in
- (* If we must do alpha conversion then temporarily set the
- * names of the function, local variables and formals in a
- * standard way *)
- if mergeInlinesWithAlphaConvert then
- fdec'.svar.vname <- "@@alphaname@@";
- let nameId = ref 0 in
- let oldNames : string list ref = ref [] in
- let renameOne (v: varinfo) =
- oldNames := v.vname :: !oldNames;
- incr nameId;
- v.vname <- "___alpha" ^ string_of_int !nameId
- in
- let undoRenameOne (v: varinfo) =
- match !oldNames with
- n :: rest ->
- oldNames := rest;
- v.vname <- n
- | _ -> Kernel.fatal "undoRenameOne"
- in
- (* Remember the original type *)
- let origType = fdec'.svar.vtype in
- if mergeInlinesWithAlphaConvert then begin
- (* Rename the formals *)
- List.iter renameOne fdec'.sformals;
- (* Reflect in the type *)
- setFormals fdec' fdec'.sformals;
- (* Now do the locals *)
- List.iter renameOne fdec'.slocals
- end;
- (* Now print it *)
- let res = Format.asprintf "%a" Cil_printer.pp_global g' in
- Cil_printer.state.Printer_api.line_directive_style
- <- oldprintln;
- fdec'.svar.vname <- newname;
- if mergeInlinesWithAlphaConvert then begin
- (* Do the locals in reverse order *)
- List.iter undoRenameOne (List.rev fdec'.slocals);
- (* Do the formals in reverse order *)
- List.iter undoRenameOne (List.rev fdec'.sformals);
- (* Restore the type *)
- Cil.update_var_type fdec'.svar origType;
- end;
- res
- in
- (* Make a node for this inline function using the original
- name. *)
- let inode =
- PlainMerging.getNode vEq vSyn !currentFidx origname fdec'.svar
- (Some (l, !currentDeclIdx))
- in
- if debugInlines then begin
- Kernel.debug "getNode %s(%d) with loc=%a. declidx=%d"
- inode.nname inode.nfidx
- d_nloc inode.nloc
- !currentDeclIdx;
- Kernel.debug
- "Looking for previous definition of inline %s(%d)"
- origname !currentFidx;
- end;
- try
- let oldinode = H.find inlineBodies printout in
- if debugInlines then
- Kernel.debug " Matches %s(%d)"
- oldinode.nname oldinode.nfidx;
- (* There is some other inline function with the same printout.
- * We should reuse this, but watch for the case when the inline
- * was already used. *)
- if H.mem varUsedAlready fdec'.svar.vname then begin
- if mergeInlinesRepeat then begin
- repeatPass2 := true
- end else begin
- Kernel.warning ~current:true
- "Inline function %s because \
- it is used before it is defined"
- fdec'.svar.vname;
- raise Not_found
- end
- end;
- let _ = union oldinode inode in
- (* Clean up the vreferenced bit in the new inline, so that we
- * can rename it. Reset the name to the original one so that
- * we can find the replacement name. *)
- fdec'.svar.vname <- origname;
- () (* Drop this definition *)
- with Not_found -> begin
- if debugInlines then Kernel.debug " Not found";
- H.add inlineBodies printout inode;
- mergePushGlobal g'
- end
- end else begin
- (* either the function is not inline, or we're not attempting to
- * merge inlines *)
- if mergeGlobals
- && not fdec'.svar.vinline
- && fdec'.svar.vstorage <> Static
- then begin
- (* sm: this is a non-inline, non-static function. I want to
- * consider dropping it if a same-named function has already
- * been put into the merged file *)
- let curSum = (functionChecksum fdec') in
- try
- let _prevFun, prevLoc, prevSum =
- (H.find emittedFunDefn fdec'.svar.vname)
- in
- (* restore old binding for vi, as we are about to drop
- the new definition and its formals.
- *)
- Cil_datatype.Varinfo.Hashtbl.remove formals_renaming vi;
- (* Restore the formals from the old definition. We always have
- Some l from getFormalsDecl
- in case of a defined function. *)
- Cil.setFormals fdec (Extlib.the defn_formals);
- (* previous was found *)
- if (curSum = prevSum) then
- Kernel.warning ~current:true
- "dropping duplicate def'n of func %s at %a in favor of \
- that at %a"
- fdec'.svar.vname
- Cil_printer.pp_location l Cil_printer.pp_location prevLoc
- else begin
- (* the checksums differ, so print a warning but keep the
- * older one to avoid a link error later. I think this is
- * a reasonable approximation of what ld does. *)
- Kernel.warning ~current:true
- "def'n of func %s at %a (sum %d) conflicts with the one \
- at %a (sum %d); keeping the one at %a."
- fdec'.svar.vname
- Cil_printer.pp_location l
- curSum
- Cil_printer.pp_location prevLoc
- prevSum Cil_printer.pp_location prevLoc
- end
- with Not_found -> begin
- (* there was no previous definition *)
- (mergePushGlobal g');
- (H.add emittedFunDefn fdec'.svar.vname (fdec', l, curSum))
- end
+ (* Now print it *)
+ let res = Format.asprintf "%a" Cil_printer.pp_global g' in
+ Cil_printer.state.Printer_api.line_directive_style
+ <- oldprintln;
+ fdec'.svar.vname <- newname;
+ if mergeInlinesWithAlphaConvert then begin
+ (* Do the locals in reverse order *)
+ List.iter undoRenameOne (List.rev fdec'.slocals);
+ (* Do the formals in reverse order *)
+ List.iter undoRenameOne (List.rev fdec'.sformals);
+ (* Restore the type *)
+ Cil.update_var_type fdec'.svar origType;
+ end;
+ res
+ in
+ (* Make a node for this inline function using the original
+ name. *)
+ let inode =
+ PlainMerging.getNode vEq vSyn !currentFidx origname fdec'.svar
+ (Some (l, !currentDeclIdx))
+ in
+ if debugInlines then begin
+ Kernel.debug "getNode %s(%d) with loc=%a. declidx=%d"
+ inode.nname inode.nfidx
+ d_nloc inode.nloc
+ !currentDeclIdx;
+ Kernel.debug
+ "Looking for previous definition of inline %s(%d)"
+ origname !currentFidx;
+ end;
+ try
+ let oldinode = H.find inlineBodies printout in
+ if debugInlines then
+ Kernel.debug " Matches %s(%d)"
+ oldinode.nname oldinode.nfidx;
+ (* There is some other inline function with the same printout.
+ * We should reuse this, but watch for the case when the inline
+ * was already used. *)
+ if H.mem varUsedAlready fdec'.svar.vname then begin
+ if mergeInlinesRepeat then begin
+ repeatPass2 := true
end else begin
- (* not attempting to merge global functions, or it was static
- * or inline *)
- mergePushGlobal g'
- end;
- end
- end
-
- | GCompTag (ci, l) as g -> begin
- CurrentLoc.set l;
- incr currentDeclIdx;
- if ci.creferenced then
- ()
- else begin
- match
- PlainMerging.findReplacement true sEq !currentFidx ci.cname
- with
- None ->
- (* A new one, we must rename it and keep the definition *)
- (* Make sure this is root *)
- (try
- let nd =
- PlainMerging.find_eq_table sEq (!currentFidx, ci.cname)
- in
- if nd.nrep != nd then
- Kernel.fatal "Setting creferenced for struct %s which is \
- not root!"
- ci.cname;
- with Not_found -> begin
- Kernel.fatal "Setting creferenced for struct %s which \
- is not in the sEq!"
- ci.cname;
- end);
- let orig_name =
- if ci.corig_name = "" then ci.cname else ci.corig_name
- in
- let newname, _ =
- Alpha.newAlphaName sAlpha orig_name (CurrentLoc.get ())
- in
- ci.cname <- newname;
- ci.creferenced <- true;
- (* Now we should visit the fields as well *)
- H.add emittedCompDecls ci.cname true; (* Remember that we
- * emitted it *)
- mergePushGlobals (visitCilGlobal renameVisitor g)
- | Some (_oldci, _oldfidx) -> begin
- (* We are not the representative. Drop this declaration
- * because we'll not be using it. *)
- ()
+ Kernel.warning ~current:true
+ "Inline function %s because \
+ it is used before it is defined"
+ fdec'.svar.vname;
+ raise Not_found
end
- end
- end
- | GEnumTag (ei, l) as g -> begin
- CurrentLoc.set l;
- incr currentDeclIdx;
- if ei.ereferenced then
- ()
- else begin
- match
- EnumMerging.findReplacement true eEq !currentFidx ei
- with
- | None -> (* We must rename it *)
- let orig_name =
- if ei.eorig_name = "" then ei.ename else ei.eorig_name
+ end;
+ let _ = union oldinode inode in
+ (* Clean up the vreferenced bit in the new inline, so that we
+ * can rename it. Reset the name to the original one so that
+ * we can find the replacement name. *)
+ fdec'.svar.vname <- origname;
+ () (* Drop this definition *)
+ with Not_found -> begin
+ if debugInlines then Kernel.debug " Not found";
+ H.add inlineBodies printout inode;
+ mergePushGlobal g'
+ end
+ end else begin
+ (* either the function is not inline, or we're not attempting to
+ * merge inlines *)
+ if mergeGlobals
+ && not fdec'.svar.vinline
+ && fdec'.svar.vstorage <> Static
+ then begin
+ (* sm: this is a non-inline, non-static function. I want to
+ * consider dropping it if a same-named function has already
+ * been put into the merged file *)
+ let curSum = (functionChecksum fdec') in
+ try
+ let _prevFun, prevLoc, prevSum =
+ (H.find emittedFunDefn fdec'.svar.vname)
in
- let newname, _ =
- Alpha.newAlphaName eAlpha orig_name (CurrentLoc.get ())
- in
- ei.ename <- newname;
- ei.ereferenced <- true;
- (* And we must rename the items to using the same name space
- * as the variables *)
- List.iter
- (fun item ->
- let newname,_ =
- Alpha.newAlphaName vtAlpha item.eiorig_name item.eiloc
- in
- item.einame <- newname)
- ei.eitems;
- mergePushGlobals (visitCilGlobal renameVisitor g);
- | Some (_ei', _) -> (* Drop this since we are reusing it from
- * before *)
- ()
- end
- end
- | GCompTagDecl (ci, l) -> begin
- CurrentLoc.set l; (* This is here just to introduce an undefined
- * structure. But maybe the structure was defined
- * already. *)
- (* Do not increment currentDeclIdx because it is not incremented in
- * pass 1*)
- if H.mem emittedCompDecls ci.cname then
- () (* It was already declared *)
- else begin
- H.add emittedCompDecls ci.cname true;
- (* Keep it as a declaration *)
- mergePushGlobal g;
- end
- end
+ (* restore old binding for vi, as we are about to drop
+ the new definition and its formals.
+ *)
+ Cil_datatype.Varinfo.Hashtbl.remove formals_renaming vi;
+ (* Restore the formals from the old definition. We always have
+ Some l from getFormalsDecl
+ in case of a defined function. *)
+ Cil.setFormals fdec (Extlib.the defn_formals);
+ (* previous was found *)
+ if (curSum = prevSum) then
+ Kernel.warning ~current:true
+ "dropping duplicate def'n of func %s at %a in favor of \
+ that at %a"
+ fdec'.svar.vname
+ Cil_printer.pp_location l Cil_printer.pp_location prevLoc
+ else begin
+ (* the checksums differ, so print a warning but keep the
+ * older one to avoid a link error later. I think this is
+ * a reasonable approximation of what ld does. *)
+ Kernel.warning ~current:true
+ "def'n of func %s at %a (sum %d) conflicts with the one \
+ at %a (sum %d); keeping the one at %a."
+ fdec'.svar.vname
+ Cil_printer.pp_location l
+ curSum
+ Cil_printer.pp_location prevLoc
+ prevSum Cil_printer.pp_location prevLoc
+ end
+ with Not_found -> begin
+ (* there was no previous definition *)
+ (mergePushGlobal g');
+ (H.add emittedFunDefn fdec'.svar.vname (fdec', l, curSum))
+ end
+ end else begin
+ (* not attempting to merge global functions, or it was static
+ * or inline *)
+ mergePushGlobal g'
+ end;
+ end
+ end
- | GEnumTagDecl (_ei, l) ->
- CurrentLoc.set l;
- (* Do not increment currentDeclIdx because it is not incremented in
- * pass 1*)
+ | GCompTag (ci, l) as g -> begin
+ CurrentLoc.set l;
+ incr currentDeclIdx;
+ if ci.creferenced then
+ ()
+ else begin
+ match
+ PlainMerging.findReplacement true sEq !currentFidx ci.cname
+ with
+ None ->
+ (* A new one, we must rename it and keep the definition *)
+ (* Make sure this is root *)
+ (try
+ let nd =
+ PlainMerging.find_eq_table sEq (!currentFidx, ci.cname)
+ in
+ if nd.nrep != nd then
+ Kernel.fatal "Setting creferenced for struct %s which is \
+ not root!"
+ ci.cname;
+ with Not_found -> begin
+ Kernel.fatal "Setting creferenced for struct %s which \
+ is not in the sEq!"
+ ci.cname;
+ end);
+ let orig_name =
+ if ci.corig_name = "" then ci.cname else ci.corig_name
+ in
+ let newname, _ =
+ Alpha.newAlphaName sAlpha orig_name (CurrentLoc.get ())
+ in
+ ci.cname <- newname;
+ ci.creferenced <- true;
+ (* Now we should visit the fields as well *)
+ H.add emittedCompDecls ci.cname true; (* Remember that we
+ * emitted it *)
+ mergePushGlobals (visitCilGlobal renameVisitor g)
+ | Some (_oldci, _oldfidx) -> begin
+ (* We are not the representative. Drop this declaration
+ * because we'll not be using it. *)
+ ()
+ end
+ end
+ end
+ | GEnumTag (ei, l) as g -> begin
+ CurrentLoc.set l;
+ incr currentDeclIdx;
+ if ei.ereferenced then
+ ()
+ else begin
+ match
+ EnumMerging.findReplacement true eEq !currentFidx ei
+ with
+ | None -> (* We must rename it *)
+ let orig_name =
+ if ei.eorig_name = "" then ei.ename else ei.eorig_name
+ in
+ let newname, _ =
+ Alpha.newAlphaName eAlpha orig_name (CurrentLoc.get ())
+ in
+ ei.ename <- newname;
+ ei.ereferenced <- true;
+ (* And we must rename the items to using the same name space
+ * as the variables *)
+ List.iter
+ (fun item ->
+ let newname,_ =
+ Alpha.newAlphaName vtAlpha item.eiorig_name item.eiloc
+ in
+ item.einame <- newname)
+ ei.eitems;
+ mergePushGlobals (visitCilGlobal renameVisitor g);
+ | Some (_ei', _) -> (* Drop this since we are reusing it from
+ * before *)
+ ()
+ end
+ end
+ | GCompTagDecl (ci, l) -> begin
+ CurrentLoc.set l; (* This is here just to introduce an undefined
+ * structure. But maybe the structure was defined
+ * already. *)
+ (* Do not increment currentDeclIdx because it is not incremented in
+ * pass 1*)
+ if H.mem emittedCompDecls ci.cname then
+ () (* It was already declared *)
+ else begin
+ H.add emittedCompDecls ci.cname true;
(* Keep it as a declaration *)
- mergePushGlobal g
+ mergePushGlobal g;
+ end
+ end
+ | GEnumTagDecl (_ei, l) ->
+ CurrentLoc.set l;
+ (* Do not increment currentDeclIdx because it is not incremented in
+ * pass 1*)
+ (* Keep it as a declaration *)
+ mergePushGlobal g
- | GType (ti, l) as g -> begin
- CurrentLoc.set l;
- incr currentDeclIdx;
- if ti.treferenced then
+
+ | GType (ti, l) as g -> begin
+ CurrentLoc.set l;
+ incr currentDeclIdx;
+ if ti.treferenced then
+ ()
+ else begin
+ match
+ PlainMerging.findReplacement true tEq !currentFidx ti.tname
+ with
+ None -> (* We must rename it and keep it *)
+ let newname, _ =
+ Alpha.newAlphaName vtAlpha ti.torig_name (CurrentLoc.get ())
+ in
+ ti.tname <- newname;
+ ti.treferenced <- true;
+ mergePushGlobals (visitCilGlobal renameVisitor g);
+ | Some (_ti', _) ->(* Drop this since we are reusing it from
+ * before *)
()
- else begin
- match
- PlainMerging.findReplacement true tEq !currentFidx ti.tname
- with
- None -> (* We must rename it and keep it *)
- let newname, _ =
- Alpha.newAlphaName vtAlpha ti.torig_name (CurrentLoc.get ())
- in
- ti.tname <- newname;
- ti.treferenced <- true;
- mergePushGlobals (visitCilGlobal renameVisitor g);
- | Some (_ti', _) ->(* Drop this since we are reusing it from
- * before *)
- ()
- end
end
- | GAnnot (a, l) as g ->
- CurrentLoc.set l;
- incr currentDeclIdx;
- global_annot_pass2 g a
- | g -> mergePushGlobals (visitCilGlobal renameVisitor g)
+ end
+ | GAnnot (a, l) as g ->
+ CurrentLoc.set l;
+ incr currentDeclIdx;
+ global_annot_pass2 g a
+ | g -> mergePushGlobals (visitCilGlobal renameVisitor g)
in
(* Now do the real PASS 2 *)
List.iter processOneGlobal f.globals;
@@ -3145,15 +3145,15 @@ let oneFilePass2 (f: file) =
List.rev
(List.rev_map
(function
- | GVar(vi,{init=None},loc) as g ->
- (try let (_,real_init,_) = H.find emittedVarDefn vi.vname
- in match real_init with
- | None -> g
- | Some _ -> GVarDecl(vi,loc)
- with Not_found -> g)
- | g -> g)
+ | GVar(vi,{init=None},loc) as g ->
+ (try let (_,real_init,_) = H.find emittedVarDefn vi.vname
+ in match real_init with
+ | None -> g
+ | Some _ -> GVarDecl(vi,loc)
+ with Not_found -> g)
+ | g -> g)
!theFile)
- end;
+ end;
(* See if we must re-visit the globals in this file because an inline that
* is being removed was used before we saw the definition and we decided to
* remove it *)
@@ -3170,8 +3170,8 @@ let oneFilePass2 (f: file) =
match l with
| [] -> Kernel.fatal "mergecil: scanUntil could not find the marker"
| g :: rest ->
- theseGlobals := g :: !theseGlobals;
- scanUntil tail rest
+ theseGlobals := g :: !theseGlobals;
+ scanUntil tail rest
in
(* Collect in theseGlobals all the globals from this file *)
theseGlobals := [];
@@ -3179,7 +3179,7 @@ let oneFilePass2 (f: file) =
(* Now reprocess them *)
theFile := savedTheFile;
List.iter (fun g ->
- theFile := (visitCilGlobal renameInlinesVisitor g) @ !theFile)
+ theFile := (visitCilGlobal renameInlinesVisitor g) @ !theFile)
!theseGlobals;
(* Now check if we have inlines that we could not remove
H.iter (fun name _ ->
@@ -3214,12 +3214,12 @@ let global_merge_spec g =
"Merging global definition %a" Cil_printer.pp_global g;
let specs = Cil_datatype.Varinfo.Hashtbl.find spec_to_merge fdec.svar in
List.iter
- (fun s ->
- Kernel.debug ~dkey:Kernel.dkey_linker
- "Found spec to merge %a" Cil_printer.pp_funspec s;
- rename fdec.svar s;
- Kernel.debug ~dkey:Kernel.dkey_linker
- "After renaming:@\n%a" Cil_printer.pp_funspec s)
+ (fun s ->
+ Kernel.debug ~dkey:Kernel.dkey_linker
+ "Found spec to merge %a" Cil_printer.pp_funspec s;
+ rename fdec.svar s;
+ Kernel.debug ~dkey:Kernel.dkey_linker
+ "After renaming:@\n%a" Cil_printer.pp_funspec s)
specs;
Kernel.debug ~dkey:Kernel.dkey_linker
"Merging with %a" Cil_printer.pp_funspec fdec.sspec ;
@@ -3235,14 +3235,14 @@ let global_merge_spec g =
(try
let specs = Cil_datatype.Varinfo.Hashtbl.find spec_to_merge v in
List.iter
- (fun s ->
- Kernel.debug ~dkey:Kernel.dkey_linker
- "Found spec to merge %a" Cil_printer.pp_funspec s)
+ (fun s ->
+ Kernel.debug ~dkey:Kernel.dkey_linker
+ "Found spec to merge %a" Cil_printer.pp_funspec s)
specs;
Kernel.debug ~dkey:Kernel.dkey_linker
"Renaming %a" Cil_printer.pp_funspec spec ;
rename v spec;
- (* The registered specs might also need renaming up to
+ (* The registered specs might also need renaming up to
definition's formals instead of declaration's ones. *)
List.iter (rename v) specs;
Kernel.debug ~dkey:Kernel.dkey_linker
@@ -3251,7 +3251,7 @@ let global_merge_spec g =
merge_specs spec specs;
Kernel.debug ~dkey:Kernel.dkey_linker
"Merged into %a" Cil_printer.pp_funspec spec ;
- with Not_found ->
+ with Not_found ->
Kernel.debug ~dkey:Kernel.dkey_linker "No spec_to_merge for declaration" ;
rename v spec;
Kernel.debug ~dkey:Kernel.dkey_linker
@@ -3263,7 +3263,7 @@ let find_decls g =
let c_res = ref Cil_datatype.Varinfo.Set.empty in
let res = ref Cil_datatype.Logic_var.Set.empty in
let visit =
-object(self)
+ object(self)
inherit Cil.nopCilVisitor
method! vvdec v =
c_res:=Cil_datatype.Varinfo.Set.add v !c_res; DoChildren
@@ -3271,12 +3271,12 @@ object(self)
res := Cil_datatype.Logic_var.Set.add lv !res;
SkipChildren
method! vspec _ = SkipChildren
- method! vfunc f =
+ method! vfunc f =
ignore (self#vvdec f.svar);
Extlib.may (ignore $ self#vlogic_var_decl) f.svar.vlogic_var_assoc;
SkipChildren
end
- in
+ in
ignore (visitCilGlobal visit g); !c_res, !res
let used_vars g =
@@ -3289,10 +3289,10 @@ let used_vars g =
locals := Cil_datatype.Logic_var.Set.add lv !locals;
SkipChildren
method! vlogic_var_use lv =
- if not (Cil_datatype.Logic_var.Set.mem lv !locals)
- && not (Logic_env.is_builtin_logic_function lv.lv_name)
- && not (lv.lv_name = "\\exit_status")
- then
+ if not (Cil_datatype.Logic_var.Set.mem lv !locals)
+ && not (Logic_env.is_builtin_logic_function lv.lv_name)
+ && not (lv.lv_name = "\\exit_status")
+ then
begin
res:=Cil_datatype.Logic_var.Set.add lv !res
end;
@@ -3303,15 +3303,15 @@ let used_vars g =
let print_missing fmt to_declare =
let print_one_binding fmt s =
- Cil_datatype.Logic_var.Set.iter
+ Cil_datatype.Logic_var.Set.iter
(fun x -> Format.fprintf fmt "%a;@ " Cil_printer.pp_logic_var x) s
in
let print_entry fmt v (_,s) =
- Format.fprintf fmt "@[%a:@[%a@]@]@\n"
+ Format.fprintf fmt "@[%a:@[%a@]@]@\n"
Cil_printer.pp_varinfo v print_one_binding s
in
Cil_datatype.Varinfo.Map.iter (print_entry fmt) to_declare
-
+
let move_spec globals =
let all_declared known v (g,missing) (can_declare,to_declare) =
@@ -3330,40 +3330,40 @@ let move_spec globals =
in
let res, to_declare =
match g with
- | GFunDecl (_,v,l) ->
- let needs = used_vars g in
- let missing = Cil_datatype.Logic_var.Set.diff needs known in
- if Cil_datatype.Logic_var.Set.is_empty missing then
- g::res, to_declare
- else
- (GFunDecl(Cil.empty_funspec (),v,l)::res,
- Cil_datatype.Varinfo.Map.add v (g,missing) to_declare)
- | GFun (f,l) ->
- let needs = used_vars g in
- let missing = Cil_datatype.Logic_var.Set.diff needs known in
- if Cil_datatype.Logic_var.Set.is_empty missing then g::res,to_declare
- else
- let res =
- if Cil_datatype.Varinfo.Set.mem f.svar c_known then
- res
- else
- GFunDecl(Cil.empty_funspec (),f.svar,l)::res
- in
- res, Cil_datatype.Varinfo.Map.add f.svar (g,missing) to_declare
- | _ -> (g::res,to_declare)
+ | GFunDecl (_,v,l) ->
+ let needs = used_vars g in
+ let missing = Cil_datatype.Logic_var.Set.diff needs known in
+ if Cil_datatype.Logic_var.Set.is_empty missing then
+ g::res, to_declare
+ else
+ (GFunDecl(Cil.empty_funspec (),v,l)::res,
+ Cil_datatype.Varinfo.Map.add v (g,missing) to_declare)
+ | GFun (f,l) ->
+ let needs = used_vars g in
+ let missing = Cil_datatype.Logic_var.Set.diff needs known in
+ if Cil_datatype.Logic_var.Set.is_empty missing then g::res,to_declare
+ else
+ let res =
+ if Cil_datatype.Varinfo.Set.mem f.svar c_known then
+ res
+ else
+ GFunDecl(Cil.empty_funspec (),f.svar,l)::res
+ in
+ res, Cil_datatype.Varinfo.Map.add f.svar (g,missing) to_declare
+ | _ -> (g::res,to_declare)
in
let c_known = Cil_datatype.Varinfo.Set.union my_c_decls c_known in
(can_declare @ res, c_known, known, to_declare)
in
- let (res,_,_,to_declare) =
- List.fold_left
- aux
+ let (res,_,_,to_declare) =
+ List.fold_left
+ aux
([],
Cil_datatype.Varinfo.Set.empty,
Cil_datatype.Logic_var.Set.empty,
Cil_datatype.Varinfo.Map.empty)
globals
- in
+ in
assert
(Kernel.verify (Cil_datatype.Varinfo.Map.is_empty to_declare)
"Some globals contain dangling references after link:@\n%a"
@@ -3404,7 +3404,7 @@ let merge (files: file list) (newname: string) : file =
if mergeInlines then begin
(* Copy all the nodes from the iEq to vEq as well. This is needed
* because vEq will be used for variable renaming *)
- PlainMerging.iter_eq_table
+ PlainMerging.iter_eq_table
(fun k n -> PlainMerging.add_eq_table vEq k n) iEq;
doMergeSynonyms iSyn matchInlines;
end
@@ -3427,7 +3427,7 @@ let merge (files: file list) (newname: string) : file =
let rec revonto acc = function
[] -> acc
| x :: t ->
- revonto (x :: acc) t
+ revonto (x :: acc) t
in
let res =
{ fileName = Datatype.Filepath.of_string newname;
diff --git a/src/kernel_services/ast_data/cil_types.mli b/src/kernel_services/ast_data/cil_types.mli
index c7dcf53a99f..49d3a0fecd3 100644
--- a/src/kernel_services/ast_data/cil_types.mli
+++ b/src/kernel_services/ast_data/cil_types.mli
@@ -67,14 +67,14 @@
{!Cil.iterGlobals} and {!Cil.foldGlobals}. You can also use the
{!Cil.dummyFile} when you need a {!Cil_types.file} as a placeholder. For
each global item CIL stores the source location where it appears (using the
- type {!Cil_types.location})
+ type {!Cil_types.location})
@plugin development guide *)
-type file = {
+type file = {
mutable fileName: Filepath.Normalized.t; (** The complete file name *)
-
- mutable globals: global list;
+
+ mutable globals: global list;
(** List of globals as they will appear in the printed file *)
-
+
mutable globinit: fundec option;
(** An optional global initializer function. This is a function where you
can put stuff that must be executed before the program is
@@ -83,10 +83,10 @@ type file = {
create/get one. *)
mutable globinitcalled: bool;
-(** Whether the global initialization function is called in main. This
- should always be false if there is no global initializer. When you
- create a global initialization CIL will try to insert code in main to
- call it. *)
+ (** Whether the global initialization function is called in main. This
+ should always be false if there is no global initializer. When you
+ create a global initialization CIL will try to insert code in main to
+ call it. *)
}
(** The main type for representing global declarations and definitions. A list
@@ -147,7 +147,7 @@ and global =
| GAsm of string * location
(** Global asm statement. These ones can contain only a template *)
-
+
| GPragma of attribute * location
(** Pragmas at top level. Use the same syntax as attributes *)
@@ -156,12 +156,12 @@ and global =
comments in the output. *)
| GAnnot of global_annotation * location
-(** a global annotation. Can be
- - an axiom or a lemma
- - a predicate declaration or definition
- - a global type invariant
- - a global invariant
- - a logic function declaration or definition. *)
+ (** a global annotation. Can be
+ - an axiom or a lemma
+ - a predicate declaration or definition
+ - a global type invariant
+ - a global invariant
+ - a logic function declaration or definition. *)
(* ************************************************************************* *)
(** {2 Types} *)
@@ -241,7 +241,7 @@ and typ =
enumeration itself, which are stored inside the enuminfo *)
| TBuiltin_va_list of attributes
-(** This is the same as the gcc's type with the same name *)
+ (** This is the same as the gcc's type with the same name *)
(** Various kinds of integers *)
and ikind =
@@ -306,10 +306,10 @@ and attrparam =
- __fc_assign takes two arguments and emulate [a1=a2] syntax
- __fc_float takes one string argument and indicates a floating point
constant, that will be printed as such.
- See https://clang.llvm.org/docs/AttributeReference.html#availability
- for more information. Proper attributes node might be added if really
- needed, i.e. if some plug-in wants to interpret the availability
- attribute.
+ See https://clang.llvm.org/docs/AttributeReference.html#availability
+ for more information. Proper attributes node might be added if really
+ needed, i.e. if some plug-in wants to interpret the availability
+ attribute.
*)
| ASizeOf of typ (** A way to talk about types *)
@@ -346,7 +346,7 @@ and attrparam =
(** The definition of a structure or union type. Use {!Cil.mkCompInfo} to make
one and use {!Cil.copyCompInfo} to copy one (this ensures that a new key is
- assigned and that the fields have the right pointers to parents.).
+ assigned and that the fields have the right pointers to parents.).
@plugin development guide *)
and compinfo = {
mutable cstruct: bool;
@@ -381,7 +381,7 @@ and compinfo = {
no fields (such things are allowed in gcc). *)
mutable creferenced: bool;
-(** [true] if used. Initially set to [false]. *)
+ (** [true] if used. Initially set to [false]. *)
}
(* ************************************************************************* *)
@@ -442,8 +442,8 @@ and fieldinfo = {
but use {!Cil.bitsOffset} instead. *)
mutable fpadding_in_bits: int option;
-(** (Deprecated.) Store the size of the padding that follows the field, if any.
- @deprecated only Jessie uses this *)
+ (** (Deprecated.) Store the size of the padding that follows the field, if any.
+ @deprecated only Jessie uses this *)
}
(* ************************************************************************* *)
@@ -473,12 +473,12 @@ and enuminfo = {
for gcc. See ISO C 6.7.2.2 *)
}
-and enumitem = {
+and enumitem = {
eiorig_name: string; (** original name as found in C file. *)
mutable einame: string; (** the name, always non-empty. *)
mutable eival: exp; (** value of the item. Must be a compile-time constant *)
mutable eihost: enuminfo; (** the host enumeration in which the item is
- declared. *)
+ declared. *)
eiloc: location;
}
@@ -518,11 +518,11 @@ and typeinfo = {
of the following functions:
- {!Cil.makeGlobalVar} : to make a global variable
- {!Cil.makeTempVar} : to make a temporary local variable whose name
- will be generated so that to avoid conflict with other locals.
+ will be generated so that to avoid conflict with other locals.
- {!Cil.makeLocalVar} : like {!Cil.makeTempVar} but you can specify the
- exact name to be used.
+ exact name to be used.
- {!Cil.copyVarinfo}: make a shallow copy of a varinfo assigning a new name
- and a new unique identifier
+ and a new unique identifier
A [varinfo] is also used in a function type to denote the list of
formals. *)
@@ -592,13 +592,13 @@ and varinfo = {
(e.g. for temporaries used for function call results, this string is a
representation of the function call.) *)
- mutable vdescrpure: bool;
+ mutable vdescrpure: bool;
(** Indicates whether the vdescr above is a pure expression or call. True
for all CIL expressions and Lvals, but false for e.g. function calls.
Printing a non-pure vdescr more than once may yield incorrect
results. *)
- mutable vghost: bool;
+ mutable vghost: bool;
(** Indicates if the variable is declared in ghost code *)
vsource: bool;
@@ -631,7 +631,7 @@ and storage =
This way the integer 15 can be printed as 0xF if that is how it occurred in
the source.
- CIL uses arbitrary precision integers
+ CIL uses arbitrary precision integers
to represent the integer constants and also stores the
width of the integer type. Care must be taken to ensure that the constant is
representable with the given width. Use the functions {!Cil.kinteger},
@@ -657,7 +657,7 @@ and storage =
{!Cil.constFold}. *)
(** Expressions (Side-effect free)*)
-and exp = {
+and exp = {
eid: int; (** unique identifier *)
enode: exp_node; (** the expression itself *)
eloc: location; (** location of the expression. *)
@@ -705,7 +705,7 @@ and exp_node =
printed. We have it in CIL because it makes the typing rules simpler. *)
| Info of exp * exp_info
-(** Additional information on the underlying expression *)
+ (** Additional information on the underlying expression *)
(** Additional information on an expression *)
and exp_info = {
@@ -752,8 +752,8 @@ and constant =
textual representation, if available. *)
| CEnum of enumitem
-(** An enumeration constant. Use [Cillower.lowerEnumVisitor] to replace these
- with integer constants. *)
+ (** An enumeration constant. Use [Cillower.lowerEnumVisitor] to replace these
+ with integer constants. *)
(** Unary operators *)
and unop =
@@ -775,10 +775,10 @@ and binop =
| MinusPI (** pointer - integer *)
| MinusPP (** pointer - pointer *)
| Mult (** * *)
- | Div (** /
- @plugin development guide *)
- | Mod (** %
- @plugin development guide *)
+ | Div (** /
+ @plugin development guide *)
+ | Mod (** %
+ @plugin development guide *)
| Shiftlt (** shift left *)
| Shiftrt (** shift right *)
@@ -833,15 +833,15 @@ and binop =
The following are a few useful function for operating on lvalues:
- {!Cil.mkMem} - makes an lvalue of [Mem] kind. Use this to ensure
- that certain equivalent forms of lvalues are canonized.
- For example, [*&x = x].
+ that certain equivalent forms of lvalues are canonized.
+ For example, [*&x = x].
- {!Cil.typeOfLval} - the type of an lvalue
- {!Cil.typeOffset} - the type of an offset, given the type of the
- host.
+ host.
- {!Cil.addOffset} and {!Cil.addOffsetLval} - extend sequences
- of offsets.
+ of offsets.
- {!Cil.removeOffset} and {!Cil.removeOffsetLval} - shrink sequences
- of offsets.
+ of offsets.
The following equivalences hold {v
Mem(AddrOf(Mem a, aoff)), off = Mem a, aoff + off
@@ -857,14 +857,14 @@ and lhost =
(** The host is a variable. *)
| Mem of exp
-(** The host is an object of type [T] when the expression has pointer
- [TPtr(T)]. *)
+ (** The host is an object of type [T] when the expression has pointer
+ [TPtr(T)]. *)
(** The offset part of an {!Cil_types.lval}. Each offset can be applied to
certain kinds of lvalues and its effect is that it advances the starting
address of the lvalue and changes the denoted type, essentially focussing
- to some smaller lvalue that is contained in the original one.
+ to some smaller lvalue that is contained in the original one.
@plugin development guide *)
and offset =
| NoOffset
@@ -879,10 +879,10 @@ and offset =
the mentioned field. *)
| Index of exp * offset
-(** An array index offset. Can be applied only to an lvalue that denotes an
- array. This advances the starting address of the lval to the beginning of
- the mentioned array element and changes the denoted type to be the type of
- the array element *)
+ (** An array index offset. Can be applied only to an lvalue that denotes an
+ array. This advances the starting address of the lval to the beginning of
+ the mentioned array element and changes the denoted type to be the type of
+ the array element *)
(* ************************************************************************* *)
(** {2 Initializers} *)
@@ -899,16 +899,16 @@ and offset =
and init =
| SingleInit of exp (** A single initializer *)
| CompoundInit of typ * (offset * init) list
-(** Used only for initializers of structures, unions and arrays. The offsets
- are all of the form [Field(f, NoOffset)] or [Index(i, NoOffset)] and
- specify the field or the index being initialized. For structures all fields
- must have an initializer (except the unnamed bitfields), in the proper
- order. This is necessary since the offsets are not printed. For arrays the
- list must contain a prefix of the initializers; the rest are 0-initialized.
- For unions there must be exactly one initializer. If the initializer is not
- for the first field then a field designator is printed, so you better be on
- GCC since MSVC does not understand this. You can scan an initializer list
- with {!Cil.foldLeftCompound}. *)
+ (** Used only for initializers of structures, unions and arrays. The offsets
+ are all of the form [Field(f, NoOffset)] or [Index(i, NoOffset)] and
+ specify the field or the index being initialized. For structures all fields
+ must have an initializer (except the unnamed bitfields), in the proper
+ order. This is necessary since the offsets are not printed. For arrays the
+ list must contain a prefix of the initializers; the rest are 0-initialized.
+ For unions there must be exactly one initializer. If the initializer is not
+ for the first field then a field designator is printed, so you better be on
+ GCC since MSVC does not understand this. You can scan an initializer list
+ with {!Cil.foldLeftCompound}. *)
(** We want to be able to update an initializer in a global variable, so we
define it as a mutable field *)
@@ -919,11 +919,11 @@ and initinfo = { mutable init : init option }
@since Phosphorus-20170501-beta1. *)
and constructor_kind =
- | Plain_func (** plain function call, whose result is used for initializing
- the variable. *)
- | Constructor (** C++-like constructor: the function takes as first argument
- the address of the variable to be initialized, and
- returns [void]. *)
+ | Plain_func (** plain function call, whose result is used for initializing
+ the variable. *)
+ | Constructor (** C++-like constructor: the function takes as first argument
+ the address of the variable to be initialized, and
+ returns [void]. *)
(** Initializers for local variables.
@since Phosphorus-20170501-beta1
@@ -931,9 +931,9 @@ and constructor_kind =
and local_init =
| AssignInit of init (** normal initialization *)
| ConsInit of varinfo * exp list * constructor_kind
- (** [ConsInit(f,args,kind)] indicates that the corresponding
- local is initialized via a call to [f], of kind [kind]
- with the given [args]. *)
+ (** [ConsInit(f,args,kind)] indicates that the corresponding
+ local is initialized via a call to [f], of kind [kind]
+ with the given [args]. *)
(* ************************************************************************* *)
(** {2 Function definitions} *)
(* ************************************************************************* *)
@@ -961,11 +961,11 @@ and fundec = {
call or in a prototype must point to the same [varinfo]. *)
mutable sformals: varinfo list;
- (** Formals. These must be in the same order and with the same information
- as the formal information in the type of the function. Use
- {!Cil.setFormals} or {!Cil.setFunctionType} to set these formals and
- ensure that they are reflected in the function type. Do not make
- copies of these because the body refers to them. *)
+ (** Formals. These must be in the same order and with the same information
+ as the formal information in the type of the function. Use
+ {!Cil.setFormals} or {!Cil.setFunctionType} to set these formals and
+ ensure that they are reflected in the function type. Do not make
+ copies of these because the body refers to them. *)
mutable slocals: varinfo list;
(** Locals. Does NOT include the sformals. Do not make copies of these
@@ -1110,7 +1110,7 @@ and stmtkind =
@plugin development guide *)
| If of exp * block * block * location
- (** A conditional. Two successors, the "then" and the "else" branches (in
+ (** A conditional. Two successors, the "then" and the "else" branches (in
this order).
Both branches fall-through to the successor of the If statement.
@plugin development guide *)
@@ -1125,7 +1125,7 @@ and stmtkind =
cases.
@plugin development guide *)
- | Loop of
+ | Loop of
code_annotation list * block * location * (stmt option) * (stmt option)
(** A [while(1)] loop. The termination test is implemented in the body of a
loop using a [Break] statement. If {!Cfg.prepareCFG} has been called, the
@@ -1146,21 +1146,21 @@ and stmtkind =
during evaluation of expressions. Each statement comes
together with three list of lval, in this order.
- lvals that are written during the sequence and whose future
- value depends upon the statement (it is legal to read from them, but
- not to write to them)
+ value depends upon the statement (it is legal to read from them, but
+ not to write to them)
- lvals that are written during the evaluation of the statement itself
- lval that are read.
- Function calls in the corresponding statement
- Note that this include only a subset of the affectations
- of the statement. Namely, the
- temporary variables generated by cil are excluded (i.e. it
- is assumed that the "compilation" is correct). In addition,
- side effects caused by function applications are not taken
- into account in the list. For a single statement, the written lvals
- are supposed to be ordered (or their order of evaluation doesn't
- matter), so that an alarm should be emitted only if the lvals read by
- a statement overlap with the lvals written (or read) by another
- statement of the sequence.
+ Note that this include only a subset of the affectations
+ of the statement. Namely, the
+ temporary variables generated by cil are excluded (i.e. it
+ is assumed that the "compilation" is correct). In addition,
+ side effects caused by function applications are not taken
+ into account in the list. For a single statement, the written lvals
+ are supposed to be ordered (or their order of evaluation doesn't
+ matter), so that an alarm should be emitted only if the lvals read by
+ a statement overlap with the lvals written (or read) by another
+ statement of the sequence.
At this time this feature is
experimental and may miss some unspecified sequences.
@@ -1170,13 +1170,13 @@ and stmtkind =
@plugin development guide *)
| Throw of (exp * typ) option * location
- (** Throws an exception, C++ style.
- We keep the type of the expression, to match
- it against the appropriate catch clause. A Throw node has
- no successor, even if it is in try-catch block that will catch
- the exception: we keep normal and exceptional control-flow
- completely separate, as in Jo and Chang, ICSSA 2004.
- *)
+ (** Throws an exception, C++ style.
+ We keep the type of the expression, to match
+ it against the appropriate catch clause. A Throw node has
+ no successor, even if it is in try-catch block that will catch
+ the exception: we keep normal and exceptional control-flow
+ completely separate, as in Jo and Chang, ICSSA 2004.
+ *)
| TryCatch of block * (catch_binder * block) list * location
@@ -1187,45 +1187,45 @@ and stmtkind =
@plugin development guide *)
| TryExcept of block * (instr list * exp) * block * location
-(** On MSVC we support structured exception handling. The try/except
- statement is a bit tricky:
- {v __try \{ blk \}
+ (** On MSVC we support structured exception handling. The try/except
+ statement is a bit tricky:
+ {v __try \{ blk \}
__except (e) \{
handler
\}
v}
- The argument to __except must be an expression. However, we keep a
- list of instructions AND an expression in case you need to make
- function calls. We'll print those as a comma expression. The control
- can get to the __except expression only if an exception is thrown.
- After that, depending on the value of the expression the control
- goes to the handler, propagates the exception, or retries the
- exception. The location corresponds to the try keyword.
- @plugin development guide *)
+ The argument to __except must be an expression. However, we keep a
+ list of instructions AND an expression in case you need to make
+ function calls. We'll print those as a comma expression. The control
+ can get to the __except expression only if an exception is thrown.
+ After that, depending on the value of the expression the control
+ goes to the handler, propagates the exception, or retries the
+ exception. The location corresponds to the try keyword.
+ @plugin development guide *)
(** Kind of exceptions that are caught by a given clause. *)
and catch_binder =
| Catch_exn of varinfo * (varinfo * block) list
- (** catch exception of given type(s).
- If the list is empty, only exceptions with the same type as the
- varinfo can be caught. If the list is non-empty, only exceptions
- matching one of the type of a varinfo in the list are caught.
- The associated block contains the operations necessary to transform
- the matched varinfo into the principal one.
- Semantics is by value (i.e. the varinfo is bound to a copy of the
- caught object).
-
- This clause is a declaration point for the varinfo(s)
- mentioned in it. More precisely, for
- [Catch_exn(v_0,[(v_1, b_1),..., (v_n, b_n)])],
- the [v_i] must be referenced in the [slocals] of the
- enclosing [fundec], and _must not_ appear in any [blocals]
- of some block. The scope of v_0 is all the [b_i] and
- the corresponding block in the [catch_binder * block list] of the
- [TryCatch] node the binder belongs to. The scope of the other [v_i]
- is the corresponding [b_i].
- *)
+ (** catch exception of given type(s).
+ If the list is empty, only exceptions with the same type as the
+ varinfo can be caught. If the list is non-empty, only exceptions
+ matching one of the type of a varinfo in the list are caught.
+ The associated block contains the operations necessary to transform
+ the matched varinfo into the principal one.
+ Semantics is by value (i.e. the varinfo is bound to a copy of the
+ caught object).
+
+ This clause is a declaration point for the varinfo(s)
+ mentioned in it. More precisely, for
+ [Catch_exn(v_0,[(v_1, b_1),..., (v_n, b_n)])],
+ the [v_i] must be referenced in the [slocals] of the
+ enclosing [fundec], and _must not_ appear in any [blocals]
+ of some block. The scope of v_0 is all the [b_i] and
+ the corresponding block in the [catch_binder * block list] of the
+ [TryCatch] node the binder belongs to. The scope of the other [v_i]
+ is the corresponding [b_i].
+ *)
| Catch_all (** default catch clause: all exceptions are caught. *)
(** Instructions. They may cause effects directly but may not have control
@@ -1241,29 +1241,29 @@ and instr =
Actual arguments must have a type equivalent (i.e. {!Cil.need_cast} must
return [false]) to the one of the formals of the function.
If the type of the result variable is not the same as the declared type of
- the function result then an implicit cast exists.
+ the function result then an implicit cast exists.
*)
| Local_init of varinfo * local_init * location
- (** initialization of a local variable. The corresponding varinfo must
- belong to the [blocals] list of the innermost enclosing block that does
- not have attribute {!Cil.block_no_scope_attr}. Such blocks are purely
- here for grouping statements and do not play a role for scoping
- variables. See {!Cil_types.block} definition for more information
- @since Phosphorus-20170501-beta1
- *)
+ (** initialization of a local variable. The corresponding varinfo must
+ belong to the [blocals] list of the innermost enclosing block that does
+ not have attribute {!Cil.block_no_scope_attr}. Such blocks are purely
+ here for grouping statements and do not play a role for scoping
+ variables. See {!Cil_types.block} definition for more information
+ @since Phosphorus-20170501-beta1
+ *)
(* See the GCC specification for the meaning of ASM.
- If the source is MS VC then only the templates
- are used.
+ If the source is MS VC then only the templates
+ are used.
[sm] I've added a notes.txt file which contains more
information on interpreting Asm instructions *)
| Asm of
- attributes (* Really only const and volatile can appear here *)
- * string list (* templates (CR-separated) *)
- * extended_asm option
- * location
- (** An inline assembly instruction. The arguments are
+ attributes (* Really only const and volatile can appear here *)
+ * string list (* templates (CR-separated) *)
+ * extended_asm option
+ * location
+ (** An inline assembly instruction. The arguments are
(1) a list of attributes (only const and volatile can appear here and only
for GCC)
(2) templates (CR-separated)
@@ -1281,17 +1281,17 @@ and instr =
- clobbered registers
- Possible destinations statements *)
and extended_asm =
- {
+ {
asm_outputs: (string option * string * lval) list
- (** outputs must be lvals with optional names and constraints. I would
- like these to be actually variables, but I run into some trouble with
- ASMs in the Linux sources *);
+ (** outputs must be lvals with optional names and constraints. I would
+ like these to be actually variables, but I run into some trouble with
+ ASMs in the Linux sources *);
asm_inputs: (string option * string * exp) list
- (** inputs with optional names and constraints *);
+ (** inputs with optional names and constraints *);
asm_clobbers: string list (** register clobbers *);
asm_gotos: (stmt ref) list
- (** list of statements this asm section may jump to. Destination
- must have a label. *);
+ (** list of statements this asm section may jump to. Destination
+ must have a label. *);
}
(** Describes a location in a source file *)
@@ -1300,7 +1300,7 @@ and location = Filepath.position * Filepath.position
(** {1 Abstract syntax trees for annotations} *)
and logic_constant =
- | Integer of Integer.t * string option
+ | Integer of Integer.t * string option
(** Integer constant with a textual representation. *)
| LStr of string (** String constant. *)
| LWStr of int64 list (** Wide character string constant. *)
@@ -1320,7 +1320,7 @@ and logic_real = {
and logic_type =
| Ctype of typ (** a C type *)
| Ltype of logic_type_info * logic_type list
- (** an user-defined logic type with its parameters *)
+ (** an user-defined logic type with its parameters *)
| Lvar of string (** a type variable. *)
| Linteger (** mathematical integers, {i i.e.} Z *)
| Lreal (** mathematical reals, {i i.e.} R *)
@@ -1361,11 +1361,11 @@ and term = {
term_loc : Filepath.position * Filepath.position;
(** position in the source file. *)
term_type : logic_type; (** type of the term. *)
- term_name: string list;
- (** names of the term if any. A name can be an arbitrary string, where
- '"' and '\'' are escaped by a \, and which does not end with a \.
- Hence, "name" and 'name' should be recognized as a unique label by most
- tools. *)
+ term_name: string list;
+ (** names of the term if any. A name can be an arbitrary string, where
+ '"' and '\'' are escaped by a \, and which does not end with a \.
+ Hence, "name" and 'name' should be recognized as a unique label by most
+ tools. *)
}
(** the various kind of terms. *)
@@ -1386,25 +1386,25 @@ and term_node =
(* additional constructs *)
| Tapp of logic_info * logic_label list * term list
- (** application of a logic function. *)
+ (** application of a logic function. *)
| Tlambda of quantifiers * term (** lambda abstraction. *)
| TDataCons of logic_ctor_info * term list
- (** constructor of logic sum-type. *)
+ (** constructor of logic sum-type. *)
| Tif of term * term * term
- (** conditional operator*)
+ (** conditional operator*)
| Tat of term * logic_label
- (** term refers to a particular program point. *)
+ (** term refers to a particular program point. *)
| Tbase_addr of logic_label * term (** base address of a pointer. *)
| Toffset of logic_label * term (** offset from the base address of a pointer. *)
| Tblock_length of logic_label * term (** length of the block pointed to by the term. *)
| Tnull (** the null pointer. *)
| TLogic_coerce of logic_type * term
- (** implicit conversion from a C type to a logic type.
+ (** implicit conversion from a C type to a logic type.
The logic type must not be a Ctype. In particular, used to denote
lifting to Linteger and Lreal.
*)
| TUpdate of term * term_offset * term
- (** functional update of a field. *)
+ (** functional update of a field. *)
| Ttypeof of term (** type tag for a term. *)
| Ttype of typ (** type tag for a C type. *)
| Tempty_set (** the empty set. *)
@@ -1418,14 +1418,14 @@ and term_node =
(** lvalue: base address and offset. *)
and term_lval =
- term_lhost * term_offset
+ term_lhost * term_offset
(** base address of an lvalue. *)
and term_lhost =
| TVar of logic_var (** a variable. *)
| TResult of typ (** value returned by a C function.
Only used in post-conditions or assigns
- *)
+ *)
| TMem of term (** memory access. *)
(** model field. *)
@@ -1443,13 +1443,13 @@ and model_info = {
and term_offset =
| TNoOffset (** no further offset. *)
| TField of fieldinfo * term_offset
- (** access to the field of a compound type. *)
+ (** access to the field of a compound type. *)
| TModel of model_info * term_offset (** access to a model field. *)
| TIndex of term * term_offset
- (** index. Note that a range is denoted by [TIndex(Trange(i1,i2),ofs)] *)
+ (** index. Note that a range is denoted by [TIndex(Trange(i1,i2),ofs)] *)
(** description of a logic function or predicate.
-@plugin development guide *)
+ @plugin development guide *)
and logic_info = {
(*
mutable l_name : string; (** name of the function. *)
@@ -1464,7 +1464,7 @@ and logic_info = {
mutable l_body : logic_body; (** body of the function. *)
}
-and builtin_logic_info = {
+and builtin_logic_info = {
mutable bl_name: string;
mutable bl_labels: logic_label list;
mutable bl_params: string list;
@@ -1480,7 +1480,7 @@ and logic_body =
| LBpred of predicate (** direct definition of a predicate. *)
| LBinductive of
(string * logic_label list * string list * predicate) list
- (** inductive definition *)
+ (** inductive definition *)
(** Description of a logic type.
@plugin development guide *)
@@ -1488,10 +1488,10 @@ and logic_type_info = {
mutable lt_name: string;
lt_params : string list; (** type parameters*)
mutable lt_def: logic_type_def option;
- (** definition of the type. None for abstract types. *)
+ (** definition of the type. None for abstract types. *)
mutable lt_attr: attributes;
- (** attributes associated to the logic type.
- @since Phosphorus-20170501-beta1 *)
+ (** attributes associated to the logic type.
+ @since Phosphorus-20170501-beta1 *)
}
(* will be expanded when dealing with concrete types *)
@@ -1500,7 +1500,7 @@ and logic_type_def =
| LTsyn of logic_type (** Synonym of another type. *)
(** origin of a logic variable. *)
-and logic_var_kind =
+and logic_var_kind =
| LVGlobal (** global logic function or predicate. *)
| LVC (** Logic counterpart of a C variable. *)
| LVFormal (** formal parameter of a logic function / predicate
@@ -1509,28 +1509,28 @@ and logic_var_kind =
| LVLocal (** local \let *)
(** description of a logic variable
-@plugin development guide *)
+ @plugin development guide *)
and logic_var = {
mutable lv_name : string; (** name of the variable. *)
mutable lv_id : int; (** unique identifier *)
mutable lv_type : logic_type; (** type of the variable. *)
mutable lv_kind: logic_var_kind; (** kind of the variable *)
mutable lv_origin : varinfo option;
- (** when the logic variable stems from a C variable, set to the original C
- variable. *)
+ (** when the logic variable stems from a C variable, set to the original C
+ variable. *)
mutable lv_attr: attributes
- (** attributes tied to the logic variable
- @since Phosphorus-20170501-beta1 *)
+ (** attributes tied to the logic variable
+ @since Phosphorus-20170501-beta1 *)
}
(** Description of a constructor of a logic sum-type.
@plugin development guide *)
and logic_ctor_info =
- { mutable ctor_name: string; (** name of the constructor. *)
- ctor_type: logic_type_info; (** type to which the constructor belongs. *)
- ctor_params: logic_type list
- (** types of the parameters of the constructor. *)
- }
+ { mutable ctor_name: string; (** name of the constructor. *)
+ ctor_type: logic_type_info; (** type to which the constructor belongs. *)
+ ctor_params: logic_type list
+ (** types of the parameters of the constructor. *)
+ }
(* ************************************************************************* *)
(** {2 Predicates} *)
@@ -1540,12 +1540,12 @@ and logic_ctor_info =
and quantifiers = logic_var list
(** comparison relations*)
-and relation =
+and relation =
| Rlt
| Rgt
| Rle
| Rge
- | Req
+ | Req
| Rneq (** @plugin development guide *)
@@ -1554,7 +1554,7 @@ and predicate_node =
| Pfalse (** always-false predicate. *)
| Ptrue (** always-true predicate. *)
| Papp of logic_info * logic_label list * term list
- (** application of a predicate. *)
+ (** application of a predicate. *)
| Pseparated of term list
| Prel of relation * term * term (** comparison of two terms. *)
| Pand of predicate * predicate (** conjunction *)
@@ -1572,15 +1572,15 @@ and predicate_node =
| Pvalid_read of logic_label * term (** the given locations are valid for reading. *)
| Pvalid of logic_label * term (** the given locations are valid. *)
| Pvalid_function of term
- (** the pointed function has a type compatible with the one of pointer. *)
+ (** the pointed function has a type compatible with the one of pointer. *)
| Pinitialized of logic_label * term (** the given locations are initialized. *)
| Pdangling of logic_label * term (** the given locations contain dangling
addresses. *)
| Pallocable of logic_label * term (** the given locations can be allocated. *)
| Pfreeable of logic_label * term (** the given locations can be free. *)
| Pfresh of logic_label * logic_label * term * term
- (** \fresh(pointer, n)
- A memory block of n bytes is newly allocated to the pointer.*)
+ (** \fresh(pointer, n)
+ A memory block of n bytes is newly allocated to the pointer.*)
(** predicate with an unique identifier. Use {!Logic_const.new_predicate} to
create fresh predicates *)
@@ -1599,12 +1599,12 @@ and predicate = {
(** variant of a loop or a recursive function. *)
and variant = term * string option
-(** allocates and frees.
+(** allocates and frees.
@since Oxygen-20120901 *)
and allocation =
| FreeAlloc of identified_term list * identified_term 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. *)
(** dependencies of an assigned location. *)
and deps =
@@ -1617,7 +1617,7 @@ and from = identified_term * 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. *)
(** Function or statement contract. This type shares the name of its
constructors with {!Logic_ptree.spec}. *)
@@ -1637,7 +1637,7 @@ and 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 *)
}
@@ -1657,8 +1657,8 @@ and spec = {
- [Cil_printer.register_xxx_extension] for pretty-printing an
extended clause
- [Cil.register_xxx_extension] for visiting an extended clause
- where xxx can be either [global], [behavior], [code_annot] or
- [loop annot] depending on the level at which the extension should be seen.
+ where xxx can be either [global], [behavior], [code_annot] or
+ [loop annot] depending on the level at which the extension should be seen.
It is _not_ possible to register the same keyword for annotations at two
different levels (e.g. [global] and [behavior]), as this would make the
@@ -1666,11 +1666,11 @@ and spec = {
@plugin development guide *)
and acsl_extension = {
- ext_id : int;
- ext_name : string;
- ext_loc : location;
- ext_has_status : bool;
- ext_kind : acsl_extension_kind
+ ext_id : int;
+ ext_name : string;
+ ext_loc : location;
+ ext_has_status : bool;
+ ext_kind : acsl_extension_kind
}
(** @plugin development guide *)
@@ -1678,7 +1678,7 @@ and acsl_extension_kind =
| Ext_id of int (** id used internally by the extension itself. *)
| Ext_terms of term list
| Ext_preds of predicate list
- (** a list of predicates, the most common case of for extensions *)
+ (** a list of predicates, the most common case of for extensions *)
(** Where are we expected to find corresponding extension keyword.
@plugin development guide
@@ -1701,18 +1701,18 @@ and ext_code_annot_context =
@since Carbon-20101201 [b_requires] has been added.
@modify Boron-20100401 [b_ensures] is replaced by [b_post_cond].
Old [b_ensures] represent the [Normal] case of [b_post_cond].
- *)
+*)
and behavior = {
mutable b_name : string; (** name of the behavior. *)
mutable b_requires : identified_predicate list; (** require clauses. *)
mutable b_assumes : identified_predicate list; (** assume clauses. *)
mutable b_post_cond : (termination_kind * identified_predicate) list
- (** post-condition. *);
+(** post-condition. *);
mutable b_assigns : assigns; (** assignments. *)
mutable b_allocation : allocation; (** frees, allocates. *)
mutable b_extended : acsl_extension list
- (** extensions
- @plugin development guide *)
+ (** extensions
+ @plugin development guide *)
}
(** kind of termination a post-condition applies to. See ACSL manual. *)
@@ -1763,7 +1763,7 @@ and code_annotation_node =
(** loop/code invariant. The list of strings is the list of behaviors to which
this invariant applies. The boolean flag is true for normal loop
invariants and false for invariant-as-assertions. *)
-
+
| AVariant of variant
(** loop variant. Note that there can be at most one variant associated to a
given statement *)
@@ -1780,9 +1780,9 @@ and code_annotation_node =
| APragma of pragma (** pragma. *)
| AExtended of string list * bool * acsl_extension
- (** extension in a code or loop annotation.
- Boolean flag is true for loop extensions and false for code extensions
- @since Silicon-20161101 *)
+ (** extension in a code or loop annotation.
+ Boolean flag is true for loop extensions and false for code extensions
+ @since Silicon-20161101 *)
(** function contract. *)
@@ -1791,8 +1791,8 @@ and funspec = spec
(** code annotation with an unique identifier.
Use {!Logic_const.new_code_annotation} to create new code annotations with
a fresh id. *)
-and code_annotation = {
- annot_id: int; (** identifier. *)
+and code_annotation = {
+ annot_id: int; (** identifier. *)
annot_content : code_annotation_node; (** content of the annotation. *)
}
@@ -1810,7 +1810,7 @@ and global_annotation =
| Dtype of logic_type_info * location (** declaration of a logic type. *)
| Dlemma of
string * bool * logic_label list * string list *
- predicate * attributes * location
+ predicate * attributes * location
(** definition of a lemma. The boolean flag is [true] if the property should
be taken as an axiom and [false] if it must be proved. *)
| Dinvariant of logic_info * location
@@ -1821,9 +1821,9 @@ and global_annotation =
(** Model field for a type t, seen as a logic function with one
argument of type t *)
| Dextended of acsl_extension * attributes * location
- (** Extended global clause. *)
+ (** Extended global clause. *)
| Dcustom_annot of custom_tree * string * attributes * location
- (*Custom declaration*)
+ (*Custom declaration*)
and custom_tree = CustomDummy
(*
@@ -1840,11 +1840,11 @@ type kinstr =
type cil_function =
| Definition of (fundec * location) (** defined function *)
| Declaration of (funspec * varinfo * varinfo list option * location)
- (** Declaration(spec,f,args,loc) represents a leaf function [f] with
- specification [spec] and arguments [args], at location [loc]. As
- with the [TFun] constructor of {!Cil_types.typ}, the arg list is
- optional, to distinguish [void f()] ([None]) from
- [void f(void)] ([Some []]). *)
+ (** Declaration(spec,f,args,loc) represents a leaf function [f] with
+ specification [spec] and arguments [args], at location [loc]. As
+ with the [TFun] constructor of {!Cil_types.typ}, the arg list is
+ optional, to distinguish [void f()] ([None]) from
+ [void f(void)] ([Some []]). *)
(** Only field [fundec] can be used directly. Use {!Annotations.funspec},
[Annotations.add_*] and [Annotations.remove_*] to query or modify field
@@ -1871,10 +1871,10 @@ type localisation =
type syntactic_scope =
| Program (** Only non-static global symbols. *)
| Translation_unit of Filepath.Normalized.t
- (** Any global visible within the given C source file. *)
+ (** Any global visible within the given C source file. *)
| Block_scope of stmt
- (** same as above + all locals of the blocks to which the given statement
- belongs. *)
+ (** same as above + all locals of the blocks to which the given statement
+ belongs. *)
(** Definition of a machine model (architecture + compiler).
@plugin development guide *)
diff --git a/src/kernel_services/ast_data/property.ml b/src/kernel_services/ast_data/property.ml
index 62b20fdd550..0e7c1ab1431 100644
--- a/src/kernel_services/ast_data/property.ml
+++ b/src/kernel_services/ast_data/property.ml
@@ -175,7 +175,7 @@ and identified_property =
| IPPropertyInstance of identified_instance
| IPTypeInvariant of identified_type_invariant
| IPGlobalInvariant of identified_global_invariant
- | IPOther of identified_other
+ | IPOther of identified_other
let pretty_predicate_kind fmt = function
| PKRequires _ -> Format.pp_print_string fmt "requires"
@@ -183,11 +183,11 @@ let pretty_predicate_kind fmt = function
| PKEnsures(_, tk) ->
Format.pp_print_string fmt
(match tk with
- | Normal -> "ensures"
- | Exits -> "exits"
- | Breaks -> "breaks"
- | Continues -> "continues"
- | Returns -> "returns")
+ | Normal -> "ensures"
+ | Exits -> "exits"
+ | Breaks -> "breaks"
+ | Continues -> "continues"
+ | Returns -> "returns")
| PKTerminates -> Format.pp_print_string fmt "terminates"
let other_loc_equal le1 le2 =
@@ -289,26 +289,26 @@ let rec location = function
| IPReachable {ir_kf=None; ir_kinstr=Kstmt s}
| IPPropertyInstance {ii_stmt=s} -> Cil_datatype.Stmt.loc s
| IPCodeAnnot {ica_stmt=s; ica_ca=ca} -> (
- match Cil_datatype.Code_annotation.loc ca with
- | None -> Cil_datatype.Stmt.loc s
- | Some loc -> loc)
+ match Cil_datatype.Code_annotation.loc ca with
+ | None -> Cil_datatype.Stmt.loc s
+ | Some loc -> loc)
| IPReachable {ir_kf=None; ir_kinstr=Kglobal} -> Cil_datatype.Location.unknown
| IPAssigns {ias_kf=kf; ias_kinstr=ki; ias_froms=a} ->
(match a with
- | [] -> loc_of_kf_ki kf ki
- | (t,_) :: _ -> t.it_content.term_loc)
+ | [] -> loc_of_kf_ki kf ki
+ | (t,_) :: _ -> t.it_content.term_loc)
| IPAllocation {ial_kf=kf; ial_kinstr=ki; ial_allocs=fa} ->
(match fa with
- | [],[] -> loc_of_kf_ki kf ki
- | (t :: _),_
- | _,(t :: _) -> t.it_content.term_loc)
+ | [],[] -> loc_of_kf_ki kf ki
+ | (t :: _),_
+ | _,(t :: _) -> t.it_content.term_loc)
| IPFrom {if_from=(t, _)} -> t.it_content.term_loc
| IPDecrease {id_variant=(t, _)} -> t.term_loc
| IPAxiom {il_loc} -> il_loc
| IPAxiomatic {iax_props} ->
(match iax_props with
- | [] -> Cil_datatype.Location.unknown
- | p :: _ -> location p)
+ | [] -> Cil_datatype.Location.unknown
+ | p :: _ -> location p)
| IPLemma {il_loc} -> il_loc
| IPExtended {ie_ext={ext_loc}} -> ext_loc
| IPOther {io_loc} -> loc_of_loc_o io_loc
@@ -534,7 +534,7 @@ include Datatype.Make_with_collections
| IPPredicate {ip_pred=s1}, IPPredicate {ip_pred=s2} -> s1.ip_id = s2.ip_id
| IPExtended {ie_ext={ext_id=i1}}, IPExtended {ie_ext={ext_id=i2}} ->
Datatype.Int.equal i1 i2
- | IPAxiom {il_name=s1}, IPAxiom {il_name=s2}
+ | IPAxiom {il_name=s1}, IPAxiom {il_name=s2}
| IPAxiomatic {iax_name=s1}, IPAxiomatic {iax_name=s2}
| IPTypeInvariant {iti_name=s1}, IPTypeInvariant {iti_name=s2}
| IPGlobalInvariant {igi_name=s1}, IPGlobalInvariant {igi_name=s2}
@@ -640,7 +640,7 @@ include Datatype.Make_with_collections
if n = 0 then Transitioning.Stdlib.compare ba1 ba2 else n
else
n
- | IPAxiom {il_name=s1}, IPAxiom {il_name=s2}
+ | IPAxiom {il_name=s1}, IPAxiom {il_name=s2}
| IPAxiomatic {iax_name=s1}, IPAxiomatic {iax_name=s2}
| IPTypeInvariant {iti_name=s1}, IPTypeInvariant {iti_name=s2}
| IPGlobalInvariant {igi_name=s1}, IPGlobalInvariant {igi_name=s2}
@@ -648,7 +648,7 @@ include Datatype.Make_with_collections
Datatype.String.compare s1 s2
| IPOther {io_name=s1;io_loc=l1}, IPOther {io_name=s2;io_loc=l2} ->
let s = Datatype.String.compare s1 s2 in
- if s <> 0 then s else other_loc_compare l1 l2
+ if s <> 0 then s else other_loc_compare l1 l2
| IPAllocation {ial_kf=f1;ial_kinstr=ki1;ial_bhv=b1},
IPAllocation {ial_kf=f2;ial_kinstr=ki2;ial_bhv=b2} ->
cmp_bhv (f1,ki1,b1) (f2,ki2,b2)
@@ -1315,7 +1315,7 @@ let ip_of_assigns ias_kf ias_kinstr ias_bhv = function
| Writes [(a,_)] when Logic_utils.is_result a.it_content ->
(* We're only assigning the result (with dependencies), but no
global variables, this amounts to \nothing.
- *)
+ *)
Some (IPAssigns {ias_kf; ias_kinstr; ias_bhv; ias_froms=[]})
| Writes ias_froms ->
Some (IPAssigns {ias_kf; ias_kinstr; ias_bhv; ias_froms})
@@ -1326,8 +1326,8 @@ let ip_assigns_of_behavior kf st ~active b =
let ip_of_from if_kf if_kinstr if_bhv if_from =
match snd if_from with
- | FromAny -> None
- | From _ -> Some (IPFrom {if_kf;if_kinstr;if_bhv;if_from})
+ | FromAny -> None
+ | From _ -> Some (IPFrom {if_kf;if_kinstr;if_bhv;if_from})
let ip_from_of_behavior kf st ~active b =
match b.b_assigns with
@@ -1337,10 +1337,10 @@ let ip_from_of_behavior kf st ~active b =
| FromAny -> acc
| From _ ->
let a = Datatype.String.Set.of_list active in
- let ip =
+ let ip =
Extlib.the (ip_of_from kf st (Id_contract (a,b)) (out, froms))
in
- ip :: acc
+ ip :: acc
in
List.fold_left treat_from [] l
@@ -1356,11 +1356,11 @@ let ip_from_of_code_annot kf st ca = match ca.annot_content with
| AAssigns(_,WritesAny) -> []
| AAssigns (_,Writes l) ->
let treat_from acc (out, froms) = match froms with FromAny -> acc
- | From _ ->
- let ip =
- Extlib.the (ip_of_from kf st (Id_loop ca) (out, froms))
- in
- ip::acc
+ | From _ ->
+ let ip =
+ Extlib.the (ip_of_from kf st (Id_loop ca) (out, froms))
+ in
+ ip::acc
in
List.fold_left treat_from [] l
| _ -> []
@@ -1375,7 +1375,7 @@ let ip_of_behavior ib_kf ib_kinstr ~active ib_bhv =
let ib_active = Datatype.String.Set.of_list active in
IPBehavior {ib_kf; ib_kinstr; ib_active; ib_bhv}
-let ip_of_requires ip_kf ip_kinstr b ip_pred =
+let ip_of_requires ip_kf ip_kinstr b ip_pred =
IPPredicate {ip_kind=PKRequires b; ip_kf; ip_kinstr; ip_pred}
let ip_requires_of_behavior kf st b =
@@ -1448,7 +1448,7 @@ let ip_of_code_annot kf stmt ca =
| AVariant t ->
[ IPDecrease {id_kf=kf;id_kinstr=ki;id_ca=Some ca; id_variant=t}]
| AAllocation _ ->
- Extlib.list_of_opt (ip_allocation_of_code_annot kf ki ca)
+ Extlib.list_of_opt (ip_allocation_of_code_annot kf ki ca)
@ ip_from_of_code_annot kf ki ca
| AAssigns _ ->
Extlib.list_of_opt (ip_assigns_of_code_annot kf ki ca)
@@ -1474,7 +1474,7 @@ let ip_of_code_annot_single kf stmt ca = match ip_of_code_annot kf stmt ca with
| ip :: _ ->
Kernel.warning
"@[choosing one of multiple properties associated \
- to code annotation@\n%a@]"
+ to code annotation@\n%a@]"
Cil_printer.pp_code_annotation ca;
ip
@@ -1492,25 +1492,25 @@ let ip_of_global_annotation a =
ip_lemma {il_name; il_labels; il_args; il_pred; il_loc} :: acc
| Dinvariant(l, igi_loc) ->
let igi_pred = match l.l_body with
- | LBpred p -> p
- | _ -> assert false
+ | LBpred p -> p
+ | _ -> assert false
in
IPGlobalInvariant {igi_name=l.l_var_info.lv_name; igi_pred; igi_loc} :: acc
| Dtype_annot(l, iti_loc) ->
let parameter = match l.l_profile with
- | h :: [] -> h
- | _ -> assert false
+ | h :: [] -> h
+ | _ -> assert false
in
let iti_type = match parameter.lv_type with
- | Ctype x -> x
- | _ -> assert false
+ | Ctype x -> x
+ | _ -> assert false
in
let iti_pred = match l.l_body with
- | LBpred p -> p
- | _ -> assert false
+ | LBpred p -> p
+ | _ -> assert false
in
IPTypeInvariant {iti_name=l.l_var_info.lv_name;
- iti_type; iti_pred; iti_loc} :: acc
+ iti_type; iti_pred; iti_loc} :: acc
| Dcustom_annot(_c, _n, _, _) ->
(* TODO *)
Kernel.warning ~once "ignoring status of custom annotation";
diff --git a/src/kernel_services/ast_data/property.mli b/src/kernel_services/ast_data/property.mli
index 6a74d626876..6c76961d3e5 100644
--- a/src/kernel_services/ast_data/property.mli
+++ b/src/kernel_services/ast_data/property.mli
@@ -34,17 +34,17 @@ open Cil_types
- use private records instead of tuples whenever possible
- extend identified_property to any possible annotations
- design more consistent type
- For instance,
+ For instance,
- why code annotations are represented so differently?
- why type [behavior_or_loop] does not contain "assigns" somewhere in its
- name?
+ name?
- why this last type cannot be private? *)
(** assigns can belong either to a contract or a loop annotation *)
type behavior_or_loop = (* private *)
| Id_contract of Datatype.String.Set.t * funbehavior
- (** in case of statement contract, we can have different contracts
- based on different sets of active behaviors. *)
+ (** in case of statement contract, we can have different contracts
+ based on different sets of active behaviors. *)
| Id_loop of code_annotation
(** Only AAssert, AInvariant, or APragma. Other code annotations are
@@ -92,8 +92,8 @@ type identified_behavior = {
ib_bhv : funbehavior
}
(** for statement contract, the set of parent behavior for which the
- contract is active is part of its identification. If the set is empty,
- the contract is active for all parent behaviors.
+ contract is active is part of its identification. If the set is empty,
+ the contract is active for all parent behaviors.
*)
type identified_complete = {
@@ -218,7 +218,7 @@ val short_pretty: Format.formatter -> t -> unit
reverting back to the full ACSL formula if it can't find one.
The name is not meant to uniquely identify the property.
@since Neon-20140301
- *)
+*)
(** @since Oxygen-20120901 *)
val pretty_predicate_kind: Format.formatter -> predicate_kind -> unit
@@ -246,7 +246,7 @@ val ip_other: string -> other_loc -> identified_property
(** Create a non-standard property.
@since Nitrogen-20111001
@modify 18.0-Argon Refine localisation argument
- *)
+*)
val ip_reachable_stmt: kernel_function -> stmt -> identified_property
(** @since Oxygen-20120901 *)
@@ -320,7 +320,7 @@ val ip_of_assigns:
See {!ip_allocation_of_behavior} for signification of [active].
@since Carbon-20110201
@modify Aluminium-20160501 added active argument
- *)
+*)
val ip_assigns_of_behavior:
kernel_function -> kinstr -> active:string list ->
funbehavior -> identified_property option
@@ -358,7 +358,7 @@ val ip_from_of_code_annot:
of the [active] argument.
@since Carbon-20110201
@modify Aluminium-20160501 added active argument
- *)
+*)
val ip_post_cond_of_behavior:
kernel_function -> kinstr -> active:string list ->
funbehavior -> identified_property list
@@ -442,7 +442,7 @@ val ip_decreases_of_spec:
See {!ip_post_cond_of_behavior} for more information.
@since Carbon-20110201
@modify Aluminium-20160501 added active argument
- *)
+*)
val ip_post_cond_of_spec:
kernel_function -> kinstr -> active:string list ->
funspec -> identified_property list
diff --git a/src/kernel_services/ast_data/property_status.ml b/src/kernel_services/ast_data/property_status.ml
index 76b09d36f78..b3540db63af 100644
--- a/src/kernel_services/ast_data/property_status.ml
+++ b/src/kernel_services/ast_data/property_status.ml
@@ -27,10 +27,10 @@
module Caml_hashtbl = Hashtbl
open Emitter
-module Emitted = struct
- type t = True | False_if_reachable | False_and_reachable | Dont_know
+module Emitted = struct
+ type t = True | False_if_reachable | False_and_reachable | Dont_know
end
-type emitted_status = Emitted.t =
+type emitted_status = Emitted.t =
True | False_if_reachable | False_and_reachable | Dont_know
module Emitted_status =
@@ -41,21 +41,21 @@ module Emitted_status =
let name = "Property_status.emitted_status"
let reprs = [ True; False_if_reachable; False_and_reachable; Dont_know ]
let mem_project = Datatype.never_any_project
- let pretty fmt s =
- Format.fprintf fmt "%s"
- (match s with
- | True -> "VALID"
- | False_if_reachable | False_and_reachable -> "**NOT** VALID"
- | Dont_know -> "unknown")
+ let pretty fmt s =
+ Format.fprintf fmt "%s"
+ (match s with
+ | True -> "VALID"
+ | False_if_reachable | False_and_reachable -> "**NOT** VALID"
+ | Dont_know -> "unknown")
let compare (s1:t) s2 = Transitioning.Stdlib.compare s1 s2
let equal (s1:t) s2 = s1 = s2
let hash (s:t) = Caml_hashtbl.hash s
- end)
+ end)
-type emitter_with_properties =
- { emitter: Usable_emitter.t;
- mutable properties: Property.t list;
- logical_consequence: bool }
+type emitter_with_properties =
+ { emitter: Usable_emitter.t;
+ mutable properties: Property.t list;
+ logical_consequence: bool }
module Emitter_with_properties =
Datatype.Make_with_collections
@@ -64,31 +64,31 @@ module Emitter_with_properties =
let name = "Property_status.emitter"
let rehash = Datatype.identity
let structural_descr = Structural_descr.t_abstract
- let reprs =
- List.fold_left
- (fun acc e ->
- { emitter = e;
- properties = Property.reprs;
- logical_consequence = false }
- :: acc)
- []
- Usable_emitter.reprs
-
+ let reprs =
+ List.fold_left
+ (fun acc e ->
+ { emitter = e;
+ properties = Property.reprs;
+ logical_consequence = false }
+ :: acc)
+ []
+ Usable_emitter.reprs
+
let equal x y = Usable_emitter.equal x.emitter y.emitter
let compare x y = Usable_emitter.compare x.emitter y.emitter
let hash x = Caml_hashtbl.hash x.emitter
-
+
let copy = Datatype.undefined
let pretty fmt e = Usable_emitter.pretty fmt e.emitter
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 inconsistent =
- { valid: emitter_with_properties list;
- invalid: emitter_with_properties list }
+ { valid: emitter_with_properties list;
+ invalid: emitter_with_properties list }
module Local = struct
type t =
@@ -98,52 +98,52 @@ module Local = struct
end
type status = Local.t =
- | Never_tried
- | Best of emitted_status * emitter_with_properties list
- | Inconsistent of inconsistent
+ | Never_tried
+ | Best of emitted_status * emitter_with_properties list
+ | Inconsistent of inconsistent
module L = Datatype.Make
- (struct
- type t = status
- include Datatype.Serializable_undefined
- let name = "Property_status.t"
- let reprs =
- let l = Emitter_with_properties.reprs in
- [ Never_tried; Best(True, []); Inconsistent { valid = l; invalid = l } ]
- let mem_project = Datatype.never_any_project
- let pretty fmt s =
- let pp_emitters fmt l =
- Pretty_utils.pp_list ~sep:",@ " ~last:" and "
- Emitter_with_properties.pretty fmt l
- in
- match s with
- | Never_tried -> Format.fprintf fmt "no verification attempted"
- | Best(Dont_know as s, l) ->
- Format.fprintf fmt "@[%a@ @[(tried by %a)@]@]"
- Emitted_status.pretty s
- pp_emitters l
- | Best(True | False_if_reachable | False_and_reachable as s, l) ->
- Format.fprintf fmt "@[%a according to %a%s@]"
- Emitted_status.pretty s
- pp_emitters l
- (match l with
- | [] -> assert false
- | { properties = [] } :: _ -> ""
- | { properties = _ :: _ } :: _ -> " (under hypotheses)")
- | Inconsistent i ->
- Format.fprintf fmt "@[<hv 2>inconsistent status:@ \
-@[%a according to %a@]@ \
-@[but %a according to %a@]"
- Emitted_status.pretty True pp_emitters i.valid
- Emitted_status.pretty False_if_reachable pp_emitters i.invalid
- end)
+ (struct
+ type t = status
+ include Datatype.Serializable_undefined
+ let name = "Property_status.t"
+ let reprs =
+ let l = Emitter_with_properties.reprs in
+ [ Never_tried; Best(True, []); Inconsistent { valid = l; invalid = l } ]
+ let mem_project = Datatype.never_any_project
+ let pretty fmt s =
+ let pp_emitters fmt l =
+ Pretty_utils.pp_list ~sep:",@ " ~last:" and "
+ Emitter_with_properties.pretty fmt l
+ in
+ match s with
+ | Never_tried -> Format.fprintf fmt "no verification attempted"
+ | Best(Dont_know as s, l) ->
+ Format.fprintf fmt "@[%a@ @[(tried by %a)@]@]"
+ Emitted_status.pretty s
+ pp_emitters l
+ | Best(True | False_if_reachable | False_and_reachable as s, l) ->
+ Format.fprintf fmt "@[%a according to %a%s@]"
+ Emitted_status.pretty s
+ pp_emitters l
+ (match l with
+ | [] -> assert false
+ | { properties = [] } :: _ -> ""
+ | { properties = _ :: _ } :: _ -> " (under hypotheses)")
+ | Inconsistent i ->
+ Format.fprintf fmt "@[<hv 2>inconsistent status:@ \
+ @[%a according to %a@]@ \
+ @[but %a according to %a@]"
+ Emitted_status.pretty True pp_emitters i.valid
+ Emitted_status.pretty False_if_reachable pp_emitters i.invalid
+ end)
include L
-
+
(**************************************************************************)
(** {3 Projectified tables} *)
(**************************************************************************)
-let register_as_kernel_logical_consequence_ref =
+let register_as_kernel_logical_consequence_ref =
Extlib.mk_fun "register_as_kernel_logical_consequence_ref"
(* property -> emitter -> emitted_status *)
@@ -154,18 +154,18 @@ module Status =
(struct
include Emitter_with_properties
let local_clear p h =
- Hashtbl.clear h;
- !register_as_kernel_logical_consequence_ref p
+ Hashtbl.clear h;
+ !register_as_kernel_logical_consequence_ref p
let usable_get e = e.emitter
let get e = Emitter.Usable_emitter.get e.emitter
- end)
+ end)
(Emitted_status)
- (struct
- let name = "Property_status.Status"
+ (struct
+ let name = "Property_status.Status"
let dependencies = [ Ast.self ]
let kinds = [ Emitter.Property_status ]
let size = 97
- end)
+ end)
let self = Status.self
@@ -198,20 +198,20 @@ module Hypotheses =
let name = "Property_status.Hypotheses"
let dependencies = [ self ]
let size = 97
- end)
+ end)
let () =
Status.add_hook_on_remove
(fun e ppt _ ->
- (* remove the properties from the hypotheses table *)
- let remove h =
- try
- let l = Hypotheses.find h in
- l := List.filter (fun (ppt', _) -> not (Property.equal ppt ppt')) !l
- with Not_found ->
- ()
- in
- List.iter remove e.properties)
+ (* remove the properties from the hypotheses table *)
+ let remove h =
+ try
+ let l = Hypotheses.find h in
+ l := List.filter (fun (ppt', _) -> not (Property.equal ppt ppt')) !l
+ with Not_found ->
+ ()
+ in
+ List.iter remove e.properties)
module Valid_cycles : sig
@@ -228,7 +228,7 @@ end = struct
let size = 7
let dependencies = [ self ]
let name = "Property_status.Valid_cycles"
- end)
+ end)
let self = S.self
@@ -263,15 +263,15 @@ exception Inconsistent_emitted_status of emitted_status * emitted_status
@raise Inconsistent_emitted_status if the check fails *)
let check_strongest_emitted x y = match x, y with
| True, (False_if_reachable | False_and_reachable)
- | (False_if_reachable | False_and_reachable), True ->
- raise (Inconsistent_emitted_status (x, y))
+ | (False_if_reachable | False_and_reachable), True ->
+ raise (Inconsistent_emitted_status (x, y))
| Dont_know, (True | False_if_reachable | False_and_reachable | Dont_know)
- | True, True
+ | True, True
| False_if_reachable, (False_and_reachable | False_if_reachable)
| False_and_reachable, False_and_reachable
-> false
- | (True | False_if_reachable | False_and_reachable), Dont_know
- | False_and_reachable, False_if_reachable
+ | (True | False_if_reachable | False_and_reachable), Dont_know
+ | False_and_reachable, False_if_reachable
-> true
(* [strengthen emitter emitted_status status] gets [status] and updates it
@@ -279,51 +279,51 @@ let check_strongest_emitted x y = match x, y with
the strongest status between them, or an inconsistency if any. *)
let strengthen emitter emitted_status status =
match status, emitted_status with
- | Never_tried, (True | False_if_reachable | False_and_reachable | Dont_know)
- ->
+ | Never_tried, (True | False_if_reachable | False_and_reachable | Dont_know)
+ ->
(* was not tried, but now we have tried :) *)
Best(emitted_status, [ emitter ])
- | Best(s, l), s2 when s = s2 ->
+ | Best(s, l), s2 when s = s2 ->
(* status are equal: update the emitters *)
Best(s, emitter :: l)
| Best(s, l), s2 (* when s <> emitted_status *) ->
(try
let first = check_strongest_emitted s s2 in
if first then
- (* the old one is the strongest, keep it *)
- status
- else
- (* the new one is the strongest, replace the old one *)
- Best(emitted_status, [ emitter ])
+ (* the old one is the strongest, keep it *)
+ status
+ else
+ (* the new one is the strongest, replace the old one *)
+ Best(emitted_status, [ emitter ])
with Inconsistent_emitted_status _ ->
(* inconsistency detected *)
(match s with
- | True ->
- assert (emitted_status = False_if_reachable
- || emitted_status = False_and_reachable);
- (* the old one is valid, but the new one is invalid *)
- Inconsistent { valid = l; invalid = [ emitter ] }
- | False_if_reachable | False_and_reachable ->
- assert (emitted_status = True);
- (* the old one is invalid, but the new one is valid *)
- Inconsistent { valid = [ emitter ]; invalid = l }
- | Dont_know -> assert false))
- | Inconsistent i, True ->
- (* was already inconsistent and the new one is valid: update the valid
+ | True ->
+ assert (emitted_status = False_if_reachable
+ || emitted_status = False_and_reachable);
+ (* the old one is valid, but the new one is invalid *)
+ Inconsistent { valid = l; invalid = [ emitter ] }
+ | False_if_reachable | False_and_reachable ->
+ assert (emitted_status = True);
+ (* the old one is invalid, but the new one is valid *)
+ Inconsistent { valid = [ emitter ]; invalid = l }
+ | Dont_know -> assert false))
+ | Inconsistent i, True ->
+ (* was already inconsistent and the new one is valid: update the valid
field *)
Inconsistent { i with valid = emitter :: i.valid }
- | Inconsistent i, (False_if_reachable | False_and_reachable) ->
- (* was already inconsistent and the new one is invalid: update the invalid
+ | Inconsistent i, (False_if_reachable | False_and_reachable) ->
+ (* was already inconsistent and the new one is invalid: update the invalid
field *)
Inconsistent { i with invalid = emitter :: i.invalid }
- | Inconsistent _, Dont_know ->
+ | Inconsistent _, Dont_know ->
(* was already inconsistent, but the new one gets no new info: ignore it *)
status
-
+
exception Unmergeable
-(* @return [true] if one must keep the status of the first parameter.
- [false] otherwise. In case of equality, return [false].
+(* @return [true] if one must keep the status of the first parameter.
+ [false] otherwise. In case of equality, return [false].
@raise Unmergeable *)
let merge_distinct_emitted x y = match x, y with
| False_and_reachable, (True | Dont_know | False_if_reachable)
@@ -347,7 +347,7 @@ let rec register ppt =
Project.pretty (Project.current ());
if Status.mem ppt then
Kernel.fatal "trying to register twice property `%a'.\n\
-That is forbidden (kernel invariant broken)."
+ That is forbidden (kernel invariant broken)."
Property.pretty ppt;
let h = Emitter_with_properties.Hashtbl.create 7 in
Status.add ppt h;
@@ -357,7 +357,7 @@ That is forbidden (kernel invariant broken)."
(* the functions below and this one MUST be synchronized *)
and register_as_kernel_logical_consequence ppt =
let open Property in match ppt with
- | IPAxiom _
+ | IPAxiom _
| IPPredicate {ip_kind = PKAssumes _} ->
(* always valid, but must be verifiable by the end-user,
see [is_not_verifiable_but_valid] *)
@@ -370,7 +370,7 @@ and register_as_kernel_logical_consequence ppt =
Emitter.kernel ppt (ip_post_cond_of_behavior ib_kf ib_kinstr active ib_bhv)
| IPReachable {ir_kf = None; ir_kinstr = Cil_types.Kglobal;
ir_program_point = Before} ->
- (* valid: global properties are always reachable *)
+ (* valid: global properties are always reachable *)
emit_valid ppt
| IPReachable {ir_kf = None; ir_kinstr = Cil_types.Kglobal;
ir_program_point = After} ->
@@ -381,12 +381,12 @@ and register_as_kernel_logical_consequence ppt =
ir_program_point = Before} ->
let f = kf.Cil_types.fundec in
if Ast_info.Function.get_name f = Kernel.MainFunction.get_plain_string ()
- (* main is always reachable *)
+ (* main is always reachable *)
then emit_valid ppt
| IPOther _ | IPReachable _
| IPExtended _
- | IPPredicate _ | IPCodeAnnot _ | IPComplete _
- | IPDisjoint _ | IPAssigns _ | IPFrom _
+ | IPPredicate _ | IPCodeAnnot _ | IPComplete _
+ | IPDisjoint _ | IPAssigns _ | IPFrom _
| IPAllocation _ | IPDecrease _ | IPLemma _
| IPPropertyInstance _
| IPTypeInvariant _ | IPGlobalInvariant _ ->
@@ -414,7 +414,7 @@ and is_kernel_logical_consequence ppt =
| IPAxiomatic _
| IPOther _ | IPReachable _
| IPPredicate _ | IPCodeAnnot _ | IPComplete _
- | IPDisjoint _ | IPAssigns _ | IPFrom _
+ | IPDisjoint _ | IPAssigns _ | IPFrom _
| IPAllocation _ | IPDecrease _ | IPLemma _
| IPPropertyInstance _
| IPTypeInvariant _ | IPGlobalInvariant _ ->
@@ -429,12 +429,12 @@ and unsafe_emit_and_get e ~hyps ~auto ppt ?(distinct=false) s =
(List.length hyps);
try
let by_emitter = Status.find ppt in
- let emitter =
- { emitter = Emitter.get e;
- properties = hyps;
- logical_consequence = auto }
+ let emitter =
+ { emitter = Emitter.get e;
+ properties = hyps;
+ logical_consequence = auto }
in
- let emit s =
+ let emit s =
(* first remove from the hypotheses table, each binding [(previous
hypothesis of e, ppt)]. These hypotheses are stored together with the
associated emitter as a key of [by_emitter]. Since there is no way to
@@ -444,11 +444,11 @@ and unsafe_emit_and_get e ~hyps ~auto ppt ?(distinct=false) s =
(try
Emitter_with_properties.Hashtbl.iter
(fun e' _ ->
- if Usable_emitter.equal (Emitter.get e) e'.emitter then begin
- (* the status [Dont_know] is unused by the call below *)
- Status.apply_hooks_on_remove e' ppt Dont_know;
- raise Exit
- end)
+ if Usable_emitter.equal (Emitter.get e) e'.emitter then begin
+ (* the status [Dont_know] is unused by the call below *)
+ Status.apply_hooks_on_remove e' ppt Dont_know;
+ raise Exit
+ end)
by_emitter
with Exit ->
());
@@ -458,103 +458,103 @@ and unsafe_emit_and_get e ~hyps ~auto ppt ?(distinct=false) s =
let selection = State_selection.diff selection linked_to_self in
Project.clear ~selection ();
(* finally, replace the old emitter by the new one *)
- let add e s =
- Emitter_with_properties.Hashtbl.replace by_emitter e s;
- List.iter
- (function
- | Property.IPOther _ -> ()
- | h ->
- let pair = ppt, e in
- try
- let l = Hypotheses.find h in
- l := pair :: !l
- with Not_found ->
- Hypotheses.add h (ref [ pair ]))
- e.properties
+ let add e s =
+ Emitter_with_properties.Hashtbl.replace by_emitter e s;
+ List.iter
+ (function
+ | Property.IPOther _ -> ()
+ | h ->
+ let pair = ppt, e in
+ try
+ let l = Hypotheses.find h in
+ l := pair :: !l
+ with Not_found ->
+ Hypotheses.add h (ref [ pair ]))
+ e.properties
in
(match s with
- | True -> add emitter s
- | Dont_know ->
- add emitter s
- | False_and_reachable ->
- (match hyps with
- | [] -> add emitter s
- | _ :: _ -> Kernel.fatal "Emitter %a proves invalidity of %a under \
-hypotheses: unsound!" Emitter.pretty e Property.pretty ppt)
- | False_if_reachable ->
- (match ppt with
- | Property.IPReachable _ ->
- Kernel.fatal "Emitter %a proves %a by using itself: unsound!"
- Emitter.pretty e Property.pretty ppt
- | _ -> ());
- (match hyps with
- | [] ->
- let reach_ppt = Property.ip_reachable_ppt ppt in
- if is_kernel_logical_consequence reach_ppt then emit_valid reach_ppt;
- add { emitter with properties = [ reach_ppt ] } s
- | _ :: _ -> Kernel.fatal "Emitter %a proves invalidity of %a under \
-hypotheses: unsound!" Emitter.pretty e Property.pretty ppt));
+ | True -> add emitter s
+ | Dont_know ->
+ add emitter s
+ | False_and_reachable ->
+ (match hyps with
+ | [] -> add emitter s
+ | _ :: _ -> Kernel.fatal "Emitter %a proves invalidity of %a under \
+ hypotheses: unsound!" Emitter.pretty e Property.pretty ppt)
+ | False_if_reachable ->
+ (match ppt with
+ | Property.IPReachable _ ->
+ Kernel.fatal "Emitter %a proves %a by using itself: unsound!"
+ Emitter.pretty e Property.pretty ppt
+ | _ -> ());
+ (match hyps with
+ | [] ->
+ let reach_ppt = Property.ip_reachable_ppt ppt in
+ if is_kernel_logical_consequence reach_ppt then emit_valid reach_ppt;
+ add { emitter with properties = [ reach_ppt ] } s
+ | _ :: _ -> Kernel.fatal "Emitter %a proves invalidity of %a under \
+ hypotheses: unsound!" Emitter.pretty e Property.pretty ppt));
s
in
(try
- if auto then
- (* registering again a logical consequence because dependencies change,
- thus erase the previous (now erroneous) calculus *)
- emit s
+ if auto then
+ (* registering again a logical consequence because dependencies change,
+ thus erase the previous (now erroneous) calculus *)
+ emit s
else
- let old_s = Emitter_with_properties.Hashtbl.find by_emitter emitter in
- try
- let first =
- (if distinct then merge_distinct_emitted
- else check_strongest_emitted)
- s
- old_s
- in
- if first then emit s else old_s
- with Unmergeable -> emit Dont_know
+ let old_s = Emitter_with_properties.Hashtbl.find by_emitter emitter in
+ try
+ let first =
+ (if distinct then merge_distinct_emitted
+ else check_strongest_emitted)
+ s
+ old_s
+ in
+ if first then emit s else old_s
+ with Unmergeable -> emit Dont_know
with Not_found ->
emit s)
with Not_found ->
- (* assume that all ACSL properties are registered, except non-ACSL and
- conjunctions ones (but conjunctions are automatically computed and so
- already registered) *)
- match ppt with
- | Property.IPOther _ | Property.IPReachable _
- | Property.IPPropertyInstance _ ->
- register ppt;
- unsafe_emit_and_get e ~hyps ~auto ppt ~distinct s
- | Property.IPPredicate _ | Property.IPCodeAnnot _ | Property.IPComplete _
- | Property.IPDisjoint _ | Property.IPAssigns _ | Property.IPFrom _
- | Property.IPAllocation _ | Property.IPDecrease _ | Property.IPBehavior _
- | Property.IPAxiom _ | Property.IPAxiomatic _ | Property.IPLemma _
- | Property.IPTypeInvariant _ | Property.IPGlobalInvariant _ | Property.IPExtended _ ->
- Kernel.fatal "unregistered property %a" Property.pretty ppt
-
-and logical_consequence e ppt hyps =
+ (* assume that all ACSL properties are registered, except non-ACSL and
+ conjunctions ones (but conjunctions are automatically computed and so
+ already registered) *)
+ match ppt with
+ | Property.IPOther _ | Property.IPReachable _
+ | Property.IPPropertyInstance _ ->
+ register ppt;
+ unsafe_emit_and_get e ~hyps ~auto ppt ~distinct s
+ | Property.IPPredicate _ | Property.IPCodeAnnot _ | Property.IPComplete _
+ | Property.IPDisjoint _ | Property.IPAssigns _ | Property.IPFrom _
+ | Property.IPAllocation _ | Property.IPDecrease _ | Property.IPBehavior _
+ | Property.IPAxiom _ | Property.IPAxiomatic _ | Property.IPLemma _
+ | Property.IPTypeInvariant _ | Property.IPGlobalInvariant _ | Property.IPExtended _ ->
+ Kernel.fatal "unregistered property %a" Property.pretty ppt
+
+and logical_consequence e ppt hyps =
ignore (unsafe_emit_and_get e ~hyps ~auto:true ppt Dont_know)
and emit_valid ppt =
ignore (unsafe_emit_and_get Emitter.kernel ~hyps:[] ~auto:true ppt True)
-let () =
+let () =
register_as_kernel_logical_consequence_ref :=
register_as_kernel_logical_consequence
let emit_and_get e ~hyps ppt ?distinct s =
let open Property in begin match ppt with
- | IPBehavior _ | IPAxiom _ | IPAxiomatic _
- | IPPredicate {ip_kind = PKAssumes _} ->
- Kernel.fatal
- "only the kernel should set the status of property %a"
- pretty
- ppt
- | IPPredicate _ | IPCodeAnnot _ | IPComplete _
- | IPDisjoint _ | IPAssigns _ | IPFrom _
- | IPDecrease _ | IPLemma _ | IPReachable _
- | IPAllocation _ | IPOther _
- | IPPropertyInstance _
- | IPExtended _
- | IPTypeInvariant _ | IPGlobalInvariant _ -> ()
+ | IPBehavior _ | IPAxiom _ | IPAxiomatic _
+ | IPPredicate {ip_kind = PKAssumes _} ->
+ Kernel.fatal
+ "only the kernel should set the status of property %a"
+ pretty
+ ppt
+ | IPPredicate _ | IPCodeAnnot _ | IPComplete _
+ | IPDisjoint _ | IPAssigns _ | IPFrom _
+ | IPDecrease _ | IPLemma _ | IPReachable _
+ | IPAllocation _ | IPOther _
+ | IPPropertyInstance _
+ | IPExtended _
+ | IPTypeInvariant _ | IPGlobalInvariant _ -> ()
end;
unsafe_emit_and_get e ~hyps ~auto:false ppt ?distinct s
@@ -566,11 +566,11 @@ let remove_when_used_as_hypothesis hyp =
let l = Hypotheses.find hyp in
let remove (ppt, e) =
if e.logical_consequence then
- (* only remove [hyp] from hypotheses without killing the status *)
- e.properties <- List.filter (fun ppt' -> ppt' != hyp) e.properties
+ (* only remove [hyp] from hypotheses without killing the status *)
+ e.properties <- List.filter (fun ppt' -> ppt' != hyp) e.properties
else
- let by_emitter = try Status.find ppt with Not_found -> assert false in
- Emitter_with_properties.Hashtbl.remove by_emitter e
+ let by_emitter = try Status.find ppt with Not_found -> assert false in
+ Emitter_with_properties.Hashtbl.remove by_emitter e
in
List.iter remove !l
with Not_found ->
@@ -591,7 +591,7 @@ module Remove_hook = Hook.Build(struct type t = Property.t end)
let register_property_remove_hook = Remove_hook.extend
let remove ppt =
- Kernel.debug ~dkey:Kernel.dkey_prop_status_reg "REMOVING %a in %a"
+ Kernel.debug ~dkey:Kernel.dkey_prop_status_reg "REMOVING %a in %a"
Property.pretty ppt
Project.pretty (Project.current ());
remove_when_used_as_hypothesis ppt;
@@ -601,7 +601,7 @@ let remove ppt =
let merge ~old l =
let dkey = Kernel.dkey_prop_status_merge in
- let property_id fmt p =
+ let property_id fmt p =
Format.fprintf fmt "%a(%d)" Property.pretty p (Property.hash p)
in
Kernel.feedback ~dkey
@@ -611,23 +611,23 @@ let merge ~old l =
let old_h = Property.Hashtbl.create 17 in
List.iter
(fun p ->
- if not (Status.mem p) then
- Kernel.fatal "Unknown property %a" property_id p;
- Property.Hashtbl.add old_h p ())
+ if not (Status.mem p) then
+ Kernel.fatal "Unknown property %a" property_id p;
+ Property.Hashtbl.add old_h p ())
old;
- List.iter
- (fun p ->
- if Property.Hashtbl.mem old_h p then begin
- (* [p] belongs to both lists *)
- Kernel.feedback ~dkey "UNCHANGED %a" Property.pretty p;
- Property.Hashtbl.remove old_h p;
- (* if [p] was a logical consequence, its dependencies may change *)
- register_as_kernel_logical_consequence p
- end else begin
- (* [p] belongs only to the new list *)
- Kernel.feedback ~dkey "ADD %a" Property.pretty p;
- register p
- end)
+ List.iter
+ (fun p ->
+ if Property.Hashtbl.mem old_h p then begin
+ (* [p] belongs to both lists *)
+ Kernel.feedback ~dkey "UNCHANGED %a" Property.pretty p;
+ Property.Hashtbl.remove old_h p;
+ (* if [p] was a logical consequence, its dependencies may change *)
+ register_as_kernel_logical_consequence p
+ end else begin
+ (* [p] belongs only to the new list *)
+ Kernel.feedback ~dkey "ADD %a" Property.pretty p;
+ register p
+ end)
l;
(* remove the properties which are not in the new list *)
Property.Hashtbl.iter
@@ -646,32 +646,32 @@ let conjunction s1 s2 = match s1, s2 with
let is_not_verifiable_but_valid ppt status = match status with
| Never_tried ->
(match ppt with
- | Property.IPOther _ ->
- (* Non-ACSL properties are not verifiable *)
- false
- | Property.IPReachable _ -> false
- | Property.IPAxiom _ | Property.IPAxiomatic _ -> true
- | _ ->
- match Property.get_kf ppt with
- | None -> false
- | Some kf ->
- (* cannot use module [Kernel_function] nor [Globals] here *)
- let f = kf.Cil_types.fundec in
- if Ast_info.Function.is_definition f then
- false
- else
- (* postconditions of functions without code are not verifiable *)
- let open Property in match ppt with
- | IPPredicate {ip_kind = PKEnsures _ | PKTerminates}
- | IPAssigns _ | IPAllocation _
- | IPFrom _ -> true
- | _ -> false)
+ | Property.IPOther _ ->
+ (* Non-ACSL properties are not verifiable *)
+ false
+ | Property.IPReachable _ -> false
+ | Property.IPAxiom _ | Property.IPAxiomatic _ -> true
+ | _ ->
+ match Property.get_kf ppt with
+ | None -> false
+ | Some kf ->
+ (* cannot use module [Kernel_function] nor [Globals] here *)
+ let f = kf.Cil_types.fundec in
+ if Ast_info.Function.is_definition f then
+ false
+ else
+ (* postconditions of functions without code are not verifiable *)
+ let open Property in match ppt with
+ | IPPredicate {ip_kind = PKEnsures _ | PKTerminates}
+ | IPAssigns _ | IPAllocation _
+ | IPFrom _ -> true
+ | _ -> false)
| Best((True | False_if_reachable | False_and_reachable | Dont_know), _)
| Inconsistent _ ->
false
-let rec compute_automatic_status _e properties =
- let local_get p =
+let rec compute_automatic_status _e properties =
+ let local_get p =
let status = get_status p in
let emitted_status = match status with
| Never_tried | Inconsistent _ -> Dont_know
@@ -681,80 +681,80 @@ let rec compute_automatic_status _e properties =
in
List.fold_left (fun s p -> conjunction s (local_get p)) True properties
-and get_status ?(must_register=true) ppt =
+and get_status ?(must_register=true) ppt =
try
let by_emitter = Status.find ppt in
- Emitter_with_properties.Hashtbl.fold
- (fun e s acc ->
- let s, tried =
- if e.logical_consequence && Emitted_status.equal s Dont_know then
- let ppts =
- List.filter
- (function Property.IPReachable _ -> false | _ -> true)
- e.properties
- in
- let new_s = compute_automatic_status e ppts in
- match new_s with
- | True | False_if_reachable | False_and_reachable ->
- (* the status is now known: register it *)
- Emitter_with_properties.Hashtbl.replace by_emitter e new_s;
- new_s, true
- | Dont_know ->
- (* no change *)
- new_s,
- (* there is a status for this logical consequence iff
- there is a status for one of its hypotheses *)
- List.exists (fun p -> get_status p <> Never_tried) ppts
- else
- s, true
- in
- if tried then strengthen e s acc else acc)
- by_emitter
+ Emitter_with_properties.Hashtbl.fold
+ (fun e s acc ->
+ let s, tried =
+ if e.logical_consequence && Emitted_status.equal s Dont_know then
+ let ppts =
+ List.filter
+ (function Property.IPReachable _ -> false | _ -> true)
+ e.properties
+ in
+ let new_s = compute_automatic_status e ppts in
+ match new_s with
+ | True | False_if_reachable | False_and_reachable ->
+ (* the status is now known: register it *)
+ Emitter_with_properties.Hashtbl.replace by_emitter e new_s;
+ new_s, true
+ | Dont_know ->
+ (* no change *)
+ new_s,
+ (* there is a status for this logical consequence iff
+ there is a status for one of its hypotheses *)
+ List.exists (fun p -> get_status p <> Never_tried) ppts
+ else
+ s, true
+ in
+ if tried then strengthen e s acc else acc)
+ by_emitter
Never_tried
with Not_found ->
- (* assume that all ACSL properties are registered, except non-ACSL ones *)
- match ppt with
- | Property.IPOther _ | Property.IPReachable _
- | Property.IPPropertyInstance _ ->
- if must_register then begin
- register ppt;
- if is_kernel_logical_consequence ppt then get_status ppt
- else Never_tried
- end else
- Never_tried
- | Property.IPBehavior _
- | Property.IPExtended _
- | Property.IPPredicate _ | Property.IPCodeAnnot _ | Property.IPComplete _
- | Property.IPDisjoint _ | Property.IPAssigns _ | Property.IPFrom _
- | Property.IPDecrease _ | Property.IPAllocation _
- | Property.IPAxiom _ | Property.IPAxiomatic _ | Property.IPLemma _
- | Property.IPTypeInvariant _ | Property.IPGlobalInvariant _ ->
- Kernel.fatal "trying to get status of unregistered property `%a'.\n\
-That is forbidden (kernel invariant broken)."
- Property.pretty ppt
+ (* assume that all ACSL properties are registered, except non-ACSL ones *)
+ match ppt with
+ | Property.IPOther _ | Property.IPReachable _
+ | Property.IPPropertyInstance _ ->
+ if must_register then begin
+ register ppt;
+ if is_kernel_logical_consequence ppt then get_status ppt
+ else Never_tried
+ end else
+ Never_tried
+ | Property.IPBehavior _
+ | Property.IPExtended _
+ | Property.IPPredicate _ | Property.IPCodeAnnot _ | Property.IPComplete _
+ | Property.IPDisjoint _ | Property.IPAssigns _ | Property.IPFrom _
+ | Property.IPDecrease _ | Property.IPAllocation _
+ | Property.IPAxiom _ | Property.IPAxiomatic _ | Property.IPLemma _
+ | Property.IPTypeInvariant _ | Property.IPGlobalInvariant _ ->
+ Kernel.fatal "trying to get status of unregistered property `%a'.\n\
+ That is forbidden (kernel invariant broken)."
+ Property.pretty ppt
(* local alias: too much local definitions of get implies name clashes *)
let get ppt = get_status ppt
let automatically_proven ppt =
- is_kernel_logical_consequence ppt
+ is_kernel_logical_consequence ppt
&&
- (* nobody else tried to prove it *)
+ (* nobody else tried to prove it *)
+ try
+ let by_emitter = Status.find ppt in
try
- let by_emitter = Status.find ppt in
- try
- Emitter_with_properties.Hashtbl.iter
- (fun e _ ->
- if not (Emitter.equal
- (Emitter.Usable_emitter.get e.emitter)
- Emitter.kernel)
- then raise Exit)
- by_emitter;
- true
- with Exit ->
- false
- with Not_found ->
+ Emitter_with_properties.Hashtbl.iter
+ (fun e _ ->
+ if not (Emitter.equal
+ (Emitter.Usable_emitter.get e.emitter)
+ Emitter.kernel)
+ then raise Exit)
+ by_emitter;
true
+ with Exit ->
+ false
+ with Not_found ->
+ true
(**************************************************************************)
@@ -764,7 +764,7 @@ let automatically_proven ppt =
module Consolidation = struct
type pending =
- Property.Set.t Usable_emitter.Map.t Usable_emitter.Map.t
+ Property.Set.t Usable_emitter.Map.t Usable_emitter.Map.t
type consolidated_status =
| Never_tried
@@ -780,76 +780,76 @@ module Consolidation = struct
| Inconsistent of string
module D = Datatype.Make
- (struct
- type t = consolidated_status
- include Datatype.Serializable_undefined
- let name = "Property_status.consolidated_status"
- let reprs =
- [ Never_tried;
- Considered_valid;
- Valid Usable_emitter.Set.empty;
- Valid_under_hyp Usable_emitter.Map.empty;
- Unknown Usable_emitter.Map.empty;
- Invalid Usable_emitter.Set.empty;
- Invalid_under_hyp Usable_emitter.Map.empty;
- Invalid_but_dead Usable_emitter.Map.empty;
- Valid_but_dead Usable_emitter.Map.empty;
- Unknown_but_dead Usable_emitter.Map.empty;
- Inconsistent "" ]
-
- let mem_project = Datatype.never_any_project
- let pretty fmt s =
- let pp_emitters f fmt l =
- Pretty_utils.pp_list ~sep:",@ " ~last:" and " f fmt l
- in
- match s with
- | Never_tried -> Format.fprintf fmt "no verification attempted"
- | Considered_valid ->
- Format.fprintf fmt
- "unverifiable but considered %a; requires external review"
- Emitted_status.pretty Emitted.True
- | Valid set | Invalid set ->
- Format.fprintf fmt "@[%a according to %a@]"
- Emitted_status.pretty
- (match s with
- | Valid _ -> Emitted.True
- | Invalid _ -> Emitted.False_and_reachable
- | _ -> assert false)
- (pp_emitters Usable_emitter.pretty)
- (Usable_emitter.Set.elements set)
- | Valid_under_hyp map | Invalid_under_hyp map ->
- let l = Usable_emitter.Map.fold (fun e _ acc -> e :: acc) map [] in
- Format.fprintf fmt "@[%a@ @[(%a according to %a, but properties \
-remain to be verified)@]@]"
- Emitted_status.pretty Emitted.Dont_know
- Emitted_status.pretty
- (match s with
- | Valid_under_hyp _ -> Emitted.True
- | Invalid_under_hyp _ -> Emitted.False_and_reachable
- | _ -> assert false)
- (pp_emitters Usable_emitter.pretty) l
- | Unknown map ->
- let l = Usable_emitter.Map.fold (fun e _ acc -> e :: acc) map [] in
- Format.fprintf fmt "@[%a@ @[(tried by %a)@]@]"
- Emitted_status.pretty Emitted.Dont_know
- (pp_emitters Usable_emitter.pretty) l
- | Valid_but_dead map
- | Invalid_but_dead map
- | Unknown_but_dead map ->
- let l = Usable_emitter.Map.fold (fun e _ acc -> e :: acc) map [] in
- Format.fprintf fmt "@[%a according to %a, but dead anyway@]"
- Emitted_status.pretty
- (match s with
- | Valid_but_dead _ -> Emitted.True
- | Invalid_but_dead _ -> Emitted.False_and_reachable
- | Unknown_but_dead _ -> Emitted.Dont_know
- | _ -> assert false)
- (pp_emitters Usable_emitter.pretty) l
- | Inconsistent msg ->
- Format.fprintf fmt "inconsistency detected:\n%s.\n\
-Check your axiomatics and implicit hypotheses."
- msg
- end)
+ (struct
+ type t = consolidated_status
+ include Datatype.Serializable_undefined
+ let name = "Property_status.consolidated_status"
+ let reprs =
+ [ Never_tried;
+ Considered_valid;
+ Valid Usable_emitter.Set.empty;
+ Valid_under_hyp Usable_emitter.Map.empty;
+ Unknown Usable_emitter.Map.empty;
+ Invalid Usable_emitter.Set.empty;
+ Invalid_under_hyp Usable_emitter.Map.empty;
+ Invalid_but_dead Usable_emitter.Map.empty;
+ Valid_but_dead Usable_emitter.Map.empty;
+ Unknown_but_dead Usable_emitter.Map.empty;
+ Inconsistent "" ]
+
+ let mem_project = Datatype.never_any_project
+ let pretty fmt s =
+ let pp_emitters f fmt l =
+ Pretty_utils.pp_list ~sep:",@ " ~last:" and " f fmt l
+ in
+ match s with
+ | Never_tried -> Format.fprintf fmt "no verification attempted"
+ | Considered_valid ->
+ Format.fprintf fmt
+ "unverifiable but considered %a; requires external review"
+ Emitted_status.pretty Emitted.True
+ | Valid set | Invalid set ->
+ Format.fprintf fmt "@[%a according to %a@]"
+ Emitted_status.pretty
+ (match s with
+ | Valid _ -> Emitted.True
+ | Invalid _ -> Emitted.False_and_reachable
+ | _ -> assert false)
+ (pp_emitters Usable_emitter.pretty)
+ (Usable_emitter.Set.elements set)
+ | Valid_under_hyp map | Invalid_under_hyp map ->
+ let l = Usable_emitter.Map.fold (fun e _ acc -> e :: acc) map [] in
+ Format.fprintf fmt "@[%a@ @[(%a according to %a, but properties \
+ remain to be verified)@]@]"
+ Emitted_status.pretty Emitted.Dont_know
+ Emitted_status.pretty
+ (match s with
+ | Valid_under_hyp _ -> Emitted.True
+ | Invalid_under_hyp _ -> Emitted.False_and_reachable
+ | _ -> assert false)
+ (pp_emitters Usable_emitter.pretty) l
+ | Unknown map ->
+ let l = Usable_emitter.Map.fold (fun e _ acc -> e :: acc) map [] in
+ Format.fprintf fmt "@[%a@ @[(tried by %a)@]@]"
+ Emitted_status.pretty Emitted.Dont_know
+ (pp_emitters Usable_emitter.pretty) l
+ | Valid_but_dead map
+ | Invalid_but_dead map
+ | Unknown_but_dead map ->
+ let l = Usable_emitter.Map.fold (fun e _ acc -> e :: acc) map [] in
+ Format.fprintf fmt "@[%a according to %a, but dead anyway@]"
+ Emitted_status.pretty
+ (match s with
+ | Valid_but_dead _ -> Emitted.True
+ | Invalid_but_dead _ -> Emitted.False_and_reachable
+ | Unknown_but_dead _ -> Emitted.Dont_know
+ | _ -> assert false)
+ (pp_emitters Usable_emitter.pretty) l
+ | Inconsistent msg ->
+ Format.fprintf fmt "inconsistency detected:\n%s.\n\
+ Check your axiomatics and implicit hypotheses."
+ msg
+ end)
include D
module Consolidated_status =
@@ -857,10 +857,10 @@ Check your axiomatics and implicit hypotheses."
(Property.Hashtbl)
(D)
(struct
- let name = "Property_status.Consolidated_status"
- let dependencies = [ Status.self ]
- let size = 97
- end)
+ let name = "Property_status.Consolidated_status"
+ let dependencies = [ Status.self ]
+ let size = 97
+ end)
let merge_property e ppt map =
try
@@ -879,17 +879,17 @@ Check your axiomatics and implicit hypotheses."
let flatten_map init map =
Usable_emitter.Map.fold
- (fun _ -> Usable_emitter.Map.fold merge_properties)
- map
+ (fun _ -> Usable_emitter.Map.fold merge_properties)
+ map
init
- let flatten_set init h set =
+ let flatten_set init h set =
Usable_emitter.Set.fold (fun e map -> merge_property e h map) set init
let reduce_hypothesis_status ppt = function
| Never_tried | Inconsistent _ ->
- let singleton_map v =
- Usable_emitter.Map.singleton usable_kernel_emitter v
+ let singleton_map v =
+ Usable_emitter.Map.singleton usable_kernel_emitter v
in
Unknown (singleton_map (singleton_map (Property.Set.singleton ppt)))
| Invalid_under_hyp m -> Unknown m
@@ -897,11 +897,11 @@ Check your axiomatics and implicit hypotheses."
| Valid _ -> Valid Emitter.Usable_emitter.Set.empty
| Invalid_but_dead m
| Valid_but_dead m
- | Unknown_but_dead m ->
+ | Unknown_but_dead m ->
(* Must keep where are invalidities, thus keep the map.
- But anyway, each of these three "dead" status are consolidated in the
- same way *)
- Valid_but_dead m
+ But anyway, each of these three "dead" status are consolidated in the
+ same way *)
+ Valid_but_dead m
| Valid_under_hyp m
| Unknown m -> Unknown m
| Invalid _ as s -> s
@@ -911,15 +911,15 @@ Check your axiomatics and implicit hypotheses."
e is the emitter of s2 for property h
issues are the issues already computed
compute:
- - consolidated status of (h1 /\ h2)
+ - consolidated status of (h1 /\ h2)
- where are the issues and who finds them *)
let hypotheses_conjunction issues h s1 s2 = match s1, s2 with
(* order of patterns does matter *)
| _, Never_tried
| Considered_valid, _ | _, Considered_valid
| Valid_under_hyp _, _ | _, Valid_under_hyp _
- | Inconsistent _, _ | _, Inconsistent _
- | Invalid_under_hyp _, _ | _, Invalid_under_hyp _
+ | Inconsistent _, _ | _, Inconsistent _
+ | Invalid_under_hyp _, _ | _, Invalid_under_hyp _
| Invalid_but_dead _, _ | _, Invalid_but_dead _
| Unknown_but_dead _, _ | _, Unknown_but_dead _ ->
(* handle at callsite *)
@@ -932,28 +932,28 @@ Check your axiomatics and implicit hypotheses."
(* first status encountered: no issue with the first hypothesis *)
assert (Usable_emitter.Map.is_empty issues);
Valid Usable_emitter.Set.empty, issues
- | Invalid set1, Invalid set2 ->
+ | Invalid set1, Invalid set2 ->
assert (Usable_emitter.Set.is_empty set1);
Invalid Usable_emitter.Set.empty, flatten_set issues h set2
- | _, Invalid set ->
- Invalid Usable_emitter.Set.empty,
+ | _, Invalid set ->
+ Invalid Usable_emitter.Set.empty,
flatten_set Usable_emitter.Map.empty h set
- | Invalid set, _ ->
+ | Invalid set, _ ->
assert (Usable_emitter.Set.is_empty set);
Invalid Usable_emitter.Set.empty, issues
| Unknown m1, Unknown m2 ->
assert (Usable_emitter.Map.is_empty m1);
Unknown Usable_emitter.Map.empty, flatten_map issues m2
- | Unknown m, (Valid _ | Valid_but_dead _)
- | (Valid _ | Valid_but_dead _), Unknown m ->
- Unknown Usable_emitter.Map.empty,
+ | Unknown m, (Valid _ | Valid_but_dead _)
+ | (Valid _ | Valid_but_dead _), Unknown m ->
+ Unknown Usable_emitter.Map.empty,
flatten_map issues m
- | (Valid _ | Valid_but_dead _), (Valid _ | Valid_but_dead _) ->
+ | (Valid _ | Valid_but_dead _), (Valid _ | Valid_but_dead _) ->
assert (Usable_emitter.Map.is_empty issues);
Valid Usable_emitter.Set.empty, issues
(* compute the best status [s] and add the emitter [e] if it computes [s] *)
- let choose_best_emitter old_status e (status, issues) =
+ let choose_best_emitter old_status e (status, issues) =
match old_status, status with
| _, Never_tried
| Considered_valid, _ | _, Considered_valid
@@ -961,35 +961,35 @@ Check your axiomatics and implicit hypotheses."
| Invalid_under_hyp _, _ | _, Invalid_under_hyp _
| Valid_but_dead _, _ | _, Valid_but_dead _
| Unknown_but_dead _, _ | _, Unknown_but_dead _
- | Inconsistent _, _ | _, Inconsistent _
+ | Inconsistent _, _ | _, Inconsistent _
| Invalid _, _ (* the current best status cannot be invalid, but
- invalid_but_dead instead *)
+ invalid_but_dead instead *)
| _, Invalid_but_dead _ (* the last computed status cannot be
- invalid_but_dead, but invalid instead *)
- ->
+ invalid_but_dead, but invalid instead *)
+ ->
Kernel.fatal "@[[Property_status] invariant of consolidation broken:@ \
-either status %a or %a not allowed when choosing the best emitter@]"
- pretty old_status
- pretty status
+ either status %a or %a not allowed when choosing the best emitter@]"
+ pretty old_status
+ pretty status
(* first status encountered: keep it *)
| Never_tried, Valid _ -> Valid (Usable_emitter.Set.singleton e)
- | Never_tried, Invalid _ ->
+ | Never_tried, Invalid _ ->
Invalid_but_dead (Usable_emitter.Map.singleton e issues)
| Never_tried, Unknown _ -> Unknown (Usable_emitter.Map.singleton e issues)
(* the old computed status remains the best one *)
- | (Valid _ | Invalid_but_dead _), Unknown _ ->
+ | (Valid _ | Invalid_but_dead _), Unknown _ ->
old_status
(* [e] is the best *)
| Unknown _, Valid _ -> Valid (Usable_emitter.Set.singleton e)
- | Unknown _, Invalid _ ->
+ | Unknown _, Invalid _ ->
Invalid_but_dead (Usable_emitter.Map.singleton e issues)
(* [e] is as good as the previous best emitter *)
| Valid set, Valid _ -> Valid (Usable_emitter.Set.add e set)
- | Invalid_but_dead m, Invalid _ ->
+ | Invalid_but_dead m, Invalid _ ->
Invalid_but_dead (Usable_emitter.Map.add e issues m)
| Unknown m, Unknown _ -> Unknown (Usable_emitter.Map.add e issues m)
@@ -997,39 +997,39 @@ either status %a or %a not allowed when choosing the best emitter@]"
| Invalid_but_dead m, Valid _ ->
assert (Usable_emitter.Map.is_empty issues);
Inconsistent
- (let l = Usable_emitter.Map.fold (fun e _ acc -> e :: acc) m [] in
- Format.asprintf
- "@[Valid for: %a (at least).@\n\
-Invalid for: %a.@]"
- Usable_emitter.pretty e
- (Pretty_utils.pp_list ~sep:", " ~last:" and " Usable_emitter.pretty)
- l)
+ (let l = Usable_emitter.Map.fold (fun e _ acc -> e :: acc) m [] in
+ Format.asprintf
+ "@[Valid for: %a (at least).@\n\
+ Invalid for: %a.@]"
+ Usable_emitter.pretty e
+ (Pretty_utils.pp_list ~sep:", " ~last:" and " Usable_emitter.pretty)
+ l)
| Valid set, Invalid _ ->
Inconsistent
- (let l = Usable_emitter.Set.elements set in
- Format.asprintf
- "@[Valid for: %a.@\n\
-Invalid for: %a (at least).@]"
- (Pretty_utils.pp_list ~sep:", " ~last:" and " Usable_emitter.pretty)
- l
- Usable_emitter.pretty
- e)
-
- let mk_issue e ppt =
- Usable_emitter.Map.singleton e (Property.Set.singleton ppt)
-
- let issues_without_emitter issues =
+ (let l = Usable_emitter.Set.elements set in
+ Format.asprintf
+ "@[Valid for: %a.@\n\
+ Invalid for: %a (at least).@]"
+ (Pretty_utils.pp_list ~sep:", " ~last:" and " Usable_emitter.pretty)
+ l
+ Usable_emitter.pretty
+ e)
+
+ let mk_issue e ppt =
+ Usable_emitter.Map.singleton e (Property.Set.singleton ppt)
+
+ let issues_without_emitter issues =
Usable_emitter.Map.fold
- (fun _ -> Usable_emitter.Map.fold Usable_emitter.Map.add)
+ (fun _ -> Usable_emitter.Map.fold Usable_emitter.Map.add)
issues
Usable_emitter.Map.empty
let local_hyp_issues emitters ppt issues =
let m = issues_without_emitter issues in
List.fold_left
- (fun acc ep ->
- let e = ep.emitter in
- Usable_emitter.Map.add e (merge_property e ppt m) acc)
+ (fun acc ep ->
+ let e = ep.emitter in
+ Usable_emitter.Map.add e (merge_property e ppt m) acc)
Usable_emitter.Map.empty
emitters
@@ -1037,7 +1037,7 @@ Invalid for: %a (at least).@]"
match hyps_status, local_status with
(* impossible cases: handle at callsite *)
- | Never_tried, _
+ | Never_tried, _
| Considered_valid, _
| Valid_under_hyp _, _
| Invalid_under_hyp _, _
@@ -1046,58 +1046,58 @@ Invalid for: %a (at least).@]"
| Invalid _, _
| _, Local.Never_tried ->
Kernel.fatal "@[[Property_status] invariant of consolidation broken:@ \
-either status %a or %a not allowed when merging status@]"
- pretty hyps_status
- L.pretty local_status
+ either status %a or %a not allowed when merging status@]"
+ pretty hyps_status
+ L.pretty local_status
(* status of hypotheses = valid;
filter emitters by the one for which hypotheses are valid *)
- | Valid set, Best(Emitted.Dont_know, _) ->
+ | Valid set, Best(Emitted.Dont_know, _) ->
let mk e = mk_issue e ppt in
- let map =
- Usable_emitter.Set.fold
- (fun e -> Usable_emitter.Map.add e (mk e))
- set
- Usable_emitter.Map.empty
+ let map =
+ Usable_emitter.Set.fold
+ (fun e -> Usable_emitter.Map.add e (mk e))
+ set
+ Usable_emitter.Map.empty
in
Unknown map
| Valid _, Best(Emitted.True, _) ->
hyps_status
- | Valid set,
+ | Valid set,
Best((Emitted.False_and_reachable | Emitted.False_if_reachable), _) ->
Invalid set
| Valid set, (Local.Inconsistent i as s) ->
- let mk =
- let internal_map =
- Usable_emitter.Map.singleton
- usable_kernel_emitter
- (Property.Set.singleton ppt)
- in
- List.fold_left
- (fun acc ep ->
- let e = ep.emitter in
- if Usable_emitter.Set.mem e set then
- Usable_emitter.Map.add e internal_map acc
- else
- acc)
- Usable_emitter.Map.empty
+ let mk =
+ let internal_map =
+ Usable_emitter.Map.singleton
+ usable_kernel_emitter
+ (Property.Set.singleton ppt)
+ in
+ List.fold_left
+ (fun acc ep ->
+ let e = ep.emitter in
+ if Usable_emitter.Set.mem e set then
+ Usable_emitter.Map.add e internal_map acc
+ else
+ acc)
+ Usable_emitter.Map.empty
in
let valid_map = mk i.valid in
let invalid_map = mk i.invalid in
(* something strange locally appears: the only way that there is no
- global inconsistency if that this program point is actually dead *)
+ global inconsistency if that this program point is actually dead *)
if Usable_emitter.Map.is_empty valid_map then begin
- assert (not (Usable_emitter.Map.is_empty invalid_map));
- Invalid_but_dead invalid_map
+ assert (not (Usable_emitter.Map.is_empty invalid_map));
+ Invalid_but_dead invalid_map
end else
- if Usable_emitter.Map.is_empty invalid_map then Valid_but_dead valid_map
- else Inconsistent (Format.asprintf "%a" L.pretty s)
+ if Usable_emitter.Map.is_empty invalid_map then Valid_but_dead valid_map
+ else Inconsistent (Format.asprintf "%a" L.pretty s)
(* status of hypotheses = invalid (encoded by invalid_but_dead) *)
- | Invalid_but_dead m,
- Best((Emitted.False_and_reachable | Emitted.False_if_reachable), _) ->
+ | Invalid_but_dead m,
+ Best((Emitted.False_and_reachable | Emitted.False_if_reachable), _) ->
Invalid_but_dead m
- | Invalid_but_dead m, Best(Emitted.True, _) ->
+ | Invalid_but_dead m, Best(Emitted.True, _) ->
Valid_but_dead m
| Invalid_but_dead m, (Best(Emitted.Dont_know, _) | Local.Inconsistent _) ->
Unknown_but_dead m
@@ -1105,8 +1105,8 @@ either status %a or %a not allowed when merging status@]"
(* status of hypotheses = dont_know *)
| Unknown m, Best(Emitted.True, _) ->
Valid_under_hyp m
- | Unknown m, Best((Emitted.False_if_reachable
- | Emitted.False_and_reachable), _) ->
+ | Unknown m, Best((Emitted.False_if_reachable
+ | Emitted.False_and_reachable), _) ->
Invalid_under_hyp m
| Unknown m, Best(Emitted.Dont_know, emitters) ->
Unknown (local_hyp_issues emitters ppt m)
@@ -1120,176 +1120,176 @@ either status %a or %a not allowed when merging status@]"
(* convert a local status into a consolidated one,
but ignore hypotheses *)
- let consolidate_of_local_when_cycle ppt =
+ let consolidate_of_local_when_cycle ppt =
match get_status ~must_register:false ppt with
| Local.Never_tried -> Never_tried
| Best(True, _) -> Considered_valid
- | Best((False_if_reachable | False_and_reachable), _) ->
+ | Best((False_if_reachable | False_and_reachable), _) ->
(* no cycle is possible *)
Kernel.fatal "invalid cycle for invalid property %a" Property.pretty ppt
- | Best(Dont_know, _) | Local.Inconsistent _ ->
- Unknown
- (Emitter.Usable_emitter.Map.singleton
- usable_kernel_emitter
- (Emitter.Usable_emitter.Map.singleton
- usable_kernel_emitter
- (Property.Set.singleton ppt)))
-
- let consolidate_reachable ppt =
+ | Best(Dont_know, _) | Local.Inconsistent _ ->
+ Unknown
+ (Emitter.Usable_emitter.Map.singleton
+ usable_kernel_emitter
+ (Emitter.Usable_emitter.Map.singleton
+ usable_kernel_emitter
+ (Property.Set.singleton ppt)))
+
+ let consolidate_reachable ppt =
match ppt with
| Property.IPReachable _ -> ()
| _ ->
let reach_ppt = Property.ip_reachable_ppt ppt in
match get_status ~must_register:false reach_ppt with
- | Best(False_and_reachable, _) ->
- (* someone proves unreachability of [ppt] *)
- (try
- let by_emitter = Status.find ppt in
- (* someone emits a status for [ppt]: add (reachable ppt) to
- hypotheses of [ppt] if that is not already the case *)
- Emitter_with_properties.Hashtbl.iter
- (fun e _ ->
- if List.for_all
- (fun p -> not (Property.equal p reach_ppt))
- e.properties
- then
- e.properties <- reach_ppt :: e.properties)
- by_emitter
- with Not_found ->
- (* no-one emits a status for [ppt]: add an unknown status *)
- ())
+ | Best(False_and_reachable, _) ->
+ (* someone proves unreachability of [ppt] *)
+ (try
+ let by_emitter = Status.find ppt in
+ (* someone emits a status for [ppt]: add (reachable ppt) to
+ hypotheses of [ppt] if that is not already the case *)
+ Emitter_with_properties.Hashtbl.iter
+ (fun e _ ->
+ if List.for_all
+ (fun p -> not (Property.equal p reach_ppt))
+ e.properties
+ then
+ e.properties <- reach_ppt :: e.properties)
+ by_emitter
+ with Not_found ->
+ (* no-one emits a status for [ppt]: add an unknown status *)
+ ())
| Local.Never_tried
| Local.Best((True | Dont_know), _)
- | Local.Inconsistent _ ->
- ()
- | Local.Best(False_if_reachable, _) ->
- assert false
+ | Local.Inconsistent _ ->
+ ()
+ | Local.Best(False_if_reachable, _) ->
+ assert false
let consolidate ppt compute_deps_status =
let dkey = Kernel.dkey_prop_status_merge in
consolidate_reachable ppt;
let local_status = get ppt in
- if is_not_verifiable_but_valid ppt local_status then
+ if is_not_verifiable_but_valid ppt local_status then
Considered_valid
else
match local_status with
| Local.Never_tried -> Never_tried
- | Best(_, l) as local ->
- let status = compute_deps_status l in
- Kernel.feedback ~dkey "status of hypotheses of %a: %a"
- Property.pretty ppt
- pretty status;
- let s = merge_hypotheses_and_local_status ppt status local in
- Kernel.feedback ~dkey "consolidated status of %a: %a"
- Property.pretty ppt
- pretty s;
- s
- | Local.Inconsistent { valid = valid; invalid = invalid } as local ->
- let hyps_status = compute_deps_status (valid @ invalid) in
- merge_hypotheses_and_local_status ppt hyps_status local
+ | Best(_, l) as local ->
+ let status = compute_deps_status l in
+ Kernel.feedback ~dkey "status of hypotheses of %a: %a"
+ Property.pretty ppt
+ pretty status;
+ let s = merge_hypotheses_and_local_status ppt status local in
+ Kernel.feedback ~dkey "consolidated status of %a: %a"
+ Property.pretty ppt
+ pretty s;
+ s
+ | Local.Inconsistent { valid = valid; invalid = invalid } as local ->
+ let hyps_status = compute_deps_status (valid @ invalid) in
+ merge_hypotheses_and_local_status ppt hyps_status local
type emitter =
| Not_yet
| Single of Usable_emitter.t
| Several
-
+
let rec memo_consolidated e path ppt =
Consolidated_status.memo
(fun ppt ->
- if Property.Hashtbl.mem visited_ppt ppt then begin
- consolidate_of_local_when_cycle ppt
-(* [JS 2011/11/04] use the following code (to be tested) as soon as WP uses the
- new function [legal_dependency_cycle] *)
-(* match e with
- | Not_yet -> assert false
- | Single e ->
- if Valid_cycles.mem e path then
- consolidate_of_local_when_cycle ppt
- else
- Kernel.fatal
- "illegal dependency cycle for emitter %a"
- Usable_emitter.pretty e
- | Several ->
- (* cycle because the proof of [ppt] with emitter [E1] depends
- on another [ppt'] which is proven with another emitter [E2]
- by using [ppt] itself: it is not inconsistent by itself, but we
- cannot use it as a proof. *)
- consolidate ppt
- (fun _ ->
- Unknown
- (Usable_emitter.Map.add
- usable_kernel_emitter
- (Usable_emitter.Map.add
- usable_kernel_emitter
- (List.fold_left
- (fun acc p -> Property.Set.add p acc)
- Property.Set.empty
- path)
- Usable_emitter.Map.empty)
- Usable_emitter.Map.empty))*)
- end else begin
- Property.Hashtbl.add visited_ppt ppt ();
- consolidate ppt (consolidated_emitters ppt e (ppt :: path))
-(* [JS 2011/11/04] think about that when uncommenting the code above *)
-(* try
- (* was previously added during its own calculus
- in case of inconsistent mutual dependency *)
- Consolidated_status.find ppt
- with Not_found ->*)
-(* consolidated_status*)
- end)
+ if Property.Hashtbl.mem visited_ppt ppt then begin
+ consolidate_of_local_when_cycle ppt
+ (* [JS 2011/11/04] use the following code (to be tested) as soon as WP uses the
+ new function [legal_dependency_cycle] *)
+ (* match e with
+ | Not_yet -> assert false
+ | Single e ->
+ if Valid_cycles.mem e path then
+ consolidate_of_local_when_cycle ppt
+ else
+ Kernel.fatal
+ "illegal dependency cycle for emitter %a"
+ Usable_emitter.pretty e
+ | Several ->
+ (* cycle because the proof of [ppt] with emitter [E1] depends
+ on another [ppt'] which is proven with another emitter [E2]
+ by using [ppt] itself: it is not inconsistent by itself, but we
+ cannot use it as a proof. *)
+ consolidate ppt
+ (fun _ ->
+ Unknown
+ (Usable_emitter.Map.add
+ usable_kernel_emitter
+ (Usable_emitter.Map.add
+ usable_kernel_emitter
+ (List.fold_left
+ (fun acc p -> Property.Set.add p acc)
+ Property.Set.empty
+ path)
+ Usable_emitter.Map.empty)
+ Usable_emitter.Map.empty))*)
+ end else begin
+ Property.Hashtbl.add visited_ppt ppt ();
+ consolidate ppt (consolidated_emitters ppt e (ppt :: path))
+ (* [JS 2011/11/04] think about that when uncommenting the code above *)
+ (* try
+ (* was previously added during its own calculus
+ in case of inconsistent mutual dependency *)
+ Consolidated_status.find ppt
+ with Not_found ->*)
+ (* consolidated_status*)
+ end)
ppt
and consolidated_emitters ppt current_e path l =
let dkey = Kernel.dkey_prop_status_merge in
- (* [l] is the list of the best emitters of the local status of [ppt].
+ (* [l] is the list of the best emitters of the local status of [ppt].
As they emit the same local status, we only choose the best one according
to the status of their hypotheses. *)
- let status =
+ let status =
List.fold_left
- (fun current_status e ->
- let current_e = match current_e with
- | Not_yet -> Single e.emitter
- | Single e' as x when Usable_emitter.equal e.emitter e' -> x
- | Single _ | Several -> Several
- in
- let (s, issues) =
- (* compute the status of conjunction of hypotheses of [e],
- with related issues *)
- List.fold_left
- (fun (status, issues) h ->
- let s = memo_consolidated current_e path h in
- let s = reduce_hypothesis_status h s in
- Kernel.feedback ~dkey "status of hypothesis %a (for %a): %a"
+ (fun current_status e ->
+ let current_e = match current_e with
+ | Not_yet -> Single e.emitter
+ | Single e' as x when Usable_emitter.equal e.emitter e' -> x
+ | Single _ | Several -> Several
+ in
+ let (s, issues) =
+ (* compute the status of conjunction of hypotheses of [e],
+ with related issues *)
+ List.fold_left
+ (fun (status, issues) h ->
+ let s = memo_consolidated current_e path h in
+ let s = reduce_hypothesis_status h s in
+ Kernel.feedback ~dkey "status of hypothesis %a (for %a): %a"
Property.pretty h
- Property.pretty ppt
- pretty s;
- hypotheses_conjunction issues h status s)
- (Never_tried, Usable_emitter.Map.empty)
- e.properties
- in
- let hyps_status = match s with
- | Never_tried ->
- (* if no hypothesis, status of hypotheses must be valid *)
- Valid (Usable_emitter.Set.singleton usable_kernel_emitter)
- | Valid _ | Invalid _ | Unknown _ -> s
- | Considered_valid | Inconsistent _
- | Valid_under_hyp _ | Invalid_under_hyp _
- | Valid_but_dead _ | Invalid_but_dead _ | Unknown_but_dead _ ->
- Kernel.fatal "@[[Property_status] invariant of consolidation \
-broken:@ status %a not allowed when simplifying hypothesis status@]"
- pretty s
-
- in
- let cur =
- choose_best_emitter current_status e.emitter (hyps_status, issues)
- in
- Kernel.feedback ~dkey "status of hypotheses for emitter `%a': %a"
- Usable_emitter.pretty e.emitter pretty s;
- Kernel.feedback ~dkey "current best status: %a" pretty cur;
- cur)
- Never_tried
- l
+ Property.pretty ppt
+ pretty s;
+ hypotheses_conjunction issues h status s)
+ (Never_tried, Usable_emitter.Map.empty)
+ e.properties
+ in
+ let hyps_status = match s with
+ | Never_tried ->
+ (* if no hypothesis, status of hypotheses must be valid *)
+ Valid (Usable_emitter.Set.singleton usable_kernel_emitter)
+ | Valid _ | Invalid _ | Unknown _ -> s
+ | Considered_valid | Inconsistent _
+ | Valid_under_hyp _ | Invalid_under_hyp _
+ | Valid_but_dead _ | Invalid_but_dead _ | Unknown_but_dead _ ->
+ Kernel.fatal "@[[Property_status] invariant of consolidation \
+ broken:@ status %a not allowed when simplifying hypothesis status@]"
+ pretty s
+
+ in
+ let cur =
+ choose_best_emitter current_status e.emitter (hyps_status, issues)
+ in
+ Kernel.feedback ~dkey "status of hypotheses for emitter `%a': %a"
+ Usable_emitter.pretty e.emitter pretty s;
+ Kernel.feedback ~dkey "current best status: %a" pretty cur;
+ cur)
+ Never_tried
+ l
in
match status with
| Never_tried ->
@@ -1297,10 +1297,10 @@ broken:@ status %a not allowed when simplifying hypothesis status@]"
Valid (Usable_emitter.Set.singleton usable_kernel_emitter)
| _ -> status
- let get ppt =
- let s = memo_consolidated Not_yet [] ppt in
- Property.Hashtbl.clear visited_ppt;
- s
+ let get ppt =
+ let s = memo_consolidated Not_yet [] ppt in
+ Property.Hashtbl.clear visited_ppt;
+ s
let get_conjunction ppts =
let tmp =
@@ -1319,7 +1319,7 @@ module Feedback = struct
type t =
| Never_tried
- | Considered_valid
+ | Considered_valid
| Valid
| Valid_under_hyp
| Unknown
@@ -1367,11 +1367,11 @@ end
module Consolidation_graph = struct
- type v =
+ type v =
| Property of Property.t
| Emitter of string
| Tuning_parameter of string
-(* | Correctness_parameter of string*)
+ (* | Correctness_parameter of string*)
module Vertex = struct
@@ -1381,11 +1381,11 @@ module Consolidation_graph = struct
| Property p1, Property p2 -> Property.compare p1 p2
| Emitter s1, Emitter s2 -> String.compare s1 s2
| Tuning_parameter s1, Tuning_parameter s2
-(* | Correctness_parameter s1, Correctness_parameter s2*) ->
- String.compare s1 s2
- | Property _, _
+ (* | Correctness_parameter s1, Correctness_parameter s2*) ->
+ String.compare s1 s2
+ | Property _, _
| Emitter _, (Tuning_parameter _ (*| Correctness_parameter _*))
-(* | Tuning_parameter _, Correctness_parameter _*) -> 1
+ (* | Tuning_parameter _, Correctness_parameter _*) -> 1
| _, _ -> -1
let equal v1 v2 = compare v1 v2 = 0
@@ -1394,15 +1394,15 @@ module Consolidation_graph = struct
| Property p -> Caml_hashtbl.hash (0, Property.hash p)
| Emitter s -> Caml_hashtbl.hash (1, s)
| Tuning_parameter s -> Caml_hashtbl.hash (2, s)
-(* | Correctness_parameter s -> Caml_hashtbl.hash (3, s)*)
+ (* | Correctness_parameter s -> Caml_hashtbl.hash (3, s)*)
end
module Edge = struct
include Datatype.Option_with_collections
- (Emitted_status)
- (struct let module_name = "Property_status.Consolidation_graph.Edge" end)
+ (Emitted_status)
+ (struct let module_name = "Property_status.Consolidation_graph.Edge" end)
let default = None
@@ -1414,19 +1414,19 @@ module Consolidation_graph = struct
State_builder.Hashtbl
(Property.Hashtbl)
(Datatype.Pair
- (Datatype.Make
- (struct
- type t = G.t
- let name = "Property_status.Graph_by_property"
- let reprs = [ G.empty ]
- include Datatype.Serializable_undefined
- end))
- (Datatype.Bool) (* is the graph truncated? *))
+ (Datatype.Make
+ (struct
+ type t = G.t
+ let name = "Property_status.Graph_by_property"
+ let reprs = [ G.empty ]
+ include Datatype.Serializable_undefined
+ end))
+ (Datatype.Bool) (* is the graph truncated? *))
(struct
- let name = "Consolidation graph"
- let size = 97
- let dependencies = [ Consolidation.Consolidated_status.self ]
- end)
+ let name = "Consolidation graph"
+ let size = 97
+ let dependencies = [ Consolidation.Consolidated_status.self ]
+ end)
type t = G.t
@@ -1441,75 +1441,75 @@ module Consolidation_graph = struct
let dkey = Kernel.dkey_prop_status_graph in
let compute ppt =
Kernel.debug ~dkey "BUILDING GRAPH of %a" Property.pretty ppt;
- (* [JS 2011/07/21] Only the better proof is added on the graph. For
- instance, if the consolidated status is valid thanks to WP, it does
- not show the dont_know proof tried by Value. *)
+ (* [JS 2011/07/21] Only the better proof is added on the graph. For
+ instance, if the consolidated status is valid thanks to WP, it does
+ not show the dont_know proof tried by Value. *)
if Property.Hashtbl.mem already_done ppt then
- G.empty, true
+ G.empty, true
else begin
- Kernel.debug ~dkey "MARK %a" Property.pretty ppt;
- Property.Hashtbl.add already_done ppt ();
- let v_ppt = Property ppt in
- (* adding the property *)
- let g = G.add_vertex G.empty v_ppt in
- match get_status ppt with
- | Never_tried -> g, false
- | Best(s, emitters) ->
- get_emitters g v_ppt s emitters
- | Inconsistent i ->
- let g, truncated1 = get_emitters g v_ppt True i.valid in
- let g, truncated2 =
- get_emitters g v_ppt False_and_reachable i.invalid
- in
- g, truncated1 || truncated2
+ Kernel.debug ~dkey "MARK %a" Property.pretty ppt;
+ Property.Hashtbl.add already_done ppt ();
+ let v_ppt = Property ppt in
+ (* adding the property *)
+ let g = G.add_vertex G.empty v_ppt in
+ match get_status ppt with
+ | Never_tried -> g, false
+ | Best(s, emitters) ->
+ get_emitters g v_ppt s emitters
+ | Inconsistent i ->
+ let g, truncated1 = get_emitters g v_ppt True i.valid in
+ let g, truncated2 =
+ get_emitters g v_ppt False_and_reachable i.invalid
+ in
+ g, truncated1 || truncated2
end
in
- let change (_, truncated as data) =
- if truncated then compute ppt else data
+ let change (_, truncated as data) =
+ if truncated then compute ppt else data
in
Graph_by_property.memo ~change compute ppt
and get_emitters g v_ppt s l =
assert (l <> []);
List.fold_left
- (fun (g, b) e ->
- let emitter = e.emitter in
- let v_e = Emitter (Usable_emitter.get_unique_name emitter) in
- (* adding the emitter with its computed status *)
- let g = G.add_edge_e g (v_ppt, Some s, v_e) in
- Kernel.debug ~dkey:Kernel.dkey_prop_status_graph "%a --> %a (%a)"
- Property.pretty (match v_ppt with Property p -> p | _ -> assert false)
- Usable_emitter.pretty emitter
- Emitted_status.pretty s;
- let g =
- (* adding the tuning parameters *)
- Datatype.String.Set.fold
- (fun p g ->
- let s = get_parameter_string ~tuning:true emitter p in
- G.add_edge g v_e (Tuning_parameter s))
- (distinct_tuning_parameters emitter)
- g
- in
-(* let g =
- (* adding the correctness parameters *)
- Datatype.String.Set.fold
- (fun p g ->
- let s = get_parameter_string ~tuning:false emitter p in
- G.add_edge g v_e (Correctness_parameter s); g)
- (distinct_correctness_parameters emitter)
- g
- in*)
- (* adding the hypotheses *)
- let g, truncated =
- List.fold_left
- (fun (g, b) h ->
- let g', truncated = get h in
- let union = G.fold_edges_e (fun e g -> G.add_edge_e g e) g g' in
- G.add_edge union v_ppt (Property h), b || truncated)
- (g, false)
- e.properties
- in
- g, b || truncated)
+ (fun (g, b) e ->
+ let emitter = e.emitter in
+ let v_e = Emitter (Usable_emitter.get_unique_name emitter) in
+ (* adding the emitter with its computed status *)
+ let g = G.add_edge_e g (v_ppt, Some s, v_e) in
+ Kernel.debug ~dkey:Kernel.dkey_prop_status_graph "%a --> %a (%a)"
+ Property.pretty (match v_ppt with Property p -> p | _ -> assert false)
+ Usable_emitter.pretty emitter
+ Emitted_status.pretty s;
+ let g =
+ (* adding the tuning parameters *)
+ Datatype.String.Set.fold
+ (fun p g ->
+ let s = get_parameter_string ~tuning:true emitter p in
+ G.add_edge g v_e (Tuning_parameter s))
+ (distinct_tuning_parameters emitter)
+ g
+ in
+ (* let g =
+ (* adding the correctness parameters *)
+ Datatype.String.Set.fold
+ (fun p g ->
+ let s = get_parameter_string ~tuning:false emitter p in
+ G.add_edge g v_e (Correctness_parameter s); g)
+ (distinct_correctness_parameters emitter)
+ g
+ in*)
+ (* adding the hypotheses *)
+ let g, truncated =
+ List.fold_left
+ (fun (g, b) h ->
+ let g', truncated = get h in
+ let union = G.fold_edges_e (fun e g -> G.add_edge_e g e) g g' in
+ G.add_edge union v_ppt (Property h), b || truncated)
+ (g, false)
+ e.properties
+ in
+ g, b || truncated)
(g, false)
l
@@ -1523,73 +1523,73 @@ module Consolidation_graph = struct
let dump graph formatter =
let module Dot = Graph.Graphviz.Dot
- (struct
+ (struct
- include G
+ include G
- let emitted_status_color = function
- | True -> 0x00ff00 (* green *)
- | False_if_reachable | False_and_reachable -> 0xff0000 (* red *)
- | Dont_know -> 0xffa500 (* orange *)
+ let emitted_status_color = function
+ | True -> 0x00ff00 (* green *)
+ | False_if_reachable | False_and_reachable -> 0xff0000 (* red *)
+ | Dont_know -> 0xffa500 (* orange *)
- let status_color p s =
- if is_not_verifiable_but_valid p s then
- 0x00ff00 (* green *)
- else match s with
- | Never_tried -> 0x0011ff (* dark blue, only for border *)
+ let status_color p s =
+ if is_not_verifiable_but_valid p s then
+ 0x00ff00 (* green *)
+ else match s with
+ | Never_tried -> 0x0011ff (* dark blue, only for border *)
| Best(s, _) -> emitted_status_color s
- | Inconsistent _ -> 0x808080 (* gray *)
-
- let graph_attributes _ = []
-
- let vertex_name v =
- let s = match v with
- | Property p -> Property.Names.get_prop_name_id p
- | Emitter s | Tuning_parameter s (*| Correctness_parameter s*)
- -> s
- in
- Format.asprintf "\"%s\"" s
-
- let label v =
- let s = match v with
- | Property p -> Format.asprintf "%a" Property.pretty p
- | Emitter s | Tuning_parameter s (*| Correctness_parameter s*)
- -> s
- in
- `Label (String.escaped s)
-
- let vertex_attributes = function
- | Property p as v ->
- let s = get_status p in
- let color = status_color p s in
- let style = match s with
- | Never_tried -> [`Style `Bold; `Width 0.8 ]
- | _ -> [`Style `Filled]
- in
- style @ [ label v; `Color color; `Shape `Box ]
- | Emitter _ as v ->
- [ label v; `Shape `Diamond; `Color 0xb0c4de; `Style `Filled ]
- | Tuning_parameter _ as v ->
- [ label v; (*`Style `Dotted;*) `Color 0xb0c4de; ]
- (*| Correctness_parameter _ (*as v*) -> assert false (*[ label v; `Color 0xb0c4de ]*)*)
-
- let edge_attributes e = match E.label e with
- | None -> []
- | Some s ->
- let c = emitted_status_color s in
- [ `Color c; `Fontcolor c; `Style `Bold ]
-
- let default_vertex_attributes _ = []
- let default_edge_attributes _ = []
- let get_subgraph _ = None
- end)
+ | Inconsistent _ -> 0x808080 (* gray *)
+
+ let graph_attributes _ = []
+
+ let vertex_name v =
+ let s = match v with
+ | Property p -> Property.Names.get_prop_name_id p
+ | Emitter s | Tuning_parameter s (*| Correctness_parameter s*)
+ -> s
+ in
+ Format.asprintf "\"%s\"" s
+
+ let label v =
+ let s = match v with
+ | Property p -> Format.asprintf "%a" Property.pretty p
+ | Emitter s | Tuning_parameter s (*| Correctness_parameter s*)
+ -> s
+ in
+ `Label (String.escaped s)
+
+ let vertex_attributes = function
+ | Property p as v ->
+ let s = get_status p in
+ let color = status_color p s in
+ let style = match s with
+ | Never_tried -> [`Style `Bold; `Width 0.8 ]
+ | _ -> [`Style `Filled]
+ in
+ style @ [ label v; `Color color; `Shape `Box ]
+ | Emitter _ as v ->
+ [ label v; `Shape `Diamond; `Color 0xb0c4de; `Style `Filled ]
+ | Tuning_parameter _ as v ->
+ [ label v; (*`Style `Dotted;*) `Color 0xb0c4de; ]
+ (*| Correctness_parameter _ (*as v*) -> assert false (*[ label v; `Color 0xb0c4de ]*)*)
+
+ let edge_attributes e = match E.label e with
+ | None -> []
+ | Some s ->
+ let c = emitted_status_color s in
+ [ `Color c; `Fontcolor c; `Style `Bold ]
+
+ let default_vertex_attributes _ = []
+ let default_edge_attributes _ = []
+ let get_subgraph _ = None
+ end)
in
try
Kernel.Unicode.without_unicode (Dot.fprint_graph formatter) graph;
with Sys_error _ as exn ->
Kernel.error
- "issue when generating consolidation graph: %s"
- (Printexc.to_string exn)
+ "issue when generating consolidation graph: %s"
+ (Printexc.to_string exn)
end
diff --git a/src/kernel_services/ast_data/statuses_by_call.ml b/src/kernel_services/ast_data/statuses_by_call.ml
index b9b69bd47ad..4ed6b2e99cf 100644
--- a/src/kernel_services/ast_data/statuses_by_call.ml
+++ b/src/kernel_services/ast_data/statuses_by_call.ml
@@ -34,10 +34,10 @@ let preconditions_emitter =
module PreCondProxyGenerated =
State_builder.Hashtbl(Property.Hashtbl)(Datatype.List(Property))
(struct
- let name = "Call Preconditions Generated"
- let dependencies = [Ast.self]
- let size = 97
- end)
+ let name = "Call Preconditions Generated"
+ let dependencies = [Ast.self]
+ let size = 97
+ end)
module PropStmt =
@@ -50,7 +50,7 @@ module FunctionPointers =
let name = "Statuses_by_call.FunctionPointers"
let dependencies = [Ast.self]
let size = 37
- end)
+ end)
let add_called_function stmt kf =
let prev =
@@ -226,7 +226,7 @@ and precondition_at_call kf pid stmt =
and setup_precondition_proxy called_kf precondition =
if not (PreCondProxyGenerated.mem precondition) then begin
Kernel.debug "Setting up syntactic call-preconditions for precondition \
- of %a" Kernel_function.pretty called_kf;
+ of %a" Kernel_function.pretty called_kf;
let call_preconditions =
List.map
(fun (_,stmt) -> precondition_at_call called_kf precondition stmt)
@@ -261,7 +261,7 @@ let all_call_preconditions_at ~warn_missing kf stmt =
if warn_missing then
Kernel.fatal ~source:(fst (Cil_datatype.Stmt.loc stmt))
"Preconditions %a for %a not yet registered at this statement"
- Printer.pp_identified_predicate precond Kernel_function.pretty kf;
+ Printer.pp_identified_predicate precond Kernel_function.pretty kf;
properties)
in
fold_requires aux kf []
@@ -281,7 +281,7 @@ let replace_call_precondition ip stmt ip_at_call =
let all = PreCondProxyGenerated.find ip in
let all' = Extlib.filter_out (Property.equal cur) all in
PreCondProxyGenerated.replace ip all';
- with Not_found -> ());
+ with Not_found -> ());
PreCondAt.replace (ip, stmt) ip_at_call;
add_call_precondition ip ip_at_call
diff --git a/src/kernel_services/ast_printing/cil_printer.ml b/src/kernel_services/ast_printing/cil_printer.ml
index 8bd5ca9b33d..64bcad8cbae 100644
--- a/src/kernel_services/ast_printing/cil_printer.ml
+++ b/src/kernel_services/ast_printing/cil_printer.ml
@@ -152,7 +152,7 @@ let state =
parenthesized if its parentheses level is >= that that of its context.
Identifiers have the lowest level and weakly binding operators (e.g. |)
have the largest level. The correctness criterion is that a smaller level
- MUST correspond to a stronger precedence!
+ MUST correspond to a stronger precedence!
These levels must be coherent with the precedence used in file
[src/kernel_internals/parsing/logic_parser.mly].
*)
@@ -236,9 +236,9 @@ module Precedence = struct
| Pand _ -> and_level
| Papp _ as p ->
- if subset_is_backslash_in p = None then
- applicationLevel
- else belongLevel
+ if subset_is_backslash_in p = None then
+ applicationLevel
+ else belongLevel
| Prel _ -> comparativeLevel
| Pnot _ -> unaryLevel
@@ -2381,11 +2381,11 @@ class cil_printer () = object (self)
(Pretty_utils.pp_opt
(fun fmt p -> fprintf fmt ";@ %a" self#predicate p)) p
| Trange(low,high) ->
- fprintf fmt "@[%a..%a@]"
- (Pretty_utils.pp_opt
- (fun fmt v -> Format.fprintf fmt "%a " term v)) low
- (Pretty_utils.pp_opt
- (fun fmt v -> Format.fprintf fmt "@ %a" term v)) high;
+ fprintf fmt "@[%a..%a@]"
+ (Pretty_utils.pp_opt
+ (fun fmt v -> Format.fprintf fmt "%a " term v)) low
+ (Pretty_utils.pp_opt
+ (fun fmt v -> Format.fprintf fmt "@ %a" term v)) high;
| Tlet(def,body) ->
assert
(Kernel.verify (def.l_labels = [])
diff --git a/src/kernel_services/ast_queries/cil.ml b/src/kernel_services/ast_queries/cil.ml
index c1b1928bf7e..3336c5689de 100644
--- a/src/kernel_services/ast_queries/cil.ml
+++ b/src/kernel_services/ast_queries/cil.ml
@@ -104,24 +104,24 @@ let longDoubleType = TFloat (FLongDouble, [])
let empty_size_cache () = {scache=Not_Computed}
type theMachine =
- { mutable useLogicalOperators: bool;
- mutable theMachine: mach;
- (** Cil.initCil will set this to the current machine description. *)
- mutable lowerConstants: bool; (** Do lower constants (default true) *)
- mutable insertImplicitCasts: bool; (** Do insert implicit casts
- (default true) *)
- mutable underscore_name: bool;
- mutable stringLiteralType: typ;
- mutable upointKind: ikind;
- mutable upointType: typ;
- mutable wcharKind: ikind; (** An integer type that fits wchar_t. *)
- mutable wcharType: typ;
- mutable ptrdiffKind: ikind; (** An integer type that fits ptrdiff_t. *)
- mutable ptrdiffType: typ;
- mutable typeOfSizeOf: typ; (** An integer type that is the type of
- sizeof. *)
- mutable kindOfSizeOf: ikind;
- }
+ { mutable useLogicalOperators: bool;
+ mutable theMachine: mach;
+ (** Cil.initCil will set this to the current machine description. *)
+ mutable lowerConstants: bool; (** Do lower constants (default true) *)
+ mutable insertImplicitCasts: bool; (** Do insert implicit casts
+ (default true) *)
+ mutable underscore_name: bool;
+ mutable stringLiteralType: typ;
+ mutable upointKind: ikind;
+ mutable upointType: typ;
+ mutable wcharKind: ikind; (** An integer type that fits wchar_t. *)
+ mutable wcharType: typ;
+ mutable ptrdiffKind: ikind; (** An integer type that fits ptrdiff_t. *)
+ mutable ptrdiffType: typ;
+ mutable typeOfSizeOf: typ; (** An integer type that is the type of
+ sizeof. *)
+ mutable kindOfSizeOf: ikind;
+ }
let default_machdep = Machdeps.x86_32
@@ -140,7 +140,7 @@ let createMachine () = (* Contain dummy values *)
ptrdiffType = voidType;
typeOfSizeOf = voidType;
kindOfSizeOf = IUInt;
-}
+ }
let copyMachine src dst =
dst.useLogicalOperators <- src.useLogicalOperators;
@@ -174,30 +174,30 @@ module Machine_datatype =
let name = "theMachine"
let reprs = [ theMachine ]
let copy x =
- let m = createMachine () in
- copyMachine x m;
- m
+ let m = createMachine () in
+ copyMachine x m;
+ m
let mem_project = Datatype.never_any_project
- end)
+ end)
module TheMachine =
State_builder.Register
(Machine_datatype)
(struct
- type t = theMachine
- let create = createMachine
- let get () = !theMachineProject
- let set m =
- theMachineProject := m;
- copyMachine !theMachineProject theMachine
- let clear m = copyMachine (createMachine ()) m
- let clear_some_projects _ _ = false
- end)
+ type t = theMachine
+ let create = createMachine
+ let get () = !theMachineProject
+ let set m =
+ theMachineProject := m;
+ copyMachine !theMachineProject theMachine
+ let clear m = copyMachine (createMachine ()) m
+ let clear_some_projects _ _ = false
+ end)
(struct
- let name = "theMachine"
- let unique_name = name
- let dependencies = [ Kernel.Machdep.self; Kernel.LogicalOperators.self ]
- end)
+ let name = "theMachine"
+ let unique_name = name
+ let dependencies = [ Kernel.Machdep.self; Kernel.LogicalOperators.self ]
+ end)
let selfMachine = TheMachine.self
@@ -221,10 +221,10 @@ let dummy_exp e = { eid = -1; enode = e; eloc = Cil_datatype.Location.unknown }
let argsToList : (string * typ * attributes) list option
- -> (string * typ * attributes) list
- = function
- None -> []
- | Some al -> al
+ -> (string * typ * attributes) list
+ = function
+ None -> []
+ | Some al -> al
(* A hack to allow forward reference of d_exp *)
@@ -250,8 +250,8 @@ let find_default_requires behaviors =
with Not_found -> []
let rec stripInfo e =
- match e.enode with
- | Info(e',_) -> stripInfo e'
+ match e.enode with
+ | Info(e',_) -> stripInfo e'
| _ -> e
let rec addOffset (toadd: offset) (off: offset) : offset =
@@ -287,471 +287,471 @@ and enforceGhostBlockCoherence ?force_ghost block =
let mkStmt ?(ghost=false) ?(valid_sid=false) ?(sattr=[]) (sk: stmtkind) : stmt =
{ skind = sk;
labels = [];
- (* It is better to create statements with a valid sid, so that they can
- safely be used in tables. I only do it when performing Jessie
- analysis, as other plugins rely on specific sid values for their tests
- (e.g. slicing). *)
+ (* It is better to create statements with a valid sid, so that they can
+ safely be used in tables. I only do it when performing Jessie
+ analysis, as other plugins rely on specific sid values for their tests
+ (e.g. slicing). *)
sid = if valid_sid then Sid.next () else -1;
succs = []; preds = [];
ghost = ghost;
sattr = sattr;}
let stmt_of_instr_list ?(loc=Location.unknown) = function
- | [] -> Instr (Skip loc)
- | [i] -> Instr i
- | il ->
- let b = mkBlockNonScoping (List.map (fun i -> mkStmt (Instr i)) il) in
- Block b
-
- (**** Utility functions ******)
-
- (**** ATTRIBUTES ****)
-
- let bitfield_attribute_name = "FRAMA_C_BITFIELD_SIZE"
-
- (** Construct sorted lists of attributes ***)
- let attributeName =
- function Attr(a, _) | AttrAnnot a -> Extlib.strip_underscore a
-
- let addAttribute
- (Attr(an, _) | AttrAnnot an as a: attribute) (al: attributes) =
- let rec insertSorted = function
- [] -> [a]
- | ((Attr(an0, _) | AttrAnnot an0 as a0) :: rest) as l ->
- if an < an0 then a :: l
- else if Cil_datatype.Attribute.equal a a0 then l (* Do not add if already in there *)
- else a0 :: insertSorted rest (* Make sure we see all attributes with
- * this name *)
- in
- insertSorted al
-
- (** The second attribute list is sorted *)
- let addAttributes al0 (al: attributes) : attributes =
- if al0 == [] then al else
- List.fold_left (fun acc a -> addAttribute a acc) al al0
-
- let dropAttribute (an: string) (al: attributes) =
- List.filter (fun a -> attributeName a <> an) al
-
- let hasAttribute (s: string) (al: attribute list) : bool =
- let s = Extlib.strip_underscore s in
- List.exists (fun a -> attributeName a = s) al
-
- let rec dropAttributes (anl: string list) (al: attributes) =
- match al with
- | [] -> []
- | a :: q ->
- let q' = dropAttributes anl q in
- if List.mem (attributeName a) anl then
- q' (* drop this attribute *)
- else
- if q' == q then al (* preserve sharing *) else a :: q'
-
- let filterAttributes (s: string) (al: attribute list) : attribute list =
- List.filter (fun a -> attributeName a = s) al
-
- let findAttribute (s: string) (al: attribute list) : attrparam list =
- List.fold_left
- (fun acc -> function
- | Attr (an, param) when an = s -> param @ acc
- | _ -> acc)
- [] al
-
- let rec typeAttrs = function
- TVoid a -> a
- | TInt (_, a) -> a
- | TFloat (_, a) -> a
- | TNamed (t, a) -> addAttributes a (typeAttrs t.ttype)
- | TPtr (_, a) -> a
- | TArray (_, _, _,a) -> a
- | TComp (comp, _, a) -> addAttributes comp.cattr a
- | TEnum (enum, a) -> addAttributes enum.eattr a
- | TFun (_, _, _, a) -> a
- | TBuiltin_va_list a -> a
-
- let typeAttr = function
- | TVoid a
- | TInt (_, a)
- | TFloat (_, a)
- | TNamed (_, a)
- | TPtr (_, a)
- | TArray (_, _, _, a)
- | TComp (_, _, a)
- | TEnum (_, a)
- | TFun (_, _, _, a)
- | TBuiltin_va_list a -> a
-
- let setTypeAttrs t a =
- match t with
- TVoid _ -> TVoid a
- | TInt (i, _) -> TInt (i, a)
- | TFloat (f, _) -> TFloat (f, a)
- | TNamed (t, _) -> TNamed(t, a)
- | TPtr (t', _) -> TPtr(t', a)
- | TArray (t', l, s, _) -> TArray(t', l, s, a)
- | TComp (comp, s, _) -> TComp (comp, s, a)
- | TEnum (enum, _) -> TEnum (enum, a)
- | TFun (r, args, v, _) -> TFun(r,args,v,a)
- | TBuiltin_va_list _ -> TBuiltin_va_list a
-
- let qualifier_attributes = [ "const"; "restrict"; "volatile"]
-
- let filter_qualifier_attributes al =
- List.filter
- (fun a -> List.mem (attributeName a) qualifier_attributes) al
-
- let splitArrayAttributes =
- List.partition
- (fun a -> List.mem (attributeName a) qualifier_attributes)
-
- let rec typeAddAttributes a0 t =
- begin
- match a0 with
- | [] ->
- (* no attributes, keep same type *)
- t
- | _ ->
- (* anything else: add a0 to existing attributes *)
- let add (a: attributes) = addAttributes a0 a in
- match t with
- TVoid a -> TVoid (add a)
- | TInt (ik, a) -> TInt (ik, add a)
- | TFloat (fk, a) -> TFloat (fk, add a)
- | TEnum (enum, a) -> TEnum (enum, add a)
- | TPtr (t, a) -> TPtr (t, add a)
- | TArray (t, l, s, a) ->
- let att_elt, att_typ = splitArrayAttributes a0 in
- TArray (arrayPushAttributes att_elt t, l, s,
- addAttributes att_typ a)
- | TFun (t, args, isva, a) -> TFun(t, args, isva, add a)
- | TComp (comp, s, a) -> TComp (comp, s, add a)
- | TNamed (t, a) -> TNamed (t, add a)
- | TBuiltin_va_list a -> TBuiltin_va_list (add a)
- end
- (* Push attributes that belong to the type of the elements of the array as
- far as possible *)
- and arrayPushAttributes al = function
- | TArray (bt, l, s, a) ->
- TArray (arrayPushAttributes al bt, l, s, a)
- | t -> typeAddAttributes al t
-
- let rec typeRemoveAttributes ?anl t =
- (* Try to preserve sharing. We use sharing to be more efficient, but also
- to detect that we have removed an attribute under typedefs *)
- let new_attr al =
- match anl with None -> [] | Some anl -> dropAttributes anl al
- in
- let reshare al f =
- let al' = new_attr al in if al' == al then t else f al'
- in
- match t with
- | TVoid a -> reshare a (fun a -> TVoid a)
- | TInt (ik, a) -> reshare a (fun a -> TInt (ik, a))
- | TFloat (fk, a) -> reshare a (fun a -> TFloat (fk, a))
- | TEnum (enum, a) -> reshare a (fun a -> TEnum (enum, a))
- | TPtr (t, a) -> reshare a (fun a -> TPtr (t, a))
- | TArray (t, l, s, a) -> reshare a (fun a -> TArray (t, l, s, a))
- | TFun (t, args, isva, a) -> reshare a (fun a -> TFun(t, args, isva, a))
- | TComp (comp, s, a) -> reshare a (fun a -> TComp (comp, s, a))
- | TBuiltin_va_list a -> reshare a (fun a -> TBuiltin_va_list a)
- | TNamed (tn, a) ->
- let tn' = typeRemoveAttributes ?anl tn.ttype in
- if tn' == tn.ttype then reshare a (fun a -> TNamed (tn, a))
- else typeAddAttributes (new_attr a) tn'
-
- let typeRemoveAllAttributes t = typeRemoveAttributes t
-
- let typeRemoveAttributes anl t = typeRemoveAttributes ~anl t
-
- let rec typeRemoveAttributesDeep (anl: string list) t =
- (* Try to preserve sharing. We use sharing to be more efficient, but also
- to detect that we have removed an attribute under typedefs *)
- let reshare al f =
- let al' = dropAttributes anl al in
- if al' == al then t else f al'
- in
- match t with
- | TVoid a -> reshare a (fun a -> TVoid a)
- | TInt (ik, a) -> reshare a (fun a -> TInt (ik, a))
- | TFloat (fk, a) -> reshare a (fun a -> TFloat (fk, a))
- | TEnum (enum, a) -> reshare a (fun a -> TEnum (enum, a))
- | TPtr (t, a) ->
- let t' = typeRemoveAttributesDeep anl t in
- if t != t' then TPtr(t', dropAttributes anl a)
- else reshare a (fun a -> TPtr(t,a))
- | TArray (t, l, s, a) ->
- let t' = typeRemoveAttributesDeep anl t in
- if t!=t' then TArray(t', l, s, dropAttributes anl a)
- else reshare a (fun a -> TArray (t, l, s, a))
- | TFun (t, args, isva, a) -> reshare a (fun a -> TFun(t, args, isva, a))
- | TComp (comp, s, a) -> reshare a (fun a -> TComp (comp, s, a))
- | TBuiltin_va_list a -> reshare a (fun a -> TBuiltin_va_list a)
- | TNamed (tn, a) ->
- let tn' = typeRemoveAttributesDeep anl tn.ttype in
- if tn' == tn.ttype then
- reshare a (fun a -> TNamed (tn, a))
- else
- typeAddAttributes (dropAttributes anl a) tn'
+ | [] -> Instr (Skip loc)
+ | [i] -> Instr i
+ | il ->
+ let b = mkBlockNonScoping (List.map (fun i -> mkStmt (Instr i)) il) in
+ Block b
+
+(**** Utility functions ******)
+
+(**** ATTRIBUTES ****)
+
+let bitfield_attribute_name = "FRAMA_C_BITFIELD_SIZE"
+
+(** Construct sorted lists of attributes ***)
+let attributeName =
+ function Attr(a, _) | AttrAnnot a -> Extlib.strip_underscore a
+
+let addAttribute
+ (Attr(an, _) | AttrAnnot an as a: attribute) (al: attributes) =
+ let rec insertSorted = function
+ [] -> [a]
+ | ((Attr(an0, _) | AttrAnnot an0 as a0) :: rest) as l ->
+ if an < an0 then a :: l
+ else if Cil_datatype.Attribute.equal a a0 then l (* Do not add if already in there *)
+ else a0 :: insertSorted rest (* Make sure we see all attributes with
+ * this name *)
+ in
+ insertSorted al
+
+(** The second attribute list is sorted *)
+let addAttributes al0 (al: attributes) : attributes =
+ if al0 == [] then al else
+ List.fold_left (fun acc a -> addAttribute a acc) al al0
+
+let dropAttribute (an: string) (al: attributes) =
+ List.filter (fun a -> attributeName a <> an) al
+
+let hasAttribute (s: string) (al: attribute list) : bool =
+ let s = Extlib.strip_underscore s in
+ List.exists (fun a -> attributeName a = s) al
+
+let rec dropAttributes (anl: string list) (al: attributes) =
+ match al with
+ | [] -> []
+ | a :: q ->
+ let q' = dropAttributes anl q in
+ if List.mem (attributeName a) anl then
+ q' (* drop this attribute *)
+ else
+ if q' == q then al (* preserve sharing *) else a :: q'
+
+let filterAttributes (s: string) (al: attribute list) : attribute list =
+ List.filter (fun a -> attributeName a = s) al
+
+let findAttribute (s: string) (al: attribute list) : attrparam list =
+ List.fold_left
+ (fun acc -> function
+ | Attr (an, param) when an = s -> param @ acc
+ | _ -> acc)
+ [] al
+
+let rec typeAttrs = function
+ TVoid a -> a
+ | TInt (_, a) -> a
+ | TFloat (_, a) -> a
+ | TNamed (t, a) -> addAttributes a (typeAttrs t.ttype)
+ | TPtr (_, a) -> a
+ | TArray (_, _, _,a) -> a
+ | TComp (comp, _, a) -> addAttributes comp.cattr a
+ | TEnum (enum, a) -> addAttributes enum.eattr a
+ | TFun (_, _, _, a) -> a
+ | TBuiltin_va_list a -> a
+
+let typeAttr = function
+ | TVoid a
+ | TInt (_, a)
+ | TFloat (_, a)
+ | TNamed (_, a)
+ | TPtr (_, a)
+ | TArray (_, _, _, a)
+ | TComp (_, _, a)
+ | TEnum (_, a)
+ | TFun (_, _, _, a)
+ | TBuiltin_va_list a -> a
+
+let setTypeAttrs t a =
+ match t with
+ TVoid _ -> TVoid a
+ | TInt (i, _) -> TInt (i, a)
+ | TFloat (f, _) -> TFloat (f, a)
+ | TNamed (t, _) -> TNamed(t, a)
+ | TPtr (t', _) -> TPtr(t', a)
+ | TArray (t', l, s, _) -> TArray(t', l, s, a)
+ | TComp (comp, s, _) -> TComp (comp, s, a)
+ | TEnum (enum, _) -> TEnum (enum, a)
+ | TFun (r, args, v, _) -> TFun(r,args,v,a)
+ | TBuiltin_va_list _ -> TBuiltin_va_list a
+
+let qualifier_attributes = [ "const"; "restrict"; "volatile"]
+
+let filter_qualifier_attributes al =
+ List.filter
+ (fun a -> List.mem (attributeName a) qualifier_attributes) al
+
+let splitArrayAttributes =
+ List.partition
+ (fun a -> List.mem (attributeName a) qualifier_attributes)
+
+let rec typeAddAttributes a0 t =
+ begin
+ match a0 with
+ | [] ->
+ (* no attributes, keep same type *)
+ t
+ | _ ->
+ (* anything else: add a0 to existing attributes *)
+ let add (a: attributes) = addAttributes a0 a in
+ match t with
+ TVoid a -> TVoid (add a)
+ | TInt (ik, a) -> TInt (ik, add a)
+ | TFloat (fk, a) -> TFloat (fk, add a)
+ | TEnum (enum, a) -> TEnum (enum, add a)
+ | TPtr (t, a) -> TPtr (t, add a)
+ | TArray (t, l, s, a) ->
+ let att_elt, att_typ = splitArrayAttributes a0 in
+ TArray (arrayPushAttributes att_elt t, l, s,
+ addAttributes att_typ a)
+ | TFun (t, args, isva, a) -> TFun(t, args, isva, add a)
+ | TComp (comp, s, a) -> TComp (comp, s, add a)
+ | TNamed (t, a) -> TNamed (t, add a)
+ | TBuiltin_va_list a -> TBuiltin_va_list (add a)
+ end
+(* Push attributes that belong to the type of the elements of the array as
+ far as possible *)
+and arrayPushAttributes al = function
+ | TArray (bt, l, s, a) ->
+ TArray (arrayPushAttributes al bt, l, s, a)
+ | t -> typeAddAttributes al t
+
+let rec typeRemoveAttributes ?anl t =
+ (* Try to preserve sharing. We use sharing to be more efficient, but also
+ to detect that we have removed an attribute under typedefs *)
+ let new_attr al =
+ match anl with None -> [] | Some anl -> dropAttributes anl al
+ in
+ let reshare al f =
+ let al' = new_attr al in if al' == al then t else f al'
+ in
+ match t with
+ | TVoid a -> reshare a (fun a -> TVoid a)
+ | TInt (ik, a) -> reshare a (fun a -> TInt (ik, a))
+ | TFloat (fk, a) -> reshare a (fun a -> TFloat (fk, a))
+ | TEnum (enum, a) -> reshare a (fun a -> TEnum (enum, a))
+ | TPtr (t, a) -> reshare a (fun a -> TPtr (t, a))
+ | TArray (t, l, s, a) -> reshare a (fun a -> TArray (t, l, s, a))
+ | TFun (t, args, isva, a) -> reshare a (fun a -> TFun(t, args, isva, a))
+ | TComp (comp, s, a) -> reshare a (fun a -> TComp (comp, s, a))
+ | TBuiltin_va_list a -> reshare a (fun a -> TBuiltin_va_list a)
+ | TNamed (tn, a) ->
+ let tn' = typeRemoveAttributes ?anl tn.ttype in
+ if tn' == tn.ttype then reshare a (fun a -> TNamed (tn, a))
+ else typeAddAttributes (new_attr a) tn'
+
+let typeRemoveAllAttributes t = typeRemoveAttributes t
+
+let typeRemoveAttributes anl t = typeRemoveAttributes ~anl t
+
+let rec typeRemoveAttributesDeep (anl: string list) t =
+ (* Try to preserve sharing. We use sharing to be more efficient, but also
+ to detect that we have removed an attribute under typedefs *)
+ let reshare al f =
+ let al' = dropAttributes anl al in
+ if al' == al then t else f al'
+ in
+ match t with
+ | TVoid a -> reshare a (fun a -> TVoid a)
+ | TInt (ik, a) -> reshare a (fun a -> TInt (ik, a))
+ | TFloat (fk, a) -> reshare a (fun a -> TFloat (fk, a))
+ | TEnum (enum, a) -> reshare a (fun a -> TEnum (enum, a))
+ | TPtr (t, a) ->
+ let t' = typeRemoveAttributesDeep anl t in
+ if t != t' then TPtr(t', dropAttributes anl a)
+ else reshare a (fun a -> TPtr(t,a))
+ | TArray (t, l, s, a) ->
+ let t' = typeRemoveAttributesDeep anl t in
+ if t!=t' then TArray(t', l, s, dropAttributes anl a)
+ else reshare a (fun a -> TArray (t, l, s, a))
+ | TFun (t, args, isva, a) -> reshare a (fun a -> TFun(t, args, isva, a))
+ | TComp (comp, s, a) -> reshare a (fun a -> TComp (comp, s, a))
+ | TBuiltin_va_list a -> reshare a (fun a -> TBuiltin_va_list a)
+ | TNamed (tn, a) ->
+ let tn' = typeRemoveAttributesDeep anl tn.ttype in
+ if tn' == tn.ttype then
+ reshare a (fun a -> TNamed (tn, a))
+ else
+ typeAddAttributes (dropAttributes anl a) tn'
(* JS: build an attribute annotation from [s]. *)
let mkAttrAnnot s = "/*@ " ^ s ^ " */"
-
-let type_remove_qualifier_attributes =
+
+let type_remove_qualifier_attributes =
typeRemoveAttributes qualifier_attributes
let type_remove_qualifier_attributes_deep =
typeRemoveAttributesDeep qualifier_attributes
-
+
type attributeClass =
- | AttrName of bool
- (* Attribute of a name. If argument is true and we are on MSVC then
- * the attribute is printed using __declspec as part of the storage
- * specifier *)
- | AttrFunType of bool
- (* Attribute of a function type. If argument is true and we are on
- * MSVC then the attribute is printed just before the function name *)
-
- | AttrType (* Attribute of a type *)
-
- (* This table contains the mapping of predefined attributes to classes.
- * Extend this table with more attributes as you need. This table is used to
- * determine how to associate attributes with names or type during cabs2cil
- * conversion *)
- let attributeHash: (string, attributeClass) Hashtbl.t =
- let table = Hashtbl.create 13 in
- List.iter (fun a -> Hashtbl.add table a (AttrName false))
- [ "section"; "constructor"; "destructor"; "unused"; "used"; "weak";
- "no_instrument_function"; "alias"; "no_check_memory_usage";
- "exception"; "model"; (* "restrict"; *)
- "aconst"; "__asm__" (* Gcc uses this to specify the name to be used in
- * assembly for a global *)];
- (* Now come the MSVC declspec attributes *)
- List.iter (fun a -> Hashtbl.add table a (AttrName true))
- [ "thread"; "naked"; "dllimport"; "dllexport";
- "selectany"; "allocate"; "nothrow"; "novtable"; "property"; "noreturn";
- "uuid"; "align" ];
- List.iter (fun a -> Hashtbl.add table a (AttrFunType false))
- [ "format"; "regparm"; "longcall"; "noinline"; "always_inline"; ];
- List.iter (fun a -> Hashtbl.add table a (AttrFunType true))
- [ "stdcall";"cdecl"; "fastcall" ];
- List.iter (fun a -> Hashtbl.add table a AttrType)
- [ "const"; "volatile"; "restrict"; "mode" ];
- table
-
- let attributeClass = Hashtbl.find attributeHash
-
- let registerAttribute = Hashtbl.add attributeHash
- let removeAttribute = Hashtbl.remove attributeHash
-
- (** Partition the attributes into classes *)
- let partitionAttributes
- ~(default:attributeClass)
- (attrs: attribute list) :
- attribute list * attribute list * attribute list =
- let rec loop (n,f,t) = function
- [] -> n, f, t
- | (Attr(an, _) | AttrAnnot an as a) :: rest ->
- match (try Hashtbl.find attributeHash an with Not_found -> default) with
- AttrName _ -> loop (addAttribute a n, f, t) rest
- | AttrFunType _ ->
- loop (n, addAttribute a f, t) rest
- | AttrType -> loop (n, f, addAttribute a t) rest
- in
- loop ([], [], []) attrs
-
-
- let unrollType (t: typ) : typ =
- let rec withAttrs (al: attributes) (t: typ) : typ =
- match t with
- TNamed (r, a') -> withAttrs (addAttributes al a') r.ttype
- | x -> typeAddAttributes al x
- in
- withAttrs [] t
-
- let () = punrollType := unrollType
-
- (* Unroll typedefs, discarding all intermediate attribute. To be used only
- when one is interested in the shape of the type *)
- let rec unrollTypeSkel = function
- | TNamed (r, _) -> unrollTypeSkel r.ttype
- | x -> x
-
- (* Make a varinfo. Used mostly as a helper function below *)
- let makeVarinfo ?(source=true) ?(temp=false) ?(referenced=false) global formal name typ =
- let vi =
- { vorig_name = name;
- vname = name;
- vid = -1;
- vglob = global;
- vdefined = false;
- vformal = formal;
- vtemp = temp;
- vtype = typ;
- vdecl = Location.unknown;
- vinline = false;
- vattr = [];
- vstorage = NoStorage;
- vaddrof = false;
- vreferenced = referenced;
- vdescr = None;
- vdescrpure = true;
- vghost = false;
- vsource = source;
- vlogic_var_assoc = None
- }
- in
- Cil_const.set_vid vi;
- vi
-
- module FormalsDecl =
- State_builder.Hashtbl
- (Varinfo.Hashtbl)
- (Datatype.List(Varinfo))
- (struct
- let name = "Cil.FormalsDecl"
- let dependencies = [] (* depends on Ast.self; see below *)
- let size = 47
- end)
-
- let selfFormalsDecl = FormalsDecl.self
- let () = dependency_on_ast selfFormalsDecl
-
- let makeFormalsVarDecl (n,t,a) =
- let vi = makeVarinfo ~temp:false false true n t in
- vi.vattr <- a;
- vi
-
- let setFormalsDecl vi typ =
- match unrollType typ with
- | TFun(_, Some args, _, _) ->
- FormalsDecl.replace vi (List.map makeFormalsVarDecl args)
- | TFun(_,None,_,_) -> ()
- | _ ->
- Kernel.error ~current:true
- "trying to assigns formal parameters to an object \
- that is not a function prototype"
-
- let getFormalsDecl vi = FormalsDecl.find vi
-
- let unsafeSetFormalsDecl vi args = FormalsDecl.replace vi args
-
- let removeFormalsDecl vi = FormalsDecl.remove vi
-
- let iterFormalsDecl = FormalsDecl.iter
-
- let () = Cil_datatype.Kf.set_formal_decls := unsafeSetFormalsDecl
+ | AttrName of bool
+ (* Attribute of a name. If argument is true and we are on MSVC then
+ * the attribute is printed using __declspec as part of the storage
+ * specifier *)
+ | AttrFunType of bool
+ (* Attribute of a function type. If argument is true and we are on
+ * MSVC then the attribute is printed just before the function name *)
+
+ | AttrType (* Attribute of a type *)
+
+(* This table contains the mapping of predefined attributes to classes.
+ * Extend this table with more attributes as you need. This table is used to
+ * determine how to associate attributes with names or type during cabs2cil
+ * conversion *)
+let attributeHash: (string, attributeClass) Hashtbl.t =
+ let table = Hashtbl.create 13 in
+ List.iter (fun a -> Hashtbl.add table a (AttrName false))
+ [ "section"; "constructor"; "destructor"; "unused"; "used"; "weak";
+ "no_instrument_function"; "alias"; "no_check_memory_usage";
+ "exception"; "model"; (* "restrict"; *)
+ "aconst"; "__asm__" (* Gcc uses this to specify the name to be used in
+ * assembly for a global *)];
+ (* Now come the MSVC declspec attributes *)
+ List.iter (fun a -> Hashtbl.add table a (AttrName true))
+ [ "thread"; "naked"; "dllimport"; "dllexport";
+ "selectany"; "allocate"; "nothrow"; "novtable"; "property"; "noreturn";
+ "uuid"; "align" ];
+ List.iter (fun a -> Hashtbl.add table a (AttrFunType false))
+ [ "format"; "regparm"; "longcall"; "noinline"; "always_inline"; ];
+ List.iter (fun a -> Hashtbl.add table a (AttrFunType true))
+ [ "stdcall";"cdecl"; "fastcall" ];
+ List.iter (fun a -> Hashtbl.add table a AttrType)
+ [ "const"; "volatile"; "restrict"; "mode" ];
+ table
+
+let attributeClass = Hashtbl.find attributeHash
+
+let registerAttribute = Hashtbl.add attributeHash
+let removeAttribute = Hashtbl.remove attributeHash
+
+(** Partition the attributes into classes *)
+let partitionAttributes
+ ~(default:attributeClass)
+ (attrs: attribute list) :
+ attribute list * attribute list * attribute list =
+ let rec loop (n,f,t) = function
+ [] -> n, f, t
+ | (Attr(an, _) | AttrAnnot an as a) :: rest ->
+ match (try Hashtbl.find attributeHash an with Not_found -> default) with
+ AttrName _ -> loop (addAttribute a n, f, t) rest
+ | AttrFunType _ ->
+ loop (n, addAttribute a f, t) rest
+ | AttrType -> loop (n, f, addAttribute a t) rest
+ in
+ loop ([], [], []) attrs
+
+
+let unrollType (t: typ) : typ =
+ let rec withAttrs (al: attributes) (t: typ) : typ =
+ match t with
+ TNamed (r, a') -> withAttrs (addAttributes al a') r.ttype
+ | x -> typeAddAttributes al x
+ in
+ withAttrs [] t
+
+let () = punrollType := unrollType
+
+(* Unroll typedefs, discarding all intermediate attribute. To be used only
+ when one is interested in the shape of the type *)
+let rec unrollTypeSkel = function
+ | TNamed (r, _) -> unrollTypeSkel r.ttype
+ | x -> x
+
+(* Make a varinfo. Used mostly as a helper function below *)
+let makeVarinfo ?(source=true) ?(temp=false) ?(referenced=false) global formal name typ =
+ let vi =
+ { vorig_name = name;
+ vname = name;
+ vid = -1;
+ vglob = global;
+ vdefined = false;
+ vformal = formal;
+ vtemp = temp;
+ vtype = typ;
+ vdecl = Location.unknown;
+ vinline = false;
+ vattr = [];
+ vstorage = NoStorage;
+ vaddrof = false;
+ vreferenced = referenced;
+ vdescr = None;
+ vdescrpure = true;
+ vghost = false;
+ vsource = source;
+ vlogic_var_assoc = None
+ }
+ in
+ Cil_const.set_vid vi;
+ vi
+
+module FormalsDecl =
+ State_builder.Hashtbl
+ (Varinfo.Hashtbl)
+ (Datatype.List(Varinfo))
+ (struct
+ let name = "Cil.FormalsDecl"
+ let dependencies = [] (* depends on Ast.self; see below *)
+ let size = 47
+ end)
+
+let selfFormalsDecl = FormalsDecl.self
+let () = dependency_on_ast selfFormalsDecl
+
+let makeFormalsVarDecl (n,t,a) =
+ let vi = makeVarinfo ~temp:false false true n t in
+ vi.vattr <- a;
+ vi
+
+let setFormalsDecl vi typ =
+ match unrollType typ with
+ | TFun(_, Some args, _, _) ->
+ FormalsDecl.replace vi (List.map makeFormalsVarDecl args)
+ | TFun(_,None,_,_) -> ()
+ | _ ->
+ Kernel.error ~current:true
+ "trying to assigns formal parameters to an object \
+ that is not a function prototype"
+
+let getFormalsDecl vi = FormalsDecl.find vi
+
+let unsafeSetFormalsDecl vi args = FormalsDecl.replace vi args
+
+let removeFormalsDecl vi = FormalsDecl.remove vi
+
+let iterFormalsDecl = FormalsDecl.iter
+
+let () = Cil_datatype.Kf.set_formal_decls := unsafeSetFormalsDecl
(* Set the formals and re-create the function name based on the information*)
- let setFormals (f: fundec) (forms: varinfo list) =
- unsafeSetFormalsDecl f.svar forms;
- List.iter (fun v -> v.vformal <- true) forms;
- f.sformals <- forms; (* Set the formals *)
- assert (getFormalsDecl f.svar == f.sformals);
- match unrollType f.svar.vtype with
- TFun(rt, _, isva, fa) ->
- f.svar.vtype <-
- TFun(rt,
- Some (List.map (fun a -> (a.vname, a.vtype, a.vattr)) forms),
- isva, fa)
- | _ ->
- Kernel.fatal "Set formals. %s does not have function type" f.svar.vname
-
- let empty_funspec () =
- { spec_behavior = [];
- spec_variant = None;
- spec_terminates = None;
- spec_complete_behaviors = [];
- spec_disjoint_behaviors = [] }
-
- let no_behavior l =
- match l with
- | [] -> true
- | [ b ] ->
- b.b_name = default_behavior_name &&
- b.b_requires = [] &&
- b.b_post_cond = [] &&
- b.b_assigns = WritesAny &&
- b.b_allocation = FreeAllocAny &&
- b.b_extended = []
- | _ -> false
-
- let is_empty_funspec (spec : funspec) =
- (no_behavior spec.spec_behavior) &&
- spec.spec_variant = None && spec.spec_terminates = None &&
- spec.spec_complete_behaviors = [] && spec.spec_disjoint_behaviors = []
+let setFormals (f: fundec) (forms: varinfo list) =
+ unsafeSetFormalsDecl f.svar forms;
+ List.iter (fun v -> v.vformal <- true) forms;
+ f.sformals <- forms; (* Set the formals *)
+ assert (getFormalsDecl f.svar == f.sformals);
+ match unrollType f.svar.vtype with
+ TFun(rt, _, isva, fa) ->
+ f.svar.vtype <-
+ TFun(rt,
+ Some (List.map (fun a -> (a.vname, a.vtype, a.vattr)) forms),
+ isva, fa)
+ | _ ->
+ Kernel.fatal "Set formals. %s does not have function type" f.svar.vname
+
+let empty_funspec () =
+ { spec_behavior = [];
+ spec_variant = None;
+ spec_terminates = None;
+ spec_complete_behaviors = [];
+ spec_disjoint_behaviors = [] }
+
+let no_behavior l =
+ match l with
+ | [] -> true
+ | [ b ] ->
+ b.b_name = default_behavior_name &&
+ b.b_requires = [] &&
+ b.b_post_cond = [] &&
+ b.b_assigns = WritesAny &&
+ b.b_allocation = FreeAllocAny &&
+ b.b_extended = []
+ | _ -> false
+
+let is_empty_funspec (spec : funspec) =
+ (no_behavior spec.spec_behavior) &&
+ spec.spec_variant = None && spec.spec_terminates = None &&
+ spec.spec_complete_behaviors = [] && spec.spec_disjoint_behaviors = []
let is_empty_behavior b =
b.b_assumes = [] && b.b_requires = [] && b.b_post_cond = [] &&
b.b_assigns = WritesAny && b.b_allocation = FreeAllocAny && b.b_extended = []
- (** Get the full name of a comp *)
- let compFullName comp =
- (if comp.cstruct then "struct " else "union ") ^ comp.cname
+(** Get the full name of a comp *)
+let compFullName comp =
+ (if comp.cstruct then "struct " else "union ") ^ comp.cname
- let missingFieldName = "" (* "___missing_field_name"*)
+let missingFieldName = "" (* "___missing_field_name"*)
(* The next compindo identifier to use. Counts up. *)
- let nextCompinfoKey =
- let module M =
- State_builder.SharedCounter(struct let name = "compinfokey" end)
- in
- M.next
-
- (** Creates a (potentially recursive) composite type. Make sure you add a
- * GTag for it to the file! **)
- let mkCompInfo
- (isstruct: bool)
- (n: string)
- ?(norig=n)
- (* fspec is a function that when given a forward
- * representation of the structure type constructs the type of
- * the fields. The function can ignore this argument if not
- * constructing a recursive type. *)
- (mkfspec: compinfo -> (string * typ * int option * attribute list *
- location) list)
- (a: attribute list) : compinfo =
-
- (* make a new name for anonymous structs *)
- if n = "" then Kernel.fatal "mkCompInfo: missing structure name\n" ;
- (* Make a new self cell and a forward reference *)
- let comp =
- { cstruct = isstruct;
- corig_name = norig;
- cname = n;
- ckey = nextCompinfoKey ();
- cfields = []; (* fields will be added afterwards. *)
- cattr = a;
- creferenced = false;
- (* Make this compinfo undefined by default *)
- cdefined = false; }
- in
- let flds =
- List.map (fun (fn, ft, fb, fa, fl) ->
- { fcomp = comp;
- ftype = ft;
- forig_name = fn;
- fname = fn;
- fbitfield = fb;
- fattr = fa;
- floc = fl;
- faddrof = false;
- fsize_in_bits = None;
- foffset_in_bits = None;
- fpadding_in_bits = None;
- }) (mkfspec comp) in
- comp.cfields <- flds;
- if flds <> [] then comp.cdefined <- true;
- comp
-
- (** Make a copy of a compinfo, changing the name and the key *)
- let copyCompInfo ?(fresh=true) ci cname =
- let ckey = if fresh then nextCompinfoKey () else ci.ckey in
- let ci' = { ci with cname; ckey } in
- (* Copy the fields and set the new pointers to parents *)
- ci'.cfields <- List.map (fun f -> {f with fcomp = ci'}) ci'.cfields;
- ci'
+let nextCompinfoKey =
+ let module M =
+ State_builder.SharedCounter(struct let name = "compinfokey" end)
+ in
+ M.next
+
+(** Creates a (potentially recursive) composite type. Make sure you add a
+ * GTag for it to the file! **)
+let mkCompInfo
+ (isstruct: bool)
+ (n: string)
+ ?(norig=n)
+ (* fspec is a function that when given a forward
+ * representation of the structure type constructs the type of
+ * the fields. The function can ignore this argument if not
+ * constructing a recursive type. *)
+ (mkfspec: compinfo -> (string * typ * int option * attribute list *
+ location) list)
+ (a: attribute list) : compinfo =
+
+ (* make a new name for anonymous structs *)
+ if n = "" then Kernel.fatal "mkCompInfo: missing structure name\n" ;
+ (* Make a new self cell and a forward reference *)
+ let comp =
+ { cstruct = isstruct;
+ corig_name = norig;
+ cname = n;
+ ckey = nextCompinfoKey ();
+ cfields = []; (* fields will be added afterwards. *)
+ cattr = a;
+ creferenced = false;
+ (* Make this compinfo undefined by default *)
+ cdefined = false; }
+ in
+ let flds =
+ List.map (fun (fn, ft, fb, fa, fl) ->
+ { fcomp = comp;
+ ftype = ft;
+ forig_name = fn;
+ fname = fn;
+ fbitfield = fb;
+ fattr = fa;
+ floc = fl;
+ faddrof = false;
+ fsize_in_bits = None;
+ foffset_in_bits = None;
+ fpadding_in_bits = None;
+ }) (mkfspec comp) in
+ comp.cfields <- flds;
+ if flds <> [] then comp.cdefined <- true;
+ comp
+
+(** Make a copy of a compinfo, changing the name and the key *)
+let copyCompInfo ?(fresh=true) ci cname =
+ let ckey = if fresh then nextCompinfoKey () else ci.ckey in
+ let ci' = { ci with cname; ckey } in
+ (* Copy the fields and set the new pointers to parents *)
+ ci'.cfields <- List.map (fun f -> {f with fcomp = ci'}) ci'.cfields;
+ ci'
(** Different visiting actions. 'a will be instantiated with [exp], [instr],
etc.
@@ -771,179 +771,179 @@ type 'a visitAction =
| ChangeToPost of 'a * ('a -> 'a)
| ChangeDoChildrenPost of 'a * ('a -> 'a) (** First consider that the entire
- exp is replaced by the first
- parameter. Then continue with
- the children. On return rebuild
- the node if any of the children
- has changed and then apply the
- function on the node *)
+ exp is replaced by the first
+ parameter. Then continue with
+ the children. On return rebuild
+ the node if any of the children
+ has changed and then apply the
+ function on the node *)
type visitor_behavior =
- { (* copy mutable structure which are not shared across the AST*)
- cfile: file -> file;
- cinitinfo: initinfo -> initinfo;
- cblock: block -> block;
- cfunspec: funspec -> funspec;
- cfunbehavior: funbehavior -> funbehavior;
- cidentified_term: identified_term -> identified_term;
- cidentified_predicate: identified_predicate -> identified_predicate;
- cexpr: exp -> exp;
- ccode_annotation: code_annotation -> code_annotation;
- (* get the copy of a shared value *)
- get_stmt: stmt -> stmt;
- get_compinfo: compinfo -> compinfo;
- get_fieldinfo: fieldinfo -> fieldinfo;
- get_model_info: model_info -> model_info;
- get_enuminfo: enuminfo -> enuminfo;
- get_enumitem: enumitem -> enumitem;
- get_typeinfo: typeinfo -> typeinfo;
- get_varinfo: varinfo -> varinfo;
- get_logic_info: logic_info -> logic_info;
- get_logic_type_info: logic_type_info -> logic_type_info;
- get_logic_var: logic_var -> logic_var;
- get_kernel_function: kernel_function -> kernel_function;
- get_fundec: fundec -> fundec;
- (* get the original value tied to a copy *)
- get_original_stmt: stmt -> stmt;
- get_original_compinfo: compinfo -> compinfo;
- get_original_fieldinfo: fieldinfo -> fieldinfo;
- get_original_model_info: model_info -> model_info;
- get_original_enuminfo: enuminfo -> enuminfo;
- get_original_enumitem: enumitem -> enumitem;
- get_original_typeinfo: typeinfo -> typeinfo;
- get_original_varinfo: varinfo -> varinfo;
- get_original_logic_info: logic_info -> logic_info;
- get_original_logic_type_info: logic_type_info -> logic_type_info;
- get_original_logic_var: logic_var -> logic_var;
- get_original_kernel_function: kernel_function -> kernel_function;
- get_original_fundec: fundec -> fundec;
- (* change a binding... use with care *)
- set_stmt: stmt -> stmt -> unit;
- set_compinfo: compinfo -> compinfo -> unit;
- set_fieldinfo: fieldinfo -> fieldinfo -> unit;
- set_model_info: model_info -> model_info -> unit;
- set_enuminfo: enuminfo -> enuminfo -> unit;
- set_enumitem: enumitem -> enumitem -> unit;
- set_typeinfo: typeinfo -> typeinfo -> unit;
- set_varinfo: varinfo -> varinfo -> unit;
- set_logic_info: logic_info -> logic_info -> unit;
- set_logic_type_info: logic_type_info -> logic_type_info -> unit;
- set_logic_var: logic_var -> logic_var -> unit;
- set_kernel_function: kernel_function -> kernel_function -> unit;
- set_fundec: fundec -> fundec -> unit;
- (* change a reference... use with care *)
- set_orig_stmt: stmt -> stmt -> unit;
- set_orig_compinfo: compinfo -> compinfo -> unit;
- set_orig_fieldinfo: fieldinfo -> fieldinfo -> unit;
- set_orig_model_info: model_info -> model_info -> unit;
- set_orig_enuminfo: enuminfo -> enuminfo -> unit;
- set_orig_enumitem: enumitem -> enumitem -> unit;
- set_orig_typeinfo: typeinfo -> typeinfo -> unit;
- set_orig_varinfo: varinfo -> varinfo -> unit;
- set_orig_logic_info: logic_info -> logic_info -> unit;
- set_orig_logic_type_info: logic_type_info -> logic_type_info -> unit;
- set_orig_logic_var: logic_var -> logic_var -> unit;
- set_orig_kernel_function: kernel_function -> kernel_function -> unit;
- set_orig_fundec: fundec -> fundec -> unit;
-
- unset_varinfo: varinfo -> unit;
- unset_compinfo: compinfo -> unit;
- unset_enuminfo: enuminfo -> unit;
- unset_enumitem: enumitem -> unit;
- unset_typeinfo: typeinfo -> unit;
- unset_stmt: stmt -> unit;
- unset_logic_info: logic_info -> unit;
- unset_logic_type_info: logic_type_info -> unit;
- unset_fieldinfo: fieldinfo -> unit;
- unset_model_info: model_info -> unit;
- unset_logic_var: logic_var -> unit;
- unset_kernel_function: kernel_function -> unit;
- unset_fundec: fundec -> unit;
-
- unset_orig_varinfo: varinfo -> unit;
- unset_orig_compinfo: compinfo -> unit;
- unset_orig_enuminfo: enuminfo -> unit;
- unset_orig_enumitem: enumitem -> unit;
- unset_orig_typeinfo: typeinfo -> unit;
- unset_orig_stmt: stmt -> unit;
- unset_orig_logic_info: logic_info -> unit;
- unset_orig_logic_type_info: logic_type_info -> unit;
- unset_orig_fieldinfo: fieldinfo -> unit;
- unset_orig_model_info: model_info -> unit;
- unset_orig_logic_var: logic_var -> unit;
- unset_orig_kernel_function: kernel_function -> unit;
- unset_orig_fundec: fundec -> unit;
-
- (* copy fields that can referenced in other places of the AST*)
- memo_stmt: stmt -> stmt;
- memo_varinfo: varinfo -> varinfo;
- memo_compinfo: compinfo -> compinfo;
- memo_model_info: model_info -> model_info;
- memo_enuminfo: enuminfo -> enuminfo;
- memo_enumitem: enumitem -> enumitem;
- memo_typeinfo: typeinfo -> typeinfo;
- memo_logic_info: logic_info -> logic_info;
- memo_logic_type_info: logic_type_info -> logic_type_info;
- memo_fieldinfo: fieldinfo -> fieldinfo;
- memo_logic_var: logic_var -> logic_var;
- memo_kernel_function: kernel_function -> kernel_function;
- memo_fundec: fundec -> fundec;
- (* is the behavior a copy behavior *)
- is_copy_behavior: bool;
- is_fresh_behavior: bool;
- project: Project.t option;
- (* reset memoizing tables *)
- reset_behavior_varinfo: unit -> unit;
- reset_behavior_compinfo: unit -> unit;
- reset_behavior_enuminfo: unit -> unit;
- reset_behavior_enumitem: unit -> unit;
- reset_behavior_typeinfo: unit -> unit;
- reset_behavior_logic_info: unit -> unit;
- reset_behavior_logic_type_info: unit -> unit;
- reset_behavior_fieldinfo: unit -> unit;
- reset_behavior_model_info: unit -> unit;
- reset_behavior_stmt: unit -> unit;
- reset_logic_var: unit -> unit;
- reset_behavior_kernel_function: unit -> unit;
- reset_behavior_fundec: unit -> unit;
- (* iterates over tables *)
- iter_visitor_varinfo: (varinfo -> varinfo -> unit) -> unit;
- iter_visitor_compinfo: (compinfo -> compinfo -> unit) -> unit;
- iter_visitor_enuminfo: (enuminfo -> enuminfo -> unit) -> unit;
- iter_visitor_enumitem: (enumitem -> enumitem -> unit) -> unit;
- iter_visitor_typeinfo: (typeinfo -> typeinfo -> unit) -> unit;
- iter_visitor_stmt: (stmt -> stmt -> unit) -> unit;
- iter_visitor_logic_info: (logic_info -> logic_info -> unit) -> unit;
- iter_visitor_logic_type_info:
- (logic_type_info -> logic_type_info -> unit) -> unit;
- iter_visitor_fieldinfo: (fieldinfo -> fieldinfo -> unit) -> unit;
- iter_visitor_model_info: (model_info -> model_info -> unit) -> unit;
- iter_visitor_logic_var: (logic_var -> logic_var -> unit) -> unit;
- iter_visitor_kernel_function:
- (kernel_function -> kernel_function -> unit) -> unit;
- iter_visitor_fundec: (fundec -> fundec -> unit) -> unit;
- (* folds over tables *)
- fold_visitor_varinfo: 'a.(varinfo -> varinfo -> 'a -> 'a) -> 'a -> 'a;
- fold_visitor_compinfo: 'a.(compinfo -> compinfo -> 'a -> 'a) -> 'a -> 'a;
- fold_visitor_enuminfo: 'a.(enuminfo -> enuminfo -> 'a -> 'a) -> 'a -> 'a;
- fold_visitor_enumitem: 'a.(enumitem -> enumitem -> 'a -> 'a) -> 'a -> 'a;
- fold_visitor_typeinfo: 'a.(typeinfo -> typeinfo -> 'a -> 'a) -> 'a -> 'a;
- fold_visitor_stmt: 'a.(stmt -> stmt -> 'a -> 'a) -> 'a -> 'a;
- fold_visitor_logic_info:
- 'a. (logic_info -> logic_info -> 'a -> 'a) -> 'a -> 'a;
- fold_visitor_logic_type_info:
- 'a.(logic_type_info -> logic_type_info -> 'a -> 'a) -> 'a -> 'a;
- fold_visitor_fieldinfo:
- 'a.(fieldinfo -> fieldinfo -> 'a -> 'a) -> 'a -> 'a;
- fold_visitor_model_info:
- 'a. (model_info -> model_info -> 'a -> 'a) -> 'a -> 'a;
- fold_visitor_logic_var:
- 'a.(logic_var -> logic_var -> 'a -> 'a) -> 'a -> 'a;
- fold_visitor_kernel_function:
- 'a.(kernel_function -> kernel_function -> 'a -> 'a) -> 'a -> 'a;
- fold_visitor_fundec:
- 'a.(fundec -> fundec -> 'a -> 'a) -> 'a -> 'a;
- }
+ { (* copy mutable structure which are not shared across the AST*)
+ cfile: file -> file;
+ cinitinfo: initinfo -> initinfo;
+ cblock: block -> block;
+ cfunspec: funspec -> funspec;
+ cfunbehavior: funbehavior -> funbehavior;
+ cidentified_term: identified_term -> identified_term;
+ cidentified_predicate: identified_predicate -> identified_predicate;
+ cexpr: exp -> exp;
+ ccode_annotation: code_annotation -> code_annotation;
+ (* get the copy of a shared value *)
+ get_stmt: stmt -> stmt;
+ get_compinfo: compinfo -> compinfo;
+ get_fieldinfo: fieldinfo -> fieldinfo;
+ get_model_info: model_info -> model_info;
+ get_enuminfo: enuminfo -> enuminfo;
+ get_enumitem: enumitem -> enumitem;
+ get_typeinfo: typeinfo -> typeinfo;
+ get_varinfo: varinfo -> varinfo;
+ get_logic_info: logic_info -> logic_info;
+ get_logic_type_info: logic_type_info -> logic_type_info;
+ get_logic_var: logic_var -> logic_var;
+ get_kernel_function: kernel_function -> kernel_function;
+ get_fundec: fundec -> fundec;
+ (* get the original value tied to a copy *)
+ get_original_stmt: stmt -> stmt;
+ get_original_compinfo: compinfo -> compinfo;
+ get_original_fieldinfo: fieldinfo -> fieldinfo;
+ get_original_model_info: model_info -> model_info;
+ get_original_enuminfo: enuminfo -> enuminfo;
+ get_original_enumitem: enumitem -> enumitem;
+ get_original_typeinfo: typeinfo -> typeinfo;
+ get_original_varinfo: varinfo -> varinfo;
+ get_original_logic_info: logic_info -> logic_info;
+ get_original_logic_type_info: logic_type_info -> logic_type_info;
+ get_original_logic_var: logic_var -> logic_var;
+ get_original_kernel_function: kernel_function -> kernel_function;
+ get_original_fundec: fundec -> fundec;
+ (* change a binding... use with care *)
+ set_stmt: stmt -> stmt -> unit;
+ set_compinfo: compinfo -> compinfo -> unit;
+ set_fieldinfo: fieldinfo -> fieldinfo -> unit;
+ set_model_info: model_info -> model_info -> unit;
+ set_enuminfo: enuminfo -> enuminfo -> unit;
+ set_enumitem: enumitem -> enumitem -> unit;
+ set_typeinfo: typeinfo -> typeinfo -> unit;
+ set_varinfo: varinfo -> varinfo -> unit;
+ set_logic_info: logic_info -> logic_info -> unit;
+ set_logic_type_info: logic_type_info -> logic_type_info -> unit;
+ set_logic_var: logic_var -> logic_var -> unit;
+ set_kernel_function: kernel_function -> kernel_function -> unit;
+ set_fundec: fundec -> fundec -> unit;
+ (* change a reference... use with care *)
+ set_orig_stmt: stmt -> stmt -> unit;
+ set_orig_compinfo: compinfo -> compinfo -> unit;
+ set_orig_fieldinfo: fieldinfo -> fieldinfo -> unit;
+ set_orig_model_info: model_info -> model_info -> unit;
+ set_orig_enuminfo: enuminfo -> enuminfo -> unit;
+ set_orig_enumitem: enumitem -> enumitem -> unit;
+ set_orig_typeinfo: typeinfo -> typeinfo -> unit;
+ set_orig_varinfo: varinfo -> varinfo -> unit;
+ set_orig_logic_info: logic_info -> logic_info -> unit;
+ set_orig_logic_type_info: logic_type_info -> logic_type_info -> unit;
+ set_orig_logic_var: logic_var -> logic_var -> unit;
+ set_orig_kernel_function: kernel_function -> kernel_function -> unit;
+ set_orig_fundec: fundec -> fundec -> unit;
+
+ unset_varinfo: varinfo -> unit;
+ unset_compinfo: compinfo -> unit;
+ unset_enuminfo: enuminfo -> unit;
+ unset_enumitem: enumitem -> unit;
+ unset_typeinfo: typeinfo -> unit;
+ unset_stmt: stmt -> unit;
+ unset_logic_info: logic_info -> unit;
+ unset_logic_type_info: logic_type_info -> unit;
+ unset_fieldinfo: fieldinfo -> unit;
+ unset_model_info: model_info -> unit;
+ unset_logic_var: logic_var -> unit;
+ unset_kernel_function: kernel_function -> unit;
+ unset_fundec: fundec -> unit;
+
+ unset_orig_varinfo: varinfo -> unit;
+ unset_orig_compinfo: compinfo -> unit;
+ unset_orig_enuminfo: enuminfo -> unit;
+ unset_orig_enumitem: enumitem -> unit;
+ unset_orig_typeinfo: typeinfo -> unit;
+ unset_orig_stmt: stmt -> unit;
+ unset_orig_logic_info: logic_info -> unit;
+ unset_orig_logic_type_info: logic_type_info -> unit;
+ unset_orig_fieldinfo: fieldinfo -> unit;
+ unset_orig_model_info: model_info -> unit;
+ unset_orig_logic_var: logic_var -> unit;
+ unset_orig_kernel_function: kernel_function -> unit;
+ unset_orig_fundec: fundec -> unit;
+
+ (* copy fields that can referenced in other places of the AST*)
+ memo_stmt: stmt -> stmt;
+ memo_varinfo: varinfo -> varinfo;
+ memo_compinfo: compinfo -> compinfo;
+ memo_model_info: model_info -> model_info;
+ memo_enuminfo: enuminfo -> enuminfo;
+ memo_enumitem: enumitem -> enumitem;
+ memo_typeinfo: typeinfo -> typeinfo;
+ memo_logic_info: logic_info -> logic_info;
+ memo_logic_type_info: logic_type_info -> logic_type_info;
+ memo_fieldinfo: fieldinfo -> fieldinfo;
+ memo_logic_var: logic_var -> logic_var;
+ memo_kernel_function: kernel_function -> kernel_function;
+ memo_fundec: fundec -> fundec;
+ (* is the behavior a copy behavior *)
+ is_copy_behavior: bool;
+ is_fresh_behavior: bool;
+ project: Project.t option;
+ (* reset memoizing tables *)
+ reset_behavior_varinfo: unit -> unit;
+ reset_behavior_compinfo: unit -> unit;
+ reset_behavior_enuminfo: unit -> unit;
+ reset_behavior_enumitem: unit -> unit;
+ reset_behavior_typeinfo: unit -> unit;
+ reset_behavior_logic_info: unit -> unit;
+ reset_behavior_logic_type_info: unit -> unit;
+ reset_behavior_fieldinfo: unit -> unit;
+ reset_behavior_model_info: unit -> unit;
+ reset_behavior_stmt: unit -> unit;
+ reset_logic_var: unit -> unit;
+ reset_behavior_kernel_function: unit -> unit;
+ reset_behavior_fundec: unit -> unit;
+ (* iterates over tables *)
+ iter_visitor_varinfo: (varinfo -> varinfo -> unit) -> unit;
+ iter_visitor_compinfo: (compinfo -> compinfo -> unit) -> unit;
+ iter_visitor_enuminfo: (enuminfo -> enuminfo -> unit) -> unit;
+ iter_visitor_enumitem: (enumitem -> enumitem -> unit) -> unit;
+ iter_visitor_typeinfo: (typeinfo -> typeinfo -> unit) -> unit;
+ iter_visitor_stmt: (stmt -> stmt -> unit) -> unit;
+ iter_visitor_logic_info: (logic_info -> logic_info -> unit) -> unit;
+ iter_visitor_logic_type_info:
+ (logic_type_info -> logic_type_info -> unit) -> unit;
+ iter_visitor_fieldinfo: (fieldinfo -> fieldinfo -> unit) -> unit;
+ iter_visitor_model_info: (model_info -> model_info -> unit) -> unit;
+ iter_visitor_logic_var: (logic_var -> logic_var -> unit) -> unit;
+ iter_visitor_kernel_function:
+ (kernel_function -> kernel_function -> unit) -> unit;
+ iter_visitor_fundec: (fundec -> fundec -> unit) -> unit;
+ (* folds over tables *)
+ fold_visitor_varinfo: 'a.(varinfo -> varinfo -> 'a -> 'a) -> 'a -> 'a;
+ fold_visitor_compinfo: 'a.(compinfo -> compinfo -> 'a -> 'a) -> 'a -> 'a;
+ fold_visitor_enuminfo: 'a.(enuminfo -> enuminfo -> 'a -> 'a) -> 'a -> 'a;
+ fold_visitor_enumitem: 'a.(enumitem -> enumitem -> 'a -> 'a) -> 'a -> 'a;
+ fold_visitor_typeinfo: 'a.(typeinfo -> typeinfo -> 'a -> 'a) -> 'a -> 'a;
+ fold_visitor_stmt: 'a.(stmt -> stmt -> 'a -> 'a) -> 'a -> 'a;
+ fold_visitor_logic_info:
+ 'a. (logic_info -> logic_info -> 'a -> 'a) -> 'a -> 'a;
+ fold_visitor_logic_type_info:
+ 'a.(logic_type_info -> logic_type_info -> 'a -> 'a) -> 'a -> 'a;
+ fold_visitor_fieldinfo:
+ 'a.(fieldinfo -> fieldinfo -> 'a -> 'a) -> 'a -> 'a;
+ fold_visitor_model_info:
+ 'a. (model_info -> model_info -> 'a -> 'a) -> 'a -> 'a;
+ fold_visitor_logic_var:
+ 'a.(logic_var -> logic_var -> 'a -> 'a) -> 'a -> 'a;
+ fold_visitor_kernel_function:
+ 'a.(kernel_function -> kernel_function -> 'a -> 'a) -> 'a -> 'a;
+ fold_visitor_fundec:
+ 'a.(fundec -> fundec -> 'a -> 'a) -> 'a -> 'a;
+ }
let is_copy_behavior b = b.is_copy_behavior
@@ -1270,10 +1270,10 @@ let copy_visit_gen fresh prj =
let orig_kernel_functions = Cil_datatype.Kf.Hashtbl.create 17 in
let orig_fundecs = Cil_datatype.Varinfo.Hashtbl.create 17 in
let temp_set_logic_var x new_x =
- Cil_datatype.Logic_var.Hashtbl.add logic_vars x new_x
+ Cil_datatype.Logic_var.Hashtbl.add logic_vars x new_x
in
let temp_set_orig_logic_var new_x x =
- Cil_datatype.Logic_var.Hashtbl.add orig_logic_vars new_x x
+ Cil_datatype.Logic_var.Hashtbl.add orig_logic_vars new_x x
in
let temp_unset_logic_var x =
Cil_datatype.Logic_var.Hashtbl.remove logic_vars x
@@ -1282,31 +1282,31 @@ let copy_visit_gen fresh prj =
Cil_datatype.Logic_var.Hashtbl.remove orig_logic_vars new_x
in
let temp_memo_logic_var x =
-(* Format.printf "search for %s#%d@." x.lv_name x.lv_id;*)
+ (* Format.printf "search for %s#%d@." x.lv_name x.lv_id;*)
let res =
- try Cil_datatype.Logic_var.Hashtbl.find logic_vars x
- with Not_found ->
-(* Format.printf "Not found@.";*)
- let id = if fresh then Cil_const.new_raw_id () else x.lv_id in
- let new_x = { x with lv_id = id } in
- temp_set_logic_var x new_x; temp_set_orig_logic_var new_x x; new_x
+ try Cil_datatype.Logic_var.Hashtbl.find logic_vars x
+ with Not_found ->
+ (* Format.printf "Not found@.";*)
+ let id = if fresh then Cil_const.new_raw_id () else x.lv_id in
+ let new_x = { x with lv_id = id } in
+ temp_set_logic_var x new_x; temp_set_orig_logic_var new_x x; new_x
in
-(* Format.printf "res is %s#%d@." res.lv_name res.lv_id;*)
+ (* Format.printf "res is %s#%d@." res.lv_name res.lv_id;*)
res
in
let temp_set_varinfo x new_x =
Cil_datatype.Varinfo.Hashtbl.add varinfos x new_x;
match x.vlogic_var_assoc, new_x.vlogic_var_assoc with
- | None, _ | _, None -> ()
- | Some lx, Some new_lx ->
- Cil_datatype.Logic_var.Hashtbl.add logic_vars lx new_lx
+ | None, _ | _, None -> ()
+ | Some lx, Some new_lx ->
+ Cil_datatype.Logic_var.Hashtbl.add logic_vars lx new_lx
in
let temp_set_orig_varinfo new_x x =
Cil_datatype.Varinfo.Hashtbl.add orig_varinfos new_x x;
match new_x.vlogic_var_assoc, x.vlogic_var_assoc with
- | None, _ | _, None -> ()
- | Some new_lx, Some lx ->
- Cil_datatype.Logic_var.Hashtbl.add orig_logic_vars new_lx lx
+ | None, _ | _, None -> ()
+ | Some new_lx, Some lx ->
+ Cil_datatype.Logic_var.Hashtbl.add orig_logic_vars new_lx lx
in
let temp_unset_varinfo x =
Cil_datatype.Varinfo.Hashtbl.remove varinfos x;
@@ -1317,9 +1317,9 @@ let copy_visit_gen fresh prj =
let temp_unset_orig_varinfo new_x =
Cil_datatype.Varinfo.Hashtbl.remove orig_varinfos new_x;
match new_x.vlogic_var_assoc with
- | None -> ()
- | Some new_lx ->
- Cil_datatype.Logic_var.Hashtbl.remove orig_logic_vars new_lx
+ | None -> ()
+ | Some new_lx ->
+ Cil_datatype.Logic_var.Hashtbl.remove orig_logic_vars new_lx
in
let temp_memo_varinfo x =
try Cil_datatype.Varinfo.Hashtbl.find varinfos x
@@ -1328,10 +1328,10 @@ let copy_visit_gen fresh prj =
if fresh then Cil_const.copy_with_new_vid x else begin
let new_x = { x with vid = x.vid } in
(match x.vlogic_var_assoc with
- | None -> ()
- | Some lv ->
- let new_lv = { lv with lv_origin = Some new_x } in
- new_x.vlogic_var_assoc <- Some new_lv);
+ | None -> ()
+ | Some lv ->
+ let new_lv = { lv with lv_origin = Some new_x } in
+ new_x.vlogic_var_assoc <- Some new_lv);
new_x
end
in
@@ -1359,46 +1359,46 @@ let copy_visit_gen fresh prj =
let temp_set_kernel_function kf new_kf =
Cil_datatype.Kf.Hashtbl.replace kernel_functions kf new_kf;
match kf.fundec, new_kf.fundec with
- | Declaration(_,vi,_,_), Declaration(_,new_vi,_,_)
- | Declaration(_,vi,_,_), Definition({ svar = new_vi }, _)
- | Definition({svar = vi},_), Declaration(_,new_vi,_,_) ->
- temp_set_varinfo vi new_vi
- | Definition (fundec,_), Definition(new_fundec,_) ->
- temp_set_fundec fundec new_fundec
+ | Declaration(_,vi,_,_), Declaration(_,new_vi,_,_)
+ | Declaration(_,vi,_,_), Definition({ svar = new_vi }, _)
+ | Definition({svar = vi},_), Declaration(_,new_vi,_,_) ->
+ temp_set_varinfo vi new_vi
+ | Definition (fundec,_), Definition(new_fundec,_) ->
+ temp_set_fundec fundec new_fundec
in
let temp_set_orig_kernel_function new_kf kf =
Cil_datatype.Kf.Hashtbl.replace orig_kernel_functions new_kf kf;
match new_kf.fundec, kf.fundec with
- | Declaration(_,new_vi,_,_), Declaration(_,vi,_,_)
- | Declaration(_,new_vi,_,_), Definition({ svar = vi }, _)
- | Definition({svar = new_vi},_), Declaration(_,vi,_,_) ->
- temp_set_orig_varinfo new_vi vi
- | Definition (new_fundec,_), Definition(fundec,_) ->
- temp_set_orig_fundec new_fundec fundec
+ | Declaration(_,new_vi,_,_), Declaration(_,vi,_,_)
+ | Declaration(_,new_vi,_,_), Definition({ svar = vi }, _)
+ | Definition({svar = new_vi},_), Declaration(_,vi,_,_) ->
+ temp_set_orig_varinfo new_vi vi
+ | Definition (new_fundec,_), Definition(fundec,_) ->
+ temp_set_orig_fundec new_fundec fundec
in
let temp_unset_kernel_function kf =
Cil_datatype.Kf.Hashtbl.remove kernel_functions kf;
match kf.fundec with
- | Declaration(_,vi,_,_) -> temp_unset_varinfo vi
- | Definition (fundec,_) -> temp_unset_fundec fundec
+ | Declaration(_,vi,_,_) -> temp_unset_varinfo vi
+ | Definition (fundec,_) -> temp_unset_fundec fundec
in
let temp_unset_orig_kernel_function new_kf =
Cil_datatype.Kf.Hashtbl.remove orig_kernel_functions new_kf;
match new_kf.fundec with
- | Declaration(_,new_vi,_,_) -> temp_unset_orig_varinfo new_vi
- | Definition (new_fundec,_) -> temp_unset_orig_fundec new_fundec
+ | Declaration(_,new_vi,_,_) -> temp_unset_orig_varinfo new_vi
+ | Definition (new_fundec,_) -> temp_unset_orig_fundec new_fundec
in
let temp_memo_kernel_function kf =
try Cil_datatype.Kf.Hashtbl.find kernel_functions kf
with Not_found ->
let new_kf =
match kf.fundec with
- | Declaration (spec,vi,prms,loc) ->
- let new_vi = temp_memo_varinfo vi in
- { kf with fundec = Declaration(spec,new_vi,prms,loc) }
- | Definition(f,loc) ->
- let new_f = temp_memo_fundec f in
- { kf with fundec = Definition(new_f,loc) }
+ | Declaration (spec,vi,prms,loc) ->
+ let new_vi = temp_memo_varinfo vi in
+ { kf with fundec = Declaration(spec,new_vi,prms,loc) }
+ | Definition(f,loc) ->
+ let new_f = temp_memo_fundec f in
+ { kf with fundec = Definition(new_f,loc) }
in
temp_set_kernel_function kf new_kf;
temp_set_orig_kernel_function new_kf kf;
@@ -1412,10 +1412,10 @@ let copy_visit_gen fresh prj =
in
let temp_set_orig_compinfo new_c c =
Cil_datatype.Compinfo.Hashtbl.add orig_compinfos new_c c;
- List.iter2
- (fun new_f f ->
- Cil_datatype.Fieldinfo.Hashtbl.add orig_fieldinfos new_f f)
- new_c.cfields c.cfields
+ List.iter2
+ (fun new_f f ->
+ Cil_datatype.Fieldinfo.Hashtbl.add orig_fieldinfos new_f f)
+ new_c.cfields c.cfields
in
let temp_unset_compinfo c =
Cil_datatype.Compinfo.Hashtbl.remove compinfos c;
@@ -1424,10 +1424,10 @@ let copy_visit_gen fresh prj =
in
let temp_unset_orig_compinfo new_c =
Cil_datatype.Compinfo.Hashtbl.remove orig_compinfos new_c;
- List.iter
- (fun new_f ->
- Cil_datatype.Fieldinfo.Hashtbl.remove orig_fieldinfos new_f)
- new_c.cfields
+ List.iter
+ (fun new_f ->
+ Cil_datatype.Fieldinfo.Hashtbl.remove orig_fieldinfos new_f)
+ new_c.cfields
in
let temp_memo_compinfo c =
try Cil_datatype.Compinfo.Hashtbl.find compinfos c
@@ -1439,101 +1439,101 @@ let copy_visit_gen fresh prj =
in
{ cfile = (fun x -> { x with fileName = x.fileName });
get_compinfo =
- (fun x ->
- try Cil_datatype.Compinfo.Hashtbl.find compinfos x with Not_found -> x);
+ (fun x ->
+ try Cil_datatype.Compinfo.Hashtbl.find compinfos x with Not_found -> x);
get_fieldinfo =
- (fun x ->
- try Cil_datatype.Fieldinfo.Hashtbl.find fieldinfos x
- with Not_found -> x);
+ (fun x ->
+ try Cil_datatype.Fieldinfo.Hashtbl.find fieldinfos x
+ with Not_found -> x);
get_model_info =
(fun x ->
- try Cil_datatype.Model_info.Hashtbl.find model_infos x
- with Not_found -> x);
+ try Cil_datatype.Model_info.Hashtbl.find model_infos x
+ with Not_found -> x);
get_enuminfo =
- (fun x ->
- try Cil_datatype.Enuminfo.Hashtbl.find enuminfos x with Not_found -> x);
+ (fun x ->
+ try Cil_datatype.Enuminfo.Hashtbl.find enuminfos x with Not_found -> x);
get_enumitem =
(fun x ->
- try Cil_datatype.Enumitem.Hashtbl.find enumitems x with Not_found -> x);
+ try Cil_datatype.Enumitem.Hashtbl.find enumitems x with Not_found -> x);
get_typeinfo =
(fun x ->
- try Cil_datatype.Typeinfo.Hashtbl.find typeinfos x with Not_found -> x);
+ try Cil_datatype.Typeinfo.Hashtbl.find typeinfos x with Not_found -> x);
get_varinfo =
(fun x ->
- try Cil_datatype.Varinfo.Hashtbl.find varinfos x with Not_found -> x);
+ try Cil_datatype.Varinfo.Hashtbl.find varinfos x with Not_found -> x);
get_stmt =
(fun x -> try Cil_datatype.Stmt.Hashtbl.find stmts x with Not_found -> x);
get_logic_info =
(fun x ->
- try Cil_datatype.Logic_info.Hashtbl.find logic_infos x
- with Not_found -> x);
+ try Cil_datatype.Logic_info.Hashtbl.find logic_infos x
+ with Not_found -> x);
get_logic_type_info =
(fun x ->
- try Cil_datatype.Logic_type_info.Hashtbl.find logic_type_infos x
- with Not_found -> x);
+ try Cil_datatype.Logic_type_info.Hashtbl.find logic_type_infos x
+ with Not_found -> x);
get_logic_var =
(fun x ->
- try Cil_datatype.Logic_var.Hashtbl.find logic_vars x
- with Not_found -> x);
+ try Cil_datatype.Logic_var.Hashtbl.find logic_vars x
+ with Not_found -> x);
get_kernel_function =
(fun x ->
- try Cil_datatype.Kf.Hashtbl.find kernel_functions x
- with Not_found -> x);
+ try Cil_datatype.Kf.Hashtbl.find kernel_functions x
+ with Not_found -> x);
get_fundec =
(fun x ->
- try Cil_datatype.Varinfo.Hashtbl.find fundecs x.svar
- with Not_found -> x);
+ try Cil_datatype.Varinfo.Hashtbl.find fundecs x.svar
+ with Not_found -> x);
get_original_compinfo =
(fun x ->
- try Cil_datatype.Compinfo.Hashtbl.find orig_compinfos x
- with Not_found -> x);
+ try Cil_datatype.Compinfo.Hashtbl.find orig_compinfos x
+ with Not_found -> x);
get_original_fieldinfo =
(fun x ->
- try Cil_datatype.Fieldinfo.Hashtbl.find orig_fieldinfos x
- with Not_found -> x);
+ try Cil_datatype.Fieldinfo.Hashtbl.find orig_fieldinfos x
+ with Not_found -> x);
get_original_model_info =
(fun x ->
- try Cil_datatype.Model_info.Hashtbl.find orig_model_infos x
- with Not_found -> x);
+ try Cil_datatype.Model_info.Hashtbl.find orig_model_infos x
+ with Not_found -> x);
get_original_enuminfo =
(fun x ->
- try Cil_datatype.Enuminfo.Hashtbl.find orig_enuminfos x
- with Not_found -> x);
+ try Cil_datatype.Enuminfo.Hashtbl.find orig_enuminfos x
+ with Not_found -> x);
get_original_enumitem =
(fun x ->
- try Cil_datatype.Enumitem.Hashtbl.find orig_enumitems x
- with Not_found -> x);
+ try Cil_datatype.Enumitem.Hashtbl.find orig_enumitems x
+ with Not_found -> x);
get_original_typeinfo =
(fun x ->
- try Cil_datatype.Typeinfo.Hashtbl.find orig_typeinfos x
- with Not_found -> x);
+ try Cil_datatype.Typeinfo.Hashtbl.find orig_typeinfos x
+ with Not_found -> x);
get_original_varinfo =
(fun x ->
- try Cil_datatype.Varinfo.Hashtbl.find orig_varinfos x
- with Not_found -> x);
+ try Cil_datatype.Varinfo.Hashtbl.find orig_varinfos x
+ with Not_found -> x);
get_original_stmt =
(fun x ->
- try Cil_datatype.Stmt.Hashtbl.find orig_stmts x with Not_found -> x);
+ try Cil_datatype.Stmt.Hashtbl.find orig_stmts x with Not_found -> x);
get_original_logic_var =
(fun x ->
- try Cil_datatype.Logic_var.Hashtbl.find orig_logic_vars x
- with Not_found -> x);
+ try Cil_datatype.Logic_var.Hashtbl.find orig_logic_vars x
+ with Not_found -> x);
get_original_logic_info =
- (fun x ->
- try Cil_datatype.Logic_info.Hashtbl.find orig_logic_infos x
- with Not_found -> x);
+ (fun x ->
+ try Cil_datatype.Logic_info.Hashtbl.find orig_logic_infos x
+ with Not_found -> x);
get_original_logic_type_info =
(fun x ->
- try Cil_datatype.Logic_type_info.Hashtbl.find orig_logic_type_infos x
- with Not_found -> x);
+ try Cil_datatype.Logic_type_info.Hashtbl.find orig_logic_type_infos x
+ with Not_found -> x);
get_original_kernel_function =
(fun x ->
- try Cil_datatype.Kf.Hashtbl.find orig_kernel_functions x
- with Not_found -> x);
+ try Cil_datatype.Kf.Hashtbl.find orig_kernel_functions x
+ with Not_found -> x);
get_original_fundec =
(fun x ->
- try Cil_datatype.Varinfo.Hashtbl.find orig_fundecs x.svar
- with Not_found -> x);
+ try Cil_datatype.Varinfo.Hashtbl.find orig_fundecs x.svar
+ with Not_found -> x);
cinitinfo = (fun x -> { init = x.init });
cblock = (fun x -> { x with battrs = x.battrs });
cfunspec = (fun x -> { x with spec_behavior = x.spec_behavior});
@@ -1549,62 +1549,62 @@ let copy_visit_gen fresh prj =
else (fun x -> { x with it_id = x.it_id});
cexpr =
(fun x ->
- let id = if fresh then Eid.next () else x.eid in { x with eid = id });
+ let id = if fresh then Eid.next () else x.eid in { x with eid = id });
is_copy_behavior = true;
is_fresh_behavior = fresh;
project = Some prj;
reset_behavior_varinfo =
(fun () ->
- Cil_datatype.Varinfo.Hashtbl.clear varinfos;
- Cil_datatype.Varinfo.Hashtbl.clear orig_varinfos);
+ Cil_datatype.Varinfo.Hashtbl.clear varinfos;
+ Cil_datatype.Varinfo.Hashtbl.clear orig_varinfos);
reset_behavior_compinfo =
(fun () ->
- Cil_datatype.Compinfo.Hashtbl.clear compinfos;
- Cil_datatype.Compinfo.Hashtbl.clear orig_compinfos);
+ Cil_datatype.Compinfo.Hashtbl.clear compinfos;
+ Cil_datatype.Compinfo.Hashtbl.clear orig_compinfos);
reset_behavior_enuminfo =
(fun () ->
- Cil_datatype.Enuminfo.Hashtbl.clear enuminfos;
- Cil_datatype.Enuminfo.Hashtbl.clear orig_enuminfos);
+ Cil_datatype.Enuminfo.Hashtbl.clear enuminfos;
+ Cil_datatype.Enuminfo.Hashtbl.clear orig_enuminfos);
reset_behavior_enumitem =
(fun () ->
- Cil_datatype.Enumitem.Hashtbl.clear enumitems;
- Cil_datatype.Enumitem.Hashtbl.clear orig_enumitems);
+ Cil_datatype.Enumitem.Hashtbl.clear enumitems;
+ Cil_datatype.Enumitem.Hashtbl.clear orig_enumitems);
reset_behavior_typeinfo =
(fun () ->
- Cil_datatype.Typeinfo.Hashtbl.clear typeinfos;
- Cil_datatype.Typeinfo.Hashtbl.clear orig_typeinfos);
+ Cil_datatype.Typeinfo.Hashtbl.clear typeinfos;
+ Cil_datatype.Typeinfo.Hashtbl.clear orig_typeinfos);
reset_behavior_logic_info =
(fun () ->
- Cil_datatype.Logic_info.Hashtbl.clear logic_infos;
- Cil_datatype.Logic_info.Hashtbl.clear orig_logic_infos);
+ Cil_datatype.Logic_info.Hashtbl.clear logic_infos;
+ Cil_datatype.Logic_info.Hashtbl.clear orig_logic_infos);
reset_behavior_logic_type_info =
(fun () ->
- Cil_datatype.Logic_type_info.Hashtbl.clear logic_type_infos;
- Cil_datatype.Logic_type_info.Hashtbl.clear orig_logic_type_infos);
+ Cil_datatype.Logic_type_info.Hashtbl.clear logic_type_infos;
+ Cil_datatype.Logic_type_info.Hashtbl.clear orig_logic_type_infos);
reset_behavior_fieldinfo =
(fun () ->
- Cil_datatype.Fieldinfo.Hashtbl.clear fieldinfos;
- Cil_datatype.Fieldinfo.Hashtbl.clear orig_fieldinfos);
+ Cil_datatype.Fieldinfo.Hashtbl.clear fieldinfos;
+ Cil_datatype.Fieldinfo.Hashtbl.clear orig_fieldinfos);
reset_behavior_model_info =
(fun () ->
- Cil_datatype.Model_info.Hashtbl.clear model_infos;
- Cil_datatype.Model_info.Hashtbl.clear orig_model_infos);
+ Cil_datatype.Model_info.Hashtbl.clear model_infos;
+ Cil_datatype.Model_info.Hashtbl.clear orig_model_infos);
reset_behavior_stmt =
(fun () ->
- Cil_datatype.Stmt.Hashtbl.clear stmts;
- Cil_datatype.Stmt.Hashtbl.clear orig_stmts);
+ Cil_datatype.Stmt.Hashtbl.clear stmts;
+ Cil_datatype.Stmt.Hashtbl.clear orig_stmts);
reset_logic_var =
(fun () ->
- Cil_datatype.Logic_var.Hashtbl.clear logic_vars;
- Cil_datatype.Logic_var.Hashtbl.clear orig_logic_vars);
+ Cil_datatype.Logic_var.Hashtbl.clear logic_vars;
+ Cil_datatype.Logic_var.Hashtbl.clear orig_logic_vars);
reset_behavior_kernel_function =
(fun () ->
- Cil_datatype.Kf.Hashtbl.clear kernel_functions;
- Cil_datatype.Kf.Hashtbl.clear orig_kernel_functions);
+ Cil_datatype.Kf.Hashtbl.clear kernel_functions;
+ Cil_datatype.Kf.Hashtbl.clear orig_kernel_functions);
reset_behavior_fundec =
(fun () ->
- Cil_datatype.Varinfo.Hashtbl.clear fundecs;
- Cil_datatype.Varinfo.Hashtbl.clear orig_fundecs);
+ Cil_datatype.Varinfo.Hashtbl.clear fundecs;
+ Cil_datatype.Varinfo.Hashtbl.clear orig_fundecs);
memo_varinfo = temp_memo_varinfo;
memo_compinfo = temp_memo_compinfo;
memo_enuminfo =
@@ -1635,7 +1635,7 @@ let copy_visit_gen fresh prj =
(fun x ->
try Cil_datatype.Logic_info.Hashtbl.find logic_infos x
with Not_found ->
- let new_v = temp_memo_logic_var x.l_var_info in
+ let new_v = temp_memo_logic_var x.l_var_info in
let new_x = { x with l_var_info = new_v } in
Cil_datatype.Logic_info.Hashtbl.add logic_infos x new_x;
Cil_datatype.Logic_info.Hashtbl.add orig_logic_infos new_x x;
@@ -1670,12 +1670,12 @@ let copy_visit_gen fresh prj =
new_x);
memo_model_info =
(fun x ->
- try Cil_datatype.Model_info.Hashtbl.find model_infos x
- with Not_found ->
- let new_x = { x with mi_name = x.mi_name } in
- Cil_datatype.Model_info.Hashtbl.add model_infos x new_x;
- Cil_datatype.Model_info.Hashtbl.add orig_model_infos new_x x;
- new_x
+ try Cil_datatype.Model_info.Hashtbl.find model_infos x
+ with Not_found ->
+ let new_x = { x with mi_name = x.mi_name } in
+ Cil_datatype.Model_info.Hashtbl.add model_infos x new_x;
+ Cil_datatype.Model_info.Hashtbl.add orig_model_infos new_x x;
+ new_x
);
memo_logic_var = temp_memo_logic_var;
memo_kernel_function = temp_memo_kernel_function;
@@ -1686,7 +1686,7 @@ let copy_visit_gen fresh prj =
set_enumitem = Cil_datatype.Enumitem.Hashtbl.replace enumitems;
set_typeinfo = Cil_datatype.Typeinfo.Hashtbl.replace typeinfos;
set_logic_info = Cil_datatype.Logic_info.Hashtbl.replace logic_infos;
- set_logic_type_info =
+ set_logic_type_info =
Cil_datatype.Logic_type_info.Hashtbl.replace logic_type_infos;
set_stmt = Cil_datatype.Stmt.Hashtbl.replace stmts;
set_fieldinfo = Cil_datatype.Fieldinfo.Hashtbl.replace fieldinfos;
@@ -1745,23 +1745,23 @@ let copy_visit_gen fresh prj =
unset_orig_kernel_function = temp_unset_orig_kernel_function;
unset_orig_fundec = temp_unset_orig_fundec;
- iter_visitor_varinfo =
+ iter_visitor_varinfo =
(fun f -> Cil_datatype.Varinfo.Hashtbl.iter f varinfos);
iter_visitor_compinfo =
(fun f -> Cil_datatype.Compinfo.Hashtbl.iter f compinfos);
- iter_visitor_enuminfo =
+ iter_visitor_enuminfo =
(fun f -> Cil_datatype.Enuminfo.Hashtbl.iter f enuminfos);
- iter_visitor_enumitem =
+ iter_visitor_enumitem =
(fun f -> Cil_datatype.Enumitem.Hashtbl.iter f enumitems);
iter_visitor_typeinfo =
(fun f -> Cil_datatype.Typeinfo.Hashtbl.iter f typeinfos);
- iter_visitor_stmt =
+ iter_visitor_stmt =
(fun f -> Cil_datatype.Stmt.Hashtbl.iter f stmts);
- iter_visitor_logic_info =
+ iter_visitor_logic_info =
(fun f -> Cil_datatype.Logic_info.Hashtbl.iter f logic_infos);
- iter_visitor_logic_type_info =
+ iter_visitor_logic_type_info =
(fun f -> Cil_datatype.Logic_type_info.Hashtbl.iter f logic_type_infos);
- iter_visitor_fieldinfo =
+ iter_visitor_fieldinfo =
(fun f -> Cil_datatype.Fieldinfo.Hashtbl.iter f fieldinfos);
iter_visitor_model_info =
(fun f -> Cil_datatype.Model_info.Hashtbl.iter f model_infos);
@@ -1770,17 +1770,17 @@ let copy_visit_gen fresh prj =
iter_visitor_kernel_function =
(fun f -> Cil_datatype.Kf.Hashtbl.iter f kernel_functions);
iter_visitor_fundec =
- (fun f ->
- let f _ new_fundec =
- let old_fundec =
- Cil_datatype.Varinfo.Hashtbl.find orig_fundecs new_fundec.svar
- in
- f old_fundec new_fundec
- in
- Cil_datatype.Varinfo.Hashtbl.iter f fundecs);
+ (fun f ->
+ let f _ new_fundec =
+ let old_fundec =
+ Cil_datatype.Varinfo.Hashtbl.find orig_fundecs new_fundec.svar
+ in
+ f old_fundec new_fundec
+ in
+ Cil_datatype.Varinfo.Hashtbl.iter f fundecs);
fold_visitor_varinfo =
(fun f i -> Cil_datatype.Varinfo.Hashtbl.fold f varinfos i);
- fold_visitor_compinfo =
+ fold_visitor_compinfo =
(fun f i -> Cil_datatype.Compinfo.Hashtbl.fold f compinfos i);
fold_visitor_enuminfo =
(fun f i -> Cil_datatype.Enuminfo.Hashtbl.fold f enuminfos i);
@@ -1794,7 +1794,7 @@ let copy_visit_gen fresh prj =
(fun f i -> Cil_datatype.Logic_info.Hashtbl.fold f logic_infos i);
fold_visitor_logic_type_info =
(fun f i ->
- Cil_datatype.Logic_type_info.Hashtbl.fold f logic_type_infos i);
+ Cil_datatype.Logic_type_info.Hashtbl.fold f logic_type_infos i);
fold_visitor_fieldinfo =
(fun f i -> Cil_datatype.Fieldinfo.Hashtbl.fold f fieldinfos i);
fold_visitor_model_info =
@@ -1803,16 +1803,16 @@ let copy_visit_gen fresh prj =
(fun f i -> Cil_datatype.Logic_var.Hashtbl.fold f logic_vars i);
fold_visitor_kernel_function =
(fun f i ->
- Cil_datatype.Kf.Hashtbl.fold f kernel_functions i);
+ Cil_datatype.Kf.Hashtbl.fold f kernel_functions i);
fold_visitor_fundec =
- (fun f i ->
- let f _ new_fundec acc =
- let old_fundec =
- Cil_datatype.Varinfo.Hashtbl.find orig_fundecs new_fundec.svar
- in
- f old_fundec new_fundec acc
- in
- Cil_datatype.Varinfo.Hashtbl.fold f fundecs i);
+ (fun f i ->
+ let f _ new_fundec acc =
+ let old_fundec =
+ Cil_datatype.Varinfo.Hashtbl.find orig_fundecs new_fundec.svar
+ in
+ f old_fundec new_fundec acc
+ in
+ Cil_datatype.Varinfo.Hashtbl.fold f fundecs i);
}
let copy_visit = copy_visit_gen false
@@ -1839,47 +1839,47 @@ class type cilVisitor = object
method plain_copy_visitor: cilVisitor
method vfile: file -> file visitAction
- (** visit a file. *)
+ (** visit a file. *)
method vvdec: varinfo -> varinfo visitAction
- (** Invoked for each variable declaration. The subtrees to be traversed
- * are those corresponding to the type and attributes of the variable.
- * Note that variable declarations are all the [GVar], [GVarDecl], [GFun],
- * all the [varinfo] in formals of function types, and the formals and
- * locals for function definitions. This means that the list of formals
- * in a function definition will be traversed twice, once as part of the
- * function type and second as part of the formals in a function
- * definition. *)
+ (** Invoked for each variable declaration. The subtrees to be traversed
+ * are those corresponding to the type and attributes of the variable.
+ * Note that variable declarations are all the [GVar], [GVarDecl], [GFun],
+ * all the [varinfo] in formals of function types, and the formals and
+ * locals for function definitions. This means that the list of formals
+ * in a function definition will be traversed twice, once as part of the
+ * function type and second as part of the formals in a function
+ * definition. *)
method vvrbl: varinfo -> varinfo visitAction
- (** Invoked on each variable use. Here only the [SkipChildren] and
- * [ChangeTo] actions make sense since there are no subtrees. Note that
- * the type and attributes of the variable are not traversed for a
- * variable use *)
+ (** Invoked on each variable use. Here only the [SkipChildren] and
+ * [ChangeTo] actions make sense since there are no subtrees. Note that
+ * the type and attributes of the variable are not traversed for a
+ * variable use *)
method vexpr: exp -> exp visitAction
- (** Invoked on each expression occurrence. The subtrees are the
- * subexpressions, the types (for a [Cast] or [SizeOf] expression) or the
- * variable use. *)
+ (** Invoked on each expression occurrence. The subtrees are the
+ * subexpressions, the types (for a [Cast] or [SizeOf] expression) or the
+ * variable use. *)
method vlval: lval -> lval visitAction
- (** Invoked on each lvalue occurrence *)
+ (** Invoked on each lvalue occurrence *)
method voffs: offset -> offset visitAction
- (** Invoked on each offset occurrence that is *not* as part
- * of an initializer list specification, i.e. in an lval or
- * recursively inside an offset. *)
+ (** Invoked on each offset occurrence that is *not* as part
+ * of an initializer list specification, i.e. in an lval or
+ * recursively inside an offset. *)
method vinitoffs: offset -> offset visitAction
- (** Invoked on each offset appearing in the list of a
- * CompoundInit initializer. *)
+ (** Invoked on each offset appearing in the list of a
+ * CompoundInit initializer. *)
method vinst: instr -> instr list visitAction
- (** Invoked on each instruction occurrence. The [ChangeTo] action can
- * replace this instruction with a list of instructions *)
+ (** Invoked on each instruction occurrence. The [ChangeTo] action can
+ * replace this instruction with a list of instructions *)
method vstmt: stmt -> stmt visitAction
- (** Control-flow statement. *)
+ (** Control-flow statement. *)
method vblock: block -> block visitAction (** Block. Replaced in
place. *)
@@ -1888,9 +1888,9 @@ class type cilVisitor = object
method vglob: global -> global list visitAction (** Global (vars, types,
etc.) *)
method vinit: varinfo -> offset -> init -> init visitAction
- (** Initializers for globals,
- * pass the global where this
- * occurs, and the offset *)
+ (** Initializers for globals,
+ * pass the global where this
+ * occurs, and the offset *)
method vlocal_init: varinfo -> local_init -> local_init visitAction
@@ -1911,15 +1911,15 @@ class type cilVisitor = object
method venumitem: enumitem -> enumitem visitAction
method vattr: attribute -> attribute list visitAction
- (** Attribute. Each attribute can be replaced by a list *)
+ (** Attribute. Each attribute can be replaced by a list *)
method vattrparam: attrparam -> attrparam visitAction
- (** Attribute parameters. *)
+ (** Attribute parameters. *)
- (** Add here instructions while visiting to queue them to
- * precede the current statement being processed *)
+ (** Add here instructions while visiting to queue them to
+ * precede the current statement being processed *)
method queueInstr: instr list -> unit
- (** Gets the queue of instructions and resets the queue *)
+ (** Gets the queue of instructions and resets the queue *)
method unqueueInstr: unit -> instr list
val current_stmt : stmt Stack.t
@@ -2009,153 +2009,153 @@ class type cilVisitor = object
method get_filling_actions: (unit -> unit) Queue.t
end
- class internal_genericCilVisitor current_func behavior queue: cilVisitor =
- object(self)
- method behavior = behavior
+class internal_genericCilVisitor current_func behavior queue: cilVisitor =
+ object(self)
+ method behavior = behavior
- method project = behavior.project;
+ method project = behavior.project;
- method plain_copy_visitor =
- let obj =
- new internal_genericCilVisitor current_func behavior queue
- in
- assert (obj#get_filling_actions == self#get_filling_actions); obj
+ method plain_copy_visitor =
+ let obj =
+ new internal_genericCilVisitor current_func behavior queue
+ in
+ assert (obj#get_filling_actions == self#get_filling_actions); obj
- method fill_global_tables =
- let action () = Queue.iter (fun f -> f()) queue in
- (match self#project with
- | None -> action ()
- | Some prj -> Project.on prj action ());
- Queue.clear queue
+ method fill_global_tables =
+ let action () = Queue.iter (fun f -> f()) queue in
+ (match self#project with
+ | None -> action ()
+ | Some prj -> Project.on prj action ());
+ Queue.clear queue
- method get_filling_actions = queue
+ method get_filling_actions = queue
- method vfile _f = DoChildren
- val current_stmt = Stack.create ()
- method push_stmt s = Stack.push s current_stmt
- method pop_stmt _s = ignore (Stack.pop current_stmt)
- method current_stmt =
- try Some (Stack.top current_stmt) with Stack.Empty -> None
+ method vfile _f = DoChildren
+ val current_stmt = Stack.create ()
+ method push_stmt s = Stack.push s current_stmt
+ method pop_stmt _s = ignore (Stack.pop current_stmt)
+ method current_stmt =
+ try Some (Stack.top current_stmt) with Stack.Empty -> None
- method current_kinstr =
- try Kstmt (Stack.top current_stmt) with Stack.Empty -> Kglobal
+ method current_kinstr =
+ try Kstmt (Stack.top current_stmt) with Stack.Empty -> Kglobal
- method current_func = !current_func
- method set_current_func f = current_func := Some f
- method reset_current_func () = current_func := None
+ method current_func = !current_func
+ method set_current_func f = current_func := Some f
+ method reset_current_func () = current_func := None
- method vvrbl (_v:varinfo) = DoChildren
- method vvdec (_v:varinfo) = DoChildren
- method vexpr (_e:exp) = DoChildren
- method vlval (_l:lval) = DoChildren
- method voffs (_o:offset) = DoChildren
- method vinitoffs (_o:offset) = DoChildren
- method vinst (_i:instr) = DoChildren
- method vstmt (_s:stmt) = DoChildren
- method vblock (_b: block) = DoChildren
- method vfunc (_f:fundec) = DoChildren
- method vglob (_g:global) = DoChildren
- method vinit (_forg: varinfo) (_off: offset) (_i:init) = DoChildren
- method vlocal_init _ _ = DoChildren
- method vtype (_t:typ) = DoChildren
- method vcompinfo _ = DoChildren
- method venuminfo _ = DoChildren
- method vfieldinfo _ = DoChildren
- method venumitem _ = DoChildren
- method vattr (_a: attribute) = DoChildren
- method vattrparam (_a: attrparam) = DoChildren
+ method vvrbl (_v:varinfo) = DoChildren
+ method vvdec (_v:varinfo) = DoChildren
+ method vexpr (_e:exp) = DoChildren
+ method vlval (_l:lval) = DoChildren
+ method voffs (_o:offset) = DoChildren
+ method vinitoffs (_o:offset) = DoChildren
+ method vinst (_i:instr) = DoChildren
+ method vstmt (_s:stmt) = DoChildren
+ method vblock (_b: block) = DoChildren
+ method vfunc (_f:fundec) = DoChildren
+ method vglob (_g:global) = DoChildren
+ method vinit (_forg: varinfo) (_off: offset) (_i:init) = DoChildren
+ method vlocal_init _ _ = DoChildren
+ method vtype (_t:typ) = DoChildren
+ method vcompinfo _ = DoChildren
+ method venuminfo _ = DoChildren
+ method vfieldinfo _ = DoChildren
+ method venumitem _ = DoChildren
+ method vattr (_a: attribute) = DoChildren
+ method vattrparam (_a: attrparam) = DoChildren
- val mutable instrQueue = []
+ val mutable instrQueue = []
- method queueInstr (il: instr list) =
- List.iter (fun i -> instrQueue <- i :: instrQueue) il
+ method queueInstr (il: instr list) =
+ List.iter (fun i -> instrQueue <- i :: instrQueue) il
- method unqueueInstr () =
- let res = List.rev instrQueue in
- instrQueue <- [];
- res
+ method unqueueInstr () =
+ let res = List.rev instrQueue in
+ instrQueue <- [];
+ res
- method vmodel_info _ = DoChildren
+ method vmodel_info _ = DoChildren
- method vlogic_type _lt = DoChildren
+ method vlogic_type _lt = DoChildren
- method videntified_term _t = DoChildren
+ method videntified_term _t = DoChildren
- method vterm _t = DoChildren
+ method vterm _t = DoChildren
- method vlogic_label _l = DoChildren
+ method vlogic_label _l = DoChildren
- method vterm_node _tn = DoChildren
+ method vterm_node _tn = DoChildren
- method vterm_lval _tl = DoChildren
+ method vterm_lval _tl = DoChildren
- method vterm_lhost _tl = DoChildren
+ method vterm_lhost _tl = DoChildren
- method vterm_offset _vo = DoChildren
+ method vterm_offset _vo = DoChildren
- method vlogic_info_decl _li = DoChildren
+ method vlogic_info_decl _li = DoChildren
- method vlogic_info_use _li = DoChildren
+ method vlogic_info_use _li = DoChildren
- method vlogic_type_info_decl _ = DoChildren
+ method vlogic_type_info_decl _ = DoChildren
- method vlogic_type_info_use _ = DoChildren
+ method vlogic_type_info_use _ = DoChildren
- method vlogic_type_def _ = DoChildren
+ method vlogic_type_def _ = DoChildren
- method vlogic_ctor_info_decl _ = DoChildren
+ method vlogic_ctor_info_decl _ = DoChildren
- method vlogic_ctor_info_use _ = DoChildren
+ method vlogic_ctor_info_use _ = DoChildren
- method vlogic_var_decl _lv = DoChildren
+ method vlogic_var_decl _lv = DoChildren
- method vlogic_var_use _lv = DoChildren
+ method vlogic_var_use _lv = DoChildren
- method vquantifiers _q = DoChildren
+ method vquantifiers _q = DoChildren
- method videntified_predicate _ip = DoChildren
+ method videntified_predicate _ip = DoChildren
- method vpredicate_node _p = DoChildren
+ method vpredicate_node _p = DoChildren
- method vpredicate _p = DoChildren
+ method vpredicate _p = DoChildren
- method vbehavior _b = DoChildren
+ method vbehavior _b = DoChildren
- method vspec _s = DoChildren
+ method vspec _s = DoChildren
- method vassigns _s = DoChildren
- method vfrees _s = DoChildren
- method vallocates _s = DoChildren
- method vallocation _s = DoChildren
+ method vassigns _s = DoChildren
+ method vfrees _s = DoChildren
+ method vallocates _s = DoChildren
+ method vallocation _s = DoChildren
- method vloop_pragma _ = DoChildren
+ method vloop_pragma _ = DoChildren
- method vslice_pragma _ = DoChildren
- method vimpact_pragma _ = DoChildren
+ method vslice_pragma _ = DoChildren
+ method vimpact_pragma _ = DoChildren
- method vdeps _ = DoChildren
+ method vdeps _ = DoChildren
- method vfrom _ = DoChildren
+ method vfrom _ = DoChildren
- method vcode_annot _ca = DoChildren
+ method vcode_annot _ca = DoChildren
- method vannotation _a = DoChildren
+ method vannotation _a = DoChildren
- end
+ end
- class genericCilVisitor bhv =
- let current_func = ref None in
- let queue = Queue.create () in
- internal_genericCilVisitor current_func bhv queue
+class genericCilVisitor bhv =
+ let current_func = ref None in
+ let queue = Queue.create () in
+ internal_genericCilVisitor current_func bhv queue
- class nopCilVisitor = object
- inherit genericCilVisitor (inplace_visit ())
- end
+class nopCilVisitor = object
+ inherit genericCilVisitor (inplace_visit ())
+end
- let apply_on_project ?selection vis f arg =
- match vis#project with
- | None -> f arg
- | Some prj -> Project.on ?selection prj f arg
+let apply_on_project ?selection vis f arg =
+ match vis#project with
+ | None -> f arg
+ | Some prj -> Project.on ?selection prj f arg
let assertEmptyQueue vis =
if vis#unqueueInstr () <> [] then
@@ -2181,14 +2181,14 @@ let transient_block b =
| _ -> false)
b.bstmts
then
- Kernel.fatal
- "Attempting to mark as transient a block that declares local variables";
+ Kernel.fatal
+ "Attempting to mark as transient a block that declares local variables";
Kernel.warning
~wkey:wkey_transient
"ignoring request to mark transient a block with local variables:@\n%a"
Cil_datatype.Block.pretty b
end else
- b.battrs <- addAttribute (Attr (vis_tmp_attr,[])) b.battrs; b
+ b.battrs <- addAttribute (Attr (vis_tmp_attr,[])) b.battrs; b
let block_of_transient b =
if hasAttribute vis_tmp_attr b.battrs then begin
@@ -2246,8 +2246,8 @@ let flatten_transient_sub_blocks b =
s.skind <- Block (block_of_transient b);
prev:=Some s;
s :: acc
- end
- | _ -> prev:= Some s; s :: acc
+ end
+ | _ -> prev:= Some s; s :: acc
in
b.bstmts <- List.rev (List.fold_left treat_one_stmt [] b.bstmts);
b
@@ -2263,133 +2263,133 @@ let stmt_of_instr_list_visitor ?loc l =
let doVisit (vis: 'visitor)
only_copy_vis
(previsit: 'a -> 'a)
- (startvisit: 'a -> 'a visitAction)
- (children: 'visitor -> 'a -> 'a)
- (node: 'a) : 'a =
+ (startvisit: 'a -> 'a visitAction)
+ (children: 'visitor -> 'a -> 'a)
+ (node: 'a) : 'a =
let node' = previsit node in
let action = startvisit node' in
match action with
- SkipChildren -> node'
- | ChangeTo node' -> node'
- | ChangeToPost (node',f) -> f node'
- | DoChildren | DoChildrenPost _
- | JustCopy | ChangeDoChildrenPost _ | JustCopyPost _ ->
- let nodepre = match action with
- ChangeDoChildrenPost (node', _) -> node'
- | _ -> node'
- in
- let vis = match action with
- JustCopy | JustCopyPost _ -> only_copy_vis
- | _ -> vis
- in
- let nodepost = children vis nodepre in
- match action with
- | DoChildrenPost f | ChangeDoChildrenPost (_, f) | JustCopyPost f ->
- f nodepost
- | _ -> nodepost
-
- let doVisitCil vis previsit startvisit children node =
- doVisit vis vis#plain_copy_visitor previsit startvisit children node
-
- let rev_until i l =
- let rec aux acc =
- function
- [] -> acc
- | i'::_ when i' == i -> acc
- | i'::l -> aux (i'::acc) l
- in aux [] l
-
- (* mapNoCopy is like map but avoid copying the list if the function does not
- * change the elements. *)
- let mapNoCopy (f: 'a -> 'a) orig =
- let rec aux ((acc,has_changed) as res) l =
- match l with
- [] -> if has_changed then List.rev acc else orig
- | i :: resti ->
- let i' = f i in
- if has_changed then
- aux (i'::acc,true) resti
- else if i' != i then
- aux (i'::rev_until i orig,true) resti
- else
- aux res resti
- in aux ([],false) orig
-
- let mapNoCopyList (f: 'a -> 'a list) orig =
- let rec aux ((acc,has_changed) as res) l =
- match l with
- [] -> if has_changed then List.rev acc else orig
- | i :: resti ->
- let l' = f i in
- if has_changed then
- aux (List.rev_append l' acc,true) resti
- else
- (match l' with
- [i'] when i' == i -> aux res resti
- | _ -> aux (List.rev_append l' (rev_until i orig), true) resti)
- in aux ([],false) orig
+ SkipChildren -> node'
+ | ChangeTo node' -> node'
+ | ChangeToPost (node',f) -> f node'
+ | DoChildren | DoChildrenPost _
+ | JustCopy | ChangeDoChildrenPost _ | JustCopyPost _ ->
+ let nodepre = match action with
+ ChangeDoChildrenPost (node', _) -> node'
+ | _ -> node'
+ in
+ let vis = match action with
+ JustCopy | JustCopyPost _ -> only_copy_vis
+ | _ -> vis
+ in
+ let nodepost = children vis nodepre in
+ match action with
+ | DoChildrenPost f | ChangeDoChildrenPost (_, f) | JustCopyPost f ->
+ f nodepost
+ | _ -> nodepost
+
+let doVisitCil vis previsit startvisit children node =
+ doVisit vis vis#plain_copy_visitor previsit startvisit children node
+
+let rev_until i l =
+ let rec aux acc =
+ function
+ [] -> acc
+ | i'::_ when i' == i -> acc
+ | i'::l -> aux (i'::acc) l
+ in aux [] l
+
+(* mapNoCopy is like map but avoid copying the list if the function does not
+ * change the elements. *)
+let mapNoCopy (f: 'a -> 'a) orig =
+ let rec aux ((acc,has_changed) as res) l =
+ match l with
+ [] -> if has_changed then List.rev acc else orig
+ | i :: resti ->
+ let i' = f i in
+ if has_changed then
+ aux (i'::acc,true) resti
+ else if i' != i then
+ aux (i'::rev_until i orig,true) resti
+ else
+ aux res resti
+ in aux ([],false) orig
+
+let mapNoCopyList (f: 'a -> 'a list) orig =
+ let rec aux ((acc,has_changed) as res) l =
+ match l with
+ [] -> if has_changed then List.rev acc else orig
+ | i :: resti ->
+ let l' = f i in
+ if has_changed then
+ aux (List.rev_append l' acc,true) resti
+ else
+ (match l' with
+ [i'] when i' == i -> aux res resti
+ | _ -> aux (List.rev_append l' (rev_until i orig), true) resti)
+ in aux ([],false) orig
(* A visitor for lists *)
let doVisitList (vis: 'visit)
- only_copy_vis
- (previsit: 'a -> 'a)
- (startvisit: 'a -> 'a list visitAction)
- (children: 'visit -> 'a -> 'a)
- (node: 'a) : 'a list =
+ only_copy_vis
+ (previsit: 'a -> 'a)
+ (startvisit: 'a -> 'a list visitAction)
+ (children: 'visit -> 'a -> 'a)
+ (node: 'a) : 'a list =
let node' = previsit node in
let action = startvisit node' in
match action with
- SkipChildren -> [node']
- | ChangeTo nodes' -> nodes'
- | ChangeToPost (nodes',f) -> f nodes'
- | _ ->
- let nodespre = match action with
- ChangeDoChildrenPost (nodespre, _) -> nodespre
- | _ -> [node']
- in
- let vis = match action with
- JustCopy | JustCopyPost _ -> only_copy_vis
- | _ -> vis
- in
- let nodespost = mapNoCopy (children vis) nodespre in
- match action with
- | DoChildrenPost f | ChangeDoChildrenPost (_, f) | JustCopyPost f ->
- f nodespost
- | _ -> nodespost
+ SkipChildren -> [node']
+ | ChangeTo nodes' -> nodes'
+ | ChangeToPost (nodes',f) -> f nodes'
+ | _ ->
+ let nodespre = match action with
+ ChangeDoChildrenPost (nodespre, _) -> nodespre
+ | _ -> [node']
+ in
+ let vis = match action with
+ JustCopy | JustCopyPost _ -> only_copy_vis
+ | _ -> vis
+ in
+ let nodespost = mapNoCopy (children vis) nodespre in
+ match action with
+ | DoChildrenPost f | ChangeDoChildrenPost (_, f) | JustCopyPost f ->
+ f nodespost
+ | _ -> nodespost
- let doVisitListCil vis previsit startvisit children node =
- doVisitList vis vis#plain_copy_visitor previsit startvisit children node
+let doVisitListCil vis previsit startvisit children node =
+ doVisitList vis vis#plain_copy_visitor previsit startvisit children node
- let optMapNoCopy f o =
- match o with
- None -> o
- | Some x ->
- let x' = f x in if x' != x then Some x' else o
+let optMapNoCopy f o =
+ match o with
+ None -> o
+ | Some x ->
+ let x' = f x in if x' != x then Some x' else o
- let debugVisit = false
+let debugVisit = false
let visitCilConst vis c =
match c with
- | CEnum ei -> (* In case of deep copy, we must change the enumitem*)
- let ei' = vis#behavior.get_enumitem ei in
- if ei' != ei then CEnum ei' else c
- | _ -> c
+ | CEnum ei -> (* In case of deep copy, we must change the enumitem*)
+ let ei' = vis#behavior.get_enumitem ei in
+ if ei' != ei then CEnum ei' else c
+ | _ -> c
let visitCilLConst vis c =
match c with
- | LEnum ei -> (* In case of deep copy, we must change the enumitem*)
- let ei' = vis#behavior.get_enumitem ei in
- if ei' != ei then LEnum ei' else c
- | _ -> c
+ | LEnum ei -> (* In case of deep copy, we must change the enumitem*)
+ let ei' = vis#behavior.get_enumitem ei in
+ if ei' != ei then LEnum ei' else c
+ | _ -> c
let copy_logic_label is_copy l =
if is_copy then begin
match l with
- | StmtLabel s -> StmtLabel (ref !s)
- | FormalLabel s -> FormalLabel s
- | BuiltinLabel s -> BuiltinLabel s
- (* we don't copy the associated statement. It will be recomputed
- if needed. *)
+ | StmtLabel s -> StmtLabel (ref !s)
+ | FormalLabel s -> FormalLabel s
+ | BuiltinLabel s -> BuiltinLabel s
+ (* we don't copy the associated statement. It will be recomputed
+ if needed. *)
end else l
let rec visitCilTerm vis t =
@@ -2402,8 +2402,8 @@ and childrenTerm vis t =
let tn' = visitCilTermNode vis t.term_node in
let tt' = visitCilLogicType vis t.term_type in
if tn' != t.term_node || tt' != t.term_type then
- { t with term_node = tn'; term_type = tt' }
- else t
+ { t with term_node = tn'; term_type = tt' }
+ else t
and visitCilTermNode vis tn =
doVisitCil vis id vis#vterm_node childrenTermNode tn
and childrenTermNode vis tn =
@@ -2411,514 +2411,514 @@ and childrenTermNode vis tn =
let vTermLval tl = visitCilTermLval vis tl in
let vTyp t = visitCilType vis t in
let vLogicInfo li = visitCilLogicInfoUse vis li in
- match tn with
- | TConst c ->
- let c' = visitCilLConst vis c in
- if c' != c then TConst c' else tn
- | TDataCons (ci,args) ->
- let ci' =
- doVisitCil vis id vis#vlogic_ctor_info_use alphabetabeta ci
- in
- let args' = mapNoCopy vTerm args in
- if ci' != ci || args != args' then TDataCons(ci',args') else tn
- | TLval tl ->
- let tl' = vTermLval tl in
- if tl' != tl then TLval tl' else tn
- | TSizeOf t ->
- let t' = vTyp t in if t' != t then TSizeOf t' else tn
- | TSizeOfE t ->
- let t' = vTerm t in if t' != t then TSizeOfE t' else tn
- | TSizeOfStr _ -> tn
- | TAlignOf t ->
- let t' = vTyp t in if t' != t then TAlignOf t' else tn
- | TAlignOfE t ->
- let t' = vTerm t in if t' != t then TAlignOfE t' else tn
- | TUnOp (op,t) ->
- let t' = vTerm t in if t' != t then TUnOp (op,t') else tn
- | TBinOp(op,t1,t2) ->
- let t1' = vTerm t1 in
- let t2' = vTerm t2 in
- if t1' != t1 || t2' != t2 then TBinOp(op,t1',t2') else tn
- | TCastE(ty,te) ->
- let ty' = vTyp ty in
- let te' = vTerm te in
- if ty' != ty || te' != te then TCastE(ty',te') else tn
- | TAddrOf tl ->
- let tl' = vTermLval tl in
- if tl' != tl then TAddrOf tl' else tn
- | TStartOf tl ->
- let tl' = vTermLval tl in
- if tl' != tl then TStartOf tl' else tn
- | Tapp(li,labels,args) ->
- let li' = vLogicInfo li in
- let labels' =
- mapNoCopy (visitCilLogicLabel vis) labels in
+ match tn with
+ | TConst c ->
+ let c' = visitCilLConst vis c in
+ if c' != c then TConst c' else tn
+ | TDataCons (ci,args) ->
+ let ci' =
+ doVisitCil vis id vis#vlogic_ctor_info_use alphabetabeta ci
+ in
+ let args' = mapNoCopy vTerm args in
+ if ci' != ci || args != args' then TDataCons(ci',args') else tn
+ | TLval tl ->
+ let tl' = vTermLval tl in
+ if tl' != tl then TLval tl' else tn
+ | TSizeOf t ->
+ let t' = vTyp t in if t' != t then TSizeOf t' else tn
+ | TSizeOfE t ->
+ let t' = vTerm t in if t' != t then TSizeOfE t' else tn
+ | TSizeOfStr _ -> tn
+ | TAlignOf t ->
+ let t' = vTyp t in if t' != t then TAlignOf t' else tn
+ | TAlignOfE t ->
+ let t' = vTerm t in if t' != t then TAlignOfE t' else tn
+ | TUnOp (op,t) ->
+ let t' = vTerm t in if t' != t then TUnOp (op,t') else tn
+ | TBinOp(op,t1,t2) ->
+ let t1' = vTerm t1 in
+ let t2' = vTerm t2 in
+ if t1' != t1 || t2' != t2 then TBinOp(op,t1',t2') else tn
+ | TCastE(ty,te) ->
+ let ty' = vTyp ty in
+ let te' = vTerm te in
+ if ty' != ty || te' != te then TCastE(ty',te') else tn
+ | TAddrOf tl ->
+ let tl' = vTermLval tl in
+ if tl' != tl then TAddrOf tl' else tn
+ | TStartOf tl ->
+ let tl' = vTermLval tl in
+ if tl' != tl then TStartOf tl' else tn
+ | Tapp(li,labels,args) ->
+ let li' = vLogicInfo li in
+ let labels' =
+ mapNoCopy (visitCilLogicLabel vis) labels in
(*
- Format.eprintf "Cil.children_term_node: li = %s(%d), li' = %s(%d)@."
- li.l_var_info.lv_name li.l_var_info.lv_id
+ Format.eprintf "Cil.children_term_node: li = %s(%d), li' = %s(%d)@."
+ li.l_var_info.lv_name li.l_var_info.lv_id
li'.l_var_info.lv_name li'.l_var_info.lv_id;
*)
- let args' = mapNoCopy vTerm args in
- if li' != li || labels' != labels || args' != args then
- Tapp(li',labels',args') else tn
- | Tif(test,ttrue,tfalse) ->
- let test' = vTerm test in
- let ttrue' = vTerm ttrue in
- let tfalse' = vTerm tfalse in
- if test' != test || ttrue' != ttrue || tfalse' != tfalse then
- Tif(test',ttrue',tfalse')
- else tn
- | Tat(t,s) ->
- let t' = vTerm t in
- let s' = visitCilLogicLabel vis s in
- if t' != t || s' != s then Tat (t',s') else tn
- | Toffset (s,t) ->
- let s' = visitCilLogicLabel vis s in
- let t' = vTerm t in
- if t' != t || s' != s then Toffset (s',t') else tn
- | Tbase_addr (s,t) ->
- let s' = visitCilLogicLabel vis s in
- let t' = vTerm t in
- if t' != t || s' != s then Tbase_addr (s',t') else tn
- | Tblock_length (s,t)->
- let s' = visitCilLogicLabel vis s in
- let t' = vTerm t in
- if t' != t || s' != s then Tblock_length (s',t') else tn
- | Tnull -> tn
- | TUpdate (tc,toff,te) ->
- let tc' = vTerm tc in
- let te' = vTerm te in
- let toff' = visitCilTermOffset vis toff in
- if tc' != tc || (te' != te || toff' != toff)
- then TUpdate(tc',toff',te') else tn
- | Tlambda(prms,te) ->
- let prms' = visitCilQuantifiers vis prms in
- let te' = vTerm te in
- if prms' != prms || te' != te then Tlambda(prms',te') else tn
- | Ttypeof t ->
- let t' = vTerm t in if t' != t then Ttypeof t' else tn
- | Ttype ty ->
- let ty' = vTyp ty in if ty' != ty then Ttype ty' else tn
- | Tunion locs ->
- let locs' = mapNoCopy (visitCilTerm vis) locs in
- if locs != locs' then Tunion(locs') else tn
- | Tinter locs ->
- let locs' = mapNoCopy (visitCilTerm vis) locs in
- if locs != locs' then Tinter(locs') else tn
- | Tcomprehension(lval,quant,pred) ->
- let quant' = visitCilQuantifiers vis quant in
- let lval' = visitCilTerm vis lval in
- let pred' = (optMapNoCopy (visitCilPredicate vis)) pred in
- if lval' != lval || quant' != quant || pred' != pred
- then
- Tcomprehension(lval',quant',pred')
- else
- tn
- | Tempty_set -> tn
- | Trange(low,high) ->
- let low' = optMapNoCopy (visitCilTerm vis) low in
- let high' = optMapNoCopy (visitCilTerm vis) high in
- if low != low' || high != high' then Trange(low',high')
- else tn
- | Tlet(def,body) ->
- let def'= visitCilLogicInfo vis def in
- let body' = visitCilTerm vis body in
- if def != def' || body != body' then Tlet(def',body') else tn
- | TLogic_coerce(ty,t) ->
- let ty' = visitCilLogicType vis ty in
- let t' = visitCilTerm vis t in
- if ty' != ty || t' != t then TLogic_coerce(ty',t') else tn
+ let args' = mapNoCopy vTerm args in
+ if li' != li || labels' != labels || args' != args then
+ Tapp(li',labels',args') else tn
+ | Tif(test,ttrue,tfalse) ->
+ let test' = vTerm test in
+ let ttrue' = vTerm ttrue in
+ let tfalse' = vTerm tfalse in
+ if test' != test || ttrue' != ttrue || tfalse' != tfalse then
+ Tif(test',ttrue',tfalse')
+ else tn
+ | Tat(t,s) ->
+ let t' = vTerm t in
+ let s' = visitCilLogicLabel vis s in
+ if t' != t || s' != s then Tat (t',s') else tn
+ | Toffset (s,t) ->
+ let s' = visitCilLogicLabel vis s in
+ let t' = vTerm t in
+ if t' != t || s' != s then Toffset (s',t') else tn
+ | Tbase_addr (s,t) ->
+ let s' = visitCilLogicLabel vis s in
+ let t' = vTerm t in
+ if t' != t || s' != s then Tbase_addr (s',t') else tn
+ | Tblock_length (s,t)->
+ let s' = visitCilLogicLabel vis s in
+ let t' = vTerm t in
+ if t' != t || s' != s then Tblock_length (s',t') else tn
+ | Tnull -> tn
+ | TUpdate (tc,toff,te) ->
+ let tc' = vTerm tc in
+ let te' = vTerm te in
+ let toff' = visitCilTermOffset vis toff in
+ if tc' != tc || (te' != te || toff' != toff)
+ then TUpdate(tc',toff',te') else tn
+ | Tlambda(prms,te) ->
+ let prms' = visitCilQuantifiers vis prms in
+ let te' = vTerm te in
+ if prms' != prms || te' != te then Tlambda(prms',te') else tn
+ | Ttypeof t ->
+ let t' = vTerm t in if t' != t then Ttypeof t' else tn
+ | Ttype ty ->
+ let ty' = vTyp ty in if ty' != ty then Ttype ty' else tn
+ | Tunion locs ->
+ let locs' = mapNoCopy (visitCilTerm vis) locs in
+ if locs != locs' then Tunion(locs') else tn
+ | Tinter locs ->
+ let locs' = mapNoCopy (visitCilTerm vis) locs in
+ if locs != locs' then Tinter(locs') else tn
+ | Tcomprehension(lval,quant,pred) ->
+ let quant' = visitCilQuantifiers vis quant in
+ let lval' = visitCilTerm vis lval in
+ let pred' = (optMapNoCopy (visitCilPredicate vis)) pred in
+ if lval' != lval || quant' != quant || pred' != pred
+ then
+ Tcomprehension(lval',quant',pred')
+ else
+ tn
+ | Tempty_set -> tn
+ | Trange(low,high) ->
+ let low' = optMapNoCopy (visitCilTerm vis) low in
+ let high' = optMapNoCopy (visitCilTerm vis) high in
+ if low != low' || high != high' then Trange(low',high')
+ else tn
+ | Tlet(def,body) ->
+ let def'= visitCilLogicInfo vis def in
+ let body' = visitCilTerm vis body in
+ if def != def' || body != body' then Tlet(def',body') else tn
+ | TLogic_coerce(ty,t) ->
+ let ty' = visitCilLogicType vis ty in
+ let t' = visitCilTerm vis t in
+ if ty' != ty || t' != t then TLogic_coerce(ty',t') else tn
and visitCilLogicLabel vis l =
- doVisitCil vis
+ doVisitCil vis
(copy_logic_label vis#behavior.is_copy_behavior)
vis#vlogic_label childrenLogicLabel l
-and childrenLogicLabel vis l =
+and childrenLogicLabel vis l =
match l with
- StmtLabel s -> s := vis#behavior.get_stmt !s; l
- | FormalLabel _ | BuiltinLabel _ -> l
-
- and visitCilTermLval vis tl =
- doVisitCil vis id vis#vterm_lval childrenTermLval tl
-
- and childrenTermLval vis ((tlv,toff) as tl)=
- let tlv' = visitCilTermLhost vis tlv in
- let toff' = visitCilTermOffset vis toff in
- if tlv' != tlv || toff' != toff then (tlv',toff') else tl
-
- and visitCilTermLhost vis tl =
- doVisitCil vis id vis#vterm_lhost childrenTermLhost tl
-
- and childrenTermLhost vis tl = match tl with
- TVar v ->
- let v' = visitCilLogicVarUse vis v in if v' != v then TVar v' else tl
- | TResult ty ->
- let ty' = visitCilType vis ty in if ty' != ty then TResult ty' else tl
- | TMem t ->
- let t' = visitCilTerm vis t in if t' != t then TMem t' else tl
-
- and visitCilTermOffset vis toff =
- doVisitCil vis id
- vis#vterm_offset childrenTermOffset toff
-
- and childrenTermOffset vis toff =
- let vOffset o = visitCilTermOffset vis o in
- let vTerm t = visitCilTerm vis t in
- match toff with
- TNoOffset -> toff
- | TField (fi, t) ->
- let t' = vOffset t in
- let fi' = vis#behavior.get_fieldinfo fi in
- if t' != t || fi != fi' then TField(fi',t') else toff
- | TIndex(t,o) ->
- let t' = vTerm t in let o' = vOffset o in
- if t' != t || o' != o then TIndex(t',o') else toff
- | TModel (mi,t) ->
- let t' = vOffset t in
- let mi' = vis#behavior.get_model_info mi in
- if t' != t || mi != mi' then TModel(mi', t') else toff
-
- and visitCilLogicInfoUse vis li =
- (* First, visit the underlying varinfo to fill the copy tables if needed. *)
- let new_v = visitCilLogicVarUse vis li.l_var_info in
- let new_li =
- doVisitCil vis vis#behavior.get_logic_info
- vis#vlogic_info_use alphabetabeta li
- in
- new_li.l_var_info <- new_v;
- new_li
-
- and visitCilLogicInfo vis li =
- (* visit first the underlying varinfo. This will fill internal tables
- of copy behavior if needed.
+ StmtLabel s -> s := vis#behavior.get_stmt !s; l
+ | FormalLabel _ | BuiltinLabel _ -> l
+
+and visitCilTermLval vis tl =
+ doVisitCil vis id vis#vterm_lval childrenTermLval tl
+
+and childrenTermLval vis ((tlv,toff) as tl)=
+ let tlv' = visitCilTermLhost vis tlv in
+ let toff' = visitCilTermOffset vis toff in
+ if tlv' != tlv || toff' != toff then (tlv',toff') else tl
+
+and visitCilTermLhost vis tl =
+ doVisitCil vis id vis#vterm_lhost childrenTermLhost tl
+
+and childrenTermLhost vis tl = match tl with
+ TVar v ->
+ let v' = visitCilLogicVarUse vis v in if v' != v then TVar v' else tl
+ | TResult ty ->
+ let ty' = visitCilType vis ty in if ty' != ty then TResult ty' else tl
+ | TMem t ->
+ let t' = visitCilTerm vis t in if t' != t then TMem t' else tl
+
+and visitCilTermOffset vis toff =
+ doVisitCil vis id
+ vis#vterm_offset childrenTermOffset toff
+
+and childrenTermOffset vis toff =
+ let vOffset o = visitCilTermOffset vis o in
+ let vTerm t = visitCilTerm vis t in
+ match toff with
+ TNoOffset -> toff
+ | TField (fi, t) ->
+ let t' = vOffset t in
+ let fi' = vis#behavior.get_fieldinfo fi in
+ if t' != t || fi != fi' then TField(fi',t') else toff
+ | TIndex(t,o) ->
+ let t' = vTerm t in let o' = vOffset o in
+ if t' != t || o' != o then TIndex(t',o') else toff
+ | TModel (mi,t) ->
+ let t' = vOffset t in
+ let mi' = vis#behavior.get_model_info mi in
+ if t' != t || mi != mi' then TModel(mi', t') else toff
+
+and visitCilLogicInfoUse vis li =
+ (* First, visit the underlying varinfo to fill the copy tables if needed. *)
+ let new_v = visitCilLogicVarUse vis li.l_var_info in
+ let new_li =
+ doVisitCil vis vis#behavior.get_logic_info
+ vis#vlogic_info_use alphabetabeta li
+ in
+ new_li.l_var_info <- new_v;
+ new_li
+
+and visitCilLogicInfo vis li =
+ (* visit first the underlying varinfo. This will fill internal tables
+ of copy behavior if needed.
+ *)
+ let new_v = visitCilLogicVarDecl vis li.l_var_info in
+ let res =
+ doVisitCil
+ vis vis#behavior.memo_logic_info
+ vis#vlogic_info_decl childrenLogicInfo li
+ in res.l_var_info <- new_v; res
+
+and childrenLogicInfo vis li =
+ (* NB: underlying varinfo has been already visited. *)
+ let lt = optMapNoCopy (visitCilLogicType vis) li.l_type in
+ let lp = mapNoCopy (visitCilLogicVarDecl vis) li.l_profile in
+ li.l_type <- lt;
+ li.l_profile <- lp;
+ li.l_body <-
+ begin
+ match li.l_body with
+ | LBnone -> li.l_body
+ | LBreads ol ->
+ let l = mapNoCopy (visitCilIdTerm vis) ol in
+ if l != ol then LBreads l else li.l_body
+ | LBterm ot ->
+ let t = visitCilTerm vis ot in
+ if t != ot then LBterm t else li.l_body
+ | LBinductive inddef ->
+ let i =
+ mapNoCopy
+ (fun (id,labs,tvars,p) ->
+ (id, labs, tvars, visitCilPredicate vis p))
+ inddef
+ in
+ if i != inddef then LBinductive i else li.l_body
+ | LBpred odef ->
+ let def = visitCilPredicate vis odef in
+ if def != odef then LBpred def else li.l_body
+ end;
+ li
+
+and visitCilLogicTypeInfo vis lt =
+ doVisitCil vis vis#behavior.memo_logic_type_info
+ vis#vlogic_type_info_decl childrenLogicTypeInfo lt
+
+and childrenLogicTypeInfo vis lt =
+ let def = optMapNoCopy (visitCilLogicTypeDef vis) lt.lt_def in
+ lt.lt_def <- def; lt
+
+and visitCilLogicTypeDef vis def =
+ doVisitCil vis id vis#vlogic_type_def childrenLogicTypeDef def
+
+and childrenLogicTypeDef vis def =
+ match def with
+ | LTsum l ->
+ let l' = mapNoCopy (visitCilLogicCtorInfoAddTable vis) l in
+ if l != l' then LTsum l' else def
+ | LTsyn typ ->
+ let typ' = visitCilLogicType vis typ in
+ if typ != typ' then LTsyn typ else def
+
+and visitCilLogicCtorInfoAddTable vis ctor =
+ let ctor' = visitCilLogicCtorInfo vis ctor in
+ if is_copy_behavior vis#behavior then
+ Queue.add
+ (fun () ->
+ Logic_env.add_logic_ctor ctor'.ctor_name ctor')
+ vis#get_filling_actions;
+ ctor'
+
+and visitCilLogicCtorInfo vis ctor =
+ doVisitCil vis id vis#vlogic_ctor_info_decl childrenLogicCtorInfo ctor
+
+and childrenLogicCtorInfo vis ctor =
+ let ctor_type = doVisitCil vis vis#behavior.get_logic_type_info
+ vis#vlogic_type_info_use alphabetabeta ctor.ctor_type
+ in
+ let ctor_params = ctor.ctor_params in
+ let ctor_params' = mapNoCopy (visitCilLogicType vis) ctor_params in
+ if ctor_type != ctor.ctor_type || ctor_params != ctor_params' then
+ { ctor with ctor_type = ctor_type; ctor_params = ctor_params' }
+ else ctor
+
+and visitCilLogicType vis t =
+ doVisitCil vis id vis#vlogic_type childrenLogicType t
+
+and childrenLogicType vis ty =
+ match ty with
+ Ctype t ->
+ let t' = visitCilType vis t in
+ if t != t' then Ctype t' else ty
+ | Linteger | Lreal -> ty
+ | Ltype (s,l) ->
+ let s' = doVisitCil vis vis#behavior.get_logic_type_info
+ vis#vlogic_type_info_use alphabetabeta s in
+ let l' = mapNoCopy (visitCilLogicType vis) l in
+ if s' != s || l' != l then Ltype (s',l') else ty
+ | Larrow(args,rttyp) ->
+ let args' = mapNoCopy(visitCilLogicType vis) args in
+ let rttyp' = visitCilLogicType vis rttyp in
+ if args' != args || rttyp' != rttyp then Larrow(args',rttyp') else ty
+ | Lvar _ -> ty
+
+and visitCilLogicVarDecl vis lv =
+ (* keep names in C and logic worlds in sync *)
+ (match lv.lv_origin with
+ None -> ()
+ | Some cv -> lv.lv_name <- cv.vname);
+ doVisitCil vis vis#behavior.memo_logic_var vis#vlogic_var_decl
+ childrenLogicVarDecl lv
+
+and childrenLogicVarDecl vis lv =
+ lv.lv_type <- visitCilLogicType vis lv.lv_type;
+ lv.lv_origin <-
+ optMapNoCopy (visitCilVarUse vis) lv.lv_origin;
+ lv
+
+and visitCilLogicVarUse vis lv =
+ if vis#behavior.is_copy_behavior &&
+ (* In a copy visitor, there's always a project. Furthermore, if
+ we target the current project, builtins are by definition already
+ tied to logic_infos and should not be copied.
+ *)
+ not (Project.is_current (Extlib.the vis#project)) &&
+ Logic_env.is_builtin_logic_function lv.lv_name
+ then begin
+ (* Do as if the variable has been declared.
+ We'll fill the logic info table of the new project at the end.
+ Behavior's logic_var table is filled as a side effect.
*)
- let new_v = visitCilLogicVarDecl vis li.l_var_info in
- let res =
- doVisitCil
- vis vis#behavior.memo_logic_info
- vis#vlogic_info_decl childrenLogicInfo li
- in res.l_var_info <- new_v; res
-
- and childrenLogicInfo vis li =
- (* NB: underlying varinfo has been already visited. *)
- let lt = optMapNoCopy (visitCilLogicType vis) li.l_type in
- let lp = mapNoCopy (visitCilLogicVarDecl vis) li.l_profile in
- li.l_type <- lt;
- li.l_profile <- lp;
- li.l_body <-
- begin
- match li.l_body with
- | LBnone -> li.l_body
- | LBreads ol ->
- let l = mapNoCopy (visitCilIdTerm vis) ol in
- if l != ol then LBreads l else li.l_body
- | LBterm ot ->
- let t = visitCilTerm vis ot in
- if t != ot then LBterm t else li.l_body
- | LBinductive inddef ->
- let i =
- mapNoCopy
- (fun (id,labs,tvars,p) ->
- (id, labs, tvars, visitCilPredicate vis p))
- inddef
- in
- if i != inddef then LBinductive i else li.l_body
- | LBpred odef ->
- let def = visitCilPredicate vis odef in
- if def != odef then LBpred def else li.l_body
- end;
- li
-
- and visitCilLogicTypeInfo vis lt =
- doVisitCil vis vis#behavior.memo_logic_type_info
- vis#vlogic_type_info_decl childrenLogicTypeInfo lt
-
- and childrenLogicTypeInfo vis lt =
- let def = optMapNoCopy (visitCilLogicTypeDef vis) lt.lt_def in
- lt.lt_def <- def; lt
-
- and visitCilLogicTypeDef vis def =
- doVisitCil vis id vis#vlogic_type_def childrenLogicTypeDef def
-
- and childrenLogicTypeDef vis def =
- match def with
- | LTsum l ->
- let l' = mapNoCopy (visitCilLogicCtorInfoAddTable vis) l in
- if l != l' then LTsum l' else def
- | LTsyn typ ->
- let typ' = visitCilLogicType vis typ in
- if typ != typ' then LTsyn typ else def
-
- and visitCilLogicCtorInfoAddTable vis ctor =
- let ctor' = visitCilLogicCtorInfo vis ctor in
- if is_copy_behavior vis#behavior then
- Queue.add
- (fun () ->
- Logic_env.add_logic_ctor ctor'.ctor_name ctor')
- vis#get_filling_actions;
- ctor'
-
- and visitCilLogicCtorInfo vis ctor =
- doVisitCil vis id vis#vlogic_ctor_info_decl childrenLogicCtorInfo ctor
-
- and childrenLogicCtorInfo vis ctor =
- let ctor_type = doVisitCil vis vis#behavior.get_logic_type_info
- vis#vlogic_type_info_use alphabetabeta ctor.ctor_type
- in
- let ctor_params = ctor.ctor_params in
- let ctor_params' = mapNoCopy (visitCilLogicType vis) ctor_params in
- if ctor_type != ctor.ctor_type || ctor_params != ctor_params' then
- { ctor with ctor_type = ctor_type; ctor_params = ctor_params' }
- else ctor
-
- and visitCilLogicType vis t =
- doVisitCil vis id vis#vlogic_type childrenLogicType t
-
- and childrenLogicType vis ty =
- match ty with
- Ctype t ->
- let t' = visitCilType vis t in
- if t != t' then Ctype t' else ty
- | Linteger | Lreal -> ty
- | Ltype (s,l) ->
- let s' = doVisitCil vis vis#behavior.get_logic_type_info
- vis#vlogic_type_info_use alphabetabeta s in
- let l' = mapNoCopy (visitCilLogicType vis) l in
- if s' != s || l' != l then Ltype (s',l') else ty
- | Larrow(args,rttyp) ->
- let args' = mapNoCopy(visitCilLogicType vis) args in
- let rttyp' = visitCilLogicType vis rttyp in
- if args' != args || rttyp' != rttyp then Larrow(args',rttyp') else ty
- | Lvar _ -> ty
-
- and visitCilLogicVarDecl vis lv =
- (* keep names in C and logic worlds in sync *)
- (match lv.lv_origin with
- None -> ()
- | Some cv -> lv.lv_name <- cv.vname);
- doVisitCil vis vis#behavior.memo_logic_var vis#vlogic_var_decl
- childrenLogicVarDecl lv
-
- and childrenLogicVarDecl vis lv =
- lv.lv_type <- visitCilLogicType vis lv.lv_type;
- lv.lv_origin <-
- optMapNoCopy (visitCilVarUse vis) lv.lv_origin;
- lv
-
- and visitCilLogicVarUse vis lv =
- if vis#behavior.is_copy_behavior &&
- (* In a copy visitor, there's always a project. Furthermore, if
- we target the current project, builtins are by definition already
- tied to logic_infos and should not be copied.
- *)
- not (Project.is_current (Extlib.the vis#project)) &&
- Logic_env.is_builtin_logic_function lv.lv_name
- then begin
- (* Do as if the variable has been declared.
- We'll fill the logic info table of the new project at the end.
- Behavior's logic_var table is filled as a side effect.
- *)
- let siblings = Logic_env.find_all_logic_functions lv.lv_name in
- let siblings' = List.map (visitCilLogicInfo vis) siblings in
- (*Format.printf "new vars:@.";
- List.iter (fun x -> Format.printf "%s#%d@." x.l_var_info.lv_name x.l_var_info.lv_id) siblings';
- *)
- Queue.add
- (fun () ->
- if not (Logic_env.Logic_builtin_used.mem lv.lv_name) then begin
- (* Format.printf
- "Adding info for %s#%d@."
- x.l_var_info.lv_name x.l_var_info.lv_id; *)
- Logic_env.Logic_builtin_used.add lv.lv_name siblings';
- Logic_env.Logic_info.add lv.lv_name siblings'
- end)
- vis#get_filling_actions;
- end;
- doVisitCil vis vis#behavior.get_logic_var vis#vlogic_var_use
- childrenLogicVarUse lv
-
- and childrenLogicVarUse vis lv =
- lv.lv_origin <- optMapNoCopy (visitCilVarUse vis) lv.lv_origin; lv
-
- and visitCilQuantifiers vis lv =
- doVisitCil vis id vis#vquantifiers
- (fun vis l -> mapNoCopy (visitCilLogicVarDecl vis) l) lv
-
- and visitCilIdPredicate vis ip =
- doVisitCil
- vis
- vis#behavior.cidentified_predicate
- vis#videntified_predicate
- childrenIdentified_predicate
- ip
- and visitCilPredicateNode vis p =
- doVisitCil vis id vis#vpredicate_node childrenPredicateNode p
-
- and visitCilPredicate vis p =
- doVisitCil vis
- id vis#vpredicate childrenPredicate p
-
- and childrenIdentified_predicate vis ip =
+ let siblings = Logic_env.find_all_logic_functions lv.lv_name in
+ let siblings' = List.map (visitCilLogicInfo vis) siblings in
+ (*Format.printf "new vars:@.";
+ List.iter (fun x -> Format.printf "%s#%d@." x.l_var_info.lv_name x.l_var_info.lv_id) siblings';
+ *)
+ Queue.add
+ (fun () ->
+ if not (Logic_env.Logic_builtin_used.mem lv.lv_name) then begin
+ (* Format.printf
+ "Adding info for %s#%d@."
+ x.l_var_info.lv_name x.l_var_info.lv_id; *)
+ Logic_env.Logic_builtin_used.add lv.lv_name siblings';
+ Logic_env.Logic_info.add lv.lv_name siblings'
+ end)
+ vis#get_filling_actions;
+ end;
+ doVisitCil vis vis#behavior.get_logic_var vis#vlogic_var_use
+ childrenLogicVarUse lv
+
+and childrenLogicVarUse vis lv =
+ lv.lv_origin <- optMapNoCopy (visitCilVarUse vis) lv.lv_origin; lv
+
+and visitCilQuantifiers vis lv =
+ doVisitCil vis id vis#vquantifiers
+ (fun vis l -> mapNoCopy (visitCilLogicVarDecl vis) l) lv
+
+and visitCilIdPredicate vis ip =
+ doVisitCil
+ vis
+ vis#behavior.cidentified_predicate
+ vis#videntified_predicate
+ childrenIdentified_predicate
+ ip
+and visitCilPredicateNode vis p =
+ doVisitCil vis id vis#vpredicate_node childrenPredicateNode p
+
+and visitCilPredicate vis p =
+ doVisitCil vis
+ id vis#vpredicate childrenPredicate p
+
+and childrenIdentified_predicate vis ip =
let p = ip.ip_content in
let p' = visitCilPredicate vis p in
if p != p' then { ip with ip_content = p' }
else ip
- and childrenPredicate vis p =
- let content = visitCilPredicateNode vis p.pred_content in
- if content != p.pred_content then { p with pred_content = content} else p
-
- and childrenPredicateNode vis p =
- let vPred p = visitCilPredicate vis p in
- let vLogicInfo li = visitCilLogicInfoUse vis li in
- let vTerm t = visitCilTerm vis t in
- match p with
- Pfalse | Ptrue -> p
- | Papp (pred,labels,args) ->
- let pred' = vLogicInfo pred in
- let labels' = mapNoCopy (visitCilLogicLabel vis) labels in
- let args' = mapNoCopy vTerm args in
- if pred' != pred || labels' != labels || args' != args then
- Papp(pred',labels',args')
- else p
- | Prel(rel,t1,t2) ->
- let t1' = vTerm t1 in
- let t2' = vTerm t2 in
- if t1' != t1 || t2' != t2 then
- Prel(rel,t1',t2')
- else p
- | Pand(p1,p2) ->
- let p1' = vPred p1 in
- let p2' = vPred p2 in
- if p1' != p1 || p2' != p2 then
- Pand(p1',p2')
- else p
- | Por(p1,p2) ->
- let p1' = vPred p1 in
- let p2' = vPred p2 in
- if p1' != p1 || p2' != p2 then
- Por(p1',p2')
- else p
- | Pxor(p1,p2) ->
- let p1' = vPred p1 in
- let p2' = vPred p2 in
- if p1' != p1 || p2' != p2 then
- Pxor(p1',p2')
- else p
- | Pimplies(p1,p2) ->
- let p1' = vPred p1 in
- let p2' = vPred p2 in
- if p1' != p1 || p2' != p2 then
- Pimplies(p1',p2')
- else p
- | Piff(p1,p2) ->
- let p1' = vPred p1 in
- let p2' = vPred p2 in
- if p1' != p1 || p2' != p2 then
- Piff(p1',p2')
- else p
- | Pnot p1 ->
- let p1' = vPred p1 in
- if p1' != p1 then Pnot p1' else p
- | Pif(t,ptrue,pfalse) ->
- let t' = vTerm t in
- let ptrue' = vPred ptrue in
- let pfalse' = vPred pfalse in
- if t' != t || ptrue' != ptrue || pfalse' != pfalse then
- Pif(t', ptrue',pfalse')
- else p
- | Plet(def,p1) ->
- let def' = visitCilLogicInfo vis def in
- let p1' = vPred p1 in
- if def' != def || p1' != p1 then
- Plet(def',p1')
- else p
- | Pforall(quant,p1) ->
- let quant' = visitCilQuantifiers vis quant in
- let p1' = vPred p1 in
- if quant' != quant || p1' != p1 then
- Pforall(quant', p1')
- else p
- | Pexists(quant,p1) ->
- let quant' = visitCilQuantifiers vis quant in
- let p1' = vPred p1 in
- if quant' != quant || p1' != p1 then
- Pexists(quant', p1')
- else p
- | Pat(p1,s) ->
- let p1' = vPred p1 in
- let s' = visitCilLogicLabel vis s in
- if p1' != p1 || s != s' then Pat(p1',s') else p
- | Pallocable (s,t) ->
- let s' = visitCilLogicLabel vis s in
- let t' = vTerm t in
- if t' != t || s != s' then Pallocable (s',t') else p
- | Pfreeable (s,t) ->
- let s' = visitCilLogicLabel vis s in
- let t' = vTerm t in
- if t' != t || s != s' then Pfreeable (s',t') else p
- | Pvalid (s,t) ->
- let s' = visitCilLogicLabel vis s in
- let t' = vTerm t in
- if t' != t || s != s' then Pvalid (s',t') else p
- | Pvalid_read (s,t) ->
- let s' = visitCilLogicLabel vis s in
- let t' = vTerm t in
- if t' != t || s != s' then Pvalid_read (s',t') else p
- | Pvalid_function t ->
- let t' = vTerm t in
- if t' != t then Pvalid_function t' else p
- | Pinitialized (s,t) ->
- let s' = visitCilLogicLabel vis s in
- let t' = vTerm t in
- if t' != t || s != s' then Pinitialized (s',t') else p
- | Pdangling (s,t) ->
- let s' = visitCilLogicLabel vis s in
- let t' = vTerm t in
- if t' != t || s != s' then Pdangling (s',t') else p
- | Pseparated seps ->
- let seps' = mapNoCopy vTerm seps in
- if seps' != seps then Pseparated seps' else p
- | Pfresh (s1,s2,t,n) ->
- let s1' = visitCilLogicLabel vis s1 in
- let s2' = visitCilLogicLabel vis s2 in
- let t' = vTerm t in
- let n' = vTerm n in
- if t' != t || n' != n || s1 != s1' || s2 != s2' then Pfresh (s1',s2',t',n') else p
+and childrenPredicate vis p =
+ let content = visitCilPredicateNode vis p.pred_content in
+ if content != p.pred_content then { p with pred_content = content} else p
+
+and childrenPredicateNode vis p =
+ let vPred p = visitCilPredicate vis p in
+ let vLogicInfo li = visitCilLogicInfoUse vis li in
+ let vTerm t = visitCilTerm vis t in
+ match p with
+ Pfalse | Ptrue -> p
+ | Papp (pred,labels,args) ->
+ let pred' = vLogicInfo pred in
+ let labels' = mapNoCopy (visitCilLogicLabel vis) labels in
+ let args' = mapNoCopy vTerm args in
+ if pred' != pred || labels' != labels || args' != args then
+ Papp(pred',labels',args')
+ else p
+ | Prel(rel,t1,t2) ->
+ let t1' = vTerm t1 in
+ let t2' = vTerm t2 in
+ if t1' != t1 || t2' != t2 then
+ Prel(rel,t1',t2')
+ else p
+ | Pand(p1,p2) ->
+ let p1' = vPred p1 in
+ let p2' = vPred p2 in
+ if p1' != p1 || p2' != p2 then
+ Pand(p1',p2')
+ else p
+ | Por(p1,p2) ->
+ let p1' = vPred p1 in
+ let p2' = vPred p2 in
+ if p1' != p1 || p2' != p2 then
+ Por(p1',p2')
+ else p
+ | Pxor(p1,p2) ->
+ let p1' = vPred p1 in
+ let p2' = vPred p2 in
+ if p1' != p1 || p2' != p2 then
+ Pxor(p1',p2')
+ else p
+ | Pimplies(p1,p2) ->
+ let p1' = vPred p1 in
+ let p2' = vPred p2 in
+ if p1' != p1 || p2' != p2 then
+ Pimplies(p1',p2')
+ else p
+ | Piff(p1,p2) ->
+ let p1' = vPred p1 in
+ let p2' = vPred p2 in
+ if p1' != p1 || p2' != p2 then
+ Piff(p1',p2')
+ else p
+ | Pnot p1 ->
+ let p1' = vPred p1 in
+ if p1' != p1 then Pnot p1' else p
+ | Pif(t,ptrue,pfalse) ->
+ let t' = vTerm t in
+ let ptrue' = vPred ptrue in
+ let pfalse' = vPred pfalse in
+ if t' != t || ptrue' != ptrue || pfalse' != pfalse then
+ Pif(t', ptrue',pfalse')
+ else p
+ | Plet(def,p1) ->
+ let def' = visitCilLogicInfo vis def in
+ let p1' = vPred p1 in
+ if def' != def || p1' != p1 then
+ Plet(def',p1')
+ else p
+ | Pforall(quant,p1) ->
+ let quant' = visitCilQuantifiers vis quant in
+ let p1' = vPred p1 in
+ if quant' != quant || p1' != p1 then
+ Pforall(quant', p1')
+ else p
+ | Pexists(quant,p1) ->
+ let quant' = visitCilQuantifiers vis quant in
+ let p1' = vPred p1 in
+ if quant' != quant || p1' != p1 then
+ Pexists(quant', p1')
+ else p
+ | Pat(p1,s) ->
+ let p1' = vPred p1 in
+ let s' = visitCilLogicLabel vis s in
+ if p1' != p1 || s != s' then Pat(p1',s') else p
+ | Pallocable (s,t) ->
+ let s' = visitCilLogicLabel vis s in
+ let t' = vTerm t in
+ if t' != t || s != s' then Pallocable (s',t') else p
+ | Pfreeable (s,t) ->
+ let s' = visitCilLogicLabel vis s in
+ let t' = vTerm t in
+ if t' != t || s != s' then Pfreeable (s',t') else p
+ | Pvalid (s,t) ->
+ let s' = visitCilLogicLabel vis s in
+ let t' = vTerm t in
+ if t' != t || s != s' then Pvalid (s',t') else p
+ | Pvalid_read (s,t) ->
+ let s' = visitCilLogicLabel vis s in
+ let t' = vTerm t in
+ if t' != t || s != s' then Pvalid_read (s',t') else p
+ | Pvalid_function t ->
+ let t' = vTerm t in
+ if t' != t then Pvalid_function t' else p
+ | Pinitialized (s,t) ->
+ let s' = visitCilLogicLabel vis s in
+ let t' = vTerm t in
+ if t' != t || s != s' then Pinitialized (s',t') else p
+ | Pdangling (s,t) ->
+ let s' = visitCilLogicLabel vis s in
+ let t' = vTerm t in
+ if t' != t || s != s' then Pdangling (s',t') else p
+ | Pseparated seps ->
+ let seps' = mapNoCopy vTerm seps in
+ if seps' != seps then Pseparated seps' else p
+ | Pfresh (s1,s2,t,n) ->
+ let s1' = visitCilLogicLabel vis s1 in
+ let s2' = visitCilLogicLabel vis s2 in
+ let t' = vTerm t in
+ let n' = vTerm n in
+ if t' != t || n' != n || s1 != s1' || s2 != s2' then Pfresh (s1',s2',t',n') else p
and visitCilIdTerm vis loc =
- doVisitCil vis vis#behavior.cidentified_term vis#videntified_term
- childrenIdentified_term loc
+ doVisitCil vis vis#behavior.cidentified_term vis#videntified_term
+ childrenIdentified_term loc
and childrenIdentified_term vis loc =
- let loc' = visitCilTerm vis loc.it_content in
- if loc' != loc.it_content then { loc with it_content = loc' } else loc
+ let loc' = visitCilTerm vis loc.it_content in
+ if loc' != loc.it_content then { loc with it_content = loc' } else loc
and visitCilAllocation vis fa =
doVisitCil vis id vis#vallocation childrenAllocation fa
and childrenAllocation vis fa =
match fa with
- FreeAllocAny -> fa
- | FreeAlloc(f,a) ->
- let f' = visitCilFrees vis f in
- let a' = visitCilAllocates vis a in
- if f != f' || a' != a then FreeAlloc(f',a') else fa
-
- and visitCilFrees vis l =
- doVisitCil vis id vis#vfrees childrenFreeAlloc l
- and visitCilAllocates vis l =
- doVisitCil vis id vis#vallocates childrenFreeAlloc l
- and childrenFreeAlloc vis l =
- mapNoCopy (visitCilIdTerm vis) l
-
- and visitCilAssigns vis a =
- doVisitCil vis id vis#vassigns childrenAssigns a
- and childrenAssigns vis a =
+ FreeAllocAny -> fa
+ | FreeAlloc(f,a) ->
+ let f' = visitCilFrees vis f in
+ let a' = visitCilAllocates vis a in
+ if f != f' || a' != a then FreeAlloc(f',a') else fa
+
+and visitCilFrees vis l =
+ doVisitCil vis id vis#vfrees childrenFreeAlloc l
+and visitCilAllocates vis l =
+ doVisitCil vis id vis#vallocates childrenFreeAlloc l
+and childrenFreeAlloc vis l =
+ mapNoCopy (visitCilIdTerm vis) l
+
+and visitCilAssigns vis a =
+ doVisitCil vis id vis#vassigns childrenAssigns a
+and childrenAssigns vis a =
match a with
- WritesAny -> a
- | Writes l ->
- let l' = mapNoCopy (visitCilFrom vis) l in
- if l' != l then Writes l' else a
+ WritesAny -> a
+ | Writes l ->
+ let l' = mapNoCopy (visitCilFrom vis) l in
+ if l' != l then Writes l' else a
and visitCilFrom vis f =
doVisitCil vis id vis#vfrom childrenFrom f
@@ -2931,27 +2931,27 @@ and visitCilDeps vis d =
doVisitCil vis id vis#vdeps childrenDeps d
and childrenDeps vis d =
match d with
- FromAny -> d
- | From l ->
- let l' = mapNoCopy (visitCilIdTerm vis) l in
- if l !=l' then From l' else d
+ FromAny -> d
+ | From l ->
+ let l' = mapNoCopy (visitCilIdTerm vis) l in
+ if l !=l' then From l' else d
and visitCilBehavior vis b =
- doVisitCil vis vis#behavior.cfunbehavior
- vis#vbehavior childrenBehavior b
+ doVisitCil vis vis#behavior.cfunbehavior
+ vis#vbehavior childrenBehavior b
and childrenBehavior vis b =
- b.b_assumes <- visitCilPredicates vis b.b_assumes;
- b.b_requires <- visitCilPredicates vis b.b_requires;
- b.b_post_cond <-
- mapNoCopy
- (function ((k,p) as pc) ->
- let p' = visitCilIdPredicate vis p in if p != p' then (k,p') else pc)
- b.b_post_cond;
- b.b_assigns <- visitCilAssigns vis b.b_assigns;
- b.b_allocation <- visitCilAllocation vis b.b_allocation ;
- b.b_extended <- mapNoCopy (visitCilExtended vis) b.b_extended;
- b
+ b.b_assumes <- visitCilPredicates vis b.b_assumes;
+ b.b_requires <- visitCilPredicates vis b.b_requires;
+ b.b_post_cond <-
+ mapNoCopy
+ (function ((k,p) as pc) ->
+ let p' = visitCilIdPredicate vis p in if p != p' then (k,p') else pc)
+ b.b_post_cond;
+ b.b_assigns <- visitCilAssigns vis b.b_assigns;
+ b.b_allocation <- visitCilAllocation vis b.b_allocation ;
+ b.b_extended <- mapNoCopy (visitCilExtended vis) b.b_extended;
+ b
and visitCilExtended vis orig =
let visit =
@@ -2961,7 +2961,7 @@ and visitCilExtended vis orig =
let e' = doVisitCil vis id (visit vis) childrenCilExtended orig.ext_kind in
if is_fresh_behavior vis#behavior then
Logic_const.new_acsl_extension orig.ext_name orig.ext_loc
- orig.ext_has_status e'
+ orig.ext_has_status e'
else if orig.ext_kind == e' then orig else {orig with ext_kind = e'}
and childrenCilExtended vis p =
@@ -2992,52 +2992,52 @@ and childrenSpec vis s =
*)
s
- and visitCilSlicePragma vis p =
- doVisitCil vis id vis#vslice_pragma childrenSlicePragma p
-
- and childrenSlicePragma vis p =
- match p with
- | SPexpr t ->
- let t' = visitCilTerm vis t in if t' != t then SPexpr t' else p
- | SPctrl | SPstmt -> p
+and visitCilSlicePragma vis p =
+ doVisitCil vis id vis#vslice_pragma childrenSlicePragma p
- and visitCilImpactPragma vis p =
- doVisitCil vis id vis#vimpact_pragma childrenImpactPragma p
+and childrenSlicePragma vis p =
+ match p with
+ | SPexpr t ->
+ let t' = visitCilTerm vis t in if t' != t then SPexpr t' else p
+ | SPctrl | SPstmt -> p
- and childrenImpactPragma vis p = match p with
- | IPexpr t -> let t' = visitCilTerm vis t in if t' != t then IPexpr t' else p
- | IPstmt -> p
+and visitCilImpactPragma vis p =
+ doVisitCil vis id vis#vimpact_pragma childrenImpactPragma p
- and visitCilLoopPragma vis p =
- doVisitCil vis
- id vis#vloop_pragma childrenLoopPragma p
+and childrenImpactPragma vis p = match p with
+ | IPexpr t -> let t' = visitCilTerm vis t in if t' != t then IPexpr t' else p
+ | IPstmt -> p
- and childrenLoopPragma vis p =
- match p with
- | Unroll_specs lt -> let lt' = mapNoCopy (visitCilTerm vis) lt in
- if lt' != lt then Unroll_specs lt' else p
- | Widen_hints lt -> let lt' = mapNoCopy (visitCilTerm vis) lt in
- if lt' != lt then Widen_hints lt' else p
- | Widen_variables lt -> let lt' = mapNoCopy (visitCilTerm vis) lt in
- if lt' != lt then Widen_variables lt' else p
+and visitCilLoopPragma vis p =
+ doVisitCil vis
+ id vis#vloop_pragma childrenLoopPragma p
- and childrenModelInfo vis m =
+and childrenLoopPragma vis p =
+ match p with
+ | Unroll_specs lt -> let lt' = mapNoCopy (visitCilTerm vis) lt in
+ if lt' != lt then Unroll_specs lt' else p
+ | Widen_hints lt -> let lt' = mapNoCopy (visitCilTerm vis) lt in
+ if lt' != lt then Widen_hints lt' else p
+ | Widen_variables lt -> let lt' = mapNoCopy (visitCilTerm vis) lt in
+ if lt' != lt then Widen_variables lt' else p
+
+and childrenModelInfo vis m =
let field_type = visitCilLogicType vis m.mi_field_type in
let base_type = visitCilType vis m.mi_base_type in
let mi_attr = visitCilAttributes vis m.mi_attr in
if
field_type != m.mi_field_type || base_type != m.mi_base_type
then
- {
- mi_name = m.mi_name;
- mi_field_type = field_type;
- mi_base_type = base_type;
- mi_decl = Cil_datatype.Location.copy m.mi_decl;
- mi_attr;
- }
+ {
+ mi_name = m.mi_name;
+ mi_field_type = field_type;
+ mi_base_type = base_type;
+ mi_decl = Cil_datatype.Location.copy m.mi_decl;
+ mi_attr;
+ }
else begin m.mi_attr <- mi_attr; m end
- and visitCilModelInfo vis m =
+and visitCilModelInfo vis m =
let oldloc = CurrentLoc.get () in
CurrentLoc.set m.mi_decl;
let m' =
@@ -3052,123 +3052,123 @@ and childrenSpec vis s =
end;
m'
- and visitCilAnnotation vis a =
- let oldloc = CurrentLoc.get () in
- CurrentLoc.set (Global_annotation.loc a);
- let res = doVisitCil vis id vis#vannotation childrenAnnotation a in
- CurrentLoc.set oldloc;
- res
-
- and childrenAnnotation vis a =
- match a with
- | Dfun_or_pred (li,loc) ->
- let li' = visitCilLogicInfo vis li in
- if vis#behavior.is_copy_behavior then
- Queue.add
- (fun () ->
- Logic_env.add_logic_function_gen alphabetafalse li')
- vis#get_filling_actions;
- if li' != li then Dfun_or_pred (li',loc) else a
- | Dtype (ti,loc) ->
- let ti' = visitCilLogicTypeInfo vis ti in
- if vis#behavior.is_copy_behavior then
- Queue.add
- (fun () ->
- Logic_env.add_logic_type ti'.lt_name ti')
- vis#get_filling_actions;
- if ti' != ti then Dtype (ti',loc) else a
- | Dlemma(s,is_axiom,labels,tvars,p,attr,loc) ->
- let p' = visitCilPredicate vis p in
- let attr' = visitCilAttributes vis attr in
- if p' != p || attr != attr' then
- Dlemma(s,is_axiom,labels,tvars,p',attr',loc)
- else a
- | Dinvariant (p,loc) ->
- let p' = visitCilLogicInfo vis p in
- if vis#behavior.is_copy_behavior then
- Queue.add
- (fun () -> Logic_env.add_logic_function_gen alphabetafalse p')
- vis#get_filling_actions;
- if p' != p then Dinvariant (p',loc) else a
- | Dtype_annot (ta,loc) ->
- let ta' = visitCilLogicInfo vis ta in
- if vis#behavior.is_copy_behavior then
- Queue.add
- (fun () -> Logic_env.add_logic_function_gen alphabetafalse ta')
- vis#get_filling_actions;
- if ta' != ta then Dtype_annot (ta',loc) else a
- | Dmodel_annot (mfi,loc) ->
- let mfi' = visitCilModelInfo vis mfi in
- if vis#behavior.is_copy_behavior then
- Queue.add (fun () -> Logic_env.add_model_field mfi')
- vis#get_filling_actions;
- if mfi' != mfi then Dmodel_annot (mfi',loc) else a
- | Dcustom_annot(c,n,attr,loc) ->
- let attr' = visitCilAttributes vis attr in
- if attr != attr' then Dcustom_annot(c,n,attr',loc) else a
- | Dvolatile(tset,rvi,wvi,attr,loc) ->
- let tset' = mapNoCopy (visitCilIdTerm vis) tset in
- let rvi' = optMapNoCopy (visitCilVarUse vis) rvi in
- let wvi' = optMapNoCopy (visitCilVarUse vis) wvi in
- let attr' = visitCilAttributes vis attr in
- if tset' != tset || rvi' != rvi || wvi' != wvi || attr' != attr then
- Dvolatile(tset',rvi',wvi',attr',loc)
- else a
- | Daxiomatic(id,l,attr,loc) ->
+and visitCilAnnotation vis a =
+ let oldloc = CurrentLoc.get () in
+ CurrentLoc.set (Global_annotation.loc a);
+ let res = doVisitCil vis id vis#vannotation childrenAnnotation a in
+ CurrentLoc.set oldloc;
+ res
+
+and childrenAnnotation vis a =
+ match a with
+ | Dfun_or_pred (li,loc) ->
+ let li' = visitCilLogicInfo vis li in
+ if vis#behavior.is_copy_behavior then
+ Queue.add
+ (fun () ->
+ Logic_env.add_logic_function_gen alphabetafalse li')
+ vis#get_filling_actions;
+ if li' != li then Dfun_or_pred (li',loc) else a
+ | Dtype (ti,loc) ->
+ let ti' = visitCilLogicTypeInfo vis ti in
+ if vis#behavior.is_copy_behavior then
+ Queue.add
+ (fun () ->
+ Logic_env.add_logic_type ti'.lt_name ti')
+ vis#get_filling_actions;
+ if ti' != ti then Dtype (ti',loc) else a
+ | Dlemma(s,is_axiom,labels,tvars,p,attr,loc) ->
+ let p' = visitCilPredicate vis p in
+ let attr' = visitCilAttributes vis attr in
+ if p' != p || attr != attr' then
+ Dlemma(s,is_axiom,labels,tvars,p',attr',loc)
+ else a
+ | Dinvariant (p,loc) ->
+ let p' = visitCilLogicInfo vis p in
+ if vis#behavior.is_copy_behavior then
+ Queue.add
+ (fun () -> Logic_env.add_logic_function_gen alphabetafalse p')
+ vis#get_filling_actions;
+ if p' != p then Dinvariant (p',loc) else a
+ | Dtype_annot (ta,loc) ->
+ let ta' = visitCilLogicInfo vis ta in
+ if vis#behavior.is_copy_behavior then
+ Queue.add
+ (fun () -> Logic_env.add_logic_function_gen alphabetafalse ta')
+ vis#get_filling_actions;
+ if ta' != ta then Dtype_annot (ta',loc) else a
+ | Dmodel_annot (mfi,loc) ->
+ let mfi' = visitCilModelInfo vis mfi in
+ if vis#behavior.is_copy_behavior then
+ Queue.add (fun () -> Logic_env.add_model_field mfi')
+ vis#get_filling_actions;
+ if mfi' != mfi then Dmodel_annot (mfi',loc) else a
+ | Dcustom_annot(c,n,attr,loc) ->
+ let attr' = visitCilAttributes vis attr in
+ if attr != attr' then Dcustom_annot(c,n,attr',loc) else a
+ | Dvolatile(tset,rvi,wvi,attr,loc) ->
+ let tset' = mapNoCopy (visitCilIdTerm vis) tset in
+ let rvi' = optMapNoCopy (visitCilVarUse vis) rvi in
+ let wvi' = optMapNoCopy (visitCilVarUse vis) wvi in
+ let attr' = visitCilAttributes vis attr in
+ if tset' != tset || rvi' != rvi || wvi' != wvi || attr' != attr then
+ Dvolatile(tset',rvi',wvi',attr',loc)
+ else a
+ | Daxiomatic(id,l,attr,loc) ->
(*
Format.eprintf "cil.visitCilAnnotation on axiomatic %s@." id;
*)
- let l' = mapNoCopy (visitCilAnnotation vis) l in
- let attr' = visitCilAttributes vis attr in
- if l' != l || attr != attr' then Daxiomatic(id,l',attr',loc) else a
- | Dextended (e,attr,loc) ->
- let e' = visitCilExtended vis e in
- let attr' = visitCilAttributes vis attr in
- if e != e' || attr != attr' then Dextended(e',attr', loc) else a
-
- and visitCilCodeAnnotation vis ca =
- doVisitCil
- vis vis#behavior.ccode_annotation vis#vcode_annot childrenCodeAnnot ca
-
- and childrenCodeAnnot vis ca =
- let vPred p = visitCilPredicate vis p in
- let vTerm t = visitCilTerm vis t in
- let vSpec s = visitCilFunspec vis s in
- let change_content annot = { ca with annot_content = annot } in
- match ca.annot_content with
- AAssert (behav,kind,p) ->
- let p' = vPred p in if p' != p then
- change_content (AAssert (behav,kind,p'))
- else ca
- | APragma (Impact_pragma t) ->
- let t' = visitCilImpactPragma vis t in
- if t' != t then change_content (APragma (Impact_pragma t')) else ca
- | APragma (Slice_pragma t) ->
- let t' = visitCilSlicePragma vis t in
- if t' != t then change_content (APragma (Slice_pragma t')) else ca
- | APragma (Loop_pragma p) ->
- let p' = visitCilLoopPragma vis p in
- if p' != p then change_content (APragma (Loop_pragma p')) else ca
- | AStmtSpec (behav,s) ->
- let s' = vSpec s in
- if s' != s then change_content (AStmtSpec (behav,s')) else ca
- | AInvariant(behav,f,p) ->
- let p' = vPred p in
- if p' != p then change_content (AInvariant (behav,f,p')) else ca
- | AVariant ((t,s)) ->
- let t' = vTerm t in
- if t != t' then change_content (AVariant ((t',s))) else ca
- | AAssigns(behav, a) ->
- let a' = visitCilAssigns vis a in
- if a != a' then change_content (AAssigns (behav,a')) else ca
- | AAllocation(behav, fa) ->
- let fa' = visitCilAllocation vis fa in
- if fa != fa' then change_content (AAllocation (behav,fa')) else ca
- | AExtended(behav, is_loop, ext) ->
- let ext' = visitCilExtended vis ext in
- if ext' != ext then
- change_content (AExtended (behav, is_loop, ext'))
- else ca
+ let l' = mapNoCopy (visitCilAnnotation vis) l in
+ let attr' = visitCilAttributes vis attr in
+ if l' != l || attr != attr' then Daxiomatic(id,l',attr',loc) else a
+ | Dextended (e,attr,loc) ->
+ let e' = visitCilExtended vis e in
+ let attr' = visitCilAttributes vis attr in
+ if e != e' || attr != attr' then Dextended(e',attr', loc) else a
+
+and visitCilCodeAnnotation vis ca =
+ doVisitCil
+ vis vis#behavior.ccode_annotation vis#vcode_annot childrenCodeAnnot ca
+
+and childrenCodeAnnot vis ca =
+ let vPred p = visitCilPredicate vis p in
+ let vTerm t = visitCilTerm vis t in
+ let vSpec s = visitCilFunspec vis s in
+ let change_content annot = { ca with annot_content = annot } in
+ match ca.annot_content with
+ AAssert (behav,kind,p) ->
+ let p' = vPred p in if p' != p then
+ change_content (AAssert (behav,kind,p'))
+ else ca
+ | APragma (Impact_pragma t) ->
+ let t' = visitCilImpactPragma vis t in
+ if t' != t then change_content (APragma (Impact_pragma t')) else ca
+ | APragma (Slice_pragma t) ->
+ let t' = visitCilSlicePragma vis t in
+ if t' != t then change_content (APragma (Slice_pragma t')) else ca
+ | APragma (Loop_pragma p) ->
+ let p' = visitCilLoopPragma vis p in
+ if p' != p then change_content (APragma (Loop_pragma p')) else ca
+ | AStmtSpec (behav,s) ->
+ let s' = vSpec s in
+ if s' != s then change_content (AStmtSpec (behav,s')) else ca
+ | AInvariant(behav,f,p) ->
+ let p' = vPred p in
+ if p' != p then change_content (AInvariant (behav,f,p')) else ca
+ | AVariant ((t,s)) ->
+ let t' = vTerm t in
+ if t != t' then change_content (AVariant ((t',s))) else ca
+ | AAssigns(behav, a) ->
+ let a' = visitCilAssigns vis a in
+ if a != a' then change_content (AAssigns (behav,a')) else ca
+ | AAllocation(behav, fa) ->
+ let fa' = visitCilAllocation vis fa in
+ if fa != fa' then change_content (AAllocation (behav,fa')) else ca
+ | AExtended(behav, is_loop, ext) ->
+ let ext' = visitCilExtended vis ext in
+ if ext' != ext then
+ change_content (AExtended (behav, is_loop, ext'))
+ else ca
and visitCilExpr (vis: cilVisitor) (e: exp) : exp =
let oldLoc = CurrentLoc.get () in
@@ -3187,205 +3187,205 @@ and childrenExp (vis: cilVisitor) (e: exp) : exp =
let c' = visitCilConst vis c in
if c' != c then new_exp (Const c') else e
| SizeOf t ->
- let t'= vTyp t in
- if t' != t then new_exp (SizeOf t') else e
+ let t'= vTyp t in
+ if t' != t then new_exp (SizeOf t') else e
| SizeOfE e1 ->
- let e1' = vExp e1 in
- if e1' != e1 then new_exp (SizeOfE e1') else e
+ let e1' = vExp e1 in
+ if e1' != e1 then new_exp (SizeOfE e1') else e
| SizeOfStr _s -> e
- | AlignOf t ->
- let t' = vTyp t in
- if t' != t then new_exp (AlignOf t') else e
- | AlignOfE e1 ->
- let e1' = vExp e1 in
- if e1' != e1 then new_exp (AlignOfE e1') else e
- | Lval lv ->
- let lv' = vLval lv in
- if lv' != lv then new_exp (Lval lv') else e
- | UnOp (uo, e1, t) ->
- let e1' = vExp e1 in let t' = vTyp t in
- if e1' != e1 || t' != t then new_exp (UnOp(uo, e1', t')) else e
- | BinOp (bo, e1, e2, t) ->
- let e1' = vExp e1 in let e2' = vExp e2 in let t' = vTyp t in
- if e1' != e1 || e2' != e2 || t' != t then
- new_exp (BinOp(bo, e1',e2',t'))
- else e
- | CastE (t, e1) ->
- let t' = vTyp t in let e1' = vExp e1 in
- if t' != t || e1' != e1 then new_exp (CastE(t', e1')) else e
- | AddrOf lv ->
- let lv' = vLval lv in
- if lv' != lv then new_exp (AddrOf lv') else e
- | StartOf lv ->
- let lv' = vLval lv in
- if lv' != lv then new_exp (StartOf lv') else e
-
- and visitCilInit (vis: cilVisitor) (forglob: varinfo)
- (atoff: offset) (i: init) : init =
- let childrenInit (vis: cilVisitor) (i: init) : init =
- let fExp e = visitCilExpr vis e in
- let fTyp t = visitCilType vis t in
- match i with
- | SingleInit e ->
- let e' = fExp e in
- if e' != e then SingleInit e' else i
- | CompoundInit (t, initl) ->
- let t' = fTyp t in
- (* Collect the new initializer list, in reverse. We prefer two
- * traversals to ensure tail-recursion. *)
- let newinitl : (offset * init) list ref = ref [] in
- (* Keep track whether the list has changed *)
- let hasChanged = ref false in
- let doOneInit ((o, i) as oi) =
- let o' = visitCilInitOffset vis o in (* use initializer version *)
- let i' = visitCilInit vis forglob (addOffset o' atoff) i in
- let newio =
- if o' != o || i' != i then
- begin hasChanged := true; (o', i') end else oi
- in
- newinitl := newio :: !newinitl
- in
- List.iter doOneInit initl;
- let initl' = if !hasChanged then List.rev !newinitl else initl in
- if t' != t || initl' != initl then CompoundInit (t', initl') else i
- in
- doVisitCil vis id (vis#vinit forglob atoff) childrenInit i
-
- and visitCilLval (vis: cilVisitor) (lv: lval) : lval =
- doVisitCil vis id vis#vlval childrenLval lv
- and childrenLval (vis: cilVisitor) (lv: lval) : lval =
- (* and visit its subexpressions *)
- let vExp e = visitCilExpr vis e in
- let vOff off = visitCilOffset vis off in
- match lv with
- Var v, off ->
- let v'= visitCilVarUse vis v in
- let off' = vOff off in
- if v' != v || off' != off then Var v', off' else lv
- | Mem e, off ->
- let e' = vExp e in
- let off' = vOff off in
- if e' != e || off' != off then Mem e', off' else lv
-
- and visitCilOffset (vis: cilVisitor) (off: offset) : offset =
- doVisitCil vis id vis#voffs childrenOffset off
- and childrenOffset (vis: cilVisitor) (off: offset) : offset =
- let vOff off = visitCilOffset vis off in
- match off with
- Field (f, o) ->
- let o' = vOff o in
- let f' = vis#behavior.get_fieldinfo f in
- if o' != o || f' != f then Field (f', o') else off
- | Index (e, o) ->
- let e' = visitCilExpr vis e in
- let o' = vOff o in
- if e' != e || o' != o then Index (e', o') else off
- | NoOffset -> off
-
- (* sm: for offsets in initializers, the 'startvisit' will be the
- * vinitoffs method, but we can re-use the childrenOffset from
- * above since recursive offsets are visited by voffs. (this point
- * is moot according to cil.mli which claims the offsets in
- * initializers will never recursively contain offsets)
- *)
- and visitCilInitOffset (vis: cilVisitor) (off: offset) : offset =
- doVisitCil vis id vis#vinitoffs childrenOffset off
+ | AlignOf t ->
+ let t' = vTyp t in
+ if t' != t then new_exp (AlignOf t') else e
+ | AlignOfE e1 ->
+ let e1' = vExp e1 in
+ if e1' != e1 then new_exp (AlignOfE e1') else e
+ | Lval lv ->
+ let lv' = vLval lv in
+ if lv' != lv then new_exp (Lval lv') else e
+ | UnOp (uo, e1, t) ->
+ let e1' = vExp e1 in let t' = vTyp t in
+ if e1' != e1 || t' != t then new_exp (UnOp(uo, e1', t')) else e
+ | BinOp (bo, e1, e2, t) ->
+ let e1' = vExp e1 in let e2' = vExp e2 in let t' = vTyp t in
+ if e1' != e1 || e2' != e2 || t' != t then
+ new_exp (BinOp(bo, e1',e2',t'))
+ else e
+ | CastE (t, e1) ->
+ let t' = vTyp t in let e1' = vExp e1 in
+ if t' != t || e1' != e1 then new_exp (CastE(t', e1')) else e
+ | AddrOf lv ->
+ let lv' = vLval lv in
+ if lv' != lv then new_exp (AddrOf lv') else e
+ | StartOf lv ->
+ let lv' = vLval lv in
+ if lv' != lv then new_exp (StartOf lv') else e
+
+and visitCilInit (vis: cilVisitor) (forglob: varinfo)
+ (atoff: offset) (i: init) : init =
+ let childrenInit (vis: cilVisitor) (i: init) : init =
+ let fExp e = visitCilExpr vis e in
+ let fTyp t = visitCilType vis t in
+ match i with
+ | SingleInit e ->
+ let e' = fExp e in
+ if e' != e then SingleInit e' else i
+ | CompoundInit (t, initl) ->
+ let t' = fTyp t in
+ (* Collect the new initializer list, in reverse. We prefer two
+ * traversals to ensure tail-recursion. *)
+ let newinitl : (offset * init) list ref = ref [] in
+ (* Keep track whether the list has changed *)
+ let hasChanged = ref false in
+ let doOneInit ((o, i) as oi) =
+ let o' = visitCilInitOffset vis o in (* use initializer version *)
+ let i' = visitCilInit vis forglob (addOffset o' atoff) i in
+ let newio =
+ if o' != o || i' != i then
+ begin hasChanged := true; (o', i') end else oi
+ in
+ newinitl := newio :: !newinitl
+ in
+ List.iter doOneInit initl;
+ let initl' = if !hasChanged then List.rev !newinitl else initl in
+ if t' != t || initl' != initl then CompoundInit (t', initl') else i
+ in
+ doVisitCil vis id (vis#vinit forglob atoff) childrenInit i
+
+and visitCilLval (vis: cilVisitor) (lv: lval) : lval =
+ doVisitCil vis id vis#vlval childrenLval lv
+and childrenLval (vis: cilVisitor) (lv: lval) : lval =
+ (* and visit its subexpressions *)
+ let vExp e = visitCilExpr vis e in
+ let vOff off = visitCilOffset vis off in
+ match lv with
+ Var v, off ->
+ let v'= visitCilVarUse vis v in
+ let off' = vOff off in
+ if v' != v || off' != off then Var v', off' else lv
+ | Mem e, off ->
+ let e' = vExp e in
+ let off' = vOff off in
+ if e' != e || off' != off then Mem e', off' else lv
+
+and visitCilOffset (vis: cilVisitor) (off: offset) : offset =
+ doVisitCil vis id vis#voffs childrenOffset off
+and childrenOffset (vis: cilVisitor) (off: offset) : offset =
+ let vOff off = visitCilOffset vis off in
+ match off with
+ Field (f, o) ->
+ let o' = vOff o in
+ let f' = vis#behavior.get_fieldinfo f in
+ if o' != o || f' != f then Field (f', o') else off
+ | Index (e, o) ->
+ let e' = visitCilExpr vis e in
+ let o' = vOff o in
+ if e' != e || o' != o then Index (e', o') else off
+ | NoOffset -> off
+
+(* sm: for offsets in initializers, the 'startvisit' will be the
+ * vinitoffs method, but we can re-use the childrenOffset from
+ * above since recursive offsets are visited by voffs. (this point
+ * is moot according to cil.mli which claims the offsets in
+ * initializers will never recursively contain offsets)
+*)
+and visitCilInitOffset (vis: cilVisitor) (off: offset) : offset =
+ doVisitCil vis id vis#vinitoffs childrenOffset off
- and visitCilLocal_init (vis: cilVisitor) vi li =
+and visitCilLocal_init (vis: cilVisitor) vi li =
doVisitCil vis id (vis#vlocal_init vi) (childrenLocal_init vi) li
- and childrenLocal_init vi (vis: cilVisitor) li =
- match li with
- | AssignInit i ->
- let i' = visitCilInit vis vi NoOffset i in
- if i != i' then AssignInit i' else li
- | ConsInit(f,args, k) ->
- let f' = visitCilVarUse vis f in
- let args' = mapNoCopy (visitCilExpr vis) args in
- if f' != f || args' != args then ConsInit(f',args',k) else li
-
- and visitCilInstr (vis: cilVisitor) (i: instr) : instr list =
- let oldloc = CurrentLoc.get () in
- CurrentLoc.set (Cil_datatype.Instr.loc i);
- let res =
- doVisitListCil vis id vis#vinst childrenInstr i in
- CurrentLoc.set oldloc;
- res
-
- and childrenInstr (vis: cilVisitor) (i: instr) : instr =
- let fExp = visitCilExpr vis in
- let fLval = visitCilLval vis in
- match i with
- | Skip _l ->
- i
- | Local_init (vi, li, l) ->
- let vi' = visitCilVarUse vis vi in
- let li' = visitCilLocal_init vis vi' li in
- if vi' != vi || li' != li then
- Local_init(vi', li', l)
- else i
- | Set(lv,e,l) ->
- let lv' = fLval lv in let e' = fExp e in
- if lv' != lv || e' != e then Set(lv',e',l) else i
- | Call(None,f,args,l) ->
- let f' = fExp f in let args' = mapNoCopy fExp args in
- if f' != f || args' != args then Call(None,f',args',l) else i
- | Call(Some lv,fn,args,l) ->
- let lv' = fLval lv in let fn' = fExp fn in
- let args' = mapNoCopy fExp args in
- if lv' != lv || fn' != fn || args' != args
- then Call(Some lv', fn', args', l) else i
-
- | Asm(sl,isvol,ext_asm,l) ->
- (match ext_asm with
- | None -> i (* only strings and location, nothing to visit. *)
- | Some ext ->
- let asm_outputs_pre = ext.asm_outputs in
- let asm_outputs =
- mapNoCopy
- (fun ((id,s,lv) as pair) ->
- let lv' = fLval lv in
- if lv' != lv then (id,s,lv') else pair) asm_outputs_pre
- in
- let asm_inputs_pre = ext.asm_inputs in
- let asm_inputs =
- mapNoCopy
- (fun ((id,s,e) as pair) ->
- let e' = fExp e in
- if e' != e then (id,s,e') else pair) asm_inputs_pre
- in
- let asm_gotos =
- if vis#behavior.is_copy_behavior then
- List.map (fun s -> ref (vis#behavior.memo_stmt !s)) ext.asm_gotos
- else ext.asm_gotos
- in
- if asm_outputs != asm_outputs_pre
- || asm_inputs != asm_inputs_pre
- || asm_gotos != ext.asm_gotos
- then
- begin
- let ext = { ext with asm_outputs; asm_inputs; asm_gotos } in
- Asm(sl,isvol,Some ext,l)
- end else i)
- | Code_annot (a,l) ->
- let a' = visitCilCodeAnnotation vis a in
- if a != a' then Code_annot(a',l) else i
-
- (* visit all nodes in a Cil statement tree in preorder *)
- and visitCilStmt (vis:cilVisitor) (s: stmt) : stmt =
- let oldloc = CurrentLoc.get () in
- CurrentLoc.set (Stmt.loc s) ;
- vis#push_stmt s; (*(vis#behavior.memo_stmt s);*)
- assertEmptyQueue vis;
- let toPrepend : instr list ref = ref [] in (* childrenStmt may add to this *)
- let res =
- doVisitCil vis
- vis#behavior.memo_stmt vis#vstmt (childrenStmt toPrepend) s in
- let ghost = res.ghost in
- (* Now see if we have saved some instructions *)
- toPrepend := !toPrepend @ vis#unqueueInstr ();
- (match !toPrepend with
+and childrenLocal_init vi (vis: cilVisitor) li =
+ match li with
+ | AssignInit i ->
+ let i' = visitCilInit vis vi NoOffset i in
+ if i != i' then AssignInit i' else li
+ | ConsInit(f,args, k) ->
+ let f' = visitCilVarUse vis f in
+ let args' = mapNoCopy (visitCilExpr vis) args in
+ if f' != f || args' != args then ConsInit(f',args',k) else li
+
+and visitCilInstr (vis: cilVisitor) (i: instr) : instr list =
+ let oldloc = CurrentLoc.get () in
+ CurrentLoc.set (Cil_datatype.Instr.loc i);
+ let res =
+ doVisitListCil vis id vis#vinst childrenInstr i in
+ CurrentLoc.set oldloc;
+ res
+
+and childrenInstr (vis: cilVisitor) (i: instr) : instr =
+ let fExp = visitCilExpr vis in
+ let fLval = visitCilLval vis in
+ match i with
+ | Skip _l ->
+ i
+ | Local_init (vi, li, l) ->
+ let vi' = visitCilVarUse vis vi in
+ let li' = visitCilLocal_init vis vi' li in
+ if vi' != vi || li' != li then
+ Local_init(vi', li', l)
+ else i
+ | Set(lv,e,l) ->
+ let lv' = fLval lv in let e' = fExp e in
+ if lv' != lv || e' != e then Set(lv',e',l) else i
+ | Call(None,f,args,l) ->
+ let f' = fExp f in let args' = mapNoCopy fExp args in
+ if f' != f || args' != args then Call(None,f',args',l) else i
+ | Call(Some lv,fn,args,l) ->
+ let lv' = fLval lv in let fn' = fExp fn in
+ let args' = mapNoCopy fExp args in
+ if lv' != lv || fn' != fn || args' != args
+ then Call(Some lv', fn', args', l) else i
+
+ | Asm(sl,isvol,ext_asm,l) ->
+ (match ext_asm with
+ | None -> i (* only strings and location, nothing to visit. *)
+ | Some ext ->
+ let asm_outputs_pre = ext.asm_outputs in
+ let asm_outputs =
+ mapNoCopy
+ (fun ((id,s,lv) as pair) ->
+ let lv' = fLval lv in
+ if lv' != lv then (id,s,lv') else pair) asm_outputs_pre
+ in
+ let asm_inputs_pre = ext.asm_inputs in
+ let asm_inputs =
+ mapNoCopy
+ (fun ((id,s,e) as pair) ->
+ let e' = fExp e in
+ if e' != e then (id,s,e') else pair) asm_inputs_pre
+ in
+ let asm_gotos =
+ if vis#behavior.is_copy_behavior then
+ List.map (fun s -> ref (vis#behavior.memo_stmt !s)) ext.asm_gotos
+ else ext.asm_gotos
+ in
+ if asm_outputs != asm_outputs_pre
+ || asm_inputs != asm_inputs_pre
+ || asm_gotos != ext.asm_gotos
+ then
+ begin
+ let ext = { ext with asm_outputs; asm_inputs; asm_gotos } in
+ Asm(sl,isvol,Some ext,l)
+ end else i)
+ | Code_annot (a,l) ->
+ let a' = visitCilCodeAnnotation vis a in
+ if a != a' then Code_annot(a',l) else i
+
+(* visit all nodes in a Cil statement tree in preorder *)
+and visitCilStmt (vis:cilVisitor) (s: stmt) : stmt =
+ let oldloc = CurrentLoc.get () in
+ CurrentLoc.set (Stmt.loc s) ;
+ vis#push_stmt s; (*(vis#behavior.memo_stmt s);*)
+ assertEmptyQueue vis;
+ let toPrepend : instr list ref = ref [] in (* childrenStmt may add to this *)
+ let res =
+ doVisitCil vis
+ vis#behavior.memo_stmt vis#vstmt (childrenStmt toPrepend) s in
+ let ghost = res.ghost in
+ (* Now see if we have saved some instructions *)
+ toPrepend := !toPrepend @ vis#unqueueInstr ();
+ (match !toPrepend with
[] -> () (* Return the same statement *)
| _ ->
let b =
@@ -3396,524 +3396,524 @@ and childrenExp (vis: cilVisitor) (e: exp) : exp =
b.battrs <- addAttribute (Attr (vis_tmp_attr, [])) b.battrs;
(* Make our statement contain the instructions to prepend *)
res.skind <- Block b);
- CurrentLoc.set oldloc;
- vis#pop_stmt s;
- res
-
- and childrenStmt (toPrepend: instr list ref) (vis:cilVisitor) (s:stmt): stmt =
- let fExp e = (visitCilExpr vis e) in
- let fBlock b = visitCilBlock vis b in
- let fInst i = visitCilInstr vis i in
- let fLoopAnnot a = mapNoCopy (visitCilCodeAnnotation vis) a in
- (* Just change the statement kind *)
- let skind' =
- match s.skind with
- Break _ | Continue _ | Return (None, _) -> s.skind
- | UnspecifiedSequence seq ->
- let seq' =
- mapNoCopy
- (function (stmt,modified,writes,reads,calls) as orig->
- let stmt' = visitCilStmt vis stmt in
- (match stmt'.skind with
- | Block b -> b.battrs <- dropAttribute vis_tmp_attr b.battrs;
- | _ -> ());
- (* might make sense for the default to be
- to just copy the varinfo when using the copy visitor,
- and not apply vvrbl, i.e. not using vis but generic_visitor ?
- *)
- let modified' = mapNoCopy (visitCilLval vis) modified in
- let writes' = mapNoCopy (visitCilLval vis) writes in
- let reads' = mapNoCopy (visitCilLval vis) reads in
- let calls' =
- if vis#behavior.is_copy_behavior then
- (* we need new references anyway, no need for mapNoCopy *)
- List.map (fun x -> ref (vis#behavior.memo_stmt !x)) calls
- else calls
- in
- if stmt' != stmt || writes' != writes || reads' != reads ||
- modified != modified' || calls' != calls
- then
- (stmt',modified', writes',reads',calls')
- else orig)
- seq
- in
- if seq' != seq then UnspecifiedSequence seq' else s.skind
- | Goto (sr,l) ->
- if vis#behavior.is_copy_behavior then
- Goto(ref (vis#behavior.memo_stmt !sr),l)
- else s.skind
- | Return (Some e, l) ->
- let e' = fExp e in
- if e' != e then Return (Some e', l) else s.skind
- | Loop (a, b, l, s1, s2) ->
- let a' = fLoopAnnot a in
- let b' = fBlock b in
- if a' != a || b' != b then Loop (a', b', l, s1, s2) else s.skind
- | If(e, s1, s2, l) ->
- let e' = fExp e in
- (*if e queued any instructions, pop them here and remember them so that
- they are inserted before the If stmt, not in the then block. *)
- toPrepend := vis#unqueueInstr ();
- let s1'= fBlock s1 in let s2'= fBlock s2 in
- (* the stmts in the blocks should have cleaned up after themselves.*)
- assertEmptyQueue vis;
- if e' != e || s1' != s1 || s2' != s2 then
- If(e', s1', s2', l) else s.skind
- | Switch (e, b, stmts, l) ->
- let e' = fExp e in
- toPrepend := vis#unqueueInstr (); (* insert these before the switch *)
- let b' = fBlock b in
- let stmts' = mapNoCopy (vis#behavior.get_stmt) stmts in
- (* the stmts in b should have cleaned up after themselves.*)
- assertEmptyQueue vis;
- if e' != e || b' != b || stmts' != stmts then
- Switch (e', b', stmts', l) else s.skind
- | Instr i ->
- begin match fInst i with
- | [i'] when i' == i -> s.skind
- | il -> stmt_of_instr_list_visitor ~loc:(Cil_datatype.Instr.loc i) il
- end
- | Block b ->
- let b' = fBlock b in
- if b' != b then Block b' else s.skind
- | Throw (e,loc) ->
- let visit (e,t as exc) =
- let e' = fExp e in
- let t' = visitCilType vis t in
- if e != e' || t != t' then (e',t') else exc
- in
- let e' = optMapNoCopy visit e in
- if e != e' then Throw (e,loc) else s.skind
- | TryCatch (b,l,loc) ->
- let b' = fBlock b in
- let visit (v,b as catch) =
- let v' = visitCilCatch_binder vis v in
- let b' = fBlock b in
- if v != v' || b != b' then (v', b') else catch
- in
- let l' = mapNoCopy visit l in
- if b != b' || l != l' then TryCatch (b', l',loc) else s.skind
- | TryFinally (b, h, l) ->
- let b' = fBlock b in
- let h' = fBlock h in
- if b' != b || h' != h then TryFinally(b', h', l) else s.skind
- | TryExcept (b, (il, e), h, l) ->
- let b' = fBlock b in
- assertEmptyQueue vis;
- (* visit the instructions *)
- let il' = mapNoCopyList fInst il in
- (* Visit the expression *)
- let e' = fExp e in
- let il'' =
- let more = vis#unqueueInstr () in
- if more != [] then
- il' @ more
- else
- il'
- in
- let h' = fBlock h in
- (* Now collect the instructions *)
- if b' != b || il'' != il || e' != e || h' != h then
- TryExcept(b', (il'', e'), h', l)
- else s.skind
- in
- if skind' != s.skind then s.skind <- skind';
- enforceGhostStmtCoherence s ;
- (* Visit the labels *)
- let labels' =
- let fLabel = function
- Case (e, l) as lb ->
- let e' = fExp e in
- if e' != e then Case (e', l) else lb
- | lb -> lb
- in
- mapNoCopy fLabel s.labels
- in
- if labels' != s.labels then s.labels <- labels';
- s
+ CurrentLoc.set oldloc;
+ vis#pop_stmt s;
+ res
+
+and childrenStmt (toPrepend: instr list ref) (vis:cilVisitor) (s:stmt): stmt =
+ let fExp e = (visitCilExpr vis e) in
+ let fBlock b = visitCilBlock vis b in
+ let fInst i = visitCilInstr vis i in
+ let fLoopAnnot a = mapNoCopy (visitCilCodeAnnotation vis) a in
+ (* Just change the statement kind *)
+ let skind' =
+ match s.skind with
+ Break _ | Continue _ | Return (None, _) -> s.skind
+ | UnspecifiedSequence seq ->
+ let seq' =
+ mapNoCopy
+ (function (stmt,modified,writes,reads,calls) as orig->
+ let stmt' = visitCilStmt vis stmt in
+ (match stmt'.skind with
+ | Block b -> b.battrs <- dropAttribute vis_tmp_attr b.battrs;
+ | _ -> ());
+ (* might make sense for the default to be
+ to just copy the varinfo when using the copy visitor,
+ and not apply vvrbl, i.e. not using vis but generic_visitor ?
+ *)
+ let modified' = mapNoCopy (visitCilLval vis) modified in
+ let writes' = mapNoCopy (visitCilLval vis) writes in
+ let reads' = mapNoCopy (visitCilLval vis) reads in
+ let calls' =
+ if vis#behavior.is_copy_behavior then
+ (* we need new references anyway, no need for mapNoCopy *)
+ List.map (fun x -> ref (vis#behavior.memo_stmt !x)) calls
+ else calls
+ in
+ if stmt' != stmt || writes' != writes || reads' != reads ||
+ modified != modified' || calls' != calls
+ then
+ (stmt',modified', writes',reads',calls')
+ else orig)
+ seq
+ in
+ if seq' != seq then UnspecifiedSequence seq' else s.skind
+ | Goto (sr,l) ->
+ if vis#behavior.is_copy_behavior then
+ Goto(ref (vis#behavior.memo_stmt !sr),l)
+ else s.skind
+ | Return (Some e, l) ->
+ let e' = fExp e in
+ if e' != e then Return (Some e', l) else s.skind
+ | Loop (a, b, l, s1, s2) ->
+ let a' = fLoopAnnot a in
+ let b' = fBlock b in
+ if a' != a || b' != b then Loop (a', b', l, s1, s2) else s.skind
+ | If(e, s1, s2, l) ->
+ let e' = fExp e in
+ (*if e queued any instructions, pop them here and remember them so that
+ they are inserted before the If stmt, not in the then block. *)
+ toPrepend := vis#unqueueInstr ();
+ let s1'= fBlock s1 in let s2'= fBlock s2 in
+ (* the stmts in the blocks should have cleaned up after themselves.*)
+ assertEmptyQueue vis;
+ if e' != e || s1' != s1 || s2' != s2 then
+ If(e', s1', s2', l) else s.skind
+ | Switch (e, b, stmts, l) ->
+ let e' = fExp e in
+ toPrepend := vis#unqueueInstr (); (* insert these before the switch *)
+ let b' = fBlock b in
+ let stmts' = mapNoCopy (vis#behavior.get_stmt) stmts in
+ (* the stmts in b should have cleaned up after themselves.*)
+ assertEmptyQueue vis;
+ if e' != e || b' != b || stmts' != stmts then
+ Switch (e', b', stmts', l) else s.skind
+ | Instr i ->
+ begin match fInst i with
+ | [i'] when i' == i -> s.skind
+ | il -> stmt_of_instr_list_visitor ~loc:(Cil_datatype.Instr.loc i) il
+ end
+ | Block b ->
+ let b' = fBlock b in
+ if b' != b then Block b' else s.skind
+ | Throw (e,loc) ->
+ let visit (e,t as exc) =
+ let e' = fExp e in
+ let t' = visitCilType vis t in
+ if e != e' || t != t' then (e',t') else exc
+ in
+ let e' = optMapNoCopy visit e in
+ if e != e' then Throw (e,loc) else s.skind
+ | TryCatch (b,l,loc) ->
+ let b' = fBlock b in
+ let visit (v,b as catch) =
+ let v' = visitCilCatch_binder vis v in
+ let b' = fBlock b in
+ if v != v' || b != b' then (v', b') else catch
+ in
+ let l' = mapNoCopy visit l in
+ if b != b' || l != l' then TryCatch (b', l',loc) else s.skind
+ | TryFinally (b, h, l) ->
+ let b' = fBlock b in
+ let h' = fBlock h in
+ if b' != b || h' != h then TryFinally(b', h', l) else s.skind
+ | TryExcept (b, (il, e), h, l) ->
+ let b' = fBlock b in
+ assertEmptyQueue vis;
+ (* visit the instructions *)
+ let il' = mapNoCopyList fInst il in
+ (* Visit the expression *)
+ let e' = fExp e in
+ let il'' =
+ let more = vis#unqueueInstr () in
+ if more != [] then
+ il' @ more
+ else
+ il'
+ in
+ let h' = fBlock h in
+ (* Now collect the instructions *)
+ if b' != b || il'' != il || e' != e || h' != h then
+ TryExcept(b', (il'', e'), h', l)
+ else s.skind
+ in
+ if skind' != s.skind then s.skind <- skind';
+ enforceGhostStmtCoherence s ;
+ (* Visit the labels *)
+ let labels' =
+ let fLabel = function
+ Case (e, l) as lb ->
+ let e' = fExp e in
+ if e' != e then Case (e', l) else lb
+ | lb -> lb
+ in
+ mapNoCopy fLabel s.labels
+ in
+ if labels' != s.labels then s.labels <- labels';
+ s
- and visitCilCatch_binder vis cb =
+and visitCilCatch_binder vis cb =
match cb with
- | Catch_exn (v,l) ->
- let visit_one_conversion (v, b as conv) =
- let v' = visitCilVarDecl vis v in
- let b' = visitCilBlock vis b in
- if v != v' || b != b' then (v', b') else conv
- in
+ | Catch_exn (v,l) ->
+ let visit_one_conversion (v, b as conv) =
let v' = visitCilVarDecl vis v in
- let l' = mapNoCopy visit_one_conversion l in
- if v != v' || l != l' then Catch_exn(v',l') else cb
- | Catch_all -> cb
- and visitCilBlock (vis: cilVisitor) (b: block) : block =
- let b' = vis#behavior.cblock b in
- if vis#behavior.is_copy_behavior then begin
- (* in case we are the main block of the current function,
- update immediately the sbody, so that makeLocalVar can be used
- seamlessly by the underlying visitor and associate the
- local variable to the appropriate sbody when no inner block is present.
- *)
- match vis#current_func with
- | Some fd when fd.sbody == b ->
- (get_fundec vis#behavior fd).sbody <- b'
- | Some _ | None -> ()
- end;
- doVisitCil vis id vis#vblock childrenBlock b'
- and childrenBlock (vis: cilVisitor) (b: block) : block =
- let fStmt s = visitCilStmt vis s in
- (* first visit locals and update the field. This way, statements visitors
- that wish to create a local into the innermost scope can simply append
- it to the current block.
- *)
- let locals' = mapNoCopy (vis#behavior.get_varinfo) b.blocals in
- let statics' = mapNoCopy (vis#behavior.get_varinfo) b.bstatics in
- b.blocals <- locals';
- b.bstatics <- statics';
- let stmts' = mapNoCopy fStmt b.bstmts in
- b.bstmts <- stmts';
- flatten_transient_sub_blocks b
-
- and visitCilType (vis : cilVisitor) (t : typ) : typ =
- doVisitCil vis id vis#vtype childrenType t
- and childrenType (vis : cilVisitor) (t : typ) : typ =
- (* look for types referred to inside t's definition *)
- let fTyp t = visitCilType vis t in
- let fAttr a = visitCilAttributes vis a in
- match t with
- TPtr(t1, a) ->
- let t1' = fTyp t1 in
- let a' = fAttr a in
- if t1' != t1 || a' != a then TPtr(t1', a') else t
- | TArray(t1, None, _, a) ->
- let t1' = fTyp t1 in
- let a' = fAttr a in
- if t1' != t1 || a' != a then TArray(t1', None, empty_size_cache (), a') else t
- | TArray(t1, Some e, _, a) ->
- let t1' = fTyp t1 in
- let e' = visitCilExpr vis e in
- let a' = fAttr a in
- if t1' != t1 || e' != e || a' != a then TArray(t1', Some e',empty_size_cache (), a') else t
-
- (* DON'T recurse into the compinfo, this is done in visitCilGlobal.
- User can iterate over cinfo.cfields manually, if desired.*)
- | TComp(cinfo, _, a) ->
- let cinfo' = vis#behavior.get_compinfo cinfo in
- let a' = fAttr a in
- if a != a' || cinfo' != cinfo then TComp(cinfo',empty_size_cache (), a') else t
-
- | TFun(rettype, args, isva, a) ->
- let rettype' = fTyp rettype in
- (* iterate over formals, as variable declarations *)
- let argslist = argsToList args in
- let visitArg ((an,at,aa) as arg) =
- let at' = fTyp at in
- let aa' = fAttr aa in
- if at' != at || aa' != aa then (an,at',aa') else arg
- in
- let argslist' = mapNoCopy visitArg argslist in
- let a' = fAttr a in
- if rettype' != rettype || argslist' != argslist || a' != a then
- let args' = if argslist' == argslist then args else Some argslist' in
- TFun(rettype', args', isva, a') else t
-
- | TNamed(t1, a) ->
- let a' = fAttr a in
- let t1' = vis#behavior.get_typeinfo t1 in
- if a' != a || t1' != t1 then TNamed (t1', a') else t
- | TEnum(enum,a) ->
- let a' = fAttr a in
- let enum' = vis#behavior.get_enuminfo enum in
- if a' != a || enum' != enum then TEnum(enum',a') else t
- | TVoid _ | TInt _ | TFloat _ | TBuiltin_va_list _ ->
- (* no nested type. visit only the attributes. *)
- let a = typeAttrs t in
- let a' = fAttr a in
- if a' != a then setTypeAttrs t a' else t
-
- (* for declarations, we visit the types inside; but for uses, *)
- (* we just visit the varinfo node *)
- and visitCilVarDecl (vis : cilVisitor) (v : varinfo) : varinfo =
- let oldloc = CurrentLoc.get () in
- CurrentLoc.set v.vdecl;
- let res =
- doVisitCil vis vis#behavior.memo_varinfo
- vis#vvdec childrenVarDecl v
- in CurrentLoc.set oldloc; res
-
- and childrenVarDecl (vis : cilVisitor) (v : varinfo) : varinfo =
+ let b' = visitCilBlock vis b in
+ if v != v' || b != b' then (v', b') else conv
+ in
+ let v' = visitCilVarDecl vis v in
+ let l' = mapNoCopy visit_one_conversion l in
+ if v != v' || l != l' then Catch_exn(v',l') else cb
+ | Catch_all -> cb
+and visitCilBlock (vis: cilVisitor) (b: block) : block =
+ let b' = vis#behavior.cblock b in
+ if vis#behavior.is_copy_behavior then begin
+ (* in case we are the main block of the current function,
+ update immediately the sbody, so that makeLocalVar can be used
+ seamlessly by the underlying visitor and associate the
+ local variable to the appropriate sbody when no inner block is present.
+ *)
+ match vis#current_func with
+ | Some fd when fd.sbody == b ->
+ (get_fundec vis#behavior fd).sbody <- b'
+ | Some _ | None -> ()
+ end;
+ doVisitCil vis id vis#vblock childrenBlock b'
+and childrenBlock (vis: cilVisitor) (b: block) : block =
+ let fStmt s = visitCilStmt vis s in
+ (* first visit locals and update the field. This way, statements visitors
+ that wish to create a local into the innermost scope can simply append
+ it to the current block.
+ *)
+ let locals' = mapNoCopy (vis#behavior.get_varinfo) b.blocals in
+ let statics' = mapNoCopy (vis#behavior.get_varinfo) b.bstatics in
+ b.blocals <- locals';
+ b.bstatics <- statics';
+ let stmts' = mapNoCopy fStmt b.bstmts in
+ b.bstmts <- stmts';
+ flatten_transient_sub_blocks b
+
+and visitCilType (vis : cilVisitor) (t : typ) : typ =
+ doVisitCil vis id vis#vtype childrenType t
+and childrenType (vis : cilVisitor) (t : typ) : typ =
+ (* look for types referred to inside t's definition *)
+ let fTyp t = visitCilType vis t in
+ let fAttr a = visitCilAttributes vis a in
+ match t with
+ TPtr(t1, a) ->
+ let t1' = fTyp t1 in
+ let a' = fAttr a in
+ if t1' != t1 || a' != a then TPtr(t1', a') else t
+ | TArray(t1, None, _, a) ->
+ let t1' = fTyp t1 in
+ let a' = fAttr a in
+ if t1' != t1 || a' != a then TArray(t1', None, empty_size_cache (), a') else t
+ | TArray(t1, Some e, _, a) ->
+ let t1' = fTyp t1 in
+ let e' = visitCilExpr vis e in
+ let a' = fAttr a in
+ if t1' != t1 || e' != e || a' != a then TArray(t1', Some e',empty_size_cache (), a') else t
+
+ (* DON'T recurse into the compinfo, this is done in visitCilGlobal.
+ User can iterate over cinfo.cfields manually, if desired.*)
+ | TComp(cinfo, _, a) ->
+ let cinfo' = vis#behavior.get_compinfo cinfo in
+ let a' = fAttr a in
+ if a != a' || cinfo' != cinfo then TComp(cinfo',empty_size_cache (), a') else t
+
+ | TFun(rettype, args, isva, a) ->
+ let rettype' = fTyp rettype in
+ (* iterate over formals, as variable declarations *)
+ let argslist = argsToList args in
+ let visitArg ((an,at,aa) as arg) =
+ let at' = fTyp at in
+ let aa' = fAttr aa in
+ if at' != at || aa' != aa then (an,at',aa') else arg
+ in
+ let argslist' = mapNoCopy visitArg argslist in
+ let a' = fAttr a in
+ if rettype' != rettype || argslist' != argslist || a' != a then
+ let args' = if argslist' == argslist then args else Some argslist' in
+ TFun(rettype', args', isva, a') else t
+
+ | TNamed(t1, a) ->
+ let a' = fAttr a in
+ let t1' = vis#behavior.get_typeinfo t1 in
+ if a' != a || t1' != t1 then TNamed (t1', a') else t
+ | TEnum(enum,a) ->
+ let a' = fAttr a in
+ let enum' = vis#behavior.get_enuminfo enum in
+ if a' != a || enum' != enum then TEnum(enum',a') else t
+ | TVoid _ | TInt _ | TFloat _ | TBuiltin_va_list _ ->
+ (* no nested type. visit only the attributes. *)
+ let a = typeAttrs t in
+ let a' = fAttr a in
+ if a' != a then setTypeAttrs t a' else t
+
+(* for declarations, we visit the types inside; but for uses, *)
+(* we just visit the varinfo node *)
+and visitCilVarDecl (vis : cilVisitor) (v : varinfo) : varinfo =
+ let oldloc = CurrentLoc.get () in
+ CurrentLoc.set v.vdecl;
+ let res =
+ doVisitCil vis vis#behavior.memo_varinfo
+ vis#vvdec childrenVarDecl v
+ in CurrentLoc.set oldloc; res
+
+and childrenVarDecl (vis : cilVisitor) (v : varinfo) : varinfo =
(* in case of refresh visitor, the associated new logic var has a different
id. We must visit the original logic var associated to it. *)
let visit_orig_var_assoc lv =
let o = vis#behavior.get_original_logic_var lv in
visitCilLogicVarDecl vis o
in
- v.vtype <- visitCilType vis v.vtype;
- v.vattr <- visitCilAttributes vis v.vattr;
- v.vlogic_var_assoc <- optMapNoCopy visit_orig_var_assoc v.vlogic_var_assoc;
- v
-
- and visitCilVarUse vis v =
- doVisitCil vis vis#behavior.get_varinfo vis#vvrbl alphabetabeta v
-
- and visitCilAttributes (vis: cilVisitor) (al: attribute list) : attribute list=
- let al' =
- mapNoCopyList
- (doVisitListCil vis
- id vis#vattr childrenAttribute) al in
- if al' != al then
- (* Must re-sort *)
- addAttributes al' []
- else
- al
- and childrenAttribute (vis: cilVisitor) (a: attribute) : attribute =
- let fAttrP a = visitCilAttrParams vis a in
- match a with
- | Attr (n, args) ->
- let args' = mapNoCopy fAttrP args in
- if args' != args then Attr(n, args') else a
- | AttrAnnot _ ->
- a
-
- and visitCilAttrParams (vis: cilVisitor) (a: attrparam) : attrparam =
- doVisitCil vis id vis#vattrparam childrenAttrparam a
- and childrenAttrparam (vis: cilVisitor) (aa: attrparam) : attrparam =
- let fTyp t = visitCilType vis t in
- let fAttrP a = visitCilAttrParams vis a in
- match aa with
- AInt _ | AStr _ -> aa
- | ACons(n, args) ->
- let args' = mapNoCopy fAttrP args in
- if args' != args then ACons(n, args') else aa
- | ASizeOf t ->
- let t' = fTyp t in
- if t' != t then ASizeOf t' else aa
- | ASizeOfE e ->
- let e' = fAttrP e in
- if e' != e then ASizeOfE e' else aa
- | AAlignOf t ->
- let t' = fTyp t in
- if t' != t then AAlignOf t' else aa
- | AAlignOfE e ->
- let e' = fAttrP e in
- if e' != e then AAlignOfE e' else aa
- | AUnOp (uo, e1) ->
- let e1' = fAttrP e1 in
- if e1' != e1 then AUnOp (uo, e1') else aa
- | ABinOp (bo, e1, e2) ->
- let e1' = fAttrP e1 in
- let e2' = fAttrP e2 in
- if e1' != e1 || e2' != e2 then ABinOp (bo, e1', e2') else aa
- | ADot (ap, s) ->
- let ap' = fAttrP ap in
- if ap' != ap then ADot (ap', s) else aa
- | AStar ap ->
- let ap' = fAttrP ap in
- if ap' != ap then AStar ap' else aa
- | AAddrOf ap ->
- let ap' = fAttrP ap in
- if ap' != ap then AAddrOf ap' else aa
- | AIndex (e1, e2) ->
- let e1' = fAttrP e1 in
- let e2' = fAttrP e2 in
- if e1' != e1 || e2' != e2 then AIndex (e1', e2') else aa
- | AQuestion (e1, e2, e3) ->
- let e1' = fAttrP e1 in
- let e2' = fAttrP e2 in
- let e3' = fAttrP e3 in
- if e1' != e1 || e2' != e2 || e3' != e3
- then AQuestion (e1', e2', e3') else aa
-
-
- let rec fix_succs_preds_block b block =
- List.iter (fix_succs_preds b) block.bstmts
- and fix_succs_preds b stmt =
- stmt.succs <- mapNoCopy b.get_stmt stmt.succs;
- stmt.preds <- mapNoCopy b.get_stmt stmt.preds;
- match stmt.skind with
- If(_,bthen,belse,_) ->
- fix_succs_preds_block b bthen;
- fix_succs_preds_block b belse
- | Switch(e,cases,stmts,l) ->
- fix_succs_preds_block b cases;
- stmt.skind <- Switch(e,cases,List.map b.get_stmt stmts,l)
- | Loop(annot,block,loc,stmt1,stmt2) ->
- fix_succs_preds_block b block;
- let stmt1' = optMapNoCopy b.get_stmt stmt1 in
- let stmt2' = optMapNoCopy b.get_stmt stmt2 in
- stmt.skind <- Loop(annot,block,loc,stmt1',stmt2')
- | Block block -> fix_succs_preds_block b block
- | TryFinally(block1,block2,_) ->
- fix_succs_preds_block b block1;
- fix_succs_preds_block b block2
- | TryExcept(block1,_,block2,_) ->
- fix_succs_preds_block b block1;
- fix_succs_preds_block b block2
- | _ -> ()
-
- let rec visitCilFunction (vis : cilVisitor) (f : fundec) : fundec =
- if debugVisit then Kernel.feedback "Visiting function %s" f.svar.vname ;
- assertEmptyQueue vis;
- vis#set_current_func f;
- (* update fundec tables *)
- let f = vis#behavior.memo_fundec f in
- let f =
- doVisitCil vis id (* copy has already been done *)
- vis#vfunc childrenFunction f
- in
- let toPrepend = vis#unqueueInstr () in
- if toPrepend <> [] then
- f.sbody.bstmts <-
- (List.map (fun i -> mkStmt (Instr i)) toPrepend) @ f.sbody.bstmts;
- if vis#behavior.is_copy_behavior then begin
- fix_succs_preds_block vis#behavior f.sbody;
- f.sallstmts <-
- List.rev (List.rev_map vis#behavior.get_stmt f.sallstmts)
- end;
- vis#reset_current_func ();
- f
-
- and childrenFunction (vis : cilVisitor) (f : fundec) : fundec =
- (* we have already made a copy of the svar, but not visited it.
- Use the original variable as argument of visitCilVarDecl,
- update fundec table in case the vid gets changed. *)
- let v = vis#behavior.get_original_varinfo f.svar in
- let nv = visitCilVarDecl vis v in
- if not (Cil_datatype.Varinfo.equal nv f.svar) then begin
- Kernel.fatal
- "Visiting the varinfo declared for function %a changes its id."
- Cil_datatype.Varinfo.pretty nv
- end;
- f.svar <- nv; (* hit the function name *)
- (* visit the formals *)
- let newformals = mapNoCopy (visitCilVarDecl vis) f.sformals in
- (* visit local declarations *)
- f.slocals <- mapNoCopy (visitCilVarDecl vis) f.slocals;
- (* Make sure the type reflects the formals *)
- let selection = State_selection.singleton FormalsDecl.self in
- if vis#behavior.is_copy_behavior || newformals != f.sformals then begin
- apply_on_project ~selection vis (setFormals f) newformals;
- end;
- (* Remember any new instructions that were generated while visiting
- variable declarations. *)
- let toPrepend = vis#unqueueInstr () in
- f.sbody <- visitCilBlock vis f.sbody; (* visit the body *)
- if toPrepend <> [] then
- f.sbody.bstmts <-
- (List.map (fun i -> mkStmt (Instr i)) toPrepend) @ f.sbody.bstmts;
- if not (is_empty_funspec f.sspec) then
- f.sspec <- visitCilFunspec vis f.sspec;
- f
-
- let childrenFieldInfo vis fi =
- (* already done at copy creation *)
- (* fi.fcomp <- vis#behavior.get_compinfo fi.fcomp; *)
- fi.ftype <- visitCilType vis fi.ftype;
- fi.fattr <- visitCilAttributes vis fi.fattr;
- fi
-
- let visitCilFieldInfo vis f =
- let f = vis#behavior.get_original_fieldinfo f in
- doVisitCil vis vis#behavior.memo_fieldinfo vis#vfieldinfo childrenFieldInfo f
-
- let childrenCompInfo vis comp =
- comp.cfields <- mapNoCopy (visitCilFieldInfo vis) comp.cfields;
- comp.cattr <- visitCilAttributes vis comp.cattr;
- comp
-
- let visitCilCompInfo vis c =
- doVisitCil vis vis#behavior.memo_compinfo vis#vcompinfo childrenCompInfo c
-
- let childrenEnumItem vis e =
- e.eival <- visitCilExpr vis e.eival;
- e.eihost <- vis#behavior.get_enuminfo e.eihost;
- e
-
- let visitCilEnumItem vis e =
- doVisitCil vis vis#behavior.memo_enumitem vis#venumitem childrenEnumItem e
-
- let childrenEnumInfo vis e =
- e.eitems <- mapNoCopy (visitCilEnumItem vis) e.eitems;
- e.eattr <- visitCilAttributes vis e.eattr;
- e
-
- let visitCilEnumInfo vis e =
- doVisitCil vis vis#behavior.memo_enuminfo vis#venuminfo childrenEnumInfo e
-
- let rec visitCilGlobal (vis: cilVisitor) (g: global) : global list =
- let oldloc = CurrentLoc.get () in
- CurrentLoc.set (Global.loc g) ;
- let res =
- doVisitListCil vis id vis#vglob childrenGlobal g in
- CurrentLoc.set oldloc;
- res
- and childrenGlobal (vis: cilVisitor) (g: global) : global =
- match g with
- | GFun (f, l) ->
- let f' = visitCilFunction vis f in
- if f' != f then GFun (f', l) else g
- | GType(t, l) ->
- let t' = vis#behavior.memo_typeinfo t in
- t'.ttype <- visitCilType vis t'.ttype;
- if t' != t then GType(t',l) else g
- | GEnumTagDecl (enum,l) ->
- let enum' = vis#behavior.memo_enuminfo enum in
- if enum != enum' then GEnumTagDecl(enum',l) else g
- (* real visit'll be done in the definition *)
- | GCompTagDecl (comp,l) ->
- let comp' = vis#behavior.memo_compinfo comp in
- if comp != comp' then GCompTagDecl(comp',l) else g
- | GEnumTag (enum, l) ->
- let enum' = visitCilEnumInfo vis enum in
- if enum != enum' then GEnumTag(enum',l) else g
- | GCompTag (comp, l) ->
- let comp' = visitCilCompInfo vis comp in
- if comp != comp' then GCompTag(comp',l) else g
- | GVarDecl(v, l) ->
- let v' = visitCilVarDecl vis v in
- if v' != v then GVarDecl (v', l) else g
- | GFunDecl(spec, v, l) ->
- let form =
- try Some (getFormalsDecl v) with Not_found -> None
- in
- let v' = visitCilVarDecl vis v in
- let form' = optMapNoCopy (mapNoCopy (visitCilVarDecl vis)) form in
- let spec' =
- if is_empty_funspec spec then begin
- if is_copy_behavior vis#behavior then
- empty_funspec ()
- else spec (* do not need to change it if it's not a copy visitor. *)
- end else begin
- visitCilFunspec vis spec
- end
- in
- if v' != v || spec' != spec || form != form' then
- begin
- (match form' with
- | Some formals
- when vis#behavior.is_copy_behavior || form != form' ->
- let selection = State_selection.singleton FormalsDecl.self in
- apply_on_project
- ~selection vis (unsafeSetFormalsDecl v') formals
- | Some _ | None -> ());
- GFunDecl (spec', v', l)
- end
- else g
- | GVar (v, inito, l) ->
- let v' = visitCilVarDecl vis v in
- let inito' = vis#behavior.cinitinfo inito in
- (match inito'.init with
- None -> ()
- | Some i -> let i' = visitCilInit vis v NoOffset i in
- if i' != i then inito'.init <- Some i');
- if v' != v || inito' != inito then GVar (v', inito', l) else g
- | GPragma (a, l) -> begin
- match visitCilAttributes vis [a] with
- [a'] -> if a' != a then GPragma (a', l) else g
- | _ -> Kernel.fatal "visitCilAttributes returns more than one attribute"
- end
- | GAnnot (a,l) ->
- let a' = visitCilAnnotation vis a in
- if a' != a then GAnnot(a',l) else g
- | GText _ | GAsm _ -> g
+ v.vtype <- visitCilType vis v.vtype;
+ v.vattr <- visitCilAttributes vis v.vattr;
+ v.vlogic_var_assoc <- optMapNoCopy visit_orig_var_assoc v.vlogic_var_assoc;
+ v
+
+and visitCilVarUse vis v =
+ doVisitCil vis vis#behavior.get_varinfo vis#vvrbl alphabetabeta v
+
+and visitCilAttributes (vis: cilVisitor) (al: attribute list) : attribute list=
+ let al' =
+ mapNoCopyList
+ (doVisitListCil vis
+ id vis#vattr childrenAttribute) al in
+ if al' != al then
+ (* Must re-sort *)
+ addAttributes al' []
+ else
+ al
+and childrenAttribute (vis: cilVisitor) (a: attribute) : attribute =
+ let fAttrP a = visitCilAttrParams vis a in
+ match a with
+ | Attr (n, args) ->
+ let args' = mapNoCopy fAttrP args in
+ if args' != args then Attr(n, args') else a
+ | AttrAnnot _ ->
+ a
+
+and visitCilAttrParams (vis: cilVisitor) (a: attrparam) : attrparam =
+ doVisitCil vis id vis#vattrparam childrenAttrparam a
+and childrenAttrparam (vis: cilVisitor) (aa: attrparam) : attrparam =
+ let fTyp t = visitCilType vis t in
+ let fAttrP a = visitCilAttrParams vis a in
+ match aa with
+ AInt _ | AStr _ -> aa
+ | ACons(n, args) ->
+ let args' = mapNoCopy fAttrP args in
+ if args' != args then ACons(n, args') else aa
+ | ASizeOf t ->
+ let t' = fTyp t in
+ if t' != t then ASizeOf t' else aa
+ | ASizeOfE e ->
+ let e' = fAttrP e in
+ if e' != e then ASizeOfE e' else aa
+ | AAlignOf t ->
+ let t' = fTyp t in
+ if t' != t then AAlignOf t' else aa
+ | AAlignOfE e ->
+ let e' = fAttrP e in
+ if e' != e then AAlignOfE e' else aa
+ | AUnOp (uo, e1) ->
+ let e1' = fAttrP e1 in
+ if e1' != e1 then AUnOp (uo, e1') else aa
+ | ABinOp (bo, e1, e2) ->
+ let e1' = fAttrP e1 in
+ let e2' = fAttrP e2 in
+ if e1' != e1 || e2' != e2 then ABinOp (bo, e1', e2') else aa
+ | ADot (ap, s) ->
+ let ap' = fAttrP ap in
+ if ap' != ap then ADot (ap', s) else aa
+ | AStar ap ->
+ let ap' = fAttrP ap in
+ if ap' != ap then AStar ap' else aa
+ | AAddrOf ap ->
+ let ap' = fAttrP ap in
+ if ap' != ap then AAddrOf ap' else aa
+ | AIndex (e1, e2) ->
+ let e1' = fAttrP e1 in
+ let e2' = fAttrP e2 in
+ if e1' != e1 || e2' != e2 then AIndex (e1', e2') else aa
+ | AQuestion (e1, e2, e3) ->
+ let e1' = fAttrP e1 in
+ let e2' = fAttrP e2 in
+ let e3' = fAttrP e3 in
+ if e1' != e1 || e2' != e2 || e3' != e3
+ then AQuestion (e1', e2', e3') else aa
+
+
+let rec fix_succs_preds_block b block =
+ List.iter (fix_succs_preds b) block.bstmts
+and fix_succs_preds b stmt =
+ stmt.succs <- mapNoCopy b.get_stmt stmt.succs;
+ stmt.preds <- mapNoCopy b.get_stmt stmt.preds;
+ match stmt.skind with
+ If(_,bthen,belse,_) ->
+ fix_succs_preds_block b bthen;
+ fix_succs_preds_block b belse
+ | Switch(e,cases,stmts,l) ->
+ fix_succs_preds_block b cases;
+ stmt.skind <- Switch(e,cases,List.map b.get_stmt stmts,l)
+ | Loop(annot,block,loc,stmt1,stmt2) ->
+ fix_succs_preds_block b block;
+ let stmt1' = optMapNoCopy b.get_stmt stmt1 in
+ let stmt2' = optMapNoCopy b.get_stmt stmt2 in
+ stmt.skind <- Loop(annot,block,loc,stmt1',stmt2')
+ | Block block -> fix_succs_preds_block b block
+ | TryFinally(block1,block2,_) ->
+ fix_succs_preds_block b block1;
+ fix_succs_preds_block b block2
+ | TryExcept(block1,_,block2,_) ->
+ fix_succs_preds_block b block1;
+ fix_succs_preds_block b block2
+ | _ -> ()
+
+let rec visitCilFunction (vis : cilVisitor) (f : fundec) : fundec =
+ if debugVisit then Kernel.feedback "Visiting function %s" f.svar.vname ;
+ assertEmptyQueue vis;
+ vis#set_current_func f;
+ (* update fundec tables *)
+ let f = vis#behavior.memo_fundec f in
+ let f =
+ doVisitCil vis id (* copy has already been done *)
+ vis#vfunc childrenFunction f
+ in
+ let toPrepend = vis#unqueueInstr () in
+ if toPrepend <> [] then
+ f.sbody.bstmts <-
+ (List.map (fun i -> mkStmt (Instr i)) toPrepend) @ f.sbody.bstmts;
+ if vis#behavior.is_copy_behavior then begin
+ fix_succs_preds_block vis#behavior f.sbody;
+ f.sallstmts <-
+ List.rev (List.rev_map vis#behavior.get_stmt f.sallstmts)
+ end;
+ vis#reset_current_func ();
+ f
+
+and childrenFunction (vis : cilVisitor) (f : fundec) : fundec =
+ (* we have already made a copy of the svar, but not visited it.
+ Use the original variable as argument of visitCilVarDecl,
+ update fundec table in case the vid gets changed. *)
+ let v = vis#behavior.get_original_varinfo f.svar in
+ let nv = visitCilVarDecl vis v in
+ if not (Cil_datatype.Varinfo.equal nv f.svar) then begin
+ Kernel.fatal
+ "Visiting the varinfo declared for function %a changes its id."
+ Cil_datatype.Varinfo.pretty nv
+ end;
+ f.svar <- nv; (* hit the function name *)
+ (* visit the formals *)
+ let newformals = mapNoCopy (visitCilVarDecl vis) f.sformals in
+ (* visit local declarations *)
+ f.slocals <- mapNoCopy (visitCilVarDecl vis) f.slocals;
+ (* Make sure the type reflects the formals *)
+ let selection = State_selection.singleton FormalsDecl.self in
+ if vis#behavior.is_copy_behavior || newformals != f.sformals then begin
+ apply_on_project ~selection vis (setFormals f) newformals;
+ end;
+ (* Remember any new instructions that were generated while visiting
+ variable declarations. *)
+ let toPrepend = vis#unqueueInstr () in
+ f.sbody <- visitCilBlock vis f.sbody; (* visit the body *)
+ if toPrepend <> [] then
+ f.sbody.bstmts <-
+ (List.map (fun i -> mkStmt (Instr i)) toPrepend) @ f.sbody.bstmts;
+ if not (is_empty_funspec f.sspec) then
+ f.sspec <- visitCilFunspec vis f.sspec;
+ f
+
+let childrenFieldInfo vis fi =
+ (* already done at copy creation *)
+ (* fi.fcomp <- vis#behavior.get_compinfo fi.fcomp; *)
+ fi.ftype <- visitCilType vis fi.ftype;
+ fi.fattr <- visitCilAttributes vis fi.fattr;
+ fi
+
+let visitCilFieldInfo vis f =
+ let f = vis#behavior.get_original_fieldinfo f in
+ doVisitCil vis vis#behavior.memo_fieldinfo vis#vfieldinfo childrenFieldInfo f
+
+let childrenCompInfo vis comp =
+ comp.cfields <- mapNoCopy (visitCilFieldInfo vis) comp.cfields;
+ comp.cattr <- visitCilAttributes vis comp.cattr;
+ comp
+
+let visitCilCompInfo vis c =
+ doVisitCil vis vis#behavior.memo_compinfo vis#vcompinfo childrenCompInfo c
+
+let childrenEnumItem vis e =
+ e.eival <- visitCilExpr vis e.eival;
+ e.eihost <- vis#behavior.get_enuminfo e.eihost;
+ e
+
+let visitCilEnumItem vis e =
+ doVisitCil vis vis#behavior.memo_enumitem vis#venumitem childrenEnumItem e
+
+let childrenEnumInfo vis e =
+ e.eitems <- mapNoCopy (visitCilEnumItem vis) e.eitems;
+ e.eattr <- visitCilAttributes vis e.eattr;
+ e
+
+let visitCilEnumInfo vis e =
+ doVisitCil vis vis#behavior.memo_enuminfo vis#venuminfo childrenEnumInfo e
+
+let rec visitCilGlobal (vis: cilVisitor) (g: global) : global list =
+ let oldloc = CurrentLoc.get () in
+ CurrentLoc.set (Global.loc g) ;
+ let res =
+ doVisitListCil vis id vis#vglob childrenGlobal g in
+ CurrentLoc.set oldloc;
+ res
+and childrenGlobal (vis: cilVisitor) (g: global) : global =
+ match g with
+ | GFun (f, l) ->
+ let f' = visitCilFunction vis f in
+ if f' != f then GFun (f', l) else g
+ | GType(t, l) ->
+ let t' = vis#behavior.memo_typeinfo t in
+ t'.ttype <- visitCilType vis t'.ttype;
+ if t' != t then GType(t',l) else g
+ | GEnumTagDecl (enum,l) ->
+ let enum' = vis#behavior.memo_enuminfo enum in
+ if enum != enum' then GEnumTagDecl(enum',l) else g
+ (* real visit'll be done in the definition *)
+ | GCompTagDecl (comp,l) ->
+ let comp' = vis#behavior.memo_compinfo comp in
+ if comp != comp' then GCompTagDecl(comp',l) else g
+ | GEnumTag (enum, l) ->
+ let enum' = visitCilEnumInfo vis enum in
+ if enum != enum' then GEnumTag(enum',l) else g
+ | GCompTag (comp, l) ->
+ let comp' = visitCilCompInfo vis comp in
+ if comp != comp' then GCompTag(comp',l) else g
+ | GVarDecl(v, l) ->
+ let v' = visitCilVarDecl vis v in
+ if v' != v then GVarDecl (v', l) else g
+ | GFunDecl(spec, v, l) ->
+ let form =
+ try Some (getFormalsDecl v) with Not_found -> None
+ in
+ let v' = visitCilVarDecl vis v in
+ let form' = optMapNoCopy (mapNoCopy (visitCilVarDecl vis)) form in
+ let spec' =
+ if is_empty_funspec spec then begin
+ if is_copy_behavior vis#behavior then
+ empty_funspec ()
+ else spec (* do not need to change it if it's not a copy visitor. *)
+ end else begin
+ visitCilFunspec vis spec
+ end
+ in
+ if v' != v || spec' != spec || form != form' then
+ begin
+ (match form' with
+ | Some formals
+ when vis#behavior.is_copy_behavior || form != form' ->
+ let selection = State_selection.singleton FormalsDecl.self in
+ apply_on_project
+ ~selection vis (unsafeSetFormalsDecl v') formals
+ | Some _ | None -> ());
+ GFunDecl (spec', v', l)
+ end
+ else g
+ | GVar (v, inito, l) ->
+ let v' = visitCilVarDecl vis v in
+ let inito' = vis#behavior.cinitinfo inito in
+ (match inito'.init with
+ None -> ()
+ | Some i -> let i' = visitCilInit vis v NoOffset i in
+ if i' != i then inito'.init <- Some i');
+ if v' != v || inito' != inito then GVar (v', inito', l) else g
+ | GPragma (a, l) -> begin
+ match visitCilAttributes vis [a] with
+ [a'] -> if a' != a then GPragma (a', l) else g
+ | _ -> Kernel.fatal "visitCilAttributes returns more than one attribute"
+ end
+ | GAnnot (a,l) ->
+ let a' = visitCilAnnotation vis a in
+ if a' != a then GAnnot(a',l) else g
+ | GText _ | GAsm _ -> g
(* sm: utility *)
let startsWith prefix s =
@@ -3931,7 +3931,7 @@ let bytesSizeOfInt (ik: ikind): int =
let bitsSizeOfInt ik = 8 * bytesSizeOfInt ik
let intKindForSize (s:int) (unsigned:bool) : ikind =
- if unsigned then
+ if unsigned then
(* Test the most common sizes first *)
if s = 1 then IUChar
else if s = theMachine.theMachine.sizeof_int then IUInt
@@ -3941,12 +3941,12 @@ let intKindForSize (s:int) (unsigned:bool) : ikind =
else raise Not_found
else
(* Test the most common sizes first *)
- if s = 1 then ISChar
- else if s = theMachine.theMachine.sizeof_int then IInt
- else if s = theMachine.theMachine.sizeof_long then ILong
- else if s = theMachine.theMachine.sizeof_short then IShort
- else if s = theMachine.theMachine.sizeof_longlong then ILongLong
- else raise Not_found
+ if s = 1 then ISChar
+ else if s = theMachine.theMachine.sizeof_int then IInt
+ else if s = theMachine.theMachine.sizeof_long then ILong
+ else if s = theMachine.theMachine.sizeof_short then IShort
+ else if s = theMachine.theMachine.sizeof_longlong then ILongLong
+ else raise Not_found
let uint64_t () = TInt(intKindForSize 8 true,[])
let uint32_t () = TInt(intKindForSize 4 true,[])
@@ -3955,7 +3955,7 @@ let int64_t () = TInt(intKindForSize 8 false,[])
let int32_t () = TInt(intKindForSize 4 false,[])
let int16_t () = TInt(intKindForSize 2 false,[])
-let floatKindForSize (s:int) =
+let floatKindForSize (s:int) =
if s = theMachine.theMachine.sizeof_double then FDouble
else if s = theMachine.theMachine.sizeof_float then FFloat
else if s = theMachine.theMachine.sizeof_longdouble then FLongDouble
@@ -3968,30 +3968,30 @@ let isSigned = function
| IUInt
| IULong
| IULongLong ->
- false
+ false
| ISChar
| IShort
| IInt
| ILong
- | ILongLong ->
+ | ILongLong ->
true
- | IChar ->
+ | IChar ->
not theMachine.theMachine.Cil_types.char_is_unsigned
-let max_signed_number nrBits =
+let max_signed_number nrBits =
let n = nrBits-1 in
Integer.pred (Integer.shift_left Integer.one (Integer.of_int n))
-let max_unsigned_number nrBits =
+let max_unsigned_number nrBits =
Integer.pred (Integer.shift_left Integer.one (Integer.of_int nrBits))
-let min_signed_number nrBits =
+let min_signed_number nrBits =
let n = nrBits-1 in
Integer.neg (Integer.shift_left Integer.one (Integer.of_int n))
let debugTruncation = false
(* True if the integer fits within the kind's range *)
-let fitsInInt k i =
- let signed = isSigned k in
+let fitsInInt k i =
+ let signed = isSigned k in
let nrBits =
let unsignedbits = 8 * (bytesSizeOfInt k) in
if signed then
@@ -4010,21 +4010,21 @@ let fitsInInt k i =
Kernel.debug "Fits in %a %a : %b@."
!pp_ikind_ref k Datatype.Integer.pretty i fits;
fits
-
+
(* Represents an integer as for a given kind.
Returns a flag saying whether the value was changed
during truncation (because it was too large to fit in k). *)
let truncateInteger64 (k: ikind) i =
- if fitsInInt k i then
+ if fitsInInt k i then
i, false
else
- let i' =
+ let i' =
let nrBits = Integer.of_int (8 * (bytesSizeOfInt k)) in
let max_strict_bound = Integer.shift_left Integer.one nrBits in
let modulo = Integer.e_rem i max_strict_bound in
let signed = isSigned k in
- if signed then
- let max_signed_strict_bound =
+ if signed then
+ let max_signed_strict_bound =
Integer.shift_right max_strict_bound Integer.one
in
if Integer.ge modulo max_signed_strict_bound then
@@ -4032,19 +4032,19 @@ let truncateInteger64 (k: ikind) i =
else if Integer.lt modulo (Integer.neg max_signed_strict_bound)
then Integer.add modulo max_strict_bound
else modulo
- else
- if Integer.lt modulo Integer.zero then
- Integer.add modulo max_strict_bound
- else
- modulo
+ else
+ if Integer.lt modulo Integer.zero then
+ Integer.add modulo max_strict_bound
+ else
+ modulo
in
if debugTruncation then
- Kernel.debug ~level:3 "Truncate %a to %a: %a"
+ Kernel.debug ~level:3 "Truncate %a to %a: %a"
Datatype.Integer.pretty i !pp_ikind_ref k Datatype.Integer.pretty i';
i', true
exception Not_representable
-let intKindForValue i (unsigned: bool) =
+let intKindForValue i (unsigned: bool) =
if unsigned then
if fitsInInt IUChar i then IUChar
else if fitsInInt IUShort i then IUShort
@@ -4053,26 +4053,26 @@ let intKindForValue i (unsigned: bool) =
else if fitsInInt IULongLong i then IULongLong
else raise Not_representable
else
- if fitsInInt ISChar i then ISChar
- else if fitsInInt IShort i then IShort
- else if fitsInInt IInt i then IInt
- else if fitsInInt ILong i then ILong
- else if fitsInInt ILongLong i then ILongLong
- else raise Not_representable
+ if fitsInInt ISChar i then ISChar
+ else if fitsInInt IShort i then IShort
+ else if fitsInInt IInt i then IInt
+ else if fitsInInt ILong i then ILong
+ else if fitsInInt ILongLong i then ILongLong
+ else raise Not_representable
(* Construct an integer constant with possible truncation if the kind is not
specified *)
-let kinteger64 ~loc ?repr ?kind i =
+let kinteger64 ~loc ?repr ?kind i =
if debugTruncation then
Kernel.debug ~level:3 "kinteger64 %a" Datatype.Integer.pretty i;
- let kind = match kind with
+ let kind = match kind with
| None ->
(* compute the best ikind: [int] whenever possible and, if no signed type
is possible, try unsigned long long. *)
if fitsInInt IInt i then IInt
else begin
- try intKindForValue i false
- with Not_representable as exn ->
+ try intKindForValue i false
+ with Not_representable as exn ->
if fitsInInt IULongLong i then IULongLong else raise exn
end
| Some k -> k
@@ -4104,10 +4104,10 @@ let lzero ?(loc=Location.unknown) () = lconstant ~loc Integer.zero
let lone ?(loc=Location.unknown) () = lconstant ~loc Integer.one
let lmone ?(loc=Location.unknown) () = lconstant ~loc (Integer.minus_one)
- (** Given the character c in a (CChr c), sign-extend it to 32 bits.
- (This is the official way of interpreting character constants, according
- to ISO C 6.4.4.4.10, which says that character constants are chars cast
- to ints) *)
+(** Given the character c in a (CChr c), sign-extend it to 32 bits.
+ (This is the official way of interpreting character constants, according
+ to ISO C 6.4.4.4.10, which says that character constants are chars cast
+ to ints) *)
let charConstToInt c =
let c' = Char.code c in
if c' < 128
@@ -4118,30 +4118,30 @@ let charConstToIntConstant c =
CInt64(charConstToInt c, IInt, None)
let rec isInteger e = match e.enode with
-| Const(CInt64 (n,_,_)) -> Some n
-| Const(CChr c) -> Some (charConstToInt c)
-| Const(CEnum {eival = v}) -> isInteger v
-| CastE(_, e) -> isInteger e (* BY: This is really strange... *)
-| _ -> None
-
-let isZero (e: exp) : bool =
- match isInteger e with
+ | Const(CInt64 (n,_,_)) -> Some n
+ | Const(CChr c) -> Some (charConstToInt c)
+ | Const(CEnum {eival = v}) -> isInteger v
+ | CastE(_, e) -> isInteger e (* BY: This is really strange... *)
+ | _ -> None
+
+let isZero (e: exp) : bool =
+ match isInteger e with
| None -> false
| Some i -> Integer.equal i Integer.zero
let rec isLogicZero t = match t.term_node with
-| TConst (Integer (n,_)) -> Integer.equal n Integer.zero
-| TConst (LChr c) -> Char.code c = 0
-| TCastE(_, t) -> isLogicZero t
-| _ -> false
+ | TConst (Integer (n,_)) -> Integer.equal n Integer.zero
+ | TConst (LChr c) -> Char.code c = 0
+ | TCastE(_, t) -> isLogicZero t
+ | _ -> false
let isLogicNull t =
isLogicZero t ||
- (let rec aux t = match t.term_node with
- | Tnull -> true
- | TCastE(_, t) -> aux t
- | _ -> false
- in aux t)
+ (let rec aux t = match t.term_node with
+ | Tnull -> true
+ | TCastE(_, t) -> aux t
+ | _ -> false
+ in aux t)
let parseIntAux (str:string) =
let hasSuffix str =
@@ -4166,27 +4166,27 @@ let parseIntAux (str:string) =
2, [IULong; IULongLong]
else if hasSuffix "L" then
1, if octalhexbin then [ILong; IULong; ILongLong; IULongLong]
- else [ILong; ILongLong]
+ else [ILong; ILongLong]
else if hasSuffix "U" then
1, [IUInt; IULong; IULongLong]
else
0, if octalhexbin || true (* !!! This is against the ISO but it
- * is what GCC and MSVC do !!! *)
- then [IInt; IUInt; ILong; IULong; ILongLong; IULongLong]
- else [IInt; ILong; IUInt; ILongLong]
+ * is what GCC and MSVC do !!! *)
+ then [IInt; IUInt; ILong; IULong; ILongLong; IULongLong]
+ else [IInt; ILong; IUInt; ILongLong]
in
(* Convert to integer. To prevent overflow we do the arithmetic
* on Big_int and we take care of overflow. We work only with
* positive integers since the lexer takes care of the sign *)
let rec toInt base (acc: Integer.t) (idx: int) : Integer.t =
let doAcc what =
- if Integer.ge what base
- then
- Kernel.fatal ~current:true
- "Invalid digit %a in integer constant '%s' in base %a."
- (Integer.pretty ~hexa:false) what
- str
- (Integer.pretty ~hexa:false) base;
+ if Integer.ge what base
+ then
+ Kernel.fatal ~current:true
+ "Invalid digit %a in integer constant '%s' in base %a."
+ (Integer.pretty ~hexa:false) what
+ str
+ (Integer.pretty ~hexa:false) base;
let acc' =
Integer.add what (Integer.mul base acc) in
toInt base acc' (idx + 1)
@@ -4205,14 +4205,14 @@ let parseIntAux (str:string) =
Kernel.fatal ~current:true "Invalid integer constant: %s" str
in
let i =
- if octalhexbin && l >= 2 then
- (match String.get str 1 with
- | 'x' | 'X' (* Hexadecimal number *) ->
- toInt Integer.(of_int 16) Integer.zero 2
- | 'b' | 'B' -> (* Binary number *)
- toInt Integer.(of_int 2) Integer.zero 2
- | _ -> (* Octal number *)
- toInt Integer.(of_int 8) Integer.zero 1)
+ if octalhexbin && l >= 2 then
+ (match String.get str 1 with
+ | 'x' | 'X' (* Hexadecimal number *) ->
+ toInt Integer.(of_int 16) Integer.zero 2
+ | 'b' | 'B' -> (* Binary number *)
+ toInt Integer.(of_int 2) Integer.zero 2
+ | _ -> (* Octal number *)
+ toInt Integer.(of_int 8) Integer.zero 1)
else
toInt Integer.(of_int 10) Integer.zero 0
in
@@ -4220,177 +4220,177 @@ let parseIntAux (str:string) =
let parseInt s = fst (parseIntAux s)
-let parseIntLogic ~loc str =
+let parseIntLogic ~loc str =
let i,_= parseIntAux str in
{ term_node = TConst (Integer (i,Some str)) ; term_loc = loc;
term_name = []; term_type = Linteger;}
-
+
let parseIntExp ~loc repr =
let i,kinds = parseIntAux repr in
let rec loop = function
| k::rest ->
- if fitsInInt k i then (* i fits in the current type. *)
- kinteger64 ~loc ~repr ~kind:k i
- else loop rest
+ if fitsInInt k i then (* i fits in the current type. *)
+ kinteger64 ~loc ~repr ~kind:k i
+ else loop rest
| [] ->
- Kernel.fatal ~source:(fst loc) "Cannot represent the integer %s" repr
+ Kernel.fatal ~source:(fst loc) "Cannot represent the integer %s" repr
in
loop kinds
- let mkStmtCfg ~before ~(new_stmtkind:stmtkind) ~(ref_stmt:stmt) : stmt =
- let new_ = { skind = new_stmtkind;
- labels = [];
- sid = -1; succs = []; preds = []; ghost = false; sattr = [] }
- in
- new_.sid <- Sid.next ();
- if before then begin
- new_.succs <- [ref_stmt];
- let old_preds = ref_stmt.preds in
- ref_stmt.preds <- [new_];
- new_.preds <- old_preds;
- List.iter
- (fun pred_stmt ->
- pred_stmt.succs <-
- (List.map
- (fun a_succ -> if a_succ.sid = ref_stmt.sid then new_ else a_succ)
- pred_stmt.succs))
- old_preds
- end else begin
- let old_succs = ref_stmt.succs in
- ref_stmt.succs <- [new_];
- new_.preds <- [ref_stmt];
- new_.succs <- old_succs;
- List.iter
- (fun succ_stmt ->
- succ_stmt.preds <-
- (List.map
- (fun a_pred -> if a_pred.sid = ref_stmt.sid then new_ else a_pred)
- succ_stmt.preds))
- old_succs
- end;
- new_
-
- let mkStmtCfgBlock sl =
- let sid = Sid.next () in
- let n = mkStmt (Block (mkBlock sl)) in
- n.sid <- sid;
- match sl with
- | [] -> n
- | s::_ ->
- let old_preds = s.preds in
- n.succs <- [s];
- n.preds <- s.preds;
- List.iter
- (fun pred_stmt ->
- pred_stmt.succs <-
- (List.map
- (fun a_succ -> if a_succ.sid = s.sid then
- n
- else a_succ)
- pred_stmt.succs))
- old_preds;
- n
-
- let mkEmptyStmt ?ghost ?valid_sid ?sattr ?(loc=Location.unknown) () =
- mkStmt ?ghost ?valid_sid ?sattr (Instr (Skip loc))
-
- let mkStmtOneInstr ?ghost ?valid_sid ?sattr i =
- mkStmt ?ghost ?valid_sid ?sattr (Instr i)
-
- let dummyInstr = Asm([], ["dummy statement!!"], None, Location.unknown)
- let dummyStmt = mkStmt (Instr dummyInstr)
-
- let rec unrollTypeDeep (t: typ) : typ =
- let rec withAttrs (al: attributes) (t: typ) : typ =
- match t with
- TNamed (r, a') -> withAttrs (addAttributes al a') r.ttype
- | TPtr(t, a') -> TPtr(unrollTypeDeep t, addAttributes al a')
- | TArray(t, l, s, a') ->
- let att_elt, att_typ = splitArrayAttributes al in
- TArray(arrayPushAttributes att_elt (unrollTypeDeep t), l, s,
- addAttributes att_typ a')
- | TFun(rt, args, isva, a') ->
- TFun (unrollTypeDeep rt,
- (match args with
- None -> None
- | Some argl ->
- Some (List.map (fun (an,at,aa) ->
- (an, unrollTypeDeep at, aa)) argl)),
- isva,
- addAttributes al a')
- | x -> typeAddAttributes al x
- in
- withAttrs [] t
-
- let isSignedInteger ty =
- match unrollTypeSkel ty with
- | TInt(ik,_) | TEnum ({ekind=ik},_) -> isSigned ik
- | _ -> false
-
- let isUnsignedInteger ty =
- match unrollTypeSkel ty with
- | TInt(ik,_) | TEnum ({ekind=ik},_) -> not (isSigned ik)
- | _ -> false
-
- let var vi : lval = (Var vi, NoOffset)
- (* let assign vi e = Cil_datatype.Instrs(Set (var vi, e), lu) *)
-
- let evar ?(loc=Location.unknown) vi = new_exp ~loc (Lval (var vi))
-
- let mkString ~loc s = new_exp ~loc (Const(CStr s))
-
- let mkLoop ?(sattr = [Attr("while", [])]) ~(guard:exp) ~(body: stmt list) : stmt list =
+let mkStmtCfg ~before ~(new_stmtkind:stmtkind) ~(ref_stmt:stmt) : stmt =
+ let new_ = { skind = new_stmtkind;
+ labels = [];
+ sid = -1; succs = []; preds = []; ghost = false; sattr = [] }
+ in
+ new_.sid <- Sid.next ();
+ if before then begin
+ new_.succs <- [ref_stmt];
+ let old_preds = ref_stmt.preds in
+ ref_stmt.preds <- [new_];
+ new_.preds <- old_preds;
+ List.iter
+ (fun pred_stmt ->
+ pred_stmt.succs <-
+ (List.map
+ (fun a_succ -> if a_succ.sid = ref_stmt.sid then new_ else a_succ)
+ pred_stmt.succs))
+ old_preds
+ end else begin
+ let old_succs = ref_stmt.succs in
+ ref_stmt.succs <- [new_];
+ new_.preds <- [ref_stmt];
+ new_.succs <- old_succs;
+ List.iter
+ (fun succ_stmt ->
+ succ_stmt.preds <-
+ (List.map
+ (fun a_pred -> if a_pred.sid = ref_stmt.sid then new_ else a_pred)
+ succ_stmt.preds))
+ old_succs
+ end;
+ new_
+
+let mkStmtCfgBlock sl =
+ let sid = Sid.next () in
+ let n = mkStmt (Block (mkBlock sl)) in
+ n.sid <- sid;
+ match sl with
+ | [] -> n
+ | s::_ ->
+ let old_preds = s.preds in
+ n.succs <- [s];
+ n.preds <- s.preds;
+ List.iter
+ (fun pred_stmt ->
+ pred_stmt.succs <-
+ (List.map
+ (fun a_succ -> if a_succ.sid = s.sid then
+ n
+ else a_succ)
+ pred_stmt.succs))
+ old_preds;
+ n
+
+let mkEmptyStmt ?ghost ?valid_sid ?sattr ?(loc=Location.unknown) () =
+ mkStmt ?ghost ?valid_sid ?sattr (Instr (Skip loc))
+
+let mkStmtOneInstr ?ghost ?valid_sid ?sattr i =
+ mkStmt ?ghost ?valid_sid ?sattr (Instr i)
+
+let dummyInstr = Asm([], ["dummy statement!!"], None, Location.unknown)
+let dummyStmt = mkStmt (Instr dummyInstr)
+
+let rec unrollTypeDeep (t: typ) : typ =
+ let rec withAttrs (al: attributes) (t: typ) : typ =
+ match t with
+ TNamed (r, a') -> withAttrs (addAttributes al a') r.ttype
+ | TPtr(t, a') -> TPtr(unrollTypeDeep t, addAttributes al a')
+ | TArray(t, l, s, a') ->
+ let att_elt, att_typ = splitArrayAttributes al in
+ TArray(arrayPushAttributes att_elt (unrollTypeDeep t), l, s,
+ addAttributes att_typ a')
+ | TFun(rt, args, isva, a') ->
+ TFun (unrollTypeDeep rt,
+ (match args with
+ None -> None
+ | Some argl ->
+ Some (List.map (fun (an,at,aa) ->
+ (an, unrollTypeDeep at, aa)) argl)),
+ isva,
+ addAttributes al a')
+ | x -> typeAddAttributes al x
+ in
+ withAttrs [] t
+
+let isSignedInteger ty =
+ match unrollTypeSkel ty with
+ | TInt(ik,_) | TEnum ({ekind=ik},_) -> isSigned ik
+ | _ -> false
+
+let isUnsignedInteger ty =
+ match unrollTypeSkel ty with
+ | TInt(ik,_) | TEnum ({ekind=ik},_) -> not (isSigned ik)
+ | _ -> false
+
+let var vi : lval = (Var vi, NoOffset)
+(* let assign vi e = Cil_datatype.Instrs(Set (var vi, e), lu) *)
+
+let evar ?(loc=Location.unknown) vi = new_exp ~loc (Lval (var vi))
+
+let mkString ~loc s = new_exp ~loc (Const(CStr s))
+
+let mkLoop ?(sattr = [Attr("while", [])]) ~(guard:exp) ~(body: stmt list) : stmt list =
(* Do it like this so that the pretty printer recognizes it *)
[ mkStmt ~valid_sid:true ~sattr
(Loop ([],
- mkBlock
- (mkStmt ~valid_sid:true
- (If(guard,
+ mkBlock
+ (mkStmt ~valid_sid:true
+ (If(guard,
mkBlock [],
mkBlock [ mkStmt (Break guard.eloc)], guard.eloc)) ::
- body), guard.eloc, None, None)) ]
+ body), guard.eloc, None, None)) ]
- let mkFor ~(start: stmt list) ~(guard: exp) ~(next: stmt list)
- ~(body: stmt list) : stmt list =
- (start @
- (mkLoop ~sattr:[Attr("For",[])] ~guard ~body:(body @ next)))
+let mkFor ~(start: stmt list) ~(guard: exp) ~(next: stmt list)
+ ~(body: stmt list) : stmt list =
+ (start @
+ (mkLoop ~sattr:[Attr("For",[])] ~guard ~body:(body @ next)))
- let mkForIncr ~(iter : varinfo) ~(first: exp) ~(stopat: exp) ~(incr: exp)
- ~(body: stmt list) : stmt list =
+let mkForIncr ~(iter : varinfo) ~(first: exp) ~(stopat: exp) ~(incr: exp)
+ ~(body: stmt list) : stmt list =
(* See what kind of operator we need *)
- let nextop = match unrollTypeSkel iter.vtype with
- | TPtr _ -> PlusPI
- | _ -> PlusA
- in
- mkFor
- [ mkStmtOneInstr ~valid_sid:true (Set (var iter, first, first.eloc)) ]
- (new_exp ~loc:stopat.eloc (BinOp(Lt, evar iter, stopat, intType)))
- [ mkStmtOneInstr ~valid_sid:true
- (Set
- (var iter,
- (new_exp ~loc:incr.eloc
- (BinOp(nextop, evar iter, incr, iter.vtype))),
- incr.eloc))]
- body
-
- let block_from_unspecified_sequence us =
- mkBlock (List.map (fun (x,_,_,_,_) ->x) us)
-
- let rec stripCasts (e: exp) =
- match e.enode with CastE(_, e') -> stripCasts e' | _ -> e
-
- let rec stripCastsAndInfo (e: exp) =
- match e.enode with Info(e',_) | CastE(_,e') -> stripCastsAndInfo e' | _ -> e
-
- let rec stripCastsButLastInfo (e: exp) =
- match e.enode with
- Info({enode = (Info _ | CastE _)} as e',_)
- | CastE(_,e') ->
- stripCastsButLastInfo e'
- | _ -> e
-
- let rec stripTermCasts (t: term) =
- match t.term_node with TCastE(_, t') -> stripTermCasts t' | _ -> t
+ let nextop = match unrollTypeSkel iter.vtype with
+ | TPtr _ -> PlusPI
+ | _ -> PlusA
+ in
+ mkFor
+ [ mkStmtOneInstr ~valid_sid:true (Set (var iter, first, first.eloc)) ]
+ (new_exp ~loc:stopat.eloc (BinOp(Lt, evar iter, stopat, intType)))
+ [ mkStmtOneInstr ~valid_sid:true
+ (Set
+ (var iter,
+ (new_exp ~loc:incr.eloc
+ (BinOp(nextop, evar iter, incr, iter.vtype))),
+ incr.eloc))]
+ body
+
+let block_from_unspecified_sequence us =
+ mkBlock (List.map (fun (x,_,_,_,_) ->x) us)
+
+let rec stripCasts (e: exp) =
+ match e.enode with CastE(_, e') -> stripCasts e' | _ -> e
+
+let rec stripCastsAndInfo (e: exp) =
+ match e.enode with Info(e',_) | CastE(_,e') -> stripCastsAndInfo e' | _ -> e
+
+let rec stripCastsButLastInfo (e: exp) =
+ match e.enode with
+ Info({enode = (Info _ | CastE _)} as e',_)
+ | CastE(_,e') ->
+ stripCastsButLastInfo e'
+ | _ -> e
+
+let rec stripTermCasts (t: term) =
+ match t.term_node with TCastE(_, t') -> stripTermCasts t' | _ -> t
let exp_info_of_term t = { exp_type = t.term_type; exp_name = t.term_name;}
@@ -4404,57 +4404,57 @@ let map_under_info f e = match e.enode with
| Info(e,einfo) -> new_exp ~loc:e.eloc (Info(f e,einfo))
| _ -> f e
- let app_under_info f e = match e.enode with
- | Info(e,_) -> f e
- | _ -> f e
-
- (* Separate out the storage-modifier name attributes *)
- let separateStorageModifiers (al: attribute list) =
- let isstoragemod (Attr(an, _) | AttrAnnot an : attribute) : bool =
- try
- match Hashtbl.find attributeHash an with
- AttrName issm -> issm
- | _ -> false
- with Not_found -> false
- in
- let stom, rest = List.partition isstoragemod al in
- if not (msvcMode ()) then stom, rest
- else
- (* Put back the declspec. Put it without the leading __ since these will
- * be added later *)
- let stom' =
- List.map
- (function
- | Attr(an, args) -> Attr("declspec", [ACons(an, args)])
- | AttrAnnot _ -> assert false)
- stom
- in
- stom', rest
+let app_under_info f e = match e.enode with
+ | Info(e,_) -> f e
+ | _ -> f e
- let isVoidType t =
- match unrollTypeSkel t with
- TVoid _ -> true
- | _ -> false
+(* Separate out the storage-modifier name attributes *)
+let separateStorageModifiers (al: attribute list) =
+ let isstoragemod (Attr(an, _) | AttrAnnot an : attribute) : bool =
+ try
+ match Hashtbl.find attributeHash an with
+ AttrName issm -> issm
+ | _ -> false
+ with Not_found -> false
+ in
+ let stom, rest = List.partition isstoragemod al in
+ if not (msvcMode ()) then stom, rest
+ else
+ (* Put back the declspec. Put it without the leading __ since these will
+ * be added later *)
+ let stom' =
+ List.map
+ (function
+ | Attr(an, args) -> Attr("declspec", [ACons(an, args)])
+ | AttrAnnot _ -> assert false)
+ stom
+ in
+ stom', rest
- let isVoidPtrType t =
- match unrollTypeSkel t with
- TPtr(tau,_) when isVoidType tau -> true
- | _ -> false
+let isVoidType t =
+ match unrollTypeSkel t with
+ TVoid _ -> true
+ | _ -> false
+
+let isVoidPtrType t =
+ match unrollTypeSkel t with
+ TPtr(tau,_) when isVoidType tau -> true
+ | _ -> false
- let isAnyCharType t =
- match unrollTypeSkel t with
- | TInt((IChar|ISChar|IUChar),_) -> true
- | _ -> false
+let isAnyCharType t =
+ match unrollTypeSkel t with
+ | TInt((IChar|ISChar|IUChar),_) -> true
+ | _ -> false
- let isCharType t =
- match unrollTypeSkel t with
- | TInt(IChar,_) -> true
- | _ -> false
+let isCharType t =
+ match unrollTypeSkel t with
+ | TInt(IChar,_) -> true
+ | _ -> false
let isShortType t =
match unrollTypeSkel t with
- | TInt((IUShort|IShort),_) -> true
- | _ -> false
+ | TInt((IUShort|IShort),_) -> true
+ | _ -> false
let isAnyCharPtrType t =
match unrollTypeSkel t with
@@ -4471,24 +4471,24 @@ let isCharConstPtrType t =
TPtr(tau,attrs) when isCharType tau -> hasAttribute "const" attrs
| _ -> false
- let isIntegralType t =
- match unrollTypeSkel t with
- (TInt _ | TEnum _) -> true
- | _ -> false
+let isIntegralType t =
+ match unrollTypeSkel t with
+ (TInt _ | TEnum _) -> true
+ | _ -> false
- let isIntegralOrPointerType t =
- match unrollTypeSkel t with
- | TInt _ | TEnum _ | TPtr _ -> true
- | _ -> false
+let isIntegralOrPointerType t =
+ match unrollTypeSkel t with
+ | TInt _ | TEnum _ | TPtr _ -> true
+ | _ -> false
- let rec isLogicBooleanType t =
- match t with
- | Ctype ty -> isIntegralType ty
- | Linteger -> true
- | Ltype ({lt_name = name} as tdef,_) ->
- name = Utf8_logic.boolean ||
- ( is_unrollable_ltdef tdef && isLogicBooleanType (unroll_ltdef t))
- | Lreal | Lvar _ | Larrow _ -> false
+let rec isLogicBooleanType t =
+ match t with
+ | Ctype ty -> isIntegralType ty
+ | Linteger -> true
+ | Ltype ({lt_name = name} as tdef,_) ->
+ name = Utf8_logic.boolean ||
+ ( is_unrollable_ltdef tdef && isLogicBooleanType (unroll_ltdef t))
+ | Lreal | Lvar _ | Larrow _ -> false
let isBoolType typ = match unrollType typ with
| TInt (IBool, _) -> true
@@ -4502,513 +4502,513 @@ let rec isLogicPureBooleanType t =
(is_unrollable_ltdef def && isLogicPureBooleanType (unroll_ltdef t))
| _ -> false
- let rec isLogicIntegralType t =
- match t with
- | Ctype t -> isIntegralType t
- | Linteger -> true
- | Lreal -> false
- | Ltype (tdef,_) as ty when is_unrollable_ltdef tdef ->
- isLogicIntegralType (unroll_ltdef ty)
- | Lvar _ | Ltype _ | Larrow _ -> false
-
- let isFloatingType t =
- match unrollTypeSkel t with
- TFloat _ -> true
- | _ -> false
-
- let isLogicFloatType t =
- match t with
- | Ctype t -> isFloatingType t
- | Linteger -> false
- | Lreal -> false
- | Lvar _ | Ltype _ | Larrow _ -> false
-
- let rec isLogicRealOrFloatType t =
- match t with
- | Ctype t -> isFloatingType t
- | Linteger -> false
- | Lreal -> true
- | Ltype (tdef,_) as ty when is_unrollable_ltdef tdef ->
- isLogicRealOrFloatType (unroll_ltdef ty)
- | Lvar _ | Ltype _ | Larrow _ -> false
-
- let rec isLogicRealType t =
- match t with
- | Ctype _ -> false
- | Linteger -> false
- | Lreal -> true
- | Ltype (tdef,_) as ty when is_unrollable_ltdef tdef ->
- isLogicRealType (unroll_ltdef ty)
- | Lvar _ | Ltype _ | Larrow _ -> false
-
- let isArithmeticType t =
- match unrollTypeSkel t with
- (TInt _ | TEnum _ | TFloat _) -> true
- | _ -> false
-
- let isArithmeticOrPointerType t=
- match unrollTypeSkel t with
- | TInt _ | TEnum _ | TFloat _ | TPtr _ -> true
- | _ -> false
-
- let rec isLogicArithmeticType t =
- match t with
- | Ctype t -> isArithmeticType t
- | Linteger | Lreal -> true
- | Ltype (tdef,_) as ty when is_unrollable_ltdef tdef ->
- isLogicArithmeticType (unroll_ltdef ty)
- | Lvar _ | Ltype _ | Larrow _ -> false
-
- let isFunctionType t =
- match unrollTypeSkel t with
- | TFun _ -> true
- | _ -> false
-
- let isLogicFunctionType t = Logic_const.isLogicCType isFunctionType t
-
- let isFunPtrType t =
- match unrollTypeSkel t with
- | TPtr (t,_) -> isFunctionType t
- | _ -> false
-
- let isLogicFunPtrType t = Logic_const.isLogicCType isFunPtrType t
-
- let isPointerType t =
- match unrollTypeSkel t with
- | TPtr _ -> true
- | _ -> false
-
- let rec isTypeTagType t =
- match t with
- | Ltype ({lt_name = "typetag"},[]) -> true
- | Ltype (tdef,_) as ty when is_unrollable_ltdef tdef ->
- isTypeTagType (unroll_ltdef ty)
- | _ -> false
-
- let getReturnType t =
- match unrollType t with
- | TFun(rt,_,_,_) -> rt
- | _ -> Kernel.fatal "getReturnType: not a function type"
-
- let setReturnTypeVI (v: varinfo) (t: typ) =
- match unrollType v.vtype with
- | TFun (_, args, va, a) ->
- v.vtype <- TFun (t, args, va, a)
- | _ -> Kernel.fatal "setReturnType: not a function type"
-
- let setReturnType (f:fundec) (t:typ) =
- setReturnTypeVI f.svar t
-
- (** Returns the type pointed by the given type. Asserts it is a pointer type *)
- let typeOf_pointed typ =
- match unrollType typ with
- | TPtr (typ,_) -> typ
- | _ -> Kernel.fatal "Not a pointer type %a" !pp_typ_ref typ
-
- (** Returns the type of the elements of the array. Asserts it is an array type
- *)
- let typeOf_array_elem t =
- match unrollType t with
- | TArray (ty_elem, _, _, _) -> ty_elem
- | _ -> Kernel.fatal "Not an array type %a" !pp_typ_ref t
-
-
- let frama_c_mutable = "__fc_mutable"
- let () = registerAttribute frama_c_mutable (AttrName false)
- let () =
- registerAttribute (Extlib.strip_underscore frama_c_mutable) (AttrName false)
-
- let frama_c_init_obj = "__fc_initialized_object"
- let () = registerAttribute frama_c_init_obj (AttrName false)
- let () =
- registerAttribute (Extlib.strip_underscore frama_c_init_obj) (AttrName false)
-
- let no_op_coerce typ t =
- match typ with
- | Lreal -> true
- | Linteger -> isLogicIntegralType t.term_type
- | Ltype _ when Logic_const.is_boolean_type typ ->
- isLogicPureBooleanType t.term_type
- | Ltype ({lt_name="set"},_) -> true
- | _ -> false
-
- (**** Compute the type of an expression ****)
- let rec typeOf (e: exp) : typ =
- match (stripInfo e).enode with
- | Info _ -> assert false
- | Const(CInt64 (_, ik, _)) -> TInt(ik, [])
-
- (* Character constants have type int. ISO/IEC 9899:1999 (E),
- * section 6.4.4.4 [Character constants], paragraph 10, if you
- * don't believe me. *)
- | Const(CChr _) -> intType
-
- (* The type of a string is a pointer to characters ! The only case when
- * you would want it to be an array is as an argument to sizeof, but we
- * have SizeOfStr for that *)
- | Const(CStr _s) -> theMachine.stringLiteralType
-
- | Const(CWStr _s) -> TPtr(theMachine.wcharType,[])
-
- | Const(CReal (_, fk, _)) -> TFloat(fk, [])
-
- | Const(CEnum {eival=v}) -> typeOf v
-
- (* l-values used as r-values lose their qualifiers (C99 6.3.2.1:2) *)
- | Lval(lv) -> type_remove_qualifier_attributes (typeOfLval lv)
-
- | SizeOf _ | SizeOfE _ | SizeOfStr _ -> theMachine.typeOfSizeOf
- | AlignOf _ | AlignOfE _ -> theMachine.typeOfSizeOf
- | UnOp (_, _, t) -> t
- | BinOp (_, _, _, t) -> t
- | CastE (t, _) -> t
- | AddrOf (lv) -> TPtr(typeOfLval lv, [])
- | StartOf (lv) ->
- match unrollType (typeOfLval lv) with
- | TArray (t,_,_, _) -> TPtr(t, [])
- | _ -> Kernel.fatal ~current:true "typeOf: StartOf on a non-array"
-
- and typeOfInit (i: init) : typ =
- match i with
- SingleInit e -> typeOf e
- | CompoundInit (t, _) -> t
-
- and typeOfLval = function
- Var vi, off -> typeOffset vi.vtype off
- | Mem addr, off -> begin
- match unrollType (typeOf addr) with
- | TPtr (t, _) -> typeOffset t off
- | _ -> Kernel.fatal ~current:true
- "typeOfLval: Mem on a non-pointer (%a)" !pp_exp_ref addr
- end
-
- and typeOfLhost = function
- | Var x -> x.vtype
- | Mem e -> typeOf_pointed (typeOf e)
-
- and typeOffset basetyp = function
- NoOffset -> basetyp
- | Index (_, o) -> begin
- match unrollType basetyp with
- TArray (t, _, _, _baseAttrs) ->
- typeOffset t o
- | _ -> Kernel.fatal ~current:true "typeOffset: Index on a non-array"
- end
- | Field (fi, o) ->
- match unrollType basetyp with
- | TComp (_, _,baseAttrs) ->
- let attrs = filter_qualifier_attributes baseAttrs in
- (* if the field is mutable, it can written to even if it is
- part of a const object (but a const subpart of the field
- is still const (except potentially a mutable subsubpart, etc.)
- *)
- let attrs =
- if hasAttribute frama_c_mutable fi.fattr then
- dropAttribute "const" attrs
- else attrs
- in
- typeOffset (typeAddAttributes attrs fi.ftype) o
- | basetyp ->
- Kernel.fatal ~current:true
- "typeOffset: Field %s on a non-compound type '%a'"
- fi.fname !pp_typ_ref basetyp
-
- (**** Compute the type of a term lval ****)
- let rec typeOfTermLval = function
- TVar vi, off ->
- let ty = match vi.lv_origin with
- | Some v -> Ctype v.vtype
- | None -> vi.lv_type
- in
- typeTermOffset ty off
- | TResult ty, off -> typeTermOffset (Ctype ty) off
- | TMem addr, off -> begin
- let rec type_of_pointed = function
- | Ctype typ ->
- begin match unrollType typ with
- | TPtr (t, _) -> typeTermOffset (Ctype t) off
- | _ ->
- Kernel.fatal ~current:true
- "typeOfTermLval: Mem on a non-pointer"
- end
- | Linteger | Lreal ->
- Kernel.fatal ~current:true "typeOfTermLval: Mem on a logic type"
- | Ltype (s,_) as ty when is_unrollable_ltdef s ->
- type_of_pointed (unroll_ltdef ty)
- | Ltype (s,_) ->
- Kernel.fatal ~current:true
- "typeOfTermLval: Mem on a non-C type (%s)" s.lt_name
- | Lvar s ->
- Kernel.fatal ~current:true
- "typeOfTermLval: Mem on a non-C type ('%s)" s
- | Larrow _ ->
- Kernel.fatal ~current:true
- "typeOfTermLval: Mem on a function type"
- in
- Logic_const.transform_element type_of_pointed addr.term_type
- end
-
- and typeTermOffset basetyp =
- let blendAttributes baseAttrs t =
- let (_, _, contagious) =
- partitionAttributes ~default:(AttrName false) baseAttrs in
- let rec putAttributes = function
- | Ctype typ ->
- Ctype (typeAddAttributes contagious typ)
- | Linteger | Lreal ->
- Kernel.fatal ~current:true
- "typeTermOffset: Attribute on a logic type"
- | Ltype (s,_) as ty when is_unrollable_ltdef s ->
- putAttributes (unroll_ltdef ty)
- | Ltype (s,_) ->
- Kernel.fatal ~current:true
- "typeTermOffset: Attribute on a non-C type (%s)" s.lt_name
- | Lvar s ->
- Kernel.fatal ~current:true
- "typeTermOffset: Attribute on a non-C type ('%s)" s
- | Larrow _ ->
- Kernel.fatal ~current:true
- "typeTermOffset: Attribute on a function type"
- in
- Logic_const.transform_element putAttributes t
- in
- function
- | TNoOffset -> basetyp
- | TIndex (e, o) -> begin
- let rec elt_type basetyp =
- match basetyp with
- | Ctype typ ->
- begin match unrollType typ with
- TArray (t, _, _, baseAttrs) ->
- let elementType = typeTermOffset (Ctype t) o in
- blendAttributes baseAttrs elementType
- | _ ->
- Kernel.fatal ~current:true
- "typeTermOffset: Index on a non-array"
- end
- | Linteger | Lreal -> Kernel.fatal ~current:true "typeTermOffset: Index on a logic type"
- | Ltype (s,_) as ty when is_unrollable_ltdef s ->
- elt_type (unroll_ltdef ty)
- | Ltype (s,_) ->
- Kernel.fatal ~current:true "typeTermOffset: Index on a non-C type (%s)" s.lt_name
- | Lvar s -> Kernel.fatal ~current:true "typeTermOffset: Index on a non-C type ('%s)" s
- | Larrow _ -> Kernel.fatal ~current:true "typeTermOffset: Index on a function type"
- in
- Logic_const.set_conversion
- (Logic_const.transform_element elt_type basetyp) e.term_type
- end
- | TModel (m,o) -> typeTermOffset m.mi_field_type o
- | TField (fi, o) ->
- let rec elt_type = function
- | Ctype typ ->
- begin match unrollType typ with
- TComp (_, _, baseAttrs) ->
- let fieldType = typeTermOffset (Ctype fi.ftype) o in
- blendAttributes baseAttrs fieldType
- | _ -> Kernel.fatal ~current:true "typeTermOffset: Field on a non-compound"
- end
- | Linteger | Lreal -> Kernel.fatal ~current:true "typeTermOffset: Field on a logic type"
- | Ltype (s,_) as ty when is_unrollable_ltdef s ->
- elt_type (unroll_ltdef ty)
- | Ltype (s,_) ->
- Kernel.fatal ~current:true "typeTermOffset: Field on a non-C type (%s)" s.lt_name
- | Lvar s -> Kernel.fatal ~current:true "typeTermOffset: Field on a non-C type ('%s)" s
- | Larrow _ -> Kernel.fatal ~current:true "typeTermOffset: Field on a function type"
- in Logic_const.transform_element elt_type basetyp
-
- (**** Look for the presence of an attribute in a type ****)
-
- let typeHasAttribute attr typ = hasAttribute attr (typeAttrs typ)
-
- let rec typeHasQualifier attr typ =
- match typ with
- | TNamed (t, a) ->
- hasAttribute attr a || typeHasQualifier attr t.ttype
- | TArray (t, _, _, a) ->
- typeHasQualifier attr t || (* ill-formed type *) hasAttribute attr a
- | _ -> hasAttribute attr (typeAttrs typ)
-
- let typeHasAttributeMemoryBlock a (ty:typ): bool =
- let f attrs = if hasAttribute a attrs then raise Exit in
- let rec visit (t: typ) : unit =
+let rec isLogicIntegralType t =
+ match t with
+ | Ctype t -> isIntegralType t
+ | Linteger -> true
+ | Lreal -> false
+ | Ltype (tdef,_) as ty when is_unrollable_ltdef tdef ->
+ isLogicIntegralType (unroll_ltdef ty)
+ | Lvar _ | Ltype _ | Larrow _ -> false
+
+let isFloatingType t =
+ match unrollTypeSkel t with
+ TFloat _ -> true
+ | _ -> false
+
+let isLogicFloatType t =
+ match t with
+ | Ctype t -> isFloatingType t
+ | Linteger -> false
+ | Lreal -> false
+ | Lvar _ | Ltype _ | Larrow _ -> false
+
+let rec isLogicRealOrFloatType t =
+ match t with
+ | Ctype t -> isFloatingType t
+ | Linteger -> false
+ | Lreal -> true
+ | Ltype (tdef,_) as ty when is_unrollable_ltdef tdef ->
+ isLogicRealOrFloatType (unroll_ltdef ty)
+ | Lvar _ | Ltype _ | Larrow _ -> false
+
+let rec isLogicRealType t =
+ match t with
+ | Ctype _ -> false
+ | Linteger -> false
+ | Lreal -> true
+ | Ltype (tdef,_) as ty when is_unrollable_ltdef tdef ->
+ isLogicRealType (unroll_ltdef ty)
+ | Lvar _ | Ltype _ | Larrow _ -> false
+
+let isArithmeticType t =
+ match unrollTypeSkel t with
+ (TInt _ | TEnum _ | TFloat _) -> true
+ | _ -> false
+
+let isArithmeticOrPointerType t=
+ match unrollTypeSkel t with
+ | TInt _ | TEnum _ | TFloat _ | TPtr _ -> true
+ | _ -> false
+
+let rec isLogicArithmeticType t =
+ match t with
+ | Ctype t -> isArithmeticType t
+ | Linteger | Lreal -> true
+ | Ltype (tdef,_) as ty when is_unrollable_ltdef tdef ->
+ isLogicArithmeticType (unroll_ltdef ty)
+ | Lvar _ | Ltype _ | Larrow _ -> false
+
+let isFunctionType t =
+ match unrollTypeSkel t with
+ | TFun _ -> true
+ | _ -> false
+
+let isLogicFunctionType t = Logic_const.isLogicCType isFunctionType t
+
+let isFunPtrType t =
+ match unrollTypeSkel t with
+ | TPtr (t,_) -> isFunctionType t
+ | _ -> false
+
+let isLogicFunPtrType t = Logic_const.isLogicCType isFunPtrType t
+
+let isPointerType t =
+ match unrollTypeSkel t with
+ | TPtr _ -> true
+ | _ -> false
+
+let rec isTypeTagType t =
+ match t with
+ | Ltype ({lt_name = "typetag"},[]) -> true
+ | Ltype (tdef,_) as ty when is_unrollable_ltdef tdef ->
+ isTypeTagType (unroll_ltdef ty)
+ | _ -> false
+
+let getReturnType t =
+ match unrollType t with
+ | TFun(rt,_,_,_) -> rt
+ | _ -> Kernel.fatal "getReturnType: not a function type"
+
+let setReturnTypeVI (v: varinfo) (t: typ) =
+ match unrollType v.vtype with
+ | TFun (_, args, va, a) ->
+ v.vtype <- TFun (t, args, va, a)
+ | _ -> Kernel.fatal "setReturnType: not a function type"
+
+let setReturnType (f:fundec) (t:typ) =
+ setReturnTypeVI f.svar t
+
+(** Returns the type pointed by the given type. Asserts it is a pointer type *)
+let typeOf_pointed typ =
+ match unrollType typ with
+ | TPtr (typ,_) -> typ
+ | _ -> Kernel.fatal "Not a pointer type %a" !pp_typ_ref typ
+
+(** Returns the type of the elements of the array. Asserts it is an array type
+*)
+let typeOf_array_elem t =
+ match unrollType t with
+ | TArray (ty_elem, _, _, _) -> ty_elem
+ | _ -> Kernel.fatal "Not an array type %a" !pp_typ_ref t
+
+
+let frama_c_mutable = "__fc_mutable"
+let () = registerAttribute frama_c_mutable (AttrName false)
+let () =
+ registerAttribute (Extlib.strip_underscore frama_c_mutable) (AttrName false)
+
+let frama_c_init_obj = "__fc_initialized_object"
+let () = registerAttribute frama_c_init_obj (AttrName false)
+let () =
+ registerAttribute (Extlib.strip_underscore frama_c_init_obj) (AttrName false)
+
+let no_op_coerce typ t =
+ match typ with
+ | Lreal -> true
+ | Linteger -> isLogicIntegralType t.term_type
+ | Ltype _ when Logic_const.is_boolean_type typ ->
+ isLogicPureBooleanType t.term_type
+ | Ltype ({lt_name="set"},_) -> true
+ | _ -> false
+
+(**** Compute the type of an expression ****)
+let rec typeOf (e: exp) : typ =
+ match (stripInfo e).enode with
+ | Info _ -> assert false
+ | Const(CInt64 (_, ik, _)) -> TInt(ik, [])
+
+ (* Character constants have type int. ISO/IEC 9899:1999 (E),
+ * section 6.4.4.4 [Character constants], paragraph 10, if you
+ * don't believe me. *)
+ | Const(CChr _) -> intType
+
+ (* The type of a string is a pointer to characters ! The only case when
+ * you would want it to be an array is as an argument to sizeof, but we
+ * have SizeOfStr for that *)
+ | Const(CStr _s) -> theMachine.stringLiteralType
+
+ | Const(CWStr _s) -> TPtr(theMachine.wcharType,[])
+
+ | Const(CReal (_, fk, _)) -> TFloat(fk, [])
+
+ | Const(CEnum {eival=v}) -> typeOf v
+
+ (* l-values used as r-values lose their qualifiers (C99 6.3.2.1:2) *)
+ | Lval(lv) -> type_remove_qualifier_attributes (typeOfLval lv)
+
+ | SizeOf _ | SizeOfE _ | SizeOfStr _ -> theMachine.typeOfSizeOf
+ | AlignOf _ | AlignOfE _ -> theMachine.typeOfSizeOf
+ | UnOp (_, _, t) -> t
+ | BinOp (_, _, _, t) -> t
+ | CastE (t, _) -> t
+ | AddrOf (lv) -> TPtr(typeOfLval lv, [])
+ | StartOf (lv) ->
+ match unrollType (typeOfLval lv) with
+ | TArray (t,_,_, _) -> TPtr(t, [])
+ | _ -> Kernel.fatal ~current:true "typeOf: StartOf on a non-array"
+
+and typeOfInit (i: init) : typ =
+ match i with
+ SingleInit e -> typeOf e
+ | CompoundInit (t, _) -> t
+
+and typeOfLval = function
+ Var vi, off -> typeOffset vi.vtype off
+ | Mem addr, off -> begin
+ match unrollType (typeOf addr) with
+ | TPtr (t, _) -> typeOffset t off
+ | _ -> Kernel.fatal ~current:true
+ "typeOfLval: Mem on a non-pointer (%a)" !pp_exp_ref addr
+ end
+
+and typeOfLhost = function
+ | Var x -> x.vtype
+ | Mem e -> typeOf_pointed (typeOf e)
+
+and typeOffset basetyp = function
+ NoOffset -> basetyp
+ | Index (_, o) -> begin
+ match unrollType basetyp with
+ TArray (t, _, _, _baseAttrs) ->
+ typeOffset t o
+ | _ -> Kernel.fatal ~current:true "typeOffset: Index on a non-array"
+ end
+ | Field (fi, o) ->
+ match unrollType basetyp with
+ | TComp (_, _,baseAttrs) ->
+ let attrs = filter_qualifier_attributes baseAttrs in
+ (* if the field is mutable, it can written to even if it is
+ part of a const object (but a const subpart of the field
+ is still const (except potentially a mutable subsubpart, etc.)
+ *)
+ let attrs =
+ if hasAttribute frama_c_mutable fi.fattr then
+ dropAttribute "const" attrs
+ else attrs
+ in
+ typeOffset (typeAddAttributes attrs fi.ftype) o
+ | basetyp ->
+ Kernel.fatal ~current:true
+ "typeOffset: Field %s on a non-compound type '%a'"
+ fi.fname !pp_typ_ref basetyp
+
+(**** Compute the type of a term lval ****)
+let rec typeOfTermLval = function
+ TVar vi, off ->
+ let ty = match vi.lv_origin with
+ | Some v -> Ctype v.vtype
+ | None -> vi.lv_type
+ in
+ typeTermOffset ty off
+ | TResult ty, off -> typeTermOffset (Ctype ty) off
+ | TMem addr, off -> begin
+ let rec type_of_pointed = function
+ | Ctype typ ->
+ begin match unrollType typ with
+ | TPtr (t, _) -> typeTermOffset (Ctype t) off
+ | _ ->
+ Kernel.fatal ~current:true
+ "typeOfTermLval: Mem on a non-pointer"
+ end
+ | Linteger | Lreal ->
+ Kernel.fatal ~current:true "typeOfTermLval: Mem on a logic type"
+ | Ltype (s,_) as ty when is_unrollable_ltdef s ->
+ type_of_pointed (unroll_ltdef ty)
+ | Ltype (s,_) ->
+ Kernel.fatal ~current:true
+ "typeOfTermLval: Mem on a non-C type (%s)" s.lt_name
+ | Lvar s ->
+ Kernel.fatal ~current:true
+ "typeOfTermLval: Mem on a non-C type ('%s)" s
+ | Larrow _ ->
+ Kernel.fatal ~current:true
+ "typeOfTermLval: Mem on a function type"
+ in
+ Logic_const.transform_element type_of_pointed addr.term_type
+ end
+
+and typeTermOffset basetyp =
+ let blendAttributes baseAttrs t =
+ let (_, _, contagious) =
+ partitionAttributes ~default:(AttrName false) baseAttrs in
+ let rec putAttributes = function
+ | Ctype typ ->
+ Ctype (typeAddAttributes contagious typ)
+ | Linteger | Lreal ->
+ Kernel.fatal ~current:true
+ "typeTermOffset: Attribute on a logic type"
+ | Ltype (s,_) as ty when is_unrollable_ltdef s ->
+ putAttributes (unroll_ltdef ty)
+ | Ltype (s,_) ->
+ Kernel.fatal ~current:true
+ "typeTermOffset: Attribute on a non-C type (%s)" s.lt_name
+ | Lvar s ->
+ Kernel.fatal ~current:true
+ "typeTermOffset: Attribute on a non-C type ('%s)" s
+ | Larrow _ ->
+ Kernel.fatal ~current:true
+ "typeTermOffset: Attribute on a function type"
+ in
+ Logic_const.transform_element putAttributes t
+ in
+ function
+ | TNoOffset -> basetyp
+ | TIndex (e, o) -> begin
+ let rec elt_type basetyp =
+ match basetyp with
+ | Ctype typ ->
+ begin match unrollType typ with
+ TArray (t, _, _, baseAttrs) ->
+ let elementType = typeTermOffset (Ctype t) o in
+ blendAttributes baseAttrs elementType
+ | _ ->
+ Kernel.fatal ~current:true
+ "typeTermOffset: Index on a non-array"
+ end
+ | Linteger | Lreal -> Kernel.fatal ~current:true "typeTermOffset: Index on a logic type"
+ | Ltype (s,_) as ty when is_unrollable_ltdef s ->
+ elt_type (unroll_ltdef ty)
+ | Ltype (s,_) ->
+ Kernel.fatal ~current:true "typeTermOffset: Index on a non-C type (%s)" s.lt_name
+ | Lvar s -> Kernel.fatal ~current:true "typeTermOffset: Index on a non-C type ('%s)" s
+ | Larrow _ -> Kernel.fatal ~current:true "typeTermOffset: Index on a function type"
+ in
+ Logic_const.set_conversion
+ (Logic_const.transform_element elt_type basetyp) e.term_type
+ end
+ | TModel (m,o) -> typeTermOffset m.mi_field_type o
+ | TField (fi, o) ->
+ let rec elt_type = function
+ | Ctype typ ->
+ begin match unrollType typ with
+ TComp (_, _, baseAttrs) ->
+ let fieldType = typeTermOffset (Ctype fi.ftype) o in
+ blendAttributes baseAttrs fieldType
+ | _ -> Kernel.fatal ~current:true "typeTermOffset: Field on a non-compound"
+ end
+ | Linteger | Lreal -> Kernel.fatal ~current:true "typeTermOffset: Field on a logic type"
+ | Ltype (s,_) as ty when is_unrollable_ltdef s ->
+ elt_type (unroll_ltdef ty)
+ | Ltype (s,_) ->
+ Kernel.fatal ~current:true "typeTermOffset: Field on a non-C type (%s)" s.lt_name
+ | Lvar s -> Kernel.fatal ~current:true "typeTermOffset: Field on a non-C type ('%s)" s
+ | Larrow _ -> Kernel.fatal ~current:true "typeTermOffset: Field on a function type"
+ in Logic_const.transform_element elt_type basetyp
+
+(**** Look for the presence of an attribute in a type ****)
+
+let typeHasAttribute attr typ = hasAttribute attr (typeAttrs typ)
+
+let rec typeHasQualifier attr typ =
+ match typ with
+ | TNamed (t, a) ->
+ hasAttribute attr a || typeHasQualifier attr t.ttype
+ | TArray (t, _, _, a) ->
+ typeHasQualifier attr t || (* ill-formed type *) hasAttribute attr a
+ | _ -> hasAttribute attr (typeAttrs typ)
+
+let typeHasAttributeMemoryBlock a (ty:typ): bool =
+ let f attrs = if hasAttribute a attrs then raise Exit in
+ let rec visit (t: typ) : unit =
match t with
- | TNamed (r, a') -> f a' ; visit r.ttype
- | TArray(t, _, _, a') -> f a'; visit t
- | TComp (comp, _, a') -> f a';
- List.iter (fun fi -> f fi.fattr; visit fi.ftype) comp.cfields
- | TVoid a'
- | TInt (_, a')
- | TFloat (_, a')
- | TEnum (_, a')
- | TFun (_, _, _, a')
- | TBuiltin_va_list a'
- | TPtr(_, a') -> f a'
- in
- try visit ty; false
- with Exit -> true
-
- (**** Check for const attribute ****)
-
- let isConstType typ_lval = typeHasAttributeMemoryBlock "const" typ_lval
-
- (**** Check for volatile attribute ****)
-
- let isVolatileType typ_lval = typeHasAttributeMemoryBlock "volatile" typ_lval
-
- let rec isVolatileLogicType = function
+ | TNamed (r, a') -> f a' ; visit r.ttype
+ | TArray(t, _, _, a') -> f a'; visit t
+ | TComp (comp, _, a') -> f a';
+ List.iter (fun fi -> f fi.fattr; visit fi.ftype) comp.cfields
+ | TVoid a'
+ | TInt (_, a')
+ | TFloat (_, a')
+ | TEnum (_, a')
+ | TFun (_, _, _, a')
+ | TBuiltin_va_list a'
+ | TPtr(_, a') -> f a'
+ in
+ try visit ty; false
+ with Exit -> true
+
+(**** Check for const attribute ****)
+
+let isConstType typ_lval = typeHasAttributeMemoryBlock "const" typ_lval
+
+(**** Check for volatile attribute ****)
+
+let isVolatileType typ_lval = typeHasAttributeMemoryBlock "volatile" typ_lval
+
+let rec isVolatileLogicType = function
| Ctype typ -> isVolatileType typ
| Linteger | Lreal | Lvar _ | Larrow _ -> false
| Ltype (tdef,_) as ty when is_unrollable_ltdef tdef ->
isVolatileLogicType (unroll_ltdef ty)
| Ltype _ -> false
- let isVolatileLval lv = isVolatileType (typeOfLval lv)
- let isVolatileTermLval lv =
+let isVolatileLval lv = isVolatileType (typeOfLval lv)
+let isVolatileTermLval lv =
Logic_const.plain_or_set isVolatileLogicType (typeOfTermLval lv)
- (**
- **
- ** MACHINE DEPENDENT PART
- **
- **)
- exception SizeOfError of string * typ
- let find_size_in_cache s f =
- match s.scache with
- | Not_Computed ->
- let r =
- try
- f ()
- with SizeOfError (msg, typ) as e ->
- s.scache <- Not_Computable (msg, typ);
- raise e
- in
- s.scache <- Computed r;
- r
- | Not_Computable (msg, typ) -> raise (SizeOfError (msg, typ))
- | Computed r -> r
+(**
+ **
+ ** MACHINE DEPENDENT PART
+ **
+ **)
+exception SizeOfError of string * typ
+let find_size_in_cache s f =
+ match s.scache with
+ | Not_Computed ->
+ let r =
+ try
+ f ()
+ with SizeOfError (msg, typ) as e ->
+ s.scache <- Not_Computable (msg, typ);
+ raise e
+ in
+ s.scache <- Computed r;
+ r
+ | Not_Computable (msg, typ) -> raise (SizeOfError (msg, typ))
+ | Computed r -> r
(* Some basic type utilities *)
- let rank : ikind -> int = function
- (* these are just unique numbers representing the integer
- conversion rank. *)
- | IBool | IChar | ISChar | IUChar -> 1
- | IShort | IUShort -> 2
- | IInt | IUInt -> 3
- | ILong | IULong -> 4
- | ILongLong | IULongLong -> 5
-
- let unsignedVersionOf (ik:ikind): ikind =
- match ik with
- | ISChar | IChar -> IUChar
- | IShort -> IUShort
- | IInt -> IUInt
- | ILong -> IULong
- | ILongLong -> IULongLong
- | _ -> ik
-
- let frank = function
- | FFloat -> 1
- | FDouble -> 2
- | FLongDouble -> 3
-
-
- (* Convert 2 integer constants to integers with the same type, in preparation
- for a binary operation. See ISO C 6.3.1.8p1 *)
- let convertInts i1 ik1 i2 ik2 =
- if ik1 = ik2 then (* nothing to do *)
- i1, i2, ik1
- else begin
- let r1 = rank ik1 in
- let r2 = rank ik2 in
- let ik' =
- if (isSigned ik1) = (isSigned ik2) then begin
- (* Both signed or both unsigned. *)
- if r1 > r2 then ik1 else ik2
- end
- else begin
- let signedKind, unsignedKind, signedRank, unsignedRank =
- if isSigned ik1 then ik1, ik2, r1, r2 else ik2, ik1, r2, r1
- in
- (* The rules for signed + unsigned get hairy.
- (unsigned short + long) is converted to signed long,
- but (unsigned int + long) is converted to unsigned long.*)
- if unsignedRank >= signedRank then unsignedKind
- else if (bytesSizeOfInt signedKind) > (bytesSizeOfInt unsignedKind) then
- signedKind
- else
- unsignedVersionOf signedKind
- end
- in
- let i1',_ = truncateInteger64 ik' i1 in
- let i2',_ = truncateInteger64 ik' i2 in
- i1', i2', ik'
- end
+let rank : ikind -> int = function
+ (* these are just unique numbers representing the integer
+ conversion rank. *)
+ | IBool | IChar | ISChar | IUChar -> 1
+ | IShort | IUShort -> 2
+ | IInt | IUInt -> 3
+ | ILong | IULong -> 4
+ | ILongLong | IULongLong -> 5
+
+let unsignedVersionOf (ik:ikind): ikind =
+ match ik with
+ | ISChar | IChar -> IUChar
+ | IShort -> IUShort
+ | IInt -> IUInt
+ | ILong -> IULong
+ | ILongLong -> IULongLong
+ | _ -> ik
+
+let frank = function
+ | FFloat -> 1
+ | FDouble -> 2
+ | FLongDouble -> 3
+
+
+(* Convert 2 integer constants to integers with the same type, in preparation
+ for a binary operation. See ISO C 6.3.1.8p1 *)
+let convertInts i1 ik1 i2 ik2 =
+ if ik1 = ik2 then (* nothing to do *)
+ i1, i2, ik1
+ else begin
+ let r1 = rank ik1 in
+ let r2 = rank ik2 in
+ let ik' =
+ if (isSigned ik1) = (isSigned ik2) then begin
+ (* Both signed or both unsigned. *)
+ if r1 > r2 then ik1 else ik2
+ end
+ else begin
+ let signedKind, unsignedKind, signedRank, unsignedRank =
+ if isSigned ik1 then ik1, ik2, r1, r2 else ik2, ik1, r2, r1
+ in
+ (* The rules for signed + unsigned get hairy.
+ (unsigned short + long) is converted to signed long,
+ but (unsigned int + long) is converted to unsigned long.*)
+ if unsignedRank >= signedRank then unsignedKind
+ else if (bytesSizeOfInt signedKind) > (bytesSizeOfInt unsignedKind) then
+ signedKind
+ else
+ unsignedVersionOf signedKind
+ end
+ in
+ let i1',_ = truncateInteger64 ik' i1 in
+ let i2',_ = truncateInteger64 ik' i2 in
+ i1', i2', ik'
+ end
(* Local type to compute alignments of struct field. *)
- type offsetAcc =
- { oaFirstFree: int; (* The first free bit *)
- oaLastFieldStart: int; (* Where the previous field started *)
- oaLastFieldWidth: int; (* The width of the previous field. Might not
- * be same as FirstFree - FieldStart because
- * of internal padding *)
- oaPrevBitPack: (int * ikind * int) option; (* If the previous fields
- * were packed bitfields,
- * the bit where packing
- * has started, the ikind
- * of the bitfield and the
- * width of the ikind *)
- }
+type offsetAcc =
+ { oaFirstFree: int; (* The first free bit *)
+ oaLastFieldStart: int; (* Where the previous field started *)
+ oaLastFieldWidth: int; (* The width of the previous field. Might not
+ * be same as FirstFree - FieldStart because
+ * of internal padding *)
+ oaPrevBitPack: (int * ikind * int) option; (* If the previous fields
+ * were packed bitfields,
+ * the bit where packing
+ * has started, the ikind
+ * of the bitfield and the
+ * width of the ikind *)
+ }
(* Hack to prevent infinite recursion in alignments *)
let ignoreAlignmentAttrs = ref false
- (* Get the minimum alignment in bytes for a given type *)
-let rec bytesAlignOf t =
- let alignOfType () = match t with
- | TInt((IChar|ISChar|IUChar|IBool), _) -> 1
- | TInt((IShort|IUShort), _) -> theMachine.theMachine.alignof_short
- | TInt((IInt|IUInt), _) -> theMachine.theMachine.alignof_int
- | TInt((ILong|IULong), _) -> theMachine.theMachine.alignof_long
- | TInt((ILongLong|IULongLong), _) ->
- theMachine.theMachine.alignof_longlong
- | TEnum (ei,_) -> bytesAlignOf (TInt(ei.ekind, []))
- | TFloat(FFloat, _) -> theMachine.theMachine.alignof_float
- | TFloat(FDouble, _) -> theMachine.theMachine.alignof_double
- | TFloat(FLongDouble, _) ->
- theMachine.theMachine.alignof_longdouble
- | TNamed (t, _) -> bytesAlignOf t.ttype
- | TArray (t, _, _, _) -> bytesAlignOf t
- | TPtr _ | TBuiltin_va_list _ ->
- theMachine.theMachine.alignof_ptr
-
- (* For composite types get the maximum alignment of any field inside *)
- | TComp (c, _, _) ->
- (* On GCC the zero-width fields do not contribute to the alignment. On
- * MSVC only those zero-width that _do_ appear after other
- * bitfields contribute to the alignment. So we drop those that
- * do not occur after other bitfields *)
- (* This is not correct for Diab-C compiler. *)
- let rec dropZeros (afterbitfield: bool) = function
- | f :: rest when f.fbitfield = Some 0 && not afterbitfield ->
- dropZeros afterbitfield rest
- | f :: rest -> f :: dropZeros (f.fbitfield <> None) rest
- | [] -> []
- in
- let fields = dropZeros false c.cfields in
- List.fold_left
- (fun sofar f ->
- (* Bitfields with zero width do not contribute to the alignment in
- * GCC *)
- if not (msvcMode ()) && f.fbitfield = Some 0 then sofar else
- max sofar (alignOfField f)) 1 fields
- (* These are some error cases *)
- | TFun _ when not (msvcMode ()) ->
- theMachine.theMachine.alignof_fun
- | TFun _ as t -> raise (SizeOfError ("Undefined sizeof on a function.", t))
- | TVoid _ as t -> raise (SizeOfError ("Undefined sizeof(void).", t))
+(* Get the minimum alignment in bytes for a given type *)
+let rec bytesAlignOf t =
+ let alignOfType () = match t with
+ | TInt((IChar|ISChar|IUChar|IBool), _) -> 1
+ | TInt((IShort|IUShort), _) -> theMachine.theMachine.alignof_short
+ | TInt((IInt|IUInt), _) -> theMachine.theMachine.alignof_int
+ | TInt((ILong|IULong), _) -> theMachine.theMachine.alignof_long
+ | TInt((ILongLong|IULongLong), _) ->
+ theMachine.theMachine.alignof_longlong
+ | TEnum (ei,_) -> bytesAlignOf (TInt(ei.ekind, []))
+ | TFloat(FFloat, _) -> theMachine.theMachine.alignof_float
+ | TFloat(FDouble, _) -> theMachine.theMachine.alignof_double
+ | TFloat(FLongDouble, _) ->
+ theMachine.theMachine.alignof_longdouble
+ | TNamed (t, _) -> bytesAlignOf t.ttype
+ | TArray (t, _, _, _) -> bytesAlignOf t
+ | TPtr _ | TBuiltin_va_list _ ->
+ theMachine.theMachine.alignof_ptr
+
+ (* For composite types get the maximum alignment of any field inside *)
+ | TComp (c, _, _) ->
+ (* On GCC the zero-width fields do not contribute to the alignment. On
+ * MSVC only those zero-width that _do_ appear after other
+ * bitfields contribute to the alignment. So we drop those that
+ * do not occur after other bitfields *)
+ (* This is not correct for Diab-C compiler. *)
+ let rec dropZeros (afterbitfield: bool) = function
+ | f :: rest when f.fbitfield = Some 0 && not afterbitfield ->
+ dropZeros afterbitfield rest
+ | f :: rest -> f :: dropZeros (f.fbitfield <> None) rest
+ | [] -> []
+ in
+ let fields = dropZeros false c.cfields in
+ List.fold_left
+ (fun sofar f ->
+ (* Bitfields with zero width do not contribute to the alignment in
+ * GCC *)
+ if not (msvcMode ()) && f.fbitfield = Some 0 then sofar else
+ max sofar (alignOfField f)) 1 fields
+ (* These are some error cases *)
+ | TFun _ when not (msvcMode ()) ->
+ theMachine.theMachine.alignof_fun
+ | TFun _ as t -> raise (SizeOfError ("Undefined sizeof on a function.", t))
+ | TVoid _ as t -> raise (SizeOfError ("Undefined sizeof(void).", t))
in
process_aligned_attribute ~may_reduce:false
(fun fmt -> !pp_typ_ref fmt t)
@@ -5020,10 +5020,10 @@ let rec bytesAlignOf t =
to specifying the packed attribute on each of the structure or union members."
Note that is not the case for the aligned attribute, which behaves
differently when put into a struct, or in each of its fields.
- *)
+*)
and alignOfField (fi: fieldinfo) =
- let fieldIsPacked = hasAttribute "packed" fi.fattr
- || hasAttribute "packed" fi.fcomp.cattr
+ let fieldIsPacked = hasAttribute "packed" fi.fattr
+ || hasAttribute "packed" fi.fcomp.cattr
in
if fieldIsPacked then begin
if hasAttribute "aligned" fi.fattr then
@@ -5042,7 +5042,7 @@ and alignOfField (fi: fieldinfo) =
(fun fmt -> Format.fprintf fmt "field %s" fi.fname)
fi.fattr
(fun () -> bytesAlignOf fi.ftype)
-
+
and intOfAttrparam (a:attrparam) : int option =
let rec doit a : int =
match a with
@@ -5070,7 +5070,7 @@ and intOfAttrparam (a:attrparam) : int option =
| _ -> raise (SizeOfError ("Cannot convert an attribute to int.", voidType))
in
(* Use ignoreAlignmentAttrs here to prevent stack overflow if a buggy
- program does something like
+ program does something like
struct s {...} __attribute__((aligned(sizeof(struct s))))
This is too conservative, but it's often enough.
*)
@@ -5091,27 +5091,27 @@ and process_aligned_attribute (pp:Format.formatter->unit) ~may_reduce attrs defa
"The aligned attribute can only increase alignment.
Alignment can be decreased by specifying the packed attribute." *)
match filterAttributes "aligned" attrs with
- | [] ->
- (* no __aligned__ attribute, so get the default alignment *)
- default_align ()
- | _ when !ignoreAlignmentAttrs ->
+ | [] ->
+ (* no __aligned__ attribute, so get the default alignment *)
+ default_align ()
+ | _ when !ignoreAlignmentAttrs ->
Kernel.warning ~current:true "ignoring recursive align attributes on %t"
pp;
default_align ()
| (Attr(_, [a]) as at)::rest -> begin
- if rest <> [] then
- Kernel.warning ~current:true "ignoring duplicate align attributes on %t"
- pp;
- match intOfAttrparam a with
- | Some n -> if may_reduce then n else max n (default_align ())
- | None ->
- Kernel.warning ~current:true "alignment attribute \"%a\" not understood on %t"
- !pp_attribute_ref at pp;
- default_align ()
- end
+ if rest <> [] then
+ Kernel.warning ~current:true "ignoring duplicate align attributes on %t"
+ pp;
+ match intOfAttrparam a with
+ | Some n -> if may_reduce then n else max n (default_align ())
+ | None ->
+ Kernel.warning ~current:true "alignment attribute \"%a\" not understood on %t"
+ !pp_attribute_ref at pp;
+ default_align ()
+ end
| Attr(_, [])::rest ->
- (* aligned with no arg means a power of two at least as large as
- any alignment on the system.*)
+ (* aligned with no arg means a power of two at least as large as
+ any alignment on the system.*)
if rest <> [] then
Kernel.warning ~current:true "ignoring duplicate align attributes on %t"
pp;
@@ -5121,269 +5121,269 @@ and process_aligned_attribute (pp:Format.formatter->unit) ~may_reduce attrs defa
!pp_attribute_ref at pp;
default_align ()
- (* Computation of the offset of the field [fi], given the information [sofar]
- computed for the previous fields. [last] indicates that we are considering
- the last field of the struct. Set to [false] by default for unions. *)
- and offsetOfFieldAcc ?(last=false) ~(fi: fieldinfo) ~(sofar: offsetAcc) : offsetAcc =
- if msvcMode () then offsetOfFieldAcc_MSVC last fi sofar
- else offsetOfFieldAcc_GCC last fi sofar
+(* Computation of the offset of the field [fi], given the information [sofar]
+ computed for the previous fields. [last] indicates that we are considering
+ the last field of the struct. Set to [false] by default for unions. *)
+and offsetOfFieldAcc ?(last=false) ~(fi: fieldinfo) ~(sofar: offsetAcc) : offsetAcc =
+ if msvcMode () then offsetOfFieldAcc_MSVC last fi sofar
+ else offsetOfFieldAcc_GCC last fi sofar
(* GCC version *)
(* Does not use the sofar.oaPrevBitPack *)
and offsetOfFieldAcc_GCC last (fi: fieldinfo) (sofar: offsetAcc) : offsetAcc =
- (* field type *)
- let ftype = unrollType fi.ftype in
- let ftypeAlign = 8 * alignOfField fi in
- let ftypeBits = (if last then bitsSizeOfEmptyArray else bitsSizeOf) ftype in
- match ftype, fi.fbitfield with
- (* A width of 0 means that we must end the current packing. It seems that
- * GCC pads only up to the alignment boundary for the type of this field.
- * *)
- | _, Some 0 ->
- let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in
- { oaFirstFree = firstFree;
- oaLastFieldStart = firstFree;
- oaLastFieldWidth = 0;
- oaPrevBitPack = None }
-
- (* A bitfield cannot span more alignment boundaries of its type than the
- * type itself *)
- | _, Some wdthis
- when (sofar.oaFirstFree + wdthis + ftypeAlign - 1) / ftypeAlign
- - sofar.oaFirstFree / ftypeAlign > ftypeBits / ftypeAlign ->
- let start = addTrailing sofar.oaFirstFree ftypeAlign in
- { oaFirstFree = start + wdthis;
- oaLastFieldStart = start;
- oaLastFieldWidth = wdthis;
- oaPrevBitPack = None }
-
- (* Try a simple method. Just put the field down *)
- | _, Some wdthis ->
- { oaFirstFree = sofar.oaFirstFree + wdthis;
- oaLastFieldStart = sofar.oaFirstFree;
- oaLastFieldWidth = wdthis;
- oaPrevBitPack = None
- }
-
- (* Non-bitfield *)
- | _, None ->
- (* Align this field *)
- let newStart = addTrailing sofar.oaFirstFree ftypeAlign in
- { oaFirstFree = newStart + ftypeBits;
- oaLastFieldStart = newStart;
- oaLastFieldWidth = ftypeBits;
- oaPrevBitPack = None;
- }
-
- (* MSVC version *)
- and offsetOfFieldAcc_MSVC last (fi: fieldinfo)
- (sofar: offsetAcc) : offsetAcc =
- (* field type *)
- let ftype = unrollType fi.ftype in
- let ftypeAlign = 8 * alignOfField fi in
- let ftypeBits = (if last then bitsSizeOfEmptyArray else bitsSizeOf) ftype in
- match ftype, fi.fbitfield, sofar.oaPrevBitPack with
- (* Ignore zero-width bitfields that come after non-bitfields *)
- | TInt (_ikthis, _), Some 0, None ->
- let firstFree = sofar.oaFirstFree in
- { oaFirstFree = firstFree;
- oaLastFieldStart = firstFree;
- oaLastFieldWidth = 0;
- oaPrevBitPack = None }
-
- (* If we are in a bitpack and we see a bitfield for a type with the
- * different width than the pack, then we finish the pack and retry *)
- | _, Some _, Some (packstart, _, wdpack) when wdpack != ftypeBits ->
- let firstFree =
- if sofar.oaFirstFree = packstart then packstart else
- packstart + wdpack
- in
- offsetOfFieldAcc_MSVC last fi
- { oaFirstFree = addTrailing firstFree ftypeAlign;
- oaLastFieldStart = sofar.oaLastFieldStart;
- oaLastFieldWidth = sofar.oaLastFieldWidth;
- oaPrevBitPack = None }
-
- (* A width of 0 means that we must end the current packing. *)
- | TInt (ikthis, _), Some 0, Some (packstart, _, wdpack) ->
- let firstFree =
- if sofar.oaFirstFree = packstart then packstart else
- packstart + wdpack
- in
- let firstFree = addTrailing firstFree ftypeAlign in
- { oaFirstFree = firstFree;
- oaLastFieldStart = firstFree;
- oaLastFieldWidth = 0;
- oaPrevBitPack = Some (firstFree, ikthis, ftypeBits) }
-
- (* Check for a bitfield that fits in the current pack after some other
- * bitfields *)
- | TInt(_ikthis, _), Some wdthis, Some (packstart, _ikprev, wdpack)
- when packstart + wdpack >= sofar.oaFirstFree + wdthis ->
- { oaFirstFree = sofar.oaFirstFree + wdthis;
- oaLastFieldStart = sofar.oaFirstFree;
- oaLastFieldWidth = wdthis;
- oaPrevBitPack = sofar.oaPrevBitPack
- }
-
-
- | _, _, Some (packstart, _, wdpack) -> (* Finish up the bitfield pack and
- * restart. *)
- let firstFree =
- if sofar.oaFirstFree = packstart then packstart else
- packstart + wdpack
- in
- offsetOfFieldAcc_MSVC last fi
- { oaFirstFree = addTrailing firstFree ftypeAlign;
- oaLastFieldStart = sofar.oaLastFieldStart;
- oaLastFieldWidth = sofar.oaLastFieldWidth;
- oaPrevBitPack = None }
-
- (* No active bitfield pack. But we are seeing a bitfield. *)
- | TInt(ikthis, _), Some wdthis, None ->
- let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in
- { oaFirstFree = firstFree + wdthis;
- oaLastFieldStart = firstFree;
- oaLastFieldWidth = wdthis;
- oaPrevBitPack = Some (firstFree, ikthis, ftypeBits); }
-
- (* No active bitfield pack. Non-bitfield *)
- | _, None, None ->
- (* Align this field *)
- let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in
- { oaFirstFree = firstFree + ftypeBits;
- oaLastFieldStart = firstFree;
- oaLastFieldWidth = ftypeBits;
- oaPrevBitPack = None;
- }
-
- | _, Some _, None -> Kernel.fatal ~current:true "offsetAcc"
-
- (** This is a special version of [bitsSizeOf] that accepts empty arrays.
- Currently, we only use it for flexible array members *)
- and bitsSizeOfEmptyArray typ =
+ (* field type *)
+ let ftype = unrollType fi.ftype in
+ let ftypeAlign = 8 * alignOfField fi in
+ let ftypeBits = (if last then bitsSizeOfEmptyArray else bitsSizeOf) ftype in
+ match ftype, fi.fbitfield with
+ (* A width of 0 means that we must end the current packing. It seems that
+ * GCC pads only up to the alignment boundary for the type of this field.
+ * *)
+ | _, Some 0 ->
+ let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in
+ { oaFirstFree = firstFree;
+ oaLastFieldStart = firstFree;
+ oaLastFieldWidth = 0;
+ oaPrevBitPack = None }
+
+ (* A bitfield cannot span more alignment boundaries of its type than the
+ * type itself *)
+ | _, Some wdthis
+ when (sofar.oaFirstFree + wdthis + ftypeAlign - 1) / ftypeAlign
+ - sofar.oaFirstFree / ftypeAlign > ftypeBits / ftypeAlign ->
+ let start = addTrailing sofar.oaFirstFree ftypeAlign in
+ { oaFirstFree = start + wdthis;
+ oaLastFieldStart = start;
+ oaLastFieldWidth = wdthis;
+ oaPrevBitPack = None }
+
+ (* Try a simple method. Just put the field down *)
+ | _, Some wdthis ->
+ { oaFirstFree = sofar.oaFirstFree + wdthis;
+ oaLastFieldStart = sofar.oaFirstFree;
+ oaLastFieldWidth = wdthis;
+ oaPrevBitPack = None
+ }
+
+ (* Non-bitfield *)
+ | _, None ->
+ (* Align this field *)
+ let newStart = addTrailing sofar.oaFirstFree ftypeAlign in
+ { oaFirstFree = newStart + ftypeBits;
+ oaLastFieldStart = newStart;
+ oaLastFieldWidth = ftypeBits;
+ oaPrevBitPack = None;
+ }
+
+(* MSVC version *)
+and offsetOfFieldAcc_MSVC last (fi: fieldinfo)
+ (sofar: offsetAcc) : offsetAcc =
+ (* field type *)
+ let ftype = unrollType fi.ftype in
+ let ftypeAlign = 8 * alignOfField fi in
+ let ftypeBits = (if last then bitsSizeOfEmptyArray else bitsSizeOf) ftype in
+ match ftype, fi.fbitfield, sofar.oaPrevBitPack with
+ (* Ignore zero-width bitfields that come after non-bitfields *)
+ | TInt (_ikthis, _), Some 0, None ->
+ let firstFree = sofar.oaFirstFree in
+ { oaFirstFree = firstFree;
+ oaLastFieldStart = firstFree;
+ oaLastFieldWidth = 0;
+ oaPrevBitPack = None }
+
+ (* If we are in a bitpack and we see a bitfield for a type with the
+ * different width than the pack, then we finish the pack and retry *)
+ | _, Some _, Some (packstart, _, wdpack) when wdpack != ftypeBits ->
+ let firstFree =
+ if sofar.oaFirstFree = packstart then packstart else
+ packstart + wdpack
+ in
+ offsetOfFieldAcc_MSVC last fi
+ { oaFirstFree = addTrailing firstFree ftypeAlign;
+ oaLastFieldStart = sofar.oaLastFieldStart;
+ oaLastFieldWidth = sofar.oaLastFieldWidth;
+ oaPrevBitPack = None }
+
+ (* A width of 0 means that we must end the current packing. *)
+ | TInt (ikthis, _), Some 0, Some (packstart, _, wdpack) ->
+ let firstFree =
+ if sofar.oaFirstFree = packstart then packstart else
+ packstart + wdpack
+ in
+ let firstFree = addTrailing firstFree ftypeAlign in
+ { oaFirstFree = firstFree;
+ oaLastFieldStart = firstFree;
+ oaLastFieldWidth = 0;
+ oaPrevBitPack = Some (firstFree, ikthis, ftypeBits) }
+
+ (* Check for a bitfield that fits in the current pack after some other
+ * bitfields *)
+ | TInt(_ikthis, _), Some wdthis, Some (packstart, _ikprev, wdpack)
+ when packstart + wdpack >= sofar.oaFirstFree + wdthis ->
+ { oaFirstFree = sofar.oaFirstFree + wdthis;
+ oaLastFieldStart = sofar.oaFirstFree;
+ oaLastFieldWidth = wdthis;
+ oaPrevBitPack = sofar.oaPrevBitPack
+ }
+
+
+ | _, _, Some (packstart, _, wdpack) -> (* Finish up the bitfield pack and
+ * restart. *)
+ let firstFree =
+ if sofar.oaFirstFree = packstart then packstart else
+ packstart + wdpack
+ in
+ offsetOfFieldAcc_MSVC last fi
+ { oaFirstFree = addTrailing firstFree ftypeAlign;
+ oaLastFieldStart = sofar.oaLastFieldStart;
+ oaLastFieldWidth = sofar.oaLastFieldWidth;
+ oaPrevBitPack = None }
+
+ (* No active bitfield pack. But we are seeing a bitfield. *)
+ | TInt(ikthis, _), Some wdthis, None ->
+ let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in
+ { oaFirstFree = firstFree + wdthis;
+ oaLastFieldStart = firstFree;
+ oaLastFieldWidth = wdthis;
+ oaPrevBitPack = Some (firstFree, ikthis, ftypeBits); }
+
+ (* No active bitfield pack. Non-bitfield *)
+ | _, None, None ->
+ (* Align this field *)
+ let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in
+ { oaFirstFree = firstFree + ftypeBits;
+ oaLastFieldStart = firstFree;
+ oaLastFieldWidth = ftypeBits;
+ oaPrevBitPack = None;
+ }
+
+ | _, Some _, None -> Kernel.fatal ~current:true "offsetAcc"
+
+(** This is a special version of [bitsSizeOf] that accepts empty arrays.
+ Currently, we only use it for flexible array members *)
+and bitsSizeOfEmptyArray typ =
match unrollType typ with
| TArray (_, None, _, _) -> 0
| TArray (_, Some e, _, _) -> begin
- match constFoldToInt e with
- | Some i when Integer.is_zero i ->
- (* Used for GCC extension of non-C99 flexible array members.
- Note that Cabs2cil no longer rewrites top-level zero-sized arrays,
- so this can also happen in such cases. *)
- 0
- | _ -> bitsSizeOf typ
- end
+ match constFoldToInt e with
+ | Some i when Integer.is_zero i ->
+ (* Used for GCC extension of non-C99 flexible array members.
+ Note that Cabs2cil no longer rewrites top-level zero-sized arrays,
+ so this can also happen in such cases. *)
+ 0
+ | _ -> bitsSizeOf typ
+ end
| _ -> bitsSizeOf typ
- (* The size of a type, in bits. If struct or array then trailing padding is
- * added *)
- and bitsSizeOf t =
- match t with
- | TInt (ik,_) -> 8 * (bytesSizeOfInt ik)
- | TFloat(FDouble, _) -> 8 * theMachine.theMachine.sizeof_double
- | TFloat(FLongDouble, _) ->
- 8 * theMachine.theMachine.sizeof_longdouble
- | TFloat _ -> 8 * theMachine.theMachine.sizeof_float
- | TEnum (ei,_) -> bitsSizeOf (TInt(ei.ekind, []))
- | TPtr _ -> 8 * theMachine.theMachine.sizeof_ptr
- | TBuiltin_va_list _ -> 8 * theMachine.theMachine.sizeof_ptr
- | TNamed (t, _) -> bitsSizeOf t.ttype
- | TComp (comp, scache, _) when comp.cfields == [] ->
- find_size_in_cache
- scache
- (fun () -> begin
- (* sizeof() empty structs/arrays is only allowed on GCC/MSVC *)
- if not comp.cdefined && not (gccMode () || msvcMode ()) then begin
- raise
- (SizeOfError
- (Format.sprintf "abstract type '%s'" (compFullName comp), t))
- end else
- 0
- end)
-
- | TComp (comp, scache, _) when comp.cstruct -> (* Struct *)
- find_size_in_cache
- scache
- (fun () ->
- (* Go and get the last offset *)
- let startAcc =
- { oaFirstFree = 0;
- oaLastFieldStart = 0;
- oaLastFieldWidth = 0;
- oaPrevBitPack = None;
- } in
- let lastoff =
- fold_struct_fields
- (fun ~last acc fi -> offsetOfFieldAcc ~last ~fi ~sofar:acc)
- startAcc comp.cfields
- in
- if msvcMode () && lastoff.oaFirstFree = 0 && comp.cfields <> []
- then
- (* On MSVC if we have just a zero-width bitfields then the length
- * is 32 and is not padded *)
- 32
- else
- addTrailing lastoff.oaFirstFree (8 * bytesAlignOf t))
-
- | TComp (comp, scache, _) -> (* Union *)
- find_size_in_cache
- scache
- (fun () ->
- (* Get the maximum of all fields *)
- let startAcc =
- { oaFirstFree = 0;
- oaLastFieldStart = 0;
- oaLastFieldWidth = 0;
- oaPrevBitPack = None;
- } in
- let max =
- List.fold_left (fun acc fi ->
- let lastoff = offsetOfFieldAcc ?last:None ~fi ~sofar:startAcc in
- if lastoff.oaFirstFree > acc then
- lastoff.oaFirstFree else acc) 0 comp.cfields in
- (* Add trailing by simulating adding an extra field *)
- addTrailing max (8 * bytesAlignOf t))
-
- | TArray(bt, Some len, scache, _) ->
- find_size_in_cache
- scache
- (fun () ->
- begin
- match (constFold true len).enode with
- Const(CInt64(l,_,_)) ->
- let sz = Integer.mul (Integer.of_int (bitsSizeOf bt)) l in
- let sz' =
- try
- Integer.to_int sz
- with Z.Overflow ->
- raise
- (SizeOfError
- ("Array is so long that its size can't be "
- ^"represented with an OCaml int.", t))
-
- in
- sz' (*WAS: addTrailing sz' (8 * bytesAlignOf t)*)
- | _ -> raise (SizeOfError ("Array with non-constant length.", t))
- end)
- | TVoid _ -> 8 * theMachine.theMachine.sizeof_void
- | TFun _ ->
- if theMachine.theMachine.sizeof_fun >= 0 then
- 8 * theMachine.theMachine.sizeof_fun
- else
- raise (SizeOfError ("Undefined sizeof on a function.", t))
-
- | TArray (_, None, _, _) ->
- raise (SizeOfError ("Size of array without number of elements.", t))
-
- (* Iterator on the fields of a structure, with additional information about
- having reached the last field (for flexible member arrays) *)
- and fold_struct_fields f acc l = match l with
- | [] -> acc
- | [fi_last] -> f ~last:true acc fi_last
- | fi :: (_ :: _ as q) -> fold_struct_fields f (f ~last:false acc fi) q
-
- and addTrailing nrbits roundto =
- (nrbits + roundto - 1) land (lnot (roundto - 1))
+(* The size of a type, in bits. If struct or array then trailing padding is
+ * added *)
+and bitsSizeOf t =
+ match t with
+ | TInt (ik,_) -> 8 * (bytesSizeOfInt ik)
+ | TFloat(FDouble, _) -> 8 * theMachine.theMachine.sizeof_double
+ | TFloat(FLongDouble, _) ->
+ 8 * theMachine.theMachine.sizeof_longdouble
+ | TFloat _ -> 8 * theMachine.theMachine.sizeof_float
+ | TEnum (ei,_) -> bitsSizeOf (TInt(ei.ekind, []))
+ | TPtr _ -> 8 * theMachine.theMachine.sizeof_ptr
+ | TBuiltin_va_list _ -> 8 * theMachine.theMachine.sizeof_ptr
+ | TNamed (t, _) -> bitsSizeOf t.ttype
+ | TComp (comp, scache, _) when comp.cfields == [] ->
+ find_size_in_cache
+ scache
+ (fun () -> begin
+ (* sizeof() empty structs/arrays is only allowed on GCC/MSVC *)
+ if not comp.cdefined && not (gccMode () || msvcMode ()) then begin
+ raise
+ (SizeOfError
+ (Format.sprintf "abstract type '%s'" (compFullName comp), t))
+ end else
+ 0
+ end)
+
+ | TComp (comp, scache, _) when comp.cstruct -> (* Struct *)
+ find_size_in_cache
+ scache
+ (fun () ->
+ (* Go and get the last offset *)
+ let startAcc =
+ { oaFirstFree = 0;
+ oaLastFieldStart = 0;
+ oaLastFieldWidth = 0;
+ oaPrevBitPack = None;
+ } in
+ let lastoff =
+ fold_struct_fields
+ (fun ~last acc fi -> offsetOfFieldAcc ~last ~fi ~sofar:acc)
+ startAcc comp.cfields
+ in
+ if msvcMode () && lastoff.oaFirstFree = 0 && comp.cfields <> []
+ then
+ (* On MSVC if we have just a zero-width bitfields then the length
+ * is 32 and is not padded *)
+ 32
+ else
+ addTrailing lastoff.oaFirstFree (8 * bytesAlignOf t))
+
+ | TComp (comp, scache, _) -> (* Union *)
+ find_size_in_cache
+ scache
+ (fun () ->
+ (* Get the maximum of all fields *)
+ let startAcc =
+ { oaFirstFree = 0;
+ oaLastFieldStart = 0;
+ oaLastFieldWidth = 0;
+ oaPrevBitPack = None;
+ } in
+ let max =
+ List.fold_left (fun acc fi ->
+ let lastoff = offsetOfFieldAcc ?last:None ~fi ~sofar:startAcc in
+ if lastoff.oaFirstFree > acc then
+ lastoff.oaFirstFree else acc) 0 comp.cfields in
+ (* Add trailing by simulating adding an extra field *)
+ addTrailing max (8 * bytesAlignOf t))
+
+ | TArray(bt, Some len, scache, _) ->
+ find_size_in_cache
+ scache
+ (fun () ->
+ begin
+ match (constFold true len).enode with
+ Const(CInt64(l,_,_)) ->
+ let sz = Integer.mul (Integer.of_int (bitsSizeOf bt)) l in
+ let sz' =
+ try
+ Integer.to_int sz
+ with Z.Overflow ->
+ raise
+ (SizeOfError
+ ("Array is so long that its size can't be "
+ ^"represented with an OCaml int.", t))
+
+ in
+ sz' (*WAS: addTrailing sz' (8 * bytesAlignOf t)*)
+ | _ -> raise (SizeOfError ("Array with non-constant length.", t))
+ end)
+ | TVoid _ -> 8 * theMachine.theMachine.sizeof_void
+ | TFun _ ->
+ if theMachine.theMachine.sizeof_fun >= 0 then
+ 8 * theMachine.theMachine.sizeof_fun
+ else
+ raise (SizeOfError ("Undefined sizeof on a function.", t))
+
+ | TArray (_, None, _, _) ->
+ raise (SizeOfError ("Size of array without number of elements.", t))
+
+(* Iterator on the fields of a structure, with additional information about
+ having reached the last field (for flexible member arrays) *)
+and fold_struct_fields f acc l = match l with
+ | [] -> acc
+ | [fi_last] -> f ~last:true acc fi_last
+ | fi :: (_ :: _ as q) -> fold_struct_fields f (f ~last:false acc fi) q
+
+and addTrailing nrbits roundto =
+ (nrbits + roundto - 1) land (lnot (roundto - 1))
and bytesSizeOf t = (bitsSizeOf t) lsr 3
@@ -5392,54 +5392,54 @@ and sizeOf ~loc t =
integer ~loc ((bitsSizeOf t) lsr 3)
with SizeOfError _ -> new_exp ~loc (SizeOf(t))
- and bitsOffset (baset: typ) (off: offset) : int * int =
- let rec loopOff (baset: typ) (width: int) (start: int) = function
- NoOffset -> start, width
- | Index(e, off) -> begin
- let ei =
- match constFoldToInt e with
- | Some i -> Integer.to_int i
- | None -> raise (SizeOfError ("Index is not constant", baset))
- in
- let bt = typeOf_array_elem baset in
- let bitsbt = bitsSizeOf bt in
- loopOff bt bitsbt (start + ei * bitsbt) off
- end
- | Field(f, off) when not f.fcomp.cstruct (* union *) ->
- if check_invariants then
- assert (match unrollType baset with
- | TComp (ci, _, _) -> ci == f.fcomp
- | _ -> false);
- (* All union fields start at offset 0 *)
- loopOff f.ftype (bitsSizeOf f.ftype) start off
-
- | Field(f, off) (* struct *) ->
- if check_invariants then
- assert (match unrollType baset with
- | TComp (ci, _, _) -> ci == f.fcomp
- | _ -> false);
- if f.foffset_in_bits = None then begin
- let aux ~last acc fi =
- let acc' = offsetOfFieldAcc ~last ~fi ~sofar:acc in
- fi.fsize_in_bits <- Some acc'.oaLastFieldWidth;
- fi.foffset_in_bits <- Some acc'.oaLastFieldStart;
- acc'
- in
- ignore (
- fold_struct_fields aux
- { oaFirstFree = 0;
- oaLastFieldStart = 0;
- oaLastFieldWidth = 0;
- oaPrevBitPack = None }
- f.fcomp.cfields
- );
- end;
- let offsbits, size =
- Extlib.the f.foffset_in_bits, Extlib.the f.fsize_in_bits
- in
- loopOff f.ftype size (start + offsbits) off
- in
- loopOff baset (bitsSizeOf baset) 0 off
+and bitsOffset (baset: typ) (off: offset) : int * int =
+ let rec loopOff (baset: typ) (width: int) (start: int) = function
+ NoOffset -> start, width
+ | Index(e, off) -> begin
+ let ei =
+ match constFoldToInt e with
+ | Some i -> Integer.to_int i
+ | None -> raise (SizeOfError ("Index is not constant", baset))
+ in
+ let bt = typeOf_array_elem baset in
+ let bitsbt = bitsSizeOf bt in
+ loopOff bt bitsbt (start + ei * bitsbt) off
+ end
+ | Field(f, off) when not f.fcomp.cstruct (* union *) ->
+ if check_invariants then
+ assert (match unrollType baset with
+ | TComp (ci, _, _) -> ci == f.fcomp
+ | _ -> false);
+ (* All union fields start at offset 0 *)
+ loopOff f.ftype (bitsSizeOf f.ftype) start off
+
+ | Field(f, off) (* struct *) ->
+ if check_invariants then
+ assert (match unrollType baset with
+ | TComp (ci, _, _) -> ci == f.fcomp
+ | _ -> false);
+ if f.foffset_in_bits = None then begin
+ let aux ~last acc fi =
+ let acc' = offsetOfFieldAcc ~last ~fi ~sofar:acc in
+ fi.fsize_in_bits <- Some acc'.oaLastFieldWidth;
+ fi.foffset_in_bits <- Some acc'.oaLastFieldStart;
+ acc'
+ in
+ ignore (
+ fold_struct_fields aux
+ { oaFirstFree = 0;
+ oaLastFieldStart = 0;
+ oaLastFieldWidth = 0;
+ oaPrevBitPack = None }
+ f.fcomp.cfields
+ );
+ end;
+ let offsbits, size =
+ Extlib.the f.foffset_in_bits, Extlib.the f.fsize_in_bits
+ in
+ loopOff f.ftype size (start + offsbits) off
+ in
+ loopOff baset (bitsSizeOf baset) 0 off
(** Do constant folding on an expression. If the first argument is true then
will also compute compiler-dependent expressions such as sizeof.
@@ -5463,17 +5463,17 @@ and constFold (machdep: bool) (e: exp) : exp =
Const(CInt64(i,_ik,repr)) -> begin
match unop with
Neg ->
- let repr = Extlib.opt_map (fun s -> "-" ^ s) repr in
- kinteger64 ~loc ?repr ~kind:tk (Integer.neg i)
+ let repr = Extlib.opt_map (fun s -> "-" ^ s) repr in
+ kinteger64 ~loc ?repr ~kind:tk (Integer.neg i)
| BNot -> kinteger64 ~loc ~kind:tk (Integer.lognot i)
- | LNot ->
+ | LNot ->
if Integer.equal i Integer.zero then one ~loc
else zero ~loc
end
| _ -> if e1 == e1c then e else new_exp ~loc (UnOp(unop, e1c, tres))
with Not_found -> e
end
- (* Characters are integers *)
+ (* Characters are integers *)
| Const(CChr c) -> new_exp ~loc (Const(charConstToIntConstant c))
| Const(CEnum {eival = v}) -> constFold machdep v
| Const (CReal _ | CWStr _ | CStr _ | CInt64 _) -> e (* a constant *)
@@ -5484,42 +5484,42 @@ and constFold (machdep: bool) (e: exp) : exp =
with SizeOfError _ -> e
end
| SizeOfE e when machdep -> constFold machdep
- (new_exp ~loc:e.eloc (SizeOf (typeOf e)))
+ (new_exp ~loc:e.eloc (SizeOf (typeOf e)))
| SizeOfStr s when machdep ->
- kinteger ~loc theMachine.kindOfSizeOf (1 + String.length s)
+ kinteger ~loc theMachine.kindOfSizeOf (1 + String.length s)
| AlignOf t when machdep ->
- kinteger ~loc theMachine.kindOfSizeOf (bytesAlignOf t)
+ kinteger ~loc theMachine.kindOfSizeOf (bytesAlignOf t)
| AlignOfE e when machdep -> begin
(* The alignment of an expression is not always the alignment of its
* type. I know that for strings this is not true *)
match e.enode with
| Const (CStr _) when not (msvcMode ()) ->
- kinteger ~loc
- theMachine.kindOfSizeOf theMachine.theMachine.alignof_str
- (* For an array, it is the alignment of the array ! *)
+ kinteger ~loc
+ theMachine.kindOfSizeOf theMachine.theMachine.alignof_str
+ (* For an array, it is the alignment of the array ! *)
| _ -> constFold machdep (new_exp ~loc:e.eloc (AlignOf (typeOf e)))
end
- | AlignOfE _ | AlignOf _ | SizeOfStr _ | SizeOfE _ | SizeOf _ ->
- e (* Depends on machdep. Do not evaluate in this case*)
-
- (* Special case to handle the C macro 'offsetof' *)
- | CastE(it,
- { enode = AddrOf (Mem ({enode = CastE(TPtr(bt, _), z)}), off)})
- when machdep && isZero z -> begin
- try
- let start, _width = bitsOffset bt off in
- if start mod 8 <> 0 then
- Kernel.error ~current:true "Using offset of bitfield" ;
- constFold machdep
- (new_exp ~loc (CastE(it, (integer ~loc (start / 8)))))
- with SizeOfError _ -> e
- end
+ | AlignOfE _ | AlignOf _ | SizeOfStr _ | SizeOfE _ | SizeOf _ ->
+ e (* Depends on machdep. Do not evaluate in this case*)
+
+ (* Special case to handle the C macro 'offsetof' *)
+ | CastE(it,
+ { enode = AddrOf (Mem ({enode = CastE(TPtr(bt, _), z)}), off)})
+ when machdep && isZero z -> begin
+ try
+ let start, _width = bitsOffset bt off in
+ if start mod 8 <> 0 then
+ Kernel.error ~current:true "Using offset of bitfield" ;
+ constFold machdep
+ (new_exp ~loc (CastE(it, (integer ~loc (start / 8)))))
+ with SizeOfError _ -> e
+ end
| CastE (t, e) -> begin
- if debugConstFold then
- Kernel.debug "ConstFold CAST to to %a@." !pp_typ_ref t ;
- let e = constFold machdep e in
- match e.enode, unrollType t with
+ if debugConstFold then
+ Kernel.debug "ConstFold CAST to to %a@." !pp_typ_ref t ;
+ let e = constFold machdep e in
+ match e.enode, unrollType t with
| Const(CInt64(i,_k,_)),(TInt(nk,a)|TEnum({ekind = nk},a)) when a = [] ->
begin
(* If the cast has attributes, leave it alone. *)
@@ -5549,19 +5549,19 @@ and constFold (machdep: bool) (e: exp) : exp =
| StartOf lv -> new_exp ~loc (StartOf (constFoldLval machdep lv))
| Info _ -> e (* Deprecated constructor *)
- and constFoldLval machdep (host,offset) =
- let newhost =
- match host with
- | Mem e -> Mem (constFold machdep e)
- | Var _ -> host
- in
- let rec constFoldOffset machdep = function
- | NoOffset -> NoOffset
- | Field (fi,offset) -> Field (fi, constFoldOffset machdep offset)
- | Index (exp,offset) -> Index (constFold machdep exp,
- constFoldOffset machdep offset)
- in
- (newhost, constFoldOffset machdep offset)
+and constFoldLval machdep (host,offset) =
+ let newhost =
+ match host with
+ | Mem e -> Mem (constFold machdep e)
+ | Var _ -> host
+ in
+ let rec constFoldOffset machdep = function
+ | NoOffset -> NoOffset
+ | Field (fi,offset) -> Field (fi, constFoldOffset machdep offset)
+ | Index (exp,offset) -> Index (constFold machdep exp,
+ constFoldOffset machdep offset)
+ in
+ (newhost, constFoldOffset machdep offset)
and constFoldBinOp ~loc (machdep: bool) bop e1 e2 tres =
let e1' = constFold machdep e1 in
@@ -5571,22 +5571,22 @@ and constFoldBinOp ~loc (machdep: bool) bop e1 e2 tres =
let rec mkInt e =
let loc = e.eloc in
match e.enode with
- | Const(CChr c) -> new_exp ~loc (Const(charConstToIntConstant c))
- | Const(CEnum {eival = v}) -> mkInt v
- | CastE(TInt (ik, ta), e) -> begin
- let exp = mkInt e in
- match exp.enode with
- Const(CInt64(i, _, _)) ->
- kinteger64 ~loc ~kind:ik i
- | _ -> {exp with enode = CastE(TInt(ik, ta), exp)}
- end
- | _ -> e
+ | Const(CChr c) -> new_exp ~loc (Const(charConstToIntConstant c))
+ | Const(CEnum {eival = v}) -> mkInt v
+ | CastE(TInt (ik, ta), e) -> begin
+ let exp = mkInt e in
+ match exp.enode with
+ Const(CInt64(i, _, _)) ->
+ kinteger64 ~loc ~kind:ik i
+ | _ -> {exp with enode = CastE(TInt(ik, ta), exp)}
+ end
+ | _ -> e
in
let tk =
match unrollTypeSkel tres with
- TInt(ik, _) -> ik
- | TEnum (ei,_) -> ei.ekind
- | _ -> Kernel.fatal ~current:true "constFoldBinOp"
+ TInt(ik, _) -> ik
+ | TEnum (ei,_) -> ei.ekind
+ | _ -> Kernel.fatal ~current:true "constFoldBinOp"
in
(* See if the result is unsigned *)
let isunsigned typ = not (isSigned typ) in
@@ -5606,96 +5606,96 @@ and constFoldBinOp ~loc (machdep: bool) bop e1 e2 tres =
let e1'' = mkInt e1' in
let e2'' = mkInt e2' in
match bop, e1''.enode, e2''.enode with
- | PlusA, Const(CInt64(z,_,_)), _
+ | PlusA, Const(CInt64(z,_,_)), _
when Integer.equal z Integer.zero -> e2''
- | PlusA, _, Const(CInt64(z,_,_))
+ | PlusA, _, Const(CInt64(z,_,_))
when Integer.equal z Integer.zero -> e1''
- | PlusPI, _, Const(CInt64(z,_,_))
+ | PlusPI, _, Const(CInt64(z,_,_))
when Integer.equal z Integer.zero -> e1''
- | IndexPI, _, Const(CInt64(z,_,_))
+ | IndexPI, _, Const(CInt64(z,_,_))
when Integer.equal z Integer.zero -> e1''
- | MinusPI, _, Const(CInt64(z,_,_))
+ | MinusPI, _, Const(CInt64(z,_,_))
when Integer.equal z Integer.zero -> e1''
| PlusA, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
- kinteger64 ~loc ~kind:tk (Integer.add i1 i2)
+ kinteger64 ~loc ~kind:tk (Integer.add i1 i2)
| MinusA, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_))
- when ik1 = ik2 ->
- kinteger64 ~loc ~kind:tk (Integer.sub i1 i2)
+ when ik1 = ik2 ->
+ kinteger64 ~loc ~kind:tk (Integer.sub i1 i2)
| Mult, Const(CInt64(i1,ik1,_)), Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
- kinteger64 ~loc ~kind:tk (Integer.mul i1 i2)
+ kinteger64 ~loc ~kind:tk (Integer.mul i1 i2)
| Mult, Const(CInt64(z,_,_)), _
when Integer.equal z Integer.zero -> e1''
- | Mult, Const(CInt64(one,_,_)), _
+ | Mult, Const(CInt64(one,_,_)), _
when Integer.equal one Integer.one -> e2''
- | Mult, _, Const(CInt64(z,_,_))
+ | Mult, _, Const(CInt64(z,_,_))
when Integer.equal z Integer.zero -> e2''
- | Mult, _, Const(CInt64(one,_,_))
+ | Mult, _, Const(CInt64(one,_,_))
when Integer.equal one Integer.one -> e1''
| Div, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
- begin
- try kinteger64 ~loc ~kind:tk (Integer.c_div i1 i2)
- with Division_by_zero -> new_exp ~loc (BinOp(bop, e1', e2', tres))
- end
+ begin
+ try kinteger64 ~loc ~kind:tk (Integer.c_div i1 i2)
+ with Division_by_zero -> new_exp ~loc (BinOp(bop, e1', e2', tres))
+ end
| Div, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_))
- when bytesSizeOfInt ik1 = bytesSizeOfInt ik2 -> begin
- try kinteger64 ~loc ~kind:tk (Integer.c_div i1 i2)
- with Division_by_zero -> new_exp ~loc (BinOp(bop, e1', e2', tres))
- end
- | Div, _, Const(CInt64(one,_,_))
- when Integer.equal one Integer.one -> e1''
+ when bytesSizeOfInt ik1 = bytesSizeOfInt ik2 -> begin
+ try kinteger64 ~loc ~kind:tk (Integer.c_div i1 i2)
+ with Division_by_zero -> new_exp ~loc (BinOp(bop, e1', e2', tres))
+ end
+ | Div, _, Const(CInt64(one,_,_))
+ when Integer.equal one Integer.one -> e1''
| Mod, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
- begin
- try kinteger64 ~loc ~kind:tk (Integer.c_rem i1 i2)
- with Division_by_zero -> new_exp ~loc (BinOp(bop, e1', e2', tres))
- end
+ begin
+ try kinteger64 ~loc ~kind:tk (Integer.c_rem i1 i2)
+ with Division_by_zero -> new_exp ~loc (BinOp(bop, e1', e2', tres))
+ end
| BAnd, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
- kinteger64 ~loc ~kind:tk (Integer.logand i1 i2)
- | BAnd, Const(CInt64(z,_,_)), _
+ kinteger64 ~loc ~kind:tk (Integer.logand i1 i2)
+ | BAnd, Const(CInt64(z,_,_)), _
when Integer.equal z Integer.zero -> e1''
- | BAnd, _, Const(CInt64(z,_,_))
+ | BAnd, _, Const(CInt64(z,_,_))
when Integer.equal z Integer.zero -> e2''
| BOr, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
- kinteger64 ~loc ~kind:tk (Integer.logor i1 i2)
+ kinteger64 ~loc ~kind:tk (Integer.logor i1 i2)
| BOr, _, _ when isZero e1' -> e2'
| BOr, _, _ when isZero e2' -> e1'
| BXor, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
- kinteger64 ~loc ~kind:tk (Integer.logxor i1 i2)
+ kinteger64 ~loc ~kind:tk (Integer.logxor i1 i2)
| Shiftlt, Const(CInt64(i1,_ik1,_)),Const(CInt64(i2,_,_))
- when shiftInBounds i2 ->
- kinteger64 ~loc ~kind:tk (Integer.shift_left i1 i2)
- | Shiftlt, Const(CInt64(z,_,_)), _
+ when shiftInBounds i2 ->
+ kinteger64 ~loc ~kind:tk (Integer.shift_left i1 i2)
+ | Shiftlt, Const(CInt64(z,_,_)), _
when Integer.equal z Integer.zero -> e1''
- | Shiftlt, _, Const(CInt64(z,_,_))
+ | Shiftlt, _, Const(CInt64(z,_,_))
when Integer.equal z Integer.zero -> e1''
| Shiftrt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,_,_))
- when shiftInBounds i2 ->
- if isunsigned ik1 then
- kinteger64 ~loc ~kind:tk
- (Integer.shift_right_logical i1 i2)
- else
- kinteger64 ~loc ~kind:tk (Integer.shift_right i1 i2)
- | Shiftrt, Const(CInt64(z,_,_)), _
+ when shiftInBounds i2 ->
+ if isunsigned ik1 then
+ kinteger64 ~loc ~kind:tk
+ (Integer.shift_right_logical i1 i2)
+ else
+ kinteger64 ~loc ~kind:tk (Integer.shift_right i1 i2)
+ | Shiftrt, Const(CInt64(z,_,_)), _
when Integer.equal z Integer.zero -> e1''
- | Shiftrt, _, Const(CInt64(z,_,_))
+ | Shiftrt, _, Const(CInt64(z,_,_))
when Integer.equal z Integer.zero -> e1''
| Eq, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) ->
- let i1', i2', _ = convertInts i1 ik1 i2 ik2 in
- if Integer.equal i1' i2' then one ~loc else zero ~loc
+ let i1', i2', _ = convertInts i1 ik1 i2 ik2 in
+ if Integer.equal i1' i2' then one ~loc else zero ~loc
| Ne, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) ->
- let i1', i2', _ = convertInts i1 ik1 i2 ik2 in
- if Integer.equal i1' i2' then zero ~loc else one ~loc
+ let i1', i2', _ = convertInts i1 ik1 i2 ik2 in
+ if Integer.equal i1' i2' then zero ~loc else one ~loc
| Le, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) ->
- let i1', i2', _ = convertInts i1 ik1 i2 ik2 in
- if Integer.le i1' i2' then one ~loc else zero ~loc
+ let i1', i2', _ = convertInts i1 ik1 i2 ik2 in
+ if Integer.le i1' i2' then one ~loc else zero ~loc
| Ge, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) ->
- let i1', i2', _ = convertInts i1 ik1 i2 ik2 in
- if Integer.ge i1' i2' then one ~loc else zero ~loc
+ let i1', i2', _ = convertInts i1 ik1 i2 ik2 in
+ if Integer.ge i1' i2' then one ~loc else zero ~loc
| Lt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) ->
- let i1', i2', _ = convertInts i1 ik1 i2 ik2 in
- if Integer.lt i1' i2' then one ~loc else zero ~loc
+ let i1', i2', _ = convertInts i1 ik1 i2 ik2 in
+ if Integer.lt i1' i2' then one ~loc else zero ~loc
| Gt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) ->
- let i1', i2', _ = convertInts i1 ik1 i2 ik2 in
- if Integer.gt i1' i2' then one ~loc else zero ~loc
+ let i1', i2', _ = convertInts i1 ik1 i2 ik2 in
+ if Integer.gt i1' i2' then one ~loc else zero ~loc
(* We rely on the fact that LAnd/LOr appear in global initializers
and should not have side effects. *)
@@ -5705,8 +5705,8 @@ and constFoldBinOp ~loc (machdep: bool) bop e1 e2 tres =
| LOr, _, _ when isZero e1' -> e2'
| LOr, _, _ when isZero e2' -> e1'
| LOr, _, _ when isInteger e1' <> None || isInteger e2' <> None ->
- (* One of e1' or e2' is a nonzero constant *)
- one ~loc
+ (* One of e1' or e2' is a nonzero constant *)
+ one ~loc
| _ -> new_exp ~loc (BinOp(bop, e1', e2', tres))
in
if debugConstFold then
@@ -5721,11 +5721,11 @@ and constFoldToInt ?(machdep=true) e =
match (constFold machdep e).enode with
| Const(CInt64(c,_,_)) -> Some c
| CastE (typ, e) when machdep && isPointerType typ -> begin
- (* Those casts are left left by constFold *)
- match constFoldToInt ~machdep e with
- | None -> None
- | Some i as r -> if fitsInInt theMachine.upointKind i then r else None
- end
+ (* Those casts are left left by constFold *)
+ match constFoldToInt ~machdep e with
+ | None -> None
+ | Some i as r -> if fitsInInt theMachine.upointKind i then r else None
+ end
| _ -> None
let bitsSizeOfBitfield typlv =
@@ -5742,71 +5742,71 @@ let intTypeIncluded kind1 kind2 =
let bitsize1 = bitsSizeOfInt kind1 in
let bitsize2 = bitsSizeOfInt kind2 in
match isSigned kind1, isSigned kind2 with
- | true, true
- | false, false -> bitsize1 <= bitsize2
- | true, false -> false
- | false, true -> bitsize1 < bitsize2
+ | true, true
+ | false, false -> bitsize1 <= bitsize2
+ | true, false -> false
+ | false, true -> bitsize1 < bitsize2
- (* CEA: moved from cabs2cil.ml. See cil.mli for infos *)
- (* Weimer
- * multi-character character constants
- * In MSVC, this code works:
- *
- * long l1 = 'abcd'; // note single quotes
- * char * s = "dcba";
- * long * lptr = ( long * )s;
- * long l2 = *lptr;
- * assert(l1 == l2);
- *
- * We need to change a multi-character character literal into the
- * appropriate integer constant. However, the plot sickens: we
- * must also be able to handle things like 'ab\nd' (value = * "d\nba")
- * and 'abc' (vale = *"cba").
- *
- * First we convert 'AB\nD' into the list [ 65 ; 66 ; 10 ; 68 ], then we
- * multiply and add to get the desired value.
- *)
+(* CEA: moved from cabs2cil.ml. See cil.mli for infos *)
+(* Weimer
+ * multi-character character constants
+ * In MSVC, this code works:
+ *
+ * long l1 = 'abcd'; // note single quotes
+ * char * s = "dcba";
+ * long * lptr = ( long * )s;
+ * long l2 = *lptr;
+ * assert(l1 == l2);
+ *
+ * We need to change a multi-character character literal into the
+ * appropriate integer constant. However, the plot sickens: we
+ * must also be able to handle things like 'ab\nd' (value = * "d\nba")
+ * and 'abc' (vale = *"cba").
+ *
+ * First we convert 'AB\nD' into the list [ 65 ; 66 ; 10 ; 68 ], then we
+ * multiply and add to get the desired value.
+*)
+
+(* Given a character constant (like 'a' or 'abc') as a list of 64-bit
+ * values, turn it into a CIL constant. Multi-character constants are
+ * treated as multi-digit numbers with radix given by the bit width of
+ * the specified type (either char or wchar_t). *)
+let reduce_multichar typ : int64 list -> int64 =
+ let radix = bitsSizeOf typ in
+ List.fold_left
+ (fun acc -> Int64.add (Int64.shift_left acc radix))
+ Int64.zero
+
+let interpret_character_constant char_list =
+ let value = reduce_multichar charType char_list in
+ if value < (Int64.of_int 256) then
+ (* ISO C 6.4.4.4.10: single-character constants have type int *)
+ (CChr(Char.chr (Int64.to_int value))), intType
+ else begin
+ let orig_rep = None (* Some("'" ^ (String.escaped str) ^ "'") *) in
+ if value <= (Int64.of_int32 Int32.max_int) then
+ (CInt64(Integer.of_int64 value,IULong,orig_rep)),(TInt(IULong,[]))
+ else
+ (CInt64(Integer.of_int64 value,IULongLong,orig_rep)),(TInt(IULongLong,[]))
+ end
- (* Given a character constant (like 'a' or 'abc') as a list of 64-bit
- * values, turn it into a CIL constant. Multi-character constants are
- * treated as multi-digit numbers with radix given by the bit width of
- * the specified type (either char or wchar_t). *)
- let reduce_multichar typ : int64 list -> int64 =
- let radix = bitsSizeOf typ in
- List.fold_left
- (fun acc -> Int64.add (Int64.shift_left acc radix))
- Int64.zero
-
- let interpret_character_constant char_list =
- let value = reduce_multichar charType char_list in
- if value < (Int64.of_int 256) then
- (* ISO C 6.4.4.4.10: single-character constants have type int *)
- (CChr(Char.chr (Int64.to_int value))), intType
- else begin
- let orig_rep = None (* Some("'" ^ (String.escaped str) ^ "'") *) in
- if value <= (Int64.of_int32 Int32.max_int) then
- (CInt64(Integer.of_int64 value,IULong,orig_rep)),(TInt(IULong,[]))
- else
- (CInt64(Integer.of_int64 value,IULongLong,orig_rep)),(TInt(IULongLong,[]))
- end
-
- let invalidStmt = mkStmt (Instr (Skip Location.unknown))
- module Frama_c_builtins =
- State_builder.Hashtbl
- (Datatype.String.Hashtbl)
- (Cil_datatype.Varinfo)
- (struct
- let name = "Cil.Frama_c_Builtins"
- let dependencies = []
- let size = 3
+let invalidStmt = mkStmt (Instr (Skip Location.unknown))
+module Frama_c_builtins =
+ State_builder.Hashtbl
+ (Datatype.String.Hashtbl)
+ (Cil_datatype.Varinfo)
+ (struct
+ let name = "Cil.Frama_c_Builtins"
+ let dependencies = []
+ let size = 3
end)
- let () = dependency_on_ast Frama_c_builtins.self
+let () = dependency_on_ast Frama_c_builtins.self
- let is_builtin v = hasAttribute "FC_BUILTIN" v.vattr
+let is_builtin v = hasAttribute "FC_BUILTIN" v.vattr
- let is_unused_builtin v = is_builtin v && not v.vreferenced
+let is_unused_builtin v = is_builtin v && not v.vreferenced
(* [VP] Should we projectify this ?*)
@@ -5822,344 +5822,344 @@ let add_special_builtin s =
special_builtins_table := Datatype.String.Set.add s !special_builtins_table
let () = add_special_builtin_family
- (fun s -> Datatype.String.Set.mem s !special_builtins_table)
+ (fun s -> Datatype.String.Set.mem s !special_builtins_table)
let () = List.iter add_special_builtin
- [ "__builtin_stdarg_start"; "__builtin_va_arg";
- "__builtin_va_start"; "__builtin_expect"; "__builtin_next_arg"; ]
+ [ "__builtin_stdarg_start"; "__builtin_va_arg";
+ "__builtin_va_start"; "__builtin_expect"; "__builtin_next_arg"; ]
let typeAddVolatile typ = typeAddAttributes [Attr ("volatile", [])] typ
- module Builtin_functions =
- State_builder.Hashtbl
- (Datatype.String.Hashtbl)
- (Datatype.Triple(Typ)(Datatype.List(Typ))(Datatype.Bool))
- (struct
- let name = "Builtin_functions"
- let dependencies = [ TheMachine.self ]
- let size = 49
- end)
-
- let add_builtin ?(prefix="__builtin_") s t l b =
- Builtin_functions.add (prefix ^ s) (t, l, b)
-
- let () = registerAttribute "FC_BUILTIN" (AttrName true)
-
- (* Initialize the builtin functions after the machine has been initialized. *)
- let initGccBuiltins () : unit =
- let sizeType = theMachine.upointType in
- let add = add_builtin in
- add "__fprintf_chk"
- intType
- (* first argument is really FILE*, not void*, but we don't want to build in
- the definition for FILE *)
- [ voidPtrType; intType; charConstPtrType ]
- true;
- add "__memcpy_chk"
- voidPtrType
- [ voidPtrType; voidConstPtrType; sizeType; sizeType ]
- false;
- add "__memmove_chk"
- voidPtrType [ voidPtrType; voidConstPtrType; sizeType; sizeType ] false;
- add "__mempcpy_chk"
- voidPtrType [ voidPtrType; voidConstPtrType; sizeType; sizeType ] false;
- add "__memset_chk"
- voidPtrType [ voidPtrType; intType; sizeType; sizeType ] false;
- add "__printf_chk" intType [ intType; charConstPtrType ] true;
- add "__snprintf_chk"
- intType [ charPtrType; sizeType; intType; sizeType; charConstPtrType ]
- true;
- add "__sprintf_chk"
- intType [ charPtrType; intType; sizeType; charConstPtrType ] true;
- add "__stpcpy_chk"
- charPtrType [ charPtrType; charConstPtrType; sizeType ] false;
- add "__strcat_chk"
- charPtrType [ charPtrType; charConstPtrType; sizeType ] false;
- add "__strcpy_chk"
- charPtrType [ charPtrType; charConstPtrType; sizeType ] false;
- add "__strncat_chk"
- charPtrType [ charPtrType; charConstPtrType; sizeType; sizeType ] false;
- add "__strncpy_chk"
- charPtrType [ charPtrType; charConstPtrType; sizeType; sizeType ] false;
- add "__vfprintf_chk"
- intType
- (* first argument is really FILE*, not void*, but we don't want to build in
- the definition for FILE *)
- [ voidPtrType; intType; charConstPtrType; TBuiltin_va_list [] ]
- false;
- add "__vprintf_chk"
- intType [ intType; charConstPtrType; TBuiltin_va_list [] ] false;
- add "__vsnprintf_chk"
- intType
- [ charPtrType; sizeType; intType; sizeType; charConstPtrType;
- TBuiltin_va_list [] ]
- false;
- add "__vsprintf_chk"
- intType
- [ charPtrType; intType; sizeType; charConstPtrType; TBuiltin_va_list [] ]
- false;
-
- add "alloca" voidPtrType [ sizeType ] false;
-
- add "acos" doubleType [ doubleType ] false;
- add "acosf" floatType [ floatType ] false;
- add "acosl" longDoubleType [ longDoubleType ] false;
-
- add "asin" doubleType [ doubleType ] false;
- add "asinf" floatType [ floatType ] false;
- add "asinl" longDoubleType [ longDoubleType ] false;
-
- add "atan" doubleType [ doubleType ] false;
- add "atanf" floatType [ floatType ] false;
- add "atanl" longDoubleType [ longDoubleType ] false;
-
- add "atan2" doubleType [ doubleType; doubleType ] false;
- add "atan2f" floatType [ floatType; floatType ] false;
- add "atan2l" longDoubleType [ longDoubleType;
- longDoubleType ] false;
-
- let uint16t = uint16_t () in
- add "bswap16" uint16t [uint16t] false;
-
- let uint32t = uint32_t () in
- add "bswap32" uint32t [uint32t] false;
-
- let uint64t = uint64_t () in
- add "bswap64" uint64t [uint64t] false;
-
- add "ceil" doubleType [ doubleType ] false;
- add "ceilf" floatType [ floatType ] false;
- add "ceill" longDoubleType [ longDoubleType ] false;
-
- add "cos" doubleType [ doubleType ] false;
- add "cosf" floatType [ floatType ] false;
- add "cosl" longDoubleType [ longDoubleType ] false;
-
- add "cosh" doubleType [ doubleType ] false;
- add "coshf" floatType [ floatType ] false;
- add "coshl" longDoubleType [ longDoubleType ] false;
-
- add "clz" intType [ uintType ] false;
- add "clzl" intType [ ulongType ] false;
- add "clzll" intType [ ulongLongType ] false;
- add "constant_p" intType [ intType ] false;
- add "ctz" intType [ uintType ] false;
- add "ctzl" intType [ ulongType ] false;
- add "ctzll" intType [ ulongLongType ] false;
-
- add "exp" doubleType [ doubleType ] false;
- add "expf" floatType [ floatType ] false;
- add "expl" longDoubleType [ longDoubleType ] false;
-
- add "expect" longType [ longType; longType ] false;
-
- add "fabs" doubleType [ doubleType ] false;
- add "fabsf" floatType [ floatType ] false;
- add "fabsl" longDoubleType [ longDoubleType ] false;
-
- add "ffs" intType [ uintType ] false;
- add "ffsl" intType [ ulongType ] false;
- add "ffsll" intType [ ulongLongType ] false;
- add "frame_address" voidPtrType [ uintType ] false;
-
- add "floor" doubleType [ doubleType ] false;
- add "floorf" floatType [ floatType ] false;
- add "floorl" longDoubleType [ longDoubleType ] false;
-
- add "huge_val" doubleType [] false;
- add "huge_valf" floatType [] false;
- add "huge_vall" longDoubleType [] false;
- add "ia32_lfence" voidType [] false;
- add "ia32_mfence" voidType [] false;
- add "ia32_sfence" voidType [] false;
-
- add "inf" doubleType [] false;
- add "inff" floatType [] false;
- add "infl" longDoubleType [] false;
- add "memcpy" voidPtrType [ voidPtrType; voidConstPtrType; sizeType ] false;
- add "mempcpy" voidPtrType [ voidPtrType; voidConstPtrType; sizeType ] false;
- add "memset" voidPtrType [ voidPtrType; intType; intType ] false;
-
- add "fmod" doubleType [ doubleType ] false;
- add "fmodf" floatType [ floatType ] false;
- add "fmodl" longDoubleType [ longDoubleType ] false;
-
- add "frexp" doubleType [ doubleType; intPtrType ] false;
- add "frexpf" floatType [ floatType; intPtrType ] false;
- add "frexpl" longDoubleType [ longDoubleType; intPtrType ] false;
-
- add "ldexp" doubleType [ doubleType; intType ] false;
- add "ldexpf" floatType [ floatType; intType ] false;
- add "ldexpl" longDoubleType [ longDoubleType; intType ] false;
-
- add "log" doubleType [ doubleType ] false;
- add "logf" floatType [ floatType ] false;
- add "logl" longDoubleType [ longDoubleType ] false;
-
- add "log10" doubleType [ doubleType ] false;
- add "log10f" floatType [ floatType ] false;
- add "log10l" longDoubleType [ longDoubleType ] false;
-
- add "modff" floatType [ floatType; TPtr(floatType,[]) ] false;
- add "modfl"
- longDoubleType [ longDoubleType; TPtr(longDoubleType, []) ] false;
-
- add "nan" doubleType [ charConstPtrType ] false;
- add "nanf" floatType [ charConstPtrType ] false;
- add "nanl" longDoubleType [ charConstPtrType ] false;
- add "nans" doubleType [ charConstPtrType ] false;
- add "nansf" floatType [ charConstPtrType ] false;
- add "nansl" longDoubleType [ charConstPtrType ] false;
- add "object_size" sizeType [ voidPtrType; intType ] false;
-
- add "parity" intType [ uintType ] false;
- add "parityl" intType [ ulongType ] false;
- add "parityll" intType [ ulongLongType ] false;
-
- add "popcount" intType [ uintType ] false;
- add "popcountl" intType [ ulongType ] false;
- add "popcountll" intType [ ulongLongType ] false;
-
- add "powi" doubleType [ doubleType; intType ] false;
- add "powif" floatType [ floatType; intType ] false;
- add "powil" longDoubleType [ longDoubleType; intType ] false;
- add "prefetch" voidType [ voidConstPtrType ] true;
- add "return" voidType [ voidConstPtrType ] false;
- add "return_address" voidPtrType [ uintType ] false;
-
- add "sin" doubleType [ doubleType ] false;
- add "sinf" floatType [ floatType ] false;
- add "sinl" longDoubleType [ longDoubleType ] false;
-
- add "sinh" doubleType [ doubleType ] false;
- add "sinhf" floatType [ floatType ] false;
- add "sinhl" longDoubleType [ longDoubleType ] false;
-
- add "sqrt" doubleType [ doubleType ] false;
- add "sqrtf" floatType [ floatType ] false;
- add "sqrtl" longDoubleType [ longDoubleType ] false;
-
- add "stpcpy" charPtrType [ charPtrType; charConstPtrType ] false;
- add "strchr" charPtrType [ charPtrType; intType ] false;
- add "strcmp" intType [ charConstPtrType; charConstPtrType ] false;
- add "strcpy" charPtrType [ charPtrType; charConstPtrType ] false;
- add "strcspn" sizeType [ charConstPtrType; charConstPtrType ] false;
- add "strncat" charPtrType [ charPtrType; charConstPtrType; sizeType ] false;
- add "strncmp" intType [ charConstPtrType; charConstPtrType; sizeType ] false;
- add "strncpy" charPtrType [ charPtrType; charConstPtrType; sizeType ] false;
- add "strspn" sizeType [ charConstPtrType; charConstPtrType ] false;
- add "strpbrk" charPtrType [ charConstPtrType; charConstPtrType ] false;
- (* When we parse builtin_types_compatible_p, we change its interface *)
- add "types_compatible_p"
- intType
- [ theMachine.typeOfSizeOf;(* Sizeof the type *)
- theMachine.typeOfSizeOf (* Sizeof the type *) ]
- false;
- add "tan" doubleType [ doubleType ] false;
- add "tanf" floatType [ floatType ] false;
- add "tanl" longDoubleType [ longDoubleType ] false;
-
- add "tanh" doubleType [ doubleType ] false;
- add "tanhf" floatType [ floatType ] false;
- add "tanhl" longDoubleType [ longDoubleType ] false;
-
- add "unreachable" voidType [ ] false;
-
- let int8_t = Some scharType in
- let int16_t = try Some (int16_t ()) with Not_found -> None in
- let int32_t = try Some (int32_t ()) with Not_found -> None in
- let int64_t = try Some (int64_t ()) with Not_found -> None in
- let uint8_t = Some ucharType in
- let uint16_t = try Some (uint16_t ()) with Not_found -> None in
- let uint32_t = try Some (uint32_t ()) with Not_found -> None in
- let uint64_t = try Some (uint64_t ()) with Not_found -> None in
-
- (* Binary monomorphic versions of atomic builtins *)
- let atomic_instances =
- [int8_t, "_int8_t";
- int16_t,"_int16_t";
- int32_t,"_int32_t";
- int64_t,"_int64_t";
- uint8_t, "_uint8_t";
- uint16_t,"_uint16_t";
- uint32_t,"_uint32_t";
- uint64_t,"_uint64_t"]
- in
- let add_sync (typ,name) f =
- match typ with
- | Some typ ->
- add ~prefix:"__sync_" (f^name) typ [ TPtr(typeAddVolatile typ,[]); typ] true
- | None -> ()
- in
- let add_sync f =
- List.iter (fun typ -> add_sync typ f) atomic_instances
- in
- add_sync "fetch_and_add";
- add_sync "fetch_and_sub";
- add_sync "fetch_and_or";
- add_sync "fetch_and_and";
- add_sync "fetch_and_xor";
- add_sync "fetch_and_nand";
- add_sync "add_and_fetch";
- add_sync "sub_and_fetch";
- add_sync "or_and_fetch";
- add_sync "and_and_fetch";
- add_sync "xor_and_fetch";
- add_sync "nand_and_fetch";
- add_sync "lock_test_and_set";
- List.iter (fun (typ,n) ->
- match typ with
- | Some typ ->
- add ~prefix:"" ("__sync_bool_compare_and_swap"^n)
- intType
- [ TPtr(typeAddVolatile typ,[]); typ ; typ]
- true
- | None -> ())
- atomic_instances;
- List.iter (fun (typ,n) ->
- match typ with
- | Some typ ->
- add ~prefix:"" ("__sync_val_compare_and_swap"^n)
- typ
- [ TPtr(typeAddVolatile typ,[]); typ ; typ]
- true
- | None -> ())
- atomic_instances;
- List.iter (fun (typ,n) ->
- match typ with
- | Some typ ->
- add ~prefix:"" ("__sync_lock_release"^n)
- voidType
- [ TPtr(typeAddVolatile typ,[]) ]
- true;
- | None -> ())
- atomic_instances;
- add ~prefix:"" "__sync_synchronize" voidType [] true
+module Builtin_functions =
+ State_builder.Hashtbl
+ (Datatype.String.Hashtbl)
+ (Datatype.Triple(Typ)(Datatype.List(Typ))(Datatype.Bool))
+ (struct
+ let name = "Builtin_functions"
+ let dependencies = [ TheMachine.self ]
+ let size = 49
+ end)
+
+let add_builtin ?(prefix="__builtin_") s t l b =
+ Builtin_functions.add (prefix ^ s) (t, l, b)
+
+let () = registerAttribute "FC_BUILTIN" (AttrName true)
+
+(* Initialize the builtin functions after the machine has been initialized. *)
+let initGccBuiltins () : unit =
+ let sizeType = theMachine.upointType in
+ let add = add_builtin in
+ add "__fprintf_chk"
+ intType
+ (* first argument is really FILE*, not void*, but we don't want to build in
+ the definition for FILE *)
+ [ voidPtrType; intType; charConstPtrType ]
+ true;
+ add "__memcpy_chk"
+ voidPtrType
+ [ voidPtrType; voidConstPtrType; sizeType; sizeType ]
+ false;
+ add "__memmove_chk"
+ voidPtrType [ voidPtrType; voidConstPtrType; sizeType; sizeType ] false;
+ add "__mempcpy_chk"
+ voidPtrType [ voidPtrType; voidConstPtrType; sizeType; sizeType ] false;
+ add "__memset_chk"
+ voidPtrType [ voidPtrType; intType; sizeType; sizeType ] false;
+ add "__printf_chk" intType [ intType; charConstPtrType ] true;
+ add "__snprintf_chk"
+ intType [ charPtrType; sizeType; intType; sizeType; charConstPtrType ]
+ true;
+ add "__sprintf_chk"
+ intType [ charPtrType; intType; sizeType; charConstPtrType ] true;
+ add "__stpcpy_chk"
+ charPtrType [ charPtrType; charConstPtrType; sizeType ] false;
+ add "__strcat_chk"
+ charPtrType [ charPtrType; charConstPtrType; sizeType ] false;
+ add "__strcpy_chk"
+ charPtrType [ charPtrType; charConstPtrType; sizeType ] false;
+ add "__strncat_chk"
+ charPtrType [ charPtrType; charConstPtrType; sizeType; sizeType ] false;
+ add "__strncpy_chk"
+ charPtrType [ charPtrType; charConstPtrType; sizeType; sizeType ] false;
+ add "__vfprintf_chk"
+ intType
+ (* first argument is really FILE*, not void*, but we don't want to build in
+ the definition for FILE *)
+ [ voidPtrType; intType; charConstPtrType; TBuiltin_va_list [] ]
+ false;
+ add "__vprintf_chk"
+ intType [ intType; charConstPtrType; TBuiltin_va_list [] ] false;
+ add "__vsnprintf_chk"
+ intType
+ [ charPtrType; sizeType; intType; sizeType; charConstPtrType;
+ TBuiltin_va_list [] ]
+ false;
+ add "__vsprintf_chk"
+ intType
+ [ charPtrType; intType; sizeType; charConstPtrType; TBuiltin_va_list [] ]
+ false;
+
+ add "alloca" voidPtrType [ sizeType ] false;
+
+ add "acos" doubleType [ doubleType ] false;
+ add "acosf" floatType [ floatType ] false;
+ add "acosl" longDoubleType [ longDoubleType ] false;
+
+ add "asin" doubleType [ doubleType ] false;
+ add "asinf" floatType [ floatType ] false;
+ add "asinl" longDoubleType [ longDoubleType ] false;
+
+ add "atan" doubleType [ doubleType ] false;
+ add "atanf" floatType [ floatType ] false;
+ add "atanl" longDoubleType [ longDoubleType ] false;
+
+ add "atan2" doubleType [ doubleType; doubleType ] false;
+ add "atan2f" floatType [ floatType; floatType ] false;
+ add "atan2l" longDoubleType [ longDoubleType;
+ longDoubleType ] false;
+
+ let uint16t = uint16_t () in
+ add "bswap16" uint16t [uint16t] false;
+
+ let uint32t = uint32_t () in
+ add "bswap32" uint32t [uint32t] false;
+
+ let uint64t = uint64_t () in
+ add "bswap64" uint64t [uint64t] false;
+
+ add "ceil" doubleType [ doubleType ] false;
+ add "ceilf" floatType [ floatType ] false;
+ add "ceill" longDoubleType [ longDoubleType ] false;
+
+ add "cos" doubleType [ doubleType ] false;
+ add "cosf" floatType [ floatType ] false;
+ add "cosl" longDoubleType [ longDoubleType ] false;
+
+ add "cosh" doubleType [ doubleType ] false;
+ add "coshf" floatType [ floatType ] false;
+ add "coshl" longDoubleType [ longDoubleType ] false;
+
+ add "clz" intType [ uintType ] false;
+ add "clzl" intType [ ulongType ] false;
+ add "clzll" intType [ ulongLongType ] false;
+ add "constant_p" intType [ intType ] false;
+ add "ctz" intType [ uintType ] false;
+ add "ctzl" intType [ ulongType ] false;
+ add "ctzll" intType [ ulongLongType ] false;
+
+ add "exp" doubleType [ doubleType ] false;
+ add "expf" floatType [ floatType ] false;
+ add "expl" longDoubleType [ longDoubleType ] false;
+
+ add "expect" longType [ longType; longType ] false;
+
+ add "fabs" doubleType [ doubleType ] false;
+ add "fabsf" floatType [ floatType ] false;
+ add "fabsl" longDoubleType [ longDoubleType ] false;
+
+ add "ffs" intType [ uintType ] false;
+ add "ffsl" intType [ ulongType ] false;
+ add "ffsll" intType [ ulongLongType ] false;
+ add "frame_address" voidPtrType [ uintType ] false;
+
+ add "floor" doubleType [ doubleType ] false;
+ add "floorf" floatType [ floatType ] false;
+ add "floorl" longDoubleType [ longDoubleType ] false;
+
+ add "huge_val" doubleType [] false;
+ add "huge_valf" floatType [] false;
+ add "huge_vall" longDoubleType [] false;
+ add "ia32_lfence" voidType [] false;
+ add "ia32_mfence" voidType [] false;
+ add "ia32_sfence" voidType [] false;
+
+ add "inf" doubleType [] false;
+ add "inff" floatType [] false;
+ add "infl" longDoubleType [] false;
+ add "memcpy" voidPtrType [ voidPtrType; voidConstPtrType; sizeType ] false;
+ add "mempcpy" voidPtrType [ voidPtrType; voidConstPtrType; sizeType ] false;
+ add "memset" voidPtrType [ voidPtrType; intType; intType ] false;
+
+ add "fmod" doubleType [ doubleType ] false;
+ add "fmodf" floatType [ floatType ] false;
+ add "fmodl" longDoubleType [ longDoubleType ] false;
+
+ add "frexp" doubleType [ doubleType; intPtrType ] false;
+ add "frexpf" floatType [ floatType; intPtrType ] false;
+ add "frexpl" longDoubleType [ longDoubleType; intPtrType ] false;
+
+ add "ldexp" doubleType [ doubleType; intType ] false;
+ add "ldexpf" floatType [ floatType; intType ] false;
+ add "ldexpl" longDoubleType [ longDoubleType; intType ] false;
+
+ add "log" doubleType [ doubleType ] false;
+ add "logf" floatType [ floatType ] false;
+ add "logl" longDoubleType [ longDoubleType ] false;
+
+ add "log10" doubleType [ doubleType ] false;
+ add "log10f" floatType [ floatType ] false;
+ add "log10l" longDoubleType [ longDoubleType ] false;
+
+ add "modff" floatType [ floatType; TPtr(floatType,[]) ] false;
+ add "modfl"
+ longDoubleType [ longDoubleType; TPtr(longDoubleType, []) ] false;
+
+ add "nan" doubleType [ charConstPtrType ] false;
+ add "nanf" floatType [ charConstPtrType ] false;
+ add "nanl" longDoubleType [ charConstPtrType ] false;
+ add "nans" doubleType [ charConstPtrType ] false;
+ add "nansf" floatType [ charConstPtrType ] false;
+ add "nansl" longDoubleType [ charConstPtrType ] false;
+ add "object_size" sizeType [ voidPtrType; intType ] false;
+
+ add "parity" intType [ uintType ] false;
+ add "parityl" intType [ ulongType ] false;
+ add "parityll" intType [ ulongLongType ] false;
+
+ add "popcount" intType [ uintType ] false;
+ add "popcountl" intType [ ulongType ] false;
+ add "popcountll" intType [ ulongLongType ] false;
+
+ add "powi" doubleType [ doubleType; intType ] false;
+ add "powif" floatType [ floatType; intType ] false;
+ add "powil" longDoubleType [ longDoubleType; intType ] false;
+ add "prefetch" voidType [ voidConstPtrType ] true;
+ add "return" voidType [ voidConstPtrType ] false;
+ add "return_address" voidPtrType [ uintType ] false;
+
+ add "sin" doubleType [ doubleType ] false;
+ add "sinf" floatType [ floatType ] false;
+ add "sinl" longDoubleType [ longDoubleType ] false;
+
+ add "sinh" doubleType [ doubleType ] false;
+ add "sinhf" floatType [ floatType ] false;
+ add "sinhl" longDoubleType [ longDoubleType ] false;
+
+ add "sqrt" doubleType [ doubleType ] false;
+ add "sqrtf" floatType [ floatType ] false;
+ add "sqrtl" longDoubleType [ longDoubleType ] false;
+
+ add "stpcpy" charPtrType [ charPtrType; charConstPtrType ] false;
+ add "strchr" charPtrType [ charPtrType; intType ] false;
+ add "strcmp" intType [ charConstPtrType; charConstPtrType ] false;
+ add "strcpy" charPtrType [ charPtrType; charConstPtrType ] false;
+ add "strcspn" sizeType [ charConstPtrType; charConstPtrType ] false;
+ add "strncat" charPtrType [ charPtrType; charConstPtrType; sizeType ] false;
+ add "strncmp" intType [ charConstPtrType; charConstPtrType; sizeType ] false;
+ add "strncpy" charPtrType [ charPtrType; charConstPtrType; sizeType ] false;
+ add "strspn" sizeType [ charConstPtrType; charConstPtrType ] false;
+ add "strpbrk" charPtrType [ charConstPtrType; charConstPtrType ] false;
+ (* When we parse builtin_types_compatible_p, we change its interface *)
+ add "types_compatible_p"
+ intType
+ [ theMachine.typeOfSizeOf;(* Sizeof the type *)
+ theMachine.typeOfSizeOf (* Sizeof the type *) ]
+ false;
+ add "tan" doubleType [ doubleType ] false;
+ add "tanf" floatType [ floatType ] false;
+ add "tanl" longDoubleType [ longDoubleType ] false;
+
+ add "tanh" doubleType [ doubleType ] false;
+ add "tanhf" floatType [ floatType ] false;
+ add "tanhl" longDoubleType [ longDoubleType ] false;
+
+ add "unreachable" voidType [ ] false;
+
+ let int8_t = Some scharType in
+ let int16_t = try Some (int16_t ()) with Not_found -> None in
+ let int32_t = try Some (int32_t ()) with Not_found -> None in
+ let int64_t = try Some (int64_t ()) with Not_found -> None in
+ let uint8_t = Some ucharType in
+ let uint16_t = try Some (uint16_t ()) with Not_found -> None in
+ let uint32_t = try Some (uint32_t ()) with Not_found -> None in
+ let uint64_t = try Some (uint64_t ()) with Not_found -> None in
+
+ (* Binary monomorphic versions of atomic builtins *)
+ let atomic_instances =
+ [int8_t, "_int8_t";
+ int16_t,"_int16_t";
+ int32_t,"_int32_t";
+ int64_t,"_int64_t";
+ uint8_t, "_uint8_t";
+ uint16_t,"_uint16_t";
+ uint32_t,"_uint32_t";
+ uint64_t,"_uint64_t"]
+ in
+ let add_sync (typ,name) f =
+ match typ with
+ | Some typ ->
+ add ~prefix:"__sync_" (f^name) typ [ TPtr(typeAddVolatile typ,[]); typ] true
+ | None -> ()
+ in
+ let add_sync f =
+ List.iter (fun typ -> add_sync typ f) atomic_instances
+ in
+ add_sync "fetch_and_add";
+ add_sync "fetch_and_sub";
+ add_sync "fetch_and_or";
+ add_sync "fetch_and_and";
+ add_sync "fetch_and_xor";
+ add_sync "fetch_and_nand";
+ add_sync "add_and_fetch";
+ add_sync "sub_and_fetch";
+ add_sync "or_and_fetch";
+ add_sync "and_and_fetch";
+ add_sync "xor_and_fetch";
+ add_sync "nand_and_fetch";
+ add_sync "lock_test_and_set";
+ List.iter (fun (typ,n) ->
+ match typ with
+ | Some typ ->
+ add ~prefix:"" ("__sync_bool_compare_and_swap"^n)
+ intType
+ [ TPtr(typeAddVolatile typ,[]); typ ; typ]
+ true
+ | None -> ())
+ atomic_instances;
+ List.iter (fun (typ,n) ->
+ match typ with
+ | Some typ ->
+ add ~prefix:"" ("__sync_val_compare_and_swap"^n)
+ typ
+ [ TPtr(typeAddVolatile typ,[]); typ ; typ]
+ true
+ | None -> ())
+ atomic_instances;
+ List.iter (fun (typ,n) ->
+ match typ with
+ | Some typ ->
+ add ~prefix:"" ("__sync_lock_release"^n)
+ voidType
+ [ TPtr(typeAddVolatile typ,[]) ]
+ true;
+ | None -> ())
+ atomic_instances;
+ add ~prefix:"" "__sync_synchronize" voidType [] true
;;
(* Builtins related to va_list. Added to all non-msvc machdeps, because
Cabs2cil supposes they exist. *)
- let initVABuiltins () =
- let hasbva = theMachine.theMachine.has__builtin_va_list in
- let add = add_builtin in
- add "next_arg"
- (* When we parse builtin_next_arg we drop the second argument *)
- (if hasbva then TBuiltin_va_list [] else voidPtrType) [] false;
- if hasbva then begin
- add "va_end" voidType [ TBuiltin_va_list [] ] false;
- add "varargs_start" voidType [ TBuiltin_va_list [] ] false;
- (* When we parse builtin_{va,stdarg}_start, we drop the second argument *)
- add "va_start" voidType [ TBuiltin_va_list [] ] false;
- add "stdarg_start" voidType [ TBuiltin_va_list [] ] false;
- (* When we parse builtin_va_arg we change its interface *)
- add "va_arg"
- voidType
- [ TBuiltin_va_list [];
- theMachine.typeOfSizeOf;(* Sizeof the type *)
- voidPtrType (* Ptr to res *) ]
- false;
- add "va_copy" voidType [ TBuiltin_va_list []; TBuiltin_va_list [] ] false;
- end
+let initVABuiltins () =
+ let hasbva = theMachine.theMachine.has__builtin_va_list in
+ let add = add_builtin in
+ add "next_arg"
+ (* When we parse builtin_next_arg we drop the second argument *)
+ (if hasbva then TBuiltin_va_list [] else voidPtrType) [] false;
+ if hasbva then begin
+ add "va_end" voidType [ TBuiltin_va_list [] ] false;
+ add "varargs_start" voidType [ TBuiltin_va_list [] ] false;
+ (* When we parse builtin_{va,stdarg}_start, we drop the second argument *)
+ add "va_start" voidType [ TBuiltin_va_list [] ] false;
+ add "stdarg_start" voidType [ TBuiltin_va_list [] ] false;
+ (* When we parse builtin_va_arg we change its interface *)
+ add "va_arg"
+ voidType
+ [ TBuiltin_va_list [];
+ theMachine.typeOfSizeOf;(* Sizeof the type *)
+ voidPtrType (* Ptr to res *) ]
+ false;
+ add "va_copy" voidType [ TBuiltin_va_list []; TBuiltin_va_list [] ] false;
+ end
let initMsvcBuiltins () : unit =
(** Take a number of wide string literals *)
@@ -6178,741 +6178,741 @@ let init_builtins () =
if gccMode () then initGccBuiltins ();
end
- (** This is used as the location of the prototypes of builtin functions. *)
- let builtinLoc: location = Location.unknown
+(** This is used as the location of the prototypes of builtin functions. *)
+let builtinLoc: location = Location.unknown
- let range_loc loc1 loc2 = fst loc1, snd loc2
+let range_loc loc1 loc2 = fst loc1, snd loc2
(* JS 2012/11/16: probably broken since it may call constFold on some exp: this
operation modifies this expression in-place! *)
- let compareConstant c1 c2 =
- match c1, c2 with
- | CEnum e1, CEnum e2 ->
- e1.einame = e2.einame && e1.eihost.ename = e2.eihost.ename &&
- (match constFoldToInt e1.eival, constFoldToInt e2.eival with
- | Some i1, Some i2 -> Integer.equal i1 i2
- | _ -> false)
- | CInt64 (i1,k1,_), CInt64(i2,k2,_) ->
- k1 = k2 && Integer.equal i1 i2
- | CStr s1, CStr s2 -> s1 = s2
- | CWStr l1, CWStr l2 ->
- (try List.for_all2 (fun x y -> Int64.compare x y = 0) l1 l2
- with Invalid_argument _ -> false)
- | CChr c1, CChr c2 -> c1 = c2
- | CReal(f1,k1,_), CReal(f2,k2,_) -> k1 = k2 && f1 = f2
- | (CEnum _ | CInt64 _ | CStr _ | CWStr _ | CChr _ | CReal _), _ -> false
-
- (* Iterate over all globals, including the global initializer *)
- let iterGlobals (fl: file) (doone: global -> unit) : unit =
- let doone' g =
- CurrentLoc.set (Global.loc g);
- doone g
- in
- List.iter doone' fl.globals;
- match fl.globinit with
- | None -> ()
- | Some g -> doone' (GFun(g, Location.unknown))
-
- (* Fold over all globals, including the global initializer *)
- let foldGlobals (fl: file) (doone: 'a -> global -> 'a) (acc: 'a) : 'a =
- let doone' acc g =
- CurrentLoc.set (Global.loc g);
- doone acc g
- in
- let acc' = List.fold_left doone' acc fl.globals in
- match fl.globinit with
- | None -> acc'
- | Some g -> doone' acc' (GFun(g, Location.unknown))
-
- let is_skip = function Instr (Skip _) -> true | _ -> false
-
- (** [b_assumes] must be always empty for behavior named
- [Cil.default_behavior_name] *)
- let mk_behavior ?(name=default_behavior_name) ?(assumes=[]) ?(requires=[])
- ?(post_cond=[]) ?(assigns=WritesAny) ?(allocation=FreeAllocAny) ?(extended=[]) ()
- =
- { b_name = name;
- b_assumes = assumes; (* must be always empty for default_behavior_name *)
- b_requires = requires;
- b_assigns = assigns ;
- b_allocation = allocation ;
- b_post_cond = post_cond ;
- b_extended = extended;
- }
+let compareConstant c1 c2 =
+ match c1, c2 with
+ | CEnum e1, CEnum e2 ->
+ e1.einame = e2.einame && e1.eihost.ename = e2.eihost.ename &&
+ (match constFoldToInt e1.eival, constFoldToInt e2.eival with
+ | Some i1, Some i2 -> Integer.equal i1 i2
+ | _ -> false)
+ | CInt64 (i1,k1,_), CInt64(i2,k2,_) ->
+ k1 = k2 && Integer.equal i1 i2
+ | CStr s1, CStr s2 -> s1 = s2
+ | CWStr l1, CWStr l2 ->
+ (try List.for_all2 (fun x y -> Int64.compare x y = 0) l1 l2
+ with Invalid_argument _ -> false)
+ | CChr c1, CChr c2 -> c1 = c2
+ | CReal(f1,k1,_), CReal(f2,k2,_) -> k1 = k2 && f1 = f2
+ | (CEnum _ | CInt64 _ | CStr _ | CWStr _ | CChr _ | CReal _), _ -> false
+
+(* Iterate over all globals, including the global initializer *)
+let iterGlobals (fl: file) (doone: global -> unit) : unit =
+ let doone' g =
+ CurrentLoc.set (Global.loc g);
+ doone g
+ in
+ List.iter doone' fl.globals;
+ match fl.globinit with
+ | None -> ()
+ | Some g -> doone' (GFun(g, Location.unknown))
+
+(* Fold over all globals, including the global initializer *)
+let foldGlobals (fl: file) (doone: 'a -> global -> 'a) (acc: 'a) : 'a =
+ let doone' acc g =
+ CurrentLoc.set (Global.loc g);
+ doone acc g
+ in
+ let acc' = List.fold_left doone' acc fl.globals in
+ match fl.globinit with
+ | None -> acc'
+ | Some g -> doone' acc' (GFun(g, Location.unknown))
+
+let is_skip = function Instr (Skip _) -> true | _ -> false
+
+(** [b_assumes] must be always empty for behavior named
+ [Cil.default_behavior_name] *)
+let mk_behavior ?(name=default_behavior_name) ?(assumes=[]) ?(requires=[])
+ ?(post_cond=[]) ?(assigns=WritesAny) ?(allocation=FreeAllocAny) ?(extended=[]) ()
+ =
+ { b_name = name;
+ b_assumes = assumes; (* must be always empty for default_behavior_name *)
+ b_requires = requires;
+ b_assigns = assigns ;
+ b_allocation = allocation ;
+ b_post_cond = post_cond ;
+ b_extended = extended;
+ }
let spare_attributes_for_c_cast =
"declspec"::"arraylen"::"fc_stdlib"::qualifier_attributes
let type_remove_attributes_for_c_cast =
typeRemoveAttributes spare_attributes_for_c_cast
-
+
let spare_attributes_for_logic_cast =
spare_attributes_for_c_cast
let type_remove_attributes_for_logic_type =
typeRemoveAttributes spare_attributes_for_logic_cast
-
+
let () = Cil_datatype.drop_non_logic_attributes :=
- dropAttributes spare_attributes_for_logic_cast
+ dropAttributes spare_attributes_for_logic_cast
let need_cast ?(force=false) oldt newt =
let oldt = type_remove_attributes_for_c_cast (unrollType oldt) in
let newt = type_remove_attributes_for_c_cast (unrollType newt) in
not (Cil_datatype.Typ.equal oldt newt) &&
- (force ||
- match oldt, newt with
- | TInt(ik,ai),TEnum(e,ae)
- | TEnum(e,ae),TInt(ik,ai) when Attributes.equal ai ae ->
- ik <> e.ekind
- | _ -> true)
-
- let cvar_to_lvar vi = match vi.vlogic_var_assoc with
- | None ->
- let lv =
- { lv_name = vi.vname;
- lv_id = vi.vid;
- lv_kind = LVC;
- lv_type = Ctype vi.vtype ;
- lv_attr = [];
- lv_origin = Some vi}
- in
- vi.vlogic_var_assoc <- Some lv; lv
- | Some lv -> lv
-
- let copyVarinfo (vi: varinfo) (newname: string) : varinfo =
- let vi' = Cil_const.copy_with_new_vid vi in
- vi'.vname <- newname;
- (match vi.vlogic_var_assoc with
- None -> ()
- | Some _ ->
- vi'.vlogic_var_assoc <- None;
- ignore(cvar_to_lvar vi'));
- vi'
-
- let rec findUniqueName ?(suffix="") fdec name =
- let current_name = name ^ suffix in
- (* Is this check a performance problem? We could bring the old
- unchecked makeTempVar back as a separate function that assumes
- the prefix name does not occur in the original program. *)
- if (List.exists (fun vi -> vi.vname = current_name) fdec.slocals)
- || (List.exists (fun vi -> vi.vname = current_name) fdec.sformals) then begin
- fdec.smaxid <- 1 + fdec.smaxid;
- findUniqueName ~suffix:("_" ^ (string_of_int (1 + fdec.smaxid))) fdec name
- end else
- current_name
-
- let refresh_local_name fdec vi =
- let new_name = findUniqueName fdec vi.vname in vi.vname <- new_name
-
- let makeLocal ?(temp=false) ?referenced ?(formal=false) fdec name typ =
- (* a helper function *)
- let name = findUniqueName fdec name in
- fdec.smaxid <- 1 + fdec.smaxid;
- let vi = makeVarinfo ~temp ?referenced false formal name typ in
- vi
-
- (* Make a local variable and add it to a function *)
- let makeLocalVar fdec ?scope ?(temp=false) ?referenced ?(insert = true) name typ =
- let vi = makeLocal ~temp ?referenced fdec name typ in
- refresh_local_name fdec vi;
- if insert then
- begin
- fdec.slocals <- fdec.slocals @ [vi];
- let local_block =
- match scope with
- | None -> fdec.sbody
- | Some b -> b
- in
- local_block.blocals <- vi::local_block.blocals
- end;
- vi
-
- let makeTempVar fdec ?insert ?(name = "__cil_tmp") ?descr ?(descrpure = true)
- typ : varinfo =
- let vi = makeLocalVar fdec ~temp:true ?insert name typ in
- vi.vdescr <- descr;
- vi.vdescrpure <- descrpure;
- vi
-
- (* Set the types of arguments and results as given by the function type
- * passed as the second argument *)
- let setFunctionType (f: fundec) (t: typ) =
- match unrollType t with
- TFun (_rt, Some args, _va, _a) ->
- if List.length f.sformals <> List.length args then
- Kernel.fatal ~current:true "setFunctionType: number of arguments differs from the number of formals" ;
- (* Change the function type. *)
- f.svar.vtype <- t;
- (* Change the sformals and we know that indirectly we'll change the
- * function type *)
- List.iter2
- (fun (_an,at,aa) f ->
- f.vtype <- at; f.vattr <- aa)
- args f.sformals
-
- | _ -> Kernel.fatal ~current:true "setFunctionType: not a function type"
-
- (* Set the types of arguments and results as given by the function type
- passed as the second argument *)
- let setFunctionTypeMakeFormals (f: fundec) (t: typ) =
- match unrollType t with
- TFun (_rt, Some args, _va, _a) ->
- if f.sformals <> [] then
- Kernel.fatal ~current:true "setFunctionTypMakeFormals called on function %s with some formals already"
- f.svar.vname ;
- (* Change the function type. *)
- f.svar.vtype <- t;
- f.sformals <-
- List.map (fun (n,t,_a) -> makeLocal ~formal:true f n t) args;
- setFunctionType f t
-
- | _ ->
- Kernel.fatal ~current:true "setFunctionTypeMakeFormals: not a function type: %a"
- !pp_typ_ref t
-
- let setMaxId (f: fundec) =
- f.smaxid <- List.length f.sformals + List.length f.slocals
-
- (* Make a formal variable for a function. Insert it in both the sformals
- * and the type of the function. You can optionally specify where to insert
- * this one. If where = "^" then it is inserted first. If where = "$" then
- * it is inserted last. Otherwise where must be the name of a formal after
- * which to insert this. By default it is inserted at the end. *)
- let makeFormalVar fdec ?(where = "$") name typ : varinfo =
- (* Search for the insertion place *)
- let makeit name = makeLocal ~formal:true fdec name typ in
- let rec loopFormals acc = function
- [] ->
- if where = "$" then
- let vi = makeit name in vi, List.rev (vi::acc)
- else Kernel.fatal ~current:true
- "makeFormalVar: cannot find insert-after formal %s" where
- | f :: rest when f.vname = where ->
- let vi = makeit name in vi, List.rev_append acc (f :: vi :: rest)
- | f :: rest -> loopFormals (f::acc) rest
- in
- let vi, newformals =
- if where = "^" then let vi = makeit name in vi, vi :: fdec.sformals
- else
- loopFormals [] fdec.sformals
- in
- setFormals fdec newformals;
- vi
-
- (* Make a global variable. Your responsibility to make sure that the name
- * is unique *)
- let makeGlobalVar ?source ?temp ?referenced name typ =
- makeVarinfo ?source ?temp ?referenced true false name typ
-
- let mkPureExprInstr ~fundec ~scope ?loc e =
- let loc = match loc with None -> e.eloc | Some l -> l in
- let typ = typeOf e in
- let descr = Format.asprintf "%a" !pp_exp_ref e in
- let tmp = makeLocalVar ~temp:true ~scope fundec "tmp" typ in
- tmp.vdescr <- Some descr;
- tmp.vdefined <- true;
- Local_init(tmp, AssignInit (SingleInit e), loc)
-
- let mkPureExpr ?ghost ?valid_sid ~(fundec:fundec) ?loc (e : exp) : stmt =
- let scope = mkBlock [] in
- let instr = mkPureExprInstr ~fundec ~scope ?loc e in
- scope.bstmts <- [ mkStmtOneInstr ?ghost ?valid_sid instr];
- mkStmt ?ghost ?valid_sid (Block scope)
-
- let emptyFunctionFromVI vi =
- let r =
- { svar = vi;
- smaxid = 0;
- slocals = [];
- sformals = [];
- sbody = mkBlock [];
- smaxstmtid = None;
- sallstmts = [];
- sspec = empty_funspec ()
- }
- in
- setFormalsDecl r.svar r.svar.vtype;
- r
-
- (* Make an empty function *)
- let emptyFunction name =
- let vi =
- makeGlobalVar ~temp:false name (TFun(voidType, Some [], false,[]))
- in emptyFunctionFromVI vi
-
- let dummyFile =
- { globals = [];
- fileName = Datatype.Filepath.of_string "<dummy>";
- globinit = None;
- globinitcalled = false;}
-
- let rec lastOffset (off: offset) : offset =
- match off with
- | NoOffset | Field(_,NoOffset) | Index(_,NoOffset) -> off
- | Field(_,off) | Index(_,off) -> lastOffset off
-
- let isBitfield lval =
- match lval with
- | _, off ->
- let off = lastOffset off in
- match off with
- Field({fbitfield=Some _}, _) -> true
- | _ -> false
-
- let addOffsetLval toadd (b, off) : lval =
+ (force ||
+ match oldt, newt with
+ | TInt(ik,ai),TEnum(e,ae)
+ | TEnum(e,ae),TInt(ik,ai) when Attributes.equal ai ae ->
+ ik <> e.ekind
+ | _ -> true)
+
+let cvar_to_lvar vi = match vi.vlogic_var_assoc with
+ | None ->
+ let lv =
+ { lv_name = vi.vname;
+ lv_id = vi.vid;
+ lv_kind = LVC;
+ lv_type = Ctype vi.vtype ;
+ lv_attr = [];
+ lv_origin = Some vi}
+ in
+ vi.vlogic_var_assoc <- Some lv; lv
+ | Some lv -> lv
+
+let copyVarinfo (vi: varinfo) (newname: string) : varinfo =
+ let vi' = Cil_const.copy_with_new_vid vi in
+ vi'.vname <- newname;
+ (match vi.vlogic_var_assoc with
+ None -> ()
+ | Some _ ->
+ vi'.vlogic_var_assoc <- None;
+ ignore(cvar_to_lvar vi'));
+ vi'
+
+let rec findUniqueName ?(suffix="") fdec name =
+ let current_name = name ^ suffix in
+ (* Is this check a performance problem? We could bring the old
+ unchecked makeTempVar back as a separate function that assumes
+ the prefix name does not occur in the original program. *)
+ if (List.exists (fun vi -> vi.vname = current_name) fdec.slocals)
+ || (List.exists (fun vi -> vi.vname = current_name) fdec.sformals) then begin
+ fdec.smaxid <- 1 + fdec.smaxid;
+ findUniqueName ~suffix:("_" ^ (string_of_int (1 + fdec.smaxid))) fdec name
+ end else
+ current_name
+
+let refresh_local_name fdec vi =
+ let new_name = findUniqueName fdec vi.vname in vi.vname <- new_name
+
+let makeLocal ?(temp=false) ?referenced ?(formal=false) fdec name typ =
+ (* a helper function *)
+ let name = findUniqueName fdec name in
+ fdec.smaxid <- 1 + fdec.smaxid;
+ let vi = makeVarinfo ~temp ?referenced false formal name typ in
+ vi
+
+(* Make a local variable and add it to a function *)
+let makeLocalVar fdec ?scope ?(temp=false) ?referenced ?(insert = true) name typ =
+ let vi = makeLocal ~temp ?referenced fdec name typ in
+ refresh_local_name fdec vi;
+ if insert then
+ begin
+ fdec.slocals <- fdec.slocals @ [vi];
+ let local_block =
+ match scope with
+ | None -> fdec.sbody
+ | Some b -> b
+ in
+ local_block.blocals <- vi::local_block.blocals
+ end;
+ vi
+
+let makeTempVar fdec ?insert ?(name = "__cil_tmp") ?descr ?(descrpure = true)
+ typ : varinfo =
+ let vi = makeLocalVar fdec ~temp:true ?insert name typ in
+ vi.vdescr <- descr;
+ vi.vdescrpure <- descrpure;
+ vi
+
+(* Set the types of arguments and results as given by the function type
+ * passed as the second argument *)
+let setFunctionType (f: fundec) (t: typ) =
+ match unrollType t with
+ TFun (_rt, Some args, _va, _a) ->
+ if List.length f.sformals <> List.length args then
+ Kernel.fatal ~current:true "setFunctionType: number of arguments differs from the number of formals" ;
+ (* Change the function type. *)
+ f.svar.vtype <- t;
+ (* Change the sformals and we know that indirectly we'll change the
+ * function type *)
+ List.iter2
+ (fun (_an,at,aa) f ->
+ f.vtype <- at; f.vattr <- aa)
+ args f.sformals
+
+ | _ -> Kernel.fatal ~current:true "setFunctionType: not a function type"
+
+(* Set the types of arguments and results as given by the function type
+ passed as the second argument *)
+let setFunctionTypeMakeFormals (f: fundec) (t: typ) =
+ match unrollType t with
+ TFun (_rt, Some args, _va, _a) ->
+ if f.sformals <> [] then
+ Kernel.fatal ~current:true "setFunctionTypMakeFormals called on function %s with some formals already"
+ f.svar.vname ;
+ (* Change the function type. *)
+ f.svar.vtype <- t;
+ f.sformals <-
+ List.map (fun (n,t,_a) -> makeLocal ~formal:true f n t) args;
+ setFunctionType f t
+
+ | _ ->
+ Kernel.fatal ~current:true "setFunctionTypeMakeFormals: not a function type: %a"
+ !pp_typ_ref t
+
+let setMaxId (f: fundec) =
+ f.smaxid <- List.length f.sformals + List.length f.slocals
+
+(* Make a formal variable for a function. Insert it in both the sformals
+ * and the type of the function. You can optionally specify where to insert
+ * this one. If where = "^" then it is inserted first. If where = "$" then
+ * it is inserted last. Otherwise where must be the name of a formal after
+ * which to insert this. By default it is inserted at the end. *)
+let makeFormalVar fdec ?(where = "$") name typ : varinfo =
+ (* Search for the insertion place *)
+ let makeit name = makeLocal ~formal:true fdec name typ in
+ let rec loopFormals acc = function
+ [] ->
+ if where = "$" then
+ let vi = makeit name in vi, List.rev (vi::acc)
+ else Kernel.fatal ~current:true
+ "makeFormalVar: cannot find insert-after formal %s" where
+ | f :: rest when f.vname = where ->
+ let vi = makeit name in vi, List.rev_append acc (f :: vi :: rest)
+ | f :: rest -> loopFormals (f::acc) rest
+ in
+ let vi, newformals =
+ if where = "^" then let vi = makeit name in vi, vi :: fdec.sformals
+ else
+ loopFormals [] fdec.sformals
+ in
+ setFormals fdec newformals;
+ vi
+
+(* Make a global variable. Your responsibility to make sure that the name
+ * is unique *)
+let makeGlobalVar ?source ?temp ?referenced name typ =
+ makeVarinfo ?source ?temp ?referenced true false name typ
+
+let mkPureExprInstr ~fundec ~scope ?loc e =
+ let loc = match loc with None -> e.eloc | Some l -> l in
+ let typ = typeOf e in
+ let descr = Format.asprintf "%a" !pp_exp_ref e in
+ let tmp = makeLocalVar ~temp:true ~scope fundec "tmp" typ in
+ tmp.vdescr <- Some descr;
+ tmp.vdefined <- true;
+ Local_init(tmp, AssignInit (SingleInit e), loc)
+
+let mkPureExpr ?ghost ?valid_sid ~(fundec:fundec) ?loc (e : exp) : stmt =
+ let scope = mkBlock [] in
+ let instr = mkPureExprInstr ~fundec ~scope ?loc e in
+ scope.bstmts <- [ mkStmtOneInstr ?ghost ?valid_sid instr];
+ mkStmt ?ghost ?valid_sid (Block scope)
+
+let emptyFunctionFromVI vi =
+ let r =
+ { svar = vi;
+ smaxid = 0;
+ slocals = [];
+ sformals = [];
+ sbody = mkBlock [];
+ smaxstmtid = None;
+ sallstmts = [];
+ sspec = empty_funspec ()
+ }
+ in
+ setFormalsDecl r.svar r.svar.vtype;
+ r
+
+(* Make an empty function *)
+let emptyFunction name =
+ let vi =
+ makeGlobalVar ~temp:false name (TFun(voidType, Some [], false,[]))
+ in emptyFunctionFromVI vi
+
+let dummyFile =
+ { globals = [];
+ fileName = Datatype.Filepath.of_string "<dummy>";
+ globinit = None;
+ globinitcalled = false;}
+
+let rec lastOffset (off: offset) : offset =
+ match off with
+ | NoOffset | Field(_,NoOffset) | Index(_,NoOffset) -> off
+ | Field(_,off) | Index(_,off) -> lastOffset off
+
+let isBitfield lval =
+ match lval with
+ | _, off ->
+ let off = lastOffset off in
+ match off with
+ Field({fbitfield=Some _}, _) -> true
+ | _ -> false
+
+let addOffsetLval toadd (b, off) : lval =
b, addOffset toadd off
- let rec removeOffset (off: offset) : offset * offset =
- match off with
- NoOffset -> NoOffset, NoOffset
- | Field(_f, NoOffset) -> NoOffset, off
- | Index(_i, NoOffset) -> NoOffset, off
- | Field(f, restoff) ->
- let off', last = removeOffset restoff in
- Field(f, off'), last
- | Index(i, restoff) ->
- let off', last = removeOffset restoff in
- Index(i, off'), last
-
- let removeOffsetLval ((b, off): lval) : lval * offset =
- let off', last = removeOffset off in
- (b, off'), last
-
- class copyVisitExpr = object
- inherit genericCilVisitor (copy_visit (Project.current ()))
- method! vexpr e =
- ChangeDoChildrenPost ({e with eid = Eid.next ()}, fun x -> x)
- end
-
- let copy_exp e = visitCilExpr (new copyVisitExpr) e
-
- (** A visitor that does constant folding. If "machdep" is true then we do
- * machine dependent simplification (e.g., sizeof) *)
- class constFoldVisitorClass (machdep: bool) : cilVisitor = object
- inherit nopCilVisitor
-
- method! vinst i =
- match i with
- (* Skip two functions to which we add Sizeof to the type arguments.
- See the comments for these above. *)
- Call(_,({enode = Lval (Var vi,NoOffset)}),_,_)
- when ((vi.vname = "__builtin_va_arg")
- || (vi.vname = "__builtin_types_compatible_p")) ->
- SkipChildren
- | _ -> DoChildren
- method! vexpr (e: exp) =
- (* Do it bottom up *)
- ChangeDoChildrenPost (e, constFold machdep)
-
- end
- let constFoldVisitor (machdep: bool) = new constFoldVisitorClass machdep
-
- let rec constFoldTermNodeAtTop = function
- | TSizeOf typ as t ->
- (try integer_lconstant (bytesSizeOf typ)
- with SizeOfError _ -> t)
- | TSizeOfStr str -> integer_lconstant (String.length str + 1)
- | TAlignOf typ -> integer_lconstant (bytesAlignOf typ)
- | TSizeOfE { term_type= Ctype typ } -> constFoldTermNodeAtTop (TSizeOf typ)
- | TAlignOfE { term_type= Ctype typ }
- -> constFoldTermNodeAtTop (TAlignOf typ)
- | TSizeOfE _ | TAlignOfE _ ->
- assert false (* sizeof/alignof of logic types are rejected
- by typing anyway. *)
- | t -> t
-
- let constFoldTerm machdep t =
- let visitor = object
- inherit nopCilVisitor
- method! vterm_node t =
- if machdep then ChangeToPost (t,constFoldTermNodeAtTop)
- else DoChildren
- end
- in
- visitCilTerm visitor t
-
-
- (** Find a function or function prototype with the given name in the file.
- * If it does not exist, create a prototype with the given type, and return
- * the new varinfo. This is useful when you need to call a libc function
- * whose prototype may or may not already exist in the file.
- *
- * Because the new prototype is added to the start of the file, you shouldn't
- * refer to any struct or union types in the function type.*)
- let findOrCreateFunc (f:file) (name:string) (t:typ) : varinfo =
- let rec search glist =
- match glist with
- | GFunDecl(_, vi, _) :: _rest when vi.vname = name -> vi
- | GVarDecl(vi,_) :: _rest when vi.vname = name ->
- Kernel.fatal ~current:true
- "findOrCreateFunc: can't create %s because another global exists \
- with that name." name ;
- | _ :: rest -> search rest (* tail recursive *)
- | [] -> (*not found, so create one *)
- let t' = unrollTypeDeep t in
- let new_decl = makeGlobalVar ~temp:false name t' in
- setFormalsDecl new_decl t';
- f.globals <- GFunDecl(empty_funspec (), new_decl, Location.unknown) :: f.globals;
- new_decl
- in
- search f.globals
+let rec removeOffset (off: offset) : offset * offset =
+ match off with
+ NoOffset -> NoOffset, NoOffset
+ | Field(_f, NoOffset) -> NoOffset, off
+ | Index(_i, NoOffset) -> NoOffset, off
+ | Field(f, restoff) ->
+ let off', last = removeOffset restoff in
+ Field(f, off'), last
+ | Index(i, restoff) ->
+ let off', last = removeOffset restoff in
+ Index(i, off'), last
+
+let removeOffsetLval ((b, off): lval) : lval * offset =
+ let off', last = removeOffset off in
+ (b, off'), last
+
+class copyVisitExpr = object
+ inherit genericCilVisitor (copy_visit (Project.current ()))
+ method! vexpr e =
+ ChangeDoChildrenPost ({e with eid = Eid.next ()}, fun x -> x)
+end
+
+let copy_exp e = visitCilExpr (new copyVisitExpr) e
+
+(** A visitor that does constant folding. If "machdep" is true then we do
+ * machine dependent simplification (e.g., sizeof) *)
+class constFoldVisitorClass (machdep: bool) : cilVisitor = object
+ inherit nopCilVisitor
+
+ method! vinst i =
+ match i with
+ (* Skip two functions to which we add Sizeof to the type arguments.
+ See the comments for these above. *)
+ Call(_,({enode = Lval (Var vi,NoOffset)}),_,_)
+ when ((vi.vname = "__builtin_va_arg")
+ || (vi.vname = "__builtin_types_compatible_p")) ->
+ SkipChildren
+ | _ -> DoChildren
+ method! vexpr (e: exp) =
+ (* Do it bottom up *)
+ ChangeDoChildrenPost (e, constFold machdep)
+
+end
+let constFoldVisitor (machdep: bool) = new constFoldVisitorClass machdep
+
+let rec constFoldTermNodeAtTop = function
+ | TSizeOf typ as t ->
+ (try integer_lconstant (bytesSizeOf typ)
+ with SizeOfError _ -> t)
+ | TSizeOfStr str -> integer_lconstant (String.length str + 1)
+ | TAlignOf typ -> integer_lconstant (bytesAlignOf typ)
+ | TSizeOfE { term_type= Ctype typ } -> constFoldTermNodeAtTop (TSizeOf typ)
+ | TAlignOfE { term_type= Ctype typ }
+ -> constFoldTermNodeAtTop (TAlignOf typ)
+ | TSizeOfE _ | TAlignOfE _ ->
+ assert false (* sizeof/alignof of logic types are rejected
+ by typing anyway. *)
+ | t -> t
+
+let constFoldTerm machdep t =
+ let visitor = object
+ inherit nopCilVisitor
+ method! vterm_node t =
+ if machdep then ChangeToPost (t,constFoldTermNodeAtTop)
+ else DoChildren
+ end
+ in
+ visitCilTerm visitor t
+
+
+(** Find a function or function prototype with the given name in the file.
+ * If it does not exist, create a prototype with the given type, and return
+ * the new varinfo. This is useful when you need to call a libc function
+ * whose prototype may or may not already exist in the file.
+ *
+ * Because the new prototype is added to the start of the file, you shouldn't
+ * refer to any struct or union types in the function type.*)
+let findOrCreateFunc (f:file) (name:string) (t:typ) : varinfo =
+ let rec search glist =
+ match glist with
+ | GFunDecl(_, vi, _) :: _rest when vi.vname = name -> vi
+ | GVarDecl(vi,_) :: _rest when vi.vname = name ->
+ Kernel.fatal ~current:true
+ "findOrCreateFunc: can't create %s because another global exists \
+ with that name." name ;
+ | _ :: rest -> search rest (* tail recursive *)
+ | [] -> (*not found, so create one *)
+ let t' = unrollTypeDeep t in
+ let new_decl = makeGlobalVar ~temp:false name t' in
+ setFormalsDecl new_decl t';
+ f.globals <- GFunDecl(empty_funspec (), new_decl, Location.unknown) :: f.globals;
+ new_decl
+ in
+ search f.globals
let childrenFileSameGlobals vis f =
let fGlob g = visitCilGlobal vis g in
iterGlobals f
(fun g ->
match fGlob g with
- [g'] when g' == g -> ()
- | gl ->
- Kernel.fatal ~current:true
- "You used visitCilFileSameGlobals but \
- the global got physically changed:\n %a\nchanged to %a\n"
- !pp_global_ref g
- (Pretty_utils.pp_list ~sep:"@\n" !pp_global_ref) gl ;
+ [g'] when g' == g -> ()
+ | gl ->
+ Kernel.fatal ~current:true
+ "You used visitCilFileSameGlobals but \
+ the global got physically changed:\n %a\nchanged to %a\n"
+ !pp_global_ref g
+ (Pretty_utils.pp_list ~sep:"@\n" !pp_global_ref) gl ;
);
f
- let post_file vis f =
- let res = vis#vfile f in
- let post_action res = vis#fill_global_tables; res in
- match res with
- SkipChildren -> ChangeToPost(f, post_action)
- | JustCopy -> JustCopyPost post_action
- | JustCopyPost f -> JustCopyPost (fun x -> f (post_action x))
- | ChangeTo res -> ChangeToPost(res, post_action)
- | ChangeToPost (res, f) -> ChangeToPost (res, fun x -> f (post_action x))
- | DoChildren -> DoChildrenPost post_action
- | DoChildrenPost f -> DoChildrenPost (fun x -> f (post_action x))
- | ChangeDoChildrenPost(f,post) ->
- ChangeDoChildrenPost(f, fun x -> post (post_action x))
-
- (* A visitor for the whole file that does not change the globals *)
- let visitCilFileSameGlobals (vis : cilVisitor) (f : file) : unit =
- if vis#behavior.is_copy_behavior then
- Kernel.fatal ~current:true "You used visitCilFileSameGlobals with a copy visitor. Nothing is done"
- else
- ignore
- (doVisitCil vis vis#behavior.cfile (post_file vis) childrenFileSameGlobals f)
-
- let childrenFileCopy vis f =
- let fGlob g = visitCilGlobal vis g in
- (* Scan the globals. Make sure this is tail recursive. *)
- let rec loop (acc: global list) = function
- [] -> f.globals <- List.rev acc
- | g :: restg ->
- loop (List.rev_append (fGlob g) acc) restg
- in
- loop [] f.globals;
- (* the global initializer *)
- (match f.globinit with
+let post_file vis f =
+ let res = vis#vfile f in
+ let post_action res = vis#fill_global_tables; res in
+ match res with
+ SkipChildren -> ChangeToPost(f, post_action)
+ | JustCopy -> JustCopyPost post_action
+ | JustCopyPost f -> JustCopyPost (fun x -> f (post_action x))
+ | ChangeTo res -> ChangeToPost(res, post_action)
+ | ChangeToPost (res, f) -> ChangeToPost (res, fun x -> f (post_action x))
+ | DoChildren -> DoChildrenPost post_action
+ | DoChildrenPost f -> DoChildrenPost (fun x -> f (post_action x))
+ | ChangeDoChildrenPost(f,post) ->
+ ChangeDoChildrenPost(f, fun x -> post (post_action x))
+
+(* A visitor for the whole file that does not change the globals *)
+let visitCilFileSameGlobals (vis : cilVisitor) (f : file) : unit =
+ if vis#behavior.is_copy_behavior then
+ Kernel.fatal ~current:true "You used visitCilFileSameGlobals with a copy visitor. Nothing is done"
+ else
+ ignore
+ (doVisitCil vis vis#behavior.cfile (post_file vis) childrenFileSameGlobals f)
+
+let childrenFileCopy vis f =
+ let fGlob g = visitCilGlobal vis g in
+ (* Scan the globals. Make sure this is tail recursive. *)
+ let rec loop (acc: global list) = function
+ [] -> f.globals <- List.rev acc
+ | g :: restg ->
+ loop (List.rev_append (fGlob g) acc) restg
+ in
+ loop [] f.globals;
+ (* the global initializer *)
+ (match f.globinit with
None -> ()
| Some g -> f.globinit <- Some (visitCilFunction vis g));
- f
-
- (* Be careful with visiting the whole file because it might be huge. *)
- let visitCilFileCopy (vis : cilVisitor) (f : file) : file =
- if vis#behavior.is_copy_behavior then begin
- Queue.add Logic_env.prepare_tables vis#get_filling_actions;
- end;
- doVisitCil vis vis#behavior.cfile (post_file vis) childrenFileCopy f
-
- let visitCilFile vis f =
- if vis#behavior.is_copy_behavior then
- Kernel.fatal ~current:true "You used visitCilFile with a copy visitor. Nothing is done"
- else ignore (visitCilFileCopy vis f)
-
-
- let appears_in_expr v e =
- let module M = struct exception Found end in
- let vis = object
- inherit nopCilVisitor
- method! vvrbl v' =
- if Cil_datatype.Varinfo.equal v v' then raise M.Found;
- SkipChildren
- end
- in
- try ignore (visitCilExpr vis e); false
- with M.Found -> true
-
- (* Fold over all globals, including the global initializer *)
- let mapGlobals (fl: file)
- (doone: global -> global) : unit =
- fl.globals <- List.map doone fl.globals;
- (match fl.globinit with
+ f
+
+(* Be careful with visiting the whole file because it might be huge. *)
+let visitCilFileCopy (vis : cilVisitor) (f : file) : file =
+ if vis#behavior.is_copy_behavior then begin
+ Queue.add Logic_env.prepare_tables vis#get_filling_actions;
+ end;
+ doVisitCil vis vis#behavior.cfile (post_file vis) childrenFileCopy f
+
+let visitCilFile vis f =
+ if vis#behavior.is_copy_behavior then
+ Kernel.fatal ~current:true "You used visitCilFile with a copy visitor. Nothing is done"
+ else ignore (visitCilFileCopy vis f)
+
+
+let appears_in_expr v e =
+ let module M = struct exception Found end in
+ let vis = object
+ inherit nopCilVisitor
+ method! vvrbl v' =
+ if Cil_datatype.Varinfo.equal v v' then raise M.Found;
+ SkipChildren
+ end
+ in
+ try ignore (visitCilExpr vis e); false
+ with M.Found -> true
+
+(* Fold over all globals, including the global initializer *)
+let mapGlobals (fl: file)
+ (doone: global -> global) : unit =
+ fl.globals <- List.map doone fl.globals;
+ (match fl.globinit with
None -> ()
| Some g -> begin
match doone (GFun(g, Location.unknown)) with
- GFun(g', _) -> fl.globinit <- Some g'
+ GFun(g', _) -> fl.globinit <- Some g'
| _ -> Kernel.fatal ~current:true "mapGlobals: globinit is not a function"
- end)
-
- (***************************************************************************)
-
- (* Convert an expression into an attribute, if possible. Otherwise raise
- NotAnAttrParam *)
- exception NotAnAttrParam of exp
- let rec expToAttrParam (e: exp) : attrparam =
- match (constFold true e).enode with
- | Const(CInt64(i,k,_)) ->
- let i', _trunc = truncateInteger64 k i in
- AInt i'
- | Const(CEnum ei) -> expToAttrParam ei.eival
- | Lval (Var v, NoOffset) -> ACons(v.vname, [])
- | SizeOf t -> ASizeOf t
- | SizeOfE e' -> ASizeOfE (expToAttrParam e')
- | UnOp(uo, e', _) -> AUnOp (uo, expToAttrParam e')
- | BinOp(bo, e1',e2', _) -> ABinOp (bo, expToAttrParam e1',
- expToAttrParam e2')
- | _ -> raise (NotAnAttrParam e)
-
-
- (******************** OPTIMIZATIONS *****)
- let rec peepHole1 (* Process one statement and possibly replace it *)
- (doone: instr -> instr list option)
- (* Scan a block and recurse inside nested blocks *)
- (ss: stmt list) : unit =
- let rec doInstrList (il: instr list) : instr list =
- match il with
- [] -> []
- | i :: rest -> begin
- match doone i with
- None -> i :: doInstrList rest
- | Some sl -> doInstrList (sl @ rest)
- end
- in
- List.iter
- (fun s ->
+ end)
+
+(***************************************************************************)
+
+(* Convert an expression into an attribute, if possible. Otherwise raise
+ NotAnAttrParam *)
+exception NotAnAttrParam of exp
+let rec expToAttrParam (e: exp) : attrparam =
+ match (constFold true e).enode with
+ | Const(CInt64(i,k,_)) ->
+ let i', _trunc = truncateInteger64 k i in
+ AInt i'
+ | Const(CEnum ei) -> expToAttrParam ei.eival
+ | Lval (Var v, NoOffset) -> ACons(v.vname, [])
+ | SizeOf t -> ASizeOf t
+ | SizeOfE e' -> ASizeOfE (expToAttrParam e')
+ | UnOp(uo, e', _) -> AUnOp (uo, expToAttrParam e')
+ | BinOp(bo, e1',e2', _) -> ABinOp (bo, expToAttrParam e1',
+ expToAttrParam e2')
+ | _ -> raise (NotAnAttrParam e)
+
+
+(******************** OPTIMIZATIONS *****)
+let rec peepHole1 (* Process one statement and possibly replace it *)
+ (doone: instr -> instr list option)
+ (* Scan a block and recurse inside nested blocks *)
+ (ss: stmt list) : unit =
+ let rec doInstrList (il: instr list) : instr list =
+ match il with
+ [] -> []
+ | i :: rest -> begin
+ match doone i with
+ None -> i :: doInstrList rest
+ | Some sl -> doInstrList (sl @ rest)
+ end
+ in
+ List.iter
+ (fun s ->
begin match s.skind with
- | Instr i -> s.skind <- stmt_of_instr_list (doInstrList [i])
- | If (_e, tb, eb, _) ->
- peepHole1 doone tb.bstmts;
- peepHole1 doone eb.bstmts
- | Switch (_e, b, _, _) -> peepHole1 doone b.bstmts
- | Loop (_, b, _l, _, _) -> peepHole1 doone b.bstmts
- | Block b -> peepHole1 doone b.bstmts
- | UnspecifiedSequence seq ->
- peepHole1 doone (List.map (fun (x,_,_,_,_) -> x) seq)
- | TryCatch(b,l,_) ->
- peepHole1 doone b.bstmts;
- List.iter (fun (_,b) -> peepHole1 doone b.bstmts) l
- | TryFinally (b, h, _l) ->
- peepHole1 doone b.bstmts;
- peepHole1 doone h.bstmts
- | TryExcept (b, (il, e), h, l) ->
- peepHole1 doone b.bstmts;
- peepHole1 doone h.bstmts;
- s.skind <- TryExcept(b, (doInstrList il, e), h, l);
- | Return _ | Goto _ | Break _ | Continue _ | Throw _ -> ()
+ | Instr i -> s.skind <- stmt_of_instr_list (doInstrList [i])
+ | If (_e, tb, eb, _) ->
+ peepHole1 doone tb.bstmts;
+ peepHole1 doone eb.bstmts
+ | Switch (_e, b, _, _) -> peepHole1 doone b.bstmts
+ | Loop (_, b, _l, _, _) -> peepHole1 doone b.bstmts
+ | Block b -> peepHole1 doone b.bstmts
+ | UnspecifiedSequence seq ->
+ peepHole1 doone (List.map (fun (x,_,_,_,_) -> x) seq)
+ | TryCatch(b,l,_) ->
+ peepHole1 doone b.bstmts;
+ List.iter (fun (_,b) -> peepHole1 doone b.bstmts) l
+ | TryFinally (b, h, _l) ->
+ peepHole1 doone b.bstmts;
+ peepHole1 doone h.bstmts
+ | TryExcept (b, (il, e), h, l) ->
+ peepHole1 doone b.bstmts;
+ peepHole1 doone h.bstmts;
+ s.skind <- TryExcept(b, (doInstrList il, e), h, l);
+ | Return _ | Goto _ | Break _ | Continue _ | Throw _ -> ()
end ;
enforceGhostStmtCoherence s)
- ss
-
- (* Process two statements and possibly replace them both *)
- let rec peepHole2 ~aggressive (dotwo: stmt * stmt -> stmt list option) (ss: stmt list) =
- let rec doStmtList acc (il: stmt list) : stmt list =
- match il with
- [] -> List.rev acc
- | [i] -> process i; List.rev (i::acc)
- | (i1 :: ((i2 :: rest) as rest2)) ->
- begin
- match dotwo (i1,i2) with
- None -> process i1; doStmtList (i1::acc) rest2
- | Some sl ->
- if aggressive then
- doStmtList acc (sl @ rest)
- else
- doStmtList (List.rev_append sl acc) rest
- end
- and doUnspecifiedStmtList il =
- match il with
- [] -> []
- | [ (s,_,_,_,_) ] -> process s; il
- | ((i1,m1,w1,r1,_) as hd)::(((i2,m2,w2,r2,_)::rest) as rest2) ->
- begin
- match dotwo (i1,i2) with
- None -> process i1; hd :: doUnspecifiedStmtList rest2
- | Some [] -> doUnspecifiedStmtList rest
- | Some (hd::tl) ->
- let call s = match s.skind with
- | Instr(Call _ | Local_init (_, ConsInit _, _)) -> [ref s]
- | _ -> []
- in
- let res =
- (hd, m1@m2, w1 @ w2, r1 @ r2,call hd) ::
- (List.map (fun x -> x,[],[],[],call x) tl)
- in
- if aggressive then doUnspecifiedStmtList (res @ rest)
- else res @ doUnspecifiedStmtList rest
- end
- and process s =
- match s.skind with
- Instr _i -> ()
- | If (_e, tb, eb, _) ->
- tb.bstmts <- peepHole2 ~aggressive dotwo tb.bstmts;
- eb.bstmts <- peepHole2 ~aggressive dotwo eb.bstmts
- | Switch (_e, b, _, _) -> b.bstmts <- peepHole2 ~aggressive dotwo b.bstmts
- | Loop (_, b, _l, _, _) -> b.bstmts <- peepHole2 ~aggressive dotwo b.bstmts
- | Block b -> b.bstmts <- doStmtList [] b.bstmts
- | TryCatch (b,l,_) ->
- b.bstmts <- peepHole2 ~aggressive dotwo b.bstmts;
- List.iter
- (fun (_,b) ->
- b.bstmts <- peepHole2 ~aggressive dotwo b.bstmts)
- l
- | TryFinally (b, h, _l) ->
- b.bstmts <- peepHole2 ~aggressive dotwo b.bstmts;
- b.bstmts <- peepHole2 ~aggressive dotwo h.bstmts
- | TryExcept (b, (_il, _e), h, _l) ->
- b.bstmts <- peepHole2 ~aggressive dotwo b.bstmts;
- h.bstmts <- peepHole2 ~aggressive dotwo h.bstmts;
- () (*s.skind <- TryExcept (b, (doInstrList il, e), h, l)*)
-
- | UnspecifiedSequence seq ->
- s.skind <- UnspecifiedSequence (doUnspecifiedStmtList seq)
- | Return _ | Goto _ | Break _ | Continue _ | Throw _ -> ()
- in
- if aggressive then List.iter process ss;
- doStmtList [] ss
-
- (* Make an AddrOf. Given an lval of type T will give back an expression of
- * type ptr(T) *)
- let mkAddrOf ~loc ((_b, _off) as lval) : exp =
- (* Never take the address of a register variable *)
- (match lval with
+ ss
+
+(* Process two statements and possibly replace them both *)
+let rec peepHole2 ~aggressive (dotwo: stmt * stmt -> stmt list option) (ss: stmt list) =
+ let rec doStmtList acc (il: stmt list) : stmt list =
+ match il with
+ [] -> List.rev acc
+ | [i] -> process i; List.rev (i::acc)
+ | (i1 :: ((i2 :: rest) as rest2)) ->
+ begin
+ match dotwo (i1,i2) with
+ None -> process i1; doStmtList (i1::acc) rest2
+ | Some sl ->
+ if aggressive then
+ doStmtList acc (sl @ rest)
+ else
+ doStmtList (List.rev_append sl acc) rest
+ end
+ and doUnspecifiedStmtList il =
+ match il with
+ [] -> []
+ | [ (s,_,_,_,_) ] -> process s; il
+ | ((i1,m1,w1,r1,_) as hd)::(((i2,m2,w2,r2,_)::rest) as rest2) ->
+ begin
+ match dotwo (i1,i2) with
+ None -> process i1; hd :: doUnspecifiedStmtList rest2
+ | Some [] -> doUnspecifiedStmtList rest
+ | Some (hd::tl) ->
+ let call s = match s.skind with
+ | Instr(Call _ | Local_init (_, ConsInit _, _)) -> [ref s]
+ | _ -> []
+ in
+ let res =
+ (hd, m1@m2, w1 @ w2, r1 @ r2,call hd) ::
+ (List.map (fun x -> x,[],[],[],call x) tl)
+ in
+ if aggressive then doUnspecifiedStmtList (res @ rest)
+ else res @ doUnspecifiedStmtList rest
+ end
+ and process s =
+ match s.skind with
+ Instr _i -> ()
+ | If (_e, tb, eb, _) ->
+ tb.bstmts <- peepHole2 ~aggressive dotwo tb.bstmts;
+ eb.bstmts <- peepHole2 ~aggressive dotwo eb.bstmts
+ | Switch (_e, b, _, _) -> b.bstmts <- peepHole2 ~aggressive dotwo b.bstmts
+ | Loop (_, b, _l, _, _) -> b.bstmts <- peepHole2 ~aggressive dotwo b.bstmts
+ | Block b -> b.bstmts <- doStmtList [] b.bstmts
+ | TryCatch (b,l,_) ->
+ b.bstmts <- peepHole2 ~aggressive dotwo b.bstmts;
+ List.iter
+ (fun (_,b) ->
+ b.bstmts <- peepHole2 ~aggressive dotwo b.bstmts)
+ l
+ | TryFinally (b, h, _l) ->
+ b.bstmts <- peepHole2 ~aggressive dotwo b.bstmts;
+ b.bstmts <- peepHole2 ~aggressive dotwo h.bstmts
+ | TryExcept (b, (_il, _e), h, _l) ->
+ b.bstmts <- peepHole2 ~aggressive dotwo b.bstmts;
+ h.bstmts <- peepHole2 ~aggressive dotwo h.bstmts;
+ () (*s.skind <- TryExcept (b, (doInstrList il, e), h, l)*)
+
+ | UnspecifiedSequence seq ->
+ s.skind <- UnspecifiedSequence (doUnspecifiedStmtList seq)
+ | Return _ | Goto _ | Break _ | Continue _ | Throw _ -> ()
+ in
+ if aggressive then List.iter process ss;
+ doStmtList [] ss
+
+(* Make an AddrOf. Given an lval of type T will give back an expression of
+ * type ptr(T) *)
+let mkAddrOf ~loc ((_b, _off) as lval) : exp =
+ (* Never take the address of a register variable *)
+ (match lval with
Var vi, _off when vi.vstorage = Register -> vi.vstorage <- NoStorage
| _ -> ());
- match lval with
- Mem e, NoOffset -> e
- | b, Index(z, NoOffset) when isZero z -> new_exp ~loc (StartOf (b, NoOffset))
+ match lval with
+ Mem e, NoOffset -> e
+ | b, Index(z, NoOffset) when isZero z -> new_exp ~loc (StartOf (b, NoOffset))
(* array *)
- | _ -> new_exp ~loc (AddrOf lval)
-
- let mkAddrOfVi vi = mkAddrOf vi.vdecl (var vi)
-
- let mkAddrOrStartOf ~loc (lv: lval) : exp =
- match unrollTypeSkel (typeOfLval lv) with
- TArray _ -> new_exp ~loc (StartOf lv)
- | _ -> mkAddrOf ~loc lv
-
- let mkMem ~(addr: exp) ~(off: offset) : lval =
- let res =
- match addr.enode, off with
- | AddrOf lv, _ -> addOffsetLval off lv
- | StartOf lv, _ -> (* Must be an array *)
- addOffsetLval (Index(zero ~loc:addr.eloc, off)) lv
- | _, _ -> Mem addr, off
- in
- (* ignore (E.log "memof : %a:%a\nresult = %a\n" d_plainexp addr d_plainoffset
- off d_plainexp res); *)
- res
-
- let mkTermMem ~(addr: term) ~(off: term_offset) : term_lval =
- let loc = addr.term_loc in
- let res =
- match addr.term_node, off with
- TAddrOf lv, _ -> addTermOffsetLval off lv
- | TStartOf lv, _ -> (* Must be an array *)
- addTermOffsetLval (TIndex(lzero ~loc (), off)) lv
- | _, _ -> TMem addr, off
- in
- (* ignore (E.log "memof : %a:%a\nresult = %a\n"
- d_plainexp addr d_plainoffset off d_plainexp res); *)
- res
-
- let treat_constructor_as_func action v f args kind loc =
- let lv, args =
- match kind with
- | Plain_func -> Some (var v), args
- | Constructor -> None, mkAddrOfVi v :: args
- in
- action lv (evar f) args loc
-
- let fold_local_init b f acc =
- let rec find_stmt acc s =
- match s.skind with
- | Instr(Local_init(v',i,l)) -> f s (v',i,l) acc
- | UnspecifiedSequence l -> List.fold_left find_stmt_seq acc l
- | Block b when not b.bscoping -> List.fold_left find_stmt acc b.bstmts
- | _ -> acc
- and find_stmt_seq acc (s, _, _, _, _) = find_stmt acc s
- in
- List.fold_left find_stmt acc b.bstmts
-
- let find_def_stmt b v =
- if not (v.vdefined && List.exists (Cil_datatype.Varinfo.equal v) b.blocals)
- then Kernel.fatal "inconsistent arguments for find_def_stmt";
- let module M = struct exception Found of stmt end in
- let action s (v',_,_) () =
- if Cil_datatype.Varinfo.equal v v' then raise (M.Found s) else ()
- in
- try
- fold_local_init b action ();
- Kernel.fatal ~source:(fst v.vdecl)
- "inconsistent AST: local variable %a is supposed to be initialized, \
- but no initialization statement found." Cil_datatype.Varinfo.pretty v
- with M.Found s -> s
-
- let has_extern_local_init b =
- (* a scoping block defines all the locals inside it.*)
- if b.bscoping then false
- else begin
- let action _ _ () = raise Exit in
- try fold_local_init b action (); false with Exit -> true
- end
-
- let splitFunctionType (ftype: typ)
- : typ * (string * typ * attributes) list option * bool * attributes =
- match unrollType ftype with
- TFun (rt, args, isva, a) -> rt, args, isva, a
- | _ -> Kernel.fatal ~current:true "splitFunctionType invoked on a non function type %a"
- !pp_typ_ref ftype
-
- let splitFunctionTypeVI (fvi: varinfo)
- : typ * (string * typ * attributes) list option * bool * attributes =
- match unrollType fvi.vtype with
- TFun (rt, args, isva, a) -> rt, args, isva, a
- | _ -> Kernel.abort "Function %s invoked on a non function type" fvi.vname
-
- let remove_attributes_for_integral_promotion a =
- dropAttributes (bitfield_attribute_name :: spare_attributes_for_c_cast) a
-
- let rec integralPromotion t = (* c.f. ISO 6.3.1.1 *)
- match unrollType t with
- | TInt ((IShort|ISChar|IBool), a) ->
- let a = remove_attributes_for_integral_promotion a in
- TInt(IInt, a)
- | TInt (IUChar|IUShort as k, a) ->
- let a = remove_attributes_for_integral_promotion a in
- if bitsSizeOfInt k < bitsSizeOf intType then
- TInt(IInt, a)
- else
- TInt(IUInt,a)
- | TInt (IChar,a) ->
- let k = if isSigned IChar then ISChar else IUChar in
- integralPromotion (TInt (k, a))
- | TInt (k,a) ->
- begin match findAttribute bitfield_attribute_name a with
- | [AInt size] ->
- (* This attribute always fits in int. *)
- let size = Integer.to_int size in
- let sizeofint = bitsSizeOf intType in
- let attrs = remove_attributes_for_integral_promotion a in
- let kind =
- if size < sizeofint then IInt
- else if size = sizeofint then
- if isSigned k then IInt
- else IUInt
- else k
- in
- TInt(kind,attrs)
- | [] -> t
- | _ -> assert false
- end
- | TEnum (ei, a) -> (* gcc packed enums can be < int *)
- integralPromotion (TInt(ei.ekind, a))
- | t -> Kernel.fatal ~current:true "integralPromotion: not expecting %a" !pp_typ_ref t
-
- let arithmeticConversion t1 t2 = (* c.f. ISO 6.3.1.8 *)
+ | _ -> new_exp ~loc (AddrOf lval)
+
+let mkAddrOfVi vi = mkAddrOf vi.vdecl (var vi)
+
+let mkAddrOrStartOf ~loc (lv: lval) : exp =
+ match unrollTypeSkel (typeOfLval lv) with
+ TArray _ -> new_exp ~loc (StartOf lv)
+ | _ -> mkAddrOf ~loc lv
+
+let mkMem ~(addr: exp) ~(off: offset) : lval =
+ let res =
+ match addr.enode, off with
+ | AddrOf lv, _ -> addOffsetLval off lv
+ | StartOf lv, _ -> (* Must be an array *)
+ addOffsetLval (Index(zero ~loc:addr.eloc, off)) lv
+ | _, _ -> Mem addr, off
+ in
+ (* ignore (E.log "memof : %a:%a\nresult = %a\n" d_plainexp addr d_plainoffset
+ off d_plainexp res); *)
+ res
+
+let mkTermMem ~(addr: term) ~(off: term_offset) : term_lval =
+ let loc = addr.term_loc in
+ let res =
+ match addr.term_node, off with
+ TAddrOf lv, _ -> addTermOffsetLval off lv
+ | TStartOf lv, _ -> (* Must be an array *)
+ addTermOffsetLval (TIndex(lzero ~loc (), off)) lv
+ | _, _ -> TMem addr, off
+ in
+ (* ignore (E.log "memof : %a:%a\nresult = %a\n"
+ d_plainexp addr d_plainoffset off d_plainexp res); *)
+ res
+
+let treat_constructor_as_func action v f args kind loc =
+ let lv, args =
+ match kind with
+ | Plain_func -> Some (var v), args
+ | Constructor -> None, mkAddrOfVi v :: args
+ in
+ action lv (evar f) args loc
+
+let fold_local_init b f acc =
+ let rec find_stmt acc s =
+ match s.skind with
+ | Instr(Local_init(v',i,l)) -> f s (v',i,l) acc
+ | UnspecifiedSequence l -> List.fold_left find_stmt_seq acc l
+ | Block b when not b.bscoping -> List.fold_left find_stmt acc b.bstmts
+ | _ -> acc
+ and find_stmt_seq acc (s, _, _, _, _) = find_stmt acc s
+ in
+ List.fold_left find_stmt acc b.bstmts
+
+let find_def_stmt b v =
+ if not (v.vdefined && List.exists (Cil_datatype.Varinfo.equal v) b.blocals)
+ then Kernel.fatal "inconsistent arguments for find_def_stmt";
+ let module M = struct exception Found of stmt end in
+ let action s (v',_,_) () =
+ if Cil_datatype.Varinfo.equal v v' then raise (M.Found s) else ()
+ in
+ try
+ fold_local_init b action ();
+ Kernel.fatal ~source:(fst v.vdecl)
+ "inconsistent AST: local variable %a is supposed to be initialized, \
+ but no initialization statement found." Cil_datatype.Varinfo.pretty v
+ with M.Found s -> s
+
+let has_extern_local_init b =
+ (* a scoping block defines all the locals inside it.*)
+ if b.bscoping then false
+ else begin
+ let action _ _ () = raise Exit in
+ try fold_local_init b action (); false with Exit -> true
+ end
+
+let splitFunctionType (ftype: typ)
+ : typ * (string * typ * attributes) list option * bool * attributes =
+ match unrollType ftype with
+ TFun (rt, args, isva, a) -> rt, args, isva, a
+ | _ -> Kernel.fatal ~current:true "splitFunctionType invoked on a non function type %a"
+ !pp_typ_ref ftype
+
+let splitFunctionTypeVI (fvi: varinfo)
+ : typ * (string * typ * attributes) list option * bool * attributes =
+ match unrollType fvi.vtype with
+ TFun (rt, args, isva, a) -> rt, args, isva, a
+ | _ -> Kernel.abort "Function %s invoked on a non function type" fvi.vname
+
+let remove_attributes_for_integral_promotion a =
+ dropAttributes (bitfield_attribute_name :: spare_attributes_for_c_cast) a
+
+let rec integralPromotion t = (* c.f. ISO 6.3.1.1 *)
+ match unrollType t with
+ | TInt ((IShort|ISChar|IBool), a) ->
+ let a = remove_attributes_for_integral_promotion a in
+ TInt(IInt, a)
+ | TInt (IUChar|IUShort as k, a) ->
+ let a = remove_attributes_for_integral_promotion a in
+ if bitsSizeOfInt k < bitsSizeOf intType then
+ TInt(IInt, a)
+ else
+ TInt(IUInt,a)
+ | TInt (IChar,a) ->
+ let k = if isSigned IChar then ISChar else IUChar in
+ integralPromotion (TInt (k, a))
+ | TInt (k,a) ->
+ begin match findAttribute bitfield_attribute_name a with
+ | [AInt size] ->
+ (* This attribute always fits in int. *)
+ let size = Integer.to_int size in
+ let sizeofint = bitsSizeOf intType in
+ let attrs = remove_attributes_for_integral_promotion a in
+ let kind =
+ if size < sizeofint then IInt
+ else if size = sizeofint then
+ if isSigned k then IInt
+ else IUInt
+ else k
+ in
+ TInt(kind,attrs)
+ | [] -> t
+ | _ -> assert false
+ end
+ | TEnum (ei, a) -> (* gcc packed enums can be < int *)
+ integralPromotion (TInt(ei.ekind, a))
+ | t -> Kernel.fatal ~current:true "integralPromotion: not expecting %a" !pp_typ_ref t
+
+let arithmeticConversion t1 t2 = (* c.f. ISO 6.3.1.8 *)
let checkToInt _ = () in (* dummies for now *)
let checkToFloat _ = () in
match unrollTypeSkel t1, unrollTypeSkel t2 with
@@ -6930,11 +6930,11 @@ let childrenFileSameGlobals vis f =
| _, TInt(IULongLong, _) -> checkToInt t1'; t2'
| TInt(ILongLong,_), _
- when bitsSizeOf t1' <= bitsSizeOf t2' &&
- (not (isSignedInteger t2')) -> TInt(IULongLong,[])
+ when bitsSizeOf t1' <= bitsSizeOf t2' &&
+ (not (isSignedInteger t2')) -> TInt(IULongLong,[])
| _, TInt(ILongLong,_)
- when bitsSizeOf t2' <= bitsSizeOf t1' &&
- (not (isSignedInteger t1')) -> TInt(IULongLong,[])
+ when bitsSizeOf t2' <= bitsSizeOf t1' &&
+ (not (isSignedInteger t1')) -> TInt(IULongLong,[])
| TInt(ILongLong, _), _ -> checkToInt t2'; t1'
| _, TInt(ILongLong, _) -> checkToInt t1'; t2'
@@ -6944,9 +6944,9 @@ let childrenFileSameGlobals vis f =
| TInt(ILong,_), TInt(IUInt,_)
- when bitsSizeOf t1' <= bitsSizeOf t2' -> TInt(IULong,[])
+ when bitsSizeOf t1' <= bitsSizeOf t2' -> TInt(IULong,[])
| TInt(IUInt,_), TInt(ILong,_)
- when bitsSizeOf t2' <= bitsSizeOf t1' -> TInt(IULong,[])
+ when bitsSizeOf t2' <= bitsSizeOf t1' -> TInt(IULong,[])
| TInt(ILong, _), _ -> checkToInt t2'; t1'
| _, TInt(ILong, _) -> checkToInt t1'; t2'
@@ -6958,11 +6958,11 @@ let childrenFileSameGlobals vis f =
| t1, t2 ->
Kernel.fatal ~current:true "arithmeticConversion %a -> %a@." !pp_typ_ref t1 !pp_typ_ref t2
- end
+ end
let isArrayType t = match unrollTypeSkel t with
- | TArray _ -> true
- | _ -> false
+ | TArray _ -> true
+ | _ -> false
let isAnyCharArrayType t = match unrollTypeSkel t with
| TArray(tau,_,_,_) when isAnyCharType tau -> true
@@ -7008,8 +7008,8 @@ let isConstantOffset o = isConstantOffsetGen alphatrue o
let isIntegerConstant e =
isConstantGen
(function
- | CInt64 _ | CChr _ | CEnum _ -> true
- | CStr _ | CWStr _ | CReal _ -> false)
+ | CInt64 _ | CChr _ | CEnum _ -> true
+ | CStr _ | CWStr _ | CReal _ -> false)
e
let getCompField cinfo fieldName =
@@ -7017,12 +7017,12 @@ let getCompField cinfo fieldName =
let mkCastT ?(force=false) ~(e: exp) ~(oldt: typ) ~(newt: typ) =
let loc = e.eloc in
-(* Issue #!1546
- let force = force ||
- (* see warning of need_cast function:
- [false] as default value for that option is not safe... *)
- (match e.enode with | Const(CEnum _) -> false | _ -> true)
- in *)
+ (* Issue #!1546
+ let force = force ||
+ (* see warning of need_cast function:
+ [false] as default value for that option is not safe... *)
+ (match e.enode with | Const(CEnum _) -> false | _ -> true)
+ in *)
if need_cast ~force oldt newt then begin
let target_type =
match newt with
@@ -7036,203 +7036,203 @@ let mkCastT ?(force=false) ~(e: exp) ~(oldt: typ) ~(newt: typ) =
match unrollType newt, e.enode with
(* In the case were we have a representation for the literal,
explicitly add the cast. *)
- | TInt(newik, []), Const(CInt64(i, _, None)) ->
+ | TInt(newik, []), Const(CInt64(i, _, None)) ->
kinteger64 ~loc ~kind:newik i
| TPtr _, CastE (_, e') ->
(match unrollType (typeOf e'), e'.enode with
- | (TPtr _ as typ''), _ ->
- (* Old cast can be removed...*)
- if need_cast ~force newt typ'' then mk_cast e'
- else (* In fact, both casts can be removed. *) e'
- | _, Const(CInt64 (i, _, _)) when Integer.is_zero i -> mk_cast e'
- | _ -> mk_cast e)
- | _ ->
- (* Do not remove old casts because they are conversions !!! *)
+ | (TPtr _ as typ''), _ ->
+ (* Old cast can be removed...*)
+ if need_cast ~force newt typ'' then mk_cast e'
+ else (* In fact, both casts can be removed. *) e'
+ | _, Const(CInt64 (i, _, _)) when Integer.is_zero i -> mk_cast e'
+ | _ -> mk_cast e)
+ | _ ->
+ (* Do not remove old casts because they are conversions !!! *)
mk_cast e
end else
e
- let mkCast ?force ~(e: exp) ~(newt: typ) =
- mkCastT ?force ~e ~oldt:(typeOf e) ~newt
+let mkCast ?force ~(e: exp) ~(newt: typ) =
+ mkCastT ?force ~e ~oldt:(typeOf e) ~newt
(* TODO: unify this with doBinOp in Cabs2cil. *)
- let mkBinOp ~loc op e1 e2 =
- let t1 = typeOf e1 in
- let t2 = typeOf e2 in
- let machdep = false in
- let make_expr common_type res_type =
- constFoldBinOp ~loc machdep op
- (mkCastT e1 t1 common_type)
- (mkCastT e2 t2 common_type)
- res_type
- in
- let doArithmetic () =
- let tres = arithmeticConversion t1 t2 in
- make_expr tres tres
- in
- let doArithmeticComp () =
- let tres = arithmeticConversion t1 t2 in
- make_expr tres intType
- in
- let doIntegralArithmetic () =
- let tres = arithmeticConversion t1 t2 in
- if isIntegralType tres then
- make_expr tres tres
- else
- Kernel.fatal ~current:true "mkBinOp: %a" !pp_exp_ref (dummy_exp(BinOp(op,e1,e2,intType)))
- in
- let compare_pointer op ?cast1 ?cast2 e1 e2 =
- let do_cast e = function
- | None -> e
- | Some t' -> mkCastT ~force:false ~e ~oldt:(typeOf e) ~newt:t'
- in
- let e1, e2 =
- if need_cast ~force:true (typeOf e1) (typeOf e2) then
- do_cast e1 cast1, do_cast e2 cast2
- else
- e1, e2
- in
- constFoldBinOp ~loc machdep op e1 e2 intType
- in
- match op with
- (Mult|Div) -> doArithmetic ()
- | (Mod|BAnd|BOr|BXor|LAnd|LOr) -> doIntegralArithmetic ()
- | (Shiftlt|Shiftrt) -> (* ISO 6.5.7. Only integral promotions. The result
- * has the same type as the left hand side *)
- if msvcMode () then
- (* MSVC has a bug. We duplicate it here *)
- doIntegralArithmetic ()
- else
- let t1' = integralPromotion t1 in
- let t2' = integralPromotion t2 in
- constFoldBinOp ~loc machdep op
- (mkCastT e1 t1 t1') (mkCastT e2 t2 t2') t1'
- | (PlusA|MinusA)
- when isArithmeticType t1 && isArithmeticType t2 -> doArithmetic ()
- | (PlusPI|MinusPI|IndexPI) when isPointerType t1 && isIntegralType t2 ->
- constFoldBinOp ~loc machdep op e1 e2 t1
- | MinusPP when isPointerType t1 && isPointerType t2 ->
- (* NB: Same as cabs2cil. Check if this is really what the standard says*)
- constFoldBinOp ~loc machdep op e1 (mkCastT e2 t2 t1) intType
- | (Eq|Ne|Lt|Le|Ge|Gt)
- when isArithmeticType t1 && isArithmeticType t2 ->
- doArithmeticComp ()
- | (Eq|Ne) when isPointerType t1 && isZero e2 ->
- compare_pointer ~cast2:t1 op e1 (zero ~loc)
- | (Eq|Ne) when isPointerType t2 && isZero e1 ->
- compare_pointer ~cast1:t2 op (zero ~loc) e2
- | (Eq|Ne) when isVariadicListType t1 && isZero e2 ->
- Kernel.debug ~level:3 "Comparison of va_list and zero";
- compare_pointer ~cast2:t1 op e1 (zero ~loc)
- | (Eq|Ne) when isVariadicListType t2 && isZero e1 ->
- Kernel.debug ~level:3 "Comparison of zero and va_list";
- compare_pointer ~cast1:t2 op (zero ~loc) e2
- | (Le|Lt|Ge|Gt|Eq|Ne) when isPointerType t1 && isPointerType t2 ->
- compare_pointer ~cast1:theMachine.upointType ~cast2:theMachine.upointType
- op e1 e2
- | _ ->
- Kernel.fatal ~current:true "mkBinOp: %a"
- !pp_exp_ref (dummy_exp(BinOp(op,e1,e2,intType)))
-
- let mkBinOp_safe_ptr_cmp ~loc op e1 e2 =
- let e1, e2 =
- match op with
- | (Eq | Ne | Lt | Le | Ge | Gt) ->
- let t1 = typeOf e1 in
- let t2 = typeOf e2 in
- if isPointerType t1 && isPointerType t2
- && not (isZero e1) && not (isZero e2)
- then begin
- mkCast ~force:true ~e:e1 ~newt:theMachine.upointType,
- mkCast ~force:true ~e:e2 ~newt:theMachine.upointType
- end else e1, e2
- | _ -> e1, e2
- in
- mkBinOp ~loc op e1 e2
-
- type existsAction =
- ExistsTrue (* We have found it *)
- | ExistsFalse (* Stop processing this branch *)
- | ExistsMaybe (* This node is not what we are
- * looking for but maybe its
- * successors are *)
- let existsType (f: typ -> existsAction) (t: typ) : bool =
- let memo : (int, unit) Hashtbl.t = Hashtbl.create 17 in (* Memo table *)
- let rec loop t =
- match f t with
- ExistsTrue -> true
- | ExistsFalse -> false
- | ExistsMaybe ->
- (match t with
- TNamed (t', _) -> loop t'.ttype
- | TComp (c, _,_) -> loopComp c
- | TArray (t', _, _, _) -> loop t'
- | TPtr (t', _) -> loop t'
- | TFun (rt, args, _, _) ->
- (loop rt || List.exists (fun (_, at, _) -> loop at)
- (argsToList args))
- | _ -> false)
- and loopComp c =
- if Hashtbl.mem memo c.ckey then
- (* We are looping, the answer must be false *)
- false
- else begin
- Hashtbl.add memo c.ckey ();
- List.exists (fun f -> loop f.ftype) c.cfields
- end
- in
- loop t
-
-
- (* Try to do an increment, with constant folding *)
- let increm (e: exp) (i: int) =
- let e' = constFold false e in
- let et = typeOf e' in
- let bop = if isPointerType et then PlusPI else PlusA in
- let i = match et with
- | TInt (k, _) | TEnum ({ekind = k },_) -> kinteger k ~loc:e.eloc i
- | _ -> integer ~loc:e.eloc i
- in
- constFoldBinOp ~loc:e.eloc false bop e' i et
-
- (* Try to do an increment, with constant folding *)
- let increm64 (e: exp) i =
- let et = typeOf e in
- let bop = if isPointerType et then PlusPI else PlusA in
- constFold
- false
- (new_exp ~loc:e.eloc (BinOp(bop, e, kinteger64 ~loc:e.eloc i, et)))
-
- exception LenOfArray
- let lenOfArray64 eo =
- match eo with
- None -> raise LenOfArray
- | Some e -> begin
- match (constFold true e).enode with
- | Const(CInt64(ni, _, _)) when Integer.ge ni Integer.zero ->
- ni
- | _ -> raise LenOfArray
- end
- let lenOfArray eo = Integer.to_int (lenOfArray64 eo)
+let mkBinOp ~loc op e1 e2 =
+ let t1 = typeOf e1 in
+ let t2 = typeOf e2 in
+ let machdep = false in
+ let make_expr common_type res_type =
+ constFoldBinOp ~loc machdep op
+ (mkCastT e1 t1 common_type)
+ (mkCastT e2 t2 common_type)
+ res_type
+ in
+ let doArithmetic () =
+ let tres = arithmeticConversion t1 t2 in
+ make_expr tres tres
+ in
+ let doArithmeticComp () =
+ let tres = arithmeticConversion t1 t2 in
+ make_expr tres intType
+ in
+ let doIntegralArithmetic () =
+ let tres = arithmeticConversion t1 t2 in
+ if isIntegralType tres then
+ make_expr tres tres
+ else
+ Kernel.fatal ~current:true "mkBinOp: %a" !pp_exp_ref (dummy_exp(BinOp(op,e1,e2,intType)))
+ in
+ let compare_pointer op ?cast1 ?cast2 e1 e2 =
+ let do_cast e = function
+ | None -> e
+ | Some t' -> mkCastT ~force:false ~e ~oldt:(typeOf e) ~newt:t'
+ in
+ let e1, e2 =
+ if need_cast ~force:true (typeOf e1) (typeOf e2) then
+ do_cast e1 cast1, do_cast e2 cast2
+ else
+ e1, e2
+ in
+ constFoldBinOp ~loc machdep op e1 e2 intType
+ in
+ match op with
+ (Mult|Div) -> doArithmetic ()
+ | (Mod|BAnd|BOr|BXor|LAnd|LOr) -> doIntegralArithmetic ()
+ | (Shiftlt|Shiftrt) -> (* ISO 6.5.7. Only integral promotions. The result
+ * has the same type as the left hand side *)
+ if msvcMode () then
+ (* MSVC has a bug. We duplicate it here *)
+ doIntegralArithmetic ()
+ else
+ let t1' = integralPromotion t1 in
+ let t2' = integralPromotion t2 in
+ constFoldBinOp ~loc machdep op
+ (mkCastT e1 t1 t1') (mkCastT e2 t2 t2') t1'
+ | (PlusA|MinusA)
+ when isArithmeticType t1 && isArithmeticType t2 -> doArithmetic ()
+ | (PlusPI|MinusPI|IndexPI) when isPointerType t1 && isIntegralType t2 ->
+ constFoldBinOp ~loc machdep op e1 e2 t1
+ | MinusPP when isPointerType t1 && isPointerType t2 ->
+ (* NB: Same as cabs2cil. Check if this is really what the standard says*)
+ constFoldBinOp ~loc machdep op e1 (mkCastT e2 t2 t1) intType
+ | (Eq|Ne|Lt|Le|Ge|Gt)
+ when isArithmeticType t1 && isArithmeticType t2 ->
+ doArithmeticComp ()
+ | (Eq|Ne) when isPointerType t1 && isZero e2 ->
+ compare_pointer ~cast2:t1 op e1 (zero ~loc)
+ | (Eq|Ne) when isPointerType t2 && isZero e1 ->
+ compare_pointer ~cast1:t2 op (zero ~loc) e2
+ | (Eq|Ne) when isVariadicListType t1 && isZero e2 ->
+ Kernel.debug ~level:3 "Comparison of va_list and zero";
+ compare_pointer ~cast2:t1 op e1 (zero ~loc)
+ | (Eq|Ne) when isVariadicListType t2 && isZero e1 ->
+ Kernel.debug ~level:3 "Comparison of zero and va_list";
+ compare_pointer ~cast1:t2 op (zero ~loc) e2
+ | (Le|Lt|Ge|Gt|Eq|Ne) when isPointerType t1 && isPointerType t2 ->
+ compare_pointer ~cast1:theMachine.upointType ~cast2:theMachine.upointType
+ op e1 e2
+ | _ ->
+ Kernel.fatal ~current:true "mkBinOp: %a"
+ !pp_exp_ref (dummy_exp(BinOp(op,e1,e2,intType)))
+
+let mkBinOp_safe_ptr_cmp ~loc op e1 e2 =
+ let e1, e2 =
+ match op with
+ | (Eq | Ne | Lt | Le | Ge | Gt) ->
+ let t1 = typeOf e1 in
+ let t2 = typeOf e2 in
+ if isPointerType t1 && isPointerType t2
+ && not (isZero e1) && not (isZero e2)
+ then begin
+ mkCast ~force:true ~e:e1 ~newt:theMachine.upointType,
+ mkCast ~force:true ~e:e2 ~newt:theMachine.upointType
+ end else e1, e2
+ | _ -> e1, e2
+ in
+ mkBinOp ~loc op e1 e2
+
+type existsAction =
+ ExistsTrue (* We have found it *)
+ | ExistsFalse (* Stop processing this branch *)
+ | ExistsMaybe (* This node is not what we are
+ * looking for but maybe its
+ * successors are *)
+let existsType (f: typ -> existsAction) (t: typ) : bool =
+ let memo : (int, unit) Hashtbl.t = Hashtbl.create 17 in (* Memo table *)
+ let rec loop t =
+ match f t with
+ ExistsTrue -> true
+ | ExistsFalse -> false
+ | ExistsMaybe ->
+ (match t with
+ TNamed (t', _) -> loop t'.ttype
+ | TComp (c, _,_) -> loopComp c
+ | TArray (t', _, _, _) -> loop t'
+ | TPtr (t', _) -> loop t'
+ | TFun (rt, args, _, _) ->
+ (loop rt || List.exists (fun (_, at, _) -> loop at)
+ (argsToList args))
+ | _ -> false)
+ and loopComp c =
+ if Hashtbl.mem memo c.ckey then
+ (* We are looping, the answer must be false *)
+ false
+ else begin
+ Hashtbl.add memo c.ckey ();
+ List.exists (fun f -> loop f.ftype) c.cfields
+ end
+ in
+ loop t
+
+
+(* Try to do an increment, with constant folding *)
+let increm (e: exp) (i: int) =
+ let e' = constFold false e in
+ let et = typeOf e' in
+ let bop = if isPointerType et then PlusPI else PlusA in
+ let i = match et with
+ | TInt (k, _) | TEnum ({ekind = k },_) -> kinteger k ~loc:e.eloc i
+ | _ -> integer ~loc:e.eloc i
+ in
+ constFoldBinOp ~loc:e.eloc false bop e' i et
+
+(* Try to do an increment, with constant folding *)
+let increm64 (e: exp) i =
+ let et = typeOf e in
+ let bop = if isPointerType et then PlusPI else PlusA in
+ constFold
+ false
+ (new_exp ~loc:e.eloc (BinOp(bop, e, kinteger64 ~loc:e.eloc i, et)))
+
+exception LenOfArray
+let lenOfArray64 eo =
+ match eo with
+ None -> raise LenOfArray
+ | Some e -> begin
+ match (constFold true e).enode with
+ | Const(CInt64(ni, _, _)) when Integer.ge ni Integer.zero ->
+ ni
+ | _ -> raise LenOfArray
+ end
+let lenOfArray eo = Integer.to_int (lenOfArray64 eo)
(*** Make an initializer for zeroing a data type ***)
let rec makeZeroInit ~loc (t: typ) : init =
match unrollType t with
TInt (ik, _) ->
- SingleInit (new_exp ~loc (Const(CInt64(Integer.zero, ik, None))))
+ SingleInit (new_exp ~loc (Const(CInt64(Integer.zero, ik, None))))
| TFloat(fk, _) -> SingleInit(new_exp ~loc (Const(CReal(0.0, fk, None))))
| TEnum _ -> SingleInit (zero ~loc)
| TComp (comp, _, _) as t' when comp.cstruct ->
- let inits =
- List.fold_right
- (fun f acc ->
- if f.fname <> missingFieldName then
- (Field(f, NoOffset), makeZeroInit ~loc f.ftype) :: acc
- else
- acc)
- comp.cfields []
- in
- CompoundInit (t', inits)
+ let inits =
+ List.fold_right
+ (fun f acc ->
+ if f.fname <> missingFieldName then
+ (Field(f, NoOffset), makeZeroInit ~loc f.ftype) :: acc
+ else
+ acc)
+ comp.cfields []
+ in
+ CompoundInit (t', inits)
| TComp (comp, _, _) when not comp.cstruct ->
(match comp.cfields with
| [] -> CompoundInit(t, []) (* tolerate empty initialization. *)
@@ -7241,101 +7241,101 @@ let rec makeZeroInit ~loc (t: typ) : init =
is the one we should initialize. *)
CompoundInit(t, [(Field(f, NoOffset), makeZeroInit ~loc f.ftype)]))
| TArray(bt, Some len, _, _) as t' ->
- let n =
- match constFoldToInt len with
- | Some n -> Integer.to_int n
- | _ -> Kernel.fatal ~current:true "Cannot understand length of array"
- in
- let initbt = makeZeroInit ~loc bt in
- let rec loopElems acc i =
- if i < 0 then acc
- else loopElems ((Index(integer ~loc i, NoOffset), initbt) :: acc) (i - 1)
+ let n =
+ match constFoldToInt len with
+ | Some n -> Integer.to_int n
+ | _ -> Kernel.fatal ~current:true "Cannot understand length of array"
+ in
+ let initbt = makeZeroInit ~loc bt in
+ let rec loopElems acc i =
+ if i < 0 then acc
+ else loopElems ((Index(integer ~loc i, NoOffset), initbt) :: acc) (i - 1)
+ in
+ CompoundInit(t', loopElems [] (n - 1))
+
+ | TArray (_bt, None, _, _) as t' ->
+ (* Unsized array, allow it and fill it in later
+ * (see cabs2cil.ml, collectInitializer) *)
+ CompoundInit (t', [])
+
+ | TPtr _ as t ->
+ SingleInit(
+ if theMachine.insertImplicitCasts then mkCast (zero ~loc) t
+ else zero ~loc)
+ | x -> Kernel.fatal ~current:true "Cannot initialize type: %a" !pp_typ_ref x
+
+(** Fold over the list of initializers in a Compound (not also the nested
+ * ones). [doinit] is called on every present initializer, even if it is of
+ * compound type. The parameters of [doinit] are: the offset in the compound
+ * (this is [Field(f,NoOffset)] or [Index(i,NoOffset)]), the initializer
+ * value, expected type of the initializer value, accumulator. In the case of
+ * arrays there might be missing zero-initializers at the end of the list.
+ * These are scanned only if [implicit] is true. This is much like
+ * [List.fold_left] except we also pass the type of the initializer. *)
+let foldLeftCompound
+ ~(implicit: bool)
+ ~(doinit: offset -> init -> typ -> 'a -> 'a)
+ ~(ct: typ)
+ ~(initl: (offset * init) list)
+ ~(acc: 'a) : 'a =
+ match unrollType ct with
+ | TArray(bt, leno, _, _) -> begin
+ let default () =
+ (* iter over the supplied initializers *)
+ List.fold_left (fun acc (o, i) -> doinit o i bt acc) acc initl
in
- CompoundInit(t', loopElems [] (n - 1))
-
- | TArray (_bt, None, _, _) as t' ->
- (* Unsized array, allow it and fill it in later
- * (see cabs2cil.ml, collectInitializer) *)
- CompoundInit (t', [])
-
- | TPtr _ as t ->
- SingleInit(
- if theMachine.insertImplicitCasts then mkCast (zero ~loc) t
- else zero ~loc)
- | x -> Kernel.fatal ~current:true "Cannot initialize type: %a" !pp_typ_ref x
-
- (** Fold over the list of initializers in a Compound (not also the nested
- * ones). [doinit] is called on every present initializer, even if it is of
- * compound type. The parameters of [doinit] are: the offset in the compound
- * (this is [Field(f,NoOffset)] or [Index(i,NoOffset)]), the initializer
- * value, expected type of the initializer value, accumulator. In the case of
- * arrays there might be missing zero-initializers at the end of the list.
- * These are scanned only if [implicit] is true. This is much like
- * [List.fold_left] except we also pass the type of the initializer. *)
- let foldLeftCompound
- ~(implicit: bool)
- ~(doinit: offset -> init -> typ -> 'a -> 'a)
- ~(ct: typ)
- ~(initl: (offset * init) list)
- ~(acc: 'a) : 'a =
- match unrollType ct with
- | TArray(bt, leno, _, _) -> begin
- let default () =
- (* iter over the supplied initializers *)
- List.fold_left (fun acc (o, i) -> doinit o i bt acc) acc initl
- in
- if implicit then
- match leno with
- | Some lene -> begin
- match constFoldToInt lene with
- | Some i ->
- let len_array = Integer.to_int i in
- let len_init = List.length initl in
- if len_array <= len_init then
- default () (* enough elements in the initializers list *)
- else
- (* Some initializers are missing. Iterate over all the indexes in
- the array, and use either the supplied initializer, or a generic
- zero one. *)
- let loc = CurrentLoc.get () in
- let zinit = makeZeroInit ~loc bt in
- let acc = ref acc in
- let initl = ref initl in
- (* Is [off] the offset for the index [i] we are currently at.
- Works because [initl] is sorted by Cabs2cil.*)
- let good_offset i off = match off with
- | Index (i', NoOffset) ->
- Integer.(equal (Extlib.the (constFoldToInt i')) (of_int i))
- | _ -> Kernel.fatal ~current:true
- "Invalid initializer"
- in
- for i = 0 to len_array - 1 do
- match !initl with
- | (off, init) :: qinitl when good_offset i off->
- acc := doinit off init bt !acc;
- initl := qinitl
- | _ ->
- acc := doinit (Index(integer ~loc i, NoOffset)) zinit bt !acc
- done;
- assert (!initl = []);
- !acc
- | _ -> Kernel.fatal ~current:true
- "foldLeftCompoundAll: array with initializer and non-constant length"
- end
- | _ -> Kernel.fatal ~current:true
- "foldLeftCompoundAll: TArray with initializer and no length"
- else default ()
- end
-
- | TComp (_comp, _, _) ->
- let getTypeOffset = function
- Field(f, NoOffset) -> f.ftype
- | _ -> Kernel.fatal ~current:true "foldLeftCompound: malformed initializer"
- in
- List.fold_left
- (fun acc (o, i) -> doinit o i (getTypeOffset o) acc) acc initl
+ if implicit then
+ match leno with
+ | Some lene -> begin
+ match constFoldToInt lene with
+ | Some i ->
+ let len_array = Integer.to_int i in
+ let len_init = List.length initl in
+ if len_array <= len_init then
+ default () (* enough elements in the initializers list *)
+ else
+ (* Some initializers are missing. Iterate over all the indexes in
+ the array, and use either the supplied initializer, or a generic
+ zero one. *)
+ let loc = CurrentLoc.get () in
+ let zinit = makeZeroInit ~loc bt in
+ let acc = ref acc in
+ let initl = ref initl in
+ (* Is [off] the offset for the index [i] we are currently at.
+ Works because [initl] is sorted by Cabs2cil.*)
+ let good_offset i off = match off with
+ | Index (i', NoOffset) ->
+ Integer.(equal (Extlib.the (constFoldToInt i')) (of_int i))
+ | _ -> Kernel.fatal ~current:true
+ "Invalid initializer"
+ in
+ for i = 0 to len_array - 1 do
+ match !initl with
+ | (off, init) :: qinitl when good_offset i off->
+ acc := doinit off init bt !acc;
+ initl := qinitl
+ | _ ->
+ acc := doinit (Index(integer ~loc i, NoOffset)) zinit bt !acc
+ done;
+ assert (!initl = []);
+ !acc
+ | _ -> Kernel.fatal ~current:true
+ "foldLeftCompoundAll: array with initializer and non-constant length"
+ end
+ | _ -> Kernel.fatal ~current:true
+ "foldLeftCompoundAll: TArray with initializer and no length"
+ else default ()
+ end
+
+ | TComp (_comp, _, _) ->
+ let getTypeOffset = function
+ Field(f, NoOffset) -> f.ftype
+ | _ -> Kernel.fatal ~current:true "foldLeftCompound: malformed initializer"
+ in
+ List.fold_left
+ (fun acc (o, i) -> doinit o i (getTypeOffset o) acc) acc initl
- | _ -> Kernel.fatal ~current:true "Type of Compound is not array or struct or union"
+ | _ -> Kernel.fatal ~current:true "Type of Compound is not array or struct or union"
let has_flexible_array_member t =
let is_flexible_array t =
@@ -7352,29 +7352,29 @@ let has_flexible_array_member t =
(* last_field is [true] if the given type is the type of the last field of
a struct (which could be a FAM, making the whole struct complete even if
the array type isn't. *)
- let rec isCompleteType ?allowZeroSizeArrays ?(last_field=false) t =
- let allowZeroSizeArrays =
- match allowZeroSizeArrays with
- | None -> gccMode()
- | Some flag -> flag
- in
- match unrollType t with
- | TVoid _ -> false (* void is an incomplete type by definition (6.2.5§19) *)
- | TArray(t, None, _, _) ->
- last_field && is_complete_agg_member ~allowZeroSizeArrays ~last_field t
- | TArray(t, Some z, _, _) when isZero z ->
- allowZeroSizeArrays &&
- is_complete_agg_member ~allowZeroSizeArrays ~last_field t
- | TArray(t, Some _, _, _) ->
- is_complete_agg_member ~allowZeroSizeArrays ~last_field t
- | TComp (comp, _, _) -> (* Struct or union *)
- comp.cdefined &&
- complete_type_fields ~allowZeroSizeArrays comp.cstruct comp.cfields
- | TEnum({eitems = []},_) -> false
- | TEnum _ -> true
- | TInt _ | TFloat _ | TPtr _ | TBuiltin_va_list _ -> true
- | TFun _ -> true (* only object types can be incomplete (6.2.5§1) *)
- | TNamed _ -> assert false (* unroll should have removed it. *)
+let rec isCompleteType ?allowZeroSizeArrays ?(last_field=false) t =
+ let allowZeroSizeArrays =
+ match allowZeroSizeArrays with
+ | None -> gccMode()
+ | Some flag -> flag
+ in
+ match unrollType t with
+ | TVoid _ -> false (* void is an incomplete type by definition (6.2.5§19) *)
+ | TArray(t, None, _, _) ->
+ last_field && is_complete_agg_member ~allowZeroSizeArrays ~last_field t
+ | TArray(t, Some z, _, _) when isZero z ->
+ allowZeroSizeArrays &&
+ is_complete_agg_member ~allowZeroSizeArrays ~last_field t
+ | TArray(t, Some _, _, _) ->
+ is_complete_agg_member ~allowZeroSizeArrays ~last_field t
+ | TComp (comp, _, _) -> (* Struct or union *)
+ comp.cdefined &&
+ complete_type_fields ~allowZeroSizeArrays comp.cstruct comp.cfields
+ | TEnum({eitems = []},_) -> false
+ | TEnum _ -> true
+ | TInt _ | TFloat _ | TPtr _ | TBuiltin_va_list _ -> true
+ | TFun _ -> true (* only object types can be incomplete (6.2.5§1) *)
+ | TNamed _ -> assert false (* unroll should have removed it. *)
and complete_type_fields ?allowZeroSizeArrays is_struct fields =
let rec aux is_first l =
@@ -7396,107 +7396,107 @@ and is_complete_agg_member ?allowZeroSizeArrays ?last_field t =
let isCompleteType ?allowZeroSizeArrays t =
isCompleteType ?allowZeroSizeArrays t
- let is_mutable_or_initialized (host, offset) =
- let rec aux can_mutate typ off =
- let can_mutate = can_mutate && not (isConstType typ) in
- match unrollType typ, off with
- | _, NoOffset -> can_mutate
- | _, Field (fi, off) ->
- aux
- (can_mutate || hasAttribute frama_c_mutable fi.fattr)
- fi.ftype off
- | TArray(typ, _, _, _), Index(_, off) -> aux can_mutate typ off
- | _, Index _ -> Kernel.fatal "Index on a non-array type"
- in
- match host with
- | Mem({ enode = Lval (Var vi, NoOffset) })
- when hasAttribute frama_c_init_obj vi.vattr -> true
- | _ ->
- aux false (typeOfLhost host) offset
-
- let is_modifiable_lval lv =
- let t = typeOfLval lv in
- match unrollType t with
- | TArray _ -> false
- | TFun _ -> false
- | _ -> (not (isConstType t)
- || is_mutable_or_initialized lv) && isCompleteType t
+let is_mutable_or_initialized (host, offset) =
+ let rec aux can_mutate typ off =
+ let can_mutate = can_mutate && not (isConstType typ) in
+ match unrollType typ, off with
+ | _, NoOffset -> can_mutate
+ | _, Field (fi, off) ->
+ aux
+ (can_mutate || hasAttribute frama_c_mutable fi.fattr)
+ fi.ftype off
+ | TArray(typ, _, _, _), Index(_, off) -> aux can_mutate typ off
+ | _, Index _ -> Kernel.fatal "Index on a non-array type"
+ in
+ match host with
+ | Mem({ enode = Lval (Var vi, NoOffset) })
+ when hasAttribute frama_c_init_obj vi.vattr -> true
+ | _ ->
+ aux false (typeOfLhost host) offset
+
+let is_modifiable_lval lv =
+ let t = typeOfLval lv in
+ match unrollType t with
+ | TArray _ -> false
+ | TFun _ -> false
+ | _ -> (not (isConstType t)
+ || is_mutable_or_initialized lv) && isCompleteType t
- (* makes sure that the type of a C variable and the type of its associated
+(* makes sure that the type of a C variable and the type of its associated
logic variable -if any- stay synchronized. See bts 1538 *)
- let update_var_type v t =
- v.vtype <- t;
- match v.vlogic_var_assoc with
- | None -> ()
- | Some lv -> lv.lv_type <- Ctype t
-
- (** Uniquefy the variable names *)
- let uniqueVarNames (f: file) : unit =
- (* Setup the alpha conversion table for globals *)
- let gAlphaTable = Hashtbl.create 113 in
- (* Keep also track of the global names that we have used. Map them to the
- variable ID. We do this only to check that we do not have two globals
- with the same name. *)
- let globalNames: (string, int) Hashtbl.t = Hashtbl.create 113 in
- (* Scan the file and add the global names to the table *)
- iterGlobals f
- (function
- | GVarDecl(vi, _) | GVar(vi, _, _)
- | GFunDecl(_, vi, _) | GFun({svar = vi}, _) ->
- (* See if we have used this name already for something else *)
- (try
- let oldid = Hashtbl.find globalNames vi.vname in
- if oldid <> vi.vid && not vi.vinline then
- Kernel.warning
- "The name %s is used for two distinct globals" vi.vname
- (* Here if we have used this name already. Go ahead *)
- with Not_found -> begin
- (* Here if this is the first time we define a name *)
- Hashtbl.add globalNames vi.vname vi.vid;
- (* And register it *)
+let update_var_type v t =
+ v.vtype <- t;
+ match v.vlogic_var_assoc with
+ | None -> ()
+ | Some lv -> lv.lv_type <- Ctype t
+
+(** Uniquefy the variable names *)
+let uniqueVarNames (f: file) : unit =
+ (* Setup the alpha conversion table for globals *)
+ let gAlphaTable = Hashtbl.create 113 in
+ (* Keep also track of the global names that we have used. Map them to the
+ variable ID. We do this only to check that we do not have two globals
+ with the same name. *)
+ let globalNames: (string, int) Hashtbl.t = Hashtbl.create 113 in
+ (* Scan the file and add the global names to the table *)
+ iterGlobals f
+ (function
+ | GVarDecl(vi, _) | GVar(vi, _, _)
+ | GFunDecl(_, vi, _) | GFun({svar = vi}, _) ->
+ (* See if we have used this name already for something else *)
+ (try
+ let oldid = Hashtbl.find globalNames vi.vname in
+ if oldid <> vi.vid && not vi.vinline then
+ Kernel.warning
+ "The name %s is used for two distinct globals" vi.vname
+ (* Here if we have used this name already. Go ahead *)
+ with Not_found -> begin
+ (* Here if this is the first time we define a name *)
+ Hashtbl.add globalNames vi.vname vi.vid;
+ (* And register it *)
Alpha.registerAlphaName gAlphaTable vi.vname (CurrentLoc.get ())
- end)
- | _ -> ());
-
- (* Now we must scan the function bodies and rename the locals *)
- iterGlobals f
- (function
- GFun(fdec, l) -> begin
- CurrentLoc.set l;
- (* Setup an undo list to be able to revert the changes to the
- * global alpha table *)
- let undolist = ref [] in
- (* Process one local variable *)
- let processLocal (v: varinfo) =
- (* start from original name to avoid putting another _0 in case
- of conflicts. *)
- let lookupname = v.vorig_name in
- let data = CurrentLoc.get () in
- let newname, oldloc =
- Alpha.newAlphaName
- ~alphaTable:gAlphaTable ~undolist ~lookupname ~data
- in
- if false && newname <> v.vname then (* Disable this warning *)
- Kernel.warning
- "Changing the name of local %s in %s to %s \
- (due to duplicate at %a)"
- v.vname
- fdec.svar.vname
- newname Location.pretty oldloc ;
- v.vname <- newname
- in
- (* Do the formals first *)
- List.iter processLocal fdec.sformals;
- (* Fix the type again *)
- setFormals fdec fdec.sformals;
- (* And now the locals *)
- List.iter processLocal fdec.slocals;
- (* Undo the changes to the global table *)
- Alpha.undoAlphaChanges gAlphaTable !undolist;
- ()
- end
- | _ -> ());
- ()
+ end)
+ | _ -> ());
+
+ (* Now we must scan the function bodies and rename the locals *)
+ iterGlobals f
+ (function
+ GFun(fdec, l) -> begin
+ CurrentLoc.set l;
+ (* Setup an undo list to be able to revert the changes to the
+ * global alpha table *)
+ let undolist = ref [] in
+ (* Process one local variable *)
+ let processLocal (v: varinfo) =
+ (* start from original name to avoid putting another _0 in case
+ of conflicts. *)
+ let lookupname = v.vorig_name in
+ let data = CurrentLoc.get () in
+ let newname, oldloc =
+ Alpha.newAlphaName
+ ~alphaTable:gAlphaTable ~undolist ~lookupname ~data
+ in
+ if false && newname <> v.vname then (* Disable this warning *)
+ Kernel.warning
+ "Changing the name of local %s in %s to %s \
+ (due to duplicate at %a)"
+ v.vname
+ fdec.svar.vname
+ newname Location.pretty oldloc ;
+ v.vname <- newname
+ in
+ (* Do the formals first *)
+ List.iter processLocal fdec.sformals;
+ (* Fix the type again *)
+ setFormals fdec fdec.sformals;
+ (* And now the locals *)
+ List.iter processLocal fdec.slocals;
+ (* Undo the changes to the global table *)
+ Alpha.undoAlphaChanges gAlphaTable !undolist;
+ ()
+ end
+ | _ -> ());
+ ()
let is_case_label l = match l with
| Case _ | Default _ -> true
@@ -7540,7 +7540,7 @@ let initCIL ~initLogicBuiltins machdep =
else if name = "long long" then ILongLong
else if name = "unsigned long long" then IULongLong
else
- Kernel.fatal
+ Kernel.fatal
~current:true "initCIL: cannot find the right ikind for type %s" name
in
theMachine.upointKind <- findIkindSz true theMachine.theMachine.sizeof_ptr;
@@ -7556,7 +7556,7 @@ let initCIL ~initLogicBuiltins machdep =
theMachine.theMachine.Cil_types.underscore_name;
theMachine.useLogicalOperators <- Kernel.LogicalOperators.get() (* do not use lazy LAND and LOR *);
(*nextGlobalVID <- 1 ;
- nextCompinfoKey <- 1;*)
+ nextCompinfoKey <- 1;*)
(* Have to be marked before calling [init*Builtins] below. *)
TheMachine.mark_as_computed ();
@@ -7587,7 +7587,7 @@ let initCIL ~initLogicBuiltins machdep =
let pullTypesForward = true
- (* Scan a type and collect the variables that are referred *)
+(* Scan a type and collect the variables that are referred *)
class getVarsInGlobalClass (pacc: varinfo list ref) = object
inherit nopCilVisitor
method! vvrbl (vi: varinfo) =
@@ -7607,8 +7607,8 @@ let getVarsInGlobal (g : global) : varinfo list =
!pacc
let pushGlobal (g: global)
- ~(types:global list ref)
- ~(variables: global list ref) =
+ ~(types:global list ref)
+ ~(variables: global list ref) =
if not pullTypesForward then
variables := g :: !variables
else
@@ -7621,22 +7621,22 @@ let pushGlobal (g: global)
GType (_, l) | GCompTag (_, l) -> Some (getVarsInGlobal g, l)
| GEnumTag (_, l) | GPragma (Attr("pack", _), l)
| GCompTagDecl (_, l) | GEnumTagDecl (_, l) -> Some ([], l)
- (** Move the warning pragmas early
- | GPragma(Attr(s, _), l) when hasPrefix "warning" s -> Some ([], l)
- *)
+ (** Move the warning pragmas early
+ | GPragma(Attr(s, _), l) when hasPrefix "warning" s -> Some ([], l)
+ *)
| _ -> None (* Does not go with the types *)
in
match varsintype with
- None -> variables := g :: !variables
- | Some (vl, loc) ->
+ None -> variables := g :: !variables
+ | Some (vl, loc) ->
types :=
- (* insert declarations for referred variables ('vl'), before
- * the type definition 'g' itself *)
+ (* insert declarations for referred variables ('vl'), before
+ * the type definition 'g' itself *)
let aux acc v =
if isFunctionType v.vtype
then GFunDecl (empty_funspec (),v, loc) :: acc
else begin
- let is_same_decl = function
+ let is_same_decl = function
| GVarDecl(v',_) -> Cil_datatype.Varinfo.equal v v'
| _ -> false
in
@@ -7649,7 +7649,7 @@ let pushGlobal (g: global)
end
in
g :: (List.fold_left aux !types vl)
- end
+ end
type formatArg =
@@ -7728,7 +7728,7 @@ let extract_varinfos_from_exp vexp =
SkipChildren
end
in ignore (visitCilExpr (visitor :> nopCilVisitor) vexp) ;
- visitor#varinfos
+ visitor#varinfos
let extract_varinfos_from_lval vlval =
let visitor = object
@@ -7740,7 +7740,7 @@ let extract_varinfos_from_lval vlval =
SkipChildren
end
in ignore (visitCilLval (visitor :> nopCilVisitor) vlval) ;
- visitor#varinfos
+ visitor#varinfos
let rec free_vars_term bound_vars t = match t.term_node with
| TConst _ | TSizeOf _
@@ -7766,8 +7766,8 @@ let rec free_vars_term bound_vars t = match t.term_node with
| TUpdate (t1,toff,t2) ->
Logic_var.Set.union
(Logic_var.Set.union
- (free_vars_term bound_vars t1)
- (free_vars_term_offset bound_vars toff))
+ (free_vars_term bound_vars t1)
+ (free_vars_term_offset bound_vars toff))
(free_vars_term bound_vars t2)
| Tif (t1,t2,t3) ->
Logic_var.Set.union
@@ -7778,7 +7778,7 @@ let rec free_vars_term bound_vars t = match t.term_node with
| TDataCons(_,t) | Tapp (_,_,t) ->
List.fold_left
(fun acc t ->
- Logic_var.Set.union (free_vars_term bound_vars t) acc)
+ Logic_var.Set.union (free_vars_term bound_vars t) acc)
Logic_var.Set.empty t
| Tlambda(prms,expr) ->
let bound_vars =
@@ -7791,36 +7791,36 @@ let rec free_vars_term bound_vars t = match t.term_node with
| Some i -> free_vars_term bound_vars i
in
(match i2 with
- | None -> fv
- | Some i ->
- Logic_var.Set.union fv (free_vars_term bound_vars i))
+ | None -> fv
+ | Some i ->
+ Logic_var.Set.union fv (free_vars_term bound_vars i))
| Tempty_set -> Logic_var.Set.empty
| Tunion l | Tinter l ->
List.fold_left
(fun acc t ->
- Logic_var.Set.union (free_vars_term bound_vars t) acc)
+ Logic_var.Set.union (free_vars_term bound_vars t) acc)
Logic_var.Set.empty
l
| Tcomprehension(t,q,p) ->
let new_bv =
List.fold_left
- (fun acc v -> Logic_var.Set.add v acc) bound_vars q
+ (fun acc v -> Logic_var.Set.add v acc) bound_vars q
in
let fv = free_vars_term new_bv t in
(match p with
- | None -> fv
- | Some p ->
- Logic_var.Set.union fv (free_vars_predicate new_bv p))
+ | None -> fv
+ | Some p ->
+ Logic_var.Set.union fv (free_vars_predicate new_bv p))
| Tlet(d,b) ->
let fvd =
match d.l_body with
- | LBterm term -> free_vars_term bound_vars term
- | LBpred p -> free_vars_predicate bound_vars p
- | LBnone
- | LBreads _ | LBinductive _ ->
- Kernel.fatal ~current:true
- "definition of local variable %s is not a term or a predicate"
- d.l_var_info.lv_name
+ | LBterm term -> free_vars_term bound_vars term
+ | LBpred p -> free_vars_predicate bound_vars p
+ | LBnone
+ | LBreads _ | LBinductive _ ->
+ Kernel.fatal ~current:true
+ "definition of local variable %s is not a term or a predicate"
+ d.l_var_info.lv_name
in
let fvb =
free_vars_term (Logic_var.Set.add d.l_var_info bound_vars) b
@@ -7854,7 +7854,7 @@ and free_vars_predicate bound_vars p = match p.pred_content with
| Papp (_,_,tl) ->
List.fold_left
(fun acc t ->
- Logic_var.Set.union (free_vars_term bound_vars t) acc)
+ Logic_var.Set.union (free_vars_term bound_vars t) acc)
Logic_var.Set.empty tl
| Pallocable (_,t) | Pfreeable (_,t)
| Pvalid (_,t) | Pvalid_read (_,t) | Pvalid_function t
@@ -7863,11 +7863,11 @@ and free_vars_predicate bound_vars p = match p.pred_content with
| Pseparated seps ->
List.fold_left
(fun free_vars tset ->
- Logic_var.Set.union
- (free_vars_term bound_vars tset) free_vars)
+ Logic_var.Set.union
+ (free_vars_term bound_vars tset) free_vars)
Logic_var.Set.empty
seps
- | Pfresh (_,_,t1,t2)
+ | Pfresh (_,_,t1,t2)
| Prel (_,t1,t2)
->
Logic_var.Set.union
@@ -7883,7 +7883,7 @@ and free_vars_predicate bound_vars p = match p.pred_content with
(free_vars_predicate bound_vars p2)
| Pnot p
| Pat (p,_)
-(* | Pnamed (_,p) *) ->
+ (* | Pnamed (_,p) *) ->
free_vars_predicate bound_vars p
| Pif (t,p1,p2) ->
Logic_var.Set.union
@@ -7894,13 +7894,13 @@ and free_vars_predicate bound_vars p = match p.pred_content with
| Plet (d, p) ->
let fvd =
match d.l_body with
- | LBterm t -> free_vars_term bound_vars t
- | LBpred p -> free_vars_predicate bound_vars p
- | LBnone
- | LBreads _ | LBinductive _ ->
- Kernel.fatal ~current:true
- "Local logic var %s is not a defined term or predicate"
- d.l_var_info.lv_name
+ | LBterm t -> free_vars_term bound_vars t
+ | LBpred p -> free_vars_predicate bound_vars p
+ | LBnone
+ | LBreads _ | LBinductive _ ->
+ Kernel.fatal ~current:true
+ "Local logic var %s is not a defined term or predicate"
+ d.l_var_info.lv_name
in
let new_bv = Logic_var.Set.add d.l_var_info bound_vars in
Logic_var.Set.union fvd (free_vars_predicate new_bv p)
@@ -7908,7 +7908,7 @@ and free_vars_predicate bound_vars p = match p.pred_content with
| Pforall (lvs,p) | Pexists (lvs,p) ->
let new_bv =
List.fold_left
- (Extlib.swap Logic_var.Set.add) bound_vars lvs
+ (Extlib.swap Logic_var.Set.add) bound_vars lvs
in
free_vars_predicate new_bv p
@@ -7959,15 +7959,15 @@ let close_predicate p =
pred_content = Pforall (Logic_var.Set.elements free_vars, p)}
class alpha_conv tbl ltbl =
-object
- inherit nopCilVisitor
- method! vvrbl v =
- try let v' = Hashtbl.find tbl v.vid in ChangeTo v'
- with Not_found -> DoChildren
- method! vlogic_var_use v =
- try let v' = Hashtbl.find ltbl v.lv_id in ChangeTo v'
- with Not_found -> DoChildren
-end
+ object
+ inherit nopCilVisitor
+ method! vvrbl v =
+ try let v' = Hashtbl.find tbl v.vid in ChangeTo v'
+ with Not_found -> DoChildren
+ method! vlogic_var_use v =
+ try let v' = Hashtbl.find ltbl v.lv_id in ChangeTo v'
+ with Not_found -> DoChildren
+ end
let create_alpha_renaming old_args new_args =
let conversion = Hashtbl.create 7 in
@@ -7978,9 +7978,9 @@ let create_alpha_renaming old_args new_args =
match old_vi.vlogic_var_assoc, new_vi.vlogic_var_assoc with
| None, _ -> () (* nothing to convert in logic spec. *)
| Some old_lv, Some new_lv ->
- Hashtbl.add lconversion old_lv.lv_id new_lv
+ Hashtbl.add lconversion old_lv.lv_id new_lv
| Some old_lv, None ->
- Hashtbl.add lconversion old_lv.lv_id (cvar_to_lvar new_vi))
+ Hashtbl.add lconversion old_lv.lv_id (cvar_to_lvar new_vi))
old_args new_args;
new alpha_conv conversion lconversion
@@ -8025,17 +8025,17 @@ let separate_switch_succs s =
in
let cases_non_default = ref [] in
List.iter (fun stmt ->
- if not (is_in_cases stmt)
- then set_default stmt
- else
+ if not (is_in_cases stmt)
+ then set_default stmt
+ else
if contains_default_label stmt
then
- (set_default stmt;
- if contains_case_label stmt
- then cases_non_default := stmt::!cases_non_default)
+ (set_default stmt;
+ if contains_case_label stmt
+ then cases_non_default := stmt::!cases_non_default)
else
- (assert (contains_case_label stmt);
- cases_non_default := stmt::!cases_non_default)) s.succs;
+ (assert (contains_case_label stmt);
+ cases_non_default := stmt::!cases_non_default)) s.succs;
match !default with
| None ->
Kernel.fatal ~current:true "Bad CFG: switch with no non-case successors."
@@ -8053,10 +8053,10 @@ module Switch_cases =
(Stmt.Hashtbl)
(Datatype.Pair(Datatype.List(Stmt))(Stmt))
(struct
- let name = "Switch_cases"
- let dependencies = []
- let size = 49
- end)
+ let name = "Switch_cases"
+ let dependencies = []
+ let size = 49
+ end)
let () = dependency_on_ast Switch_cases.self
let separate_switch_succs = Switch_cases.memo separate_switch_succs
@@ -8064,16 +8064,16 @@ class dropAttributes ?select () = object
inherit genericCilVisitor (copy_visit (Project.current ()))
method! vattr a =
match select with
- | None -> ChangeTo []
- | Some l ->
- (match a with
- | (Attr (s,_) | AttrAnnot s) when List.mem s l -> ChangeTo []
- | Attr _ | AttrAnnot _ -> DoChildren)
+ | None -> ChangeTo []
+ | Some l ->
+ (match a with
+ | (Attr (s,_) | AttrAnnot s) when List.mem s l -> ChangeTo []
+ | Attr _ | AttrAnnot _ -> DoChildren)
method! vtype ty = match ty with
| TNamed (internal_ty, attrs) ->
let tty = typeAddAttributes attrs internal_ty.ttype in
(* keep the original type whenever possible *)
- ChangeDoChildrenPost
+ ChangeDoChildrenPost
(tty, fun x -> if x == internal_ty.ttype then ty else x)
| TVoid _ | TInt _ | TFloat _ | TPtr _ | TArray _ | TFun _
| TComp _ | TEnum _ | TBuiltin_va_list _ -> DoChildren
diff --git a/src/kernel_services/ast_queries/cil_datatype.ml b/src/kernel_services/ast_queries/cil_datatype.ml
index 5e519e73979..789c58e6e06 100644
--- a/src/kernel_services/ast_queries/cil_datatype.ml
+++ b/src/kernel_services/ast_queries/cil_datatype.ml
@@ -44,14 +44,14 @@ let clear_caches = ref []
(**************************************************************************)
module Make
- (X: sig
- type t
- val name: string
- val reprs: t list
- val internal_pretty_code: Type.precedence -> Format.formatter -> t -> unit
- val pretty: Format.formatter -> t -> unit
- val varname: t -> string
- end) =
+ (X: sig
+ type t
+ val name: string
+ val reprs: t list
+ val internal_pretty_code: Type.precedence -> Format.formatter -> t -> unit
+ val pretty: Format.formatter -> t -> unit
+ val varname: t -> string
+ end) =
Datatype.Make
(struct
include Datatype.Undefined
@@ -60,21 +60,21 @@ module Make
let structural_descr = Structural_descr.t_abstract
let rehash = Datatype.identity
let mem_project = Datatype.never_any_project
- end)
+ end)
module Make_with_collections
- (X: sig
- type t
- val name: string
- val reprs: t list
- val compare: t -> t -> int
- val equal: t -> t -> bool
- val internal_pretty_code: Type.precedence -> Format.formatter -> t -> unit
- val pretty: Format.formatter -> t -> unit
- val varname: t -> string
- val hash: t -> int
- val copy: t -> t
- end) =
+ (X: sig
+ type t
+ val name: string
+ val reprs: t list
+ val compare: t -> t -> int
+ val equal: t -> t -> bool
+ val internal_pretty_code: Type.precedence -> Format.formatter -> t -> unit
+ val pretty: Format.formatter -> t -> unit
+ val varname: t -> string
+ val hash: t -> int
+ val copy: t -> t
+ end) =
Datatype.Make_with_collections
(struct
include X
@@ -82,7 +82,7 @@ module Make_with_collections
let structural_descr = Structural_descr.t_abstract
let rehash = Datatype.identity
let mem_project = Datatype.never_any_project
- end)
+ end)
let compare_chain cmp x1 x2 next arg1 arg2 =
let res = cmp x1 x2 in if res = 0 then next arg1 arg2 else res
@@ -128,15 +128,15 @@ let rank_term = function
module Cabs_file = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Make
- (struct
- type t = Cabs.file
- let name = "Cabs_file"
- let reprs = [ Datatype.Filepath.dummy, [];
- Datatype.Filepath.dummy, [ true, Cabs.GLOBANNOT [] ] ]
- let varname (s, _) = "cabs_" ^ (Filepath.Normalized.to_pretty_string s)
- let internal_pretty_code = Datatype.undefined
- let pretty fmt cabs = !pretty_ref fmt cabs
- end)
+ (struct
+ type t = Cabs.file
+ let name = "Cabs_file"
+ let reprs = [ Datatype.Filepath.dummy, [];
+ Datatype.Filepath.dummy, [ true, Cabs.GLOBANNOT [] ] ]
+ let varname (s, _) = "cabs_" ^ (Filepath.Normalized.to_pretty_string s)
+ let internal_pretty_code = Datatype.undefined
+ let pretty fmt cabs = !pretty_ref fmt cabs
+ end)
end
(**************************************************************************)
@@ -164,18 +164,18 @@ module Position = struct
pos_cnum = p.Filepath.pos_cnum;
}
include Make_with_collections
- (struct
- type t = Filepath.position
- let name = "Position"
- let reprs = [ unknown ]
- let compare: t -> t -> int = (=?=)
- let hash = Hashtbl.hash
- let copy = Datatype.identity
- let equal: t -> t -> bool = ( = )
- let internal_pretty_code = Datatype.undefined
- let pretty = Filepath.pp_pos
- let varname _ = "pos"
- end)
+ (struct
+ type t = Filepath.position
+ let name = "Position"
+ let reprs = [ unknown ]
+ let compare: t -> t -> int = (=?=)
+ let hash = Hashtbl.hash
+ let copy = Datatype.identity
+ let equal: t -> t -> bool = ( = )
+ let internal_pretty_code = Datatype.undefined
+ let pretty = Filepath.pp_pos
+ let varname _ = "pos"
+ end)
let pp_with_col fmt pos =
Format.fprintf fmt "%a char %d" pretty pos
(pos.Filepath.pos_cnum - pos.Filepath.pos_bol)
@@ -185,18 +185,18 @@ module Location = struct
let unknown = Position.unknown, Position.unknown
let pretty_ref = ref (fun _ _ -> assert false)
include Make_with_collections
- (struct
- type t = location
- let name = "Location"
- let reprs = [ unknown ]
- let compare: location -> location -> int = (=?=)
- let hash (b, _e) = Hashtbl.hash (b.Filepath.pos_path, b.Filepath.pos_lnum)
- let copy = Datatype.identity (* immutable strings *)
- let equal : t -> t -> bool = ( = )
- let internal_pretty_code = Datatype.undefined
- let pretty fmt loc = !pretty_ref fmt loc
- let varname _ = "loc"
- end)
+ (struct
+ type t = location
+ let name = "Location"
+ let reprs = [ unknown ]
+ let compare: location -> location -> int = (=?=)
+ let hash (b, _e) = Hashtbl.hash (b.Filepath.pos_path, b.Filepath.pos_lnum)
+ let copy = Datatype.identity (* immutable strings *)
+ let equal : t -> t -> bool = ( = )
+ let internal_pretty_code = Datatype.undefined
+ let pretty fmt loc = !pretty_ref fmt loc
+ let varname _ = "loc"
+ end)
let pretty_long fmt loc =
let path = (fst loc).Filepath.pos_path in
@@ -224,14 +224,14 @@ module Instr = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Make
- (struct
- type t = instr
- let name = "Instr"
- let reprs = List.map (fun l -> Skip l) Location.reprs
- let internal_pretty_code = Datatype.undefined
- let pretty fmt x = !pretty_ref fmt x
- let varname = Datatype.undefined
- end)
+ (struct
+ type t = instr
+ let name = "Instr"
+ let reprs = List.map (fun l -> Skip l) Location.reprs
+ let internal_pretty_code = Datatype.undefined
+ let pretty fmt x = !pretty_ref fmt x
+ let varname = Datatype.undefined
+ end)
let loc = function
| Local_init (_,_,l) -> l
@@ -250,41 +250,41 @@ module File =
let name = "File"
let reprs =
[ { fileName = Datatype.Filepath.dummy;
- globals = [];
- globinit = None;
- globinitcalled = false } ]
+ globals = [];
+ globinit = None;
+ globinitcalled = false } ]
include Datatype.Undefined
let varname _ = "ast"
- end)
+ end)
module Stmt_Id = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Make_with_collections
- (struct
- type t = stmt
- let name = "Stmt"
- let reprs =
- [ { labels = [];
- skind = UnspecifiedSequence [];
- sid = -1;
- succs = [];
- preds = [];
- ghost = false;
- sattr = [] } ]
- let compare t1 t2 = Datatype.Int.compare t1.sid t2.sid
- let hash t1 = t1.sid
- let equal t1 t2 = t1.sid = t2.sid
- let copy = Datatype.undefined
- let internal_pretty_code p_caller fmt s =
- let pp fmt =
- Format.fprintf fmt
- "@[<hv 2>fst@;@[<hv 2>(Kernel_function.find_from_sid@;%d)@]@]"
- s.sid
- in
- Type.par p_caller Type.Call fmt pp
- let pretty fmt s = !pretty_ref fmt s
- let varname _ = "stmt"
- end)
+ (struct
+ type t = stmt
+ let name = "Stmt"
+ let reprs =
+ [ { labels = [];
+ skind = UnspecifiedSequence [];
+ sid = -1;
+ succs = [];
+ preds = [];
+ ghost = false;
+ sattr = [] } ]
+ let compare t1 t2 = Datatype.Int.compare t1.sid t2.sid
+ let hash t1 = t1.sid
+ let equal t1 t2 = t1.sid = t2.sid
+ let copy = Datatype.undefined
+ let internal_pretty_code p_caller fmt s =
+ let pp fmt =
+ Format.fprintf fmt
+ "@[<hv 2>fst@;@[<hv 2>(Kernel_function.find_from_sid@;%d)@]@]"
+ s.sid
+ in
+ Type.par p_caller Type.Call fmt pp
+ let pretty fmt s = !pretty_ref fmt s
+ let varname _ = "stmt"
+ end)
let id stmt = stmt.sid
end
module Stmt = struct
@@ -294,17 +294,17 @@ module Stmt = struct
module Hptset = struct
include Hptset.Make
- (Stmt_Id)
- (struct let v = [ [ ] ] end)
- (struct let l = [ ] (* This should be [Ast.self], but cannot be done
- here *) end)
+ (Stmt_Id)
+ (struct let v = [ [ ] ] end)
+ (struct let l = [ ] (* This should be [Ast.self], but cannot be done
+ here *) end)
end
let () = clear_caches := Hptset.clear_caches :: !clear_caches
let rec loc_skind = function
| Return(_, l) | Goto(_, l) | Break(l) | Continue l | If(_, _, _, l)
| Switch (_, _, _, l) | Loop (_, _, l, _, _)
- | TryFinally (_, _, l) | TryExcept (_, _, _, l)
+ | TryFinally (_, _, l) | TryExcept (_, _, _, l)
| Throw (_,l) | TryCatch(_,_,l) -> l
| Instr hd -> Instr.loc hd
| Block b -> (match b.bstmts with [] -> Location.unknown | s :: _ -> loc s)
@@ -318,35 +318,35 @@ end
module Kinstr = struct
include Make_with_collections
- (struct
- type t = kinstr
- let name = "Kinstr"
- let reprs = Kglobal :: List.map (fun s -> Kstmt s) Stmt.reprs
- let compare i1 i2 = match i1, i2 with
- | Kglobal, Kglobal -> 0
- | Kglobal, _ -> 1
- | _, Kglobal -> -1
- | Kstmt s1, Kstmt s2 -> Stmt.compare s1 s2
- let equal t1 t2 = compare t1 t2 = 0
- let hash = function
- | Kglobal -> 1 lsl 29
- | Kstmt s -> s.sid
- let copy = Datatype.undefined
- let internal_pretty_code p fmt = function
- | Kglobal ->
- Format.fprintf fmt "Kglobal"
- | Kstmt s ->
- let pp fmt =
- Format.fprintf fmt "@[<hv 2>Kstmt@;%a@]"
- (Stmt.internal_pretty_code Type.Call) s
- in
- Type.par p Type.Call fmt pp
- let pretty fmt = function
- | Kglobal ->
- Format.fprintf fmt "Kglobal"
- | Kstmt s -> Stmt.pretty fmt s
- let varname _ = "ki"
- end)
+ (struct
+ type t = kinstr
+ let name = "Kinstr"
+ let reprs = Kglobal :: List.map (fun s -> Kstmt s) Stmt.reprs
+ let compare i1 i2 = match i1, i2 with
+ | Kglobal, Kglobal -> 0
+ | Kglobal, _ -> 1
+ | _, Kglobal -> -1
+ | Kstmt s1, Kstmt s2 -> Stmt.compare s1 s2
+ let equal t1 t2 = compare t1 t2 = 0
+ let hash = function
+ | Kglobal -> 1 lsl 29
+ | Kstmt s -> s.sid
+ let copy = Datatype.undefined
+ let internal_pretty_code p fmt = function
+ | Kglobal ->
+ Format.fprintf fmt "Kglobal"
+ | Kstmt s ->
+ let pp fmt =
+ Format.fprintf fmt "@[<hv 2>Kstmt@;%a@]"
+ (Stmt.internal_pretty_code Type.Call) s
+ in
+ Type.par p Type.Call fmt pp
+ let pretty fmt = function
+ | Kglobal ->
+ Format.fprintf fmt "Kglobal"
+ | Kstmt s -> Stmt.pretty fmt s
+ let varname _ = "ki"
+ end)
let loc = function
| Kstmt st -> Stmt.loc st
@@ -394,17 +394,17 @@ let compare_exp_struct_eq =
ref (fun _ -> failwith "compare_exp_struct_eq not yet defined")
type type_compare_config =
- { by_name : bool;
- logic_type: bool;
- unroll: bool }
+ { by_name : bool;
+ logic_type: bool;
+ unroll: bool }
let rec compare_attribute config a1 a2 = match a1, a2 with
- | Attr (s1, l1), Attr (s2, l2) ->
- compare_chain (=?=) s1 s2 (compare_attrparam_list config) l1 l2
- | AttrAnnot s1, AttrAnnot s2 -> s1 =?= s2
- | Attr _, AttrAnnot _ -> -1
- | AttrAnnot _, Attr _ -> 1
-and compare_attributes config l1 l2 =
+ | Attr (s1, l1), Attr (s2, l2) ->
+ compare_chain (=?=) s1 s2 (compare_attrparam_list config) l1 l2
+ | AttrAnnot s1, AttrAnnot s2 -> s1 =?= s2
+ | Attr _, AttrAnnot _ -> -1
+ | AttrAnnot _, Attr _ -> 1
+and compare_attributes config l1 l2 =
let l1, l2 = if config.logic_type
then !drop_non_logic_attributes l1, !drop_non_logic_attributes l2
else l1,l2
@@ -415,39 +415,39 @@ and compare_attrparam config a1 a2 = match a1, a2 with
| AInt i1, AInt i2 -> Integer.compare i1 i2
| AStr s1, AStr s2 -> s1 =?= s2
| ACons ((s1: string), l1), ACons (s2, l2) ->
- let r1 = (=?=) s1 s2 in
- if r1 <> 0 then r1
- else
- compare_attrparam_list config l1 l2
+ let r1 = (=?=) s1 s2 in
+ if r1 <> 0 then r1
+ else
+ compare_attrparam_list config l1 l2
| ASizeOf t1, ASizeOf t2 -> compare_type config t1 t2
| ASizeOfE p1, ASizeOfE p2 -> compare_attrparam config p1 p2
| AAlignOf t1, AAlignOf t2 -> compare_type config t1 t2
| AAlignOfE p1, AAlignOfE p2 -> compare_attrparam config p1 p2
| AUnOp (op1, a1), AUnOp (op2, a2) ->
- compare_chain (=?=) op1 op2 (compare_attrparam config) a1 a2
+ compare_chain (=?=) op1 op2 (compare_attrparam config) a1 a2
| ABinOp (op1, a1, a1'), ABinOp (op2, a2, a2') ->
- compare_chain (=?=) op1 op2
- (compare_chain
- (compare_attrparam config) a1 a2 (compare_attrparam config))
- a1' a2'
+ compare_chain (=?=) op1 op2
+ (compare_chain
+ (compare_attrparam config) a1 a2 (compare_attrparam config))
+ a1' a2'
| ADot (a1, s1), ADot (a2, s2) ->
- compare_chain (=?=) s1 s2 (compare_attrparam config) a1 a2
+ compare_chain (=?=) s1 s2 (compare_attrparam config) a1 a2
| AStar a1, AStar a2
| AAddrOf a1, AAddrOf a2 -> compare_attrparam config a1 a2
| AIndex (a1, a1'), AIndex (a2, a2') ->
- compare_chain
- (compare_attrparam config) a1 a2
- (compare_attrparam config) a1' a2'
+ compare_chain
+ (compare_attrparam config) a1 a2
+ (compare_attrparam config) a1' a2'
| AQuestion (a1, a1', a1''), AQuestion (a2, a2', a2'') ->
- compare_chain
- (compare_attrparam config) a1 a2
- (compare_chain (compare_attrparam config) a1' a2'
- (compare_attrparam config))
- a1'' a2''
- | (AInt _ | AStr _ | ACons _ | ASizeOf _ | ASizeOfE _ |
- AAlignOf _ | AAlignOfE _ | AUnOp _ | ABinOp _ | ADot _ |
- AStar _ | AAddrOf _ | AIndex _ | AQuestion _ as a1), a2 ->
- index_attrparam a1 - index_attrparam a2
+ compare_chain
+ (compare_attrparam config) a1 a2
+ (compare_chain (compare_attrparam config) a1' a2'
+ (compare_attrparam config))
+ a1'' a2''
+ | (AInt _ | AStr _ | ACons _ | ASizeOf _ | ASizeOfE _ |
+ AAlignOf _ | AAlignOfE _ | AUnOp _ | ABinOp _ | ADot _ |
+ AStar _ | AAddrOf _ | AIndex _ | AQuestion _ as a1), a2 ->
+ index_attrparam a1 - index_attrparam a2
and compare_array_sizes e1o e2o =
let compare_non_empty_size e1 e2 =
let i1 = !constfoldtoint e1 in
@@ -467,60 +467,60 @@ and compare_type config t1 t2 =
else t1,t2
in
match typs with
- | TVoid l1, TVoid l2 -> compare_attributes config l1 l2
- | TInt (i1, l1), TInt (i2, l2) ->
- compare_chain (=?=) i1 i2 (compare_attributes config) l1 l2
- | TFloat (f1, l1), TFloat (f2, l2) ->
- compare_chain (=?=) f1 f2 (compare_attributes config) l1 l2
- | TPtr (t1, l1), TPtr (t2, l2) ->
- compare_chain
- (compare_type config) t1 t2
- (compare_attributes config) l1 l2
- | TArray (t1', e1, _, l1), TArray (t2', e2, _, l2) ->
- compare_chain compare_array_sizes e1 e2
- (compare_chain
- (compare_type config) t1' t2'
- (compare_attributes config)) l1 l2
- | TFun (r1, a1, v1, l1), TFun (r2, a2, v2, l2) ->
- compare_chain (compare_type config) r1 r2
- (compare_chain (=?=) v1 v2
- (compare_chain (compare_arg_list config) a1 a2
- (compare_attributes config))) l1 l2
- | TNamed (t1,a1), TNamed (t2,a2) ->
- assert (not config.unroll);
- compare_chain (=?=) t1.tname t2.tname
- (compare_attributes config) a1 a2
- | TComp (c1, _, l1), TComp (c2, _, l2) ->
- let res =
- if config.by_name
- then (=?=) c1.cname c2.cname
- else (=?=) c1.ckey c2.ckey
- in
- if res <> 0 then res
- else compare_attributes config l1 l2
- | TEnum (e1, l1), TEnum (e2, l2) ->
- compare_chain
- (=?=) e1.ename e2.ename
- (compare_attributes config) l1 l2
- | TBuiltin_va_list l1, TBuiltin_va_list l2 ->
- compare_attributes config l1 l2
- | (TVoid _ | TInt _ | TFloat _ | TPtr _ | TArray _ | TFun _ | TNamed _ |
- TComp _ | TEnum _ | TBuiltin_va_list _ as a1), a2 ->
- index_typ a1 - index_typ a2
+ | TVoid l1, TVoid l2 -> compare_attributes config l1 l2
+ | TInt (i1, l1), TInt (i2, l2) ->
+ compare_chain (=?=) i1 i2 (compare_attributes config) l1 l2
+ | TFloat (f1, l1), TFloat (f2, l2) ->
+ compare_chain (=?=) f1 f2 (compare_attributes config) l1 l2
+ | TPtr (t1, l1), TPtr (t2, l2) ->
+ compare_chain
+ (compare_type config) t1 t2
+ (compare_attributes config) l1 l2
+ | TArray (t1', e1, _, l1), TArray (t2', e2, _, l2) ->
+ compare_chain compare_array_sizes e1 e2
+ (compare_chain
+ (compare_type config) t1' t2'
+ (compare_attributes config)) l1 l2
+ | TFun (r1, a1, v1, l1), TFun (r2, a2, v2, l2) ->
+ compare_chain (compare_type config) r1 r2
+ (compare_chain (=?=) v1 v2
+ (compare_chain (compare_arg_list config) a1 a2
+ (compare_attributes config))) l1 l2
+ | TNamed (t1,a1), TNamed (t2,a2) ->
+ assert (not config.unroll);
+ compare_chain (=?=) t1.tname t2.tname
+ (compare_attributes config) a1 a2
+ | TComp (c1, _, l1), TComp (c2, _, l2) ->
+ let res =
+ if config.by_name
+ then (=?=) c1.cname c2.cname
+ else (=?=) c1.ckey c2.ckey
+ in
+ if res <> 0 then res
+ else compare_attributes config l1 l2
+ | TEnum (e1, l1), TEnum (e2, l2) ->
+ compare_chain
+ (=?=) e1.ename e2.ename
+ (compare_attributes config) l1 l2
+ | TBuiltin_va_list l1, TBuiltin_va_list l2 ->
+ compare_attributes config l1 l2
+ | (TVoid _ | TInt _ | TFloat _ | TPtr _ | TArray _ | TFun _ | TNamed _ |
+ TComp _ | TEnum _ | TBuiltin_va_list _ as a1), a2 ->
+ index_typ a1 - index_typ a2
and compare_arg_list config l1 l2 =
Extlib.opt_compare
(compare_list
(fun (_n1, t1, l1) (_n2, t2, l2) ->
- (compare_chain (compare_type config) t1 t2
- (compare_attributes config)) l1 l2
+ (compare_chain (compare_type config) t1 t2
+ (compare_attributes config)) l1 l2
)) l1 l2
let hash_attribute _config = function
| AttrAnnot s -> Hashtbl.hash s
| Attr (s, _) -> (* We do not hash attrparams. There is a recursivity problem
- with typ, and the equal function will be complicated enough in itself *)
- 3 * Hashtbl.hash s + 117
+ with typ, and the equal function will be complicated enough in itself *)
+ 3 * Hashtbl.hash s + 117
let hash_attributes config l =
let attrs = if config.logic_type then !drop_non_logic_attributes l else l in
hash_list (hash_attribute config) attrs
@@ -528,48 +528,48 @@ let hash_attributes config l =
let rec hash_type config t =
let t = if config.unroll then !punrollType t else t in
match t with
- | TVoid l -> Hashtbl.hash (hash_attributes config l, 1)
- | TInt (i, l) -> Hashtbl.hash (i, 2, hash_attributes config l)
- | TFloat (f, l) -> Hashtbl.hash (f, 3, hash_attributes config l)
- | TPtr (t, l) ->
- Hashtbl.hash (hash_type config t, 4, hash_attributes config l)
- | TArray (t, _, _, l) ->
- Hashtbl.hash (hash_type config t, 5, hash_attributes config l)
+ | TVoid l -> Hashtbl.hash (hash_attributes config l, 1)
+ | TInt (i, l) -> Hashtbl.hash (i, 2, hash_attributes config l)
+ | TFloat (f, l) -> Hashtbl.hash (f, 3, hash_attributes config l)
+ | TPtr (t, l) ->
+ Hashtbl.hash (hash_type config t, 4, hash_attributes config l)
+ | TArray (t, _, _, l) ->
+ Hashtbl.hash (hash_type config t, 5, hash_attributes config l)
| TFun (r, a, v, l) ->
- Hashtbl.hash
- (hash_type config r, 6, hash_args config a, v, hash_attributes config l)
+ Hashtbl.hash
+ (hash_type config r, 6, hash_args config a, v, hash_attributes config l)
| TNamed (ti, l) ->
- Hashtbl.hash (ti.tname, 7, hash_attributes config l)
- | TComp (c, _, l) ->
- Hashtbl.hash
- ((if config.by_name then Hashtbl.hash c.cname else c.ckey), 8,
- hash_attributes config l)
+ Hashtbl.hash (ti.tname, 7, hash_attributes config l)
+ | TComp (c, _, l) ->
+ Hashtbl.hash
+ ((if config.by_name then Hashtbl.hash c.cname else c.ckey), 8,
+ hash_attributes config l)
| TEnum (e, l) ->
- Hashtbl.hash (e.ename, 9, hash_attributes config l)
+ Hashtbl.hash (e.ename, 9, hash_attributes config l)
| TBuiltin_va_list l -> Hashtbl.hash (hash_attributes config l, 10)
and hash_args config = function
| None -> 11713
| Some l ->
- hash_list
- (fun (_, t, l) ->
- Hashtbl.hash (17, hash_type config t, hash_attributes config l)) l
+ hash_list
+ (fun (_, t, l) ->
+ Hashtbl.hash (17, hash_type config t, hash_attributes config l)) l
module Attribute=struct
let pretty_ref = ref (fun _ _ -> assert false)
include Make_with_collections
- (struct
- type t = attribute
- let config = { by_name = false; logic_type = false; unroll = true }
- let name = "Attribute"
- let reprs = [ AttrAnnot "" ]
- let compare = compare_attribute config
- let hash = hash_attribute config
- let equal = Datatype.from_compare
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let pretty fmt t = !pretty_ref fmt t
- let varname = Datatype.undefined
- end)
+ (struct
+ type t = attribute
+ let config = { by_name = false; logic_type = false; unroll = true }
+ let name = "Attribute"
+ let reprs = [ AttrAnnot "" ]
+ let compare = compare_attribute config
+ let hash = hash_attribute config
+ let equal = Datatype.from_compare
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let pretty fmt t = !pretty_ref fmt t
+ let varname = Datatype.undefined
+ end)
end
(* Shared between the different modules for types. *)
@@ -583,38 +583,38 @@ module MakeTyp(M:sig val config: type_compare_config val name: string end) =
struct
let pretty_ref = pretty_typ_ref
include Make_with_collections
- (struct
- type t = typ
- let name = M.name
- let reprs = [ TVoid [] ]
- let compare = compare_type M.config
- let hash = hash_type M.config
- let equal = Datatype.from_compare
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let pretty fmt t = !pretty_typ_ref fmt t
- let varname = Datatype.undefined
- end)
+ (struct
+ type t = typ
+ let name = M.name
+ let reprs = [ TVoid [] ]
+ let compare = compare_type M.config
+ let hash = hash_type M.config
+ let equal = Datatype.from_compare
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let pretty fmt t = !pretty_typ_ref fmt t
+ let varname = Datatype.undefined
+ end)
end
module Typ= struct
-include
- MakeTyp
- (struct
- let config = { by_name = false; logic_type = false; unroll = true; }
- let name = "Typ"
- end)
-let toplevel_attr = function
- | TVoid a -> a
- | TInt (_, a) -> a
- | TFloat (_, a) -> a
- | TNamed (_, a) -> a
- | TPtr (_, a) -> a
- | TArray (_, _, _,a) -> a
- | TComp (_, _, a) -> a
- | TEnum (_, a) -> a
- | TFun (_, _, _, a) -> a
- | TBuiltin_va_list a -> a
+ include
+ MakeTyp
+ (struct
+ let config = { by_name = false; logic_type = false; unroll = true; }
+ let name = "Typ"
+ end)
+ let toplevel_attr = function
+ | TVoid a -> a
+ | TInt (_, a) -> a
+ | TFloat (_, a) -> a
+ | TNamed (_, a) -> a
+ | TPtr (_, a) -> a
+ | TArray (_, _, _,a) -> a
+ | TComp (_, _, a) -> a
+ | TEnum (_, a) -> a
+ | TFun (_, _, _, a) -> a
+ | TBuiltin_va_list a -> a
end
module TypByName =
@@ -622,14 +622,14 @@ module TypByName =
(struct
let config = { by_name = true; logic_type = false; unroll = false; }
let name = "TypByName"
- end)
+ end)
module TypNoUnroll =
MakeTyp
(struct
let config = { by_name = false; logic_type = false; unroll = false; }
let name = "TypNoUnroll"
- end)
+ end)
module Typeinfo =
Make_with_collections
@@ -638,69 +638,69 @@ module Typeinfo =
type t = typeinfo
let name = "Type_info"
let reprs =
- [ { torig_name = "";
- tname = "";
- ttype = TVoid [];
- treferenced = false } ]
+ [ { torig_name = "";
+ tname = "";
+ ttype = TVoid [];
+ treferenced = false } ]
let compare v1 v2 = String.compare v1.tname v2.tname
let hash v = Hashtbl.hash v.tname
let equal v1 v2 = v1.tname = v2.tname
- end)
+ end)
module Exp = struct
let pretty_ref = ref (fun _ _ -> assert false)
let dummy = { eid = -1; enode = Const (CStr ""); eloc = Location.unknown }
include Make_with_collections
- (struct
- include Datatype.Undefined
- type t = exp
- let name = "Exp"
- let reprs =
- [ dummy ]
- let compare e1 e2 = Datatype.Int.compare e1.eid e2.eid
- let hash e = Hashtbl.hash e.eid
- let equal e1 e2 = e1.eid = e2.eid
- let pretty fmt t = !pretty_ref fmt t
- end)
+ (struct
+ include Datatype.Undefined
+ type t = exp
+ let name = "Exp"
+ let reprs =
+ [ dummy ]
+ let compare e1 e2 = Datatype.Int.compare e1.eid e2.eid
+ let hash e = Hashtbl.hash e.eid
+ let equal e1 e2 = e1.eid = e2.eid
+ let pretty fmt t = !pretty_ref fmt t
+ end)
end
module Label = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Make_with_collections
- (struct
- type t = label
- let name = "Label"
- let reprs =
- [ Label("", Location.unknown, false); Default Location.unknown ]
- let internal_pretty_code = Datatype.undefined
- let pretty = !pretty_ref
- let varname = Datatype.undefined
- let hash = function
- | Default _ -> 7
- | Case (e, _) -> Exp.hash e
- | Label (s, _, b) -> Hashtbl.hash s + (if b then 13 else 59)
- let compare l1 l2 = match l1, l2 with
- | Default loc1, Default loc2 -> Location.compare loc1 loc2
- | Case (e1, loc1), Case (e2, loc2) ->
+ (struct
+ type t = label
+ let name = "Label"
+ let reprs =
+ [ Label("", Location.unknown, false); Default Location.unknown ]
+ let internal_pretty_code = Datatype.undefined
+ let pretty = !pretty_ref
+ let varname = Datatype.undefined
+ let hash = function
+ | Default _ -> 7
+ | Case (e, _) -> Exp.hash e
+ | Label (s, _, b) -> Hashtbl.hash s + (if b then 13 else 59)
+ let compare l1 l2 = match l1, l2 with
+ | Default loc1, Default loc2 -> Location.compare loc1 loc2
+ | Case (e1, loc1), Case (e2, loc2) ->
let c = Exp.compare e1 e2 in
if c = 0 then Location.compare loc1 loc2
else c
- | Label (s1, loc1, b1), Label (s2, loc2, b2) ->
+ | Label (s1, loc1, b1), Label (s2, loc2, b2) ->
let c = s1 =?= s2 in
if c = 0 then
let c = b1 =?= b2 in
if c = 0 then Location.compare loc1 loc2
else c
else c
- | Label _, (Case _ | Default _)
- | Case _, Default _ -> -1
- | Case _, Label _
- | Default _, (Label _ | Case _) -> 1
- let equal = Datatype.from_compare
- let copy = Datatype.undefined
- end)
+ | Label _, (Case _ | Default _)
+ | Case _, Default _ -> -1
+ | Case _, Label _
+ | Default _, (Label _ | Case _) -> 1
+ let equal = Datatype.from_compare
+ let copy = Datatype.undefined
+ end)
end
-
+
module Varinfo_Id = struct
let pretty_ref = ref (fun _ _ -> assert false)
let internal_pretty_code_ref = ref (fun _ _ _ -> assert false)
@@ -727,17 +727,17 @@ module Varinfo_Id = struct
include Make_with_collections
(struct
- type t = varinfo
- let name = "Varinfo"
- let reprs = [ dummy ]
- let compare v1 v2 = Datatype.Int.compare v1.vid v2.vid
- let hash v = v.vid
- let equal v1 v2 = v1.vid = v2.vid
- let copy = Datatype.undefined
- let internal_pretty_code p fmt v = !internal_pretty_code_ref p fmt v
- let pretty fmt v = !pretty_ref fmt v
- let varname v = "vi_" ^ v.vorig_name
- end)
+ type t = varinfo
+ let name = "Varinfo"
+ let reprs = [ dummy ]
+ let compare v1 v2 = Datatype.Int.compare v1.vid v2.vid
+ let hash v = v.vid
+ let equal v1 v2 = v1.vid = v2.vid
+ let copy = Datatype.undefined
+ let internal_pretty_code p fmt v = !internal_pretty_code_ref p fmt v
+ let pretty fmt v = !pretty_ref fmt v
+ let varname v = "vi_" ^ v.vorig_name
+ end)
let id v = v.vid
end
@@ -746,9 +746,9 @@ module Varinfo = struct
module Hptset = struct
include Hptset.Make
- (Varinfo_Id)
- (struct let v = [ [ ] ] end)
- (struct let l = [ ] (* Should morally be [Ast.self] *) end)
+ (Varinfo_Id)
+ (struct let v = [ [ ] ] end)
+ (struct let l = [ ] (* Should morally be [Ast.self] *) end)
end
let () = clear_caches := Hptset.clear_caches :: !clear_caches
end
@@ -756,115 +756,115 @@ end
module Compinfo = struct
let pretty_ref = Extlib.mk_fun "Cil_datatype.Compinfo.pretty_ref"
include Make_with_collections
- (struct
- type t = compinfo
- let name = "compinfo"
- let reprs =
- [ { cstruct = false;
- corig_name = "";
- cname = "";
- ckey = -1;
- cfields = [];
- cattr = [];
- cdefined = false;
- creferenced = false } ]
- let compare v1 v2 = Datatype.Int.compare v1.ckey v2.ckey
- let hash v = Hashtbl.hash v.ckey
- let equal v1 v2 = v1.ckey = v2.ckey
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let pretty fmt f = !pretty_ref fmt f
- let varname = Datatype.undefined
- end)
+ (struct
+ type t = compinfo
+ let name = "compinfo"
+ let reprs =
+ [ { cstruct = false;
+ corig_name = "";
+ cname = "";
+ ckey = -1;
+ cfields = [];
+ cattr = [];
+ cdefined = false;
+ creferenced = false } ]
+ let compare v1 v2 = Datatype.Int.compare v1.ckey v2.ckey
+ let hash v = Hashtbl.hash v.ckey
+ let equal v1 v2 = v1.ckey = v2.ckey
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let pretty fmt f = !pretty_ref fmt f
+ let varname = Datatype.undefined
+ end)
end
module Fieldinfo = struct
let pretty_ref = Extlib.mk_fun "Cil_datatype.Fieldinfo.pretty_ref"
include Make_with_collections
- (struct
- type t = fieldinfo
- let name = "fieldinfo"
- let reprs =
- List.fold_left
- (fun acc ci ->
- List.fold_left
- (fun acc typ ->
- List.fold_left
- (fun acc loc ->
- { fcomp = ci;
- forig_name = "";
- fname = "";
- ftype = typ;
- fbitfield = None;
- fattr = [];
- floc = loc;
- faddrof = false;
- fsize_in_bits = None;
- foffset_in_bits = None;
- fpadding_in_bits = None }
- :: acc)
- acc
- Location.reprs)
- acc
- Typ.reprs)
- []
- Compinfo.reprs
- let fid fi = fi.fcomp.ckey, fi.fname
- let compare f1 f2 = Extlib.compare_basic (fid f1) (fid f2)
- let hash f1 = Hashtbl.hash (fid f1)
- let equal f1 f2 = (fid f1) = (fid f2)
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let pretty fmt f = !pretty_ref fmt f
- let varname = Datatype.undefined
- end)
+ (struct
+ type t = fieldinfo
+ let name = "fieldinfo"
+ let reprs =
+ List.fold_left
+ (fun acc ci ->
+ List.fold_left
+ (fun acc typ ->
+ List.fold_left
+ (fun acc loc ->
+ { fcomp = ci;
+ forig_name = "";
+ fname = "";
+ ftype = typ;
+ fbitfield = None;
+ fattr = [];
+ floc = loc;
+ faddrof = false;
+ fsize_in_bits = None;
+ foffset_in_bits = None;
+ fpadding_in_bits = None }
+ :: acc)
+ acc
+ Location.reprs)
+ acc
+ Typ.reprs)
+ []
+ Compinfo.reprs
+ let fid fi = fi.fcomp.ckey, fi.fname
+ let compare f1 f2 = Extlib.compare_basic (fid f1) (fid f2)
+ let hash f1 = Hashtbl.hash (fid f1)
+ let equal f1 f2 = (fid f1) = (fid f2)
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let pretty fmt f = !pretty_ref fmt f
+ let varname = Datatype.undefined
+ end)
end
module Enuminfo = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Make_with_collections
- (struct
- include Datatype.Undefined
- type t = enuminfo
- let name = "Enuminfo"
- let reprs =
- [ { eorig_name = "";
- ename = "";
- eitems = [];
- eattr = [];
- ereferenced = false;
- ekind = IInt; } ]
- let compare v1 v2 = String.compare v1.ename v2.ename
- let hash v = Hashtbl.hash v.ename
- let equal v1 v2 = v1.ename = v2.ename
- let pretty fmt v = !pretty_ref fmt v
- end)
+ (struct
+ include Datatype.Undefined
+ type t = enuminfo
+ let name = "Enuminfo"
+ let reprs =
+ [ { eorig_name = "";
+ ename = "";
+ eitems = [];
+ eattr = [];
+ ereferenced = false;
+ ekind = IInt; } ]
+ let compare v1 v2 = String.compare v1.ename v2.ename
+ let hash v = Hashtbl.hash v.ename
+ let equal v1 v2 = v1.ename = v2.ename
+ let pretty fmt v = !pretty_ref fmt v
+ end)
end
-
+
module Enumitem = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Make_with_collections
- (struct
- include Datatype.Undefined
- type t = enumitem
- let name = "Enumitem"
- let reprs =
- List.map
- (fun i ->
- { eiorig_name = "";
- einame = "";
- eival =
- { eloc = Location.unknown; eid = -1; enode = Const (CStr "") };
- eihost = i;
- eiloc = Location.unknown })
- Enuminfo.reprs
- let compare v1 v2 = String.compare v1.einame v2.einame
- let hash v = Hashtbl.hash v.einame
- let equal v1 v2 = v1.einame = v2.einame
- let pretty fmt v = !pretty_ref fmt v
- end)
+ (struct
+ include Datatype.Undefined
+ type t = enumitem
+ let name = "Enumitem"
+ let reprs =
+ List.map
+ (fun i ->
+ { eiorig_name = "";
+ einame = "";
+ eival =
+ { eloc = Location.unknown; eid = -1; enode = Const (CStr "") };
+ eihost = i;
+ eiloc = Location.unknown })
+ Enuminfo.reprs
+ let compare v1 v2 = String.compare v1.einame v2.einame
+ let hash v = Hashtbl.hash v.einame
+ let equal v1 v2 = v1.einame = v2.einame
+ let pretty fmt v = !pretty_ref fmt v
+ end)
end
-
+
let compare_constant c1 c2 = match c1, c2 with
| CInt64(v1,k1,_), CInt64(v2,k2,_) ->
compare_chain Integer.compare v1 v2 Extlib.compare_basic k1 k2
@@ -882,155 +882,155 @@ let compare_constant c1 c2 = match c1, c2 with
| (CReal _, CEnum _) -> 1
| (CStr _ | CWStr _ | CChr _ | CReal _ | CEnum _),
(CInt64 _ | CStr _ | CWStr _ | CChr _ | CReal _) -> -1
-
+
let hash_const c =
match c with
- | CStr _ | CWStr _ | CChr _ -> Hashtbl.hash c
- | CReal (fn,fk,_) -> Hashtbl.hash fn + Hashtbl.hash fk
- | CInt64 (n,k,_) -> Integer.hash n + Hashtbl.hash k
- | CEnum ei -> 95 + Enumitem.hash ei
+ | CStr _ | CWStr _ | CChr _ -> Hashtbl.hash c
+ | CReal (fn,fk,_) -> Hashtbl.hash fn + Hashtbl.hash fk
+ | CInt64 (n,k,_) -> Integer.hash n + Hashtbl.hash k
+ | CEnum ei -> 95 + Enumitem.hash ei
module StructEq =
- struct
- let rec compare_exp e1 e2 =
- match e1.enode, e2.enode with
- | Const (CStr _), Const (CStr _)
- | Const (CWStr _), Const (CWStr _) -> compare e1.eid e2.eid
- | Const c1, Const c2 -> compare_constant c1 c2
- | Const _, _ -> 1
- | _, Const _ -> -1
- | Lval lv1, Lval lv2 -> compare_lval lv1 lv2
- | Lval _, _ -> 1
- | _, Lval _ -> -1
- | SizeOf t1, SizeOf t2 -> Typ.compare t1 t2
- | SizeOf _, _ -> 1
- | _, SizeOf _ -> -1
- | SizeOfE e1, SizeOfE e2 -> compare_exp e1 e2
- | SizeOfE _, _ -> 1
- | _, SizeOfE _ -> -1
- | SizeOfStr s1, SizeOfStr s2 -> String.compare s1 s2
- | SizeOfStr _, _ -> 1
- | _, SizeOfStr _ -> -1
- | AlignOf ty1, AlignOf ty2 -> Typ.compare ty1 ty2
- | AlignOf _, _ -> 1
- | _, AlignOf _ -> -1
- | AlignOfE e1, AlignOfE e2 -> compare_exp e1 e2
- | AlignOfE _, _ -> 1
- | _, AlignOfE _ -> -1
- | UnOp(op1,e1,ty1), UnOp(op2,e2,ty2) ->
- let res = Extlib.compare_basic op1 op2 in
- if res = 0 then
- let res = compare_exp e1 e2 in
- if res = 0 then Typ.compare ty1 ty2 else res
- else res
- | UnOp _, _ -> 1
- | _, UnOp _ -> -1
- | BinOp(op1,e11,e21, ty1), BinOp(op2,e12,e22, ty2) ->
- let res = Extlib.compare_basic op1 op2 in
- if res = 0 then
- let res = compare_exp e11 e12 in
- if res = 0 then
- let res = compare_exp e21 e22 in
- if res = 0 then Typ.compare ty1 ty2 else res
- else res
- else res
- | BinOp _, _ -> 1
- | _, BinOp _ -> -1
- | CastE(t1,e1), CastE(t2, e2) ->
- let res = Typ.compare t1 t2 in
- if res = 0 then compare_exp e1 e2 else res
- | CastE _, _ -> 1
- | _, CastE _ -> -1
- | AddrOf lv1, AddrOf lv2 -> compare_lval lv1 lv2
- | AddrOf _, _ -> 1
- | _, AddrOf _ -> -1
- | StartOf lv1, StartOf lv2 -> compare_lval lv1 lv2
- | StartOf _, _ -> 1
- | _, StartOf _ -> -1
- | Info _, Info _ ->
- Cmdline.Kernel_log.fatal
- "[exp_compare] Info node is obsolete. Do not use it"
-
- and compare_lval (h1,o1) (h2,o2) =
- let res = compare_lhost h1 h2 in
+struct
+ let rec compare_exp e1 e2 =
+ match e1.enode, e2.enode with
+ | Const (CStr _), Const (CStr _)
+ | Const (CWStr _), Const (CWStr _) -> compare e1.eid e2.eid
+ | Const c1, Const c2 -> compare_constant c1 c2
+ | Const _, _ -> 1
+ | _, Const _ -> -1
+ | Lval lv1, Lval lv2 -> compare_lval lv1 lv2
+ | Lval _, _ -> 1
+ | _, Lval _ -> -1
+ | SizeOf t1, SizeOf t2 -> Typ.compare t1 t2
+ | SizeOf _, _ -> 1
+ | _, SizeOf _ -> -1
+ | SizeOfE e1, SizeOfE e2 -> compare_exp e1 e2
+ | SizeOfE _, _ -> 1
+ | _, SizeOfE _ -> -1
+ | SizeOfStr s1, SizeOfStr s2 -> String.compare s1 s2
+ | SizeOfStr _, _ -> 1
+ | _, SizeOfStr _ -> -1
+ | AlignOf ty1, AlignOf ty2 -> Typ.compare ty1 ty2
+ | AlignOf _, _ -> 1
+ | _, AlignOf _ -> -1
+ | AlignOfE e1, AlignOfE e2 -> compare_exp e1 e2
+ | AlignOfE _, _ -> 1
+ | _, AlignOfE _ -> -1
+ | UnOp(op1,e1,ty1), UnOp(op2,e2,ty2) ->
+ let res = Extlib.compare_basic op1 op2 in
+ if res = 0 then
+ let res = compare_exp e1 e2 in
+ if res = 0 then Typ.compare ty1 ty2 else res
+ else res
+ | UnOp _, _ -> 1
+ | _, UnOp _ -> -1
+ | BinOp(op1,e11,e21, ty1), BinOp(op2,e12,e22, ty2) ->
+ let res = Extlib.compare_basic op1 op2 in
+ if res = 0 then
+ let res = compare_exp e11 e12 in
+ if res = 0 then
+ let res = compare_exp e21 e22 in
+ if res = 0 then Typ.compare ty1 ty2 else res
+ else res
+ else res
+ | BinOp _, _ -> 1
+ | _, BinOp _ -> -1
+ | CastE(t1,e1), CastE(t2, e2) ->
+ let res = Typ.compare t1 t2 in
+ if res = 0 then compare_exp e1 e2 else res
+ | CastE _, _ -> 1
+ | _, CastE _ -> -1
+ | AddrOf lv1, AddrOf lv2 -> compare_lval lv1 lv2
+ | AddrOf _, _ -> 1
+ | _, AddrOf _ -> -1
+ | StartOf lv1, StartOf lv2 -> compare_lval lv1 lv2
+ | StartOf _, _ -> 1
+ | _, StartOf _ -> -1
+ | Info _, Info _ ->
+ Cmdline.Kernel_log.fatal
+ "[exp_compare] Info node is obsolete. Do not use it"
+
+ and compare_lval (h1,o1) (h2,o2) =
+ let res = compare_lhost h1 h2 in
+ if res = 0 then compare_offset o1 o2 else res
+
+ and compare_lhost h1 h2 =
+ match h1, h2 with
+ | Var v1, Var v2 -> Varinfo.compare v1 v2
+ | Var _, Mem _ -> 1
+ | Mem e1, Mem e2 -> compare_exp e1 e2
+ | Mem _, Var _ -> -1
+
+ and compare_offset o1 o2 =
+ match o1, o2 with
+ | NoOffset, NoOffset -> 0
+ | NoOffset, _ -> 1
+ | _, NoOffset -> -1
+ | Field(f1,o1), Field(f2, o2) ->
+ let res = Fieldinfo.compare f1 f2 in
+ if res = 0 then compare_offset o1 o2 else res
+ | Field _, _ -> 1
+ | _, Field _ -> -1
+ | Index(e1, o1), Index(e2, o2) ->
+ let res = compare_exp e1 e2 in
if res = 0 then compare_offset o1 o2 else res
-
- and compare_lhost h1 h2 =
- match h1, h2 with
- | Var v1, Var v2 -> Varinfo.compare v1 v2
- | Var _, Mem _ -> 1
- | Mem e1, Mem e2 -> compare_exp e1 e2
- | Mem _, Var _ -> -1
-
- and compare_offset o1 o2 =
- match o1, o2 with
- | NoOffset, NoOffset -> 0
- | NoOffset, _ -> 1
- | _, NoOffset -> -1
- | Field(f1,o1), Field(f2, o2) ->
- let res = Fieldinfo.compare f1 f2 in
- if res = 0 then compare_offset o1 o2 else res
- | Field _, _ -> 1
- | _, Field _ -> -1
- | Index(e1, o1), Index(e2, o2) ->
- let res = compare_exp e1 e2 in
- if res = 0 then compare_offset o1 o2 else res
-
- let prime = 83047
- let rec hash_exp acc e =
- match e.enode with
- | Const c -> prime * acc lxor hash_const c
- | Lval lv -> hash_lval ((prime*acc) lxor 42) lv
- | SizeOf t -> (prime*acc) lxor Typ.hash t
- | SizeOfE e -> hash_exp ((prime*acc) lxor 75) e
- | SizeOfStr s -> (prime*acc) lxor Hashtbl.hash s
- | AlignOf t -> (prime*acc) lxor Typ.hash t
- | AlignOfE e -> hash_exp ((prime*acc) lxor 153) e
- | UnOp(op,e,ty) ->
- let res = hash_exp ((prime*acc) lxor Hashtbl.hash op) e in
- (prime*res) lxor Typ.hash ty
- | BinOp(op,e1,e2,ty) ->
- let res = hash_exp ((prime*acc) lxor Hashtbl.hash op) e1 in
- let res = hash_exp ((prime*res) lxor 257) e2 in
- (prime * res) lxor Typ.hash ty
- | CastE(ty,e) -> hash_exp ((prime*acc) lxor Typ.hash ty) e
- | AddrOf lv -> hash_lval (prime*acc lxor 329) lv
- | StartOf lv -> hash_lval (prime*acc lxor 431) lv
- | Info _ ->
- Cmdline.Kernel_log.fatal
- "Info node is deprecated and should not be used@."
- and hash_lval acc (h,o) =
- hash_offset ((prime * acc) lxor hash_lhost 856 h) o
- and hash_lhost acc = function
- | Var v -> (prime * acc) lxor (Varinfo.hash v)
- | Mem e -> hash_exp ((prime * acc) lxor 967) e
- and hash_offset acc = function
- | NoOffset -> (prime * acc) lxor 1583
- | Index(e,o) ->
- let res = hash_exp 1790 e in
- hash_offset ((prime * acc) lxor res) o
- | Field(f,o) -> hash_offset ((prime * acc) lxor Hashtbl.hash f.fname) o
- end
+
+ let prime = 83047
+ let rec hash_exp acc e =
+ match e.enode with
+ | Const c -> prime * acc lxor hash_const c
+ | Lval lv -> hash_lval ((prime*acc) lxor 42) lv
+ | SizeOf t -> (prime*acc) lxor Typ.hash t
+ | SizeOfE e -> hash_exp ((prime*acc) lxor 75) e
+ | SizeOfStr s -> (prime*acc) lxor Hashtbl.hash s
+ | AlignOf t -> (prime*acc) lxor Typ.hash t
+ | AlignOfE e -> hash_exp ((prime*acc) lxor 153) e
+ | UnOp(op,e,ty) ->
+ let res = hash_exp ((prime*acc) lxor Hashtbl.hash op) e in
+ (prime*res) lxor Typ.hash ty
+ | BinOp(op,e1,e2,ty) ->
+ let res = hash_exp ((prime*acc) lxor Hashtbl.hash op) e1 in
+ let res = hash_exp ((prime*res) lxor 257) e2 in
+ (prime * res) lxor Typ.hash ty
+ | CastE(ty,e) -> hash_exp ((prime*acc) lxor Typ.hash ty) e
+ | AddrOf lv -> hash_lval (prime*acc lxor 329) lv
+ | StartOf lv -> hash_lval (prime*acc lxor 431) lv
+ | Info _ ->
+ Cmdline.Kernel_log.fatal
+ "Info node is deprecated and should not be used@."
+ and hash_lval acc (h,o) =
+ hash_offset ((prime * acc) lxor hash_lhost 856 h) o
+ and hash_lhost acc = function
+ | Var v -> (prime * acc) lxor (Varinfo.hash v)
+ | Mem e -> hash_exp ((prime * acc) lxor 967) e
+ and hash_offset acc = function
+ | NoOffset -> (prime * acc) lxor 1583
+ | Index(e,o) ->
+ let res = hash_exp 1790 e in
+ hash_offset ((prime * acc) lxor res) o
+ | Field(f,o) -> hash_offset ((prime * acc) lxor Hashtbl.hash f.fname) o
+end
module Wide_string =
Datatype.List_with_collections(Datatype.Int64)
(struct let module_name = "Cil_datatype.Wide_string" end)
module Constant =
- struct
- let pretty_ref = Extlib.mk_fun "Cil_datatype.Constant.pretty_ref"
- include Make_with_collections
- (struct
- include Datatype.Undefined
- type t = constant
- let name = "Constant"
- let reprs = [ CInt64(Integer.zero, IInt, Some "0") ]
- let compare = compare_constant
- let hash = hash_const
- let equal = Datatype.from_compare
- let pretty fmt t = !pretty_ref fmt t
- end)
- end
+struct
+ let pretty_ref = Extlib.mk_fun "Cil_datatype.Constant.pretty_ref"
+ include Make_with_collections
+ (struct
+ include Datatype.Undefined
+ type t = constant
+ let name = "Constant"
+ let reprs = [ CInt64(Integer.zero, IInt, Some "0") ]
+ let compare = compare_constant
+ let hash = hash_const
+ let equal = Datatype.from_compare
+ let pretty fmt t = !pretty_ref fmt t
+ end)
+end
module ExpStructEq =
Make_with_collections
@@ -1043,22 +1043,22 @@ module ExpStructEq =
let hash = StructEq.hash_exp 7863
let equal = Datatype.from_compare
let pretty fmt t = !Exp.pretty_ref fmt t
- end)
+ end)
let () = compare_exp_struct_eq := ExpStructEq.compare
module Block = struct
let pretty_ref = Extlib.mk_fun "Cil_datatype.Block.pretty_ref"
include Make
- (struct
- type t = block
- let name = "Block"
- let reprs =
- [{battrs=[]; blocals=Varinfo.reprs; bstatics = [];
- bstmts=Stmt.reprs; bscoping=true}]
- let internal_pretty_code = Datatype.undefined
- let pretty fmt b = !pretty_ref fmt b
- let varname = Datatype.undefined
- end)
+ (struct
+ type t = block
+ let name = "Block"
+ let reprs =
+ [{battrs=[]; blocals=Varinfo.reprs; bstatics = [];
+ bstmts=Stmt.reprs; bscoping=true}]
+ let internal_pretty_code = Datatype.undefined
+ let pretty fmt b = !pretty_ref fmt b
+ let varname = Datatype.undefined
+ end)
let equal b1 b2 = (b1 == b2)
end
@@ -1075,9 +1075,9 @@ and equal_offset o1 o2 =
match o1,o2 with
| NoOffset, NoOffset -> true
| Field(f1,o1), Field(f2,o2) ->
- Fieldinfo.equal f1 f2 && equal_offset o1 o2
+ Fieldinfo.equal f1 f2 && equal_offset o1 o2
| Index(e1,o1), Index(e2,o2) ->
- Exp.equal e1 e2 && equal_offset o1 o2
+ Exp.equal e1 e2 && equal_offset o1 o2
| (NoOffset | Field _ | Index _), _ -> false
let rec compare_lval (h1,o1) (h2,o2) =
@@ -1116,66 +1116,66 @@ and hash_offset = function
module Lval = struct
let pretty_ref = ref (fun _ -> assert false)
include Make_with_collections
- (struct
- type t = lval
- let name = "Lval"
- let reprs = List.map (fun v -> Var v, NoOffset) Varinfo.reprs
- let compare = compare_lval
- let equal = equal_lval
- let hash = hash_lval
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let pretty fmt x = !pretty_ref fmt x
- let varname _ = "lv"
- end)
+ (struct
+ type t = lval
+ let name = "Lval"
+ let reprs = List.map (fun v -> Var v, NoOffset) Varinfo.reprs
+ let compare = compare_lval
+ let equal = equal_lval
+ let hash = hash_lval
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let pretty fmt x = !pretty_ref fmt x
+ let varname _ = "lv"
+ end)
end
module LvalStructEq =
Make_with_collections
(struct
type t = lval
- let name = "LvalStructEq"
- let reprs = List.map (fun v -> Var v, NoOffset) Varinfo.reprs
- let compare = StructEq.compare_lval
- let equal = Datatype.from_compare
- let hash = StructEq.hash_lval 13598
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let pretty fmt x = !Lval.pretty_ref fmt x
- let varname _ = "lv"
- end)
+ let name = "LvalStructEq"
+ let reprs = List.map (fun v -> Var v, NoOffset) Varinfo.reprs
+ let compare = StructEq.compare_lval
+ let equal = Datatype.from_compare
+ let hash = StructEq.hash_lval 13598
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let pretty fmt x = !Lval.pretty_ref fmt x
+ let varname _ = "lv"
+ end)
module Offset = struct
let pretty_ref = ref (fun _ -> assert false)
include Make_with_collections
- (struct
- type t = offset
- let name = "Offset"
- let reprs = [NoOffset]
- let compare = compare_offset
- let equal = equal_offset
- let hash = hash_offset
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let pretty fmt x = !pretty_ref fmt x
- let varname _ = "offs"
- end)
+ (struct
+ type t = offset
+ let name = "Offset"
+ let reprs = [NoOffset]
+ let compare = compare_offset
+ let equal = equal_offset
+ let hash = hash_offset
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let pretty fmt x = !pretty_ref fmt x
+ let varname _ = "offs"
+ end)
end
module OffsetStructEq =
Make_with_collections
(struct
type t = offset
- let name = "OffsetStructEq"
- let reprs = [NoOffset]
- let compare = StructEq.compare_offset
- let equal = Datatype.from_compare
- let hash = StructEq.hash_offset 75489
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let pretty fmt x = !Offset.pretty_ref fmt x
- let varname _ = "offs"
- end)
+ let name = "OffsetStructEq"
+ let reprs = [NoOffset]
+ let compare = StructEq.compare_offset
+ let equal = Datatype.from_compare
+ let hash = StructEq.hash_offset 75489
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let pretty fmt x = !Offset.pretty_ref fmt x
+ let varname _ = "offs"
+ end)
(**************************************************************************)
(** {3 ACSL types} *)
@@ -1184,133 +1184,133 @@ module OffsetStructEq =
module Logic_var = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Make_with_collections
- (struct
- type t = logic_var
- let name = "Logic_var"
- let reprs =
- let dummy v =
- let kind = match v with None -> LVQuant | Some _ -> LVC in
- { lv_name = "";
- lv_kind = kind;
- lv_id = -1;
- lv_type = Linteger;
- lv_origin = v;
- lv_attr = [];
- }
- in
- dummy None
- :: List.map (fun v -> dummy (Some v)) Varinfo.reprs
- let compare v1 v2 = Datatype.Int.compare v1.lv_id v2.lv_id
- let hash v = v.lv_id
- let equal v1 v2 = v1.lv_id = v2.lv_id
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let pretty fmt t = !pretty_ref fmt t
- let varname _ = "logic_var"
- end)
+ (struct
+ type t = logic_var
+ let name = "Logic_var"
+ let reprs =
+ let dummy v =
+ let kind = match v with None -> LVQuant | Some _ -> LVC in
+ { lv_name = "";
+ lv_kind = kind;
+ lv_id = -1;
+ lv_type = Linteger;
+ lv_origin = v;
+ lv_attr = [];
+ }
+ in
+ dummy None
+ :: List.map (fun v -> dummy (Some v)) Varinfo.reprs
+ let compare v1 v2 = Datatype.Int.compare v1.lv_id v2.lv_id
+ let hash v = v.lv_id
+ let equal v1 v2 = v1.lv_id = v2.lv_id
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let pretty fmt t = !pretty_ref fmt t
+ let varname _ = "logic_var"
+ end)
end
module Builtin_logic_info = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Make_with_collections
- (struct
- type t = builtin_logic_info
- let name = "Builtin_logic_info"
- let reprs =
- [ { bl_name = "";
- bl_labels = [];
- bl_params = [];
- bl_type = None;
- bl_profile = [] } ]
- let compare i1 i2 = String.compare i1.bl_name i2.bl_name
- let hash i = Hashtbl.hash i.bl_name
- let equal i1 i2 = i1.bl_name = i2.bl_name
- let copy = Datatype.identity (* works only if an AST is never modified *)
- let internal_pretty_code = Datatype.undefined
- let pretty = !pretty_ref
- let varname = Datatype.undefined
- end)
+ (struct
+ type t = builtin_logic_info
+ let name = "Builtin_logic_info"
+ let reprs =
+ [ { bl_name = "";
+ bl_labels = [];
+ bl_params = [];
+ bl_type = None;
+ bl_profile = [] } ]
+ let compare i1 i2 = String.compare i1.bl_name i2.bl_name
+ let hash i = Hashtbl.hash i.bl_name
+ let equal i1 i2 = i1.bl_name = i2.bl_name
+ let copy = Datatype.identity (* works only if an AST is never modified *)
+ let internal_pretty_code = Datatype.undefined
+ let pretty = !pretty_ref
+ let varname = Datatype.undefined
+ end)
end
-
+
module Logic_type_info = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Make_with_collections
- (struct
- type t = logic_type_info
- let name = "Logic_type_info"
- let reprs =
- [ { lt_name = ""; lt_params = []; lt_def = None; lt_attr=[] } ]
- let compare t1 t2 = String.compare t1.lt_name t2.lt_name
- let equal t1 t2 = t1.lt_name = t2.lt_name
- let hash t = Hashtbl.hash t.lt_name
- let copy = Datatype.identity (* works only if an AST is never modified *)
- let internal_pretty_code = Datatype.undefined
- let pretty = !pretty_ref
- let varname = Datatype.undefined
- end)
+ (struct
+ type t = logic_type_info
+ let name = "Logic_type_info"
+ let reprs =
+ [ { lt_name = ""; lt_params = []; lt_def = None; lt_attr=[] } ]
+ let compare t1 t2 = String.compare t1.lt_name t2.lt_name
+ let equal t1 t2 = t1.lt_name = t2.lt_name
+ let hash t = Hashtbl.hash t.lt_name
+ let copy = Datatype.identity (* works only if an AST is never modified *)
+ let internal_pretty_code = Datatype.undefined
+ let pretty = !pretty_ref
+ let varname = Datatype.undefined
+ end)
end
module Logic_ctor_info = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Make_with_collections
- (struct
- type t = logic_ctor_info
- let name = "Logic_ctor_info"
- let reprs =
- List.map
- (fun v -> { ctor_name = ""; ctor_type = v; ctor_params = [] })
- Logic_type_info.reprs
- let compare t1 t2 = String.compare t1.ctor_name t2.ctor_name
- let equal t1 t2 = t1.ctor_name = t2.ctor_name
- let hash t = Hashtbl.hash t.ctor_name
- let copy = Datatype.identity (* works only if an AST is never modified *)
- let internal_pretty_code = Datatype.undefined
- let pretty = !pretty_ref
- let varname = Datatype.undefined
- end)
+ (struct
+ type t = logic_ctor_info
+ let name = "Logic_ctor_info"
+ let reprs =
+ List.map
+ (fun v -> { ctor_name = ""; ctor_type = v; ctor_params = [] })
+ Logic_type_info.reprs
+ let compare t1 t2 = String.compare t1.ctor_name t2.ctor_name
+ let equal t1 t2 = t1.ctor_name = t2.ctor_name
+ let hash t = Hashtbl.hash t.ctor_name
+ let copy = Datatype.identity (* works only if an AST is never modified *)
+ let internal_pretty_code = Datatype.undefined
+ let pretty = !pretty_ref
+ let varname = Datatype.undefined
+ end)
end
-
+
module Initinfo = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Make
- (struct
- type t = initinfo
- let name = "Initinfo"
- let reprs =
- { init = None } ::
- List.map (fun t -> { init = Some (CompoundInit(t, [])) }) Typ.reprs
- let internal_pretty_code = Datatype.undefined
- let pretty = !pretty_ref
- let varname = Datatype.undefined
- end)
+ (struct
+ type t = initinfo
+ let name = "Initinfo"
+ let reprs =
+ { init = None } ::
+ List.map (fun t -> { init = Some (CompoundInit(t, [])) }) Typ.reprs
+ let internal_pretty_code = Datatype.undefined
+ let pretty = !pretty_ref
+ let varname = Datatype.undefined
+ end)
end
module Logic_info = struct
let pretty_ref = ref (fun fmt f -> Logic_var.pretty fmt f.l_var_info)
include Make_with_collections
- (struct
- type t = logic_info
- let name = "Logic_info"
- let reprs =
- List.map
- (fun v ->
- { l_var_info = v;
- l_labels = [];
- l_tparams = [];
- l_type = None;
- l_profile = [];
- l_body = LBnone })
- Logic_var.reprs
- let compare i1 i2 = Logic_var.compare i1.l_var_info i2.l_var_info
- let equal i1 i2 = Logic_var.equal i1.l_var_info i2.l_var_info
- let hash i = Logic_var.hash i.l_var_info
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let pretty = !pretty_ref
- let varname _ = "logic_varinfo"
- end)
+ (struct
+ type t = logic_info
+ let name = "Logic_info"
+ let reprs =
+ List.map
+ (fun v ->
+ { l_var_info = v;
+ l_labels = [];
+ l_tparams = [];
+ l_type = None;
+ l_profile = [];
+ l_body = LBnone })
+ Logic_var.reprs
+ let compare i1 i2 = Logic_var.compare i1.l_var_info i2.l_var_info
+ let equal i1 i2 = Logic_var.equal i1.l_var_info i2.l_var_info
+ let hash i = Logic_var.hash i.l_var_info
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let pretty = !pretty_ref
+ let varname _ = "logic_varinfo"
+ end)
end
-
+
let rec compare_logic_type config v1 v2 =
let rank = function
| Linteger -> 0
@@ -1325,32 +1325,32 @@ let rec compare_logic_type config v1 v2 =
if k1 <> k2 then k1-k2
else
match v1,v2 with
- | Ctype t1 , Ctype t2 -> compare_type config t1 t2
- | Ltype ({lt_def = Some (LTsyn t1)},ts1),
- Ltype ({lt_def = Some (LTsyn t2)},ts2) when config.unroll ->
- let c = compare_logic_type config t1 t2 in
- if c <> 0 then c
- else compare_list (compare_logic_type config) ts1 ts2
- | Ltype(a,ts1), Ltype(b,ts2) ->
- let c = Logic_type_info.compare a b in
- if c <> 0 then c
- else compare_list (compare_logic_type config) ts1 ts2
- | Lvar x1, Lvar x2 -> Datatype.String.compare x1 x2
- | Linteger, Linteger -> 0
- | Lreal, Lreal -> 0
- | Larrow(l1, t1), Larrow(l2, t2) ->
- let c = compare_logic_type config t1 t2 in
- if c <> 0 then c else compare_list (compare_logic_type config) l1 l2
- | _ -> assert false
+ | Ctype t1 , Ctype t2 -> compare_type config t1 t2
+ | Ltype ({lt_def = Some (LTsyn t1)},ts1),
+ Ltype ({lt_def = Some (LTsyn t2)},ts2) when config.unroll ->
+ let c = compare_logic_type config t1 t2 in
+ if c <> 0 then c
+ else compare_list (compare_logic_type config) ts1 ts2
+ | Ltype(a,ts1), Ltype(b,ts2) ->
+ let c = Logic_type_info.compare a b in
+ if c <> 0 then c
+ else compare_list (compare_logic_type config) ts1 ts2
+ | Lvar x1, Lvar x2 -> Datatype.String.compare x1 x2
+ | Linteger, Linteger -> 0
+ | Lreal, Lreal -> 0
+ | Larrow(l1, t1), Larrow(l2, t2) ->
+ let c = compare_logic_type config t1 t2 in
+ if c <> 0 then c else compare_list (compare_logic_type config) l1 l2
+ | _ -> assert false
let rec hash_logic_type config = function
| Linteger -> 0
| Lreal -> 1
| Ctype ty -> hash_type config ty
| Ltype({ lt_def = Some (LTsyn t)},_) when config.unroll ->
- hash_logic_type config t
+ hash_logic_type config t
| Ltype(t,_) ->
- Logic_type_info.hash t
+ Logic_type_info.hash t
| Lvar x -> Datatype.String.hash x
| Larrow (_,t) -> 41 * hash_logic_type config t
@@ -1361,47 +1361,47 @@ let rec hash_logic_type config = function
module Logic_info_structural = struct
let pretty_ref = ref (fun fmt f -> Logic_var.pretty fmt f.l_var_info)
include Make_with_collections
- (struct
- type t = logic_info
- let name = "Logic_info_structural"
- let reprs =
- List.map
- (fun v ->
- { l_var_info = v;
- l_labels = [];
- l_tparams = [];
- l_type = None;
- l_profile = [];
- l_body = LBnone })
- Logic_var.reprs
- let compare i1 i2 =
- let name_cmp =
- String.compare i1.l_var_info.lv_name i2.l_var_info.lv_name
- in
- if name_cmp <> 0 then name_cmp else begin
- let config =
- { by_name = true ; logic_type = true ; unroll = true }
- in
- let prm_cmp p1 p2 =
- compare_logic_type config p1.lv_type p2.lv_type
+ (struct
+ type t = logic_info
+ let name = "Logic_info_structural"
+ let reprs =
+ List.map
+ (fun v ->
+ { l_var_info = v;
+ l_labels = [];
+ l_tparams = [];
+ l_type = None;
+ l_profile = [];
+ l_body = LBnone })
+ Logic_var.reprs
+ let compare i1 i2 =
+ let name_cmp =
+ String.compare i1.l_var_info.lv_name i2.l_var_info.lv_name
in
- compare_list prm_cmp i1.l_profile i2.l_profile
- end
+ if name_cmp <> 0 then name_cmp else begin
+ let config =
+ { by_name = true ; logic_type = true ; unroll = true }
+ in
+ let prm_cmp p1 p2 =
+ compare_logic_type config p1.lv_type p2.lv_type
+ in
+ compare_list prm_cmp i1.l_profile i2.l_profile
+ end
- let equal = Datatype.from_compare
- let hash i = Logic_var.hash i.l_var_info
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let pretty = !pretty_ref
- let varname _ = "logic_varinfo"
- end)
+ let equal = Datatype.from_compare
+ let hash i = Logic_var.hash i.l_var_info
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let pretty = !pretty_ref
+ let varname _ = "logic_varinfo"
+ end)
end
(* Shared between the different modules for logic types *)
let pretty_logic_type_ref = ref (fun _ _ -> assert false)
module Make_Logic_type
- (M: sig val config: type_compare_config val name: string end) = struct
+ (M: sig val config: type_compare_config val name: string end) = struct
let pretty_ref = pretty_logic_type_ref
include Make_with_collections(
struct
@@ -1409,22 +1409,22 @@ module Make_Logic_type
type t = logic_type
let name = M.name
let reprs = List.map (fun t -> Ctype t) Typ.reprs
-
+
let compare = compare_logic_type M.config
let equal = Datatype.from_compare
let hash = hash_logic_type M.config
let pretty fmt t = !pretty_logic_type_ref fmt t
-
+
end)
end
module Logic_type =
Make_Logic_type(
- struct
- let config = { by_name = false; logic_type = true; unroll = true }
- let name = "Logic_type"
- end)
+ struct
+ let config = { by_name = false; logic_type = true; unroll = true }
+ let name = "Logic_type"
+ end)
module Logic_type_ByName =
Make_Logic_type(
@@ -1435,10 +1435,10 @@ module Logic_type_ByName =
module Logic_type_NoUnroll =
Make_Logic_type(
- struct
- let name = "Logic_type_NoUnroll"
- let config = { by_name = false; logic_type = false; unroll = false }
- end)
+ struct
+ let name = "Logic_type_NoUnroll"
+ let config = { by_name = false; logic_type = false; unroll = false }
+ end)
module Model_info = struct
let pretty_ref = ref (fun _ _ -> assert false)
@@ -1450,12 +1450,12 @@ module Model_info = struct
let reprs =
Extlib.product
(fun base field ->
- { mi_name = "dummy";
- mi_base_type = base;
- mi_field_type = field;
- mi_decl = Location.unknown;
- mi_attr = [];
- })
+ { mi_name = "dummy";
+ mi_base_type = base;
+ mi_field_type = field;
+ mi_decl = Location.unknown;
+ mi_attr = [];
+ })
Typ.reprs
Logic_type.reprs
let compare mi1 mi2 =
@@ -1535,16 +1535,16 @@ let rec compare_term t1 t2 =
| TBinOp(op1,x1,y1) , TBinOp(op2,x2,y2) ->
let c = Extlib.compare_basic op1 op2 in
if c <> 0 then c else
- let cx = compare_term x1 x2 in
- if cx <> 0 then cx else compare_term y1 y2
+ let cx = compare_term x1 x2 in
+ if cx <> 0 then cx else compare_term y1 y2
| TCastE(ty1,t1) , TCastE(ty2,t2) ->
let c = Typ.compare ty1 ty2 in
if c <> 0 then c else compare_term t1 t2
| Tapp(f1,labs1,ts1) , Tapp(f2,labs2,ts2) ->
let cf = Logic_info.compare f1 f2 in
if cf <> 0 then cf else
- let cl = compare_list compare_logic_label labs1 labs2 in
- if cl <> 0 then cl else compare_list compare_term ts1 ts2
+ let cl = compare_list compare_logic_label labs1 labs2 in
+ if cl <> 0 then cl else compare_list compare_term ts1 ts2
| Tlambda(q1,t1) , Tlambda(q2,t2) ->
let cq = compare_list Logic_var.compare q1 q2 in
if cq <> 0 then cq else compare_term t1 t2
@@ -1563,8 +1563,8 @@ let rec compare_term t1 t2 =
| TUpdate(x1,off1,y1) , TUpdate(x2,off2,y2) ->
let cx = compare_term x1 x2 in
if cx <> 0 then cx else
- let cf = compare_toffset off1 off2 in
- if cf <> 0 then cf else compare_term y1 y2
+ let cf = compare_toffset off1 off2 in
+ if cf <> 0 then cf else compare_term y1 y2
| Ttypeof t1 , Ttypeof t2 -> compare_term t1 t2
| Ttype ty1 , Ttype ty2 -> Typ.compare ty1 ty2
| Tempty_set , Tempty_set -> 0
@@ -1577,22 +1577,22 @@ let rec compare_term t1 t2 =
let c = Logic_info.compare x1 x2 in
if c <> 0 then c else compare_term t1 t2
| Tcomprehension (t1, q1, _p1), Tcomprehension (t2, q2, _p2) ->
- let c = compare_term t1 t2 in
- if c <> 0 then c
- else
- let cq = compare_list Logic_var.compare q1 q2 in
- if cq <> 0 then cq else assert false (* TODO !*)
+ let c = compare_term t1 t2 in
+ if c <> 0 then c
+ else
+ let cq = compare_list Logic_var.compare q1 q2 in
+ if cq <> 0 then cq else assert false (* TODO !*)
| TLogic_coerce(ty1,e1), TLogic_coerce(ty2,e2) ->
- let ct = Logic_type.compare ty1 ty2 in
- if ct <> 0 then ct
- else compare_term e1 e2
+ let ct = Logic_type.compare ty1 ty2 in
+ if ct <> 0 then ct
+ else compare_term e1 e2
| (TConst _ | TLval _ | TSizeOf _ | TSizeOfE _ | TSizeOfStr _ | TAlignOf _
| TAlignOfE _ | TUnOp _ | TBinOp _ | TCastE _ | TAddrOf _ | TStartOf _
| Tapp _ | Tlambda _ | TDataCons _ | Tif _ | Tat _
| Tbase_addr _ | Tblock_length _ | Toffset _
| Tnull | TUpdate _ | Ttypeof _
| Ttype _ | Tempty_set | Tunion _ | Tinter _ | Tcomprehension _
- | Trange _ | Tlet _
+ | Trange _ | Tlet _
| TLogic_coerce _), _ -> assert false
and compare_tlval (h1,off1) (h2,off2) =
@@ -1617,8 +1617,8 @@ and compare_toffset off1 off2 =
let cf = compare_term t1 t2 in
if cf <> 0 then cf else compare_toffset next1 next2
| TModel(f1,next1), TModel(f2,next2) ->
- let cf = Model_info.compare f1 f2 in
- if cf <> 0 then cf else compare_toffset next1 next2
+ let cf = Model_info.compare f1 f2 in
+ if cf <> 0 then cf else compare_toffset next1 next2
| TNoOffset , (TField _ | TModel _ | TIndex _ )
| TField _, (TModel _ | TIndex _)
| TModel _, TIndex _ -> (-1)
@@ -1656,106 +1656,106 @@ let hash_logic_constant = function
let hash_label x =
match x with
- StmtLabel r -> 2*(Stmt.hash !r)
- | BuiltinLabel l -> 2*(Hashtbl.hash l) + 1
- | FormalLabel s -> 2*(Hashtbl.hash s) + 3
+ StmtLabel r -> 2*(Stmt.hash !r)
+ | BuiltinLabel l -> 2*(Hashtbl.hash l) + 1
+ | FormalLabel s -> 2*(Hashtbl.hash s) + 3
let rec hash_term (acc,depth,tot) t =
if tot <= 0 || depth <= 0 then raise (StopRecursion acc)
else begin
match t.term_node with
- | TConst c -> (acc + hash_logic_constant c, tot - 1)
- | TLval lv -> hash_tlval (acc+19,depth - 1,tot -1) lv
- | TSizeOf t -> (acc + 38 + Typ.hash t, tot - 1)
- | TSizeOfE t -> hash_term (acc+57,depth -1, tot-1) t
- | TSizeOfStr s -> (acc + 76 + Hashtbl.hash s, tot - 1)
- | TAlignOf t -> (acc + 95 + Typ.hash t, tot - 1)
- | TAlignOfE t -> hash_term (acc+114,depth-1,tot-1) t
- | TUnOp(op,t) -> hash_term (acc+133+Hashtbl.hash op,depth-1,tot-2) t
- | TBinOp(bop,t1,t2) ->
- let hash1,tot1 =
- hash_term (acc+152+Hashtbl.hash bop,depth-1,tot-2) t1
- in
- hash_term (hash1,depth-1,tot1) t2
- | TCastE(ty,t) ->
- let hash1 = Typ.hash ty in
- hash_term (acc+171+hash1,depth-1,tot-2) t
- | TAddrOf lv -> hash_tlval (acc+190,depth-1,tot-1) lv
- | TStartOf lv -> hash_tlval (acc+209,depth-1,tot-1) lv
- | Tapp (li,labs,apps) ->
- let hash1 = acc + 228 + Logic_info.hash li in
- let hash_lb (acc,tot) l =
- if tot = 0 then raise (StopRecursion acc)
- else (acc + hash_label l,tot - 1)
- in
- let hash_one_term (acc,tot) t = hash_term (acc,depth-1,tot) t in
- let res = List.fold_left hash_lb (hash1,tot-1) labs in
- List.fold_left hash_one_term res apps
- | Tlambda(quants,t) ->
- let hash_var (acc,tot) lv =
- if tot = 0 then raise (StopRecursion acc)
- else (acc + Logic_var.hash lv,tot-1)
- in
- let (acc,tot) = List.fold_left hash_var (acc+247,tot-1) quants in
- hash_term (acc,depth-1,tot-1) t
- | TDataCons(ctor,args) ->
- let hash = acc + 266 + Logic_ctor_info.hash ctor in
- let hash_one_term (acc,tot) t = hash_term (acc,depth-1,tot) t in
- List.fold_left hash_one_term (hash,tot-1) args
- | Tif(t1,t2,t3) ->
- let hash1,tot1 = hash_term (acc+285,depth-1,tot) t1 in
- let hash2,tot2 = hash_term (hash1,depth-1,tot1) t2 in
- hash_term (hash2,depth-1,tot2) t3
- | Tat(t,l) ->
- let hash = acc + 304 + hash_label l in
- hash_term (hash,depth-1,tot-2) t
- | Tbase_addr (l,t) ->
- let hash = acc + 323 + hash_label l in
- hash_term (hash,depth-1,tot-2) t
- | Tblock_length (l,t) ->
- let hash = acc + 342 + hash_label l in
- hash_term (hash,depth-1,tot-2) t
- | Toffset (l,t) ->
- let hash = acc + 351 + hash_label l in
- hash_term (hash,depth-1,tot-2) t
- | Tnull -> acc+361, tot - 1
- | TUpdate(t1,off,t2) ->
- let hash1,tot1 = hash_term (acc+418,depth-1,tot-1) t1 in
- let hash2,tot2 = hash_toffset (hash1,depth-1,tot1) off in
- hash_term (hash2,depth-1,tot2) t2
- | Ttypeof t -> hash_term (acc+437,depth-1,tot-1) t
- | Ttype t -> acc + 456 + Typ.hash t, tot - 1
- | Tempty_set -> acc + 475, tot - 1
- | Tunion tl ->
- let hash_one_term (acc,tot) t = hash_term (acc,depth-1,tot) t in
- List.fold_left hash_one_term (acc+494,tot-1) tl
- | Tinter tl ->
- let hash_one_term (acc,tot) t = hash_term (acc,depth-1,tot) t in
- List.fold_left hash_one_term (acc+513,tot-1) tl
- | Tcomprehension (t,quants,_) -> (* TODO: hash predicates *)
- let hash_var (acc,tot) lv =
- if tot = 0 then raise (StopRecursion acc)
- else (acc + Logic_var.hash lv,tot-1)
- in
- let (acc,tot) = List.fold_left hash_var (acc+532,tot-1) quants in
- hash_term (acc,depth-1,tot-1) t
- | Trange(t1,t2) ->
- let acc = acc + 551 in
- let acc,tot =
- match t1 with
- None -> acc,tot - 1
- | Some t -> hash_term (acc,depth-1,tot-2) t
- in
- if tot <= 0 then raise (StopRecursion acc)
- else
- (match t2 with
- None -> acc, tot - 1
- | Some t -> hash_term (acc,depth-1,tot-1) t)
- | Tlet(li,t) ->
- hash_term
- (acc + 570 + Hashtbl.hash li.l_var_info.lv_name, depth-1, tot-1)
- t
- | TLogic_coerce(_,e) -> hash_term (acc + 587, depth - 1, tot - 1) e
+ | TConst c -> (acc + hash_logic_constant c, tot - 1)
+ | TLval lv -> hash_tlval (acc+19,depth - 1,tot -1) lv
+ | TSizeOf t -> (acc + 38 + Typ.hash t, tot - 1)
+ | TSizeOfE t -> hash_term (acc+57,depth -1, tot-1) t
+ | TSizeOfStr s -> (acc + 76 + Hashtbl.hash s, tot - 1)
+ | TAlignOf t -> (acc + 95 + Typ.hash t, tot - 1)
+ | TAlignOfE t -> hash_term (acc+114,depth-1,tot-1) t
+ | TUnOp(op,t) -> hash_term (acc+133+Hashtbl.hash op,depth-1,tot-2) t
+ | TBinOp(bop,t1,t2) ->
+ let hash1,tot1 =
+ hash_term (acc+152+Hashtbl.hash bop,depth-1,tot-2) t1
+ in
+ hash_term (hash1,depth-1,tot1) t2
+ | TCastE(ty,t) ->
+ let hash1 = Typ.hash ty in
+ hash_term (acc+171+hash1,depth-1,tot-2) t
+ | TAddrOf lv -> hash_tlval (acc+190,depth-1,tot-1) lv
+ | TStartOf lv -> hash_tlval (acc+209,depth-1,tot-1) lv
+ | Tapp (li,labs,apps) ->
+ let hash1 = acc + 228 + Logic_info.hash li in
+ let hash_lb (acc,tot) l =
+ if tot = 0 then raise (StopRecursion acc)
+ else (acc + hash_label l,tot - 1)
+ in
+ let hash_one_term (acc,tot) t = hash_term (acc,depth-1,tot) t in
+ let res = List.fold_left hash_lb (hash1,tot-1) labs in
+ List.fold_left hash_one_term res apps
+ | Tlambda(quants,t) ->
+ let hash_var (acc,tot) lv =
+ if tot = 0 then raise (StopRecursion acc)
+ else (acc + Logic_var.hash lv,tot-1)
+ in
+ let (acc,tot) = List.fold_left hash_var (acc+247,tot-1) quants in
+ hash_term (acc,depth-1,tot-1) t
+ | TDataCons(ctor,args) ->
+ let hash = acc + 266 + Logic_ctor_info.hash ctor in
+ let hash_one_term (acc,tot) t = hash_term (acc,depth-1,tot) t in
+ List.fold_left hash_one_term (hash,tot-1) args
+ | Tif(t1,t2,t3) ->
+ let hash1,tot1 = hash_term (acc+285,depth-1,tot) t1 in
+ let hash2,tot2 = hash_term (hash1,depth-1,tot1) t2 in
+ hash_term (hash2,depth-1,tot2) t3
+ | Tat(t,l) ->
+ let hash = acc + 304 + hash_label l in
+ hash_term (hash,depth-1,tot-2) t
+ | Tbase_addr (l,t) ->
+ let hash = acc + 323 + hash_label l in
+ hash_term (hash,depth-1,tot-2) t
+ | Tblock_length (l,t) ->
+ let hash = acc + 342 + hash_label l in
+ hash_term (hash,depth-1,tot-2) t
+ | Toffset (l,t) ->
+ let hash = acc + 351 + hash_label l in
+ hash_term (hash,depth-1,tot-2) t
+ | Tnull -> acc+361, tot - 1
+ | TUpdate(t1,off,t2) ->
+ let hash1,tot1 = hash_term (acc+418,depth-1,tot-1) t1 in
+ let hash2,tot2 = hash_toffset (hash1,depth-1,tot1) off in
+ hash_term (hash2,depth-1,tot2) t2
+ | Ttypeof t -> hash_term (acc+437,depth-1,tot-1) t
+ | Ttype t -> acc + 456 + Typ.hash t, tot - 1
+ | Tempty_set -> acc + 475, tot - 1
+ | Tunion tl ->
+ let hash_one_term (acc,tot) t = hash_term (acc,depth-1,tot) t in
+ List.fold_left hash_one_term (acc+494,tot-1) tl
+ | Tinter tl ->
+ let hash_one_term (acc,tot) t = hash_term (acc,depth-1,tot) t in
+ List.fold_left hash_one_term (acc+513,tot-1) tl
+ | Tcomprehension (t,quants,_) -> (* TODO: hash predicates *)
+ let hash_var (acc,tot) lv =
+ if tot = 0 then raise (StopRecursion acc)
+ else (acc + Logic_var.hash lv,tot-1)
+ in
+ let (acc,tot) = List.fold_left hash_var (acc+532,tot-1) quants in
+ hash_term (acc,depth-1,tot-1) t
+ | Trange(t1,t2) ->
+ let acc = acc + 551 in
+ let acc,tot =
+ match t1 with
+ None -> acc,tot - 1
+ | Some t -> hash_term (acc,depth-1,tot-2) t
+ in
+ if tot <= 0 then raise (StopRecursion acc)
+ else
+ (match t2 with
+ None -> acc, tot - 1
+ | Some t -> hash_term (acc,depth-1,tot-1) t)
+ | Tlet(li,t) ->
+ hash_term
+ (acc + 570 + Hashtbl.hash li.l_var_info.lv_name, depth-1, tot-1)
+ t
+ | TLogic_coerce(_,e) -> hash_term (acc + 587, depth - 1, tot - 1) e
end
and hash_tlval (acc,depth,tot) (h,o) =
@@ -1769,23 +1769,23 @@ and hash_tlhost (acc,depth,tot) t =
if tot <=0 || depth <= 0 then raise (StopRecursion acc)
else begin
match t with
- | TVar v -> acc + 17 + Logic_var.hash v, tot - 1
- | TResult typ -> 31 + 7 * Typ.hash typ, tot - 2
- | TMem t -> hash_term (acc + 71, depth - 1, tot - 1) t
+ | TVar v -> acc + 17 + Logic_var.hash v, tot - 1
+ | TResult typ -> 31 + 7 * Typ.hash typ, tot - 2
+ | TMem t -> hash_term (acc + 71, depth - 1, tot - 1) t
end
and hash_toffset (acc, depth, tot) t =
if depth <= 0 || tot <= 0 then raise (StopRecursion acc)
else begin
match t with
- | TNoOffset -> acc, tot - 1
- | TField(f,o) ->
- hash_toffset (acc+13+Fieldinfo.hash f, depth -1, tot - 1) o
- | TModel (mi, o) ->
- hash_toffset (acc+41+Model_info.hash mi, depth - 1, tot - 1) o
- | TIndex (t, o) ->
- let hash, tot = hash_term (acc+73, depth - 1, tot - 1) t in
- hash_toffset (hash, depth - 1, tot) o
+ | TNoOffset -> acc, tot - 1
+ | TField(f,o) ->
+ hash_toffset (acc+13+Fieldinfo.hash f, depth -1, tot - 1) o
+ | TModel (mi, o) ->
+ hash_toffset (acc+41+Model_info.hash mi, depth - 1, tot - 1) o
+ | TIndex (t, o) ->
+ let hash, tot = hash_term (acc+73, depth - 1, tot - 1) t in
+ hash_toffset (hash, depth - 1, tot) o
end
let hash_fct f t = try fst (f (0,10,100) t) with StopRecursion n -> n
@@ -1793,48 +1793,48 @@ let hash_fct f t = try fst (f (0,10,100) t) with StopRecursion n -> n
module Logic_constant = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Make_with_collections
- (struct
- type t = logic_constant
- let name = "Logic_constant"
- let reprs = [LStr "Foo"]
- let compare = compare_logic_constant
- let equal = Datatype.from_compare
- let hash = hash_logic_constant
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let pretty = !pretty_ref
- let varname _ = "lconst"
- end)
+ (struct
+ type t = logic_constant
+ let name = "Logic_constant"
+ let reprs = [LStr "Foo"]
+ let compare = compare_logic_constant
+ let equal = Datatype.from_compare
+ let hash = hash_logic_constant
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let pretty = !pretty_ref
+ let varname _ = "lconst"
+ end)
end
module Term = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Make_with_collections
- (struct
- type t = term
- let name = "Term"
- let reprs =
- List.map
- (fun t ->
- { term_node = TConst (LStr "");
- term_loc = Location.unknown;
- term_type = t;
- term_name = [] })
- Logic_type.reprs
- let compare = compare_term
- let equal = Datatype.from_compare
- let copy = Datatype.undefined
- let hash = hash_fct hash_term
- let internal_pretty_code = Datatype.undefined
- let pretty fmt t = !pretty_ref fmt t
- let varname _ = "term"
- end)
+ (struct
+ type t = term
+ let name = "Term"
+ let reprs =
+ List.map
+ (fun t ->
+ { term_node = TConst (LStr "");
+ term_loc = Location.unknown;
+ term_type = t;
+ term_name = [] })
+ Logic_type.reprs
+ let compare = compare_term
+ let equal = Datatype.from_compare
+ let copy = Datatype.undefined
+ let hash = hash_fct hash_term
+ let internal_pretty_code = Datatype.undefined
+ let pretty fmt t = !pretty_ref fmt t
+ let varname _ = "term"
+ end)
end
module Identified_term = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Make_with_collections
- (struct
+ (struct
type t = identified_term
let name = "Identified_term"
let reprs =
@@ -1842,70 +1842,70 @@ module Identified_term = struct
let compare x y = Extlib.compare_basic x.it_id y.it_id
let equal x y = x.it_id = y.it_id
let copy x =
- (* NB: Term.copy itself is undefined. *)
+ (* NB: Term.copy itself is undefined. *)
{ it_id = x.it_id; it_content = Term.copy x.it_content }
let hash x = x.it_id
let internal_pretty_code = Datatype.undefined
let pretty = !pretty_ref
let varname _ = "id_term"
- end)
+ end)
end
-
+
module Term_lhost = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Make_with_collections
- (struct
- type t = term_lhost
- let name = "Term_lhost"
- let reprs =
- List.fold_left
- (fun acc ty ->
- List.fold_left
- (fun acc t -> TMem t :: acc)
- (TResult ty :: acc)
- Term.reprs)
- (List.map (fun lv -> TVar lv) Logic_var.reprs)
- Typ.reprs
- let compare = compare_tlhost
- let equal = Datatype.from_compare
- let hash = hash_fct hash_tlhost
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let pretty = !pretty_ref
- let varname = Datatype.undefined
- end)
+ (struct
+ type t = term_lhost
+ let name = "Term_lhost"
+ let reprs =
+ List.fold_left
+ (fun acc ty ->
+ List.fold_left
+ (fun acc t -> TMem t :: acc)
+ (TResult ty :: acc)
+ Term.reprs)
+ (List.map (fun lv -> TVar lv) Logic_var.reprs)
+ Typ.reprs
+ let compare = compare_tlhost
+ let equal = Datatype.from_compare
+ let hash = hash_fct hash_tlhost
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let pretty = !pretty_ref
+ let varname = Datatype.undefined
+ end)
end
module Term_offset = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Make_with_collections
- (struct
- type t = term_offset
- let name = "Term_offset"
- let reprs = [ TNoOffset ]
- let compare = compare_toffset
- let equal = Datatype.from_compare
- let hash = hash_fct hash_toffset
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let pretty fmt t_o = !pretty_ref fmt t_o
- let varname = Datatype.undefined
- end)
+ (struct
+ type t = term_offset
+ let name = "Term_offset"
+ let reprs = [ TNoOffset ]
+ let compare = compare_toffset
+ let equal = Datatype.from_compare
+ let hash = hash_fct hash_toffset
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let pretty fmt t_o = !pretty_ref fmt t_o
+ let varname = Datatype.undefined
+ end)
end
module Term_lval = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Datatype.Pair_with_collections
- (Term_lhost)
- (Term_offset)
- (struct let module_name = "Cil_datatype.Term_lval" end)
+ (Term_lhost)
+ (Term_offset)
+ (struct let module_name = "Cil_datatype.Term_lval" end)
let pretty fmt t = !pretty_ref fmt t
end
module Logic_label = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Make_with_collections
- (struct
+ (struct
type t = logic_label
let name = "Logic_label"
let reprs =
@@ -1918,43 +1918,43 @@ module Logic_label = struct
let internal_pretty_code = Datatype.undefined
let pretty fmt l = !pretty_ref fmt l
let varname _ = "logic_label"
- end)
+ end)
end
module Logic_real = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Make_with_collections
- (struct
- type t = logic_real
- let name = "Logic_real"
- let reprs =
- [{ r_literal = ""; r_nearest = 0.0; r_lower = 0.0; r_upper = 0.0; }]
- let compare = compare_logic_real
- let hash r =
- let fhash = Datatype.Float.hash in
- fhash r.r_lower + 3 * fhash r.r_nearest + 7 * fhash r.r_upper +
- 11 * Datatype.String.hash r.r_literal
- let equal r1 r2 = compare r1 r2 = 0
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let pretty fmt t = !pretty_ref fmt t
- let varname _ = "logic_real"
- end)
+ (struct
+ type t = logic_real
+ let name = "Logic_real"
+ let reprs =
+ [{ r_literal = ""; r_nearest = 0.0; r_lower = 0.0; r_upper = 0.0; }]
+ let compare = compare_logic_real
+ let hash r =
+ let fhash = Datatype.Float.hash in
+ fhash r.r_lower + 3 * fhash r.r_nearest + 7 * fhash r.r_upper +
+ 11 * Datatype.String.hash r.r_literal
+ let equal r1 r2 = compare r1 r2 = 0
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let pretty fmt t = !pretty_ref fmt t
+ let varname _ = "logic_real"
+ end)
end
module Global_annotation = struct
let pretty_ref = ref (fun _ -> assert false)
include Make_with_collections
- (struct
- type t = global_annotation
- let name = "Global_annotation"
- let reprs = List.map (fun l -> Daxiomatic ("", [],[], l)) Location.reprs
- let internal_pretty_code = Datatype.undefined
- let pretty fmt v = !pretty_ref fmt v
- let varname = Datatype.undefined
+ (struct
+ type t = global_annotation
+ let name = "Global_annotation"
+ let reprs = List.map (fun l -> Daxiomatic ("", [],[], l)) Location.reprs
+ let internal_pretty_code = Datatype.undefined
+ let pretty fmt v = !pretty_ref fmt v
+ let varname = Datatype.undefined
- let rec compare g1 g2 =
- match g1,g2 with
+ let rec compare g1 g2 =
+ match g1,g2 with
| Dfun_or_pred (l1,_), Dfun_or_pred(l2,_) -> Logic_info.compare l1 l2
| Dfun_or_pred _,_ -> -1
| _, Dfun_or_pred _ -> 1
@@ -1995,27 +1995,27 @@ module Global_annotation = struct
| Dextended (ext1, _, _), Dextended (ext2, _, _) ->
Datatype.Int.compare ext1.ext_id ext2.ext_id
- let equal = Datatype.from_compare
+ let equal = Datatype.from_compare
- let rec hash g = match g with
- | Dfun_or_pred (l,_) -> 2 * Logic_info.hash l
- | Dvolatile ([],_,_,_,(_source,_)) ->
- Cmdline.Kernel_log.fatal
- "Empty location list for volatile annotation@."
- | Dvolatile (t::_,_,_,_,_) -> 3 * Identified_term.hash t
- | Daxiomatic (_,[],_,_) -> 5
- (* Empty axiomatic is weird but authorized. *)
- | Daxiomatic (_,g::_,_,_) -> 5 * hash g
- | Dtype (t,_) -> 7 * Logic_type_info.hash t
- | Dlemma(n,_,_,_,_,_,_) -> 11 * Datatype.String.hash n
- | Dinvariant(l,_) -> 13 * Logic_info.hash l
- | Dtype_annot(l,_) -> 17 * Logic_info.hash l
- | Dmodel_annot(l,_) -> 19 * Model_info.hash l
- | Dcustom_annot(_,n,_,_) -> 23 * Datatype.String.hash n
- | Dextended ({ext_id},_,_) -> 29 * Datatype.Int.hash ext_id
+ let rec hash g = match g with
+ | Dfun_or_pred (l,_) -> 2 * Logic_info.hash l
+ | Dvolatile ([],_,_,_,(_source,_)) ->
+ Cmdline.Kernel_log.fatal
+ "Empty location list for volatile annotation@."
+ | Dvolatile (t::_,_,_,_,_) -> 3 * Identified_term.hash t
+ | Daxiomatic (_,[],_,_) -> 5
+ (* Empty axiomatic is weird but authorized. *)
+ | Daxiomatic (_,g::_,_,_) -> 5 * hash g
+ | Dtype (t,_) -> 7 * Logic_type_info.hash t
+ | Dlemma(n,_,_,_,_,_,_) -> 11 * Datatype.String.hash n
+ | Dinvariant(l,_) -> 13 * Logic_info.hash l
+ | Dtype_annot(l,_) -> 17 * Logic_info.hash l
+ | Dmodel_annot(l,_) -> 19 * Model_info.hash l
+ | Dcustom_annot(_,n,_,_) -> 23 * Datatype.String.hash n
+ | Dextended ({ext_id},_,_) -> 29 * Datatype.Int.hash ext_id
- let copy = Datatype.undefined
- end)
+ let copy = Datatype.undefined
+ end)
let loc = function
| Dfun_or_pred(_, loc)
@@ -2045,16 +2045,16 @@ end
module Global = struct
let pretty_ref = ref (fun _ -> assert false)
include Make_with_collections
- (struct
- type t = global
- let name = "Global"
- let reprs = [ GText "" ]
- let internal_pretty_code = Datatype.undefined
- let pretty fmt v = !pretty_ref fmt v
- let varname = Datatype.undefined
+ (struct
+ type t = global
+ let name = "Global"
+ let reprs = [ GText "" ]
+ let internal_pretty_code = Datatype.undefined
+ let pretty fmt v = !pretty_ref fmt v
+ let varname = Datatype.undefined
- let compare g1 g2 =
- match g1, g2 with
+ let compare g1 g2 =
+ match g1, g2 with
| GType (t1,_), GType (t2,_) -> Typeinfo.compare t1 t2
| GType _,_ -> -1
| _, GType _ -> 1
@@ -2093,25 +2093,25 @@ module Global = struct
| _, GText _ -> 1
| GAnnot (g1,_), GAnnot(g2,_) -> Global_annotation.compare g1 g2
- let equal = Datatype.from_compare
+ let equal = Datatype.from_compare
- let hash g = match g with
- GType (t,_) -> 2 * Typeinfo.hash t
- | GCompTag (t,_) -> 3 * Compinfo.hash t
- | GCompTagDecl (t,_) -> 5 * Compinfo.hash t
- | GEnumTag (t,_) -> 7 * Enuminfo.hash t
- | GEnumTagDecl(t,_) -> 11 * Enuminfo.hash t
- | GVarDecl (v,_) -> 13 * Varinfo.hash v
- | GVar (v,_,_) -> 17 * Varinfo.hash v
- | GFun (f,_) -> 19 * Varinfo.hash f.svar
- | GAsm (_,l) -> 23 * Location.hash l
- | GText t -> 29 * Datatype.String.hash t
- | GAnnot (g,_) -> 31 * Global_annotation.hash g
- | GPragma(_,l) -> 37 * Location.hash l
- | GFunDecl (_,v,_) -> 43 * Varinfo.hash v
+ let hash g = match g with
+ GType (t,_) -> 2 * Typeinfo.hash t
+ | GCompTag (t,_) -> 3 * Compinfo.hash t
+ | GCompTagDecl (t,_) -> 5 * Compinfo.hash t
+ | GEnumTag (t,_) -> 7 * Enuminfo.hash t
+ | GEnumTagDecl(t,_) -> 11 * Enuminfo.hash t
+ | GVarDecl (v,_) -> 13 * Varinfo.hash v
+ | GVar (v,_,_) -> 17 * Varinfo.hash v
+ | GFun (f,_) -> 19 * Varinfo.hash f.svar
+ | GAsm (_,l) -> 23 * Location.hash l
+ | GText t -> 29 * Datatype.String.hash t
+ | GAnnot (g,_) -> 31 * Global_annotation.hash g
+ | GPragma(_,l) -> 37 * Location.hash l
+ | GFunDecl (_,v,_) -> 43 * Varinfo.hash v
- let copy = Datatype.undefined
- end)
+ let copy = Datatype.undefined
+ end)
let loc = function
| GFun(_, l)
@@ -2129,13 +2129,13 @@ module Global = struct
| GText _ -> Location.unknown
let attr = function
- | GVar (vi,_,_) | GFun ({svar = vi},_) | GVarDecl (vi,_) | GFunDecl (_,vi,_)->
- vi.vattr
- | GType (t,_) -> Typ.toplevel_attr t.ttype
- | GCompTag(ci,_) | GCompTagDecl(ci,_) -> ci.cattr
- | GEnumTag(ei,_) | GEnumTagDecl(ei,_) -> ei.eattr
- | GAnnot (g,_) -> Global_annotation.attr g
- | _ -> []
+ | GVar (vi,_,_) | GFun ({svar = vi},_) | GVarDecl (vi,_) | GFunDecl (_,vi,_)->
+ vi.vattr
+ | GType (t,_) -> Typ.toplevel_attr t.ttype
+ | GCompTag(ci,_) | GCompTagDecl(ci,_) -> ci.cattr
+ | GEnumTag(ei,_) | GEnumTagDecl(ei,_) -> ei.eattr
+ | GAnnot (g,_) -> Global_annotation.attr g
+ | _ -> []
end
@@ -2150,70 +2150,70 @@ module Kf = struct
let set_formal_decls = ref (fun _ _ -> assert false)
include Datatype.Make_with_collections
- (struct
- type t = kernel_function
- let name = "Cil_datatype.Kf"
- let structural_descr = Structural_descr.t_abstract
- let reprs =
- let empty_spec =
- { spec_behavior = [];
- spec_variant = None;
- spec_terminates = None;
- spec_complete_behaviors = [];
- spec_disjoint_behaviors = [] }
- in
- List.fold_left
- (fun acc loc ->
- List.fold_left
- (fun acc b ->
- List.fold_left
- (fun acc vi ->
- { fundec =
- Definition
- ({ svar = vi;
- smaxid = 0;
- slocals = [];
- sformals = [];
- sbody = b;
- smaxstmtid = None;
- sallstmts = [];
- sspec = empty_spec },
- loc);
- spec = empty_spec } :: acc)
- acc
- Varinfo.reprs)
- acc
- Block.reprs)
- []
- Location.reprs
- let compare k1 k2 = Datatype.Int.compare (id k1) (id k2)
- let equal k1 k2 =
- if k1 != k2 then begin
- if id k1 = id k2 then begin
- Cmdline.Kernel_log.fatal "Two kf for %a (%d) and %a (%d) (%d)@."
- Varinfo.pretty (vi k1) (Extlib.address_of_value k1)
- Varinfo.pretty (vi k2) (Extlib.address_of_value k2)
- (id k1)
- end;
- false
- end else true
- let hash = id
- let copy = Datatype.undefined
- let rehash x = match x.fundec with
- | Definition _ | Declaration (_, _, None, _)-> x
- | Declaration (_, v, Some args, _) ->
- !set_formal_decls v args;
- x
- let get_name_kf kf = (vi kf).Cil_types.vname
- let internal_pretty_code p_caller fmt kf =
- Type.par p_caller Type.Call fmt
- (fun fmt ->
- Format.fprintf fmt "@[<hv 2>Globals.Functions.find_by_name@;%S@]"
- (get_name_kf kf))
- let pretty fmt kf = Varinfo.pretty fmt (vi kf)
- let mem_project = Datatype.never_any_project
- let varname kf = "kf_" ^ (get_name_kf kf)
- end)
+ (struct
+ type t = kernel_function
+ let name = "Cil_datatype.Kf"
+ let structural_descr = Structural_descr.t_abstract
+ let reprs =
+ let empty_spec =
+ { spec_behavior = [];
+ spec_variant = None;
+ spec_terminates = None;
+ spec_complete_behaviors = [];
+ spec_disjoint_behaviors = [] }
+ in
+ List.fold_left
+ (fun acc loc ->
+ List.fold_left
+ (fun acc b ->
+ List.fold_left
+ (fun acc vi ->
+ { fundec =
+ Definition
+ ({ svar = vi;
+ smaxid = 0;
+ slocals = [];
+ sformals = [];
+ sbody = b;
+ smaxstmtid = None;
+ sallstmts = [];
+ sspec = empty_spec },
+ loc);
+ spec = empty_spec } :: acc)
+ acc
+ Varinfo.reprs)
+ acc
+ Block.reprs)
+ []
+ Location.reprs
+ let compare k1 k2 = Datatype.Int.compare (id k1) (id k2)
+ let equal k1 k2 =
+ if k1 != k2 then begin
+ if id k1 = id k2 then begin
+ Cmdline.Kernel_log.fatal "Two kf for %a (%d) and %a (%d) (%d)@."
+ Varinfo.pretty (vi k1) (Extlib.address_of_value k1)
+ Varinfo.pretty (vi k2) (Extlib.address_of_value k2)
+ (id k1)
+ end;
+ false
+ end else true
+ let hash = id
+ let copy = Datatype.undefined
+ let rehash x = match x.fundec with
+ | Definition _ | Declaration (_, _, None, _)-> x
+ | Declaration (_, v, Some args, _) ->
+ !set_formal_decls v args;
+ x
+ let get_name_kf kf = (vi kf).Cil_types.vname
+ let internal_pretty_code p_caller fmt kf =
+ Type.par p_caller Type.Call fmt
+ (fun fmt ->
+ Format.fprintf fmt "@[<hv 2>Globals.Functions.find_by_name@;%S@]"
+ (get_name_kf kf))
+ let pretty fmt kf = Varinfo.pretty fmt (vi kf)
+ let mem_project = Datatype.never_any_project
+ let varname kf = "kf_" ^ (get_name_kf kf)
+ end)
let () = Type.set_ml_name ty (Some "Kernel_function.ty")
end
@@ -2223,19 +2223,19 @@ module Code_annotation = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Make_with_collections
- (struct
- type t = code_annotation
- let name = "Code_annotation"
- let reprs =
- [ { annot_content = AAssigns([],WritesAny); annot_id = -1 } ]
- let hash x = x.annot_id
- let equal x y = x.annot_id = y.annot_id
- let compare x y = Datatype.Int.compare x.annot_id y.annot_id
- let copy = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let pretty fmt ca = !pretty_ref fmt ca
- let varname _ = "code_annot"
- end)
+ (struct
+ type t = code_annotation
+ let name = "Code_annotation"
+ let reprs =
+ [ { annot_content = AAssigns([],WritesAny); annot_id = -1 } ]
+ let hash x = x.annot_id
+ let equal x y = x.annot_id = y.annot_id
+ let compare x y = Datatype.Int.compare x.annot_id y.annot_id
+ let copy = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let pretty fmt ca = !pretty_ref fmt ca
+ let varname _ = "code_annot"
+ end)
let loc ca = match ca.annot_content with
| AAssert(_,_,{pred_loc=loc})
@@ -2249,23 +2249,23 @@ end
module Predicate = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Make
- (struct
- type t = predicate
- let name = "Predicate"
- let reprs =
- [ { pred_name = [ "" ];
- pred_loc = Location.unknown;
- pred_content = Pfalse } ]
- let internal_pretty_code = Datatype.undefined
- let pretty fmt x = !pretty_ref fmt x
- let varname _ = "p"
- end)
+ (struct
+ type t = predicate
+ let name = "Predicate"
+ let reprs =
+ [ { pred_name = [ "" ];
+ pred_loc = Location.unknown;
+ pred_content = Pfalse } ]
+ let internal_pretty_code = Datatype.undefined
+ let pretty fmt x = !pretty_ref fmt x
+ let varname _ = "p"
+ end)
end
module Identified_predicate = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Make_with_collections
- (struct
+ (struct
type t = identified_predicate
let name = "Identified_predicate"
let reprs =
@@ -2277,7 +2277,7 @@ module Identified_predicate = struct
let internal_pretty_code = Datatype.undefined
let pretty fmt x = !pretty_ref fmt x
let varname _ = "id_predyes"
- end)
+ end)
end
module Funbehavior =
@@ -2287,40 +2287,40 @@ module Funbehavior =
type t = funbehavior
let name = "Funbehavior"
let reprs =
- [ { b_name = "default!"; (* Cil.default_behavior_name *)
- b_requires = Identified_predicate.reprs;
- b_assumes = Identified_predicate.reprs;
- b_post_cond =
- List.map (fun x -> Normal, x) Identified_predicate.reprs;
- b_assigns = WritesAny;
- b_allocation = FreeAllocAny;
- b_extended = []; } ]
+ [ { b_name = "default!"; (* Cil.default_behavior_name *)
+ b_requires = Identified_predicate.reprs;
+ b_assumes = Identified_predicate.reprs;
+ b_post_cond =
+ List.map (fun x -> Normal, x) Identified_predicate.reprs;
+ b_assigns = WritesAny;
+ b_allocation = FreeAllocAny;
+ b_extended = []; } ]
let mem_project = Datatype.never_any_project
- end)
+ end)
module Funspec = struct
let pretty_ref = ref (fun _ _ -> assert false)
include Datatype.Make
- (struct
- include Datatype.Serializable_undefined
- type t = funspec
- let name = "Funspec"
- let reprs =
- [ { spec_behavior = Funbehavior.reprs;
- spec_variant = None;
- spec_terminates = None;
- spec_complete_behaviors = [];
- spec_disjoint_behaviors = [] } ]
- let pretty fmt x = !pretty_ref fmt x
- let mem_project = Datatype.never_any_project
- end)
+ (struct
+ include Datatype.Serializable_undefined
+ type t = funspec
+ let name = "Funspec"
+ let reprs =
+ [ { spec_behavior = Funbehavior.reprs;
+ spec_variant = None;
+ spec_terminates = None;
+ spec_complete_behaviors = [];
+ spec_disjoint_behaviors = [] } ]
+ let pretty fmt x = !pretty_ref fmt x
+ let mem_project = Datatype.never_any_project
+ end)
end
module Fundec = struct
let pretty_ref = ref (fun _ _ -> assert false)
- let make_dummy vi fs = {
- svar = vi;
+ let make_dummy vi fs = {
+ svar = vi;
sformals = [];
slocals = [];
smaxid = 0;
@@ -2331,26 +2331,26 @@ module Fundec = struct
}
let reprs = List.fold_left (fun list vi ->
- List.fold_left (fun list fs ->
- ((make_dummy vi fs)::list)) list Funspec.reprs)
- [] Varinfo.reprs;;
+ List.fold_left (fun list fs ->
+ ((make_dummy vi fs)::list)) list Funspec.reprs)
+ [] Varinfo.reprs;;
include Datatype.Make_with_collections
- (struct
- type t = fundec
- let name = "Fundec"
- let varname v = "fd_" ^ v.svar.vorig_name
- let reprs = reprs
- let structural_descr = Structural_descr.t_abstract
- let compare v1 v2 = Datatype.Int.compare v1.svar.vid v2.svar.vid
- let hash v = v.svar.vid
- let equal v1 v2 = v1.svar.vid = v2.svar.vid
- let rehash = Datatype.identity
- let copy = Datatype.undefined
- let pretty = Datatype.undefined
- let internal_pretty_code = Datatype.undefined
- let mem_project = Datatype.never_any_project
- end)
+ (struct
+ type t = fundec
+ let name = "Fundec"
+ let varname v = "fd_" ^ v.svar.vorig_name
+ let reprs = reprs
+ let structural_descr = Structural_descr.t_abstract
+ let compare v1 v2 = Datatype.Int.compare v1.svar.vid v2.svar.vid
+ let hash v = v.svar.vid
+ let equal v1 v2 = v1.svar.vid = v2.svar.vid
+ let rehash = Datatype.identity
+ let copy = Datatype.undefined
+ let pretty = Datatype.undefined
+ let internal_pretty_code = Datatype.undefined
+ let mem_project = Datatype.never_any_project
+ end)
end
@@ -2382,20 +2382,20 @@ module Localisation =
let name = "Localisation"
let reprs = [ VGlobal ]
let internal_pretty_code p_caller fmt loc =
- let pp s kf =
- Type.par p_caller Type.Call fmt
- (fun fmt ->
- Format.fprintf fmt "@[<hv 2>%s@;%a@]"
- s
- (Kf.internal_pretty_code Type.Call)
- kf)
- in
- match loc with
- | VGlobal -> Format.fprintf fmt "Cil_types.VGlobal"
- | VLocal kf -> pp "Cil_types.VLocal" kf
- | VFormal kf -> pp "Cil_types.VFormal" kf
+ let pp s kf =
+ Type.par p_caller Type.Call fmt
+ (fun fmt ->
+ Format.fprintf fmt "@[<hv 2>%s@;%a@]"
+ s
+ (Kf.internal_pretty_code Type.Call)
+ kf)
+ in
+ match loc with
+ | VGlobal -> Format.fprintf fmt "Cil_types.VGlobal"
+ | VLocal kf -> pp "Cil_types.VLocal" kf
+ | VFormal kf -> pp "Cil_types.VFormal" kf
let mem_project = Datatype.never_any_project
- end)
+ end)
module Syntactic_scope =
Datatype.Make_with_collections
diff --git a/src/kernel_services/ast_queries/file.ml b/src/kernel_services/ast_queries/file.ml
index daef01e19de..6500566a916 100644
--- a/src/kernel_services/ast_queries/file.ml
+++ b/src/kernel_services/ast_queries/file.ml
@@ -60,11 +60,11 @@ module D =
| External (f,p) ->
Format.fprintf fmt "@[File.External (%S,%S)@]" (f :> string) p
| NeedCPP (a,b,c) ->
- Format.fprintf
- fmt "@[File.NeedCPP (%S,%S,%a)@]" (a :> string) b pretty_cpp_opt_kind c
+ Format.fprintf
+ fmt "@[File.NeedCPP (%S,%S,%a)@]" (a :> string) b pretty_cpp_opt_kind c
in
Type.par p_caller Type.Call fmt pp
- end)
+ end)
include D
let check_suffixes = Hashtbl.create 17
@@ -96,7 +96,7 @@ let cpp_opt_kind () =
let get_preprocessor_command () =
let cmdline = Kernel.CppCommand.get() in
if cmdline <> "" then begin
- (cmdline, cpp_opt_kind ())
+ (cmdline, cpp_opt_kind ())
end else begin
let gnu =
if Config.using_default_cpp then
@@ -160,13 +160,13 @@ end = struct
State_builder.List_ref
(D)
(struct
- let dependencies =
- [ Kernel.CppCommand.self;
- Kernel.CppExtraArgs.self;
- Kernel.JsonCompilationDatabase.self;
- Kernel.Files.self ]
- let name = "Files for preprocessing"
- end)
+ let dependencies =
+ [ Kernel.CppCommand.self;
+ Kernel.CppExtraArgs.self;
+ Kernel.JsonCompilationDatabase.self;
+ Kernel.Files.self ]
+ let name = "Files for preprocessing"
+ end)
module Pre_files =
State_builder.List_ref
@@ -174,7 +174,7 @@ end = struct
(struct
let dependencies = []
let name = "Built-ins headers and source"
- end)
+ end)
let () =
State_dependency_graph.add_dependencies
@@ -184,8 +184,8 @@ end = struct
let () =
State_dependency_graph.add_dependencies
~from:Pre_files.self
- [ Ast.self;
- Ast.UntypedFiles.self;
+ [ Ast.self;
+ Ast.UntypedFiles.self;
Cabshelper.Comments.self;
Cil.Frama_c_builtins.self ]
@@ -280,15 +280,15 @@ let print_machdep fmt (m : Cil_types.mach) =
end
module DatatypeMachdep = Datatype.Make_with_collections(struct
- include Datatype.Serializable_undefined
- let reprs = [Machdeps.x86_32]
- let name = "File.Machdep"
- type t = Cil_types.mach
- let compare : t -> t -> int = Transitioning.Stdlib.compare
- let equal : t -> t -> bool = (=)
- let hash : t -> int = Hashtbl.hash
- let copy = Datatype.identity
-end)
+ include Datatype.Serializable_undefined
+ let reprs = [Machdeps.x86_32]
+ let name = "File.Machdep"
+ type t = Cil_types.mach
+ let compare : t -> t -> int = Transitioning.Stdlib.compare
+ let equal : t -> t -> bool = (=)
+ let hash : t -> int = Hashtbl.hash
+ let copy = Datatype.identity
+ end)
let default_machdeps =
[ "x86_16", Machdeps.x86_16;
@@ -320,10 +320,10 @@ let machdep_macro = function
| "ppc_32" -> "__FC_MACHDEP_PPC_32"
| "msvc_x86_64" -> "__FC_MACHDEP_MSVC_X86_64"
| s ->
- let res = "__FC_MACHDEP_" ^ (Transitioning.String.uppercase_ascii s) in
- Kernel.warning ~once:true
- "machdep %s has no registered macro. Using %s for pre-processing" s res;
- res
+ let res = "__FC_MACHDEP_" ^ (Transitioning.String.uppercase_ascii s) in
+ Kernel.warning ~once:true
+ "machdep %s has no registered macro. Using %s for pre-processing" s res;
+ res
module Machdeps =
State_builder.Hashtbl(Datatype.String.Hashtbl)(DatatypeMachdep)
@@ -331,7 +331,7 @@ module Machdeps =
let name = " File.Machdeps"
let size = 5
let dependencies = []
- end)
+ end)
let mem_machdep s = Machdeps.mem s || List.mem_assoc s default_machdeps
@@ -350,8 +350,8 @@ let pretty_machdeps fmt =
let machdep_help () =
let m = Kernel.Machdep.get () in
if m = "help" then begin
- Kernel.feedback
- "@[supported machines are%t@ (default is x86_32).@]"
+ Kernel.feedback
+ "@[supported machines are%t@ (default is x86_32).@]"
pretty_machdeps;
raise Cmdline.Exit
end else
@@ -372,10 +372,10 @@ let get_machdep () =
try
Machdeps.find m
with Not_found ->
- try
- List.assoc m default_machdeps
- with Not_found -> (* Should not happen given the checks above *)
- Kernel.fatal "Machdep %s not registered" m
+ try
+ List.assoc m default_machdeps
+ with Not_found -> (* Should not happen given the checks above *)
+ Kernel.fatal "Machdep %s not registered" m
let pretty_machdep ?fmt ?machdep () =
let machine = match machdep with None -> get_machdep () | Some m -> m in
@@ -393,40 +393,40 @@ let safe_remove_file (f : Datatype.Filepath.t) =
let build_cpp_cmd cmdl supp_args in_file out_file =
try
- (* Format.eprintf "-cpp-command=|%s|@\n" cmdl; *)
- (* look at the command line to find two "%s" or one "%1" and a "%2"
- *)
+ (* Format.eprintf "-cpp-command=|%s|@\n" cmdl; *)
+ (* look at the command line to find two "%s" or one "%1" and a "%2"
+ *)
let percent1 = String.index cmdl '%' in
- (* Format.eprintf "-cpp-command percent1=%d@\n" percent1;
- Format.eprintf "-cpp-command %%%c@\n" (String.get cmdl
- (percent1+1)); *)
+ (* Format.eprintf "-cpp-command percent1=%d@\n" percent1;
+ Format.eprintf "-cpp-command %%%c@\n" (String.get cmdl
+ (percent1+1)); *)
let percent2 = String.index_from cmdl (percent1+1) '%' in
- (* Format.eprintf "-cpp-command percent2=%d@\n" percent2;
- Format.eprintf "-cpp-command %%%c@\n" (String.get cmdl
- (percent2+1)); *)
+ (* Format.eprintf "-cpp-command percent2=%d@\n" percent2;
+ Format.eprintf "-cpp-command %%%c@\n" (String.get cmdl
+ (percent2+1)); *)
let file1, file2 =
match String.get cmdl (percent1+1), String.get cmdl (percent2+1)
with
| '1', '2' ->
in_file, out_file
- (* "%1" followed by "%2" is used to printf 'ppf' after 'f' *)
+ (* "%1" followed by "%2" is used to printf 'ppf' after 'f' *)
| '2', '1' ->
out_file, in_file
| _, _ -> raise (Invalid_argument "maybe a bad cpp command")
in
let cmd1 = String.sub cmdl 0 percent1 in
- (* Format.eprintf "-cpp-command cmd1=|%s|@\n" cmd1; *)
+ (* Format.eprintf "-cpp-command cmd1=|%s|@\n" cmd1; *)
let cmd2 =
String.sub cmdl (percent1 + 2) (percent2 - (percent1 + 2))
in
- (* Format.eprintf "-cpp-command cmd2=|%s|@\n" cmd2; *)
+ (* Format.eprintf "-cpp-command cmd2=|%s|@\n" cmd2; *)
let cmd3 =
String.sub cmdl (percent2 + 2) (String.length cmdl - (percent2 + 2))
in
- (* Format.eprintf "-cpp-command cmd3=|%s|@\n" cmd3; *)
+ (* Format.eprintf "-cpp-command cmd3=|%s|@\n" cmd3; *)
Format.sprintf "%s%s %s %s%s%s" cmd1
- (* using Filename.quote for filenames which contain space or
- shell metacharacters *)
+ (* using Filename.quote for filenames which contain space or
+ shell metacharacters *)
(Filename.quote file1)
supp_args
cmd2 (Filename.quote file2) cmd3
@@ -435,161 +435,161 @@ let build_cpp_cmd cmdl supp_args in_file out_file =
| Not_found ->
Format.sprintf "%s %s -o %s %s" cmdl
supp_args
- (* using Filename.quote for filenames which contain space or
- shell metacharacters *)
+ (* using Filename.quote for filenames which contain space or
+ shell metacharacters *)
(Filename.quote out_file) (Filename.quote in_file)
let parse_cabs = function
| NoCPP f ->
- if not (Sys.file_exists f) then
- Kernel.abort "preprocessed file %S does not exist" f;
- let path = Datatype.Filepath.of_string f in
- Kernel.feedback "Parsing %a (no preprocessing)"
- Datatype.Filepath.pretty path;
- Frontc.parse (Datatype.Filepath.of_string f) ()
+ if not (Sys.file_exists f) then
+ Kernel.abort "preprocessed file %S does not exist" f;
+ let path = Datatype.Filepath.of_string f in
+ Kernel.feedback "Parsing %a (no preprocessing)"
+ Datatype.Filepath.pretty path;
+ Frontc.parse (Datatype.Filepath.of_string f) ()
| NeedCPP (f, cmdl, is_gnu_like) ->
- if not (Sys.file_exists (f :> string)) then
- Kernel.abort "source file %S does not exist" (f :> string);
- let debug = Kernel.is_debug_key_enabled Kernel.dkey_parser in
- let add_if_gnu opt =
- match is_gnu_like with
- | Gnu -> [opt]
- | Not_gnu -> []
- | Unknown ->
- Kernel.warning
- ~once:true
- "your preprocessor is not known to handle option `%s'. \
- If pre-processing fails because of it, please add \
- -no-cpp-frama-c-compliant option to Frama-C's command-line. \
- If you do not want to see this warning again, explicitly use \
- option -cpp-frama-c-compliant."
- opt;
- [opt]
- in
- let ppf =
- try
- Datatype.Filepath.of_string
- (Extlib.temp_file_cleanup_at_exit ~debug
- (Filename.basename (f :> string)) ".i")
- with Extlib.Temp_file_error s ->
- Kernel.abort "cannot create temporary file: %s" s
- in
- (* Hypothesis: the preprocessor is POSIX compliant,
- hence understands -I and -D. *)
- let include_args =
- if Kernel.FramaCStdLib.get () then [Config.framac_libc]
- else []
- in
- let define_args =
- if Kernel.FramaCStdLib.get () && not (existing_machdep_macro ())
- then [machdep_macro (Kernel.Machdep.get ())]
- else []
- in
- let extra_args =
- if include_args = [] && define_args = [] then []
- else add_if_gnu "-nostdinc"
- in
- let define_args = "__FRAMAC__" :: define_args in
- (* Hypothesis: the preprocessor does support the arch-related
- options tested when 'configure' was run. *)
- let required_cpp_arch_args = (get_machdep ()).cpp_arch_flags in
- let supported_cpp_arch_args, unsupported_cpp_arch_args =
- List.partition (fun arg ->
- List.mem arg Config.preprocessor_supported_arch_options)
- required_cpp_arch_args
- in
- if is_gnu_like = Unknown && not (Kernel.CppCommand.is_set ())
- && unsupported_cpp_arch_args <> [] then
- Kernel.warning ~once:true
- "your preprocessor is not known to handle option(s) `%a', \
- considered necessary for machdep `%s'. To ensure compatibility \
- between your preprocessor and the machdep, consider using \
- -cpp-command with the appropriate flags. \
- Your preprocessor is known to support these flags: %a"
- (Pretty_utils.pp_list ~sep:" " Format.pp_print_string)
- unsupported_cpp_arch_args (Kernel.Machdep.get ())
- (Pretty_utils.pp_list ~sep:" " Format.pp_print_string)
- Config.preprocessor_supported_arch_options;
- let extra_args =
- if Kernel.ReadAnnot.get () then
- if Kernel.PreprocessAnnot.is_set () then
- if Kernel.PreprocessAnnot.get () then
- "-dD" :: extra_args
- else extra_args
- else
- let opt = add_if_gnu "-dD" in
- opt @ extra_args
- else extra_args
- in
- let pp_str = Format.pp_print_string in
- let string_of_supp_args extra includes defines =
- Format.asprintf "%a%a%a"
- (Pretty_utils.pp_list ~pre:" -I" ~sep:" -I" ~empty:"" pp_str) includes
- (Pretty_utils.pp_list ~pre:" -D" ~sep:" -D" ~empty:"" pp_str) defines
- (Pretty_utils.pp_list ~pre:" " ~sep:" " ~empty:"" pp_str) extra
- in
- let supp_args =
- string_of_supp_args
- (Kernel.CppExtraArgs.get () @ extra_args @ supported_cpp_arch_args)
- include_args define_args
- in
- Kernel.feedback ~dkey:Kernel.dkey_pp
- "@{<i>preprocessing@} with \"%s %s %s\"" cmdl supp_args f;
- let path = Datatype.Filepath.of_string f in
- Kernel.feedback "Parsing %a (with preprocessing)"
- Datatype.Filepath.pretty path;
- let cpp_command = build_cpp_cmd cmdl supp_args f (ppf :> string) in
- if Sys.command cpp_command <> 0 then begin
- safe_remove_file ppf;
- Kernel.abort "failed to run: %s@\n\
-you may set the CPP environment variable to select the proper \
-preprocessor command or use the option \"-cpp-command\"." cpp_command
- end;
- let ppf =
- if Kernel.ReadAnnot.get() &&
- ((Kernel.PreprocessAnnot.is_set () &&
- Kernel.PreprocessAnnot.get())
- || (match is_gnu_like with
- | Gnu -> true
- | Not_gnu -> false
- | Unknown ->
- Kernel.warning
- ~once:true
- "trying to preprocess annotation with an unknown \
- preprocessor."; true))
- then begin
- let pp_annot_supp_args =
- Format.asprintf "-nostdinc %a"
- (Pretty_utils.pp_list ~sep:" " Format.pp_print_string)
- supported_cpp_arch_args
- in
- let ppf' =
- try Logic_preprocess.file ".c"
- (build_cpp_cmd cmdl pp_annot_supp_args)
- (ppf : Filepath.Normalized.t :> string)
- with Sys_error _ as e ->
- safe_remove_file ppf;
- Kernel.abort "preprocessing of annotations failed (%s)"
- (Printexc.to_string e)
- in
- safe_remove_file ppf ;
- ppf'
- end else ppf
- in
- let (cil,(_,defs)) = Frontc.parse ppf () in
- cil.fileName <- path;
+ if not (Sys.file_exists (f :> string)) then
+ Kernel.abort "source file %S does not exist" (f :> string);
+ let debug = Kernel.is_debug_key_enabled Kernel.dkey_parser in
+ let add_if_gnu opt =
+ match is_gnu_like with
+ | Gnu -> [opt]
+ | Not_gnu -> []
+ | Unknown ->
+ Kernel.warning
+ ~once:true
+ "your preprocessor is not known to handle option `%s'. \
+ If pre-processing fails because of it, please add \
+ -no-cpp-frama-c-compliant option to Frama-C's command-line. \
+ If you do not want to see this warning again, explicitly use \
+ option -cpp-frama-c-compliant."
+ opt;
+ [opt]
+ in
+ let ppf =
+ try
+ Datatype.Filepath.of_string
+ (Extlib.temp_file_cleanup_at_exit ~debug
+ (Filename.basename (f :> string)) ".i")
+ with Extlib.Temp_file_error s ->
+ Kernel.abort "cannot create temporary file: %s" s
+ in
+ (* Hypothesis: the preprocessor is POSIX compliant,
+ hence understands -I and -D. *)
+ let include_args =
+ if Kernel.FramaCStdLib.get () then [Config.framac_libc]
+ else []
+ in
+ let define_args =
+ if Kernel.FramaCStdLib.get () && not (existing_machdep_macro ())
+ then [machdep_macro (Kernel.Machdep.get ())]
+ else []
+ in
+ let extra_args =
+ if include_args = [] && define_args = [] then []
+ else add_if_gnu "-nostdinc"
+ in
+ let define_args = "__FRAMAC__" :: define_args in
+ (* Hypothesis: the preprocessor does support the arch-related
+ options tested when 'configure' was run. *)
+ let required_cpp_arch_args = (get_machdep ()).cpp_arch_flags in
+ let supported_cpp_arch_args, unsupported_cpp_arch_args =
+ List.partition (fun arg ->
+ List.mem arg Config.preprocessor_supported_arch_options)
+ required_cpp_arch_args
+ in
+ if is_gnu_like = Unknown && not (Kernel.CppCommand.is_set ())
+ && unsupported_cpp_arch_args <> [] then
+ Kernel.warning ~once:true
+ "your preprocessor is not known to handle option(s) `%a', \
+ considered necessary for machdep `%s'. To ensure compatibility \
+ between your preprocessor and the machdep, consider using \
+ -cpp-command with the appropriate flags. \
+ Your preprocessor is known to support these flags: %a"
+ (Pretty_utils.pp_list ~sep:" " Format.pp_print_string)
+ unsupported_cpp_arch_args (Kernel.Machdep.get ())
+ (Pretty_utils.pp_list ~sep:" " Format.pp_print_string)
+ Config.preprocessor_supported_arch_options;
+ let extra_args =
+ if Kernel.ReadAnnot.get () then
+ if Kernel.PreprocessAnnot.is_set () then
+ if Kernel.PreprocessAnnot.get () then
+ "-dD" :: extra_args
+ else extra_args
+ else
+ let opt = add_if_gnu "-dD" in
+ opt @ extra_args
+ else extra_args
+ in
+ let pp_str = Format.pp_print_string in
+ let string_of_supp_args extra includes defines =
+ Format.asprintf "%a%a%a"
+ (Pretty_utils.pp_list ~pre:" -I" ~sep:" -I" ~empty:"" pp_str) includes
+ (Pretty_utils.pp_list ~pre:" -D" ~sep:" -D" ~empty:"" pp_str) defines
+ (Pretty_utils.pp_list ~pre:" " ~sep:" " ~empty:"" pp_str) extra
+ in
+ let supp_args =
+ string_of_supp_args
+ (Kernel.CppExtraArgs.get () @ extra_args @ supported_cpp_arch_args)
+ include_args define_args
+ in
+ Kernel.feedback ~dkey:Kernel.dkey_pp
+ "@{<i>preprocessing@} with \"%s %s %s\"" cmdl supp_args f;
+ let path = Datatype.Filepath.of_string f in
+ Kernel.feedback "Parsing %a (with preprocessing)"
+ Datatype.Filepath.pretty path;
+ let cpp_command = build_cpp_cmd cmdl supp_args f (ppf :> string) in
+ if Sys.command cpp_command <> 0 then begin
safe_remove_file ppf;
- (cil,(path,defs))
+ Kernel.abort "failed to run: %s@\n\
+ you may set the CPP environment variable to select the proper \
+ preprocessor command or use the option \"-cpp-command\"." cpp_command
+ end;
+ let ppf =
+ if Kernel.ReadAnnot.get() &&
+ ((Kernel.PreprocessAnnot.is_set () &&
+ Kernel.PreprocessAnnot.get())
+ || (match is_gnu_like with
+ | Gnu -> true
+ | Not_gnu -> false
+ | Unknown ->
+ Kernel.warning
+ ~once:true
+ "trying to preprocess annotation with an unknown \
+ preprocessor."; true))
+ then begin
+ let pp_annot_supp_args =
+ Format.asprintf "-nostdinc %a"
+ (Pretty_utils.pp_list ~sep:" " Format.pp_print_string)
+ supported_cpp_arch_args
+ in
+ let ppf' =
+ try Logic_preprocess.file ".c"
+ (build_cpp_cmd cmdl pp_annot_supp_args)
+ (ppf : Filepath.Normalized.t :> string)
+ with Sys_error _ as e ->
+ safe_remove_file ppf;
+ Kernel.abort "preprocessing of annotations failed (%s)"
+ (Printexc.to_string e)
+ in
+ safe_remove_file ppf ;
+ ppf'
+ end else ppf
+ in
+ let (cil,(_,defs)) = Frontc.parse ppf () in
+ cil.fileName <- path;
+ safe_remove_file ppf;
+ (cil,(path,defs))
| External (f,suf) ->
- if not (Sys.file_exists f) then
- Kernel.abort "file %S does not exist." f;
- try
- let path = Datatype.Filepath.of_string f in
- Kernel.feedback "Parsing %a (external front-end)"
- Datatype.Filepath.pretty path;
- Hashtbl.find check_suffixes suf f
- with Not_found ->
- Kernel.abort "could not find a suitable plugin for parsing %S." f
+ if not (Sys.file_exists f) then
+ Kernel.abort "file %S does not exist." f;
+ try
+ let path = Datatype.Filepath.of_string f in
+ Kernel.feedback "Parsing %a (external front-end)"
+ Datatype.Filepath.pretty path;
+ Hashtbl.find check_suffixes suf f
+ with Not_found ->
+ Kernel.abort "could not find a suitable plugin for parsing %S." f
let to_cil_cabs f =
try
@@ -638,15 +638,15 @@ let () =
{!Rmtmps.removeUnusedTemps}. *)
let keep_entry_point ?(specs=Kernel.Keep_unused_specified_functions.get ()) g =
Rmtmps.isExportedRoot g ||
- match g with
- | GFun({svar = v; sspec = spec},_)
- | GFunDecl(spec,v,_) ->
- Kernel.MainFunction.get_plain_string () = v.vname
- (* Always keep the declaration of the entry point *)
- || (specs && not (is_empty_funspec spec))
- (* and the declarations carrying specifications according to the
- command line.*)
- | _ -> false
+ match g with
+ | GFun({svar = v; sspec = spec},_)
+ | GFunDecl(spec,v,_) ->
+ Kernel.MainFunction.get_plain_string () = v.vname
+ (* Always keep the declaration of the entry point *)
+ || (specs && not (is_empty_funspec spec))
+ (* and the declarations carrying specifications according to the
+ command line.*)
+ | _ -> false
let files_to_cabs_cil files =
Kernel.feedback ~level:2 "parsing";
@@ -674,10 +674,10 @@ module Implicit_annotations =
State_builder.Hashtbl
(Property.Hashtbl)(Datatype.List(Property))
(struct
- let name = "File.Implicit_annotations"
- let dependencies = [Annotations.code_annot_state]
- let size = 32
- end)
+ let name = "File.Implicit_annotations"
+ let dependencies = [Annotations.code_annot_state]
+ let size = 32
+ end)
let () = Ast.add_linked_state Implicit_annotations.self
@@ -813,7 +813,7 @@ let synchronize_source_annot has_new_stmt kf =
ChangeTo (Cil.mkStmtOneInstr (Skip Cil_datatype.Location.unknown))
in
assert (!block_with_user_annots = None
- || !user_annots_for_next_stmt <> []);
+ || !user_annots_for_next_stmt <> []);
match st.skind with
| Instr (Code_annot (annot,_)) ->
(* Code annotation isn't considered as a real stmt.
@@ -874,20 +874,20 @@ let register_global = function
Implicit_annotations.add ipreturns ipgotos
) !onerets ;
| GFunDecl (spec, f,loc) ->
- (* global prototypes *)
- let args =
- try Some (Cil.getFormalsDecl f) with Not_found -> None
- in
- (* Use a copy of the spec, as the original one will be erased by
- AST cleanup. *)
- let spec = { spec with spec_variant = spec.spec_variant } in
- Globals.Functions.add (Declaration(spec,f,args,loc))
+ (* global prototypes *)
+ let args =
+ try Some (Cil.getFormalsDecl f) with Not_found -> None
+ in
+ (* Use a copy of the spec, as the original one will be erased by
+ AST cleanup. *)
+ let spec = { spec with spec_variant = spec.spec_variant } in
+ Globals.Functions.add (Declaration(spec,f,args,loc))
| GVarDecl (vi,_) when not vi.vdefined ->
- (* global variables declaration with no definitions *)
- Globals.Vars.add_decl vi
+ (* global variables declaration with no definitions *)
+ Globals.Vars.add_decl vi
| GVar (varinfo,initinfo,_) ->
- (* global variables definitions *)
- Globals.Vars.add varinfo initinfo;
+ (* global variables definitions *)
+ Globals.Vars.add varinfo initinfo;
| GAnnot (annot,_loc) ->
Annotations.add_global Emitter.end_user annot
| _ -> ()
@@ -909,11 +909,11 @@ let cleanup file =
method private remove_lexical_annotations stmt =
match stmt.skind with
- | Instr(Code_annot(_,loc)) ->
- stmt.skind <- Instr(Skip(loc))
- | Loop (_::_, b1,l1,s1,s2) ->
- stmt.skind <- Loop ([], b1, l1, s1, s2)
- | _ -> ()
+ | Instr(Code_annot(_,loc)) ->
+ stmt.skind <- Instr(Skip(loc))
+ | Loop (_::_, b1,l1,s1,s2) ->
+ stmt.skind <- Loop ([], b1, l1, s1, s2)
+ | _ -> ()
method! vstmt_aux st =
self#remove_lexical_annotations st;
@@ -934,19 +934,19 @@ let cleanup file =
let optim b =
b.bstmts <-
List.filter
- (fun x ->
- not (Cil.is_skip x.skind) || Stmt.Set.mem x keep_stmt ||
+ (fun x ->
+ not (Cil.is_skip x.skind) || Stmt.Set.mem x keep_stmt ||
( changed <- true; false) (* don't try this at home, kids...*)
- )
- b.bstmts;
+ )
+ b.bstmts;
(* Now that annotations are in the table, we do not need to
retain the block anymore.
- *)
+ *)
b.battrs <- List.filter
- (function
- | Attr(l,[]) when l = Cabs2cil.frama_c_keep_block -> false
- | _ -> true)
- b.battrs;
+ (function
+ | Attr(l,[]) when l = Cabs2cil.frama_c_keep_block -> false
+ | _ -> true)
+ b.battrs;
b
in
(* uncomment if you don't want to consider scope of locals (see below) *)
@@ -954,25 +954,25 @@ let cleanup file =
ChangeDoChildrenPost(b,optim)
method! vglob_aux = function
- | GFun (f,_) ->
- f.sspec <- Cil.empty_funspec ();
- (* uncomment if you dont want to treat scope of locals (see above)*)
- (* f.sbody.blocals <- f.slocals; *)
- DoChildren
- | GFunDecl(s,_,_) ->
- Logic_utils.clear_funspec s;
- DoChildren
- | GType _ | GCompTag _ | GCompTagDecl _ | GEnumTag _
- | GEnumTagDecl _ | GVar _ | GVarDecl _ | GAsm _ | GPragma _ | GText _
- | GAnnot _ ->
+ | GFun (f,_) ->
+ f.sspec <- Cil.empty_funspec ();
+ (* uncomment if you dont want to treat scope of locals (see above)*)
+ (* f.sbody.blocals <- f.slocals; *)
+ DoChildren
+ | GFunDecl(s,_,_) ->
+ Logic_utils.clear_funspec s;
+ DoChildren
+ | GType _ | GCompTag _ | GCompTagDecl _ | GEnumTag _
+ | GEnumTagDecl _ | GVar _ | GVarDecl _ | GAsm _ | GPragma _ | GText _
+ | GAnnot _ ->
SkipChildren
method! vfile f =
ChangeDoChildrenPost
(f,fun f -> if changed then begin
- Cfg.clearFileCFG ~clear_id:false f;
- Cfg.computeFileCFG f; f end
- else f)
+ Cfg.clearFileCFG ~clear_id:false f;
+ Cfg.computeFileCFG f; f end
+ else f)
end
in visitFramacFileSameGlobals visitor file
@@ -1023,7 +1023,7 @@ let add_transform_parameter
if Kernel.Check.get () then
Filecheck.check_ast
("after code transformation: " ^ name.name ^
- " triggered by " ^ P.option_name)
+ " triggered by " ^ P.option_name)
end
in
(* P.add_set_hook must be done only once. *)
@@ -1034,11 +1034,11 @@ let add_transform_parameter
Transform_after_parameter_change.extend name.prm_id hook;
List.iter
(fun b ->
- Transform_after_parameter_change.add_dependency name.prm_id b.prm_id)
+ Transform_after_parameter_change.add_dependency name.prm_id b.prm_id)
before;
List.iter
(fun a ->
- Transform_after_parameter_change.add_dependency a.prm_id name.prm_id)
+ Transform_after_parameter_change.add_dependency a.prm_id name.prm_id)
after
module Cfg_recomputation_queue =
@@ -1046,7 +1046,7 @@ module Cfg_recomputation_queue =
(struct
let name = "File.Cfg_recomputation_queue"
let dependencies = [Ast.self]
- end)
+ end)
let () = Ast.add_linked_state Cfg_recomputation_queue.self
@@ -1079,11 +1079,11 @@ let add_code_transformation_before_cleanup
name.before_id (transform_and_check name.name false f);
List.iter
(fun b ->
- Transform_before_cleanup.add_dependency name.before_id b.before_id)
+ Transform_before_cleanup.add_dependency name.before_id b.before_id)
before;
List.iter
(fun a ->
- Transform_before_cleanup.add_dependency a.before_id name.before_id)
+ Transform_before_cleanup.add_dependency a.before_id name.before_id)
after;
List.iter (add_transform_parameter ~before ~after name f) deps
@@ -1094,10 +1094,10 @@ let add_code_transformation_after_cleanup
(transform_and_check name.name true f);
List.iter
(fun b ->
- Transform_after_cleanup.add_dependency name.after_id b.after_id) before;
+ Transform_after_cleanup.add_dependency name.after_id b.after_id) before;
List.iter
(fun a ->
- Transform_after_cleanup.add_dependency a.after_id name.after_id) after;
+ Transform_after_cleanup.add_dependency a.after_id name.after_id) after;
List.iter (add_transform_parameter ~before ~after name f) deps
let syntactic_constant_folding ast =
@@ -1128,7 +1128,7 @@ let prepare_cil_file ast =
if Kernel.Check.get () then begin
Filecheck.check_ast ~is_normalized:false ~ast "Removed temp vars"
end;
- (try
+ (try
List.iter register_global ast.globals
with Globals.Vars.AlreadyExists(vi,_) ->
Kernel.fatal
@@ -1151,7 +1151,7 @@ let prepare_cil_file ast =
Ast.set_file ast;
(* Check that normalization is correct. *)
if Kernel.Check.get() then begin
- Filecheck.check_ast ~ast "AST after normalization";
+ Filecheck.check_ast ~ast "AST after normalization";
end;
Globals.Functions.iter Annotations.register_funspec;
if Kernel.Check.get () then begin
@@ -1200,42 +1200,42 @@ let find_typeinfo ty =
let module F = struct exception Found of global end in
let globs = (Ast.get()).globals in
try
- List.iter
+ List.iter
(fun g -> match g with
- | GType (ty',_) when ty == ty' -> raise (F.Found g)
- | GType (ty',_) when ty.tname = ty'.tname ->
- Kernel.fatal
- "Lost sharing between definition and declaration of type %s"
- ty.tname
- | _ -> ())
+ | GType (ty',_) when ty == ty' -> raise (F.Found g)
+ | GType (ty',_) when ty.tname = ty'.tname ->
+ Kernel.fatal
+ "Lost sharing between definition and declaration of type %s"
+ ty.tname
+ | _ -> ())
globs;
Kernel.fatal "Reordering AST: unknown typedef for %s" ty.tname
with F.Found g -> g
let extract_logic_infos g =
let rec aux acc = function
- | Dfun_or_pred (li,_) | Dinvariant (li,_) | Dtype_annot (li,_) -> li :: acc
- | Dvolatile _ | Dtype _ | Dlemma _
- | Dmodel_annot _ | Dcustom_annot _ | Dextended _ -> acc
- | Daxiomatic(_,l,_,_) -> List.fold_left aux acc l
+ | Dfun_or_pred (li,_) | Dinvariant (li,_) | Dtype_annot (li,_) -> li :: acc
+ | Dvolatile _ | Dtype _ | Dlemma _
+ | Dmodel_annot _ | Dcustom_annot _ | Dextended _ -> acc
+ | Daxiomatic(_,l,_,_) -> List.fold_left aux acc l
in aux [] g
let find_logic_info_decl li =
let module F = struct exception Found of global end in
let globs = (Ast.get()).globals in
try
- List.iter
+ List.iter
(fun g -> match g with
- | GAnnot (ga,_) ->
- if
- List.exists
- (fun li' -> Logic_info.equal li li')
- (extract_logic_infos ga)
- then raise (F.Found g)
- | _ -> ())
+ | GAnnot (ga,_) ->
+ if
+ List.exists
+ (fun li' -> Logic_info.equal li li')
+ (extract_logic_infos ga)
+ then raise (F.Found g)
+ | _ -> ())
globs;
Kernel.fatal "Reordering AST: unknown declaration \
- for logic function or predicate %s"
+ for logic function or predicate %s"
li.l_var_info.lv_name
with F.Found g -> g
@@ -1249,326 +1249,326 @@ class reorder_ast: Visitor.frama_c_visitor =
incr i; res
end
in
-object(self)
- inherit Visitor.frama_c_inplace
- val mutable known_enuminfo = Enuminfo.Set.empty
- val mutable known_compinfo = Compinfo.Set.empty
- val mutable known_typeinfo = Typeinfo.Set.empty
- val mutable known_var = Varinfo.Set.empty
- val mutable known_logic_info = Logic_info.Set.empty
- val mutable local_logic_info = Logic_info.Set.empty
-
- (* globals that have to be declared before current declaration. *)
- val mutable needed_decls = []
- (* global annotations are treated separately, as they need special
- care when revisiting their content *)
- val mutable needed_annots = []
+ object(self)
+ inherit Visitor.frama_c_inplace
+ val mutable known_enuminfo = Enuminfo.Set.empty
+ val mutable known_compinfo = Compinfo.Set.empty
+ val mutable known_typeinfo = Typeinfo.Set.empty
+ val mutable known_var = Varinfo.Set.empty
+ val mutable known_logic_info = Logic_info.Set.empty
+ val mutable local_logic_info = Logic_info.Set.empty
- val current_annot = Stack.create ()
+ (* globals that have to be declared before current declaration. *)
+ val mutable needed_decls = []
+ (* global annotations are treated separately, as they need special
+ care when revisiting their content *)
+ val mutable needed_annots = []
- val subvisit = Stack.create ()
+ val current_annot = Stack.create ()
- val typedefs = Stack.create ()
+ val subvisit = Stack.create ()
- val logic_info_deps = Global_annotation_graph.create ()
+ val typedefs = Stack.create ()
- method private add_known_enuminfo ei =
- known_enuminfo <- Enuminfo.Set.add ei known_enuminfo
+ val logic_info_deps = Global_annotation_graph.create ()
- method private add_known_compinfo ci =
- known_compinfo <- Compinfo.Set.add ci known_compinfo
+ method private add_known_enuminfo ei =
+ known_enuminfo <- Enuminfo.Set.add ei known_enuminfo
- method private add_known_type ty =
- known_typeinfo <- Typeinfo.Set.add ty known_typeinfo
+ method private add_known_compinfo ci =
+ known_compinfo <- Compinfo.Set.add ci known_compinfo
- method private add_known_var vi =
- known_var <- Varinfo.Set.add vi known_var
+ method private add_known_type ty =
+ known_typeinfo <- Typeinfo.Set.add ty known_typeinfo
- method private add_known_logic_info li =
- known_logic_info <- Logic_info.Set.add li known_logic_info
+ method private add_known_var vi =
+ known_var <- Varinfo.Set.add vi known_var
- method private add_needed_decl g =
- needed_decls <- g :: needed_decls
-
- method private add_needed_annot g =
- needed_annots <- g :: needed_annots
+ method private add_known_logic_info li =
+ known_logic_info <- Logic_info.Set.add li known_logic_info
- method private add_annot_depend g =
- try
- let g' = Stack.top current_annot in
- if g == g' then ()
- else
- Global_annotation_graph.add_edge
- logic_info_deps g g' (* g' depends upon g *)
- with Stack.Empty ->
- Global_annotation_graph.add_vertex logic_info_deps g
- (* Otherwise, if we only have one annotation to take care of,
- the graph will be empty... *)
-
- method private add_known_annots g =
- let lis = extract_logic_infos g in
- List.iter self#add_known_logic_info lis
-
- method private clear_deps () =
- needed_decls <- [];
- needed_annots <- [];
- Stack.clear current_annot;
- Stack.clear typedefs;
- Global_annotation_graph.clear logic_info_deps
-
- method private make_annots g =
- let g =
- match g with
+ method private add_needed_decl g =
+ needed_decls <- g :: needed_decls
+
+ method private add_needed_annot g =
+ needed_annots <- g :: needed_annots
+
+ method private add_annot_depend g =
+ try
+ let g' = Stack.top current_annot in
+ if g == g' then ()
+ else
+ Global_annotation_graph.add_edge
+ logic_info_deps g g' (* g' depends upon g *)
+ with Stack.Empty ->
+ Global_annotation_graph.add_vertex logic_info_deps g
+ (* Otherwise, if we only have one annotation to take care of,
+ the graph will be empty... *)
+
+ method private add_known_annots g =
+ let lis = extract_logic_infos g in
+ List.iter self#add_known_logic_info lis
+
+ method private clear_deps () =
+ needed_decls <- [];
+ needed_annots <- [];
+ Stack.clear current_annot;
+ Stack.clear typedefs;
+ Global_annotation_graph.clear logic_info_deps
+
+ method private make_annots g =
+ let g =
+ match g with
| [ g ] -> g
| _ -> (* We'll eventually add some globals, but the value returned
by visitor itself is supposed to be a singleton. Everything
is done in post-action.
*)
- Kernel.fatal "unexpected result of visiting global when reordering"
- in
- let deps =
- if Global_annotation_graph.nb_vertex logic_info_deps = 0 then []
- else if Global_annotation_graph.has_cycle logic_info_deps then begin
- (* Assumption: elements from the stdlib are not part of a cycle with
- others logic functions, i.e. the stdlib is well-formed. *)
- let entries =
- Global_annotation_graph.fold
- (fun g acc ->
- let stdlib =
- Cil.findAttribute "fc_stdlib" (Cil_datatype.Global.attr g)
- in
- let key =
- match stdlib with
- | [ AStr s ] -> s
- | _ -> ""
- in
- let elts =
- try Datatype.String.Map.find key acc
- with Not_found -> []
+ Kernel.fatal "unexpected result of visiting global when reordering"
+ in
+ let deps =
+ if Global_annotation_graph.nb_vertex logic_info_deps = 0 then []
+ else if Global_annotation_graph.has_cycle logic_info_deps then begin
+ (* Assumption: elements from the stdlib are not part of a cycle with
+ others logic functions, i.e. the stdlib is well-formed. *)
+ let entries =
+ Global_annotation_graph.fold
+ (fun g acc ->
+ let stdlib =
+ Cil.findAttribute "fc_stdlib" (Cil_datatype.Global.attr g)
+ in
+ let key =
+ match stdlib with
+ | [ AStr s ] -> s
+ | _ -> ""
+ in
+ let elts =
+ try Datatype.String.Map.find key acc
+ with Not_found -> []
+ in
+ Datatype.String.Map.add key (g::elts) acc
+ )
+ logic_info_deps Datatype.String.Map.empty
+ in
+ Datatype.String.Map.fold
+ (fun k l res ->
+ let attr = if k = "" then [] else [ Attr("fc_stdlib", [AStr k])] in
+ let entries =
+ List.fold_left
+ (fun acc g ->
+ match g with GAnnot (g,_) -> g :: acc | _ -> acc)
+ [] l
in
- Datatype.String.Map.add key (g::elts) acc
- )
- logic_info_deps Datatype.String.Map.empty
- in
- Datatype.String.Map.fold
- (fun k l res ->
- let attr = if k = "" then [] else [ Attr("fc_stdlib", [AStr k])] in
- let entries =
- List.fold_left
- (fun acc g ->
- match g with GAnnot (g,_) -> g :: acc | _ -> acc)
- [] l
- in
- (GAnnot
- (Daxiomatic
- (unique_name_recursive_axiomatic (),
- entries, attr,
- Location.unknown),
- Location.unknown))::res)
- entries []
- end else begin
- Global_annotation_graph.fold
- (fun ga acc -> ga :: acc) logic_info_deps []
- end
- in
- assert (List.length deps = List.length needed_annots);
- match g with
+ (GAnnot
+ (Daxiomatic
+ (unique_name_recursive_axiomatic (),
+ entries, attr,
+ Location.unknown),
+ Location.unknown))::res)
+ entries []
+ end else begin
+ Global_annotation_graph.fold
+ (fun ga acc -> ga :: acc) logic_info_deps []
+ end
+ in
+ assert (List.length deps = List.length needed_annots);
+ match g with
| GAnnot _ -> List.rev deps
- (** g is already in the dependencies graph. *)
+ (** g is already in the dependencies graph. *)
| _ -> List.rev (g::deps)
- (* TODO: add methods for uses of undeclared identifiers.
- Use functions that maps an identifier to its decl.
- Don't forget to check for cycles for TNamed and logic_info.
- *)
-
- method! vtype ty =
- (match ty with
- | TVoid _ | TInt _ | TFloat _ | TPtr _
- | TFun _ | TBuiltin_va_list _ | TArray _ -> ()
-
- | TNamed (ty,_) ->
- let g = find_typeinfo ty in
- if not (Typeinfo.Set.mem ty known_typeinfo) then begin
- self#add_needed_decl g;
- Stack.push g typedefs;
- Stack.push true subvisit;
- ignore
- (Visitor.visitFramacGlobal (self:>Visitor.frama_c_visitor) g);
- ignore (Stack.pop typedefs);
- ignore (Stack.pop subvisit);
- end
- else
- Stack.iter
- (fun g' -> if g == g' then
- Kernel.fatal
- "Globals' reordering failed: \
- recursive definition of type %s"
- ty.tname)
- typedefs
- | TComp(ci,_,_) ->
- if not (Compinfo.Set.mem ci known_compinfo) then begin
- self#add_needed_decl (GCompTagDecl (ci,Location.unknown));
- self#add_known_compinfo ci
- end
- | TEnum(ei,_) ->
- if not (Enuminfo.Set.mem ei known_enuminfo) then begin
- self#add_needed_decl (GEnumTagDecl (ei, Location.unknown));
- self#add_known_enuminfo ei
- end);
- DoChildren
+ (* TODO: add methods for uses of undeclared identifiers.
+ Use functions that maps an identifier to its decl.
+ Don't forget to check for cycles for TNamed and logic_info.
+ *)
+
+ method! vtype ty =
+ (match ty with
+ | TVoid _ | TInt _ | TFloat _ | TPtr _
+ | TFun _ | TBuiltin_va_list _ | TArray _ -> ()
+
+ | TNamed (ty,_) ->
+ let g = find_typeinfo ty in
+ if not (Typeinfo.Set.mem ty known_typeinfo) then begin
+ self#add_needed_decl g;
+ Stack.push g typedefs;
+ Stack.push true subvisit;
+ ignore
+ (Visitor.visitFramacGlobal (self:>Visitor.frama_c_visitor) g);
+ ignore (Stack.pop typedefs);
+ ignore (Stack.pop subvisit);
+ end
+ else
+ Stack.iter
+ (fun g' -> if g == g' then
+ Kernel.fatal
+ "Globals' reordering failed: \
+ recursive definition of type %s"
+ ty.tname)
+ typedefs
+ | TComp(ci,_,_) ->
+ if not (Compinfo.Set.mem ci known_compinfo) then begin
+ self#add_needed_decl (GCompTagDecl (ci,Location.unknown));
+ self#add_known_compinfo ci
+ end
+ | TEnum(ei,_) ->
+ if not (Enuminfo.Set.mem ei known_enuminfo) then begin
+ self#add_needed_decl (GEnumTagDecl (ei, Location.unknown));
+ self#add_known_enuminfo ei
+ end);
+ DoChildren
- method! vvrbl vi =
- if vi.vglob && not (Varinfo.Set.mem vi known_var) then begin
- if Cil.isFunctionType vi.vtype then
- self#add_needed_decl (GFunDecl (Cil.empty_funspec(),vi,vi.vdecl))
- else
- self#add_needed_decl (GVarDecl (vi,vi.vdecl));
- self#add_known_var vi;
- end;
- DoChildren
+ method! vvrbl vi =
+ if vi.vglob && not (Varinfo.Set.mem vi known_var) then begin
+ if Cil.isFunctionType vi.vtype then
+ self#add_needed_decl (GFunDecl (Cil.empty_funspec(),vi,vi.vdecl))
+ else
+ self#add_needed_decl (GVarDecl (vi,vi.vdecl));
+ self#add_known_var vi;
+ end;
+ DoChildren
- method private logic_info_occurrence lv =
- if not (Logic_env.is_builtin_logic_function lv.l_var_info.lv_name) then
- begin
- let g = find_logic_info_decl lv in
- if not (Logic_info.Set.mem lv known_logic_info) then begin
- self#add_annot_depend g;
- Stack.push true subvisit;
- (* visit will also push g in needed_annot. *)
- ignore (Visitor.visitFramacGlobal (self:>Visitor.frama_c_visitor) g);
- ignore (Stack.pop subvisit)
- end else if List.memq g needed_annots then begin
- self#add_annot_depend g;
- end;
- end
+ method private logic_info_occurrence lv =
+ if not (Logic_env.is_builtin_logic_function lv.l_var_info.lv_name) then
+ begin
+ let g = find_logic_info_decl lv in
+ if not (Logic_info.Set.mem lv known_logic_info) then begin
+ self#add_annot_depend g;
+ Stack.push true subvisit;
+ (* visit will also push g in needed_annot. *)
+ ignore (Visitor.visitFramacGlobal (self:>Visitor.frama_c_visitor) g);
+ ignore (Stack.pop subvisit)
+ end else if List.memq g needed_annots then begin
+ self#add_annot_depend g;
+ end;
+ end
- method private add_local_logic_info li =
- local_logic_info <- Logic_info.Set.add li local_logic_info
+ method private add_local_logic_info li =
+ local_logic_info <- Logic_info.Set.add li local_logic_info
- method private remove_local_logic_info li =
- local_logic_info <- Logic_info.Set.remove li local_logic_info
+ method private remove_local_logic_info li =
+ local_logic_info <- Logic_info.Set.remove li local_logic_info
- method private is_local_logic_info li =
- Logic_info.Set.mem li local_logic_info
+ method private is_local_logic_info li =
+ Logic_info.Set.mem li local_logic_info
- method! vlogic_var_use lv =
- let logic_infos = Annotations.logic_info_of_global lv.lv_name in
- (try
- self#logic_info_occurrence
- (List.find
- (fun x -> Cil_datatype.Logic_var.equal x.l_var_info lv)
- logic_infos)
- with Not_found -> ());
- DoChildren
+ method! vlogic_var_use lv =
+ let logic_infos = Annotations.logic_info_of_global lv.lv_name in
+ (try
+ self#logic_info_occurrence
+ (List.find
+ (fun x -> Cil_datatype.Logic_var.equal x.l_var_info lv)
+ logic_infos)
+ with Not_found -> ());
+ DoChildren
- method! vterm t =
- match t.term_node with
- | Tlet(li,_) -> self#add_local_logic_info li;
- DoChildrenPost (fun t -> self#remove_local_logic_info li; t)
+ method! vterm t =
+ match t.term_node with
+ | Tlet(li,_) -> self#add_local_logic_info li;
+ DoChildrenPost (fun t -> self#remove_local_logic_info li; t)
| _ -> DoChildren
- method! vpredicate_node p =
- match p with
+ method! vpredicate_node p =
+ match p with
| Plet(li,_) -> self#add_local_logic_info li;
- DoChildrenPost (fun t -> self#remove_local_logic_info li; t)
+ DoChildrenPost (fun t -> self#remove_local_logic_info li; t)
| _ -> DoChildren
- method! vlogic_info_use lv =
- if not (self#is_local_logic_info lv) then self#logic_info_occurrence lv;
- DoChildren
+ method! vlogic_info_use lv =
+ if not (self#is_local_logic_info lv) then self#logic_info_occurrence lv;
+ DoChildren
- method! vglob_aux g =
- let is_subvisit = try Stack.top subvisit with Stack.Empty -> false in
- (match g with
- | GType (ty,_) -> self#add_known_type ty; self#add_needed_decl g
- | GCompTagDecl(ci,_) | GCompTag(ci,_) -> self#add_known_compinfo ci
- | GEnumTagDecl(ei,_) | GEnumTag(ei,_) -> self#add_known_enuminfo ei
- | GVarDecl(vi,_) | GVar (vi,_,_) | GFun({svar = vi},_) | GFunDecl (_,vi,_)
- -> self#add_known_var vi
- | GAsm _ | GPragma _ | GText _ -> ()
- | GAnnot (ga,_) ->
- Stack.push g current_annot;
- self#add_known_annots ga;
- Global_annotation_graph.add_vertex logic_info_deps g;
- self#add_needed_annot g);
- let post_action g =
+ method! vglob_aux g =
+ let is_subvisit = try Stack.top subvisit with Stack.Empty -> false in
(match g with
- | [GAnnot _] -> ignore (Stack.pop current_annot)
- | _ -> ());
- if is_subvisit then g (* everything will be done at toplevel *)
- else begin
- let res = List.rev_append needed_decls (self#make_annots g) in
- self#clear_deps ();
- res
- end
- in
- DoChildrenPost post_action
-end
+ | GType (ty,_) -> self#add_known_type ty; self#add_needed_decl g
+ | GCompTagDecl(ci,_) | GCompTag(ci,_) -> self#add_known_compinfo ci
+ | GEnumTagDecl(ei,_) | GEnumTag(ei,_) -> self#add_known_enuminfo ei
+ | GVarDecl(vi,_) | GVar (vi,_,_) | GFun({svar = vi},_) | GFunDecl (_,vi,_)
+ -> self#add_known_var vi
+ | GAsm _ | GPragma _ | GText _ -> ()
+ | GAnnot (ga,_) ->
+ Stack.push g current_annot;
+ self#add_known_annots ga;
+ Global_annotation_graph.add_vertex logic_info_deps g;
+ self#add_needed_annot g);
+ let post_action g =
+ (match g with
+ | [GAnnot _] -> ignore (Stack.pop current_annot)
+ | _ -> ());
+ if is_subvisit then g (* everything will be done at toplevel *)
+ else begin
+ let res = List.rev_append needed_decls (self#make_annots g) in
+ self#clear_deps ();
+ res
+ end
+ in
+ DoChildrenPost post_action
+ end
module Remove_spurious = struct
- type env =
- { typeinfos: Typeinfo.Set.t;
- compinfos: Compinfo.Set.t;
- enuminfos: Enuminfo.Set.t;
- varinfos: Varinfo.Set.t;
- logic_infos: Logic_info.Set.t;
- kept: global list;
- }
-
-let treat_one_global acc g =
- match g with
+ type env =
+ { typeinfos: Typeinfo.Set.t;
+ compinfos: Compinfo.Set.t;
+ enuminfos: Enuminfo.Set.t;
+ varinfos: Varinfo.Set.t;
+ logic_infos: Logic_info.Set.t;
+ kept: global list;
+ }
+
+ let treat_one_global acc g =
+ match g with
| GType (ty,_) when Typeinfo.Set.mem ty acc.typeinfos -> acc
| GType (ty,_) ->
- { acc with
- typeinfos = Typeinfo.Set.add ty acc.typeinfos;
- kept = g :: acc.kept }
+ { acc with
+ typeinfos = Typeinfo.Set.add ty acc.typeinfos;
+ kept = g :: acc.kept }
| GCompTag _ -> { acc with kept = g :: acc.kept }
| GCompTagDecl(ci,_) when Compinfo.Set.mem ci acc.compinfos -> acc
| GCompTagDecl(ci,_) ->
- { acc with
- compinfos = Compinfo.Set.add ci acc.compinfos;
- kept = g :: acc.kept }
+ { acc with
+ compinfos = Compinfo.Set.add ci acc.compinfos;
+ kept = g :: acc.kept }
| GEnumTag _ -> { acc with kept = g :: acc.kept }
| GEnumTagDecl(ei,_) when Enuminfo.Set.mem ei acc.enuminfos -> acc
| GEnumTagDecl(ei,_) ->
- { acc with
- enuminfos = Enuminfo.Set.add ei acc.enuminfos;
- kept = g :: acc.kept }
+ { acc with
+ enuminfos = Enuminfo.Set.add ei acc.enuminfos;
+ kept = g :: acc.kept }
| GVarDecl(vi,_) | GFunDecl (_, vi, _)
- when Varinfo.Set.mem vi acc.varinfos -> acc
+ when Varinfo.Set.mem vi acc.varinfos -> acc
| GVarDecl(vi,_) ->
- { acc with
- varinfos = Varinfo.Set.add vi acc.varinfos;
- kept = g :: acc.kept }
+ { acc with
+ varinfos = Varinfo.Set.add vi acc.varinfos;
+ kept = g :: acc.kept }
| GVar _ | GFun _ | GFunDecl _ -> { acc with kept = g :: acc.kept }
| GAsm _ | GPragma _ | GText _ -> { acc with kept = g :: acc.kept }
| GAnnot (a,_) ->
- let lis = extract_logic_infos a in
- if List.exists (fun x -> Logic_info.Set.mem x acc.logic_infos) lis
- then acc
- else begin
- let known_li =
- List.fold_left (Extlib.swap Logic_info.Set.add) acc.logic_infos lis
- in
- { acc with
- kept = g::acc.kept;
- logic_infos = known_li;
- }
- end
+ let lis = extract_logic_infos a in
+ if List.exists (fun x -> Logic_info.Set.mem x acc.logic_infos) lis
+ then acc
+ else begin
+ let known_li =
+ List.fold_left (Extlib.swap Logic_info.Set.add) acc.logic_infos lis
+ in
+ { acc with
+ kept = g::acc.kept;
+ logic_infos = known_li;
+ }
+ end
-let empty =
- { typeinfos = Typeinfo.Set.empty;
- compinfos = Compinfo.Set.empty;
- enuminfos = Enuminfo.Set.empty;
- varinfos = Varinfo.Set.empty;
- logic_infos = Logic_info.Set.empty;
- kept = [];
- }
+ let empty =
+ { typeinfos = Typeinfo.Set.empty;
+ compinfos = Compinfo.Set.empty;
+ enuminfos = Enuminfo.Set.empty;
+ varinfos = Varinfo.Set.empty;
+ logic_infos = Logic_info.Set.empty;
+ kept = [];
+ }
-let process file =
- let env = List.fold_left treat_one_global empty file.globals in
- file.globals <- List.rev env.kept
+ let process file =
+ let env = List.fold_left treat_one_global empty file.globals in
+ file.globals <- List.rev env.kept
end
@@ -1593,10 +1593,10 @@ let prepare_from_c_files () =
reset the untyped AST. Restore it here. *)
Ast.UntypedFiles.set cabs_files
-let init_project_from_visitor ?(reorder=false) prj
+let init_project_from_visitor ?(reorder=false) prj
(vis:Visitor.frama_c_visitor) =
if not (Cil.is_copy_behavior vis#behavior)
- || not (Project.equal prj (Extlib.the vis#project))
+ || not (Project.equal prj (Extlib.the vis#project))
then
Kernel.fatal
"Visitor does not copy or does not operate on correct project.";
@@ -1677,7 +1677,7 @@ let init_from_cmdline () =
end;
with Ast.Bad_Initialization s ->
Kernel.fatal "@[<v 0>Cannot initialize from C files@ \
- Kernel raised Bad_Initialization %s@]" s
+ Kernel raised Bad_Initialization %s@]" s
let init_from_cmdline =
Journal.register
@@ -1698,16 +1698,16 @@ let prepare_from_c_files =
prepare_from_c_files
let () = Ast.set_default_initialization
- (fun () ->
- if Files.is_computed () then prepare_from_c_files ()
- else init_from_cmdline ())
+ (fun () ->
+ if Files.is_computed () then prepare_from_c_files ()
+ else init_from_cmdline ())
let pp_file_to fmt_opt =
let pp_ast = Printer.pp_file in
let ast = Ast.get () in
(match fmt_opt with
- | None -> Kernel.CodeOutput.output (fun fmt -> pp_ast fmt ast)
- | Some fmt -> pp_ast fmt ast)
+ | None -> Kernel.CodeOutput.output (fun fmt -> pp_ast fmt ast)
+ | Some fmt -> pp_ast fmt ast)
let unjournalized_pretty prj (fmt_opt:Format.formatter option) () =
Project.on prj pp_file_to fmt_opt
@@ -1740,7 +1740,7 @@ let create_rebuilt_project_from_visitor
let fmt = Format.formatter_of_out_channel cout in
unjournalized_pretty prj (Some fmt) ();
let redo () =
-(* Kernel.feedback "redoing initialization on file %s" f;*)
+ (* Kernel.feedback "redoing initialization on file %s" f;*)
Files.reset ();
init_from_c_files [ if preprocess then from_filename f else NoCPP f ]
in
diff --git a/src/kernel_services/ast_queries/filecheck.ml b/src/kernel_services/ast_queries/filecheck.ml
index a145816ff6a..7567114270c 100644
--- a/src/kernel_services/ast_queries/filecheck.ml
+++ b/src/kernel_services/ast_queries/filecheck.ml
@@ -40,1301 +40,1301 @@ let pretty_logic_var_kind fmt = function
| LVLocal -> Format.pp_print_string fmt "local parameter"
module Base_checker = struct
-class check ?(is_normalized=true) what : Visitor.frama_c_visitor =
- let check_abort fmt =
- Kernel.fatal ~current:true ("[AST Integrity Check]@ %s@ " ^^ fmt) what
- in
- let abort_if cond = if cond then check_abort else Pretty_utils.nullprintf in
- object(self)
- inherit Visitor.frama_c_inplace as plain
- val known_enuminfos = Enuminfo.Hashtbl.create 7
- val known_enumitems = Enumitem.Hashtbl.create 7
- val known_loop_annot_id = Hashtbl.create 7
- val known_code_annot_id = Hashtbl.create 7
- val known_fields = Fieldinfo.Hashtbl.create 7
- val known_compinfos = Compinfo.Hashtbl.create 7
- val known_stmts = Stmt.Hashtbl.create 7
- val known_vars = Varinfo.Hashtbl.create 7
- val known_logic_info = Logic_var.Hashtbl.create 7
- val mutable local_vars = Varinfo.Set.empty
- val known_logic_vars = Logic_var.Hashtbl.create 7
- val switch_cases = Stmt.Hashtbl.create 7
- val unspecified_sequence_calls = Stack.create ()
- val mutable labelled_stmt = []
- val mutable logic_labels = []
- val mutable globals_functions = Varinfo.Set.empty
- val mutable local_statics = Varinfo.Set.empty
- val mutable globals_vars = Varinfo.Set.empty
- val mutable return_stmt = None
-
- val quant_orig = Stack.create ()
-
- val behavior_stack = Stack.create ()
-
- method private push_behavior_stack () =
- Stack.push (Datatype.String.Set.empty) behavior_stack
- method private pop_behavior_stack () = ignore (Stack.pop behavior_stack)
- method private add_behavior_stack_name b =
- let current = Stack.pop behavior_stack in
- Stack.push (Datatype.String.Set.add b current) behavior_stack
- method private add_spec_behavior_names spec =
- List.iter
- (fun b -> self#add_behavior_stack_name b.b_name) spec.spec_behavior
-
- method private mem_behavior_stack_name b =
- try
+ class check ?(is_normalized=true) what : Visitor.frama_c_visitor =
+ let check_abort fmt =
+ Kernel.fatal ~current:true ("[AST Integrity Check]@ %s@ " ^^ fmt) what
+ in
+ let abort_if cond = if cond then check_abort else Pretty_utils.nullprintf in
+ object(self)
+ inherit Visitor.frama_c_inplace as plain
+ val known_enuminfos = Enuminfo.Hashtbl.create 7
+ val known_enumitems = Enumitem.Hashtbl.create 7
+ val known_loop_annot_id = Hashtbl.create 7
+ val known_code_annot_id = Hashtbl.create 7
+ val known_fields = Fieldinfo.Hashtbl.create 7
+ val known_compinfos = Compinfo.Hashtbl.create 7
+ val known_stmts = Stmt.Hashtbl.create 7
+ val known_vars = Varinfo.Hashtbl.create 7
+ val known_logic_info = Logic_var.Hashtbl.create 7
+ val mutable local_vars = Varinfo.Set.empty
+ val known_logic_vars = Logic_var.Hashtbl.create 7
+ val switch_cases = Stmt.Hashtbl.create 7
+ val unspecified_sequence_calls = Stack.create ()
+ val mutable labelled_stmt = []
+ val mutable logic_labels = []
+ val mutable globals_functions = Varinfo.Set.empty
+ val mutable local_statics = Varinfo.Set.empty
+ val mutable globals_vars = Varinfo.Set.empty
+ val mutable return_stmt = None
+
+ val quant_orig = Stack.create ()
+
+ val behavior_stack = Stack.create ()
+
+ method private push_behavior_stack () =
+ Stack.push (Datatype.String.Set.empty) behavior_stack
+ method private pop_behavior_stack () = ignore (Stack.pop behavior_stack)
+ method private add_behavior_stack_name b =
+ let current = Stack.pop behavior_stack in
+ Stack.push (Datatype.String.Set.add b current) behavior_stack
+ method private add_spec_behavior_names spec =
+ List.iter
+ (fun b -> self#add_behavior_stack_name b.b_name) spec.spec_behavior
+
+ method private mem_behavior_stack_name b =
+ try
+ Stack.iter
+ (fun s -> if Datatype.String.Set.mem b s then raise Exit)
+ behavior_stack;
+ false
+ with Exit -> true
+
+ method private remove_globals_function vi =
+ globals_functions <- Varinfo.Set.remove vi globals_functions
+
+ method private remove_globals_var vi =
+ globals_vars <- Varinfo.Set.remove vi globals_vars
+
+ method private add_local_static vi =
+ local_statics <- Varinfo.Set.add vi local_statics
+
+ method private remove_local_static vi =
+ local_statics <- Varinfo.Set.remove vi local_statics
+
+ method! venuminfo ei =
+ Enuminfo.Hashtbl.add known_enuminfos ei ei;
+ Cil.DoChildren
+
+ method! venumitem ei =
+ let orig =
+ try Enuminfo.Hashtbl.find known_enuminfos ei.eihost
+ with Not_found -> check_abort "Unknown enuminfo %s" ei.eihost.ename
+ in
+ if orig != ei.eihost then
+ check_abort "Item %s is not tied correctly to its enuminfo %s"
+ ei.einame
+ ei.eihost.ename;
+ Enumitem.Hashtbl.add known_enumitems ei ei;
+ Cil.DoChildren
+
+ method private remove_unspecified_sequence_calls s =
Stack.iter
- (fun s -> if Datatype.String.Set.mem b s then raise Exit)
- behavior_stack;
- false
- with Exit -> true
-
- method private remove_globals_function vi =
- globals_functions <- Varinfo.Set.remove vi globals_functions
-
- method private remove_globals_var vi =
- globals_vars <- Varinfo.Set.remove vi globals_vars
-
- method private add_local_static vi =
- local_statics <- Varinfo.Set.add vi local_statics
-
- method private remove_local_static vi =
- local_statics <- Varinfo.Set.remove vi local_statics
-
- method! venuminfo ei =
- Enuminfo.Hashtbl.add known_enuminfos ei ei;
- Cil.DoChildren
-
- method! venumitem ei =
- let orig =
- try Enuminfo.Hashtbl.find known_enuminfos ei.eihost
- with Not_found -> check_abort "Unknown enuminfo %s" ei.eihost.ename
- in
- if orig != ei.eihost then
- check_abort "Item %s is not tied correctly to its enuminfo %s"
- ei.einame
- ei.eihost.ename;
- Enumitem.Hashtbl.add known_enumitems ei ei;
- Cil.DoChildren
-
- method private remove_unspecified_sequence_calls s =
- Stack.iter
- (fun calls -> calls:= Stmt.Set.remove s !calls)
- unspecified_sequence_calls
-
- method! vvdec v =
- Kernel.debug
- ~dkey:Kernel.dkey_check "Declaration of %s(%d)" v.vname v.vid;
- if Varinfo.Hashtbl.mem known_vars v then
- (let v' = Varinfo.Hashtbl.find known_vars v in
- if v != v' then (* we can see the declaration twice
- (decl and def in fact) *)
- (check_abort "variables %s and %s have the same id (%d)"
- v.vname v'.vname v.vid))
- else
- Varinfo.Hashtbl.add known_vars v v;
- match v.vlogic_var_assoc with
- | None -> Cil.DoChildren
- | Some ({ lv_origin = Some v'} as lv) when v == v' ->
- Kernel.debug ~dkey:Kernel.dkey_check
- "var %s(%d) has an associated %s(%d)"
- v.vname v.vid lv.lv_name lv.lv_id;
- (match lv.lv_type with
- | Ctype t ->
- if not (Cil_datatype.TypNoUnroll.equal t v.vtype) then
+ (fun calls -> calls:= Stmt.Set.remove s !calls)
+ unspecified_sequence_calls
+
+ method! vvdec v =
+ Kernel.debug
+ ~dkey:Kernel.dkey_check "Declaration of %s(%d)" v.vname v.vid;
+ if Varinfo.Hashtbl.mem known_vars v then
+ (let v' = Varinfo.Hashtbl.find known_vars v in
+ if v != v' then (* we can see the declaration twice
+ (decl and def in fact) *)
+ (check_abort "variables %s and %s have the same id (%d)"
+ v.vname v'.vname v.vid))
+ else
+ Varinfo.Hashtbl.add known_vars v v;
+ match v.vlogic_var_assoc with
+ | None -> Cil.DoChildren
+ | Some ({ lv_origin = Some v'} as lv) when v == v' ->
+ Kernel.debug ~dkey:Kernel.dkey_check
+ "var %s(%d) has an associated %s(%d)"
+ v.vname v.vid lv.lv_name lv.lv_id;
+ (match lv.lv_type with
+ | Ctype t ->
+ if not (Cil_datatype.TypNoUnroll.equal t v.vtype) then
+ check_abort
+ "C variable %s and its associated variable do not have the \
+ same type:@\nC type is %a@\nLogic type is %a"
+ v.vname Cil_datatype.Typ.pretty v.vtype
+ Cil_datatype.Typ.pretty t
+ | lt ->
check_abort
- "C variable %s and its associated variable do not have the \
- same type:@\nC type is %a@\nLogic type is %a"
- v.vname Cil_datatype.Typ.pretty v.vtype
- Cil_datatype.Typ.pretty t
- | lt ->
- check_abort
- "Logic variable %s is associated to a C variable but has \
- a purely logic type, %a@."
- lv.lv_name Cil_datatype.Logic_type.pretty lt);
- Cil.DoChildren
- | Some lv ->
- (check_abort "C variable %s is not properly referenced by its \
- associated logic variable %s"
- v.vname lv.lv_name)
-
- method! vvrbl v =
- let not_shared () =
- check_abort
- "variable %s is not shared between definition and use" v.vname
- in
- let unknown () =
- check_abort "variable %s(%d) is not declared" v.vname v.vid
- in
- if not v.vglob || not (Ast_info.is_frama_c_builtin v.vname) then
- (try
- if Varinfo.Hashtbl.find known_vars v != v then not_shared ()
- with Not_found -> unknown ()
- );
- Cil.DoChildren
-
- method! vquantifiers l =
- let orig =
- try Stack.top quant_orig
- with Stack.Empty ->
+ "Logic variable %s is associated to a C variable but has \
+ a purely logic type, %a@."
+ lv.lv_name Cil_datatype.Logic_type.pretty lt);
+ Cil.DoChildren
+ | Some lv ->
+ (check_abort "C variable %s is not properly referenced by its \
+ associated logic variable %s"
+ v.vname lv.lv_name)
+
+ method! vvrbl v =
+ let not_shared () =
check_abort
- "Internal error of check visitor: don't know which origin a logic \
- variable should be checked against"
- in
- List.iter
- (fun lv ->
- if lv.lv_kind <> orig then
- check_abort
- "logic variable %a is flagged as %a but declared as a %a"
- Printer.pp_logic_var lv
- pretty_logic_var_kind lv.lv_kind
- pretty_logic_var_kind orig)
- l;
- Cil.DoChildren
-
- method! vlogic_var_decl lv =
- Logic_var.Hashtbl.add known_logic_vars lv lv;
- match lv.lv_origin with
- (* lvkind for purely logical variables is checked at the parent level. *)
- | None -> Cil.DoChildren
- | Some v when lv.lv_kind <> LVC ->
- check_abort
- "logic variable %a as an associated variable %a, but is not \
- flagged as having a C origin"
- Printer.pp_logic_var lv Printer.pp_varinfo v
- | Some { vlogic_var_assoc = Some lv' } when lv == lv' ->
- ignore
- Visitor.(visitFramacLogicType (self:>frama_c_visitor) lv.lv_type);
- (* DoChildren on initialized local variables would fail, as it performs
- a vvrbl on the C variable, before having reached the initializer. *)
- Cil.SkipChildren
- | Some v ->
- check_abort
- "logic variable %a is not properly referenced by the original \
- C variable %a"
- Printer.pp_logic_var lv Printer.pp_varinfo v
-
- method! vlogic_var_use v =
- if v.lv_name <> "\\exit_status" then begin
- if Logic_env.is_builtin_logic_function v.lv_name then begin
- match Logic_env.find_all_logic_functions v.lv_name with
- | [] ->
- check_abort "No logic variable registered for built-in %s" v.lv_name
- | _ :: _ as l ->
- if not (List.exists (fun x -> x.l_var_info == v) l) then
- check_abort
- "Built-in logic variable %s information is not shared \
- between environment and use"
- v.lv_name
- end else begin
- let unknown () =
- check_abort "logic variable %s (%d) is not declared" v.lv_name v.lv_id
- in
- let not_shared () =
+ "variable %s is not shared between definition and use" v.vname
+ in
+ let unknown () =
+ check_abort "variable %s(%d) is not declared" v.vname v.vid
+ in
+ if not v.vglob || not (Ast_info.is_frama_c_builtin v.vname) then
+ (try
+ if Varinfo.Hashtbl.find known_vars v != v then not_shared ()
+ with Not_found -> unknown ()
+ );
+ Cil.DoChildren
+
+ method! vquantifiers l =
+ let orig =
+ try Stack.top quant_orig
+ with Stack.Empty ->
check_abort
- "logic variable %s (%d) is not shared between definition and use"
- v.lv_name v.lv_id
- in
- try
- if Logic_var.Hashtbl.find known_logic_vars v != v then not_shared ()
- with Not_found -> unknown ()
- end
- end;
- Cil.DoChildren
-
- method! vfunc f =
- self#push_behavior_stack ();
- (* Initial AST does not have kf *)
- if is_normalized then begin
- let kf = Extlib.the self#current_kf in
- if not (Kernel_function.is_definition kf) then
+ "Internal error of check visitor: don't know which origin a logic \
+ variable should be checked against"
+ in
+ List.iter
+ (fun lv ->
+ if lv.lv_kind <> orig then
+ check_abort
+ "logic variable %a is flagged as %a but declared as a %a"
+ Printer.pp_logic_var lv
+ pretty_logic_var_kind lv.lv_kind
+ pretty_logic_var_kind orig)
+ l;
+ Cil.DoChildren
+
+ method! vlogic_var_decl lv =
+ Logic_var.Hashtbl.add known_logic_vars lv lv;
+ match lv.lv_origin with
+ (* lvkind for purely logical variables is checked at the parent level. *)
+ | None -> Cil.DoChildren
+ | Some v when lv.lv_kind <> LVC ->
check_abort
- "Kernel function %a is supposed to be a prototype, but it has a body"
- Kernel_function.pretty kf;
- if Kernel_function.get_definition kf != f then
+ "logic variable %a as an associated variable %a, but is not \
+ flagged as having a C origin"
+ Printer.pp_logic_var lv Printer.pp_varinfo v
+ | Some { vlogic_var_assoc = Some lv' } when lv == lv' ->
+ ignore
+ Visitor.(visitFramacLogicType (self:>frama_c_visitor) lv.lv_type);
+ (* DoChildren on initialized local variables would fail, as it performs
+ a vvrbl on the C variable, before having reached the initializer. *)
+ Cil.SkipChildren
+ | Some v ->
check_abort
- "Body of %a is not shared between kernel function and AST"
- Kernel_function.pretty kf;
- return_stmt <- Some (Kernel_function.find_return kf);
- let spec = Annotations.funspec ~populate:false kf in
- self#add_spec_behavior_names spec;
- end else begin self#add_spec_behavior_names f.sspec; end;
- labelled_stmt <- [];
- Stmt.Hashtbl.clear known_stmts;
- Stmt.Hashtbl.clear switch_cases;
- local_vars <- Varinfo.Set.empty;
- List.iter
- (fun x -> local_vars <- Varinfo.Set.add x local_vars) f.slocals;
- let print_stmt fmt stmt =
- Format.fprintf fmt "@[%a (%d)@]" Printer.pp_stmt stmt stmt.sid
- in
- let check f =
- if Stmt.Hashtbl.length switch_cases <> 0 then
- begin
- Stmt.Hashtbl.iter
- (fun x _ ->
- check_abort
- "In function %a, statement %a \
- does not appear in body of switch while porting a \
- case or default label."
- Printer.pp_varinfo f.svar print_stmt x)
- switch_cases
- end;
+ "logic variable %a is not properly referenced by the original \
+ C variable %a"
+ Printer.pp_logic_var lv Printer.pp_varinfo v
+
+ method! vlogic_var_use v =
+ if v.lv_name <> "\\exit_status" then begin
+ if Logic_env.is_builtin_logic_function v.lv_name then begin
+ match Logic_env.find_all_logic_functions v.lv_name with
+ | [] ->
+ check_abort "No logic variable registered for built-in %s" v.lv_name
+ | _ :: _ as l ->
+ if not (List.exists (fun x -> x.l_var_info == v) l) then
+ check_abort
+ "Built-in logic variable %s information is not shared \
+ between environment and use"
+ v.lv_name
+ end else begin
+ let unknown () =
+ check_abort "logic variable %s (%d) is not declared" v.lv_name v.lv_id
+ in
+ let not_shared () =
+ check_abort
+ "logic variable %s (%d) is not shared between definition and use"
+ v.lv_name v.lv_id
+ in
+ try
+ if Logic_var.Hashtbl.find known_logic_vars v != v then not_shared ()
+ with Not_found -> unknown ()
+ end
+ end;
+ Cil.DoChildren
+
+ method! vfunc f =
+ self#push_behavior_stack ();
+ (* Initial AST does not have kf *)
+ if is_normalized then begin
+ let kf = Extlib.the self#current_kf in
+ if not (Kernel_function.is_definition kf) then
+ check_abort
+ "Kernel function %a is supposed to be a prototype, but it has a body"
+ Kernel_function.pretty kf;
+ if Kernel_function.get_definition kf != f then
+ check_abort
+ "Body of %a is not shared between kernel function and AST"
+ Kernel_function.pretty kf;
+ return_stmt <- Some (Kernel_function.find_return kf);
+ let spec = Annotations.funspec ~populate:false kf in
+ self#add_spec_behavior_names spec;
+ end else begin self#add_spec_behavior_names f.sspec; end;
+ labelled_stmt <- [];
+ Stmt.Hashtbl.clear known_stmts;
+ Stmt.Hashtbl.clear switch_cases;
+ local_vars <- Varinfo.Set.empty;
List.iter
- (fun stmt ->
- try
- let stmt' = Stmt.Hashtbl.find known_stmts stmt in
- if stmt' != stmt then
+ (fun x -> local_vars <- Varinfo.Set.add x local_vars) f.slocals;
+ let print_stmt fmt stmt =
+ Format.fprintf fmt "@[%a (%d)@]" Printer.pp_stmt stmt stmt.sid
+ in
+ let check f =
+ if Stmt.Hashtbl.length switch_cases <> 0 then
+ begin
+ Stmt.Hashtbl.iter
+ (fun x _ ->
+ check_abort
+ "In function %a, statement %a \
+ does not appear in body of switch while porting a \
+ case or default label."
+ Printer.pp_varinfo f.svar print_stmt x)
+ switch_cases
+ end;
+ List.iter
+ (fun stmt ->
+ try
+ let stmt' = Stmt.Hashtbl.find known_stmts stmt in
+ if stmt' != stmt then
+ check_abort
+ "Label @[%a@]@ in function %a@ \
+ is not linked to the correct statement:@\n\
+ statement in AST is %a@\n\
+ statement referenced in goto or \\at is %a"
+ Printer.pp_stmt {stmt with skind = Instr (Skip (Stmt.loc stmt)) }
+ Printer.pp_varinfo f.svar
+ print_stmt stmt'
+ print_stmt stmt
+ with Not_found ->
check_abort
"Label @[%a@]@ in function %a@ \
- is not linked to the correct statement:@\n\
- statement in AST is %a@\n\
- statement referenced in goto or \\at is %a"
+ does not refer to an existing statement"
Printer.pp_stmt {stmt with skind = Instr (Skip (Stmt.loc stmt)) }
- Printer.pp_varinfo f.svar
- print_stmt stmt'
- print_stmt stmt
- with Not_found ->
- check_abort
- "Label @[%a@]@ in function %a@ \
- does not refer to an existing statement"
- Printer.pp_stmt {stmt with skind = Instr (Skip (Stmt.loc stmt)) }
- Printer.pp_varinfo f.svar)
- labelled_stmt;
- labelled_stmt <- [];
- (match return_stmt with
- | None -> ()
- | Some _ -> (* can only happen in normalized mode. *)
- check_abort
- "Function %a does not have a return statement in its body"
- Kernel_function.pretty (Extlib.the self#current_kf));
- let check_one_stmt stmt _ =
- let check_cfg_edge stmt' =
- try
- let ast_stmt = Stmt.Hashtbl.find known_stmts stmt' in
- if ast_stmt != stmt' then
+ Printer.pp_varinfo f.svar)
+ labelled_stmt;
+ labelled_stmt <- [];
+ (match return_stmt with
+ | None -> ()
+ | Some _ -> (* can only happen in normalized mode. *)
+ check_abort
+ "Function %a does not have a return statement in its body"
+ Kernel_function.pretty (Extlib.the self#current_kf));
+ let check_one_stmt stmt _ =
+ let check_cfg_edge stmt' =
+ try
+ let ast_stmt = Stmt.Hashtbl.find known_stmts stmt' in
+ if ast_stmt != stmt' then
+ check_abort
+ "cfg info of statement %a in function %a \
+ is not linked to correct statement:@\n\
+ statement in AST is %a@\n\
+ statement referenced in cfg info is %a"
+ print_stmt stmt
+ Printer.pp_varinfo f.svar
+ print_stmt ast_stmt
+ print_stmt stmt'
+ with Not_found ->
check_abort
- "cfg info of statement %a in function %a \
- is not linked to correct statement:@\n\
- statement in AST is %a@\n\
- statement referenced in cfg info is %a"
- print_stmt stmt
- Printer.pp_varinfo f.svar
- print_stmt ast_stmt
- print_stmt stmt'
- with Not_found ->
- check_abort
- "cfg info of statement %a in function %a does not \
- refer to an existing statement.@\n\
- Referenced statement is %a"
- print_stmt stmt Printer.pp_varinfo f.svar print_stmt stmt'
+ "cfg info of statement %a in function %a does not \
+ refer to an existing statement.@\n\
+ Referenced statement is %a"
+ print_stmt stmt Printer.pp_varinfo f.svar print_stmt stmt'
+ in
+ List.iter check_cfg_edge stmt.succs;
+ List.iter check_cfg_edge stmt.preds;
+ match stmt.skind with
+ | Return _ | Throw _ ->
+ if stmt.succs <> [] then
+ check_abort
+ "return statement %a in function %a \
+ has successors:@\n%a"
+ print_stmt stmt Printer.pp_varinfo f.svar
+ (Pretty_utils.pp_list ~sep:"@\n" print_stmt) stmt.succs
+ | Instr(Call (_, called, _, _))
+ when Cil.typeHasAttribute "noreturn" (Cil.typeOf called) ->
+ if stmt.succs <> [] then
+ check_abort
+ "exit statement %a in function %a \
+ has successors:@\n%a"
+ print_stmt stmt Printer.pp_varinfo f.svar
+ (Pretty_utils.pp_list ~sep:"@\n" print_stmt) stmt.succs
+ | Instr(Call (_, { enode = Lval(Var called,NoOffset)}, _, _))
+ when Cil.hasAttribute "noreturn" called.vattr ->
+ if stmt.succs <> [] then
+ check_abort
+ "exit statement %a in function %a \
+ has successors:@\n%a"
+ print_stmt stmt Printer.pp_varinfo f.svar
+ (Pretty_utils.pp_list ~sep:"@\n" print_stmt) stmt.succs
+ | _ ->
+ (* unnormalized code may not contain return statement,
+ leaving perfectly normal statements without succs. *)
+ if is_normalized && stmt.succs = [] then
+ check_abort
+ "statement %a in function %a has no successor."
+ print_stmt stmt Printer.pp_varinfo f.svar
in
- List.iter check_cfg_edge stmt.succs;
- List.iter check_cfg_edge stmt.preds;
- match stmt.skind with
- | Return _ | Throw _ ->
- if stmt.succs <> [] then
- check_abort
- "return statement %a in function %a \
- has successors:@\n%a"
- print_stmt stmt Printer.pp_varinfo f.svar
- (Pretty_utils.pp_list ~sep:"@\n" print_stmt) stmt.succs
- | Instr(Call (_, called, _, _))
- when Cil.typeHasAttribute "noreturn" (Cil.typeOf called) ->
- if stmt.succs <> [] then
- check_abort
- "exit statement %a in function %a \
- has successors:@\n%a"
- print_stmt stmt Printer.pp_varinfo f.svar
- (Pretty_utils.pp_list ~sep:"@\n" print_stmt) stmt.succs
- | Instr(Call (_, { enode = Lval(Var called,NoOffset)}, _, _))
- when Cil.hasAttribute "noreturn" called.vattr ->
- if stmt.succs <> [] then
- check_abort
- "exit statement %a in function %a \
- has successors:@\n%a"
- print_stmt stmt Printer.pp_varinfo f.svar
- (Pretty_utils.pp_list ~sep:"@\n" print_stmt) stmt.succs
- | _ ->
- (* unnormalized code may not contain return statement,
- leaving perfectly normal statements without succs. *)
- if is_normalized && stmt.succs = [] then
- check_abort
- "statement %a in function %a has no successor."
- print_stmt stmt Printer.pp_varinfo f.svar
- in
- Stmt.Hashtbl.iter check_one_stmt known_stmts;
- Stmt.Hashtbl.clear known_stmts;
- if not (Varinfo.Set.is_empty local_vars) then begin
- check_abort
- "Local variables %a of function %a are not part of any block"
- (Pretty_utils.pp_list ~sep:",@ " Printer.pp_varinfo)
- (Varinfo.Set.elements local_vars)
- Printer.pp_varinfo f.svar
- end;
- self#pop_behavior_stack ();
- f
- in
- Cil.DoChildrenPost check
-
- method private check_label s =
- let ok = List.exists (function Label _ -> true | _ -> false) !s.labels in
- if not ok then
- check_abort
- "@[<v 2>Statement is referenced by \\at or goto without \
- having a label:@\n%a@]"
- Printer.pp_stmt !s
- ;
- labelled_stmt <- !s :: labelled_stmt
-
- method private check_try_catch_decl (decl,_) =
- match decl with
- | Catch_exn(v,l) ->
- self#check_local_var v;
- List.iter (fun (v,_) -> self#check_local_var v) l
- | Catch_all -> ()
-
- method! vstmt_aux s =
- Stmt.Hashtbl.add known_stmts s s;
- Stmt.Hashtbl.remove switch_cases s;
- self#push_behavior_stack ();
- self#remove_unspecified_sequence_calls s;
- if is_normalized then begin
- let contracts =
- Annotations.code_annot ~filter:Logic_utils.is_contract s
- in
- List.iter
- (function
- | {annot_content = AStmtSpec(_,spec)} ->
- self#add_spec_behavior_names spec
- | _ -> assert false (* filter should prevent anything else. *))
- contracts;
- let kf = Extlib.the self#current_kf in
- let s',kf' =
- try
- Kernel_function.find_from_sid s.sid
- with Not_found ->
+ Stmt.Hashtbl.iter check_one_stmt known_stmts;
+ Stmt.Hashtbl.clear known_stmts;
+ if not (Varinfo.Set.is_empty local_vars) then begin
check_abort
- "Statement %a of function %s is unknown in internal tables"
- Printer.pp_stmt s (Kernel_function.get_name kf)
+ "Local variables %a of function %a are not part of any block"
+ (Pretty_utils.pp_list ~sep:",@ " Printer.pp_varinfo)
+ (Varinfo.Set.elements local_vars)
+ Printer.pp_varinfo f.svar
+ end;
+ self#pop_behavior_stack ();
+ f
in
- if s != s' then
+ Cil.DoChildrenPost check
+
+ method private check_label s =
+ let ok = List.exists (function Label _ -> true | _ -> false) !s.labels in
+ if not ok then
check_abort
- "Statement %a of function %s \
- is not shared with internal tables"
- Printer.pp_stmt s (Kernel_function.get_name kf);
- if kf != kf' then
+ "@[<v 2>Statement is referenced by \\at or goto without \
+ having a label:@\n%a@]"
+ Printer.pp_stmt !s
+ ;
+ labelled_stmt <- !s :: labelled_stmt
+
+ method private check_try_catch_decl (decl,_) =
+ match decl with
+ | Catch_exn(v,l) ->
+ self#check_local_var v;
+ List.iter (fun (v,_) -> self#check_local_var v) l
+ | Catch_all -> ()
+
+ method! vstmt_aux s =
+ Stmt.Hashtbl.add known_stmts s s;
+ Stmt.Hashtbl.remove switch_cases s;
+ self#push_behavior_stack ();
+ self#remove_unspecified_sequence_calls s;
+ if is_normalized then begin
+ let contracts =
+ Annotations.code_annot ~filter:Logic_utils.is_contract s
+ in
+ List.iter
+ (function
+ | {annot_content = AStmtSpec(_,spec)} ->
+ self#add_spec_behavior_names spec
+ | _ -> assert false (* filter should prevent anything else. *))
+ contracts;
+ let kf = Extlib.the self#current_kf in
+ let s',kf' =
+ try
+ Kernel_function.find_from_sid s.sid
+ with Not_found ->
+ check_abort
+ "Statement %a of function %s is unknown in internal tables"
+ Printer.pp_stmt s (Kernel_function.get_name kf)
+ in
+ if s != s' then
+ check_abort
+ "Statement %a of function %s \
+ is not shared with internal tables"
+ Printer.pp_stmt s (Kernel_function.get_name kf);
+ if kf != kf' then
+ check_abort
+ "Statement %a of function %s is registered with a wrong kf"
+ Printer.pp_stmt s (Kernel_function.get_name kf);
+ let blocks = Kernel_function.find_all_enclosing_blocks s in
+ let b = Extlib.last blocks in
+ let body = Kernel_function.get_definition kf in
+ if b != body.sbody then
+ check_abort
+ "In function %s, statement %a is supposed to belong \
+ to an outermost block different from function's body"
+ (Kernel_function.get_name kf)
+ Printer.pp_stmt s
+ end;
+ let post_action s = self#pop_behavior_stack (); s in
+ (match s.skind with
+ | Goto (l,_) ->
+ self#check_label l; Cil.ChangeDoChildrenPost(s,post_action)
+ | Switch(_,_,cases,loc) ->
+ List.iter (fun s -> Stmt.Hashtbl.add switch_cases s loc) cases;
+ Cil.ChangeDoChildrenPost(s,post_action)
+ | UnspecifiedSequence seq ->
+ let calls =
+ List.fold_left
+ (fun acc (_,_,_,_,calls) ->
+ List.fold_left (fun acc x -> Stmt.Set.add !x acc) acc calls)
+ Stmt.Set.empty
+ seq
+ in
+ Stack.push (ref calls) unspecified_sequence_calls;
+ let f s =
+ let calls = Stack.pop unspecified_sequence_calls in
+ if Stmt.Set.is_empty !calls then post_action s
+ else
+ check_abort
+ "@[Calls referenced in unspecified sequence \
+ are not in the AST:@[<v>%a@]@]"
+ (Pretty_utils.pp_list ~sep:"@ " Printer.pp_stmt)
+ (Stmt.Set.elements !calls)
+ in Cil.ChangeDoChildrenPost(s,f)
+ | If (_,bt,be,_) -> begin
+ (** Check that we have 2 successors, in the right order (then before
+ else) *)
+ match s.succs with
+ | [st; se] -> begin
+ (match bt.bstmts with
+ | st' :: _ ->
+ abort_if (not (st == st')) "Invalid 'then' successor for If"
+ | _ -> ());
+ (match be.bstmts with
+ | se' :: _ ->
+ abort_if (not (se == se')) "Invalid 'else' successor for If"
+ | _ -> ());
+ Cil.ChangeDoChildrenPost(s,post_action)
+ end
+ | l -> check_abort "If with %d successors" (List.length l)
+ end
+ | Loop _ ->
+ let old_labels = logic_labels in
+ logic_labels <-
+ Logic_const.(loop_current_label :: loop_entry_label :: logic_labels);
+ Cil.ChangeDoChildrenPost
+ (s, fun s -> logic_labels <- old_labels; post_action s)
+ | TryCatch(_,c,_) ->
+ List.iter self#check_try_catch_decl c;
+ Cil.ChangeDoChildrenPost(s, post_action)
+ | Return _ ->
+ if is_normalized then begin
+ match return_stmt with
+ | None ->
+ check_abort
+ "Found a second return statement in body of function %a"
+ Kernel_function.pretty (Extlib.the self#current_kf)
+ | Some s' when s != s' ->
+ check_abort
+ "Function %a is supposed to have as return statement %d:@\n%a@\n\
+ Found in its body statement %d:@\n%a@\n"
+ Kernel_function.pretty (Extlib.the self#current_kf)
+ s'.sid Printer.pp_stmt s'
+ s.sid Printer.pp_stmt s
+ | Some _ -> return_stmt <- None
+ end;
+ Cil.ChangeDoChildrenPost(s,post_action)
+ | _ -> Cil.ChangeDoChildrenPost (s,post_action));
+
+ method private check_local_var v =
+ if Varinfo.Set.mem v local_vars then begin
+ local_vars <- Varinfo.Set.remove v local_vars;
+ end else begin
check_abort
- "Statement %a of function %s is registered with a wrong kf"
- Printer.pp_stmt s (Kernel_function.get_name kf);
- let blocks = Kernel_function.find_all_enclosing_blocks s in
- let b = Extlib.last blocks in
- let body = Kernel_function.get_definition kf in
- if b != body.sbody then
+ "In function %a, variable %a(%d) is supposed to be local to a block \
+ but not mentioned in the function's locals."
+ Printer.pp_varinfo
+ (Extlib.the self#current_func).svar
+ Printer.pp_varinfo v v.vid
+ end
+
+ method private check_local_static v =
+ let prefix fmt =
+ Format.fprintf fmt
+ "Local variable %a(%d) in function %a"
+ Printer.pp_varinfo v v.vid
+ Printer.pp_varinfo (Extlib.the self#current_func).svar
+ in
+ if not v.vglob then
check_abort
- "In function %s, statement %a is supposed to belong \
- to an outermost block different from function's body"
- (Kernel_function.get_name kf)
- Printer.pp_stmt s
- end;
- let post_action s = self#pop_behavior_stack (); s in
- (match s.skind with
- | Goto (l,_) ->
- self#check_label l; Cil.ChangeDoChildrenPost(s,post_action)
- | Switch(_,_,cases,loc) ->
- List.iter (fun s -> Stmt.Hashtbl.add switch_cases s loc) cases;
- Cil.ChangeDoChildrenPost(s,post_action)
- | UnspecifiedSequence seq ->
- let calls =
- List.fold_left
- (fun acc (_,_,_,_,calls) ->
- List.fold_left (fun acc x -> Stmt.Set.add !x acc) acc calls)
- Stmt.Set.empty
- seq
- in
- Stack.push (ref calls) unspecified_sequence_calls;
- let f s =
- let calls = Stack.pop unspecified_sequence_calls in
- if Stmt.Set.is_empty !calls then post_action s
- else
- check_abort
- "@[Calls referenced in unspecified sequence \
- are not in the AST:@[<v>%a@]@]"
- (Pretty_utils.pp_list ~sep:"@ " Printer.pp_stmt)
- (Stmt.Set.elements !calls)
- in Cil.ChangeDoChildrenPost(s,f)
- | If (_,bt,be,_) -> begin
- (** Check that we have 2 successors, in the right order (then before
- else) *)
- match s.succs with
- | [st; se] -> begin
- (match bt.bstmts with
- | st' :: _ ->
- abort_if (not (st == st')) "Invalid 'then' successor for If"
- | _ -> ());
- (match be.bstmts with
- | se' :: _ ->
- abort_if (not (se == se')) "Invalid 'else' successor for If"
- | _ -> ());
- Cil.ChangeDoChildrenPost(s,post_action)
- end
- | l -> check_abort "If with %d successors" (List.length l)
- end
- | Loop _ ->
- let old_labels = logic_labels in
- logic_labels <-
- Logic_const.(loop_current_label :: loop_entry_label :: logic_labels);
- Cil.ChangeDoChildrenPost
- (s, fun s -> logic_labels <- old_labels; post_action s)
- | TryCatch(_,c,_) ->
- List.iter self#check_try_catch_decl c;
- Cil.ChangeDoChildrenPost(s, post_action)
- | Return _ ->
- if is_normalized then begin
- match return_stmt with
- | None ->
- check_abort
- "Found a second return statement in body of function %a"
- Kernel_function.pretty (Extlib.the self#current_kf)
- | Some s' when s != s' ->
- check_abort
- "Function %a is supposed to have as return statement %d:@\n%a@\n\
- Found in its body statement %d:@\n%a@\n"
- Kernel_function.pretty (Extlib.the self#current_kf)
- s'.sid Printer.pp_stmt s'
- s.sid Printer.pp_stmt s
- | Some _ -> return_stmt <- None
- end;
- Cil.ChangeDoChildrenPost(s,post_action)
- | _ -> Cil.ChangeDoChildrenPost (s,post_action));
-
- method private check_local_var v =
- if Varinfo.Set.mem v local_vars then begin
- local_vars <- Varinfo.Set.remove v local_vars;
- end else begin
- check_abort
- "In function %a, variable %a(%d) is supposed to be local to a block \
- but not mentioned in the function's locals."
- Printer.pp_varinfo
- (Extlib.the self#current_func).svar
- Printer.pp_varinfo v v.vid
- end
-
- method private check_local_static v =
- let prefix fmt =
- Format.fprintf fmt
- "Local variable %a(%d) in function %a"
- Printer.pp_varinfo v v.vid
- Printer.pp_varinfo (Extlib.the self#current_func).svar
- in
- if not v.vglob then
- check_abort
- "%t is supposed to be static, but varinfo has automatic storage."
- prefix;
- if not (Cil.hasAttribute Cabs2cil.fc_local_static v.vattr) then
- check_abort "%t is declared as a global static." prefix;
- ignore (self#vvrbl v);
- (* Ensure that the variable was not already claimed by another block. *)
- if not (Cil_datatype.Varinfo.Set.mem v local_statics) then
- check_abort "%t is supposed to be in scope in two blocks" prefix;
- self#remove_local_static v
-
- (* Stack of local variables that are supposed to be initialized in
- each currently opened block (with [bscoping=true]), the top of the
- stack corresponding to the innermost block. Used to check that these
- variables have a Local_init instruction in the appropriate block.
- *)
- val current_block_vars = Stack.create ()
-
- method! vblock b =
- let check_locals b =
- List.iter
- (fun v ->
- if v.vdefined then
- check_abort
- "Local variable %a is supposed to be defined, \
- but no initializer found in the block where it is in scope"
- Printer.pp_varinfo v)
- (Stack.pop current_block_vars);
- b
- in
- List.iter self#check_local_var b.blocals;
- List.iter self#check_local_static b.bstatics;
- if b.bscoping then begin
- Stack.push b.blocals current_block_vars;
- Cil.DoChildrenPost check_locals
- end else if b.blocals <> [] then
- (* non-scoping block mustn't declare locals *)
- check_abort
- "Block below is declaring local variables %a, but its attributes \
- indicates that it is not used as a scope boundary.@\n%a"
- (Pretty_utils.pp_list ~sep:", " Printer.pp_varinfo) b.blocals
- Printer.pp_block b
- else Cil.DoChildren
-
- method! vbehavior b =
- let vpred p =
- ignore Visitor.(visitFramacIdPredicate (self:>frama_c_visitor) p)
- in
- let vextend b =
- ignore Visitor.(visitFramacExtended (self:>frama_c_visitor) b)
- in
- List.iter vpred b.b_requires;
- List.iter vpred b.b_assumes;
- List.iter vextend b.b_extended;
- let old_labels = logic_labels in
- logic_labels <- Logic_const.post_label :: logic_labels;
- List.iter Extlib.(vpred $ snd) b.b_post_cond;
- ignore Visitor.(visitFramacAssigns (self:>frama_c_visitor) b.b_assigns);
- ignore
- Visitor.(visitFramacAllocation (self:>frama_c_visitor) b.b_allocation);
- logic_labels <- old_labels;
- Cil.SkipChildren
-
- method! vspec _ =
- let old_labels = logic_labels in
- logic_labels <-
- Logic_const.(
- init_label :: here_label :: pre_label :: old_label :: logic_labels);
- Cil.DoChildrenPost (fun s -> logic_labels <- old_labels; s)
-
- method! vcode_annot ca =
- if Hashtbl.mem known_code_annot_id ca.annot_id then begin
- check_abort "duplicated code annotation id: %d@\n%a@\nand@\n%a"
- ca.annot_id
- Printer.pp_code_annotation
- (Hashtbl.find known_code_annot_id ca.annot_id)
- Printer.pp_code_annotation ca
- end else Hashtbl.add known_code_annot_id ca.annot_id ca;
- let old_labels = logic_labels in
- let my_labels =
- Logic_const.([init_label; here_label; pre_label])
- in
- let my_labels =
- match ca.annot_content with
- | AExtended (_, is_loop, {ext_name}) ->
- (match Logic_env.extension_category ext_name, is_loop with
- | Some (Ext_code_annot (Ext_next_stmt | Ext_next_both)), false ->
- Logic_const.post_label :: my_labels
- | Some (Ext_code_annot Ext_here), false -> my_labels
- | Some (Ext_code_annot (Ext_next_loop | Ext_next_both)), true ->
- Logic_const.loop_current_label ::
- Logic_const.loop_entry_label :: my_labels
- | Some (Ext_code_annot (Ext_here | Ext_next_stmt)), true ->
- Kernel.(
- warning ~wkey:wkey_acsl_extension
- "%s is a code annotation extension, \
- but used as a loop annotation" ext_name);
- my_labels
- | Some (Ext_code_annot (Ext_next_loop)), false ->
- Kernel.(
- warning ~wkey:wkey_acsl_extension
- "%s is a loop annotation extension, \
- but used as a code annotation" ext_name;
- my_labels)
- | (Some (Ext_contract | Ext_global) | None), _ ->
- Kernel.(
- warning ~wkey:wkey_acsl_extension
- "%s is not a known code annotation extension" ext_name);
- my_labels)
- | AAssert _ | AStmtSpec _ | AInvariant _ | AVariant _
- | AAssigns _ | AAllocation _ | APragma _ -> my_labels
- in
- logic_labels <- my_labels @ logic_labels;
- (* on non-normalized code, we can't really check the scope of behavior
- names of statement contracts. *)
- if is_normalized then begin
- match ca.annot_content with
- | AAssert(bhvs,_,_) | AStmtSpec(bhvs,_) | AInvariant (bhvs,_,_)
- | AAssigns(bhvs,_) | AAllocation(bhvs,_) | AExtended (bhvs,_,_) ->
+ "%t is supposed to be static, but varinfo has automatic storage."
+ prefix;
+ if not (Cil.hasAttribute Cabs2cil.fc_local_static v.vattr) then
+ check_abort "%t is declared as a global static." prefix;
+ ignore (self#vvrbl v);
+ (* Ensure that the variable was not already claimed by another block. *)
+ if not (Cil_datatype.Varinfo.Set.mem v local_statics) then
+ check_abort "%t is supposed to be in scope in two blocks" prefix;
+ self#remove_local_static v
+
+ (* Stack of local variables that are supposed to be initialized in
+ each currently opened block (with [bscoping=true]), the top of the
+ stack corresponding to the innermost block. Used to check that these
+ variables have a Local_init instruction in the appropriate block.
+ *)
+ val current_block_vars = Stack.create ()
+
+ method! vblock b =
+ let check_locals b =
List.iter
- (fun b ->
- if not (self#mem_behavior_stack_name b) then
+ (fun v ->
+ if v.vdefined then
check_abort
- "code annotation %a is restricted to unknown behavior %s"
- Printer.pp_code_annotation ca b)
- bhvs
- | _ -> ()
- end;
- Cil.DoChildrenPost (fun ca -> logic_labels <- old_labels; ca)
-
- method! voffs = function
- | NoOffset -> Cil.SkipChildren
- | Index _ -> Cil.DoChildren
- | Field(fi,_) ->
- begin
- try
- if not (fi == Fieldinfo.Hashtbl.find known_fields fi)
- then
+ "Local variable %a is supposed to be defined, \
+ but no initializer found in the block where it is in scope"
+ Printer.pp_varinfo v)
+ (Stack.pop current_block_vars);
+ b
+ in
+ List.iter self#check_local_var b.blocals;
+ List.iter self#check_local_static b.bstatics;
+ if b.bscoping then begin
+ Stack.push b.blocals current_block_vars;
+ Cil.DoChildrenPost check_locals
+ end else if b.blocals <> [] then
+ (* non-scoping block mustn't declare locals *)
+ check_abort
+ "Block below is declaring local variables %a, but its attributes \
+ indicates that it is not used as a scope boundary.@\n%a"
+ (Pretty_utils.pp_list ~sep:", " Printer.pp_varinfo) b.blocals
+ Printer.pp_block b
+ else Cil.DoChildren
+
+ method! vbehavior b =
+ let vpred p =
+ ignore Visitor.(visitFramacIdPredicate (self:>frama_c_visitor) p)
+ in
+ let vextend b =
+ ignore Visitor.(visitFramacExtended (self:>frama_c_visitor) b)
+ in
+ List.iter vpred b.b_requires;
+ List.iter vpred b.b_assumes;
+ List.iter vextend b.b_extended;
+ let old_labels = logic_labels in
+ logic_labels <- Logic_const.post_label :: logic_labels;
+ List.iter Extlib.(vpred $ snd) b.b_post_cond;
+ ignore Visitor.(visitFramacAssigns (self:>frama_c_visitor) b.b_assigns);
+ ignore
+ Visitor.(visitFramacAllocation (self:>frama_c_visitor) b.b_allocation);
+ logic_labels <- old_labels;
+ Cil.SkipChildren
+
+ method! vspec _ =
+ let old_labels = logic_labels in
+ logic_labels <-
+ Logic_const.(
+ init_label :: here_label :: pre_label :: old_label :: logic_labels);
+ Cil.DoChildrenPost (fun s -> logic_labels <- old_labels; s)
+
+ method! vcode_annot ca =
+ if Hashtbl.mem known_code_annot_id ca.annot_id then begin
+ check_abort "duplicated code annotation id: %d@\n%a@\nand@\n%a"
+ ca.annot_id
+ Printer.pp_code_annotation
+ (Hashtbl.find known_code_annot_id ca.annot_id)
+ Printer.pp_code_annotation ca
+ end else Hashtbl.add known_code_annot_id ca.annot_id ca;
+ let old_labels = logic_labels in
+ let my_labels =
+ Logic_const.([init_label; here_label; pre_label])
+ in
+ let my_labels =
+ match ca.annot_content with
+ | AExtended (_, is_loop, {ext_name}) ->
+ (match Logic_env.extension_category ext_name, is_loop with
+ | Some (Ext_code_annot (Ext_next_stmt | Ext_next_both)), false ->
+ Logic_const.post_label :: my_labels
+ | Some (Ext_code_annot Ext_here), false -> my_labels
+ | Some (Ext_code_annot (Ext_next_loop | Ext_next_both)), true ->
+ Logic_const.loop_current_label ::
+ Logic_const.loop_entry_label :: my_labels
+ | Some (Ext_code_annot (Ext_here | Ext_next_stmt)), true ->
+ Kernel.(
+ warning ~wkey:wkey_acsl_extension
+ "%s is a code annotation extension, \
+ but used as a loop annotation" ext_name);
+ my_labels
+ | Some (Ext_code_annot (Ext_next_loop)), false ->
+ Kernel.(
+ warning ~wkey:wkey_acsl_extension
+ "%s is a loop annotation extension, \
+ but used as a code annotation" ext_name;
+ my_labels)
+ | (Some (Ext_contract | Ext_global) | None), _ ->
+ Kernel.(
+ warning ~wkey:wkey_acsl_extension
+ "%s is not a known code annotation extension" ext_name);
+ my_labels)
+ | AAssert _ | AStmtSpec _ | AInvariant _ | AVariant _
+ | AAssigns _ | AAllocation _ | APragma _ -> my_labels
+ in
+ logic_labels <- my_labels @ logic_labels;
+ (* on non-normalized code, we can't really check the scope of behavior
+ names of statement contracts. *)
+ if is_normalized then begin
+ match ca.annot_content with
+ | AAssert(bhvs,_,_) | AStmtSpec(bhvs,_) | AInvariant (bhvs,_,_)
+ | AAssigns(bhvs,_) | AAllocation(bhvs,_) | AExtended (bhvs,_,_) ->
+ List.iter
+ (fun b ->
+ if not (self#mem_behavior_stack_name b) then
+ check_abort
+ "code annotation %a is restricted to unknown behavior %s"
+ Printer.pp_code_annotation ca b)
+ bhvs
+ | _ -> ()
+ end;
+ Cil.DoChildrenPost (fun ca -> logic_labels <- old_labels; ca)
+
+ method! voffs = function
+ | NoOffset -> Cil.SkipChildren
+ | Index _ -> Cil.DoChildren
+ | Field(fi,_) ->
+ begin
+ try
+ if not (fi == Fieldinfo.Hashtbl.find known_fields fi)
+ then
+ (check_abort
+ "field %s of type %s(%d) is not \
+ shared between declaration and use"
+ fi.fname fi.fcomp.cname fi.fcomp.ckey)
+ with Not_found ->
+ (check_abort "field %s of type %s(%d) is unbound in the AST"
+ fi.fname fi.fcomp.cname fi.fcomp.ckey)
+ end;
+ Cil.DoChildren
+
+ method! vterm_offset = function
+ | TNoOffset -> Cil.SkipChildren
+ | TIndex _ -> Cil.DoChildren
+ | TModel(mi,_) ->
+ (try
+ let mi' = Logic_env.find_model_field mi.mi_name mi.mi_base_type in
+ if mi' != mi then begin
+ check_abort
+ "model field %s of type %a is not shared \
+ between declaration and use"
+ mi.mi_name Printer.pp_typ mi.mi_base_type
+ end
+ with Not_found ->
+ check_abort "unknown model field %s in type %a"
+ mi.mi_name Printer.pp_typ mi.mi_base_type);
+ Cil.DoChildren
+ | TField(fi,_) ->
+ begin
+ try
+ if not (fi == Fieldinfo.Hashtbl.find known_fields fi)
+ then
+ (check_abort "field %s of type %s is not \
+ shared between declaration and use"
+ fi.fname fi.fcomp.cname)
+ with Not_found ->
(check_abort
- "field %s of type %s(%d) is not \
- shared between declaration and use"
+ "field %s of type %s(%d) is unbound in the AST"
fi.fname fi.fcomp.cname fi.fcomp.ckey)
- with Not_found ->
- (check_abort "field %s of type %s(%d) is unbound in the AST"
- fi.fname fi.fcomp.cname fi.fcomp.ckey)
- end;
- Cil.DoChildren
+ end;
+ Cil.DoChildren
- method! vterm_offset = function
- | TNoOffset -> Cil.SkipChildren
- | TIndex _ -> Cil.DoChildren
- | TModel(mi,_) ->
- (try
- let mi' = Logic_env.find_model_field mi.mi_name mi.mi_base_type in
- if mi' != mi then begin
- check_abort
- "model field %s of type %a is not shared \
- between declaration and use"
- mi.mi_name Printer.pp_typ mi.mi_base_type
- end
- with Not_found ->
- check_abort "unknown model field %s in type %a"
- mi.mi_name Printer.pp_typ mi.mi_base_type);
- Cil.DoChildren
- | TField(fi,_) ->
- begin
+ method! vterm_lhost = function
+ | TResult t when is_normalized ->
+ (* if not normalized, contracts are visited while kf is not set *)
+ (match self#current_kf with
+ | None ->
+ check_abort "\\result found outside of a function contract"
+ | Some kf ->
+ let t1 = Kernel_function.get_return_type kf in
+ if Cil.isVoidType t1 then
+ check_abort
+ "\\result found in a contract for function %a that returns void"
+ Kernel_function.pretty kf;
+ if not (Cil_datatype.TypNoUnroll.equal t t1) then
+ check_abort
+ "\\result of type %a found in a contract for function %a that \
+ returns %a"
+ Cil_datatype.Typ.pretty t
+ Kernel_function.pretty kf
+ Cil_datatype.Typ.pretty t1
+ );
+ Cil.DoChildren
+ | _ -> Cil.DoChildren
+
+ method private check_ei: 'a. enumitem -> 'a Cil.visitAction =
+ fun ei ->
try
- if not (fi == Fieldinfo.Hashtbl.find known_fields fi)
- then
- (check_abort "field %s of type %s is not \
- shared between declaration and use"
- fi.fname fi.fcomp.cname)
+ let ei' = Enumitem.Hashtbl.find known_enumitems ei in
+ if ei != ei' then
+ check_abort "enumitem %s is not shared between declaration and use"
+ ei.einame;
+ Cil.DoChildren
with Not_found ->
- (check_abort
- "field %s of type %s(%d) is unbound in the AST"
- fi.fname fi.fcomp.cname fi.fcomp.ckey)
- end;
- Cil.DoChildren
-
- method! vterm_lhost = function
- | TResult t when is_normalized ->
- (* if not normalized, contracts are visited while kf is not set *)
- (match self#current_kf with
- | None ->
- check_abort "\\result found outside of a function contract"
- | Some kf ->
- let t1 = Kernel_function.get_return_type kf in
- if Cil.isVoidType t1 then
- check_abort
- "\\result found in a contract for function %a that returns void"
- Kernel_function.pretty kf;
- if not (Cil_datatype.TypNoUnroll.equal t t1) then
+ check_abort "enumitem %s is used but not declared"
+ ei.einame
+
+ (* can't use vlogic_label, as it also visits the declared labels in
+ Tapp and Papp. *)
+ method private check_logic_label lab =
+ match lab with
+ | StmtLabel _ -> ()
+ | FormalLabel _
+ | BuiltinLabel _ ->
+ let is_declared =
+ List.exists
+ (fun x -> Cil_datatype.Logic_label.equal x lab) logic_labels
+ in
+ if not is_declared then
+ check_abort "Logic label %a is not declared in this scope"
+ Printer.pp_logic_label lab
+
+ method private check_logic_app li labs args =
+ let expect = List.length li.l_profile in
+ let actual = List.length args in
+ let pred_or_func =
+ match li.l_type with
+ | None -> "Predicate"
+ | Some _ -> "Logic function"
+ in
+ if not (expect = actual) then
+ check_abort "%s %a expects %d arguments but is used with %d"
+ pred_or_func Printer.pp_logic_var li.l_var_info expect actual;
+ List.iter2
+ (fun lv arg ->
+ if not
+ (Logic_utils.is_instance_of
+ li.l_tparams arg.term_type lv.lv_type)
+ then
+ check_abort
+ "term %a has type %a, but is used as a parameter of type %a"
+ Printer.pp_term arg Printer.pp_logic_type arg.term_type
+ Printer.pp_logic_type lv.lv_type)
+ li.l_profile args;
+ let lab_declared = List.length li.l_labels in
+ let lab_provided = List.length labs in
+ if not (lab_declared = lab_provided) then
+ check_abort "%s %a expects %d logic labels, but is used with %d"
+ pred_or_func Printer.pp_logic_var li.l_var_info
+ lab_declared lab_provided;
+ List.iter
+ (fun lab -> self#check_logic_label lab) labs
+
+ method! vterm t =
+ match t.term_node with
+ | TLval lv ->
+ (match lv with
+ | TVar lvi, TNoOffset ->
+ if lvi.lv_kind = LVGlobal && not (Logic_const.is_exit_status t)
+ then begin
+ try
+ let li = Logic_env.find_logic_cons lvi in
+ (match li.l_type with
+ | None ->
+ check_abort "Trying to use predicate %a as a term"
+ Printer.pp_logic_var lvi
+ | Some typ ->
+ if
+ not
+ (Logic_utils.is_instance_of li.l_tparams t.term_type typ)
+ then
+ check_abort
+ "%a is declared with type %a. It cannot be used as \
+ a term of type %a"
+ Printer.pp_logic_var lvi
+ Printer.pp_logic_type typ
+ Printer.pp_logic_type t.term_type)
+ with Not_found ->
+ check_abort
+ "%a is supposed to be a global logic constant, \
+ but cannot be found in the logic environment."
+ Printer.pp_logic_var lvi
+ end
+ | _ -> ());
+ begin match t.term_type with
+ | Ctype ty ->
+ if (Cil.isVoidType ty) then
+ check_abort "logic term with void type: %a" Printer.pp_term t;
+ Cil.DoChildren
+ | _ -> Cil.DoChildren
+ end
+ | TConst (LEnum ei) -> self#check_ei ei
+ | Tif (_,t1,t2) ->
+ if not (Cil_datatype.Logic_type.equal t1.term_type t2.term_type) then
+ check_abort
+ "Conditional operator %a@\nFirst branch has type %a@\n\
+ Second branch has type %a"
+ Printer.pp_term t
+ Printer.pp_logic_type t1.term_type
+ Printer.pp_logic_type t2.term_type;
+ Cil.DoChildren
+ | Tlet(li,_) ->
+ if li.l_var_info.lv_kind <> LVLocal then
+ check_abort
+ "Local logic variable %a is flagged with wrong origin"
+ Printer.pp_logic_var li.l_var_info;
+ Cil.DoChildren
+ | Tlambda _ ->
+ Stack.push LVFormal quant_orig;
+ Cil.DoChildrenPost (fun t -> ignore (Stack.pop quant_orig); t)
+ | Tcomprehension _ ->
+ Stack.push LVQuant quant_orig;
+ Cil.DoChildrenPost (fun t -> ignore (Stack.pop quant_orig); t)
+ | Tapp(li,labs,args) ->
+ (match li.l_type with
+ | Some ty when
+ Logic_utils.is_instance_of li.l_tparams t.term_type ty -> ()
+ | Some ty ->
check_abort
- "\\result of type %a found in a contract for function %a that \
- returns %a"
- Cil_datatype.Typ.pretty t
- Kernel_function.pretty kf
- Cil_datatype.Typ.pretty t1
- );
+ "logic function %a has return type %a, \
+ but application %a has type %a"
+ Printer.pp_logic_var li.l_var_info
+ Printer.pp_logic_type ty
+ Printer.pp_term t
+ Printer.pp_logic_type t.term_type
+ | None ->
+ check_abort "predicate %a is used as a logic function"
+ Printer.pp_logic_var li.l_var_info);
+ self#check_logic_app li labs args;
+ Cil.DoChildren
+ | Tat(_,l) | Tbase_addr(l,_) | Toffset(l,_) | Tblock_length(l,_) ->
+ self#check_logic_label l; Cil.DoChildren
+ | TBinOp (bop, lterm, _) ->
+ begin
+ match bop, Logic_utils.isLogicPointerType lterm.term_type with
+ | (PlusA | MinusA), true ->
+ check_abort "PlusA/MinusA operator with pointer argument @[(%a)@]"
+ Printer.pp_logic_type lterm.term_type
+ | (PlusPI | MinusPI), false ->
+ check_abort "PlusPI/MinusPI with non-pointer argument @[(%a)@]"
+ Printer.pp_logic_type lterm.term_type
+ | _ -> Cil.DoChildren
+ end
+ | _ -> Cil.DoChildren
+
+ method! vinitoffs = self#voffs
+
+ method! vcompinfo c =
+ Kernel.debug
+ ~dkey:Kernel.dkey_check "Checking composite type %s(%d)" c.cname c.ckey;
+ Compinfo.Hashtbl.add known_compinfos c c;
+ Kernel.debug
+ ~dkey:Kernel.dkey_check "Adding fields for type %s(%d)" c.cname c.ckey;
+ List.iter (fun x -> Fieldinfo.Hashtbl.add known_fields x x) c.cfields;
Cil.DoChildren
- | _ -> Cil.DoChildren
- method private check_ei: 'a. enumitem -> 'a Cil.visitAction =
- fun ei ->
+ method! vfieldinfo f =
+ Kernel.debug ~dkey:Kernel.dkey_check
+ "Check field %s of type %s" f.fname f.fcomp.cname;
try
- let ei' = Enumitem.Hashtbl.find known_enumitems ei in
- if ei != ei' then
- check_abort "enumitem %s is not shared between declaration and use"
- ei.einame;
+ let c = Compinfo.Hashtbl.find known_compinfos f.fcomp in
+ if f.fcomp != c then
+ check_abort
+ "field %s of type %s does not refer to the appropriate compinfo node"
+ f.fname f.fcomp.cname;
Cil.DoChildren
with Not_found ->
- check_abort "enumitem %s is used but not declared"
- ei.einame
+ check_abort
+ "field %s belongs to an unknown type %s" f.fname f.fcomp.cname
+
+ (* In non-normalized mode, we can't rely on the Globals tables used by
+ the normal Frama-C's vglob: jump directly to vglob_aux. *)
+ method! vglob g = if is_normalized then plain#vglob g else self#vglob_aux g
+
+ method! vglob_aux g =
+ match g with
+ | GFunDecl(_,v,_) ->
+ self#remove_globals_function v;
+ if not (Cil.isFunctionType v.vtype) then
+ check_abort "Function %a has non-function type" Printer.pp_varinfo v;
+ if is_normalized then begin
+ if v.vdefined &&
+ not (Kernel_function.is_definition (Globals.Functions.get v))
+ then
+ check_abort
+ "Function %s(%d) is supposed to be defined, \
+ but not registered as such"
+ v.vname v.vid;
+ if not v.vdefined &&
+ Kernel_function.is_definition (Globals.Functions.get v)
+ then
+ check_abort
+ "Function %s has a registered definition, \
+ but is supposed to be only declared"
+ v.vname
+ end;
+ (match Cil.splitFunctionType v.vtype with
+ | (_,None,_,_) -> ()
+ | (_,Some l,_,_) ->
+ if is_normalized then begin
+ try
+ let l' = Cil.getFormalsDecl v in
+ if List.length l <> List.length l' then
+ check_abort
+ "prototype %s has %d arguments but is associated to \
+ %d formals in FormalsDecl"
+ v.vname (List.length l) (List.length l')
+ else
+ let kf = Globals.Functions.get v in
+ let l'' = Kernel_function.get_formals kf in
+ if List.length l' <> List.length l'' then
+ check_abort
+ "mismatch between FormalsDecl and Globals.Functions \
+ on prototype %s." v.vname;
+ if Kernel_function.is_definition kf then begin
+ List.iter2
+ (fun v1 v2 ->
+ if v1 != v2 then
+ check_abort
+ "formal parameters of %s are not shared \
+ between declaration and definition"
+ v.vname)
+ l' l''
+ end
+ with Not_found ->
+ check_abort
+ "prototype %s (%d) has no associated \
+ parameters in FormalsDecl"
+ v.vname v.vid
+ end);
+ Cil.DoChildren
+ | GVarDecl(v,_) | GVar(v,_,_) ->
+ if Cil.isFunctionType v.vtype then
+ check_abort "Variable %a has function type" Printer.pp_varinfo v;
+ self#remove_globals_var v;
+ if (Cil.hasAttribute Cabs2cil.fc_local_static v.vattr) then
+ self#add_local_static v;
+ Cil.DoChildren
+ | GFun (f,_) ->
+ if not (Cil.isFunctionType f.svar.vtype) then
+ check_abort "Function %a has non-function type"
+ Printer.pp_varinfo f.svar;
+ if not f.svar.vdefined then
+ check_abort
+ "Function %s has a definition, but is considered as not defined"
+ f.svar.vname;
+ self#remove_globals_function f.svar;
+ if is_normalized then begin
+ try
+ let kf = Globals.Functions.get f.svar in
+ if not (Kernel_function.is_definition kf) then
+ check_abort
+ "Function %s has a definition in the AST, but is not defined \
+ according to Globals.Functions"
+ f.svar.vname;
+ let f' = Kernel_function.get_definition kf in
+ if f != f' then
+ check_abort
+ "Definition of function %s is not shared \
+ between AST and Globals.Functions"
+ f.svar.vname;
+ with Not_found ->
+ check_abort
+ "Function %s is present in the AST but not in Globals.Functions"
+ f.svar.vname
+ end;
+ Cil.DoChildren
+ | _ -> Cil.DoChildren
- (* can't use vlogic_label, as it also visits the declared labels in
- Tapp and Papp. *)
- method private check_logic_label lab =
- match lab with
- | StmtLabel _ -> ()
- | FormalLabel _
- | BuiltinLabel _ ->
- let is_declared =
- List.exists
- (fun x -> Cil_datatype.Logic_label.equal x lab) logic_labels
+ method! vfile _ =
+ let print_var_vid fmt vi =
+ Format.fprintf fmt "%a(%d)" Printer.pp_varinfo vi vi.vid
in
- if not is_declared then
- check_abort "Logic label %a is not declared in this scope"
- Printer.pp_logic_label lab
-
- method private check_logic_app li labs args =
- let expect = List.length li.l_profile in
- let actual = List.length args in
- let pred_or_func =
- match li.l_type with
- | None -> "Predicate"
- | Some _ -> "Logic function"
- in
- if not (expect = actual) then
- check_abort "%s %a expects %d arguments but is used with %d"
- pred_or_func Printer.pp_logic_var li.l_var_info expect actual;
- List.iter2
- (fun lv arg ->
- if not
- (Logic_utils.is_instance_of
- li.l_tparams arg.term_type lv.lv_type)
- then
- check_abort
- "term %a has type %a, but is used as a parameter of type %a"
- Printer.pp_term arg Printer.pp_logic_type arg.term_type
- Printer.pp_logic_type lv.lv_type)
- li.l_profile args;
- let lab_declared = List.length li.l_labels in
- let lab_provided = List.length labs in
- if not (lab_declared = lab_provided) then
- check_abort "%s %a expects %d logic labels, but is used with %d"
- pred_or_func Printer.pp_logic_var li.l_var_info
- lab_declared lab_provided;
- List.iter
- (fun lab -> self#check_logic_label lab) labs
-
- method! vterm t =
- match t.term_node with
- | TLval lv ->
- (match lv with
- | TVar lvi, TNoOffset ->
- if lvi.lv_kind = LVGlobal && not (Logic_const.is_exit_status t)
- then begin
- try
- let li = Logic_env.find_logic_cons lvi in
- (match li.l_type with
- | None ->
- check_abort "Trying to use predicate %a as a term"
- Printer.pp_logic_var lvi
- | Some typ ->
- if
- not
- (Logic_utils.is_instance_of li.l_tparams t.term_type typ)
- then
- check_abort
- "%a is declared with type %a. It cannot be used as \
- a term of type %a"
- Printer.pp_logic_var lvi
- Printer.pp_logic_type typ
- Printer.pp_logic_type t.term_type)
- with Not_found ->
- check_abort
- "%a is supposed to be a global logic constant, \
- but cannot be found in the logic environment."
- Printer.pp_logic_var lvi
- end
- | _ -> ());
- begin match t.term_type with
- | Ctype ty ->
- if (Cil.isVoidType ty) then
- check_abort "logic term with void type: %a" Printer.pp_term t;
- Cil.DoChildren
- | _ -> Cil.DoChildren
- end
- | TConst (LEnum ei) -> self#check_ei ei
- | Tif (_,t1,t2) ->
- if not (Cil_datatype.Logic_type.equal t1.term_type t2.term_type) then
- check_abort
- "Conditional operator %a@\nFirst branch has type %a@\n\
- Second branch has type %a"
- Printer.pp_term t
- Printer.pp_logic_type t1.term_type
- Printer.pp_logic_type t2.term_type;
- Cil.DoChildren
- | Tlet(li,_) ->
- if li.l_var_info.lv_kind <> LVLocal then
- check_abort
- "Local logic variable %a is flagged with wrong origin"
- Printer.pp_logic_var li.l_var_info;
- Cil.DoChildren
- | Tlambda _ ->
- Stack.push LVFormal quant_orig;
- Cil.DoChildrenPost (fun t -> ignore (Stack.pop quant_orig); t)
- | Tcomprehension _ ->
- Stack.push LVQuant quant_orig;
- Cil.DoChildrenPost (fun t -> ignore (Stack.pop quant_orig); t)
- | Tapp(li,labs,args) ->
- (match li.l_type with
- | Some ty when
- Logic_utils.is_instance_of li.l_tparams t.term_type ty -> ()
- | Some ty ->
- check_abort
- "logic function %a has return type %a, \
- but application %a has type %a"
- Printer.pp_logic_var li.l_var_info
- Printer.pp_logic_type ty
- Printer.pp_term t
- Printer.pp_logic_type t.term_type
- | None ->
- check_abort "predicate %a is used as a logic function"
- Printer.pp_logic_var li.l_var_info);
- self#check_logic_app li labs args;
- Cil.DoChildren
- | Tat(_,l) | Tbase_addr(l,_) | Toffset(l,_) | Tblock_length(l,_) ->
- self#check_logic_label l; Cil.DoChildren
- | TBinOp (bop, lterm, _) ->
- begin
- match bop, Logic_utils.isLogicPointerType lterm.term_type with
- | (PlusA | MinusA), true ->
- check_abort "PlusA/MinusA operator with pointer argument @[(%a)@]"
- Printer.pp_logic_type lterm.term_type
- | (PlusPI | MinusPI), false ->
- check_abort "PlusPI/MinusPI with non-pointer argument @[(%a)@]"
- Printer.pp_logic_type lterm.term_type
- | _ -> Cil.DoChildren
- end
- | _ -> Cil.DoChildren
-
- method! vinitoffs = self#voffs
-
- method! vcompinfo c =
- Kernel.debug
- ~dkey:Kernel.dkey_check "Checking composite type %s(%d)" c.cname c.ckey;
- Compinfo.Hashtbl.add known_compinfos c c;
- Kernel.debug
- ~dkey:Kernel.dkey_check "Adding fields for type %s(%d)" c.cname c.ckey;
- List.iter (fun x -> Fieldinfo.Hashtbl.add known_fields x x) c.cfields;
- Cil.DoChildren
-
- method! vfieldinfo f =
- Kernel.debug ~dkey:Kernel.dkey_check
- "Check field %s of type %s" f.fname f.fcomp.cname;
- try
- let c = Compinfo.Hashtbl.find known_compinfos f.fcomp in
- if f.fcomp != c then
- check_abort
- "field %s of type %s does not refer to the appropriate compinfo node"
- f.fname f.fcomp.cname;
- Cil.DoChildren
- with Not_found ->
- check_abort
- "field %s belongs to an unknown type %s" f.fname f.fcomp.cname
-
- (* In non-normalized mode, we can't rely on the Globals tables used by
- the normal Frama-C's vglob: jump directly to vglob_aux. *)
- method! vglob g = if is_normalized then plain#vglob g else self#vglob_aux g
-
- method! vglob_aux g =
- match g with
- | GFunDecl(_,v,_) ->
- self#remove_globals_function v;
- if not (Cil.isFunctionType v.vtype) then
- check_abort "Function %a has non-function type" Printer.pp_varinfo v;
- if is_normalized then begin
- if v.vdefined &&
- not (Kernel_function.is_definition (Globals.Functions.get v))
- then
+ let check_end f =
+ if not (Cil_datatype.Varinfo.Set.is_empty globals_functions)
+ || not (Cil_datatype.Varinfo.Set.is_empty globals_vars)
+ then begin
check_abort
- "Function %s(%d) is supposed to be defined, \
- but not registered as such"
- v.vname v.vid;
- if not v.vdefined &&
- Kernel_function.is_definition (Globals.Functions.get v)
+ "Following functions and variables are present \
+ in global tables but not in AST:%a%a"
+ (Pretty_utils.pp_list
+ ~pre:"@\nFunctions:@\n" ~sep:"@ " print_var_vid)
+ (Cil_datatype.Varinfo.Set.elements globals_functions)
+ (Pretty_utils.pp_list
+ ~pre:"@\nVariables:@\n" ~sep:"@ " print_var_vid)
+ (Cil_datatype.Varinfo.Set.elements globals_vars)
+ end;
+ if not (Cil_datatype.Varinfo.Set.is_empty local_statics) then begin
+ check_abort
+ "Following variables are supposed to be local static variables, \
+ but haven't been found in any block:@\n%a"
+ (Pretty_utils.pp_list ~sep:"@ " print_var_vid)
+ (Cil_datatype.Varinfo.Set.elements local_statics)
+ end;
+ f
+ in
+ Cil.DoChildrenPost check_end
+
+ method! vannotation a =
+ match a with
+ | Dfun_or_pred (li,_) | Dinvariant (li,_) | Dtype_annot (li,_) ->
+ if
+ not
+ (List.memq li
+ (Logic_env.find_all_logic_functions li.l_var_info.lv_name))
then
check_abort
- "Function %s has a registered definition, \
- but is supposed to be only declared"
- v.vname
- end;
- (match Cil.splitFunctionType v.vtype with
- | (_,None,_,_) -> ()
- | (_,Some l,_,_) ->
- if is_normalized then begin
- try
- let l' = Cil.getFormalsDecl v in
- if List.length l <> List.length l' then
- check_abort
- "prototype %s has %d arguments but is associated to \
- %d formals in FormalsDecl"
- v.vname (List.length l) (List.length l')
- else
- let kf = Globals.Functions.get v in
- let l'' = Kernel_function.get_formals kf in
- if List.length l' <> List.length l'' then
- check_abort
- "mismatch between FormalsDecl and Globals.Functions \
- on prototype %s." v.vname;
- if Kernel_function.is_definition kf then begin
- List.iter2
- (fun v1 v2 ->
- if v1 != v2 then
- check_abort
- "formal parameters of %s are not shared \
- between declaration and definition"
- v.vname)
- l' l''
- end
- with Not_found ->
- check_abort
- "prototype %s (%d) has no associated \
- parameters in FormalsDecl"
- v.vname v.vid
- end);
- Cil.DoChildren
- | GVarDecl(v,_) | GVar(v,_,_) ->
- if Cil.isFunctionType v.vtype then
- check_abort "Variable %a has function type" Printer.pp_varinfo v;
- self#remove_globals_var v;
- if (Cil.hasAttribute Cabs2cil.fc_local_static v.vattr) then
- self#add_local_static v;
- Cil.DoChildren
- | GFun (f,_) ->
- if not (Cil.isFunctionType f.svar.vtype) then
- check_abort "Function %a has non-function type"
- Printer.pp_varinfo f.svar;
- if not f.svar.vdefined then
- check_abort
- "Function %s has a definition, but is considered as not defined"
- f.svar.vname;
- self#remove_globals_function f.svar;
- if is_normalized then begin
- try
- let kf = Globals.Functions.get f.svar in
- if not (Kernel_function.is_definition kf) then
- check_abort
- "Function %s has a definition in the AST, but is not defined \
- according to Globals.Functions"
- f.svar.vname;
- let f' = Kernel_function.get_definition kf in
- if f != f' then
- check_abort
- "Definition of function %s is not shared \
- between AST and Globals.Functions"
- f.svar.vname;
- with Not_found ->
+ "Global logic function %a information is not in the environment"
+ Printer.pp_logic_var li.l_var_info;
+ if li.l_var_info.lv_kind <> LVGlobal then
check_abort
- "Function %s is present in the AST but not in Globals.Functions"
- f.svar.vname
- end;
- Cil.DoChildren
- | _ -> Cil.DoChildren
-
- method! vfile _ =
- let print_var_vid fmt vi =
- Format.fprintf fmt "%a(%d)" Printer.pp_varinfo vi vi.vid
- in
- let check_end f =
- if not (Cil_datatype.Varinfo.Set.is_empty globals_functions)
- || not (Cil_datatype.Varinfo.Set.is_empty globals_vars)
- then begin
- check_abort
- "Following functions and variables are present \
- in global tables but not in AST:%a%a"
- (Pretty_utils.pp_list
- ~pre:"@\nFunctions:@\n" ~sep:"@ " print_var_vid)
- (Cil_datatype.Varinfo.Set.elements globals_functions)
- (Pretty_utils.pp_list
- ~pre:"@\nVariables:@\n" ~sep:"@ " print_var_vid)
- (Cil_datatype.Varinfo.Set.elements globals_vars)
- end;
- if not (Cil_datatype.Varinfo.Set.is_empty local_statics) then begin
- check_abort
- "Following variables are supposed to be local static variables, \
- but haven't been found in any block:@\n%a"
- (Pretty_utils.pp_list ~sep:"@ " print_var_vid)
- (Cil_datatype.Varinfo.Set.elements local_statics)
- end;
- f
- in
- Cil.DoChildrenPost check_end
-
- method! vannotation a =
- match a with
- | Dfun_or_pred (li,_) | Dinvariant (li,_) | Dtype_annot (li,_) ->
- if
- not
- (List.memq li
- (Logic_env.find_all_logic_functions li.l_var_info.lv_name))
- then
- check_abort
- "Global logic function %a information is not in the environment"
- Printer.pp_logic_var li.l_var_info;
- if li.l_var_info.lv_kind <> LVGlobal then
- check_abort
- "Global logic function %a is flagged with a wrong origin"
- Printer.pp_logic_var li.l_var_info;
- (match li.l_type, li.l_profile with
- | Some ty, [] ->
- if not (Cil_datatype.Logic_type.equal ty li.l_var_info.lv_type) then
- check_abort
- "Logic constant %a is declared with type %a, but \
- its logic_var has type %a"
- Printer.pp_logic_var li.l_var_info
- Printer.pp_logic_type ty
- Printer.pp_logic_type li.l_var_info.lv_type
- | None, _ | Some _, _::_ -> ());
- Cil.DoChildren
- | Dmodel_annot (mi, _) ->
- (try
- let mi' = Logic_env.find_model_field mi.mi_name mi.mi_base_type in
- if mi != mi' then
+ "Global logic function %a is flagged with a wrong origin"
+ Printer.pp_logic_var li.l_var_info;
+ (match li.l_type, li.l_profile with
+ | Some ty, [] ->
+ if not (Cil_datatype.Logic_type.equal ty li.l_var_info.lv_type) then
+ check_abort
+ "Logic constant %a is declared with type %a, but \
+ its logic_var has type %a"
+ Printer.pp_logic_var li.l_var_info
+ Printer.pp_logic_type ty
+ Printer.pp_logic_type li.l_var_info.lv_type
+ | None, _ | Some _, _::_ -> ());
+ Cil.DoChildren
+ | Dmodel_annot (mi, _) ->
+ (try
+ let mi' = Logic_env.find_model_field mi.mi_name mi.mi_base_type in
+ if mi != mi' then
+ check_abort
+ "field %s of type %a is not shared between \
+ declaration and environment"
+ mi.mi_name Printer.pp_typ mi.mi_base_type;
+ with Not_found ->
check_abort
- "field %s of type %a is not shared between \
- declaration and environment"
- mi.mi_name Printer.pp_typ mi.mi_base_type;
- with Not_found ->
- check_abort
- "field %s of type %a is not present in environment"
- mi.mi_name Printer.pp_typ mi.mi_base_type);
- Cil.DoChildren
- | Dlemma(_,_,labels,_,_,_,_) ->
- let old_labels = logic_labels in
- logic_labels <- labels @ logic_labels;
- Cil.DoChildrenPost (fun g -> logic_labels <- old_labels; g)
- | Dtype (t,_) ->
- let t' =
- try Logic_env.find_logic_type t.lt_name
- with Not_found ->
- check_abort "logic type %s is not present in the environment"
- t.lt_name
- in
- if t != t' then
- check_abort
- "Definition of logic type %s is not shared between \
- AST and environment" t.lt_name;
- let treat_cons c =
- let c' =
- try Logic_env.find_logic_ctor c.ctor_name
+ "field %s of type %a is not present in environment"
+ mi.mi_name Printer.pp_typ mi.mi_base_type);
+ Cil.DoChildren
+ | Dlemma(_,_,labels,_,_,_,_) ->
+ let old_labels = logic_labels in
+ logic_labels <- labels @ logic_labels;
+ Cil.DoChildrenPost (fun g -> logic_labels <- old_labels; g)
+ | Dtype (t,_) ->
+ let t' =
+ try Logic_env.find_logic_type t.lt_name
with Not_found ->
+ check_abort "logic type %s is not present in the environment"
+ t.lt_name
+ in
+ if t != t' then
+ check_abort
+ "Definition of logic type %s is not shared between \
+ AST and environment" t.lt_name;
+ let treat_cons c =
+ let c' =
+ try Logic_env.find_logic_ctor c.ctor_name
+ with Not_found ->
+ check_abort
+ "logic constructor %s is not present in the environment"
+ c.ctor_name
+ in
+ if c != c' then
check_abort
- "logic constructor %s is not present in the environment"
+ "Definition of logic constructor %s is not shared between \
+ AST and environment"
c.ctor_name
in
- if c != c' then
+ (match t.lt_def with
+ | Some (LTsum l) -> List.iter treat_cons l
+ | Some (LTsyn _) -> ()
+ | None -> ());
+ Cil.DoChildren
+ | _ -> Cil.DoChildren
+
+ method! vlogic_label = function
+ | StmtLabel l -> self#check_label l; Cil.SkipChildren
+ | _ -> Cil.DoChildren
+
+ method! vpredicate_node = function
+ | Papp(li,labs,args) ->
+ (match li.l_type with
+ | None -> ()
+ | Some _ ->
+ check_abort "Logic function %a is used as a predicate"
+ Printer.pp_logic_var li.l_var_info);
+ self#check_logic_app li labs args;
+ Cil.DoChildren
+ | Plet(li,_) ->
+ if li.l_var_info.lv_kind <> LVLocal then
check_abort
- "Definition of logic constructor %s is not shared between \
- AST and environment"
- c.ctor_name
+ "Local logic variable %a is flagged with wrong origin"
+ Printer.pp_logic_var li.l_var_info;
+ Cil.DoChildren
+ | Pforall _ | Pexists _ ->
+ Stack.push LVQuant quant_orig;
+ Cil.DoChildrenPost (fun p -> ignore (Stack.pop quant_orig); p)
+ | Pat(_,l) | Pvalid_read(l,_) | Pvalid(l,_) | Pinitialized(l,_)
+ | Pdangling(l,_) | Pallocable(l,_) | Pfreeable(l,_) ->
+ self#check_logic_label l; Cil.DoChildren
+ | Pfresh(l1,l2,_,_) ->
+ self#check_logic_label l1; self#check_logic_label l2; Cil.DoChildren
+ | _ -> Cil.DoChildren
+
+ method private vinductive_case (_,labels,_,p) =
+ let old_labels = logic_labels in
+ logic_labels <- labels @ logic_labels;
+ ignore
+ (Visitor.visitFramacPredicate (self:>Visitor.frama_c_visitor) p);
+ logic_labels <- old_labels
+
+ method! vlogic_info_decl li =
+ Logic_var.Hashtbl.add known_logic_info li.l_var_info li;
+ List.iter
+ (fun lv ->
+ if lv.lv_kind <> LVFormal then
+ check_abort
+ "Formal parameter %a of logic function/predicate %a is \
+ flagged with wrong origin"
+ Printer.pp_logic_var lv Printer.pp_logic_var li.l_var_info)
+ li.l_profile;
+ match li.l_body with
+ | LBinductive l ->
+ List.iter self#vinductive_case l; Cil.SkipChildren
+ | _ ->
+ let old_labels = logic_labels in
+ logic_labels <- li.l_labels @ logic_labels;
+ Cil.DoChildrenPost (fun li -> logic_labels <- old_labels; li)
+
+ method! vlogic_info_use li =
+ let unknown () =
+ check_abort "logic function %s has no information" li.l_var_info.lv_name
in
- (match t.lt_def with
- | Some (LTsum l) -> List.iter treat_cons l
- | Some (LTsyn _) -> ()
- | None -> ());
- Cil.DoChildren
- | _ -> Cil.DoChildren
-
- method! vlogic_label = function
- | StmtLabel l -> self#check_label l; Cil.SkipChildren
- | _ -> Cil.DoChildren
-
- method! vpredicate_node = function
- | Papp(li,labs,args) ->
- (match li.l_type with
- | None -> ()
- | Some _ ->
- check_abort "Logic function %a is used as a predicate"
- Printer.pp_logic_var li.l_var_info);
- self#check_logic_app li labs args;
- Cil.DoChildren
- | Plet(li,_) ->
- if li.l_var_info.lv_kind <> LVLocal then
+ let not_shared () =
check_abort
- "Local logic variable %a is flagged with wrong origin"
- Printer.pp_logic_var li.l_var_info;
+ "logic function %s information is not shared between declaration and \
+ use"
+ li.l_var_info.lv_name
+ in
+ if Logic_env.is_builtin_logic_function li.l_var_info.lv_name then
+ begin
+ if not
+ (List.memq li
+ (Logic_env.find_all_logic_functions li.l_var_info.lv_name))
+ then
+ check_abort "Built-in logic function %s information is not shared \
+ between environment and use"
+ li.l_var_info.lv_name
+ end else begin
+ try
+ if not
+ (li == Logic_var.Hashtbl.find known_logic_info li.l_var_info)
+ then not_shared ()
+ with Not_found -> unknown ()
+ end;
Cil.DoChildren
- | Pforall _ | Pexists _ ->
- Stack.push LVQuant quant_orig;
- Cil.DoChildrenPost (fun p -> ignore (Stack.pop quant_orig); p)
- | Pat(_,l) | Pvalid_read(l,_) | Pvalid(l,_) | Pinitialized(l,_)
- | Pdangling(l,_) | Pallocable(l,_) | Pfreeable(l,_) ->
- self#check_logic_label l; Cil.DoChildren
- | Pfresh(l1,l2,_,_) ->
- self#check_logic_label l1; self#check_logic_label l2; Cil.DoChildren
- | _ -> Cil.DoChildren
-
- method private vinductive_case (_,labels,_,p) =
- let old_labels = logic_labels in
- logic_labels <- labels @ logic_labels;
- ignore
- (Visitor.visitFramacPredicate (self:>Visitor.frama_c_visitor) p);
- logic_labels <- old_labels
-
- method! vlogic_info_decl li =
- Logic_var.Hashtbl.add known_logic_info li.l_var_info li;
- List.iter
- (fun lv ->
- if lv.lv_kind <> LVFormal then
- check_abort
- "Formal parameter %a of logic function/predicate %a is \
- flagged with wrong origin"
- Printer.pp_logic_var lv Printer.pp_logic_var li.l_var_info)
- li.l_profile;
- match li.l_body with
- | LBinductive l ->
- List.iter self#vinductive_case l; Cil.SkipChildren
- | _ ->
- let old_labels = logic_labels in
- logic_labels <- li.l_labels @ logic_labels;
- Cil.DoChildrenPost (fun li -> logic_labels <- old_labels; li)
-
- method! vlogic_info_use li =
- let unknown () =
- check_abort "logic function %s has no information" li.l_var_info.lv_name
- in
- let not_shared () =
- check_abort
- "logic function %s information is not shared between declaration and \
- use"
- li.l_var_info.lv_name
- in
- if Logic_env.is_builtin_logic_function li.l_var_info.lv_name then
- begin
- if not
- (List.memq li
- (Logic_env.find_all_logic_functions li.l_var_info.lv_name))
- then
- check_abort "Built-in logic function %s information is not shared \
- between environment and use"
- li.l_var_info.lv_name
- end else begin
- try
- if not
- (li == Logic_var.Hashtbl.find known_logic_info li.l_var_info)
- then not_shared ()
- with Not_found -> unknown ()
- end;
- Cil.DoChildren
-
- val accept_array = Stack.create ()
-
- method private accept_array = function
- | SizeOfE _ | AlignOfE _ | CastE _ -> true
- | _ -> false
-
- method! vexpr e =
- if Cil.typeHasAttribute "volatile" (Cil.typeOf e) then begin
- Kernel.warning ~wkey:Kernel.wkey_check_volatile ~current:true
- "Expression with volatile qualification %a" Printer.pp_exp e
- end;
- match e.enode with
- | Const (CEnum ei) -> self#check_ei ei
- | Lval lv when
- Cil.isArrayType (Cil.typeOfLval lv)
- && (Stack.is_empty accept_array || not (Stack.top accept_array)) ->
- check_abort "%a is an array, but used as an lval"
- Printer.pp_lval lv
- | StartOf lv when not (Cil.isArrayType (Cil.typeOfLval lv)) ->
- check_abort "%a is supposed to be an array, but has type %a"
- Printer.pp_lval lv Printer.pp_typ (Cil.typeOfLval lv)
- | _ ->
- Stack.push (self#accept_array e.enode) accept_array;
- Cil.ChangeDoChildrenPost (e,
- fun e -> ignore (Stack.pop accept_array); e)
-
-
- method private check_initialized_var v =
- let block_vars = Stack.pop current_block_vars in
- match List.partition (Cil_datatype.Varinfo.equal v) block_vars with
- | [_], block_vars ->
- Stack.push block_vars current_block_vars;
- Cil_datatype.Varinfo.Hashtbl.add known_vars v v
- | [], _ ->
- if Cil_datatype.Varinfo.Hashtbl.mem known_vars v then
- check_abort "Local variable %a is initialized twice"
- Printer.pp_varinfo v
- else
+
+ val accept_array = Stack.create ()
+
+ method private accept_array = function
+ | SizeOfE _ | AlignOfE _ | CastE _ -> true
+ | _ -> false
+
+ method! vexpr e =
+ if Cil.typeHasAttribute "volatile" (Cil.typeOf e) then begin
+ Kernel.warning ~wkey:Kernel.wkey_check_volatile ~current:true
+ "Expression with volatile qualification %a" Printer.pp_exp e
+ end;
+ match e.enode with
+ | Const (CEnum ei) -> self#check_ei ei
+ | Lval lv when
+ Cil.isArrayType (Cil.typeOfLval lv)
+ && (Stack.is_empty accept_array || not (Stack.top accept_array)) ->
+ check_abort "%a is an array, but used as an lval"
+ Printer.pp_lval lv
+ | StartOf lv when not (Cil.isArrayType (Cil.typeOfLval lv)) ->
+ check_abort "%a is supposed to be an array, but has type %a"
+ Printer.pp_lval lv Printer.pp_typ (Cil.typeOfLval lv)
+ | _ ->
+ Stack.push (self#accept_array e.enode) accept_array;
+ Cil.ChangeDoChildrenPost (e,
+ fun e -> ignore (Stack.pop accept_array); e)
+
+
+ method private check_initialized_var v =
+ let block_vars = Stack.pop current_block_vars in
+ match List.partition (Cil_datatype.Varinfo.equal v) block_vars with
+ | [_], block_vars ->
+ Stack.push block_vars current_block_vars;
+ Cil_datatype.Varinfo.Hashtbl.add known_vars v v
+ | [], _ ->
+ if Cil_datatype.Varinfo.Hashtbl.mem known_vars v then
+ check_abort "Local variable %a is initialized twice"
+ Printer.pp_varinfo v
+ else
+ check_abort
+ "%a is initialized, but not marked as a local variable \
+ of the nearest enclosing block"
+ Printer.pp_varinfo v
+ | _, _ ->
check_abort
- "%a is initialized, but not marked as a local variable \
- of the nearest enclosing block"
+ "Local variable %a is present several times in block's locals list"
Printer.pp_varinfo v
- | _, _ ->
- check_abort
- "Local variable %a is present several times in block's locals list"
- Printer.pp_varinfo v
-
- method! vinst i =
- let treat_call lvopt f args _loc =
- match f.enode with
- | Lval (Var f, NoOffset) ->
- let (treturn,targs,is_variadic,_) = Cil.splitFunctionTypeVI f in
- if Cil.isVoidType treturn && lvopt != None then
- check_abort
- "in call %a, assigning result of a function returning void"
- Printer.pp_instr i;
- (match lvopt with
- | None -> ()
- | Some lv ->
- let tlv = Cil.typeOfLval lv in
- let tlv = Cil.type_remove_qualifier_attributes tlv in
- if not (Cabs2cil.allow_return_collapse ~tlv ~tf:treturn) then
- check_abort "in call %a, cannot implicitly cast from \
- function return type %a to type of %a (%a)"
- Printer.pp_instr i
- Printer.pp_typ treturn
- Printer.pp_lval lv
- Printer.pp_typ tlv);
- let rec aux l1 l2 =
- match l1,l2 with
- | [],[] -> Cil.DoChildren
- | _::_, [] ->
- check_abort "call %a has too few arguments" Printer.pp_instr i
- | [],e::_ ->
- if is_variadic then Cil.DoChildren
- else
- check_abort "call %a has too many arguments, starting from %a"
- Printer.pp_instr i Printer.pp_exp e
- | (_,ty1,_)::l1,arg::l2 ->
- let ty2 = Cil.typeOf arg in
- if not (is_admissible_conversion arg ty2 ty1) then
- check_abort "in call %a, arg %a has type %a instead of %a"
- Printer.pp_instr i
- Printer.pp_exp arg
- Printer.pp_typ ty2
- Printer.pp_typ ty1;
- aux l1 l2
- in
- (match targs with
- | None -> Cil.DoChildren
- | Some targs -> aux targs args)
- | _ -> (* indirect call. Can't check coherence with a given kf *)
+
+ method! vinst i =
+ let treat_call lvopt f args _loc =
+ match f.enode with
+ | Lval (Var f, NoOffset) ->
+ let (treturn,targs,is_variadic,_) = Cil.splitFunctionTypeVI f in
+ if Cil.isVoidType treturn && lvopt != None then
+ check_abort
+ "in call %a, assigning result of a function returning void"
+ Printer.pp_instr i;
+ (match lvopt with
+ | None -> ()
+ | Some lv ->
+ let tlv = Cil.typeOfLval lv in
+ let tlv = Cil.type_remove_qualifier_attributes tlv in
+ if not (Cabs2cil.allow_return_collapse ~tlv ~tf:treturn) then
+ check_abort "in call %a, cannot implicitly cast from \
+ function return type %a to type of %a (%a)"
+ Printer.pp_instr i
+ Printer.pp_typ treturn
+ Printer.pp_lval lv
+ Printer.pp_typ tlv);
+ let rec aux l1 l2 =
+ match l1,l2 with
+ | [],[] -> Cil.DoChildren
+ | _::_, [] ->
+ check_abort "call %a has too few arguments" Printer.pp_instr i
+ | [],e::_ ->
+ if is_variadic then Cil.DoChildren
+ else
+ check_abort "call %a has too many arguments, starting from %a"
+ Printer.pp_instr i Printer.pp_exp e
+ | (_,ty1,_)::l1,arg::l2 ->
+ let ty2 = Cil.typeOf arg in
+ if not (is_admissible_conversion arg ty2 ty1) then
+ check_abort "in call %a, arg %a has type %a instead of %a"
+ Printer.pp_instr i
+ Printer.pp_exp arg
+ Printer.pp_typ ty2
+ Printer.pp_typ ty1;
+ aux l1 l2
+ in
+ (match targs with
+ | None -> Cil.DoChildren
+ | Some targs -> aux targs args)
+ | _ -> (* indirect call. Can't check coherence with a given kf *)
+ Cil.DoChildren
+ in
+ match i with
+ | Call(lvopt,f,args,loc) ->
+ treat_call lvopt f args loc
+ | Local_init (v, AssignInit _, _) ->
+ self#check_initialized_var v;
Cil.DoChildren
- in
- match i with
- | Call(lvopt,f,args,loc) ->
- treat_call lvopt f args loc
- | Local_init (v, AssignInit _, _) ->
- self#check_initialized_var v;
- Cil.DoChildren
- | Local_init (v, ConsInit(f,args,k),loc) ->
- self#check_initialized_var v;
- Cil.treat_constructor_as_func treat_call v f args k loc
- | Asm(_,_,Some { asm_gotos },_) ->
- List.iter self#check_label asm_gotos; Cil.DoChildren
- | _ -> Cil.DoChildren
-
- method! vtype ty =
- match ty with
- | TArray (_, _, _, la) ->
- let elt, _ = Cil.splitArrayAttributes la in
- if elt != [] then
- Kernel.fatal
- "Element attribute on array type itself: %a"
- Printer.pp_attributes elt;
- Cil.DoChildren
- | TFun(rt, _, _, attrs) ->
- (* we do not visit parameters. This is handled elsewhere, and it
- is not possible to perform a sensible check for dependent types
- at this level, e.g. for
- void f(int n, int arr[10][n]);
- as in TFun the parameters are simple string, and not tied to
- the varinfo that we would like to put in scope to check that
- arr[10][n] is well formed.
- *)
- ignore (Cil.visitCilType (self:>Cil.cilVisitor) rt);
- ignore (Cil.visitCilAttributes (self:>Cil.cilVisitor) attrs);
- Cil.SkipChildren
- | _ -> Cil.DoChildren
-
-
- initializer
- let add_func kf =
- let vi = Kernel_function.get_vi kf in
- if vi.vsource then
- globals_functions <- Cil_datatype.Varinfo.Set.add vi globals_functions
- in
- let add_var vi _ =
- if vi.vsource then
- globals_vars <- Cil_datatype.Varinfo.Set.add vi globals_vars
- in
- Globals.Functions.iter add_func;
- Globals.Vars.iter add_var
-
- end
+ | Local_init (v, ConsInit(f,args,k),loc) ->
+ self#check_initialized_var v;
+ Cil.treat_constructor_as_func treat_call v f args k loc
+ | Asm(_,_,Some { asm_gotos },_) ->
+ List.iter self#check_label asm_gotos; Cil.DoChildren
+ | _ -> Cil.DoChildren
+
+ method! vtype ty =
+ match ty with
+ | TArray (_, _, _, la) ->
+ let elt, _ = Cil.splitArrayAttributes la in
+ if elt != [] then
+ Kernel.fatal
+ "Element attribute on array type itself: %a"
+ Printer.pp_attributes elt;
+ Cil.DoChildren
+ | TFun(rt, _, _, attrs) ->
+ (* we do not visit parameters. This is handled elsewhere, and it
+ is not possible to perform a sensible check for dependent types
+ at this level, e.g. for
+ void f(int n, int arr[10][n]);
+ as in TFun the parameters are simple string, and not tied to
+ the varinfo that we would like to put in scope to check that
+ arr[10][n] is well formed.
+ *)
+ ignore (Cil.visitCilType (self:>Cil.cilVisitor) rt);
+ ignore (Cil.visitCilAttributes (self:>Cil.cilVisitor) attrs);
+ Cil.SkipChildren
+ | _ -> Cil.DoChildren
+
+
+ initializer
+ let add_func kf =
+ let vi = Kernel_function.get_vi kf in
+ if vi.vsource then
+ globals_functions <- Cil_datatype.Varinfo.Set.add vi globals_functions
+ in
+ let add_var vi _ =
+ if vi.vsource then
+ globals_vars <- Cil_datatype.Varinfo.Set.add vi globals_vars
+ in
+ Globals.Functions.iter add_func;
+ Globals.Vars.iter add_var
+
+ end
end
module type Extensible_checker =
@@ -1351,7 +1351,7 @@ let check_ast ?is_normalized ?(ast = Ast.get()) what =
Kernel.debug ~dkey:Kernel.dkey_check
"Checking integrity of %s (%snormalized):@\n%a"
what (if Extlib.opt_conv true is_normalized then "" else "not ")
- (if Extlib.opt_conv true is_normalized
+ (if Extlib.opt_conv true is_normalized
then Printer.pp_file else Cil_printer.pp_file)
ast;
Cil.visitCilFileSameGlobals
diff --git a/src/kernel_services/ast_queries/logic_const.ml b/src/kernel_services/ast_queries/logic_const.ml
index de7fd61e1c3..62a544622ef 100644
--- a/src/kernel_services/ast_queries/logic_const.ml
+++ b/src/kernel_services/ast_queries/logic_const.ml
@@ -72,14 +72,14 @@ let refresh_deps = function
let refresh_from (a,d) = (new_identified_term a.it_content, refresh_deps d)
let refresh_allocation = function
- | FreeAllocAny -> FreeAllocAny
- | FreeAlloc(f,a) ->
- FreeAlloc((refresh_identified_term_list f),refresh_identified_term_list a)
+ | FreeAllocAny -> FreeAllocAny
+ | FreeAlloc(f,a) ->
+ FreeAlloc((refresh_identified_term_list f),refresh_identified_term_list a)
let refresh_assigns = function
- | WritesAny -> WritesAny
- | Writes l ->
- Writes(List.map refresh_from l)
+ | WritesAny -> WritesAny
+ | Writes l ->
+ Writes(List.map refresh_from l)
let refresh_behavior b =
{ b with
@@ -103,11 +103,11 @@ let refresh_spec s =
let refresh_code_annotation annot =
let content =
match annot.annot_content with
- | AAssert _ | AInvariant _ | AAllocation _ | AVariant _ | APragma _
- | AExtended _ as c -> c
- | AStmtSpec(l,spec) -> AStmtSpec(l, refresh_spec spec)
- | AAssigns(l,a) -> AAssigns(l, refresh_assigns a)
-
+ | AAssert _ | AInvariant _ | AAllocation _ | AVariant _ | APragma _
+ | AExtended _ as c -> c
+ | AStmtSpec(l,spec) -> AStmtSpec(l, refresh_spec spec)
+ | AAssigns(l,a) -> AAssigns(l, refresh_assigns a)
+
in
new_code_annotation content
@@ -135,11 +135,11 @@ let loop_entry_label = BuiltinLabel LoopEntry
let rec instantiate subst = function
| Ltype(ty,prms) -> Ltype(ty, List.map (instantiate subst) prms)
| Larrow(args,rt) ->
- Larrow(List.map (instantiate subst) args, instantiate subst rt)
+ Larrow(List.map (instantiate subst) args, instantiate subst rt)
| Lvar v as ty ->
- (* This is an application of type parameters:
- no need to recursively substitute in the resulting type. *)
- (try List.assoc v subst with Not_found -> ty)
+ (* This is an application of type parameters:
+ no need to recursively substitute in the resulting type. *)
+ (try List.assoc v subst with Not_found -> ty)
| Ctype _ | Linteger | Lreal as ty -> ty
let is_unrollable_ltdef = function
@@ -234,10 +234,10 @@ let boolean_type = Ltype ({ lt_name = Utf8_logic.boolean ; lt_params = [] ; lt_d
(** {2 Offsets} *)
let rec lastTermOffset (off: term_offset) : term_offset =
- match off with
- | TNoOffset | TField(_,TNoOffset) | TIndex(_,TNoOffset)
- | TModel(_,TNoOffset)-> off
- | TField(_,off) | TIndex(_,off) | TModel(_,off) -> lastTermOffset off
+ match off with
+ | TNoOffset | TField(_,TNoOffset) | TIndex(_,TNoOffset)
+ | TModel(_,TNoOffset)-> off
+ | TField(_,off) | TIndex(_,off) | TModel(_,off) -> lastTermOffset off
let rec addTermOffset (toadd: term_offset) (off: term_offset) : term_offset =
match off with
@@ -262,8 +262,8 @@ let term ?(loc=Cil_datatype.Location.unknown) term typ =
let taddrof ?(loc=Cil_datatype.Location.unknown) lv typ =
match lv with
- | TMem h, TNoOffset -> h
- | _ -> term ~loc (TAddrOf lv) typ
+ | TMem h, TNoOffset -> h
+ | _ -> term ~loc (TAddrOf lv) typ
(** range of integers *)
let trange ?(loc=Cil_datatype.Location.unknown) (low,high) =
@@ -287,11 +287,11 @@ let treal ?(loc=Cil_datatype.Location.unknown) f =
let s = Pretty_utils.to_string Floating_point.pretty f in
let r = {
r_literal = s ;
- r_upper = f ; r_lower = f ; r_nearest = f ;
+ r_upper = f ; r_lower = f ; r_nearest = f ;
} in
term ~loc (TConst (LReal r)) Lreal
-let treal_zero ?(loc=Cil_datatype.Location.unknown) ?(ltyp=Lreal) () =
+let treal_zero ?(loc=Cil_datatype.Location.unknown) ?(ltyp=Lreal) () =
let zero = { r_nearest = 0.0 ; r_upper = 0.0 ; r_lower = 0.0 ; r_literal = "0." } in
term ~loc (TConst (LReal zero)) ltyp
@@ -429,16 +429,16 @@ let pvalid_index ?(loc=Cil_datatype.Location.unknown) (l,t1,t2) =
let ty1 = t1.term_type in
let ty2 = t2.term_type in
let t, ty =(match t1.term_node with
- | TStartOf lv ->
- TAddrOf (addTermOffsetLval (TIndex(t2,TNoOffset)) lv)
- | _ -> TBinOp (PlusPI, t1, t2)),
- set_conversion ty1 ty2 in
+ | TStartOf lv ->
+ TAddrOf (addTermOffsetLval (TIndex(t2,TNoOffset)) lv)
+ | _ -> TBinOp (PlusPI, t1, t2)),
+ set_conversion ty1 ty2 in
let t = term ~loc t ty in
- pvalid ~loc (l,t)
+ pvalid ~loc (l,t)
(* the range should be a range of integers *)
let pvalid_range ?(loc=Cil_datatype.Location.unknown) (l,t1,b1,b2) =
let t2 = trange ((Some b1), (Some b2)) in
- pvalid_index ~loc (l,t1,t2)
+ pvalid_index ~loc (l,t1,t2)
let pat ?(loc=Cil_datatype.Location.unknown) (p,q) = unamed ~loc (Pat (p,q))
let pinitialized ?(loc=Cil_datatype.Location.unknown) (l,p) =
unamed ~loc (Pinitialized (l,p))
diff --git a/src/kernel_services/ast_queries/logic_utils.ml b/src/kernel_services/ast_queries/logic_utils.ml
index 4ba6bcb2ddf..5c66aa85fed 100644
--- a/src/kernel_services/ast_queries/logic_utils.ml
+++ b/src/kernel_services/ast_queries/logic_utils.ml
@@ -2152,7 +2152,7 @@ let complete_types f = Cil.visitCilFile (new complete_types) f
(**
- false => keywords are all ACSL keywords
- true => only C keywords are recognized as such.
- (other remains plain identifiers/typenames)
+ (other remains plain identifiers/typenames)
*)
let kw_c_mode = ref false
diff --git a/src/plugins/gui/design.ml b/src/plugins/gui/design.ml
index 49111c839e0..bb11d8d5687 100644
--- a/src/plugins/gui/design.ml
+++ b/src/plugins/gui/design.ml
@@ -81,14 +81,14 @@ class type main_window_extension_points = object
method original_source_viewer : Source_manager.t
method reset : unit -> unit
method error : 'a.
- ?parent:GWindow.window_skel -> ?reset:bool ->
+ ?parent:GWindow.window_skel -> ?reset:bool ->
('a, Format.formatter, unit) format ->
'a
method push_info : 'a. ('a, Format.formatter, unit) format -> 'a
method pop_info : unit -> unit
method show_ids: bool
method help_message : 'a 'b.
- (<event : GObj.event_ops ; .. > as 'a)
+ (<event : GObj.event_ops ; .. > as 'a)
-> ('b, Format.formatter, unit) format
-> 'b
method lower_notebook : GPack.notebook
@@ -146,18 +146,18 @@ let filetree_selector
let source = main_ui#source_viewer in
(match globals with
| Filetree.File (f, l) ->
- Source_manager.load_file
- main_ui#original_source_viewer
- ~filename:f ~line:1
- ~click_cb:(fun _ ->
- (* original_source callback unnecessary here *) ()) ();
- main_ui#display_globals l
+ Source_manager.load_file
+ main_ui#original_source_viewer
+ ~filename:f ~line:1
+ ~click_cb:(fun _ ->
+ (* original_source callback unnecessary here *) ()) ();
+ main_ui#display_globals l
| Filetree.Global (GVarDecl (vi, _)) ->
(* try to find a definition instead of a declaration, which is more
informative. *)
main_ui#display_globals [Ast.def_or_last_decl vi]
- | Filetree.Global g ->
- main_ui#display_globals [g];
+ | Filetree.Global g ->
+ main_ui#display_globals [g];
);
source#scroll_to_mark ~use_align:true ~xalign:0. ~yalign:0.5 `INSERT;
let print_one_global prefix (v,loc) =
@@ -169,104 +169,104 @@ let filetree_selector
main_ui#annot_window#clear;
begin match globals with
| Filetree.Global g ->
- begin
- History.push (History.Global g);
- match g with
- | GFun ({svar=v},loc) -> print_one_global "Function" (v,loc)
- | GVar (v,_,loc) -> print_one_global "Variable" (v,loc)
- | GVarDecl (v, loc) -> print_one_global "Variable" (v,loc)
- | GFunDecl (_, v, loc) ->
- print_one_global "Declared function" (v,loc)
- | _ -> () (* cannot currently happen, we do not display the
- other globals in the filetree *)
- end
+ begin
+ History.push (History.Global g);
+ match g with
+ | GFun ({svar=v},loc) -> print_one_global "Function" (v,loc)
+ | GVar (v,_,loc) -> print_one_global "Variable" (v,loc)
+ | GVarDecl (v, loc) -> print_one_global "Variable" (v,loc)
+ | GFunDecl (_, v, loc) ->
+ print_one_global "Declared function" (v,loc)
+ | _ -> () (* cannot currently happen, we do not display the
+ other globals in the filetree *)
+ end
| Filetree.File (f, globals) ->
- let max_length = 40 in
- let cons_limit r g l = if !r >= max_length then l else (incr r;g::l) in
- let gfun_c,gtyp_c,gcomptagdecl_c,genumtagdecl_c,gvardecl_c,gvar_c=
- ref 0,ref 0,ref 0,ref 0,ref 0,ref 0
- in
- let (gfun,gtype,gcomp,genum,gvardecl,gvar) =
- List.fold_right
- (fun g (gfun,gtype,gcomp,genum,gvardecl,gvar) ->
- match g with
- | GFun _ ->
- (cons_limit gfun_c g gfun,gtype,gcomp,genum,gvardecl,gvar)
- | GFunDecl _ ->
- (cons_limit gfun_c g gfun,gtype,gcomp,genum,gvardecl,gvar)
- | GType _ -> (gfun,cons_limit gtyp_c g gtype,gcomp,genum,gvardecl,gvar)
- | GCompTagDecl _ ->
- (gfun,gtype,cons_limit gcomptagdecl_c g gcomp,genum,gvardecl,gvar)
- | GEnumTagDecl _ ->
- (gfun,gtype,gcomp,cons_limit genumtagdecl_c g genum,gvardecl,gvar)
- | GVarDecl _ ->
- (gfun,gtype,gcomp,genum,cons_limit gvardecl_c g gvardecl,gvar)
- | GVar _ ->
- (gfun,gtype,gcomp,genum,gvardecl,cons_limit gvar_c g gvar)
- | _ -> (gfun,gtype,gcomp,genum,gvardecl,gvar))
- globals
- ([],[],[],[],[],[])
- in
- main_ui#pretty_information "@[File %a@]@." Datatype.Filepath.pretty f;
- let printing
- (head:string)
- (ellipsis:bool)
- (f:Format.formatter -> 'a -> unit)
- (l:'a list)
- =
- if l <> [] then
- main_ui#pretty_information "@[%s @[<hov>%a@]%s@]@\n" head
- (Pretty_utils.pp_list ~sep:",@ " f) l
- (if ellipsis then "..." else "")
- in
- printing
- "Functions:"
- (!gfun_c>=max_length)
- (fun fmt -> (function GFun ({svar=v},_) | GFunDecl (_, v, _) ->
- Varinfo.pretty fmt v
- | _ -> assert false))
- gfun;
- printing
- "Types:"
- (!gtyp_c>=max_length)
- (function fmt -> (function (GType ({tname=name},_)) ->
- Format.pp_print_string fmt name
- | _ -> assert false))
- gtype;
- printing
- "Composite types:"
- (!gcomptagdecl_c>=max_length)
- (function fmt ->
- (function GCompTagDecl
- ({cname=name},_) |GCompTag ({cname=name},_)->
- Format.pp_print_string fmt name
- | _ -> assert false))
- gcomp;
- printing
- "Enums:"
- (!genumtagdecl_c>=max_length)
- (function fmt ->
- (function GEnumTagDecl
- ({ename=name},_) | GEnumTag ({ename=name},_)->
- Format.pp_print_string fmt name
- |_ -> assert false))
- genum;
- printing
- "Declared variables:"
- (!gvardecl_c>=max_length)
- (function fmt ->
- (function GVarDecl (v,_) ->
- Varinfo.pretty fmt v
+ let max_length = 40 in
+ let cons_limit r g l = if !r >= max_length then l else (incr r;g::l) in
+ let gfun_c,gtyp_c,gcomptagdecl_c,genumtagdecl_c,gvardecl_c,gvar_c=
+ ref 0,ref 0,ref 0,ref 0,ref 0,ref 0
+ in
+ let (gfun,gtype,gcomp,genum,gvardecl,gvar) =
+ List.fold_right
+ (fun g (gfun,gtype,gcomp,genum,gvardecl,gvar) ->
+ match g with
+ | GFun _ ->
+ (cons_limit gfun_c g gfun,gtype,gcomp,genum,gvardecl,gvar)
+ | GFunDecl _ ->
+ (cons_limit gfun_c g gfun,gtype,gcomp,genum,gvardecl,gvar)
+ | GType _ -> (gfun,cons_limit gtyp_c g gtype,gcomp,genum,gvardecl,gvar)
+ | GCompTagDecl _ ->
+ (gfun,gtype,cons_limit gcomptagdecl_c g gcomp,genum,gvardecl,gvar)
+ | GEnumTagDecl _ ->
+ (gfun,gtype,gcomp,cons_limit genumtagdecl_c g genum,gvardecl,gvar)
+ | GVarDecl _ ->
+ (gfun,gtype,gcomp,genum,cons_limit gvardecl_c g gvardecl,gvar)
+ | GVar _ ->
+ (gfun,gtype,gcomp,genum,gvardecl,cons_limit gvar_c g gvar)
+ | _ -> (gfun,gtype,gcomp,genum,gvardecl,gvar))
+ globals
+ ([],[],[],[],[],[])
+ in
+ main_ui#pretty_information "@[File %a@]@." Datatype.Filepath.pretty f;
+ let printing
+ (head:string)
+ (ellipsis:bool)
+ (f:Format.formatter -> 'a -> unit)
+ (l:'a list)
+ =
+ if l <> [] then
+ main_ui#pretty_information "@[%s @[<hov>%a@]%s@]@\n" head
+ (Pretty_utils.pp_list ~sep:",@ " f) l
+ (if ellipsis then "..." else "")
+ in
+ printing
+ "Functions:"
+ (!gfun_c>=max_length)
+ (fun fmt -> (function GFun ({svar=v},_) | GFunDecl (_, v, _) ->
+ Varinfo.pretty fmt v
+ | _ -> assert false))
+ gfun;
+ printing
+ "Types:"
+ (!gtyp_c>=max_length)
+ (function fmt -> (function (GType ({tname=name},_)) ->
+ Format.pp_print_string fmt name
+ | _ -> assert false))
+ gtype;
+ printing
+ "Composite types:"
+ (!gcomptagdecl_c>=max_length)
+ (function fmt ->
+ (function GCompTagDecl
+ ({cname=name},_) |GCompTag ({cname=name},_)->
+ Format.pp_print_string fmt name
| _ -> assert false))
- gvardecl;
- printing
- "Variables:"
- (!gvar_c>=max_length)
- (fun fmt -> (function GVar(v,_,_) ->
- Varinfo.pretty fmt v
- | _ -> assert false))
- gvar;
- main_ui#pretty_information "%!"
+ gcomp;
+ printing
+ "Enums:"
+ (!genumtagdecl_c>=max_length)
+ (function fmt ->
+ (function GEnumTagDecl
+ ({ename=name},_) | GEnumTag ({ename=name},_)->
+ Format.pp_print_string fmt name
+ |_ -> assert false))
+ genum;
+ printing
+ "Declared variables:"
+ (!gvardecl_c>=max_length)
+ (function fmt ->
+ (function GVarDecl (v,_) ->
+ Varinfo.pretty fmt v
+ | _ -> assert false))
+ gvardecl;
+ printing
+ "Variables:"
+ (!gvar_c>=max_length)
+ (fun fmt -> (function GVar(v,_,_) ->
+ Varinfo.pretty fmt v
+ | _ -> assert false))
+ gvar;
+ main_ui#pretty_information "%!"
end
end
@@ -293,22 +293,22 @@ let to_do_on_real_select _menu
let go_to_definition selected main_ui =
match selected with
| PLval (_kf, _ki, lv) ->
- begin
- match lv with
- | Var vi, _ when vi.vsource && vi.vglob ->
- let typ = Cil.typeOfLval lv in
- let glob =
- if Cil.isFunctionType typ
- then Kernel_function.get_global (Globals.Functions.get vi)
- else GVarDecl (vi, Location.unknown)
- in
- let name =
- Pretty_utils.escape_underscores
- (Format.asprintf "%a" Varinfo.pretty vi)
- in
- Some (name, fun () -> ignore (main_ui#select_or_display_global glob))
- | _ -> None (* cannot go to definition *)
- end
+ begin
+ match lv with
+ | Var vi, _ when vi.vsource && vi.vglob ->
+ let typ = Cil.typeOfLval lv in
+ let glob =
+ if Cil.isFunctionType typ
+ then Kernel_function.get_global (Globals.Functions.get vi)
+ else GVarDecl (vi, Location.unknown)
+ in
+ let name =
+ Pretty_utils.escape_underscores
+ (Format.asprintf "%a" Varinfo.pretty vi)
+ in
+ Some (name, fun () -> ignore (main_ui#select_or_display_global glob))
+ | _ -> None (* cannot go to definition *)
+ end
| PStmt (kf,{skind = Goto (stmt, _)}) ->
begin
match !stmt.labels with
@@ -329,7 +329,7 @@ let print_code_annotations (main_ui:main_window_extension_points) kf stmt =
else match Alarms.find a with
| Some _ -> "alarm"
| None ->
- Format.asprintf "emitted by %a" Emitter.pretty e
+ Format.asprintf "emitted by %a" Emitter.pretty e
in
main_ui#pretty_information "@[%s: @[<hov>%a@]@]@.%a@."
kind Printer.pp_code_annotation a
@@ -348,21 +348,21 @@ let print_call_preconditions (main_ui: main_window_extension_points) stmt =
match by_ptr_call with
| None -> () (* Not a call *)
| Some by_ptr ->
- let called_at = Statuses_by_call.all_functions_with_preconditions stmt in
- let aux_callee kf =
- let warn_missing = false in
- let l= Statuses_by_call.all_call_preconditions_at ~warn_missing kf stmt in
- let pp_kf fmt =
- if by_ptr then
- Format.fprintf fmt "of %a:@ " Kernel_function.pretty kf
- in
- let aux_prop (orig, copy) =
- main_ui#pretty_information "@[Precondition %t%a@.%a@]@."
- pp_kf Property.pretty orig pretty_predicate_status copy
- in
- List.iter aux_prop l
+ let called_at = Statuses_by_call.all_functions_with_preconditions stmt in
+ let aux_callee kf =
+ let warn_missing = false in
+ let l= Statuses_by_call.all_call_preconditions_at ~warn_missing kf stmt in
+ let pp_kf fmt =
+ if by_ptr then
+ Format.fprintf fmt "of %a:@ " Kernel_function.pretty kf
+ in
+ let aux_prop (orig, copy) =
+ main_ui#pretty_information "@[Precondition %t%a@.%a@]@."
+ pp_kf Property.pretty orig pretty_predicate_status copy
in
- Kernel_function.Hptset.iter aux_callee called_at
+ List.iter aux_prop l
+ in
+ Kernel_function.Hptset.iter aux_callee called_at
(* This is called when a localizable is selected in the pretty-printed source
buffer, and also when a localizable is clicked on in the information panel *)
@@ -378,8 +378,8 @@ let to_do_on_select
(Pretty_utils.pp_opt ~none:"None" Printer.pp_location) loc
stmt.sid;
match loc with
- | None -> main_ui#view_original_stmt stmt
- | Some loc -> main_ui#view_original loc; loc
+ | None -> main_ui#view_original_stmt stmt
+ | Some loc -> main_ui#view_original loc; loc
in
let current_statement_msg ?loc kf stmt =
main_ui#pretty_information
@@ -390,11 +390,11 @@ let to_do_on_select
match stmt with
| Kglobal -> main_ui#pretty_information "@."
| Kstmt s ->
- let loc = view_original ?loc s in
- if main_ui#show_ids then
- main_ui#pretty_information
- "Statement: %d (%a)@.@." s.sid Printer.pp_location loc
- else main_ui#pretty_information "Line %a@.@." Printer.pp_location loc
+ let loc = view_original ?loc s in
+ if main_ui#show_ids then
+ main_ui#pretty_information
+ "Statement: %d (%a)@.@." s.sid Printer.pp_location loc
+ else main_ui#pretty_information "Line %a@.@." Printer.pp_location loc
in
let pp_decl fmt loc =
if Cil_datatype.Location.equal loc Cil_datatype.Location.unknown then ()
@@ -422,195 +422,195 @@ let to_do_on_select
let open Property in match selected with
| PStmtStart _ -> ()
| PStmt (kf, stmt) ->
- current_statement_msg (Some kf) (Kstmt stmt);
- print_code_annotations main_ui kf stmt;
- print_call_preconditions main_ui stmt;
+ current_statement_msg (Some kf) (Kstmt stmt);
+ print_code_annotations main_ui kf stmt;
+ print_call_preconditions main_ui stmt;
| PIP (IPCodeAnnot {ica_kf;ica_stmt;ica_ca} as ip) ->
- current_statement_msg
- ?loc:(Cil_datatype.Code_annotation.loc ica_ca)
- (Some ica_kf) (Kstmt ica_stmt);
- if main_ui#show_ids then
- main_ui#pretty_information "Code annotation id: %d@." ica_ca.annot_id;
- main_ui#pretty_information "%a@." pretty_predicate_status ip
+ current_statement_msg
+ ?loc:(Cil_datatype.Code_annotation.loc ica_ca)
+ (Some ica_kf) (Kstmt ica_stmt);
+ if main_ui#show_ids then
+ main_ui#pretty_information "Code annotation id: %d@." ica_ca.annot_id;
+ main_ui#pretty_information "%a@." pretty_predicate_status ip
| PIP(IPAllocation _ as ip) ->
- main_ui#pretty_information "This is an allocation clause@.%a@."
- pretty_predicate_status ip;
- main_ui#view_original (location ip)
+ main_ui#pretty_information "This is an allocation clause@.%a@."
+ pretty_predicate_status ip;
+ main_ui#view_original (location ip)
| PIP(IPAssigns _ as ip) ->
- main_ui#pretty_information "This is an assigns clause@.%a@."
- pretty_predicate_status ip;
- main_ui#view_original (location ip)
+ main_ui#pretty_information "This is an assigns clause@.%a@."
+ pretty_predicate_status ip;
+ main_ui#view_original (location ip)
| PIP(IPFrom _ as ip) ->
- main_ui#pretty_information "This is a from clause@.%a@."
- pretty_predicate_status ip;
- main_ui#view_original (location ip)
+ main_ui#pretty_information "This is a from clause@.%a@."
+ pretty_predicate_status ip;
+ main_ui#view_original (location ip)
| PIP (IPPredicate {ip_kind = PKRequires _} as ip) ->
- main_ui#pretty_information "This is a requires clause.@.%a@."
- pretty_predicate_status ip;
- main_ui#view_original (location ip)
+ main_ui#pretty_information "This is a requires clause.@.%a@."
+ pretty_predicate_status ip;
+ main_ui#view_original (location ip)
| PIP (IPExtended {ie_ext={ext_name}} as ip) ->
- main_ui#pretty_information "This clause is a %s extension.@.%a@."
- ext_name pretty_predicate_status ip;
- main_ui#view_original (location ip)
+ main_ui#pretty_information "This clause is a %s extension.@.%a@."
+ ext_name pretty_predicate_status ip;
+ main_ui#view_original (location ip)
| PIP (IPPredicate {ip_kind = PKTerminates} as ip) ->
- main_ui#pretty_information "This is a terminates clause.@.%a@."
- pretty_predicate_status ip;
- main_ui#view_original (location ip)
+ main_ui#pretty_information "This is a terminates clause.@.%a@."
+ pretty_predicate_status ip;
+ main_ui#view_original (location ip)
| PIP (IPPredicate {ip_kind = PKEnsures (_,Normal)} as ip) ->
- main_ui#pretty_information "This is an ensures clause.@.%a@."
- pretty_predicate_status ip;
- main_ui#view_original (location ip)
+ main_ui#pretty_information "This is an ensures clause.@.%a@."
+ pretty_predicate_status ip;
+ main_ui#view_original (location ip)
| PIP (IPPredicate {ip_kind = PKEnsures (_,Exits)} as ip) ->
- main_ui#pretty_information "This is an exits clause.@.%a@."
- pretty_predicate_status ip;
- main_ui#view_original (location ip)
+ main_ui#pretty_information "This is an exits clause.@.%a@."
+ pretty_predicate_status ip;
+ main_ui#view_original (location ip)
| PIP (IPPredicate {ip_kind = PKEnsures (_,Returns)} as ip) ->
- main_ui#pretty_information "This is a returns clause.@.%a@."
- pretty_predicate_status ip;
- main_ui#view_original (location ip)
+ main_ui#pretty_information "This is a returns clause.@.%a@."
+ pretty_predicate_status ip;
+ main_ui#view_original (location ip)
| PIP (IPPredicate {ip_kind = PKEnsures (_,Breaks)} as ip) ->
- main_ui#pretty_information "This is a breaks clause.@.%a@."
- pretty_predicate_status ip;
- main_ui#view_original (location ip)
+ main_ui#pretty_information "This is a breaks clause.@.%a@."
+ pretty_predicate_status ip;
+ main_ui#view_original (location ip)
| PIP (IPPredicate {ip_kind = PKEnsures (_,Continues)} as ip) ->
- main_ui#pretty_information "This is a continues clause.@.%a@."
- pretty_predicate_status ip;
- main_ui#view_original (location ip)
+ main_ui#pretty_information "This is a continues clause.@.%a@."
+ pretty_predicate_status ip;
+ main_ui#view_original (location ip)
| PIP (IPPredicate {ip_kind = PKAssumes _} as ip) ->
- main_ui#pretty_information "This is an assumes clause.@.";
- main_ui#view_original (location ip)
+ main_ui#pretty_information "This is an assumes clause.@.";
+ main_ui#view_original (location ip)
| PIP (IPDecrease {id_kinstr=Kglobal} as ip) ->
- main_ui#pretty_information
- "This is a decreases clause.@.%a@."
- pretty_predicate_status ip;
- main_ui#view_original (location ip)
+ main_ui#pretty_information
+ "This is a decreases clause.@.%a@."
+ pretty_predicate_status ip;
+ main_ui#view_original (location ip)
| PIP (IPDecrease {id_kinstr=Kstmt _} as ip) ->
- main_ui#pretty_information
- "This is a loop variant.@.%a@."
- pretty_predicate_status ip;
- main_ui#view_original (location ip)
+ main_ui#pretty_information
+ "This is a loop variant.@.%a@."
+ pretty_predicate_status ip;
+ main_ui#view_original (location ip)
| PIP(IPDisjoint _ as ip) ->
- main_ui#pretty_information
- "This is a disjoint behaviors clause.@.%a@."
- pretty_predicate_status ip;
- main_ui#view_original (location ip)
+ main_ui#pretty_information
+ "This is a disjoint behaviors clause.@.%a@."
+ pretty_predicate_status ip;
+ main_ui#view_original (location ip)
| PIP(IPComplete _ as ip) ->
- main_ui#pretty_information
- "This is a complete behaviors clause.@.%a@."
- pretty_predicate_status ip;
- main_ui#view_original (location ip)
+ main_ui#pretty_information
+ "This is a complete behaviors clause.@.%a@."
+ pretty_predicate_status ip;
+ main_ui#view_original (location ip)
| PIP(IPAxiom _ as ip) ->
- main_ui#pretty_information "This is an axiom.@.";
- main_ui#view_original (location ip)
+ main_ui#pretty_information "This is an axiom.@.";
+ main_ui#view_original (location ip)
| PIP(IPAxiomatic _ as ip) ->
- main_ui#pretty_information "This is an axiomatic.@.";
- main_ui#view_original (location ip)
+ main_ui#pretty_information "This is an axiomatic.@.";
+ main_ui#view_original (location ip)
| PIP(IPLemma _ as ip) ->
- main_ui#pretty_information "This is a lemma.@.";
- main_ui#view_original (location ip)
+ main_ui#pretty_information "This is a lemma.@.";
+ main_ui#view_original (location ip)
| PIP(IPTypeInvariant _ as ip) ->
- main_ui#pretty_information "This is a type invariant.@.";
- main_ui#view_original (location ip)
+ main_ui#pretty_information "This is a type invariant.@.";
+ main_ui#view_original (location ip)
| PIP(IPGlobalInvariant _ as ip) ->
- main_ui#pretty_information "This is a global invariant.@.";
- main_ui#view_original (location ip)
+ main_ui#pretty_information "This is a global invariant.@.";
+ main_ui#view_original (location ip)
| PIP(IPBehavior _ as ip) ->
- main_ui#pretty_information "This is a behavior.@.";
- main_ui#view_original (location ip)
+ main_ui#pretty_information "This is a behavior.@.";
+ main_ui#view_original (location ip)
| PIP (IPPropertyInstance {ii_ip=ip'} as ip) ->
main_ui#pretty_information "@[This is an instance of property `%a'.@]@."
short_pretty ip';
- main_ui#view_original (location ip)
+ main_ui#view_original (location ip)
| PIP(IPReachable _ | IPOther _) ->
- (* these properties are not selectable *)
- assert false
+ (* these properties are not selectable *)
+ assert false
| PGlobal _g -> main_ui#pretty_information "This is a global.@.";
| PLval (kf, ki,lv) ->
- let ty = typeOfLval lv in
- if isFunctionType ty then begin
- begin
- match ki with
- | Kstmt s -> ignore (view_original s)
- | Kglobal -> ();
- end;
- main_ui#pretty_information "This is a C function of type `%a'@."
- Gui_printers.pp_typ ty
- end
- else begin
- current_statement_msg kf ki;
- match lv with
- | Var vi,NoOffset ->
- main_ui#pretty_information
- "Variable %a has type `%a'.@\nIt is a %a.@\n\
- %tIt is %sreferenced and its address is %staken.@."
- Varinfo.pretty vi
- Gui_printers.pp_typ vi.vtype
- pp_var_with_decl vi
- (fun fmt ->
- match vi.vdescr with
- | None -> ()
- | Some s ->
- Format.fprintf fmt
- "This is a temporary variable for \"%s\".@\n" s)
- (if vi.vreferenced then "" else "not ")
- (if vi.vaddrof then "" else "not ")
- | _ ->
- let typ = typeOfLval lv in
- main_ui#pretty_information "This is an lvalue of type %a@."
- Gui_printers.pp_typ typ
- end
+ let ty = typeOfLval lv in
+ if isFunctionType ty then begin
+ begin
+ match ki with
+ | Kstmt s -> ignore (view_original s)
+ | Kglobal -> ();
+ end;
+ main_ui#pretty_information "This is a C function of type `%a'@."
+ Gui_printers.pp_typ ty
+ end
+ else begin
+ current_statement_msg kf ki;
+ match lv with
+ | Var vi,NoOffset ->
+ main_ui#pretty_information
+ "Variable %a has type `%a'.@\nIt is a %a.@\n\
+ %tIt is %sreferenced and its address is %staken.@."
+ Varinfo.pretty vi
+ Gui_printers.pp_typ vi.vtype
+ pp_var_with_decl vi
+ (fun fmt ->
+ match vi.vdescr with
+ | None -> ()
+ | Some s ->
+ Format.fprintf fmt
+ "This is a temporary variable for \"%s\".@\n" s)
+ (if vi.vreferenced then "" else "not ")
+ (if vi.vaddrof then "" else "not ")
+ | _ ->
+ let typ = typeOfLval lv in
+ main_ui#pretty_information "This is an lvalue of type %a@."
+ Gui_printers.pp_typ typ
+ end
| PExp (_kf, _ki, e) ->
- begin
- let typ = typeOf e in
- match constFoldToInt e with
- | Some i ->
- begin match e.enode with
- | Const (CEnum {eihost}) ->
- let typ_enum = TEnum (eihost, []) in
- main_ui#pretty_information
- "This is a C enumeration constant, \
- defined in %a with a value of %a.@."
- Gui_printers.pp_typ typ_enum Abstract_interp.Int.pretty i
- | _ ->
+ begin
+ let typ = typeOf e in
+ match constFoldToInt e with
+ | Some i ->
+ begin match e.enode with
+ | Const (CEnum {eihost}) ->
+ let typ_enum = TEnum (eihost, []) in
+ main_ui#pretty_information
+ "This is a C enumeration constant, \
+ defined in %a with a value of %a.@."
+ Gui_printers.pp_typ typ_enum Abstract_interp.Int.pretty i
+ | _ ->
main_ui#pretty_information
"This is a constant C expression of type %a, equal to %a.@."
Gui_printers.pp_typ typ Abstract_interp.Int.pretty i
- end
- | None ->
- main_ui#pretty_information "This is a pure C expression of type %a.@."
- Gui_printers.pp_typ typ
- end
+ end
+ | None ->
+ main_ui#pretty_information "This is a pure C expression of type %a.@."
+ Gui_printers.pp_typ typ
+ end
| PTermLval (_, _, ip, tlv) ->
- main_ui#pretty_information "This is a logical left-value, \
- of logic type %a.@."
- Printer.pp_logic_type (Cil.typeOfTermLval tlv);
- main_ui#view_original (Property.location ip)
+ main_ui#pretty_information "This is a logical left-value, \
+ of logic type %a.@."
+ Printer.pp_logic_type (Cil.typeOfTermLval tlv);
+ main_ui#view_original (Property.location ip)
| PVDecl (kf,_,vi) ->
- if vi.vglob
- then begin
- main_ui#view_original (Global.loc (Ast.def_or_last_decl vi));
- main_ui#pretty_information
- "This is the last declaration or definition of %s %a.@\n\
- It is %sreferenced and its address is %staken.@."
- (if Cil.isFunctionType vi.vtype
- then "function" else "global variable")
- Varinfo.pretty vi
- (if vi.vreferenced then "" else "not ")
- (if vi.vaddrof then "" else "not ")
- end else begin
- main_ui#view_original vi.vdecl;
- let kf = Extlib.the kf in
- main_ui#pretty_information
- "This is the declaration of %s %a in function %a%t@."
- (formal_or_local vi) Varinfo.pretty vi
- Kernel_function.pretty kf
- (fun fmt -> match vi.vdescr with None -> ()
- | Some s -> Format.fprintf fmt
- "@\nThis is a temporary variable for \"%s\".@." s)
- end
+ if vi.vglob
+ then begin
+ main_ui#view_original (Global.loc (Ast.def_or_last_decl vi));
+ main_ui#pretty_information
+ "This is the last declaration or definition of %s %a.@\n\
+ It is %sreferenced and its address is %staken.@."
+ (if Cil.isFunctionType vi.vtype
+ then "function" else "global variable")
+ Varinfo.pretty vi
+ (if vi.vreferenced then "" else "not ")
+ (if vi.vaddrof then "" else "not ")
+ end else begin
+ main_ui#view_original vi.vdecl;
+ let kf = Extlib.the kf in
+ main_ui#pretty_information
+ "This is the declaration of %s %a in function %a%t@."
+ (formal_or_local vi) Varinfo.pretty vi
+ Kernel_function.pretty kf
+ (fun fmt -> match vi.vdescr with None -> ()
+ | Some s -> Format.fprintf fmt
+ "@\nThis is a temporary variable for \"%s\".@." s)
+ end
end
else if button = 3 then begin
match go_to_definition selected main_ui with
@@ -658,7 +658,7 @@ struct
let fold_category = "fold"
let unfold_category = "unfold"
-(*GTK3 does not exist anymore in gsourceview3. *)
+ (*GTK3 does not exist anymore in gsourceview3. *)
let declare_markers (source:GSourceView.source_view) =
GSourceView.make_marker_attributes
~source ~category:fold_category ~priority:2
@@ -732,7 +732,7 @@ class protected_menu_factory (host:Gtk_helper.host) (menu:GMenu.menu) = object
let callback = match callback with
None -> None
| Some cb ->
- Some (fun () -> ignore (host#full_protect ~cancelable:true cb))
+ Some (fun () -> ignore (host#full_protect ~cancelable:true cb))
in
super#add_item ?key ?callback ?submenu string
@@ -740,8 +740,8 @@ class protected_menu_factory (host:Gtk_helper.host) (menu:GMenu.menu) = object
let callback = match callback with
None -> None
| Some cb ->
- Some (fun b ->
- ignore (host#full_protect ~cancelable:false (fun () -> cb b)))
+ Some (fun b ->
+ ignore (host#full_protect ~cancelable:false (fun () -> cb b)))
in
super#add_check_item ?active ?key ?callback string
@@ -754,7 +754,7 @@ let selector_localizable (main_ui:main_window_extension_points) origin ~button l
new protected_menu_factory (main_ui:>Gtk_helper.host) (GMenu.menu())
in
List.iter
- (fun (f, origins) ->
+ (fun (f, origins) ->
if List.mem origin origins then
f popup_factory main_ui ~button localizable
)
@@ -1018,16 +1018,16 @@ class main_window () : main_window_extension_points =
method main_window = main_window
method menu_manager () = match menu_manager with
| None ->
- (* toplevel_vbox->[*self#menu_manager();toplevel_hpaned;bottom_hbox] *)
- let m =
- new Menu_manager.menu_manager
- ~packing:(toplevel_vbox#pack ~expand:false ~fill:false ~from:`START)
- ~host:(self :> Gtk_helper.host)
- in
- menu_manager <- Some m;
- m
+ (* toplevel_vbox->[*self#menu_manager();toplevel_hpaned;bottom_hbox] *)
+ let m =
+ new Menu_manager.menu_manager
+ ~packing:(toplevel_vbox#pack ~expand:false ~fill:false ~from:`START)
+ ~host:(self :> Gtk_helper.host)
+ in
+ menu_manager <- Some m;
+ m
| Some s ->
- s
+ s
method file_tree = Extlib.the file_tree
method file_tree_view = file_tree_view
method annot_window = annot_window
@@ -1107,18 +1107,18 @@ class main_window () : main_window_extension_points =
match !dragged_frame with
| None (* Not dropping a panel *) -> true
| Some (frame,title) ->
- (*Format.printf "Hello %d %d %ld@." x y time;*)
- let w = drag_context#source_widget in
- let new_w =
- GWindow.window ~position:`MOUSE ~title ~show:true () in
- let b = GPack.vbox ~packing:new_w#add () in
- frame#misc#reparent b#coerce;
- ignore (new_w#connect#destroy
- (fun () ->
- frame#misc#reparent w;
- w#misc#show ()));
- w#misc#hide ();
- true));
+ (*Format.printf "Hello %d %d %ld@." x y time;*)
+ let w = drag_context#source_widget in
+ let new_w =
+ GWindow.window ~position:`MOUSE ~title ~show:true () in
+ let b = GPack.vbox ~packing:new_w#add () in
+ frame#misc#reparent b#coerce;
+ ignore (new_w#connect#destroy
+ (fun () ->
+ frame#misc#reparent w;
+ w#misc#show ()));
+ w#misc#hide ();
+ true));
ignore (widget#drag#connect#motion
(fun drag_context ~x:_ ~y:_ ~time ->
(*Format.printf "Motion %d %d %ld@." x y time;*)
@@ -1198,28 +1198,28 @@ class main_window () : main_window_extension_points =
match Pretty_source.locate_localizable current_buffer_state#locs loc with
| Some (b,_) -> show b
| None ->
- (* Searching in [current_buffer_state] did not work, let's try
- to open a good one *)
- begin
- match Pretty_source.kf_of_localizable loc with
- | Some kf ->
- let g = Kernel_function.get_global kf in
- self#select_or_display_global g
- | None ->
- match loc with
- | PGlobal g -> self#select_or_display_global g
- | _ ->
- Gui_parameters.debug ~dkey "does not know how to scroll to loc"
- (* In this case, there is nothing we can do: we do not
- know which file/global to open to scroll in *)
- end;
- match Pretty_source.locate_localizable current_buffer_state#locs loc with
- | Some (b, _) -> show b
+ (* Searching in [current_buffer_state] did not work, let's try
+ to open a good one *)
+ begin
+ match Pretty_source.kf_of_localizable loc with
+ | Some kf ->
+ let g = Kernel_function.get_global kf in
+ self#select_or_display_global g
| None ->
- (* Can appear eg. for an if (i<5) inside a loop,
- which is not shown in general in the source code *)
- Gui_parameters.debug ~dkey "Unable to scroll to loc, probably \
- not shown in the buffer"
+ match loc with
+ | PGlobal g -> self#select_or_display_global g
+ | _ ->
+ Gui_parameters.debug ~dkey "does not know how to scroll to loc"
+ (* In this case, there is nothing we can do: we do not
+ know which file/global to open to scroll in *)
+ end;
+ match Pretty_source.locate_localizable current_buffer_state#locs loc with
+ | Some (b, _) -> show b
+ | None ->
+ (* Can appear eg. for an if (i<5) inside a loop,
+ which is not shown in general in the source code *)
+ Gui_parameters.debug ~dkey "Unable to scroll to loc, probably \
+ not shown in the buffer"
method view_stmt stmt =
let kf = Kernel_function.find_englobing_kf stmt in
@@ -1305,9 +1305,9 @@ class main_window () : main_window_extension_points =
let bfmt = Format.formatter_of_buffer b in
Format.kfprintf
(function fmt ->
- Format.pp_print_flush fmt ();
- let content = Buffer.contents b in
- ignore (status_context#push content))
+ Format.pp_print_flush fmt ();
+ let content = Buffer.contents b in
+ ignore (status_context#push content))
bfmt
fmt
@@ -1320,12 +1320,12 @@ class main_window () : main_window_extension_points =
let bfmt = Format.formatter_of_buffer buffer in
Format.kfprintf
(function _ ->
- ignore (w#event#connect#leave_notify
- (fun _ -> self#pop_info ();true));
- ignore (w#event#connect#enter_notify
- (fun _ ->
- Format.pp_print_flush bfmt ();
- self#push_info_buffer ~buffer "" ;false)))
+ ignore (w#event#connect#leave_notify
+ (fun _ -> self#pop_info ();true));
+ ignore (w#event#connect#enter_notify
+ (fun _ ->
+ Format.pp_print_flush bfmt ();
+ self#push_info_buffer ~buffer "" ;false)))
bfmt
fmt
@@ -1389,31 +1389,31 @@ class main_window () : main_window_extension_points =
| Some _ as iters -> iters
| None ->
let title = "Find " ^ where in
- (* try to wrap search if user wishes *)
- if GToolbox.question_box ~title
- (Printf.sprintf "No more occurrences for: %s\n\
- Search from beginning?" text)
- ~buttons:["Yes"; "No"] = 1 (*yes*) then
- let cursor_iter = buffer#get_iter `START in
- (* note: may end up searching twice some parts of the buffer *)
- cursor_iter#forward_search
- ~flags:[]
- text
- else
- (notify_not_found := false; None)
+ (* try to wrap search if user wishes *)
+ if GToolbox.question_box ~title
+ (Printf.sprintf "No more occurrences for: %s\n\
+ Search from beginning?" text)
+ ~buttons:["Yes"; "No"] = 1 (*yes*) then
+ let cursor_iter = buffer#get_iter `START in
+ (* note: may end up searching twice some parts of the buffer *)
+ cursor_iter#forward_search
+ ~flags:[]
+ text
+ else
+ (notify_not_found := false; None)
in
match found_iters with
| Some (i1,i2) ->
- buffer#place_cursor i1;
- buffer#select_range i1 i2;
- ignore (scroll_to_iter i1
- ~use_align:false
- ~within_margin:0.025
- );
- last_find_text <- text
+ buffer#place_cursor i1;
+ buffer#select_range i1 i2;
+ ignore (scroll_to_iter i1
+ ~use_align:false
+ ~within_margin:0.025
+ );
+ last_find_text <- text
| None -> if !notify_not_found then
- GToolbox.message_box ~title:("Not found " ^ where)
- (Printf.sprintf "Not found %s: %s" where text)
+ GToolbox.message_box ~title:("Not found " ^ where)
+ (Printf.sprintf "Not found %s: %s" where text)
in
let focused_widget = GtkWindow.Window.get_focus main_window#as_window in
let focused_name = Gobject.Property.get focused_widget GtkBase.Widget.P.name
@@ -1442,8 +1442,8 @@ class main_window () : main_window_extension_points =
| None -> GToolbox.message_box ~title:"Global not found"
(Printf.sprintf "Global not found: %s" text)
| Some g ->
- last_find_text <- text;
- self#select_or_display_global g
+ last_find_text <- text;
+ self#select_or_display_global g
else ();
None (* indicates that we are done processing the command *)
end
@@ -1457,10 +1457,10 @@ class main_window () : main_window_extension_points =
let console_view_focused =
match !console_view with
| Some v ->
- if Gobject.Property.get v#as_widget GtkBase.Widget.P.has_focus then
- Some ("in Console",`GTextViewer v)
- else
- None
+ if Gobject.Property.get v#as_widget GtkBase.Widget.P.has_focus then
+ Some ("in Console",`GTextViewer v)
+ else
+ None
| None -> None
in
if console_view_focused <> None then console_view_focused
@@ -1472,16 +1472,16 @@ class main_window () : main_window_extension_points =
match opt_where_view with
| None -> (* no searchable focused element, or already processed *) ()
| Some (where,viewer) ->
- let text =
- if use_dialog then
- Extlib.opt_conv ""
- (Gtk_helper.input_string
- ~parent:main_window
- ~title:("Find " ^ where) ~ok:"Find" ~cancel:"Cancel"
- ("Find text (" ^ where ^ "):") ~text:last_find_text)
- else last_find_text
- in
- if text <> "" then find_text_in_viewer ~where viewer text else ()
+ let text =
+ if use_dialog then
+ Extlib.opt_conv ""
+ (Gtk_helper.input_string
+ ~parent:main_window
+ ~title:("Find " ^ where) ~ok:"Find" ~cancel:"Cancel"
+ ("Find text (" ^ where ^ "):") ~text:last_find_text)
+ else last_find_text
+ in
+ if text <> "" then find_text_in_viewer ~where viewer text else ()
initializer
self#set_reset self#reset;
@@ -1562,12 +1562,12 @@ class main_window () : main_window_extension_points =
)
in
Gdk.Rectangle.(Gui_parameters.debug ~dkey:dkey_scroll
- "my rect is %d (+%d) %d (+%d)@\n\
- vis rect is %d (+%d) %d (+%d)@\n\
- my rect is visible: %B@."
- (x my_rect) (width my_rect) (y my_rect) (height my_rect)
- (x visible_rect) (width visible_rect) (y visible_rect)
- (height visible_rect) res);
+ "my rect is %d (+%d) %d (+%d)@\n\
+ vis rect is %d (+%d) %d (+%d)@\n\
+ my rect is visible: %B@."
+ (x my_rect) (width my_rect) (y my_rect) (height my_rect)
+ (x visible_rect) (width visible_rect) (y visible_rect)
+ (height visible_rect) res);
has_stabilized := res;
(* when added as an idle procedure below, check will
be removed whenever it returns false. *)
@@ -1594,7 +1594,7 @@ class main_window () : main_window_extension_points =
done;
Glib.Timeout.remove alarm;
self#view_stmt stmt;
- with Not_found -> ()
+ with Not_found -> ()
end;
false)
in
@@ -1711,9 +1711,9 @@ class main_window () : main_window_extension_points =
History.set_display_elt_callback
(function
| History.Global g ->
- self#select_or_display_global g
+ self#select_or_display_global g
| History.Localizable l ->
- self#scroll l
+ self#scroll l
);
register_reset_extension (fun _ -> display_warnings ());
@@ -1729,11 +1729,11 @@ class main_window () : main_window_extension_points =
match typ with
| TNamed (ti, _) -> Some (Logic_typing.Typedef, ti.torig_name)
| TComp (ci, _, _) ->
- let tag = if ci.cstruct then Logic_typing.Struct
- else Logic_typing.Union
- in
- let name = if ci.corig_name <> "" then ci.corig_name else ci.cname in
- Some (tag, name)
+ let tag = if ci.cstruct then Logic_typing.Struct
+ else Logic_typing.Union
+ in
+ let name = if ci.corig_name <> "" then ci.corig_name else ci.cname in
+ Some (tag, name)
| TEnum (ei, _) ->
let name = if ei.eorig_name <> "" then ei.eorig_name else ei.ename in
Some (Logic_typing.Enum, name)
@@ -1742,9 +1742,9 @@ class main_window () : main_window_extension_points =
match opt_tag_name with
| None -> ()
| Some (tag, name) ->
- let g = Globals.Types.global tag name in
- let loc = Cil_datatype.Global.loc g in
- Format.fprintf pp ", defined at %a" Printer.pp_location loc
+ let g = Globals.Types.global tag name in
+ let loc = Cil_datatype.Global.loc g in
+ Format.fprintf pp ", defined at %a" Printer.pp_location loc
with
| Not_found -> ()
in
@@ -1760,15 +1760,15 @@ class main_window () : main_window_extension_points =
match History.selected_localizable () with
| None -> ()
| Some loc ->
- let kfopt = Pretty_source.kf_of_localizable loc in
- let ki = Pretty_source.ki_of_localizable loc in
- let var_localizable =
- Pretty_source.PLval (kfopt, ki, (Var vi, NoOffset))
- in
- let button = GdkEvent.Button.button button in
- if button = 1 then self#pretty_information "@.";
- selector_localizable self#toplevel
- InformationPanel ~button var_localizable
+ let kfopt = Pretty_source.kf_of_localizable loc in
+ let ki = Pretty_source.ki_of_localizable loc in
+ let var_localizable =
+ Pretty_source.PLval (kfopt, ki, (Var vi, NoOffset))
+ in
+ let button = GdkEvent.Button.button button in
+ if button = 1 then self#pretty_information "@.";
+ selector_localizable self#toplevel
+ InformationPanel ~button var_localizable
with Gui_printers.NoMatch -> ()
end;
begin
@@ -1777,15 +1777,15 @@ class main_window () : main_window_extension_points =
let typ = Gui_printers.typ_of_link s in
match typ with
| TComp _ | TEnum _ | TPtr _ | TArray _ | TNamed _ ->
- let base_type = Gui_printers.get_type_specifier typ in
- let sizeof_str =
- try Format.sprintf "sizeof %d" (Cil.bytesSizeOf base_type)
- with Cil.SizeOfError (b, _) -> "unknown size: " ^ b
- in
- self#pretty_information ~scroll:true
- "@.Type information for `%a':@.(%s%a)@. @[%a@]"
- Printer.pp_typ base_type sizeof_str pp_def_loc typ
- Gui_printers.pp_typ_unfolded base_type
+ let base_type = Gui_printers.get_type_specifier typ in
+ let sizeof_str =
+ try Format.sprintf "sizeof %d" (Cil.bytesSizeOf base_type)
+ with Cil.SizeOfError (b, _) -> "unknown size: " ^ b
+ in
+ self#pretty_information ~scroll:true
+ "@.Type information for `%a':@.(%s%a)@. @[%a@]"
+ Printer.pp_typ base_type sizeof_str pp_def_loc typ
+ Gui_printers.pp_typ_unfolded base_type
| _ -> () (* avoid printing anything for basic types;
also, function types are not supported *)
with Gui_printers.NoMatch -> ()
@@ -1867,7 +1867,7 @@ let toplevel play =
Project.set_current (Project.from_unique_name project_name);
Ast.compute ()
with e -> (* An error occurred: we need to enforce the splash screen
- realization before we create the error dialog widget.*)
+ realization before we create the error dialog widget.*)
force_s (); raise e);
init_crashed := false);
if Ast.is_computed () then
diff --git a/src/plugins/gui/filetree.ml b/src/plugins/gui/filetree.ml
index d8eb7c7c522..d948016b8c0 100644
--- a/src/plugins/gui/filetree.ml
+++ b/src/plugins/gui/filetree.ml
@@ -41,7 +41,7 @@ let _pretty_node fmt = function
| File (s, _) -> Datatype.Filepath.pretty fmt s
| Global (GFun ({svar = vi},_) | GVar(vi,_,_) |
GFunDecl (_,vi,_) | GVarDecl(vi,_)) ->
- Format.fprintf fmt "%s" vi.vname
+ Format.fprintf fmt "%s" vi.vname
| _ -> ()
(* Fetches the internal (hidden) GtkButton of the column header.
@@ -49,8 +49,8 @@ let _pretty_node fmt = function
you should:
- add first the column to the table;
- explicitely set the widget of the header (and this widget should not be a
- button itself).
- Otherwise, this function will return None. *)
+ button itself).
+ Otherwise, this function will return None. *)
let get_column_header_button (col: GTree.view_column) =
let rec get_button = function
| None -> None
@@ -127,21 +127,21 @@ struct
let indices: int array = GTree.Path.get_indices path in
match indices with
| [||] ->
- None
+ None
| _ ->
- if inbound indices.(0) roots then
- let result = ref (roots.(indices.(0))) in
- try
- for depth=1 to Array.length indices - 1 do
- let index = indices.(depth) in
- if inbound index !result.sons then
- result:=!result.sons.(index)
- else raise Not_found
- done;
- Some !result
- with Not_found ->
- None
- else None
+ if inbound indices.(0) roots then
+ let result = ref (roots.(indices.(0))) in
+ try
+ for depth=1 to Array.length indices - 1 do
+ let index = indices.(depth) in
+ if inbound index !result.sons then
+ result:=!result.sons.(index)
+ else raise Not_found
+ done;
+ Some !result
+ with Not_found ->
+ None
+ else None
method custom_get_path (row:custom_tree) : Gtk.tree_path =
let current_row = ref row in
@@ -160,11 +160,11 @@ struct
let nidx = succ row.fidx in
match row.parent with
| None -> if inbound nidx roots then Some roots.(nidx)
- else None
+ else None
| Some parent ->
- if inbound nidx parent.sons then
- Some parent.sons.(nidx)
- else None
+ if inbound nidx parent.sons then
+ Some parent.sons.(nidx)
+ else None
method custom_iter_children (rowopt:custom_tree option) :custom_tree option =
match rowopt with
@@ -267,11 +267,11 @@ module MYTREE = struct
let sons_info = function
| MFile (_, l) ->
- List.map (function
- | MGlobal { name = n; strikethrough = st } -> (n, st)
- | MFile _ -> assert false (* should not happen, a file is
- never under a file in the tree *)
- ) l
+ List.map (function
+ | MGlobal { name = n; strikethrough = st } -> (n, st)
+ | MFile _ -> assert false (* should not happen, a file is
+ never under a file in the tree *)
+ ) l
| MGlobal _ -> []
let get_storage t = match t with
@@ -316,7 +316,7 @@ module MYTREE = struct
let ga_name = function
| Dfun_or_pred (li, _) ->
- Some (global_name li.l_var_info.lv_name)
+ Some (global_name li.l_var_info.lv_name)
| Dvolatile _ -> Some "volatile clause"
| Daxiomatic (s, _, _,_) -> Some (global_name s)
| Dtype (lti, _) -> Some (global_name lti.lt_name)
@@ -336,17 +336,17 @@ module MYTREE = struct
match glob with
| GFun ({svar=vi},_) | GVar(vi,_,_)
| GVarDecl(vi,_) | GFunDecl (_, vi, _)->
- (* Only display the last declaration/definition *)
- if hide glob || (not (Ast.is_def_or_last_decl glob))
- then acc
- else ((global_name vi.vname), glob) :: acc
+ (* Only display the last declaration/definition *)
+ if hide glob || (not (Ast.is_def_or_last_decl glob))
+ then acc
+ else ((global_name vi.vname), glob) :: acc
| GAnnot (ga, _) ->
- if hide glob
- then acc
- else (match ga_name ga with
- | None -> acc
- | Some s -> (s, glob) :: acc)
+ if hide glob
+ then acc
+ else (match ga_name ga with
+ | None -> acc
+ | Some s -> (s, glob) :: acc)
| _ -> acc)
[]
globs
@@ -421,31 +421,31 @@ module State = struct
let path_from_node cache = function
| File (s, _) ->
- (try Some (Datatype.Filepath.Hashtbl.find cache.cache_files s)
- with Not_found -> None)
+ (try Some (Datatype.Filepath.Hashtbl.find cache.cache_files s)
+ with Not_found -> None)
| Global (GFun ({svar = vi},_) | GVar(vi,_,_) |
GVarDecl(vi,_) | GFunDecl (_,vi,_)) ->
- (try Some (Varinfo.Hashtbl.find cache.cache_vars vi)
- with Not_found -> None)
+ (try Some (Varinfo.Hashtbl.find cache.cache_vars vi)
+ with Not_found -> None)
| Global (GAnnot (ga,_)) ->
- (try Some (Global_annotation.Hashtbl.find cache.cache_global_annot ga)
- with Not_found -> None)
+ (try Some (Global_annotation.Hashtbl.find cache.cache_global_annot ga)
+ with Not_found -> None)
| _ -> None
let fill_cache cache (path:int list) row =
match row.MODEL.finfo with
| MYTREE.MFile (storage,_) ->
- Datatype.Filepath.Hashtbl.add
- cache.cache_files (Datatype.Filepath.of_string storage.MYTREE.name) (path,row)
+ Datatype.Filepath.Hashtbl.add
+ cache.cache_files (Datatype.Filepath.of_string storage.MYTREE.name) (path,row)
| MYTREE.MGlobal storage ->
- match storage.MYTREE.globals with
- (* Only one element in this array by invariant: this is a leaf*)
- | [| GFun ({svar=vi},_) | GVar(vi,_,_)
- | GVarDecl(vi,_) | GFunDecl (_,vi,_)|] ->
- Varinfo.Hashtbl.add cache.cache_vars vi (path,row)
- | [| GAnnot (ga,_) |] ->
- Global_annotation.Hashtbl.add cache.cache_global_annot ga (path,row)
- | _ -> (* no cache for other globals yet *) ()
+ match storage.MYTREE.globals with
+ (* Only one element in this array by invariant: this is a leaf*)
+ | [| GFun ({svar=vi},_) | GVar(vi,_,_)
+ | GVarDecl(vi,_) | GFunDecl (_,vi,_)|] ->
+ Varinfo.Hashtbl.add cache.cache_vars vi (path,row)
+ | [| GAnnot (ga,_) |] ->
+ Global_annotation.Hashtbl.add cache.cache_global_annot ga (path,row)
+ | _ -> (* no cache for other globals yet *) ()
(* Extract Cil globals. We remove builtins that are not used in this project,
as well as files that do not contain anything afterwards *)
@@ -456,7 +456,7 @@ module State = struct
let is_unused = function
| GFun ({svar = vi},_) | GFunDecl (_, vi, _)
| GVar (vi, _, _) | GVarDecl (vi, _) ->
- Cil.is_unused_builtin vi
+ Cil.is_unused_builtin vi
| _ -> false
in
f, Extlib.filter_out is_unused all
@@ -471,7 +471,7 @@ module State = struct
let cache = default_cache () in
(* Let's fill up the model with all files and functions. *)
let files = cil_files () in
- begin
+ begin
if flat_mode () then
let list = List.concat (List.map snd files) in
let files = MYTREE.make_list_globals hide sort_order list in
@@ -485,9 +485,9 @@ module State = struct
let files = List.fold_left
(fun acc v ->
let name, globals = MYTREE.make_file hide sort_order v in
- if not ((hide_stdlib ())
+ if not ((hide_stdlib ())
&& (MYTREE.comes_from_share name.MYTREE.name))
- then
+ then
(MYTREE.MFile (name, globals))::acc
else acc)
[] sorted_files
@@ -687,8 +687,8 @@ let make (tree_view:GTree.view) =
let (path:Gtk.tree_path) = model#get_path row in
match model_custom#custom_get_iter path with
| Some {MODEL.finfo=v} ->
- renderer#set_properties
- (f (Array.to_list((MYTREE.get_storage v).MYTREE.globals)))
+ renderer#set_properties
+ (f (Array.to_list((MYTREE.get_storage v).MYTREE.globals)))
| None -> ());
ignore (tree_view#append_column column);
let filter_active, mi = self#filter_from_column visible title f in
@@ -791,20 +791,20 @@ let make (tree_view:GTree.view) =
let rec aux text t =
match t.MODEL.finfo with
| MYTREE.MFile ({MYTREE.name},_) ->
- (* search children *)
- (* note: we avoid calling [storage_type] here because
- we do not need the child nodes *)
- let fake_node = File (Datatype.Filepath.of_string name,[]) in
- if is_current_node fake_node then node_found ();
- Array.iter (aux text) t.MODEL.sons
+ (* search children *)
+ (* note: we avoid calling [storage_type] here because
+ we do not need the child nodes *)
+ let fake_node = File (Datatype.Filepath.of_string name,[]) in
+ if is_current_node fake_node then node_found ();
+ Array.iter (aux text) t.MODEL.sons
| MYTREE.MGlobal {MYTREE.name} as st ->
- let node = MYTREE.storage_type st in
- if is_current_node node then
- node_found ()
- else (* We never consider the current node as matching. This way, if
- 'foo' is selected, we can search for 'fo' and find it farther.*)
- if !found_selection && name_matches name then
- raise (Found_global (get_global node))
+ let node = MYTREE.storage_type st in
+ if is_current_node node then
+ node_found ()
+ else (* We never consider the current node as matching. This way, if
+ 'foo' is selected, we can search for 'fo' and find it farther.*)
+ if !found_selection && name_matches name then
+ raise (Found_global (get_global node))
in
try
Array.iter (aux text) model#get_roots;
@@ -905,17 +905,17 @@ let make (tree_view:GTree.view) =
(match current_node with
| None -> ()
| Some node ->
- match State.path_from_node path_cache node with
- | None -> ()
- | Some (path, _) ->
- self#show_path_in_tree (GTree.Path.create (List.rev path)))
+ match State.path_from_node path_cache node with
+ | None -> ()
+ | Some (path, _) ->
+ self#show_path_in_tree (GTree.Path.create (List.rev path)))
method select_global g =
match State.path_from_node path_cache (Global g) with
| None -> (* selection failed *) self#unselect; false
- | Some (path, _) ->
- self#show_path_in_tree (GTree.Path.create (List.rev path));
- true
+ | Some (path, _) ->
+ self#show_path_in_tree (GTree.Path.create (List.rev path));
+ true
method selected_globals =
match current_node with
@@ -943,22 +943,22 @@ let make (tree_view:GTree.view) =
let (path:Gtk.tree_path) = lmodel#get_path iter in
match self#model#custom_get_iter path with
| Some p ->
- let special, text, strike, underline = match p.MODEL.finfo with
- | MYTREE.MFile ({MYTREE.name=m; strikethrough=strike},_) ->
- if m = "" (* Unknown location *) then
- true, "Unknown file", strike, false
- else
- let path = Datatype.Filepath.of_string m in
- false, Filepath.Normalized.to_pretty_string path, strike, false
- | MYTREE.MGlobal ({MYTREE.name=m; strikethrough=strike}) as s ->
- false, m, strike, MYTREE.is_function s
- in
- renderer#set_properties [
- `TEXT text;
- `STRIKETHROUGH strike;
- `WEIGHT (if special then `LIGHT else `NORMAL);
- `UNDERLINE (if underline then `LOW else `NONE)
- ]
+ let special, text, strike, underline = match p.MODEL.finfo with
+ | MYTREE.MFile ({MYTREE.name=m; strikethrough=strike},_) ->
+ if m = "" (* Unknown location *) then
+ true, "Unknown file", strike, false
+ else
+ let path = Datatype.Filepath.of_string m in
+ false, Filepath.Normalized.to_pretty_string path, strike, false
+ | MYTREE.MGlobal ({MYTREE.name=m; strikethrough=strike}) as s ->
+ false, m, strike, MYTREE.is_function s
+ in
+ renderer#set_properties [
+ `TEXT text;
+ `STRIKETHROUGH strike;
+ `WEIGHT (if special then `LIGHT else `NORMAL);
+ `UNDERLINE (if underline then `LOW else `NONE)
+ ]
| None -> ()
in
diff --git a/src/plugins/gui/pretty_source.ml b/src/plugins/gui/pretty_source.ml
index b472ddbdcf4..cb7cd86639e 100644
--- a/src/plugins/gui/pretty_source.ml
+++ b/src/plugins/gui/pretty_source.ml
@@ -326,33 +326,33 @@ let display_source globals
let ((pb,pe),v) = LocsArray.get locs_array !index in
match v with
| PStmt (_,ki) ->
- (try
- let pb,pe = match ki with
- | {skind = Instr _ | Return _ | Goto _
- | Break _ | Continue _ | Throw _ } -> pb,pe
- | {skind = If _ | Loop _
- | Switch _ } ->
- (* These statements contain other statements.
- We highlight only until the start of the first
- included statement. *)
- pb,
- (try LocsArray.find_next locs_array (!index+1)
- (fun p -> match p with
- | PStmt _ -> true
- | _ -> false (* Do not stop on expressions*))
- with Not_found -> pb+1)
- | {skind = Block _ | TryExcept _ | TryFinally _
- | UnspecifiedSequence _ | TryCatch _ } ->
- pb,
- (try LocsArray.find_next locs_array (!index+1) (fun _ -> true)
- with Not_found -> pb+1)
- in
- highlighter v ~start:pb ~stop:pe
- with Not_found -> ())
+ (try
+ let pb,pe = match ki with
+ | {skind = Instr _ | Return _ | Goto _
+ | Break _ | Continue _ | Throw _ } -> pb,pe
+ | {skind = If _ | Loop _
+ | Switch _ } ->
+ (* These statements contain other statements.
+ We highlight only until the start of the first
+ included statement. *)
+ pb,
+ (try LocsArray.find_next locs_array (!index+1)
+ (fun p -> match p with
+ | PStmt _ -> true
+ | _ -> false (* Do not stop on expressions*))
+ with Not_found -> pb+1)
+ | {skind = Block _ | TryExcept _ | TryFinally _
+ | UnspecifiedSequence _ | TryCatch _ } ->
+ pb,
+ (try LocsArray.find_next locs_array (!index+1) (fun _ -> true)
+ with Not_found -> pb+1)
+ in
+ highlighter v ~start:pb ~stop:pe
+ with Not_found -> ())
| PStmtStart _
| PTermLval _ | PLval _ | PVDecl _ | PGlobal _
| PIP _ | PExp _ ->
- highlighter v ~start:pb ~stop:pe
+ highlighter v ~start:pb ~stop:pe
with Not_found -> () ) ;
incr index
done;
@@ -481,10 +481,10 @@ class pos_to_localizable =
begin
match s.skind with
| If (exp, _, _, _) ->
- (* conditional expressions are treated in a special way *)
- insideIf <- Some (Kstmt s);
- ignore (Cil.visitCilExpr (self :> Cil.cilVisitor) exp);
- insideIf <- None
+ (* conditional expressions are treated in a special way *)
+ insideIf <- Some (Kstmt s);
+ ignore (Cil.visitCilExpr (self :> Cil.cilVisitor) exp);
+ insideIf <- None
| _ -> ()
end;
Cil.DoChildren
@@ -493,15 +493,15 @@ class pos_to_localizable =
begin
match insideIf with
| Some ki ->
- (* expressions inside conditionals have a special treatment *)
- begin
- match exp.enode with
- | Lval lv ->
- (* lvals must be generated differently from other expressions *)
- self#add_range exp.eloc (PLval(self#current_kf, ki, lv))
- | _ ->
- self#add_range exp.eloc (PExp(self#current_kf, ki, exp))
- end
+ (* expressions inside conditionals have a special treatment *)
+ begin
+ match exp.enode with
+ | Lval lv ->
+ (* lvals must be generated differently from other expressions *)
+ self#add_range exp.eloc (PLval(self#current_kf, ki, lv))
+ | _ ->
+ self#add_range exp.eloc (PExp(self#current_kf, ki, exp))
+ end
| None -> ()
end;
Cil.DoChildren
@@ -583,17 +583,17 @@ let apply_location_heuristics precise_col possible_locs loc =
match possible_locs, filter_locs possible_locs with
| [], _ -> (* no possible localizables *) None
| _, (_ :: _ as exact) ->
- (* one or more exact localizables; we prioritize expressions *)
- begin
- match exps exact with
- | [] -> (* no expressions, just take the last localizable *) last exact
- | exps -> (* take the last (usually only) expression *) last exps
- end
+ (* one or more exact localizables; we prioritize expressions *)
+ begin
+ match exps exact with
+ | [] -> (* no expressions, just take the last localizable *) last exact
+ | exps -> (* take the last (usually only) expression *) last exps
+ end
| (loc', _) :: __, [] ->
- (* No exact loc. We consider the innermost statements,
- ie those at the top of the list *)
- let filtered = innermost_in loc' possible_locs in
- last filtered
+ (* No exact loc. We consider the innermost statements,
+ ie those at the top of the list *)
+ let filtered = innermost_in loc' possible_locs in
+ last filtered
let loc_to_localizable ?(precise_col=false) loc =
if not (MappingLineLocalizable.is_computed ()) then (
@@ -616,8 +616,8 @@ let loc_to_localizable ?(precise_col=false) loc =
None
with
| Not_found ->
- Gui_parameters.debug ~once:true ~source:loc "no matching localizable found";
- None
+ Gui_parameters.debug ~once:true ~source:loc "no matching localizable found";
+ None
(*
Local Variables:
diff --git a/src/plugins/gui/property_navigator.ml b/src/plugins/gui/property_navigator.ml
index 2a8a584f101..fe381109caf 100644
--- a/src/plugins/gui/property_navigator.ml
+++ b/src/plugins/gui/property_navigator.ml
@@ -34,13 +34,13 @@ let all_properties () =
match Property.get_kf ip with
| None -> globals := Property.Set.add ip !globals
| Some kf ->
- if not (Ast_info.is_frama_c_builtin (Kernel_function.get_name kf))
- then try
- let fips = Kernel_function.Map.find kf !functions in
- fips := Property.Set.add ip !fips
- with Not_found ->
- let ips = Property.Set.singleton ip in
- functions := Kernel_function.Map.add kf (ref ips) !functions
+ if not (Ast_info.is_frama_c_builtin (Kernel_function.get_name kf))
+ then try
+ let fips = Kernel_function.Map.find kf !functions in
+ fips := Property.Set.add ip !fips
+ with Not_found ->
+ let ips = Property.Set.singleton ip in
+ functions := Kernel_function.Map.add kf (ref ips) !functions
);
!functions, !globals
@@ -72,8 +72,8 @@ let make_property ip =
in
let function_name, module_name = match Property.get_kf ip with
| None -> "", Datatype.Filepath.dummy (* TODO: it would be great to find the location
- of global invariants or lemmas, but there isn't
- enough information in the ast *)
+ of global invariants or lemmas, but there isn't
+ enough information in the ast *)
| Some kf -> kf_name_and_module kf
in
let kind =
@@ -409,31 +409,31 @@ let aux_rte kf acc (name, _, rte_status_get: Db.RteGen.status_accessor) =
match st, rteGenerated.get (), rteNotGenerated.get () with
| true, true, _
| false, _, true ->
- (* Considered that leaf functions are not verified internally *)
- let status_name, status =
- if st then
- if Kernel_function.is_definition kf
- then "Generated", Feedback.Valid
- else "Considered generated", Feedback.Considered_valid
- else "Not generated", Feedback.Invalid
- in
- let function_name, module_name = kf_name_and_module kf in
- let status_icon = Gtk_helper.Icon.Feedback status in
- let ip =
- Property.ip_other name
- (Property.OLGlob (Kernel_function.get_location kf))
- in
- {
- module_name = module_name;
- function_name = function_name;
- visible = true;
- ip=ip;
- kind=Format.asprintf "@[<hov>%a@]" Property.pretty ip;
- status_name = "" ;
- consolidated_status = None ;
- consolidated_status_name = status_name ;
- status_icon = status_icon ;
- } :: acc
+ (* Considered that leaf functions are not verified internally *)
+ let status_name, status =
+ if st then
+ if Kernel_function.is_definition kf
+ then "Generated", Feedback.Valid
+ else "Considered generated", Feedback.Considered_valid
+ else "Not generated", Feedback.Invalid
+ in
+ let function_name, module_name = kf_name_and_module kf in
+ let status_icon = Gtk_helper.Icon.Feedback status in
+ let ip =
+ Property.ip_other name
+ (Property.OLGlob (Kernel_function.get_location kf))
+ in
+ {
+ module_name = module_name;
+ function_name = function_name;
+ visible = true;
+ ip=ip;
+ kind=Format.asprintf "@[<hov>%a@]" Property.pretty ip;
+ status_name = "" ;
+ consolidated_status = None ;
+ consolidated_status_name = status_name ;
+ status_icon = status_icon ;
+ } :: acc
| true, false, _
| false, _, false -> acc
@@ -533,7 +533,7 @@ let make_panel (main_ui:main_window_extension_points) =
match !properties_tab_label with
| None -> ()
| Some label ->
- GtkMisc.Label.set_text label "Properties"
+ GtkMisc.Label.set_text label "Properties"
);
let sc =
GBin.scrolled_window
@@ -552,9 +552,9 @@ let make_panel (main_ui:main_window_extension_points) =
~callback:(fun path _col ->
match model#custom_get_iter path with
| Some { MODEL.finfo = { ip = ip } } ->
- let format_graph ppf =
- Consolidation_graph.dump (Consolidation_graph.get ip) ppf in
- Gtk_helper.graph_window_through_dot main_ui#main_window "Dependencies" format_graph
+ let format_graph ppf =
+ Consolidation_graph.dump (Consolidation_graph.get ip) ppf in
+ Gtk_helper.graph_window_through_dot main_ui#main_window "Dependencies" format_graph
| None -> ()));
view#selection#set_select_function
(fun path currently_selected ->
@@ -597,7 +597,7 @@ let make_panel (main_ui:main_window_extension_points) =
(* Status colored column viewer *)
make_view_column (GTree.cell_renderer_pixbuf [top])
(function {status_icon=status_icon} ->
- [`PIXBUF (Gtk_helper.Icon.get status_icon)])
+ [`PIXBUF (Gtk_helper.Icon.get status_icon)])
~title:"Status";
(* Consolidated status name column viewer *)
@@ -619,14 +619,14 @@ let make_panel (main_ui:main_window_extension_points) =
| IPBehavior {ib_kinstr=Kglobal} -> behaviors.get ()
| IPBehavior {ib_kinstr=Kstmt _} -> behaviors.get () && stmtSpec.get ()
| IPPredicate {ip_kind=PKRequires _;ip_kinstr=Kglobal} ->
- preconditions.get ()
+ preconditions.get ()
| IPPredicate {ip_kind=PKRequires _;ip_kinstr=Kstmt _} ->
- preconditions.get () && stmtSpec.get ()
+ preconditions.get () && stmtSpec.get ()
| IPPredicate {ip_kind = PKAssumes _} -> false
| IPPredicate {ip_kind=PKEnsures _;ip_kinstr=Kglobal} -> ensures.get ()
| IPExtended _ -> extended.get ()
- | IPPredicate {ip_kind=PKEnsures _;ip_kinstr=Kstmt _} ->
- ensures.get() && stmtSpec.get()
+ | IPPredicate {ip_kind=PKEnsures _;ip_kinstr=Kstmt _} ->
+ ensures.get() && stmtSpec.get()
| IPPredicate {ip_kind = PKTerminates} -> terminates.get ()
| IPAxiom _ -> false
| IPTypeInvariant _ -> typeInvariants.get()
@@ -645,20 +645,20 @@ let make_panel (main_ui:main_window_extension_points) =
| Check -> user_checks.get ()
end
| IPCodeAnnot {ica_ca={annot_content = AInvariant _}} ->
- invariant.get ()
+ invariant.get ()
| IPCodeAnnot {ica_ca={annot_content = APragma p}} ->
- Logic_utils.is_property_pragma p (* currently always false. *)
+ Logic_utils.is_property_pragma p (* currently always false. *)
| IPCodeAnnot _ -> false (* status of inner nodes *)
| IPAllocation {ial_kinstr=Kglobal} -> allocations.get ()
| IPAllocation {ial_kinstr=Kstmt _;ial_bhv=Id_loop _} ->
- allocations.get ()
+ allocations.get ()
| IPAllocation {ial_kinstr=Kstmt _;ial_bhv=Id_contract _} ->
- allocations.get() && stmtSpec.get()
+ allocations.get() && stmtSpec.get()
| IPAssigns {ias_kinstr=Kglobal} -> assigns.get ()
| IPAssigns {ias_kinstr=Kstmt _;ias_bhv=Id_loop _} ->
- assigns.get ()
+ assigns.get ()
| IPAssigns {ias_kinstr=Kstmt _;ias_bhv=Id_contract _} ->
- assigns.get() && stmtSpec.get()
+ assigns.get() && stmtSpec.get()
| IPFrom _ -> from.get ()
| IPDecrease _ -> variant.get ()
| IPPropertyInstance _ -> instances.get ()
@@ -695,7 +695,7 @@ let make_panel (main_ui:main_window_extension_points) =
List.exists
(function
| GFun ({svar = fvi},_) | GFunDecl (_, fvi, _) ->
- Cil_datatype.Varinfo.equal fvi kfvi
+ Cil_datatype.Varinfo.equal fvi kfvi
| _ -> false
) main_ui#file_tree#selected_globals)
in
@@ -735,8 +735,8 @@ let make_panel (main_ui:main_window_extension_points) =
match !properties_tab_label with
| None -> ()
| Some label ->
- let text = Format.sprintf "Properties (%d)" (model#custom_iter_n_children None) in
- GtkMisc.Label.set_text label text
+ let text = Format.sprintf "Properties (%d)" (model#custom_iter_n_children None) in
+ GtkMisc.Label.set_text label text
in
ignore
(let callback _ =
@@ -763,62 +763,62 @@ let make_panel (main_ui:main_window_extension_points) =
let highlighter (buffer:reactive_buffer) localizable ~start ~stop =
match localizable with
| Pretty_source.PIP ppt ->
- if Property.has_status ppt then
- Design.Feedback.mark
- buffer#buffer ~offset:start (Property_status.Feedback.get ppt)
+ if Property.has_status ppt then
+ Design.Feedback.mark
+ buffer#buffer ~offset:start (Property_status.Feedback.get ppt)
| Pretty_source.PStmt(_,({ skind=Instr(Call _| Local_init (_, ConsInit _, _)) } as stmt)) ->
- let kfs = Statuses_by_call.all_functions_with_preconditions stmt in
- (* We separate the consolidated statuses of the preconditions inside
- guarded behaviors from those outside. For guarded behaviors, since we
- do not keep track of the status of 'assumes' clauses, we cannot know
- if they are active. Hence, we must weaken any 'Invalid' status into
- 'Unknown'. *)
- let filter (ip_src, _ip_copy) =
- match ip_src with
- | Property.(IPPredicate {ip_kind=PKRequires bhv}) ->
- bhv.b_assumes = []
- | _ -> false
+ let kfs = Statuses_by_call.all_functions_with_preconditions stmt in
+ (* We separate the consolidated statuses of the preconditions inside
+ guarded behaviors from those outside. For guarded behaviors, since we
+ do not keep track of the status of 'assumes' clauses, we cannot know
+ if they are active. Hence, we must weaken any 'Invalid' status into
+ 'Unknown'. *)
+ let filter (ip_src, _ip_copy) =
+ match ip_src with
+ | Property.(IPPredicate {ip_kind=PKRequires bhv}) ->
+ bhv.b_assumes = []
+ | _ -> false
+ in
+ let ips_sure, ips_unsure = Kernel_function.Hptset.fold
+ (fun kf (ips_sure, ips_unsure) ->
+ Statuses_by_call.setup_all_preconditions_proxies kf;
+ let ips_kf =
+ Statuses_by_call.all_call_preconditions_at ~warn_missing:false kf stmt
+ in
+ let ips_kf_sure, ips_kf_unsure = List.partition filter ips_kf in
+ (List.map snd ips_kf_sure @ ips_sure),
+ (List.map snd ips_kf_unsure @ ips_unsure))
+ kfs ([], [])
+ in
+ let ips = ips_sure @ ips_unsure in
+ if ips <> [] then
+ let validity = Property_status.Feedback.get_conjunction ips in
+ let validity =
+ match validity with
+ | Feedback.Invalid_under_hyp ->
+ (* Weaken if the invalidity comes from [ips_unsure]. We do nothing
+ for statuses [Invalid] (a path should exist, hence the behavior
+ must be active), or [Invalid_but_dead] (equivalent to [True]) *)
+ let invalid ip = Feedback.get ip = Feedback.Invalid_under_hyp in
+ if List.exists invalid ips_unsure &&
+ not (List.exists invalid ips_sure)
+ then Feedback.Unknown
+ else validity
+ | _ -> validity
in
- let ips_sure, ips_unsure = Kernel_function.Hptset.fold
- (fun kf (ips_sure, ips_unsure) ->
- Statuses_by_call.setup_all_preconditions_proxies kf;
- let ips_kf =
- Statuses_by_call.all_call_preconditions_at ~warn_missing:false kf stmt
- in
- let ips_kf_sure, ips_kf_unsure = List.partition filter ips_kf in
- (List.map snd ips_kf_sure @ ips_sure),
- (List.map snd ips_kf_unsure @ ips_unsure))
- kfs ([], [])
+ (* Positioning the bullet is tricky. We cannot use [start] as offset,
+ because the bullet ends up at the beginning of the spec (assertions,
+ contracts, etc) instead of in front of the function name. We use
+ the beginning of the C part of the statement (which has been computed
+ when the source was rendered). *)
+ let offset =
+ try Pretty_source.stmt_start buffer#locs stmt
+ with Not_found ->
+ Gui_parameters.error
+ "Invalid internal state for statement %d" stmt.sid;
+ stop (* fallback *)
in
- let ips = ips_sure @ ips_unsure in
- if ips <> [] then
- let validity = Property_status.Feedback.get_conjunction ips in
- let validity =
- match validity with
- | Feedback.Invalid_under_hyp ->
- (* Weaken if the invalidity comes from [ips_unsure]. We do nothing
- for statuses [Invalid] (a path should exist, hence the behavior
- must be active), or [Invalid_but_dead] (equivalent to [True]) *)
- let invalid ip = Feedback.get ip = Feedback.Invalid_under_hyp in
- if List.exists invalid ips_unsure &&
- not (List.exists invalid ips_sure)
- then Feedback.Unknown
- else validity
- | _ -> validity
- in
- (* Positioning the bullet is tricky. We cannot use [start] as offset,
- because the bullet ends up at the beginning of the spec (assertions,
- contracts, etc) instead of in front of the function name. We use
- the beginning of the C part of the statement (which has been computed
- when the source was rendered). *)
- let offset =
- try Pretty_source.stmt_start buffer#locs stmt
- with Not_found ->
- Gui_parameters.error
- "Invalid internal state for statement %d" stmt.sid;
- stop (* fallback *)
- in
- Design.Feedback.mark buffer#buffer ~call_site:stmt ~offset validity
+ Design.Feedback.mark buffer#buffer ~call_site:stmt ~offset validity
| Pretty_source.PStmt _ | Pretty_source.PStmtStart _
| Pretty_source.PGlobal _| Pretty_source.PVDecl _
diff --git a/src/plugins/metrics/metrics_cilast.ml b/src/plugins/metrics/metrics_cilast.ml
index 53c8b51170f..543fe4afb8b 100644
--- a/src/plugins/metrics/metrics_cilast.ml
+++ b/src/plugins/metrics/metrics_cilast.ml
@@ -34,10 +34,10 @@ type cilast_metrics = {
}
(** Syntactic metrics
- =================
- The goal is to collect various (syntactic) information about the source code
- (slocs, assignments, loops, ...).
- From those one can compute McCabe's cyclomatic complexity.
+ =================
+ The goal is to collect various (syntactic) information about the source code
+ (slocs, assignments, loops, ...).
+ From those one can compute McCabe's cyclomatic complexity.
*)
class type sloc_visitor = object
inherit Visitor.generic_frama_c_visitor
@@ -66,7 +66,7 @@ class type sloc_visitor = object
method get_metrics_map:
(BasicMetrics.t OptionKf.Map.t) Datatype.Filepath.Map.t
- (** Compute and return per-function metrics *)
+ (** Compute and return per-function metrics *)
end
(* Various metrics computing visitor on Cil AST.
@@ -116,23 +116,23 @@ class slocVisitor ~libc : sloc_visitor = object(self)
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
method print_stats fmt =
Transitioning.Format.pp_set_formatter_stag_functions fmt Metrics_base.html_stag_functions;
@@ -141,60 +141,60 @@ class slocVisitor ~libc : sloc_visitor = object(self)
Format.fprintf fmt "@{<th>%s@}" hdr_name in
Datatype.Filepath.Map.iter
(fun filename func_tbl ->
- Metrics_parameters.result ~level:2 "%a" self#pp_file_metrics filename;
- if func_tbl <> OptionKf.Map.empty then
- begin
- Format.fprintf fmt
- "@[<v 0>@{<h3>%a@}<br/>@ \
- @{<table>\
- @[<v 2>@ \
- @[<v 2>@{<tbody>@ \
- @{<tr>@[<v 2>@ \
- %a@ %a@ %a@ %a@ %a@ %a@ %a@ %a@ %a@ @]@}@ \
- %a@ \
- @}@]@]@ @} \
- @]@ "
- Datatype.Filepath.pretty filename
- pr_hdr "Function" pr_hdr "#If stmts" pr_hdr "#Assignments"
- pr_hdr "#Loops" pr_hdr "#Calls" pr_hdr "#Gotos"
- pr_hdr "#Pointer dereferencing" pr_hdr "#Exits"
- pr_hdr "Cyclomatic value"
- (fun fmt fun_tbl ->
- OptionKf.Map.iter
- (fun _fname fmetrics ->
- Format.fprintf fmt "%a"
- pp_base_metrics_as_html_row fmetrics;
- ) fun_tbl
- ) func_tbl;
- end
- else
- Metrics_parameters.warning
- "Filename <%a> has no functions@."
- Datatype.Filepath.pretty filename)
+ Metrics_parameters.result ~level:2 "%a" self#pp_file_metrics filename;
+ if func_tbl <> OptionKf.Map.empty then
+ begin
+ Format.fprintf fmt
+ "@[<v 0>@{<h3>%a@}<br/>@ \
+ @{<table>\
+ @[<v 2>@ \
+ @[<v 2>@{<tbody>@ \
+ @{<tr>@[<v 2>@ \
+ %a@ %a@ %a@ %a@ %a@ %a@ %a@ %a@ %a@ @]@}@ \
+ %a@ \
+ @}@]@]@ @} \
+ @]@ "
+ Datatype.Filepath.pretty filename
+ pr_hdr "Function" pr_hdr "#If stmts" pr_hdr "#Assignments"
+ pr_hdr "#Loops" pr_hdr "#Calls" pr_hdr "#Gotos"
+ pr_hdr "#Pointer dereferencing" pr_hdr "#Exits"
+ pr_hdr "Cyclomatic value"
+ (fun fmt fun_tbl ->
+ OptionKf.Map.iter
+ (fun _fname fmetrics ->
+ Format.fprintf fmt "%a"
+ pp_base_metrics_as_html_row fmetrics;
+ ) fun_tbl
+ ) func_tbl;
+ end
+ else
+ Metrics_parameters.warning
+ "Filename <%a> has no functions@."
+ Datatype.Filepath.pretty filename)
metrics_map
-(* Save the local metrics currently computed.
- Clears it before starting a new metrics computation (e.g. when entering a new
- function definition.
- Global metrics are never reset as they define metrics on the whole Cil.file.
-*)
+ (* Save the local metrics currently computed.
+ Clears it before starting a new metrics computation (e.g. when entering a new
+ function definition.
+ Global metrics are never reset as they define metrics on the whole Cil.file.
+ *)
method private record_and_clear_function_metrics metrics =
let filename = metrics.cfile_name in
let funcname = 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
(OptionKf.Map.add funcname !local_metrics fun_tbl);
with
- | Not_found ->
- let new_kfmap =
- OptionKf.Map.add funcname !local_metrics
- OptionKf.Map.empty
- in self#update_metrics_map filename new_kfmap;
+ | Not_found ->
+ let new_kfmap =
+ OptionKf.Map.add funcname !local_metrics
+ OptionKf.Map.empty
+ in self#update_metrics_map filename new_kfmap;
);
local_metrics := empty_metrics;
@@ -218,7 +218,7 @@ class slocVisitor ~libc : sloc_visitor = object(self)
seen_vars <- Varinfo.Set.add vi seen_vars;
);
Cil.SkipChildren
-
+
method! vfunc fdec =
if consider_function ~libc fdec.svar then
begin
@@ -226,13 +226,13 @@ class slocVisitor ~libc : sloc_visitor = object(self)
let's put it to the "function with source" table. *)
local_metrics :=
{!local_metrics with
- cfile_name = file_of_fundef fdec;
- cfunc = Some (Globals.Functions.get fdec.svar);
- cfuncs = 1; (* Only one function is indeed being defined here *)};
+ cfile_name = file_of_fundef fdec;
+ cfunc = Some (Globals.Functions.get fdec.svar);
+ cfuncs = 1; (* Only one function is indeed being defined here *)};
let fvinfo = fdec.svar in
(if not (VInfoMap.mem fvinfo !fundef_calls) then
(* Never seen before, including never been called *)
- self#add_map fundef_calls fvinfo 0);
+ self#add_map fundef_calls fvinfo 0);
(* On return record the analysis of the function. *)
Cil.ChangeDoChildrenPost
(fdec,
@@ -249,8 +249,8 @@ class slocVisitor ~libc : sloc_visitor = object(self)
method! vlval (host, _) =
begin
match host with
- | Mem _ -> self#incr_both_metrics incr_ptrs;
- | _ -> ()
+ | Mem _ -> self#incr_both_metrics incr_ptrs;
+ | _ -> ()
end;
Cil.DoChildren
@@ -258,35 +258,35 @@ class slocVisitor ~libc : sloc_visitor = object(self)
self#incr_both_metrics incr_slocs;
let do_children =
match s.skind with
- | If _ ->
- self#incr_both_metrics incr_ifs;
- self#incr_both_metrics incr_dpoints;
- true
- | Loop _ -> self#incr_both_metrics incr_loops; true
- | Goto _ -> self#incr_both_metrics incr_gotos; true
- | Return _ -> self#incr_both_metrics incr_exits; true
- | Switch (_, _, _slist, _) -> true
- (* The catching block is one more possible flow alternative *)
- | TryFinally _
- | TryExcept _ -> self#incr_both_metrics incr_dpoints; true
- | UnspecifiedSequence l ->
- List.iter
- (fun (s,_,_,_,_) ->
- ignore
- (Visitor.visitFramacStmt (self:>Visitor.frama_c_visitor) s))
- l;
- false
- | _ -> true
+ | If _ ->
+ self#incr_both_metrics incr_ifs;
+ self#incr_both_metrics incr_dpoints;
+ true
+ | Loop _ -> self#incr_both_metrics incr_loops; true
+ | Goto _ -> self#incr_both_metrics incr_gotos; true
+ | Return _ -> self#incr_both_metrics incr_exits; true
+ | Switch (_, _, _slist, _) -> true
+ (* The catching block is one more possible flow alternative *)
+ | TryFinally _
+ | TryExcept _ -> self#incr_both_metrics incr_dpoints; true
+ | UnspecifiedSequence l ->
+ List.iter
+ (fun (s,_,_,_,_) ->
+ ignore
+ (Visitor.visitFramacStmt (self:>Visitor.frama_c_visitor) s))
+ l;
+ false
+ | _ -> true
in
(* Default cases are not path choice points, as normal labels.
Non-default cases are ... just like if statements.
*)
let rec has_case_label labels =
match labels with
- | (Case _) :: _->
- self#incr_both_metrics incr_dpoints;
- | _ :: labels -> has_case_label labels
- | [] -> ()
+ | (Case _) :: _->
+ self#incr_both_metrics incr_dpoints;
+ | _ :: labels -> has_case_label labels
+ | [] -> ()
in has_case_label s.labels;
if do_children then Cil.DoChildren else Cil.SkipChildren
@@ -294,37 +294,37 @@ class slocVisitor ~libc : sloc_visitor = object(self)
begin
(* Logical ands and ors are lazy and generate two different paths *)
match e.enode with
- | BinOp ((LAnd | LOr), _, _, _) ->
- self#incr_both_metrics incr_dpoints;
- | _ -> ()
+ | BinOp ((LAnd | LOr), _, _, _) ->
+ self#incr_both_metrics incr_dpoints;
+ | _ -> ()
end;
Cil.DoChildren
method private image (glob:global) =
(* extract just the name of the global , for printing purposes *)
match glob with
- | GVar (v, _, _) -> v.vname ^ " (GVar) "
- | GVarDecl (v, _) -> v.vname ^ " (GVarDecl) "
- | GFunDecl (_, v, _) -> v.vname ^ " (GFunDecl) "
- | GFun (fdec, _) -> fdec.svar.vname ^ " (GFun) "
- | GType (ty, _) -> ty.tname
- | GCompTag (ci, _) | GCompTagDecl (ci, _) -> ci.cname
- | GEnumTagDecl (ei, _) | GEnumTag (ei, _) -> ei.ename
- | GAsm (_, _) | GPragma _ | GText _ -> ""
- | GAnnot (an,_) ->
- begin
- match an with
- | Dfun_or_pred (li, _) -> li.l_var_info.lv_name
- | Dvolatile (_, _, _, _, _) -> " (Volatile) "
- | Daxiomatic (s, _, _, _) -> s
- | Dtype (lti, _) -> lti.lt_name
- | Dlemma (ln, _, _, _, _, _, _) -> ln
- | Dinvariant (toto, _) -> toto.l_var_info.lv_name
- | Dtype_annot (ta, _) -> ta.l_var_info.lv_name
- | Dmodel_annot (mi, _) -> mi.mi_name
- | Dcustom_annot (_c, _n, _, _) -> " (Custom) "
- | Dextended ({ext_name}, _, _) -> " (Extension " ^ ext_name ^ ")"
- end
+ | GVar (v, _, _) -> v.vname ^ " (GVar) "
+ | GVarDecl (v, _) -> v.vname ^ " (GVarDecl) "
+ | GFunDecl (_, v, _) -> v.vname ^ " (GFunDecl) "
+ | GFun (fdec, _) -> fdec.svar.vname ^ " (GFun) "
+ | GType (ty, _) -> ty.tname
+ | GCompTag (ci, _) | GCompTagDecl (ci, _) -> ci.cname
+ | GEnumTagDecl (ei, _) | GEnumTag (ei, _) -> ei.ename
+ | GAsm (_, _) | GPragma _ | GText _ -> ""
+ | GAnnot (an,_) ->
+ begin
+ match an with
+ | Dfun_or_pred (li, _) -> li.l_var_info.lv_name
+ | Dvolatile (_, _, _, _, _) -> " (Volatile) "
+ | Daxiomatic (s, _, _, _) -> s
+ | Dtype (lti, _) -> lti.lt_name
+ | Dlemma (ln, _, _, _, _, _, _) -> ln
+ | Dinvariant (toto, _) -> toto.l_var_info.lv_name
+ | Dtype_annot (ta, _) -> ta.l_var_info.lv_name
+ | Dmodel_annot (mi, _) -> mi.mi_name
+ | Dcustom_annot (_c, _n, _, _) -> " (Custom) "
+ | Dextended ({ext_name}, _, _) -> " (Extension " ^ ext_name ^ ")"
+ end
method private images (globs:global list) =
(* extract just the names of the globals, for printing purposes *)
@@ -347,8 +347,8 @@ class slocVisitor ~libc : sloc_visitor = object(self)
| Call(v, e, _, _) ->
self#incr_both_metrics incr_calls;
(match e.enode with
- | Lval(Var vinfo, NoOffset) -> self#update_call_maps vinfo 1
- | _ -> ());
+ | Lval(Var vinfo, NoOffset) -> self#update_call_maps vinfo 1
+ | _ -> ());
(match v with
| Some _ -> self#incr_both_metrics incr_assigns
| None -> ());
@@ -553,35 +553,35 @@ let dump_html fmt cil_visitor =
let pr_row s fmt n =
Format.fprintf fmt
"@{<tr>@[<v 1>@ \
- @{<td class=\"entry\">%s@}@ \
- @{<td class=\"stat\">%d@}@]@ @} " s n
+ @{<td class=\"entry\">%s@}@ \
+ @{<td class=\"stat\">%d@}@]@ @} " s n
in
let pr_stats fmt visitor =
let metrics = visitor#get_global_metrics in
Format.fprintf fmt "@[<v 0>@{<table>%a@}@]"
(fun fmt metrics ->
- List.iter2 (fun text value -> pr_row text fmt value)
- ["SLOC"; "Number of if statements"; "Number of assignments";
- "Number of loops"; "Number of calls"; "Number of gotos";
- "Number of pointer accesses";]
- [metrics.cslocs; metrics.cifs; metrics.cassigns;
- metrics.cloops; metrics.ccalls; metrics.cgotos;
- metrics.cptrs;]) metrics
+ List.iter2 (fun text value -> pr_row text fmt value)
+ ["SLOC"; "Number of if statements"; "Number of assignments";
+ "Number of loops"; "Number of calls"; "Number of gotos";
+ "Number of pointer accesses";]
+ [metrics.cslocs; metrics.cifs; metrics.cassigns;
+ metrics.cloops; metrics.ccalls; metrics.cgotos;
+ metrics.cptrs;]) metrics
in
let pr_prelude fmt cil_visitor =
Format.fprintf fmt "@[<v 0>\
- @{<div>@ \
- @{<h1>@{<span>Metrics@}@}@ \
- @{<h2>Synthetic results@}@ <br/>@ \
- @{<span>Defined function(s)@} (%d): <br/>@ \
- @[ %a@]@ <br/>@ <br/>@ \
- @{<span>Undefined function(s)@} (%d):@ <br/>@ \
- @[ %a@]@ <br>@ <br/>@ \
- @{<span>'Extern' global variable(s)@} (%d):@ <br/>@ \
- @[ %a@]@ <br>@ <br/>@ \
- @{<span>Potential entry point(s)@} (%d):@ <br/>@ \
- @[ %a@]@ <br/>@ <br/>@ \
- @}@]"
+ @{<div>@ \
+ @{<h1>@{<span>Metrics@}@}@ \
+ @{<h2>Synthetic results@}@ <br/>@ \
+ @{<span>Defined function(s)@} (%d): <br/>@ \
+ @[ %a@]@ <br/>@ <br/>@ \
+ @{<span>Undefined function(s)@} (%d):@ <br/>@ \
+ @[ %a@]@ <br>@ <br/>@ \
+ @{<span>'Extern' global variable(s)@} (%d):@ <br/>@ \
+ @[ %a@]@ <br>@ <br/>@ \
+ @{<span>Potential entry point(s)@} (%d):@ <br/>@ \
+ @[ %a@]@ <br/>@ <br/>@ \
+ @}@]"
(VInfoMap.cardinal cil_visitor#fundef_calls)
Metrics_base.pretty_set cil_visitor#fundef_calls
(VInfoMap.cardinal cil_visitor#fundecl_calls)
@@ -593,29 +593,29 @@ let dump_html fmt cil_visitor =
in
let pr_detailed_results fmt cil_visitor =
Format.fprintf fmt "@[<v 0>\
- @{<div style=\"text-align: left;\">\
- @[<v 2>@ \
- @{<h2>Detailed results@}@ \
- @[<v 0>%a@ @]\
- @]@}"
+ @{<div style=\"text-align: left;\">\
+ @[<v 2>@ \
+ @{<h2>Detailed results@}@ \
+ @[<v 0>%a@ @]\
+ @]@}"
(fun fmt cil_visitor -> cil_visitor#print_stats fmt) cil_visitor
in
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>@ \
- %a@ \
- %a@ \
- %a@ \
- @]@}@}@]@?"
+ <!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>@ \
+ %a@ \
+ %a@ \
+ %a@ \
+ @]@}@}@]@?"
"Metrics"
Css_html.css
pr_prelude cil_visitor
@@ -631,12 +631,12 @@ let pp_funinfo fmt vis =
and fundecl_hdr = Format.sprintf "Undefined functions (%d)" nfundecl
and extern_hdr = Format.sprintf "'Extern' global variables (%d)" nextern
and entry_pts_hdr = Format.sprintf "Potential entry points (%d)"
- (Metrics_base.number_entry_points vis#fundef_calls) in
+ (Metrics_base.number_entry_points vis#fundef_calls) in
Format.fprintf fmt
"@[<v 0>@[<v 1>%a@ @[%a@]@]@ @ \
- @[<v 1>%a@ @[%a@]@]@ @ \
- @[<v 1>%a@ @[%a@]@]@ @ \
- @[<v 1>%a@ @[%a@]@]@ \
+ @[<v 1>%a@ @[%a@]@]@ @ \
+ @[<v 1>%a@ @[%a@]@]@ @ \
+ @[<v 1>%a@ @[%a@]@]@ \
@]"
(Metrics_base.mk_hdr 1) fundef_hdr
Metrics_base.pretty_set vis#fundef_calls
@@ -656,7 +656,7 @@ let pp_with_funinfo fmt cil_visitor =
let get_global_metrics ~libc =
let file = Ast.get () in
- (* Do as before *)
+ (* Do as before *)
let cil_visitor = new slocVisitor ~libc in
Visitor.visitFramacFileSameGlobals
(cil_visitor:>Visitor.frama_c_visitor) file;
@@ -665,7 +665,7 @@ let get_global_metrics ~libc =
let get_metrics_map ~libc =
let file = Ast.get () in
- (* Do as before *)
+ (* Do as before *)
let cil_visitor = new slocVisitor ~libc in
Visitor.visitFramacFileSameGlobals
(cil_visitor:>Visitor.frama_c_visitor) file;
@@ -695,7 +695,7 @@ let compute_on_cilast ~libc =
if Metrics_parameters.ByFunction.get () then
Metrics_parameters.result
"@[<v 0>Cil AST@ %t@]" cil_visitor#pp_detailed_text_metrics;
-(* let r = metrics_to_result cil_visitor in *)
+ (* let r = metrics_to_result cil_visitor in *)
(* Print the result to file if required *)
let out_fname = Metrics_parameters.OutputFile.get () in
begin
@@ -704,8 +704,8 @@ let compute_on_cilast ~libc =
let oc = open_out_bin out_fname in
let fmt = Format.formatter_of_out_channel oc in
(match Metrics_base.get_file_type out_fname with
- | Html -> dump_html fmt cil_visitor
- | Text -> pp_with_funinfo fmt cil_visitor
+ | Html -> dump_html fmt cil_visitor
+ | Text -> pp_with_funinfo fmt cil_visitor
);
close_out oc;
with Sys_error _ ->
diff --git a/src/plugins/scope/dpds_gui.ml b/src/plugins/scope/dpds_gui.ml
index 653948a6f57..12b023263b3 100644
--- a/src/plugins/scope/dpds_gui.ml
+++ b/src/plugins/scope/dpds_gui.ml
@@ -52,18 +52,18 @@ let ask_for_lval (main_ui:Design.main_window_extension_points) kf =
Gtk_helper.input_string
~parent:main_ui#main_window ~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
- let lval =
- !Db.Properties.Interp.term_lval_to_lval ~result:None term_lval
- in
- Some (txt, lval)
- with e ->
- main_ui#error "[ask for lval] '%s' invalid expression: %s@."
- txt (Printexc.to_string e);
- None
+ match txt with None | Some "" -> None
+ | Some txt ->
+ try
+ let term_lval = !Db.Properties.Interp.term_lval kf txt in
+ let lval =
+ !Db.Properties.Interp.term_lval_to_lval ~result:None term_lval
+ in
+ Some (txt, lval)
+ with e ->
+ main_ui#error "[ask for lval] '%s' invalid expression: %s@."
+ txt (Printexc.to_string e);
+ None
let get_annot_opt localizable = match localizable with
| Pretty_source.PIP(Property.(IPCodeAnnot {ica_ca})) -> Some ica_ca
@@ -72,25 +72,25 @@ let get_annot_opt localizable = match localizable with
(** [kf_opt] is used if we want to ask the lval to the user in a popup *)
let get_lval_opt main_ui kf_opt localizable =
match localizable with
- | Pretty_source.PLval (Some _kf, (Kstmt _stmt), lv) ->
- let lv_txt = Format.asprintf "%a" Printer.pp_lval lv in
+ | Pretty_source.PLval (Some _kf, (Kstmt _stmt), lv) ->
+ let lv_txt = Format.asprintf "%a" Printer.pp_lval lv in
+ Some (lv_txt, lv)
+ | PTermLval (Some _kf, Kstmt _stmt, _, tlv) -> begin
+ try
+ let lv =
+ !Db.Properties.Interp.term_lval_to_lval ~result:None tlv
+ in
+ let lv_txt = Format.asprintf "%a" Printer.pp_term_lval tlv in
Some (lv_txt, lv)
- | PTermLval (Some _kf, Kstmt _stmt, _, tlv) -> begin
- try
- let lv =
- !Db.Properties.Interp.term_lval_to_lval ~result:None tlv
- in
- let lv_txt = Format.asprintf "%a" Printer.pp_term_lval tlv in
- Some (lv_txt, lv)
- with Invalid_argument _ -> None
- end
- | _ ->
- ( match kf_opt with
- None -> None
- | Some kf ->
- match (ask_for_lval main_ui kf) with
- None -> None
- | Some (lv_txt, lv) -> Some (lv_txt, lv))
+ with Invalid_argument _ -> None
+ end
+ | _ ->
+ ( match kf_opt with
+ None -> None
+ | Some kf ->
+ match (ask_for_lval main_ui kf) with
+ None -> None
+ | Some (lv_txt, lv) -> Some (lv_txt, lv))
let eval_lval =
let typ_lval_to_zone_gui = Datatype.func2 Stmt.ty Lval.ty Locations.Zone.ty in
@@ -98,54 +98,54 @@ let eval_lval =
module Kf_containing_highlighted_stmt =
Kernel_function.Make_Table
- (Datatype.String.Set)
- (struct
- let name = "Dpds_gui.Kf_containing_highlighted_stmt"
- let size = 7
- let dependencies =
- [ (*Dependencies are managed manually by Make_StmtSetState*) ]
- end)
+ (Datatype.String.Set)
+ (struct
+ let name = "Dpds_gui.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_StmtSetState (Info:sig val name: string end) =
- struct include State_builder.Ref
+struct include State_builder.Ref
(Stmt.Hptset)
(struct
- let name = Info.name
- let dependencies = [ Db.Value.self ]
- let default () = Stmt.Hptset.empty
- end)
-
- let set s =
- set s;
- Kf_containing_highlighted_stmt.clear ();
- Stmt.Hptset.iter
- (fun stmt ->
+ let name = Info.name
+ let dependencies = [ Db.Value.self ]
+ let default () = Stmt.Hptset.empty
+ end)
+
+ let set s =
+ set s;
+ Kf_containing_highlighted_stmt.clear ();
+ Stmt.Hptset.iter
+ (fun stmt ->
Kf_containing_highlighted_stmt.replace
(Kernel_function.find_englobing_kf stmt) default_icon)
- s;
- !update_column `Contents
+ s;
+ !update_column `Contents
- end
+end
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;
- Kf_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;
+ Kf_containing_highlighted_stmt.clear ();
+ Stmt.Map.iter
+ (fun stmt s ->
let kf = Kernel_function.find_englobing_kf stmt in
let prev =
try Kf_containing_highlighted_stmt.find kf
@@ -153,10 +153,10 @@ module Make_StmtMapState (Info:sig val name: string end) =
in
let union = D.String.Set.union prev s in
Kf_containing_highlighted_stmt.replace kf union)
- s;
- !update_column `Contents
+ s;
+ !update_column `Contents
- end
+end
module type DpdCmdSig = sig
@@ -187,14 +187,14 @@ module DataScope : (DpdCmdSig with type t_in = lval) = struct
let clear () = Fscope.clear(); FBscope.clear(); Bscope.clear()
let help = ("[data_scope] "
- ^"highlight the statements where the value of D is the same "
- ^"than at its value at L.\n\t"
- ^"For more information, please look at the Scope plugin documentation.")
+ ^"highlight the statements where the value of D is the same "
+ ^"than at its value at L.\n\t"
+ ^"For more information, please look at the Scope plugin documentation.")
let get_info _kf_stmt_opt =
if Stmt.Hptset.is_empty (Fscope.get ())
- && Stmt.Hptset.is_empty (FBscope.get ())
- && Stmt.Hptset.is_empty (Bscope.get ())
+ && Stmt.Hptset.is_empty (FBscope.get ())
+ && Stmt.Hptset.is_empty (Bscope.get ())
then ""
else "[scope] selected"
@@ -225,13 +225,13 @@ module Pscope (* : (DpdCmdSig with type t_in = code_annotation) *) = struct
(struct
let name = "Dpds_gui.Highlighter.Pscope_warn"
let dependencies = [ Db.Value.self ]
- end)
+ end)
let clear () = Pscope.clear(); Pscope_warn.clear()
let help = ("[prop_scope] "
- ^"highlight the statements where the value of the assertion is also ok\n\t"
- ^"For more information, please look at the Scope plugin documentation.")
+ ^"highlight the statements where the value of the assertion is also ok\n\t"
+ ^"For more information, please look at the Scope plugin documentation.")
let get_info _kf_stmt_opt =
if Stmt.Hptset.is_empty (Pscope.get ())
@@ -245,7 +245,7 @@ module Pscope (* : (DpdCmdSig with type t_in = code_annotation) *) = struct
let tag_stmt stmt =
(*if Stmt.Hptset.mem stmt (Pscope_warn.get()) then scope_p_warn_tag
- else*) if Stmt.Hptset.mem stmt (Pscope.get()) then scope_p_tag
+ else*) if Stmt.Hptset.mem stmt (Pscope.get()) then scope_p_tag
else empty_tag
let tag_annot annot =
@@ -265,10 +265,10 @@ module ShowDef : (DpdCmdSig with type t_in = lval) = struct
let clear () = ShowDefState.clear()
let help = ("[show_def] "
- ^"highlight the statements that define the value of D at L,\n\t"
- ^"and print a message if a part of D might be undefined.\n\t"
- ^"Notice that 'undefined' only means here "
- ^"not defined on some path from the beginning of the function.")
+ ^"highlight the statements that define the value of D at L,\n\t"
+ ^"and print a message if a part of D might be undefined.\n\t"
+ ^"Notice that 'undefined' only means here "
+ ^"not defined on some path from the beginning of the function.")
let get_info _kf_stmt_opt =
@@ -292,18 +292,18 @@ module ShowDef : (DpdCmdSig with type t_in = lval) = struct
let r = Defs.compute_with_def_type_zone kf stmt z in
Datascope.R.feedback "Defs computed";
match r with
- | None -> clear ();
- "[Show Defs] nothing found. The information about some functions \
- may be missing."
- | Some (defs, undef) ->
- let msg = match undef with
- | None -> ""
- | Some undef ->
- Format.asprintf "[Show Defs] notice that %a %s"
- pretty_zone undef
- "may not be defined by this function at this point"
- in
- ShowDefState.set (conv defs); msg
+ | None -> clear ();
+ "[Show Defs] nothing found. The information about some functions \
+ may be missing."
+ | Some (defs, undef) ->
+ let msg = match undef with
+ | None -> ""
+ | Some undef ->
+ Format.asprintf "[Show Defs] notice that %a %s"
+ pretty_zone undef
+ "may not be defined by this function at this point"
+ in
+ ShowDefState.set (conv defs); msg
let tag_stmt stmt =
try
@@ -319,49 +319,49 @@ module Zones : (DpdCmdSig with type t_in = lval) = struct
type t_in = lval
module ZonesState =
- struct include State_builder.Option_ref
+ struct include State_builder.Option_ref
(Datatype.Pair
(Stmt.Hashtbl.Make(Locations.Zone))
(Stmt.Hptset))
(struct
- let name = "Dpds_gui.Highlighter.ZonesState"
- let dependencies = [ Db.Value.self ]
- end)
+ let name = "Dpds_gui.Highlighter.ZonesState"
+ let dependencies = [ Db.Value.self ]
+ end)
let set s =
set s;
Kf_containing_highlighted_stmt.clear ();
Stmt.Hptset.iter
(fun stmt ->
- Kf_containing_highlighted_stmt.replace
- (Kernel_function.find_englobing_kf stmt) default_icon)
+ Kf_containing_highlighted_stmt.replace
+ (Kernel_function.find_englobing_kf stmt) default_icon)
(snd s);
- !update_column `Contents
- end
+ !update_column `Contents
+ end
let clear () = ZonesState.clear ()
let help =
("[zones] computes, for each point Li of the function, "
- ^"the data Di needed to know the value of D at L.\n"
- ^"\tAfter this computation, the result Di will be printed in the "
+ ^"the data Di needed to know the value of D at L.\n"
+ ^"\tAfter this computation, the result Di will be printed in the "
^" information window each time a statement Li is selected.")
let get_info kf_stmt_opt =
try
let zones, _ = ZonesState.get () in
- match kf_stmt_opt with
- | None -> "[zones] no information for this point"
- | Some (_kf, stmt) ->
- let z = Zones.get_zones zones stmt in
- let txt =
- Format.asprintf "[zones] needed before stmt %d = %a"
- stmt.sid pretty_zone z
- in txt
+ match kf_stmt_opt with
+ | None -> "[zones] no information for this point"
+ | Some (_kf, stmt) ->
+ let z = Zones.get_zones zones stmt in
+ let txt =
+ Format.asprintf "[zones] needed before stmt %d = %a"
+ stmt.sid pretty_zone z
+ in txt
with Not_found -> ""
let compute kf stmt lval =
let used_stmts, zones = Zones.build_zones kf stmt lval in
- ZonesState.set (zones, used_stmts);
- "[zones] computed"
+ ZonesState.set (zones, used_stmts);
+ "[zones] computed"
let tag_stmt stmt =
let is_used =
@@ -370,32 +370,32 @@ module Zones : (DpdCmdSig with type t_in = lval) = struct
Stmt.Hptset.mem stmt used
with Not_found -> false
in
- if is_used then zones_used_tag else empty_tag
+ if is_used then zones_used_tag else empty_tag
end
let help (main_ui:Design.main_window_extension_points) =
let add txt = add_msg main_ui txt in
- add ("General : "
- ^"each of these commands starts from a data D at a program point L.\n\t"
- ^"The program point is the one that is before the selected statement,\n\t"
+ add ("General : "
+ ^"each of these commands starts from a data D at a program point L.\n\t"
+ ^"The program point is the one that is before the selected statement,\n\t"
^"and the data is the one that is selected if any, "
^"or it can be given via a popup.\n"
^"\tIf the text given in the popup is empty, or 'Cancel' is chosen, "
^"the selection of the command is reset.");
- add (ShowDef.help);
- add (Zones.help);
- add (DataScope.help);
- add (Pscope.help);
- add ("Reset : reset the internal state for all the previous commands.")
+ add (ShowDef.help);
+ add (Zones.help);
+ add (DataScope.help);
+ add (Pscope.help);
+ add ("Reset : reset the internal state for all the previous commands.")
module DpdsState =
State_builder.Option_ref
(Stmt)
(struct
- let name = "Dpds_gui.Highlighter.DpdsState"
- let dependencies = [ Db.Value.self ]
- end)
+ let name = "Dpds_gui.Highlighter.DpdsState"
+ let dependencies = [ Db.Value.self ]
+ end)
let reset () =
DpdsState.clear ();
@@ -422,8 +422,8 @@ let callbacks funct main_ui (kf, stmt, localizable) =
in
let set_txt x =
let txt = Format.asprintf
- "[dependencies] for %s before stmt %d in %a"
- x stmt.sid Kernel_function.pretty kf
+ "[dependencies] for %s before stmt %d in %a"
+ x stmt.sid Kernel_function.pretty kf
in
DpdsState.set stmt;
add_msg main_ui txt
@@ -455,7 +455,7 @@ let highlighter (buffer:Design.reactive_buffer) localizable ~start ~stop =
let buffer = buffer#buffer in
let start_s = DpdsState.get () in
let put_tag tag = match tag with ("",[]) -> ()
- | _ -> add_tag buffer tag start stop
+ | _ -> add_tag buffer tag start stop
in
match localizable with
| PStmt (_,stmt) ->
@@ -474,42 +474,42 @@ let check_value (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.\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.\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 add a sensitive/insensitive 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 [~use_values], check if the value analysis has been computed.
- *)
+ * The menu item is insensitive when [arg_opt = None],
+ * else, when the item is selected, the callback is called with the argument.
+ * If [~use_values], check if the value analysis has been computed.
+*)
let add_item (main_ui:Design.main_window_extension_points)
- ~use_values (factory:GMenu.menu GMenu.factory) name arg_opt callback =
- match arg_opt with
- | None -> (* add the menu item, but it isn't sensitive *)
- let item = factory#add_item name ~callback: (fun () -> ())
- in item#misc#set_sensitive false
- | Some arg -> (* add the menu item with its callback *)
- let cb arg =
- if use_values then
- if check_value main_ui then callback arg else ()
- else callback arg
- in
- ignore (factory#add_item name ~callback: (fun () -> cb arg))
+ ~use_values (factory:GMenu.menu GMenu.factory) name arg_opt callback =
+ match arg_opt with
+ | None -> (* add the menu item, but it isn't sensitive *)
+ let item = factory#add_item name ~callback: (fun () -> ())
+ in item#misc#set_sensitive false
+ | Some arg -> (* add the menu item with its callback *)
+ let cb arg =
+ if use_values then
+ if check_value main_ui then callback arg else ()
+ else callback arg
+ in
+ ignore (factory#add_item name ~callback: (fun () -> cb arg))
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 "Dependencies" in
@@ -544,32 +544,32 @@ let filetree_decorate main_ui =
main_ui#file_tree#append_pixbuf_column
~title:"Scope"
(fun globs ->
- let icons = function
- | GFun ({svar = v }, _) ->
- (try Kf_containing_highlighted_stmt.find (Globals.Functions.get v)
- with Not_found -> Datatype.String.Set.empty)
- | _ -> Datatype.String.Set.empty
- in
- let ids =
- if Kf_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 Kf_containing_highlighted_stmt.find (Globals.Functions.get v)
+ with Not_found -> Datatype.String.Set.empty)
+ | _ -> Datatype.String.Set.empty
+ in
+ let ids =
+ if Kf_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 _ -> Kf_containing_highlighted_stmt.length () <>0)
diff --git a/src/plugins/wp/dyncall.ml b/src/plugins/wp/dyncall.ml
index ad7bbf995c3..8b0dedf82a8 100644
--- a/src/plugins/wp/dyncall.ml
+++ b/src/plugins/wp/dyncall.ml
@@ -140,47 +140,47 @@ class dyncall =
| Cil_types.AExtended
(bhvs, _,
({ext_name = "calls"; ext_kind = Ext_terms calls} as extended)) ->
- if calls <> [] && (scope <> [] || not (Stack.is_empty block_calls))
- then begin
- let bhvs =
- match bhvs with
- | [] -> [ Cil.default_behavior_name ]
- | bhvs -> bhvs
- in
- let debug_calls bhv stmt kfs =
- if Wp_parameters.has_dkey dkey_calls then
- let source = snd (Stmt.loc stmt) in
- if Cil.default_behavior_name = bhv then
- Wp_parameters.result ~source
- "@[<hov 2>Calls%a@]" pp_calls kfs
- else
- Wp_parameters.result ~source
- "@[<hov 2>Calls (for %s)%a@]" bhv pp_calls kfs
- in
- let pool = ref [] in (* collect emitted properties *)
- let add_calls_info kf stmt =
- count <- succ count ;
+ if calls <> [] && (scope <> [] || not (Stack.is_empty block_calls))
+ then begin
+ let bhvs =
+ match bhvs with
+ | [] -> [ Cil.default_behavior_name ]
+ | bhvs -> bhvs
+ in
+ let debug_calls bhv stmt kfs =
+ if Wp_parameters.has_dkey dkey_calls then
+ let source = snd (Stmt.loc stmt) in
+ if Cil.default_behavior_name = bhv then
+ Wp_parameters.result ~source
+ "@[<hov 2>Calls%a@]" pp_calls kfs
+ else
+ Wp_parameters.result ~source
+ "@[<hov 2>Calls (for %s)%a@]" bhv pp_calls kfs
+ in
+ let pool = ref [] in (* collect emitted properties *)
+ let add_calls_info kf stmt =
+ count <- succ count ;
+ List.iter
+ (fun bhv ->
+ let kfs = List.map get_call calls in
+ debug_calls bhv stmt kfs ;
+ let prop = property ~kf ~bhv ~stmt kfs in
+ pool := prop :: !pool ;
+ CallPoints.add (bhv,stmt) (prop,kfs))
+ bhvs
+ in
+ let kf = self#kf in
List.iter
- (fun bhv ->
- let kfs = List.map get_call calls in
- debug_calls bhv stmt kfs ;
- let prop = property ~kf ~bhv ~stmt kfs in
- pool := prop :: !pool ;
- CallPoints.add (bhv,stmt) (prop,kfs))
- bhvs
- in
- let kf = self#kf in
- List.iter
- (add_calls_info kf)
- (if scope <> [] then scope else Stack.top block_calls) ;
- if !pool <> [] then
- begin
- let eloc = Property.ELStmt(kf,self#stmt) in
- let annot = Property.ip_of_extended eloc extended in
- Property_status.logical_consequence emitter annot !pool ;
- end
- end;
- SkipChildren
+ (add_calls_info kf)
+ (if scope <> [] then scope else Stack.top block_calls) ;
+ if !pool <> [] then
+ begin
+ let eloc = Property.ELStmt(kf,self#stmt) in
+ let annot = Property.ip_of_extended eloc extended in
+ Property_status.logical_consequence emitter annot !pool ;
+ end
+ end;
+ SkipChildren
| _ -> SkipChildren
method! vspec spec =
diff --git a/src/plugins/wp/wpPropId.ml b/src/plugins/wp/wpPropId.ml
index 404100399b5..f05d72b2ece 100644
--- a/src/plugins/wp/wpPropId.ml
+++ b/src/plugins/wp/wpPropId.ml
@@ -580,9 +580,9 @@ let propid_hints hs p =
match p.p_kind , p.p_prop with
| PKCheck , _ -> ()
| PKProp , Property.(IPAssigns {ias_kinstr=Kstmt _}) ->
- add_required hs "stmt-assigns"
+ add_required hs "stmt-assigns"
| PKProp , Property.(IPAssigns {ias_kinstr=Kglobal}) ->
- add_required hs "fct-assigns"
+ add_required hs "fct-assigns"
| PKPropLoop , Property.IPAssigns _ -> add_required hs "loop-assigns"
| PKPropLoop , _ -> add_required hs "invariant"
| PKProp , _ -> add_required hs "property"
@@ -629,12 +629,12 @@ let property_hints hs =
let open Property in function
| IPAxiom {il_name; il_pred}
| IPLemma {il_name; il_pred} ->
- List.iter (add_required hs) (il_name::il_pred.pred_name)
+ List.iter (add_required hs) (il_name::il_pred.pred_name)
| IPBehavior _ -> ()
| IPComplete {ic_bhvs} | IPDisjoint {ic_bhvs} ->
- List.iter (add_required hs) ic_bhvs
+ List.iter (add_required hs) ic_bhvs
| IPPredicate {ip_pred} ->
- List.iter (add_hint hs) ip_pred.ip_content.pred_name
+ List.iter (add_hint hs) ip_pred.ip_content.pred_name
| IPExtended {ie_ext={ext_name}} -> List.iter (add_hint hs) [ext_name]
| IPCodeAnnot {ica_ca} -> annot_hints hs ica_ca.annot_content
| IPAssigns {ias_froms} -> assigns_hints hs ias_froms
@@ -1016,7 +1016,7 @@ let get_induction p =
| Some (kf, s) -> get_loop_stmt kf s
in loop_stmt_opt
| PKPropLoop ->
- let open Property in
+ let open Property in
let loop_stmt_opt = match property_of_id p with
| IPCodeAnnot {ica_kf; ica_stmt;
ica_ca = {annot_content = AInvariant(_, loop, _)}} ->
--
GitLab