From 87a13c257bfd5a53b6803bc2d714afb13106c243 Mon Sep 17 00:00:00 2001 From: Hans Bolinder Date: Fri, 16 Sep 2016 11:54:57 +0200 Subject: dialyzer: Fix opaque bugs t_from_form() sometimes returned a more general type than it should have done due to a bug in from_form_loop(): it stopped when the limit was exceeded, which could mean a collapsed type. Returning a type with smaller depth should fix this. is_specialization() now handles opaque types before unions, which should fix another problem. The bugs reported by Kostis. --- .../test/opaque_SUITE_data/dialyzer_options | 2 +- .../test/opaque_SUITE_data/src/recrec/cerl.erl | 4602 ++++++++++++++++ .../opaque_SUITE_data/src/recrec/core_parse.hrl | 122 + .../test/opaque_SUITE_data/src/recrec/dialyzer.hrl | 180 + .../src/recrec/dialyzer_dataflow.erl | 3802 +++++++++++++ .../src/recrec/dialyzer_races.erl | 2494 +++++++++ .../opaque_SUITE_data/src/recrec/erl_types.erl | 5741 ++++++++++++++++++++ 7 files changed, 16942 insertions(+), 1 deletion(-) create mode 100644 lib/dialyzer/test/opaque_SUITE_data/src/recrec/cerl.erl create mode 100644 lib/dialyzer/test/opaque_SUITE_data/src/recrec/core_parse.hrl create mode 100644 lib/dialyzer/test/opaque_SUITE_data/src/recrec/dialyzer.hrl create mode 100644 lib/dialyzer/test/opaque_SUITE_data/src/recrec/dialyzer_dataflow.erl create mode 100644 lib/dialyzer/test/opaque_SUITE_data/src/recrec/dialyzer_races.erl create mode 100644 lib/dialyzer/test/opaque_SUITE_data/src/recrec/erl_types.erl (limited to 'lib/dialyzer') diff --git a/lib/dialyzer/test/opaque_SUITE_data/dialyzer_options b/lib/dialyzer/test/opaque_SUITE_data/dialyzer_options index ffdf8270c8..06ed52043a 100644 --- a/lib/dialyzer/test/opaque_SUITE_data/dialyzer_options +++ b/lib/dialyzer/test/opaque_SUITE_data/dialyzer_options @@ -1,2 +1,2 @@ {dialyzer_options, [{warnings, [no_unused, no_return]}]}. -{time_limit, 2}. +{time_limit, 20}. diff --git a/lib/dialyzer/test/opaque_SUITE_data/src/recrec/cerl.erl b/lib/dialyzer/test/opaque_SUITE_data/src/recrec/cerl.erl new file mode 100644 index 0000000000..a4fdbfd5f0 --- /dev/null +++ b/lib/dialyzer/test/opaque_SUITE_data/src/recrec/cerl.erl @@ -0,0 +1,4602 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2001-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% + +%% ===================================================================== +%% @doc Core Erlang abstract syntax trees. +%% +%%

This module defines an abstract data type for representing Core +%% Erlang source code as syntax trees.

+%% +%%

A recommended starting point for the first-time user is the +%% documentation of the function type/1.

+%% +%%

NOTES:

+%% +%%

This module deals with the composition and decomposition of +%% syntactic entities (as opposed to semantic ones); its +%% purpose is to hide all direct references to the data structures +%% used to represent these entities. With few exceptions, the +%% functions in this module perform no semantic interpretation of +%% their inputs, and in general, the user is assumed to pass +%% type-correct arguments - if this is not done, the effects are not +%% defined.

+%% +%%

Currently, the internal data structure used is the same as +%% the record-based data structures used traditionally in the Beam +%% compiler.

+%% +%%

The internal representations of abstract syntax trees are +%% subject to change without notice, and should not be documented +%% outside this module. Furthermore, we do not give any guarantees on +%% how an abstract syntax tree may or may not be represented, with +%% the following exceptions: no syntax tree is represented by a +%% single atom, such as none, by a list constructor +%% [X | Y], or by the empty list []. This +%% can be relied on when writing functions that operate on syntax +%% trees.

+%% +%% @type cerl(). An abstract Core Erlang syntax tree. +%% +%%

Every abstract syntax tree has a type, given by the +%% function type/1. In addition, +%% each syntax tree has a list of user annotations (cf. get_ann/1), which are included +%% in the Core Erlang syntax.

+ +-module(cerl). + +-export([abstract/1, add_ann/2, alias_pat/1, alias_var/1, + ann_abstract/2, ann_c_alias/3, ann_c_apply/3, ann_c_atom/2, + ann_c_call/4, ann_c_case/3, ann_c_catch/2, ann_c_char/2, + ann_c_clause/3, ann_c_clause/4, ann_c_cons/3, ann_c_float/2, + ann_c_fname/3, ann_c_fun/3, ann_c_int/2, ann_c_let/4, + ann_c_letrec/3, ann_c_module/4, ann_c_module/5, ann_c_nil/1, + ann_c_cons_skel/3, ann_c_tuple_skel/2, ann_c_primop/3, + ann_c_receive/2, ann_c_receive/4, ann_c_seq/3, ann_c_string/2, + ann_c_try/6, ann_c_tuple/2, ann_c_values/2, ann_c_var/2, + ann_make_data/3, ann_make_list/2, ann_make_list/3, + ann_make_data_skel/3, ann_make_tree/3, apply_args/1, + apply_arity/1, apply_op/1, atom_lit/1, atom_name/1, atom_val/1, + c_alias/2, c_apply/2, c_atom/1, c_call/3, c_case/2, c_catch/1, + c_char/1, c_clause/2, c_clause/3, c_cons/2, c_float/1, + c_fname/2, c_fun/2, c_int/1, c_let/3, c_letrec/2, c_module/3, + c_module/4, c_nil/0, c_cons_skel/2, c_tuple_skel/1, c_primop/2, + c_receive/1, c_receive/3, c_seq/2, c_string/1, c_try/5, + c_tuple/1, c_values/1, c_var/1, call_args/1, call_arity/1, + call_module/1, call_name/1, case_arg/1, case_arity/1, + case_clauses/1, catch_body/1, char_lit/1, char_val/1, + clause_arity/1, clause_body/1, clause_guard/1, clause_pats/1, + clause_vars/1, concrete/1, cons_hd/1, cons_tl/1, copy_ann/2, + data_arity/1, data_es/1, data_type/1, float_lit/1, float_val/1, + fname_arity/1, fname_id/1, fold_literal/1, from_records/1, + fun_arity/1, fun_body/1, fun_vars/1, get_ann/1, int_lit/1, + int_val/1, is_c_alias/1, is_c_apply/1, is_c_atom/1, + is_c_call/1, is_c_case/1, is_c_catch/1, is_c_char/1, + is_c_clause/1, is_c_cons/1, is_c_float/1, is_c_fname/1, + is_c_fun/1, is_c_int/1, is_c_let/1, is_c_letrec/1, is_c_list/1, + is_c_module/1, is_c_nil/1, is_c_primop/1, is_c_receive/1, + is_c_seq/1, is_c_string/1, is_c_try/1, is_c_tuple/1, + is_c_values/1, is_c_var/1, is_data/1, is_leaf/1, is_literal/1, + is_literal_term/1, is_print_char/1, is_print_string/1, + let_arg/1, let_arity/1, let_body/1, let_vars/1, letrec_body/1, + letrec_defs/1, letrec_vars/1, list_elements/1, list_length/1, + make_data/2, make_list/1, make_list/2, make_data_skel/2, + make_tree/2, meta/1, module_attrs/1, module_defs/1, + module_exports/1, module_name/1, module_vars/1, + pat_list_vars/1, pat_vars/1, primop_args/1, primop_arity/1, + primop_name/1, receive_action/1, receive_clauses/1, + receive_timeout/1, seq_arg/1, seq_body/1, set_ann/2, + string_lit/1, string_val/1, subtrees/1, to_records/1, + try_arg/1, try_body/1, try_vars/1, try_evars/1, try_handler/1, + tuple_arity/1, tuple_es/1, type/1, unfold_literal/1, + update_c_alias/3, update_c_apply/3, update_c_call/4, + update_c_case/3, update_c_catch/2, update_c_clause/4, + update_c_cons/3, update_c_cons_skel/3, update_c_fname/2, + update_c_fname/3, update_c_fun/3, update_c_let/4, + update_c_letrec/3, update_c_module/5, update_c_primop/3, + update_c_receive/4, update_c_seq/3, update_c_try/6, + update_c_tuple/2, update_c_tuple_skel/2, update_c_values/2, + update_c_var/2, update_data/3, update_list/2, update_list/3, + update_data_skel/3, update_tree/2, update_tree/3, + values_arity/1, values_es/1, var_name/1, c_binary/1, + update_c_binary/2, ann_c_binary/2, is_c_binary/1, + binary_segments/1, c_bitstr/3, c_bitstr/4, c_bitstr/5, + update_c_bitstr/5, update_c_bitstr/6, ann_c_bitstr/5, + ann_c_bitstr/6, is_c_bitstr/1, bitstr_val/1, bitstr_size/1, + bitstr_bitsize/1, bitstr_unit/1, bitstr_type/1, bitstr_flags/1, + + %% keep map exports here for now + c_map_pattern/1, + is_c_map/1, + is_c_map_pattern/1, + map_es/1, + map_arg/1, + update_c_map/3, + c_map/1, is_c_map_empty/1, + ann_c_map/2, ann_c_map/3, + ann_c_map_pattern/2, + map_pair_op/1,map_pair_key/1,map_pair_val/1, + update_c_map_pair/4, + c_map_pair/2, c_map_pair_exact/2, + ann_c_map_pair/4 + ]). + +-export_type([c_binary/0, c_bitstr/0, c_call/0, c_clause/0, c_cons/0, c_fun/0, + c_let/0, c_literal/0, c_map/0, c_map_pair/0, + c_module/0, c_tuple/0, + c_values/0, c_var/0, cerl/0, + anns/0, attrs/0, defs/0, litval/0, var_name/0]). + +-include("core_parse.hrl"). + +-type c_alias() :: #c_alias{}. +-type c_apply() :: #c_apply{}. +-type c_binary() :: #c_binary{}. +-type c_bitstr() :: #c_bitstr{}. +-type c_call() :: #c_call{}. +-type c_case() :: #c_case{}. +-type c_catch() :: #c_catch{}. +-type c_clause() :: #c_clause{}. +-type c_cons() :: #c_cons{}. +-type c_fun() :: #c_fun{}. +-type c_let() :: #c_let{}. +-type c_letrec() :: #c_letrec{}. +-type c_literal() :: #c_literal{}. +-type c_map() :: #c_map{}. +-type c_map_pair() :: #c_map_pair{}. +-type c_module() :: #c_module{}. +-type c_primop() :: #c_primop{}. +-type c_receive() :: #c_receive{}. +-type c_seq() :: #c_seq{}. +-type c_try() :: #c_try{}. +-type c_tuple() :: #c_tuple{}. +-type c_values() :: #c_values{}. +-type c_var() :: #c_var{}. + +-type cerl() :: c_alias() | c_apply() | c_binary() | c_bitstr() + | c_call() | c_case() | c_catch() | c_clause() | c_cons() + | c_fun() | c_let() | c_letrec() | c_literal() + | c_map() | c_map_pair() + | c_module() | c_primop() | c_receive() | c_seq() + | c_try() | c_tuple() | c_values() | c_var(). + +-type anns() :: [term()]. +-type attr() :: {c_literal(), c_literal()}. +-type attrs() :: [attr()]. +-type def() :: {c_var(), c_fun()}. +-type defs() :: [def()]. + +-type litval() :: atom() | bitstring() | map() | number() + | string() | tuple() | [litval()]. + +-type var_name() :: integer() | atom() | {atom(), arity()}. + + +%% ===================================================================== +%% Representation (general) +%% +%% All nodes are represented by tuples of arity 2 or (generally) +%% greater, whose first element is an atom which uniquely identifies the +%% type of the node, and whose second element is a (proper) list of +%% annotation terms associated with the node - this is by default empty. +%% +%% For most node constructor functions, there are analogous functions +%% named 'ann_...', taking one extra argument 'As' (always the first +%% argument), specifying an annotation list at node creation time. +%% Similarly, there are also functions named 'update_...', taking one +%% extra argument 'Old', specifying a node from which all fields not +%% explicitly given as arguments should be copied (generally, this is +%% the annotation field only). +%% ===================================================================== + +%% @spec type(Node::cerl()) -> atom() +%% +%% @doc Returns the type tag of Node. Current node types +%% are: +%% +%%

+%% +%% +%% +%% +%% +%% +%% +%% +%% +%% +%% +%% +%% +%% +%% +%% +%% +%% +%% +%% +%% +%% +%% +%% +%% +%% +%% +%%
aliasapplybinarybitstrcallcasecatchclause
consfunletletrecliteralmapmap_pairmodule
primopreceiveseqtrytuplevaluesvar

+%% +%%

Note: The name of the primary constructor function for a node +%% type is always the name of the type itself, prefixed by +%% "c_"; recognizer predicates are correspondingly +%% prefixed by "is_c_". Furthermore, to simplify +%% preservation of annotations (cf. get_ann/1), there are +%% analogous constructor functions prefixed by "ann_c_" +%% and "update_c_", for setting the annotation list of +%% the new node to either a specific value or to the annotations of an +%% existing node, respectively.

+%% +%% @see abstract/1 +%% @see c_alias/2 +%% @see c_apply/2 +%% @see c_binary/1 +%% @see c_bitstr/5 +%% @see c_call/3 +%% @see c_case/2 +%% @see c_catch/1 +%% @see c_clause/3 +%% @see c_cons/2 +%% @see c_fun/2 +%% @see c_let/3 +%% @see c_letrec/2 +%% @see c_module/3 +%% @see c_primop/2 +%% @see c_receive/1 +%% @see c_seq/2 +%% @see c_try/5 +%% @see c_tuple/1 +%% @see c_values/1 +%% @see c_var/1 +%% @see get_ann/1 +%% @see to_records/1 +%% @see from_records/1 +%% @see data_type/1 +%% @see subtrees/1 +%% @see meta/1 + +-type ctype() :: 'alias' | 'apply' | 'binary' | 'bitrst' | 'call' | 'case' + | 'catch' | 'clause' | 'cons' | 'fun' | 'let' | 'letrec' + | 'literal' | 'map' | 'map_pair' | 'module' | 'primop' + | 'receive' | 'seq' | 'try' | 'tuple' | 'values' | 'var'. + +-spec type(cerl()) -> ctype(). + +type(#c_alias{}) -> alias; +type(#c_apply{}) -> apply; +type(#c_binary{}) -> binary; +type(#c_bitstr{}) -> bitstr; +type(#c_call{}) -> call; +type(#c_case{}) -> 'case'; +type(#c_catch{}) -> 'catch'; +type(#c_clause{}) -> clause; +type(#c_cons{}) -> cons; +type(#c_fun{}) -> 'fun'; +type(#c_let{}) -> 'let'; +type(#c_letrec{}) -> letrec; +type(#c_literal{}) -> literal; +type(#c_map{}) -> map; +type(#c_map_pair{}) -> map_pair; +type(#c_module{}) -> module; +type(#c_primop{}) -> primop; +type(#c_receive{}) -> 'receive'; +type(#c_seq{}) -> seq; +type(#c_try{}) -> 'try'; +type(#c_tuple{}) -> tuple; +type(#c_values{}) -> values; +type(#c_var{}) -> var. + + +%% @spec is_leaf(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is a leaf node, +%% otherwise false. The current leaf node types are +%% literal and var. +%% +%%

Note: all literals (cf. is_literal/1) are leaf +%% nodes, even if they represent structured (constant) values such as +%% {foo, [bar, baz]}. Also note that variables are leaf +%% nodes but not literals.

+%% +%% @see type/1 +%% @see is_literal/1 + +-spec is_leaf(cerl()) -> boolean(). + +is_leaf(Node) -> + case type(Node) of + literal -> true; + var -> true; + _ -> false + end. + + +%% @spec get_ann(cerl()) -> anns() +%% +%% @doc Returns the list of user annotations associated with a syntax +%% tree node. For a newly created node, this is the empty list. The +%% annotations may be any terms. +%% +%% @see set_ann/2 + +-spec get_ann(cerl()) -> anns(). + +get_ann(Node) -> + element(2, Node). + + +%% @spec set_ann(Node::cerl(), Annotations::anns()) -> cerl() +%% +%% @doc Sets the list of user annotations of Node to +%% Annotations. +%% +%% @see get_ann/1 +%% @see add_ann/2 +%% @see copy_ann/2 + +-spec set_ann(cerl(), anns()) -> cerl(). + +set_ann(Node, List) -> + setelement(2, Node, List). + + +%% @spec add_ann(Annotations::anns(), Node::cerl()) -> cerl() +%% +%% @doc Appends Annotations to the list of user +%% annotations of Node. +%% +%%

Note: this is equivalent to set_ann(Node, Annotations ++ +%% get_ann(Node)), but potentially more efficient.

+%% +%% @see get_ann/1 +%% @see set_ann/2 + +-spec add_ann(anns(), cerl()) -> cerl(). + +add_ann(Terms, Node) -> + set_ann(Node, Terms ++ get_ann(Node)). + + +%% @spec copy_ann(Source::cerl(), Target::cerl()) -> cerl() +%% +%% @doc Copies the list of user annotations from Source +%% to Target. +%% +%%

Note: this is equivalent to set_ann(Target, +%% get_ann(Source)), but potentially more efficient.

+%% +%% @see get_ann/1 +%% @see set_ann/2 + +-spec copy_ann(cerl(), cerl()) -> cerl(). + +copy_ann(Source, Target) -> + set_ann(Target, get_ann(Source)). + + +%% @spec abstract(Term::litval()) -> cerl() +%% +%% @doc Creates a syntax tree corresponding to an Erlang term. +%% Term must be a literal term, i.e., one that can be +%% represented as a source code literal. Thus, it may not contain a +%% process identifier, port, reference or function value as a subterm. +%% +%%

Note: This is a constant time operation.

+%% +%% @see ann_abstract/2 +%% @see concrete/1 +%% @see is_literal/1 +%% @see is_literal_term/1 + +-spec abstract(litval()) -> c_literal(). + +abstract(T) -> + #c_literal{val = T}. + + +%% @spec ann_abstract(Annotations::anns(), Term::litval()) -> cerl() +%% @see abstract/1 + +-spec ann_abstract(anns(), litval()) -> c_literal(). + +ann_abstract(As, T) -> + #c_literal{val = T, anno = As}. + + +%% @spec is_literal_term(Term::term()) -> boolean() +%% +%% @doc Returns true if Term can be +%% represented as a literal, otherwise false. This +%% function takes time proportional to the size of Term. +%% +%% @see abstract/1 + +-spec is_literal_term(term()) -> boolean(). + +is_literal_term(T) when is_integer(T) -> true; +is_literal_term(T) when is_float(T) -> true; +is_literal_term(T) when is_atom(T) -> true; +is_literal_term([]) -> true; +is_literal_term([H | T]) -> + is_literal_term(H) andalso is_literal_term(T); +is_literal_term(T) when is_tuple(T) -> + is_literal_term_list(tuple_to_list(T)); +is_literal_term(B) when is_bitstring(B) -> true; +is_literal_term(M) when is_map(M) -> + is_literal_term_list(maps:to_list(M)); +is_literal_term(_) -> + false. + +-spec is_literal_term_list([term()]) -> boolean(). + +is_literal_term_list([T | Ts]) -> + case is_literal_term(T) of + true -> + is_literal_term_list(Ts); + false -> + false + end; +is_literal_term_list([]) -> + true. + + +%% @spec concrete(Node::c_literal()) -> litval() +%% +%% @doc Returns the Erlang term represented by a syntax tree. An +%% exception is thrown if Node does not represent a +%% literal term. +%% +%%

Note: This is a constant time operation.

+%% +%% @see abstract/1 +%% @see is_literal/1 + +%% Because the normal tuple and list constructor operations always +%% return a literal if the arguments are literals, 'concrete' and +%% 'is_literal' never need to traverse the structure. + +-spec concrete(c_literal()) -> litval(). + +concrete(#c_literal{val = V}) -> + V. + + +%% @spec is_literal(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node represents a +%% literal term, otherwise false. This function returns +%% true if and only if the value of +%% concrete(Node) is defined. +%% +%%

Note: This is a constant time operation.

+%% +%% @see abstract/1 +%% @see concrete/1 +%% @see fold_literal/1 + +-spec is_literal(cerl()) -> boolean(). + +is_literal(#c_literal{}) -> + true; +is_literal(_) -> + false. + + +%% @spec fold_literal(Node::cerl()) -> cerl() +%% +%% @doc Assures that literals have a compact representation. This is +%% occasionally useful if c_cons_skel/2, +%% c_tuple_skel/1 or unfold_literal/1 were +%% used in the construction of Node, and you want to revert +%% to the normal "folded" representation of literals. If +%% Node represents a tuple or list constructor, its +%% elements are rewritten recursively, and the node is reconstructed +%% using c_cons/2 or c_tuple/1, respectively; +%% otherwise, Node is not changed. +%% +%% @see is_literal/1 +%% @see c_cons_skel/2 +%% @see c_tuple_skel/1 +%% @see c_cons/2 +%% @see c_tuple/1 +%% @see unfold_literal/1 + +-spec fold_literal(cerl()) -> cerl(). + +fold_literal(Node) -> + case type(Node) of + tuple -> + update_c_tuple(Node, fold_literal_list(tuple_es(Node))); + cons -> + update_c_cons(Node, fold_literal(cons_hd(Node)), + fold_literal(cons_tl(Node))); + _ -> + Node + end. + +fold_literal_list([E | Es]) -> + [fold_literal(E) | fold_literal_list(Es)]; +fold_literal_list([]) -> + []. + + +%% @spec unfold_literal(Node::cerl()) -> cerl() +%% +%% @doc Assures that literals have a fully expanded representation. If +%% Node represents a literal tuple or list constructor, its +%% elements are rewritten recursively, and the node is reconstructed +%% using c_cons_skel/2 or c_tuple_skel/1, +%% respectively; otherwise, Node is not changed. The {@link +%% fold_literal/1} can be used to revert to the normal compact +%% representation. +%% +%% @see is_literal/1 +%% @see c_cons_skel/2 +%% @see c_tuple_skel/1 +%% @see c_cons/2 +%% @see c_tuple/1 +%% @see fold_literal/1 + +-spec unfold_literal(cerl()) -> cerl(). + +unfold_literal(Node) -> + case type(Node) of + literal -> + copy_ann(Node, unfold_concrete(concrete(Node))); + _ -> + Node + end. + +unfold_concrete(Val) -> + case Val of + _ when is_tuple(Val) -> + c_tuple_skel(unfold_concrete_list(tuple_to_list(Val))); + [H|T] -> + c_cons_skel(unfold_concrete(H), unfold_concrete(T)); + _ -> + abstract(Val) + end. + +unfold_concrete_list([E | Es]) -> + [unfold_concrete(E) | unfold_concrete_list(Es)]; +unfold_concrete_list([]) -> + []. + + +%% --------------------------------------------------------------------- + +%% @spec c_module(Name::c_literal(), Exports, Definitions) -> c_module() +%% +%% Exports = [c_var()] +%% Definitions = defs() +%% +%% @equiv c_module(Name, Exports, [], Definitions) + +-spec c_module(c_literal(), [c_var()], defs()) -> c_module(). + +c_module(Name, Exports, Defs) -> + #c_module{name = Name, exports = Exports, attrs = [], defs = Defs}. + + +%% @spec c_module(Name::c_literal(), Exports, Attributes, Definitions) -> +%% c_module() +%% +%% Exports = [c_var()] +%% Attributes = attrs() +%% Definitions = defs() +%% +%% @doc Creates an abstract module definition. The result represents +%% 
+%%   module Name [E1, ..., Ek]
+%%     attributes [K1 = T1, ...,
+%%                 Km = Tm]
+%%     V1 = F1
+%%     ...
+%%     Vn = Fn
+%%   end
+%% +%% if Exports = [E1, ..., Ek], +%% Attributes = [{K1, T1}, ..., {Km, Tm}], +%% and Definitions = [{V1, F1}, ..., {Vn, +%% Fn}]. +%% +%%

Name and all the Ki must be atom +%% literals, and all the Ti must be constant literals. All +%% the Vi and Ei must have type +%% var and represent function names. All the +%% Fi must have type 'fun'.

+%% +%% @see c_module/3 +%% @see module_name/1 +%% @see module_exports/1 +%% @see module_attrs/1 +%% @see module_defs/1 +%% @see module_vars/1 +%% @see ann_c_module/4 +%% @see ann_c_module/5 +%% @see update_c_module/5 +%% @see c_atom/1 +%% @see c_var/1 +%% @see c_fun/2 +%% @see is_literal/1 + +-spec c_module(c_literal(), [c_var()], attrs(), defs()) -> c_module(). + +c_module(Name, Exports, Attrs, Defs) -> + #c_module{name = Name, exports = Exports, attrs = Attrs, defs = Defs}. + + +%% @spec ann_c_module(As::anns(), Name::c_literal(), Exports, +%% Definitions) -> c_module() +%% +%% Exports = [c_var()] +%% Definitions = defs() +%% +%% @see c_module/3 +%% @see ann_c_module/5 + +-spec ann_c_module(anns(), c_literal(), [c_var()], defs()) -> c_module(). + +ann_c_module(As, Name, Exports, Defs) -> + #c_module{name = Name, exports = Exports, attrs = [], defs = Defs, + anno = As}. + + +%% @spec ann_c_module(As::anns(), Name::c_literal(), Exports, +%% Attributes, Definitions) -> c_module() +%% +%% Exports = [c_var()] +%% Attributes = attrs() +%% Definitions = defs() +%% +%% @see c_module/4 +%% @see ann_c_module/4 + +-spec ann_c_module(anns(), c_literal(), [c_var()], attrs(), defs()) -> + c_module(). + +ann_c_module(As, Name, Exports, Attrs, Defs) -> + #c_module{name = Name, exports = Exports, attrs = Attrs, defs = Defs, + anno = As}. + + +%% @spec update_c_module(Old::cerl(), Name::c_literal(), Exports, +%% Attributes, Definitions) -> c_module() +%% +%% Exports = [c_var()] +%% Attributes = attrs() +%% Definitions = defs() +%% +%% @see c_module/4 + +-spec update_c_module(c_module(), c_literal(), [c_var()], attrs(), defs()) -> + c_module(). + +update_c_module(Node, Name, Exports, Attrs, Defs) -> + #c_module{name = Name, exports = Exports, attrs = Attrs, defs = Defs, + anno = get_ann(Node)}. + + +%% @spec is_c_module(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is an abstract +%% module definition, otherwise false. +%% +%% @see type/1 + +-spec is_c_module(cerl()) -> boolean(). + +is_c_module(#c_module{}) -> + true; +is_c_module(_) -> + false. + + +%% @spec module_name(Node::c_module()) -> c_literal() +%% +%% @doc Returns the name subtree of an abstract module definition. +%% +%% @see c_module/4 + +-spec module_name(c_module()) -> c_literal(). + +module_name(Node) -> + Node#c_module.name. + + +%% @spec module_exports(Node::c_module()) -> [c_var()] +%% +%% @doc Returns the list of exports subtrees of an abstract module +%% definition. +%% +%% @see c_module/4 + +-spec module_exports(c_module()) -> [c_var()]. + +module_exports(Node) -> + Node#c_module.exports. + + +%% @spec module_attrs(Node::c_module()) -> [{cerl(), cerl()}] +%% +%% @doc Returns the list of pairs of attribute key/value subtrees of +%% an abstract module definition. +%% +%% @see c_module/4 + +-spec module_attrs(c_module()) -> attrs(). + +module_attrs(Node) -> + Node#c_module.attrs. + + +%% @spec module_defs(Node::c_module()) -> defs() +%% +%% @doc Returns the list of function definitions of an abstract module +%% definition. +%% +%% @see c_module/4 + +-spec module_defs(c_module()) -> defs(). + +module_defs(Node) -> + Node#c_module.defs. + + +%% @spec module_vars(Node::c_module()) -> [c_var()] +%% +%% @doc Returns the list of left-hand side function variable subtrees +%% of an abstract module definition. +%% +%% @see c_module/4 + +-spec module_vars(c_module()) -> [c_var()]. + +module_vars(Node) -> + [F || {F, _} <- module_defs(Node)]. + + +%% --------------------------------------------------------------------- + +%% @spec c_int(Value::integer()) -> c_literal() +%% +%% @doc Creates an abstract integer literal. The lexical +%% representation is the canonical decimal numeral of +%% Value. +%% +%% @see ann_c_int/2 +%% @see is_c_int/1 +%% @see int_val/1 +%% @see int_lit/1 +%% @see c_char/1 + +-spec c_int(integer()) -> c_literal(). + +c_int(Value) -> + #c_literal{val = Value}. + + +%% @spec ann_c_int(As::anns(), Value::integer()) -> c_literal() +%% @see c_int/1 + +-spec ann_c_int(anns(), integer()) -> c_literal(). + +ann_c_int(As, Value) -> + #c_literal{val = Value, anno = As}. + + +%% @spec is_c_int(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node represents an +%% integer literal, otherwise false. +%% @see c_int/1 + +-spec is_c_int(cerl()) -> boolean(). + +is_c_int(#c_literal{val = V}) when is_integer(V) -> + true; +is_c_int(_) -> + false. + + +%% @spec int_val(c_literal()) -> integer() +%% +%% @doc Returns the value represented by an integer literal node. +%% @see c_int/1 + +-spec int_val(c_literal()) -> integer(). + +int_val(Node) -> + Node#c_literal.val. + + +%% @spec int_lit(c_literal()) -> string() +%% +%% @doc Returns the numeral string represented by an integer literal +%% node. +%% @see c_int/1 + +-spec int_lit(c_literal()) -> string(). + +int_lit(Node) -> + integer_to_list(int_val(Node)). + + +%% --------------------------------------------------------------------- + +%% @spec c_float(Value::float()) -> c_literal() +%% +%% @doc Creates an abstract floating-point literal. The lexical +%% representation is the decimal floating-point numeral of +%% Value. +%% +%% @see ann_c_float/2 +%% @see is_c_float/1 +%% @see float_val/1 +%% @see float_lit/1 + +%% Note that not all floating-point numerals can be represented with +%% full precision. + +-spec c_float(float()) -> c_literal(). + +c_float(Value) -> + #c_literal{val = Value}. + + +%% @spec ann_c_float(As::anns(), Value::float()) -> c_literal() +%% @see c_float/1 + +-spec ann_c_float(anns(), float()) -> c_literal(). + +ann_c_float(As, Value) -> + #c_literal{val = Value, anno = As}. + + +%% @spec is_c_float(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node represents a +%% floating-point literal, otherwise false. +%% @see c_float/1 + +-spec is_c_float(cerl()) -> boolean(). + +is_c_float(#c_literal{val = V}) when is_float(V) -> + true; +is_c_float(_) -> + false. + + +%% @spec float_val(c_literal()) -> float() +%% +%% @doc Returns the value represented by a floating-point literal +%% node. +%% @see c_float/1 + +-spec float_val(c_literal()) -> float(). + +float_val(Node) -> + Node#c_literal.val. + + +%% @spec float_lit(c_literal()) -> string() +%% +%% @doc Returns the numeral string represented by a floating-point +%% literal node. +%% @see c_float/1 + +-spec float_lit(c_literal()) -> string(). + +float_lit(Node) -> + float_to_list(float_val(Node)). + + +%% --------------------------------------------------------------------- + +%% @spec c_atom(Name) -> c_literal() +%% Name = atom() | string() +%% +%% @doc Creates an abstract atom literal. The print name of the atom +%% is the character sequence represented by Name. +%% +%%

Note: passing a string as argument to this function causes a +%% corresponding atom to be created for the internal representation.

+%% +%% @see ann_c_atom/2 +%% @see is_c_atom/1 +%% @see atom_val/1 +%% @see atom_name/1 +%% @see atom_lit/1 + +-spec c_atom(atom() | string()) -> c_literal(). + +c_atom(Name) when is_atom(Name) -> + #c_literal{val = Name}; +c_atom(Name) -> + #c_literal{val = list_to_atom(Name)}. + + +%% @spec ann_c_atom(As::anns(), Name) -> cerl() +%% Name = atom() | string() +%% @see c_atom/1 + +-spec ann_c_atom(anns(), atom() | string()) -> c_literal(). + +ann_c_atom(As, Name) when is_atom(Name) -> + #c_literal{val = Name, anno = As}; +ann_c_atom(As, Name) -> + #c_literal{val = list_to_atom(Name), anno = As}. + + +%% @spec is_c_atom(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node represents an +%% atom literal, otherwise false. +%% +%% @see c_atom/1 + +-spec is_c_atom(cerl()) -> boolean(). + +is_c_atom(#c_literal{val = V}) when is_atom(V) -> + true; +is_c_atom(_) -> + false. + +%% @spec atom_val(c_literal()) -> atom() +%% +%% @doc Returns the value represented by an abstract atom. +%% +%% @see c_atom/1 + +-spec atom_val(c_literal()) -> atom(). + +atom_val(Node) -> + Node#c_literal.val. + + +%% @spec atom_name(c_literal()) -> string() +%% +%% @doc Returns the printname of an abstract atom. +%% +%% @see c_atom/1 + +-spec atom_name(c_literal()) -> string(). + +atom_name(Node) -> + atom_to_list(atom_val(Node)). + + +%% @spec atom_lit(cerl()) -> string() +%% +%% @doc Returns the literal string represented by an abstract +%% atom. This always includes surrounding single-quote characters. +%% +%%

Note that an abstract atom may have several literal +%% representations, and that the representation yielded by this +%% function is not fixed; e.g., +%% atom_lit(c_atom("a\012b")) could yield the string +%% "\'a\\nb\'".

+%% +%% @see c_atom/1 + +%% TODO: replace the use of the unofficial 'write_string/2'. + +-spec atom_lit(cerl()) -> nonempty_string(). + +atom_lit(Node) -> + io_lib:write_string(atom_name(Node), $'). %' stupid Emacs. + + +%% --------------------------------------------------------------------- + +%% @spec c_char(Value) -> c_literal() +%% +%% Value = char() | integer() +%% +%% @doc Creates an abstract character literal. If the local +%% implementation of Erlang defines char() as a subset of +%% integer(), this function is equivalent to +%% c_int/1. Otherwise, if the given value is an integer, +%% it will be converted to the character with the corresponding +%% code. The lexical representation of a character is +%% "$Char", where Char is a single +%% printing character or an escape sequence. +%% +%% @see c_int/1 +%% @see c_string/1 +%% @see ann_c_char/2 +%% @see is_c_char/1 +%% @see char_val/1 +%% @see char_lit/1 +%% @see is_print_char/1 + +-spec c_char(non_neg_integer()) -> c_literal(). + +c_char(Value) when is_integer(Value), Value >= 0 -> + #c_literal{val = Value}. + + +%% @spec ann_c_char(As::anns(), Value::char()) -> c_literal() +%% @see c_char/1 + +-spec ann_c_char(anns(), char()) -> c_literal(). + +ann_c_char(As, Value) -> + #c_literal{val = Value, anno = As}. + + +%% @spec is_c_char(Node::c_literal()) -> boolean() +%% +%% @doc Returns true if Node may represent a +%% character literal, otherwise false. +%% +%%

If the local implementation of Erlang defines +%% char() as a subset of integer(), then +%% is_c_int(Node) will also yield +%% true.

+%% +%% @see c_char/1 +%% @see is_print_char/1 + +-spec is_c_char(c_literal()) -> boolean(). + +is_c_char(#c_literal{val = V}) when is_integer(V), V >= 0 -> + is_char_value(V); +is_c_char(_) -> + false. + + +%% @spec is_print_char(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node may represent a +%% "printing" character, otherwise false. (Cf. +%% is_c_char/1.) A "printing" character has either a +%% given graphical representation, or a "named" escape sequence such +%% as "\n". Currently, only ISO 8859-1 (Latin-1) +%% character values are recognized. +%% +%% @see c_char/1 +%% @see is_c_char/1 + +-spec is_print_char(cerl()) -> boolean(). + +is_print_char(#c_literal{val = V}) when is_integer(V), V >= 0 -> + is_print_char_value(V); +is_print_char(_) -> + false. + + +%% @spec char_val(c_literal()) -> char() +%% +%% @doc Returns the value represented by an abstract character literal. +%% +%% @see c_char/1 + +-spec char_val(c_literal()) -> char(). + +char_val(Node) -> + Node#c_literal.val. + + +%% @spec char_lit(c_literal()) -> string() +%% +%% @doc Returns the literal string represented by an abstract +%% character. This includes a leading $ +%% character. Currently, all characters that are not in the set of ISO +%% 8859-1 (Latin-1) "printing" characters will be escaped. +%% +%% @see c_char/1 + +-spec char_lit(c_literal()) -> nonempty_string(). + +char_lit(Node) -> + io_lib:write_char(char_val(Node)). + + +%% --------------------------------------------------------------------- + +%% @spec c_string(Value::string()) -> c_literal() +%% +%% @doc Creates an abstract string literal. Equivalent to creating an +%% abstract list of the corresponding character literals +%% (cf. is_c_string/1), but is typically more +%% efficient. The lexical representation of a string is +%% ""Chars"", where Chars is a +%% sequence of printing characters or spaces. +%% +%% @see c_char/1 +%% @see ann_c_string/2 +%% @see is_c_string/1 +%% @see string_val/1 +%% @see string_lit/1 +%% @see is_print_string/1 + +-spec c_string(string()) -> c_literal(). + +c_string(Value) -> + #c_literal{val = Value}. + + +%% @spec ann_c_string(As::anns(), Value::string()) -> c_literal() +%% @see c_string/1 + +-spec ann_c_string(anns(), string()) -> c_literal(). + +ann_c_string(As, Value) -> + #c_literal{val = Value, anno = As}. + + +%% @spec is_c_string(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node may represent a +%% string literal, otherwise false. Strings are defined +%% as lists of characters; see is_c_char/1 for details. +%% +%% @see c_string/1 +%% @see is_c_char/1 +%% @see is_print_string/1 + +-spec is_c_string(cerl()) -> boolean(). + +is_c_string(#c_literal{val = V}) -> + is_char_list(V); +is_c_string(_) -> + false. + + +%% @spec is_print_string(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node may represent a +%% string literal containing only "printing" characters, otherwise +%% false. See is_c_string/1 and +%% is_print_char/1 for details. Currently, only ISO +%% 8859-1 (Latin-1) character values are recognized. +%% +%% @see c_string/1 +%% @see is_c_string/1 +%% @see is_print_char/1 + +-spec is_print_string(cerl()) -> boolean(). + +is_print_string(#c_literal{val = V}) -> + is_print_char_list(V); +is_print_string(_) -> + false. + + +%% @spec string_val(cerl()) -> string() +%% +%% @doc Returns the value represented by an abstract string literal. +%% +%% @see c_string/1 + +-spec string_val(c_literal()) -> string(). + +string_val(Node) -> + Node#c_literal.val. + + +%% @spec string_lit(cerl()) -> string() +%% +%% @doc Returns the literal string represented by an abstract string. +%% This includes surrounding double-quote characters +%% "...". Currently, characters that are not in the set +%% of ISO 8859-1 (Latin-1) "printing" characters will be escaped, +%% except for spaces. +%% +%% @see c_string/1 + +-spec string_lit(c_literal()) -> nonempty_string(). + +string_lit(Node) -> + io_lib:write_string(string_val(Node)). + + +%% --------------------------------------------------------------------- + +%% @spec c_nil() -> cerl() +%% +%% @doc Creates an abstract empty list. The result represents +%% "[]". The empty list is traditionally called "nil". +%% +%% @see ann_c_nil/1 +%% @see is_c_list/1 +%% @see c_cons/2 + +-spec c_nil() -> c_literal(). + +c_nil() -> + #c_literal{val = []}. + + +%% @spec ann_c_nil(As::anns()) -> cerl() +%% @see c_nil/0 + +-spec ann_c_nil(anns()) -> c_literal(). + +ann_c_nil(As) -> + #c_literal{val = [], anno = As}. + + +%% @spec is_c_nil(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is an abstract +%% empty list, otherwise false. + +-spec is_c_nil(cerl()) -> boolean(). + +is_c_nil(#c_literal{val = []}) -> + true; +is_c_nil(_) -> + false. + + +%% --------------------------------------------------------------------- + +%% @spec c_cons(Head::cerl(), Tail::cerl()) -> cerl() +%% +%% @doc Creates an abstract list constructor. The result represents +%% "[Head | Tail]". Note that if both +%% Head and Tail have type +%% literal, then the result will also have type +%% literal, and annotations on Head and +%% Tail are lost. +%% +%%

Recall that in Erlang, the tail element of a list constructor is +%% not necessarily a list.

+%% +%% @see ann_c_cons/3 +%% @see update_c_cons/3 +%% @see c_cons_skel/2 +%% @see is_c_cons/1 +%% @see cons_hd/1 +%% @see cons_tl/1 +%% @see is_c_list/1 +%% @see c_nil/0 +%% @see list_elements/1 +%% @see list_length/1 +%% @see make_list/2 + +%% *Always* collapse literals. + +-spec c_cons(cerl(), cerl()) -> c_literal() | c_cons(). + +c_cons(#c_literal{val = Head}, #c_literal{val = Tail}) -> + #c_literal{val = [Head | Tail]}; +c_cons(Head, Tail) -> + #c_cons{hd = Head, tl = Tail}. + + +%% @spec ann_c_cons(As::anns(), Head::cerl(), Tail::cerl()) -> cerl() +%% @see c_cons/2 + +-spec ann_c_cons(anns(), cerl(), cerl()) -> c_literal() | c_cons(). + +ann_c_cons(As, #c_literal{val = Head}, #c_literal{val = Tail}) -> + #c_literal{val = [Head | Tail], anno = As}; +ann_c_cons(As, Head, Tail) -> + #c_cons{hd = Head, tl = Tail, anno = As}. + + +%% @spec update_c_cons(Old::cerl(), Head::cerl(), Tail::cerl()) -> +%% cerl() +%% @see c_cons/2 + +-spec update_c_cons(c_literal() | c_cons(), cerl(), cerl()) -> + c_literal() | c_cons(). + +update_c_cons(Node, #c_literal{val = Head}, #c_literal{val = Tail}) -> + #c_literal{val = [Head | Tail], anno = get_ann(Node)}; +update_c_cons(Node, Head, Tail) -> + #c_cons{hd = Head, tl = Tail, anno = get_ann(Node)}. + + +%% @spec c_cons_skel(Head::cerl(), Tail::cerl()) -> c_cons() +%% +%% @doc Creates an abstract list constructor skeleton. Does not fold +%% constant literals, i.e., the result always has type +%% cons, representing "[Head | +%% Tail]". +%% +%%

This function is occasionally useful when it is necessary to have +%% annotations on the subnodes of a list constructor node, even when the +%% subnodes are constant literals. Note however that +%% is_literal/1 will yield false and +%% concrete/1 will fail if passed the result from this +%% function.

+%% +%%

fold_literal/1 can be used to revert a node to the +%% normal-form representation.

+%% +%% @see ann_c_cons_skel/3 +%% @see update_c_cons_skel/3 +%% @see c_cons/2 +%% @see is_c_cons/1 +%% @see is_c_list/1 +%% @see c_nil/0 +%% @see is_literal/1 +%% @see fold_literal/1 +%% @see concrete/1 + +%% *Never* collapse literals. + +-spec c_cons_skel(cerl(), cerl()) -> c_cons(). + +c_cons_skel(Head, Tail) -> + #c_cons{hd = Head, tl = Tail}. + + +%% @spec ann_c_cons_skel(As::anns(), Head::cerl(), Tail::cerl()) -> +%% c_cons() +%% @see c_cons_skel/2 + +-spec ann_c_cons_skel(anns(), cerl(), cerl()) -> c_cons(). + +ann_c_cons_skel(As, Head, Tail) -> + #c_cons{hd = Head, tl = Tail, anno = As}. + + +%% @spec update_c_cons_skel(Old::cerl(), Head::cerl(), Tail::cerl()) -> +%% c_cons() +%% @see c_cons_skel/2 + +-spec update_c_cons_skel(c_cons() | c_literal(), cerl(), cerl()) -> c_cons(). + +update_c_cons_skel(Node, Head, Tail) -> + #c_cons{hd = Head, tl = Tail, anno = get_ann(Node)}. + + +%% @spec is_c_cons(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is an abstract +%% list constructor, otherwise false. + +-spec is_c_cons(cerl()) -> boolean(). + +is_c_cons(#c_cons{}) -> + true; +is_c_cons(#c_literal{val = [_ | _]}) -> + true; +is_c_cons(_) -> + false. + + +%% @spec cons_hd(cerl()) -> cerl() +%% +%% @doc Returns the head subtree of an abstract list constructor. +%% +%% @see c_cons/2 + +-spec cons_hd(c_cons() | c_literal()) -> cerl(). + +cons_hd(#c_cons{hd = Head}) -> + Head; +cons_hd(#c_literal{val = [Head | _]}) -> + #c_literal{val = Head}. + + +%% @spec cons_tl(c_cons() | c_literal()) -> cerl() +%% +%% @doc Returns the tail subtree of an abstract list constructor. +%% +%%

Recall that the tail does not necessarily represent a proper +%% list.

+%% +%% @see c_cons/2 + +-spec cons_tl(c_cons() | c_literal()) -> cerl(). + +cons_tl(#c_cons{tl = Tail}) -> + Tail; +cons_tl(#c_literal{val = [_ | Tail]}) -> + #c_literal{val = Tail}. + + +%% @spec is_c_list(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node represents a +%% proper list, otherwise false. A proper list is either +%% the empty list [], or a cons cell [Head | +%% Tail], where recursively Tail is a +%% proper list. +%% +%%

Note: Because Node is a syntax tree, the actual +%% run-time values corresponding to its subtrees may often be partially +%% or completely unknown. Thus, if Node represents e.g. +%% "[... | Ns]" (where Ns is a variable), then +%% the function will return false, because it is not known +%% whether Ns will be bound to a list at run-time. If +%% Node instead represents e.g. "[1, 2, 3]" or +%% "[A | []]", then the function will return +%% true.

+%% +%% @see c_cons/2 +%% @see c_nil/0 +%% @see list_elements/1 +%% @see list_length/1 + +-spec is_c_list(cerl()) -> boolean(). + +is_c_list(#c_cons{tl = Tail}) -> + is_c_list(Tail); +is_c_list(#c_literal{val = V}) -> + is_proper_list(V); +is_c_list(_) -> + false. + +is_proper_list([_ | Tail]) -> + is_proper_list(Tail); +is_proper_list([]) -> + true; +is_proper_list(_) -> + false. + +%% @spec list_elements(c_cons() | c_literal()) -> [cerl()] +%% +%% @doc Returns the list of element subtrees of an abstract list. +%% Node must represent a proper list. E.g., if +%% Node represents "[X1, X2 | +%% [X3, X4 | []]", then +%% list_elements(Node) yields the list [X1, X2, X3, +%% X4]. +%% +%% @see c_cons/2 +%% @see c_nil/0 +%% @see is_c_list/1 +%% @see list_length/1 +%% @see make_list/2 + +-spec list_elements(c_cons() | c_literal()) -> [cerl()]. + +list_elements(#c_cons{hd = Head, tl = Tail}) -> + [Head | list_elements(Tail)]; +list_elements(#c_literal{val = V}) -> + abstract_list(V). + +abstract_list([X | Xs]) -> + [abstract(X) | abstract_list(Xs)]; +abstract_list([]) -> + []. + + +%% @spec list_length(Node::c_cons() | c_literal()) -> integer() +%% +%% @doc Returns the number of element subtrees of an abstract list. +%% Node must represent a proper list. E.g., if +%% Node represents "[X1 | [X2, X3 | [X4, X5, +%% X6]]]", then list_length(Node) returns the +%% integer 6. +%% +%%

Note: this is equivalent to +%% length(list_elements(Node)), but potentially more +%% efficient.

+%% +%% @see c_cons/2 +%% @see c_nil/0 +%% @see is_c_list/1 +%% @see list_elements/1 + +-spec list_length(c_cons() | c_literal()) -> non_neg_integer(). + +list_length(L) -> + list_length(L, 0). + +list_length(#c_cons{tl = Tail}, A) -> + list_length(Tail, A + 1); +list_length(#c_literal{val = V}, A) -> + A + length(V). + + +%% @spec make_list(List) -> Node +%% @equiv make_list(List, none) + +-spec make_list([cerl()]) -> cerl(). + +make_list(List) -> + ann_make_list([], List). + + +%% @spec make_list(List::[cerl()], Tail) -> cerl() +%% +%% Tail = cerl() | none +%% +%% @doc Creates an abstract list from the elements in List +%% and the optional Tail. If Tail is +%% none, the result will represent a nil-terminated list, +%% otherwise it represents "[... | Tail]". +%% +%% @see c_cons/2 +%% @see c_nil/0 +%% @see ann_make_list/3 +%% @see update_list/3 +%% @see list_elements/1 + +-spec make_list([cerl()], cerl() | 'none') -> cerl(). + +make_list(List, Tail) -> + ann_make_list([], List, Tail). + + +%% @spec update_list(Old::cerl(), List::[cerl()]) -> cerl() +%% @equiv update_list(Old, List, none) + +-spec update_list(cerl(), [cerl()]) -> cerl(). + +update_list(Node, List) -> + ann_make_list(get_ann(Node), List). + + +%% @spec update_list(Old::cerl(), List::[cerl()], Tail) -> cerl() +%% +%% Tail = cerl() | none +%% +%% @see make_list/2 +%% @see update_list/2 + +-spec update_list(cerl(), [cerl()], cerl() | 'none') -> cerl(). + +update_list(Node, List, Tail) -> + ann_make_list(get_ann(Node), List, Tail). + + +%% @spec ann_make_list(As::anns(), List::[cerl()]) -> cerl() +%% @equiv ann_make_list(As, List, none) + +-spec ann_make_list(anns(), [cerl()]) -> cerl(). + +ann_make_list(As, List) -> + ann_make_list(As, List, none). + + +%% @spec ann_make_list(As::anns(), List::[cerl()], Tail) -> cerl() +%% +%% Tail = cerl() | none +%% +%% @see make_list/2 +%% @see ann_make_list/2 + +-spec ann_make_list(anns(), [cerl()], cerl() | 'none') -> cerl(). + +ann_make_list(As, [H | T], Tail) -> + ann_c_cons(As, H, make_list(T, Tail)); % `c_cons' folds literals +ann_make_list(As, [], none) -> + ann_c_nil(As); +ann_make_list(_, [], Node) -> + Node. + + +%% --------------------------------------------------------------------- +%% maps + +%% @spec is_c_map(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is an abstract +%% map constructor, otherwise false. + +-spec is_c_map(cerl()) -> boolean(). + +is_c_map(#c_map{}) -> + true; +is_c_map(#c_literal{val = V}) when is_map(V) -> + true; +is_c_map(_) -> + false. + +-spec map_es(c_map() | c_literal()) -> [c_map_pair()]. + +map_es(#c_literal{anno=As,val=M}) when is_map(M) -> + [ann_c_map_pair(As, + #c_literal{anno=As,val='assoc'}, + #c_literal{anno=As,val=K}, + #c_literal{anno=As,val=V}) || {K,V} <- maps:to_list(M)]; +map_es(#c_map{es = Es}) -> + Es. + +-spec map_arg(c_map() | c_literal()) -> c_map() | c_literal(). + +map_arg(#c_literal{anno=As,val=M}) when is_map(M) -> + #c_literal{anno=As,val=#{}}; +map_arg(#c_map{arg=M}) -> + M. + +-spec c_map([c_map_pair()]) -> c_map(). + +c_map(Pairs) -> + ann_c_map([], Pairs). + +-spec c_map_pattern([c_map_pair()]) -> c_map(). + +c_map_pattern(Pairs) -> + #c_map{es=Pairs, is_pat=true}. + +-spec ann_c_map_pattern([term()], [c_map_pair()]) -> c_map(). + +ann_c_map_pattern(As, Pairs) -> + #c_map{anno=As, es=Pairs, is_pat=true}. + +-spec is_c_map_empty(c_map() | c_literal()) -> boolean(). + +is_c_map_empty(#c_map{ es=[] }) -> true; +is_c_map_empty(#c_literal{val=M}) when is_map(M),map_size(M) =:= 0 -> true; +is_c_map_empty(_) -> false. + +-spec is_c_map_pattern(c_map()) -> boolean(). + +is_c_map_pattern(#c_map{is_pat=IsPat}) -> + IsPat. + +-spec ann_c_map([term()], [c_map_pair()]) -> c_map() | c_literal(). + +ann_c_map(As, Es) -> + ann_c_map(As, #c_literal{val=#{}}, Es). + +-spec ann_c_map(anns(), c_map() | c_literal(), [c_map_pair()]) -> c_map() | c_literal(). + +ann_c_map(As, #c_literal{val=M}, Es) when is_map(M) -> + fold_map_pairs(As,Es,M); +ann_c_map(As, M, Es) -> + #c_map{arg=M, es=Es, anno=As}. + +fold_map_pairs(As,[],M) -> #c_literal{anno=As,val=M}; +%% M#{ K => V} +fold_map_pairs(As,[#c_map_pair{op=#c_literal{val=assoc},key=Ck,val=Cv}=E|Es],M) -> + case is_lit_list([Ck,Cv]) of + true -> + [K,V] = lit_list_vals([Ck,Cv]), + fold_map_pairs(As,Es,maps:put(K,V,M)); + false -> + #c_map{arg=#c_literal{val=M,anno=As}, es=[E|Es], anno=As} + end; +%% M#{ K := V} +fold_map_pairs(As,[#c_map_pair{op=#c_literal{val=exact},key=Ck,val=Cv}=E|Es],M) -> + case is_lit_list([Ck,Cv]) of + true -> + [K,V] = lit_list_vals([Ck,Cv]), + case maps:is_key(K,M) of + true -> fold_map_pairs(As,Es,maps:put(K,V,M)); + false -> + #c_map{arg=#c_literal{val=M,anno=As}, es=[E|Es], anno=As } + end; + false -> + #c_map{arg=#c_literal{val=M,anno=As}, es=[E|Es], anno=As } + end. + +-spec update_c_map(c_map(), cerl(), [cerl()]) -> c_map() | c_literal(). + +update_c_map(#c_map{is_pat=true}=Old, M, Es) -> + Old#c_map{arg=M, es=Es}; +update_c_map(#c_map{is_pat=false}=Old, M, Es) -> + ann_c_map(get_ann(Old), M, Es). + +map_pair_key(#c_map_pair{key=K}) -> K. +map_pair_val(#c_map_pair{val=V}) -> V. +map_pair_op(#c_map_pair{op=Op}) -> Op. + +-spec c_map_pair(cerl(), cerl()) -> c_map_pair(). + +c_map_pair(Key,Val) -> + #c_map_pair{op=#c_literal{val=assoc},key=Key,val=Val}. + +-spec c_map_pair_exact(cerl(), cerl()) -> c_map_pair(). + +c_map_pair_exact(Key,Val) -> + #c_map_pair{op=#c_literal{val=exact},key=Key,val=Val}. + +-spec ann_c_map_pair(anns(), cerl(), cerl(), cerl()) -> + c_map_pair(). + +ann_c_map_pair(As,Op,K,V) -> + #c_map_pair{op = Op, key = K, val = V, anno = As}. + +update_c_map_pair(Old,Op,K,V) -> + #c_map_pair{op = Op, key = K, val = V, anno = get_ann(Old)}. + + +%% --------------------------------------------------------------------- + +%% @spec c_tuple(Elements::[cerl()]) -> cerl() +%% +%% @doc Creates an abstract tuple. If Elements is +%% [E1, ..., En], the result represents +%% "{E1, ..., En}". Note that if all +%% nodes in Elements have type literal, or if +%% Elements is empty, then the result will also have type +%% literal and annotations on nodes in +%% Elements are lost. +%% +%%

Recall that Erlang has distinct 1-tuples, i.e., {X} +%% is always distinct from X itself.

+%% +%% @see ann_c_tuple/2 +%% @see update_c_tuple/2 +%% @see is_c_tuple/1 +%% @see tuple_es/1 +%% @see tuple_arity/1 +%% @see c_tuple_skel/1 + +%% *Always* collapse literals. + +-spec c_tuple([cerl()]) -> c_tuple() | c_literal(). + +c_tuple(Es) -> + case is_lit_list(Es) of + false -> + #c_tuple{es = Es}; + true -> + #c_literal{val = list_to_tuple(lit_list_vals(Es))} + end. + + +%% @spec ann_c_tuple(As::anns(), Elements::[cerl()]) -> cerl() +%% @see c_tuple/1 + +-spec ann_c_tuple(anns(), [cerl()]) -> c_tuple() | c_literal(). + +ann_c_tuple(As, Es) -> + case is_lit_list(Es) of + false -> + #c_tuple{es = Es, anno = As}; + true -> + #c_literal{val = list_to_tuple(lit_list_vals(Es)), anno = As} + end. + + +%% @spec update_c_tuple(Old::cerl(), Elements::[cerl()]) -> cerl() +%% @see c_tuple/1 + +-spec update_c_tuple(c_tuple() | c_literal(), [cerl()]) -> c_tuple() | c_literal(). + +update_c_tuple(Node, Es) -> + case is_lit_list(Es) of + false -> + #c_tuple{es = Es, anno = get_ann(Node)}; + true -> + #c_literal{val = list_to_tuple(lit_list_vals(Es)), + anno = get_ann(Node)} + end. + + +%% @spec c_tuple_skel(Elements::[cerl()]) -> cerl() +%% +%% @doc Creates an abstract tuple skeleton. Does not fold constant +%% literals, i.e., the result always has type tuple, +%% representing "{E1, ..., En}", if +%% Elements is [E1, ..., En]. +%% +%%

This function is occasionally useful when it is necessary to have +%% annotations on the subnodes of a tuple node, even when all the +%% subnodes are constant literals. Note however that +%% is_literal/1 will yield false and +%% concrete/1 will fail if passed the result from this +%% function.

+%% +%%

fold_literal/1 can be used to revert a node to the +%% normal-form representation.

+%% +%% @see ann_c_tuple_skel/2 +%% @see update_c_tuple_skel/2 +%% @see c_tuple/1 +%% @see tuple_es/1 +%% @see is_c_tuple/1 +%% @see is_literal/1 +%% @see fold_literal/1 +%% @see concrete/1 + +%% *Never* collapse literals. + +-spec c_tuple_skel([cerl()]) -> c_tuple(). + +c_tuple_skel(Es) -> + #c_tuple{es = Es}. + + +%% @spec ann_c_tuple_skel(As::anns(), Elements::[cerl()]) -> cerl() +%% @see c_tuple_skel/1 + +-spec ann_c_tuple_skel(anns(), [cerl()]) -> c_tuple(). + +ann_c_tuple_skel(As, Es) -> + #c_tuple{es = Es, anno = As}. + + +%% @spec update_c_tuple_skel(Old::cerl(), Elements::[cerl()]) -> cerl() +%% @see c_tuple_skel/1 + +-spec update_c_tuple_skel(c_tuple(), [cerl()]) -> c_tuple(). + +update_c_tuple_skel(Old, Es) -> + #c_tuple{es = Es, anno = get_ann(Old)}. + + +%% @spec is_c_tuple(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is an abstract +%% tuple, otherwise false. +%% +%% @see c_tuple/1 + +-spec is_c_tuple(cerl()) -> boolean(). + +is_c_tuple(#c_tuple{}) -> + true; +is_c_tuple(#c_literal{val = V}) when is_tuple(V) -> + true; +is_c_tuple(_) -> + false. + + +%% @spec tuple_es(cerl()) -> [cerl()] +%% +%% @doc Returns the list of element subtrees of an abstract tuple. +%% +%% @see c_tuple/1 + +-spec tuple_es(c_tuple() | c_literal()) -> [cerl()]. + +tuple_es(#c_tuple{es = Es}) -> + Es; +tuple_es(#c_literal{val = V}) -> + make_lit_list(tuple_to_list(V)). + + +%% @spec tuple_arity(Node::cerl()) -> integer() +%% +%% @doc Returns the number of element subtrees of an abstract tuple. +%% +%%

Note: this is equivalent to length(tuple_es(Node)), +%% but potentially more efficient.

+%% +%% @see tuple_es/1 +%% @see c_tuple/1 + +-spec tuple_arity(c_tuple() | c_literal()) -> non_neg_integer(). + +tuple_arity(#c_tuple{es = Es}) -> + length(Es); +tuple_arity(#c_literal{val = V}) when is_tuple(V) -> + tuple_size(V). + + +%% --------------------------------------------------------------------- + +%% @spec c_var(Name::var_name()) -> cerl() +%% +%% var_name() = integer() | atom() | {atom(), arity()} +%% +%% @doc Creates an abstract variable. A variable is identified by its +%% name, given by the Name parameter. +%% +%%

If a name is given by a single atom, it should either be a +%% "simple" atom which does not need to be single-quoted in Erlang, or +%% otherwise its print name should correspond to a proper Erlang +%% variable, i.e., begin with an uppercase character or an +%% underscore. Names on the form {A, N} represent +%% function name variables "A/N"; these +%% are special variables which may be bound only in the function +%% definitions of a module or a letrec. They may not be +%% bound in let expressions and cannot occur in clause +%% patterns. The atom A in a function name may be any +%% atom; the integer N must be nonnegative. The functions +%% c_fname/2 etc. are utilities for handling function +%% name variables.

+%% +%%

When printing variable names, they must have the form of proper +%% Core Erlang variables and function names. E.g., a name represented +%% by an integer such as 42 could be formatted as +%% "_42", an atom 'Xxx' simply as +%% "Xxx", and an atom foo as +%% "_foo". However, one must assure that any two valid +%% distinct names are never mapped to the same strings. Tuples such +%% as {foo, 2} representing function names can simply by +%% formatted as "'foo'/2", with no risk of conflicts.

+%% +%% @see ann_c_var/2 +%% @see update_c_var/2 +%% @see is_c_var/1 +%% @see var_name/1 +%% @see c_fname/2 +%% @see c_module/4 +%% @see c_letrec/2 + +-spec c_var(var_name()) -> c_var(). + +c_var(Name) -> + #c_var{name = Name}. + + +%% @spec ann_c_var(As::anns(), Name::var_name()) -> c_var() +%% +%% @see c_var/1 + +-spec ann_c_var(anns(), var_name()) -> c_var(). + +ann_c_var(As, Name) -> + #c_var{name = Name, anno = As}. + +%% @spec update_c_var(Old::cerl(), Name::var_name()) -> c_var() +%% +%% @see c_var/1 + +-spec update_c_var(c_var(), var_name()) -> c_var(). + +update_c_var(Node, Name) -> + #c_var{name = Name, anno = get_ann(Node)}. + + +%% @spec is_c_var(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is an abstract +%% variable, otherwise false. +%% +%% @see c_var/1 + +-spec is_c_var(cerl()) -> boolean(). + +is_c_var(#c_var{}) -> + true; +is_c_var(_) -> + false. + + +%% @spec c_fname(Name::atom(), Arity::arity()) -> c_var() +%% @equiv c_var({Name, Arity}) +%% @see fname_id/1 +%% @see fname_arity/1 +%% @see is_c_fname/1 +%% @see ann_c_fname/3 +%% @see update_c_fname/3 + +-spec c_fname(atom(), arity()) -> c_var(). + +c_fname(Atom, Arity) -> + c_var({Atom, Arity}). + + +%% @spec ann_c_fname(As::anns(), Name::atom(), Arity::arity()) -> c_var() +%% +%% @equiv ann_c_var(As, {Atom, Arity}) +%% @see c_fname/2 + +-spec ann_c_fname(anns(), atom(), arity()) -> c_var(). + +ann_c_fname(As, Atom, Arity) -> + ann_c_var(As, {Atom, Arity}). + + +%% @spec update_c_fname(Old::c_var(), Name::atom()) -> c_var() +%% @doc Like update_c_fname/3, but takes the arity from +%% Node. +%% @see update_c_fname/3 +%% @see c_fname/2 + +-spec update_c_fname(c_var(), atom()) -> c_var(). + +update_c_fname(#c_var{name = {_, Arity}, anno = As}, Atom) -> + #c_var{name = {Atom, Arity}, anno = As}. + + +%% @spec update_c_fname(Old::var(), Name::atom(), Arity::arity()) -> c_var() +%% +%% @equiv update_c_var(Old, {Atom, Arity}) +%% @see update_c_fname/2 +%% @see c_fname/2 + +-spec update_c_fname(c_var(), atom(), arity()) -> c_var(). + +update_c_fname(Node, Atom, Arity) -> + update_c_var(Node, {Atom, Arity}). + + +%% @spec is_c_fname(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is an abstract +%% function name variable, otherwise false. +%% +%% @see c_fname/2 +%% @see c_var/1 +%% @see var_name/1 + +-spec is_c_fname(cerl()) -> boolean(). + +is_c_fname(#c_var{name = {A, N}}) when is_atom(A), is_integer(N), N >= 0 -> + true; +is_c_fname(_) -> + false. + + +%% @spec var_name(c_var()) -> var_name() +%% +%% @doc Returns the name of an abstract variable. +%% +%% @see c_var/1 + +-spec var_name(c_var()) -> var_name(). + +var_name(Node) -> + Node#c_var.name. + + +%% @spec fname_id(c_var()) -> atom() +%% +%% @doc Returns the identifier part of an abstract function name +%% variable. +%% +%% @see fname_arity/1 +%% @see c_fname/2 + +-spec fname_id(c_var()) -> atom(). + +fname_id(#c_var{name={A,_}}) -> + A. + + +%% @spec fname_arity(c_var()) -> arity() +%% +%% @doc Returns the arity part of an abstract function name variable. +%% +%% @see fname_id/1 +%% @see c_fname/2 + +-spec fname_arity(c_var()) -> arity(). + +fname_arity(#c_var{name={_,N}}) -> + N. + + +%% --------------------------------------------------------------------- + +%% @spec c_values(Elements::[cerl()]) -> c_values() +%% +%% @doc Creates an abstract value list. If Elements is +%% [E1, ..., En], the result represents +%% "<E1, ..., En>". +%% +%% @see ann_c_values/2 +%% @see update_c_values/2 +%% @see is_c_values/1 +%% @see values_es/1 +%% @see values_arity/1 + +-spec c_values([cerl()]) -> c_values(). + +c_values(Es) -> + #c_values{es = Es}. + + +%% @spec ann_c_values(As::anns(), Elements::[cerl()]) -> c_values() +%% @see c_values/1 + +-spec ann_c_values(anns(), [cerl()]) -> c_values(). + +ann_c_values(As, Es) -> + #c_values{es = Es, anno = As}. + + +%% @spec update_c_values(Old::cerl(), Elements::[cerl()]) -> c_values() +%% @see c_values/1 + +-spec update_c_values(c_values(), [cerl()]) -> c_values(). + +update_c_values(Node, Es) -> + #c_values{es = Es, anno = get_ann(Node)}. + + +%% @spec is_c_values(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is an abstract +%% value list; otherwise false. +%% +%% @see c_values/1 + +-spec is_c_values(cerl()) -> boolean(). + +is_c_values(#c_values{}) -> + true; +is_c_values(_) -> + false. + + +%% @spec values_es(c_values()) -> [cerl()] +%% +%% @doc Returns the list of element subtrees of an abstract value +%% list. +%% +%% @see c_values/1 +%% @see values_arity/1 + +-spec values_es(c_values()) -> [cerl()]. + +values_es(Node) -> + Node#c_values.es. + + +%% @spec values_arity(Node::c_values()) -> non_neg_integer() +%% +%% @doc Returns the number of element subtrees of an abstract value +%% list. +%% +%%

Note: This is equivalent to +%% length(values_es(Node)), but potentially more +%% efficient.

+%% +%% @see c_values/1 +%% @see values_es/1 + +-spec values_arity(c_values()) -> non_neg_integer(). + +values_arity(Node) -> + length(values_es(Node)). + + +%% --------------------------------------------------------------------- + +%% @spec c_binary(Segments::[c_bitstr()]) -> c_binary() +%% +%% @doc Creates an abstract binary-template. A binary object is a +%% sequence of 8-bit bytes. It is specified by zero or more bit-string +%% template segments of arbitrary lengths (in number of bits), +%% such that the sum of the lengths is evenly divisible by 8. If +%% Segments is [S1, ..., Sn], the result +%% represents "#{S1, ..., Sn}#". All the +%% Si must have type bitstr. +%% +%% @see ann_c_binary/2 +%% @see update_c_binary/2 +%% @see is_c_binary/1 +%% @see binary_segments/1 +%% @see c_bitstr/5 + +-spec c_binary([c_bitstr()]) -> c_binary(). + +c_binary(Segments) -> + #c_binary{segments = Segments}. + + +%% @spec ann_c_binary(As::anns(), Segments::[c_bitstr()]) -> c_binary() +%% @see c_binary/1 + +-spec ann_c_binary(anns(), [c_bitstr()]) -> c_binary(). + +ann_c_binary(As, Segments) -> + #c_binary{segments = Segments, anno = As}. + + +%% @spec update_c_binary(Old::cerl(), Segments::[c_bitstr()]) -> cerl() +%% @see c_binary/1 + +-spec update_c_binary(c_binary(), [c_bitstr()]) -> c_binary(). + +update_c_binary(Node, Segments) -> + #c_binary{segments = Segments, anno = get_ann(Node)}. + + +%% @spec is_c_binary(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is an abstract +%% binary-template; otherwise false. +%% +%% @see c_binary/1 + +-spec is_c_binary(cerl()) -> boolean(). + +is_c_binary(#c_binary{}) -> + true; +is_c_binary(_) -> + false. + + +%% @spec binary_segments(cerl()) -> [c_bitstr()] +%% +%% @doc Returns the list of segment subtrees of an abstract +%% binary-template. +%% +%% @see c_binary/1 +%% @see c_bitstr/5 + +-spec binary_segments(c_binary()) -> [c_bitstr()]. + +binary_segments(Node) -> + Node#c_binary.segments. + + +%% @spec c_bitstr(Value::cerl(), Size::cerl(), Unit::cerl(), +%% Type::cerl(), Flags::cerl()) -> c_bitstr() +%% +%% @doc Creates an abstract bit-string template. These can only occur as +%% components of an abstract binary-template (see {@link c_binary/1}). +%% The result represents "#<Value>(Size, +%% Unit, Type, Flags)", where +%% Unit must represent a positive integer constant, +%% Type must represent a constant atom (one of +%% 'integer', 'float', or +%% 'binary'), and Flags must represent a +%% constant list "[F1, ..., Fn]" where +%% all the Fi are atoms. +%% +%% @see c_binary/1 +%% @see ann_c_bitstr/6 +%% @see update_c_bitstr/6 +%% @see is_c_bitstr/1 +%% @see bitstr_val/1 +%% @see bitstr_size/1 +%% @see bitstr_unit/1 +%% @see bitstr_type/1 +%% @see bitstr_flags/1 + +-spec c_bitstr(cerl(), cerl(), cerl(), cerl(), cerl()) -> c_bitstr(). + +c_bitstr(Val, Size, Unit, Type, Flags) -> + #c_bitstr{val = Val, size = Size, unit = Unit, type = Type, + flags = Flags}. + + +%% @spec c_bitstr(Value::cerl(), Size::cerl(), Type::cerl(), +%% Flags::cerl()) -> c_bitstr() +%% @equiv c_bitstr(Value, Size, abstract(1), Type, Flags) + +-spec c_bitstr(cerl(), cerl(), cerl(), cerl()) -> c_bitstr(). + +c_bitstr(Val, Size, Type, Flags) -> + c_bitstr(Val, Size, abstract(1), Type, Flags). + + +%% @spec c_bitstr(Value::cerl(), Type::cerl(), +%% Flags::cerl()) -> c_bitstr() +%% @equiv c_bitstr(Value, abstract(all), abstract(1), Type, Flags) + +-spec c_bitstr(cerl(), cerl(), cerl()) -> c_bitstr(). + +c_bitstr(Val, Type, Flags) -> + c_bitstr(Val, abstract(all), abstract(1), Type, Flags). + + +%% @spec ann_c_bitstr(As::anns(), Value::cerl(), Size::cerl(), +%% Unit::cerl(), Type::cerl(), Flags::cerl()) -> cerl() +%% @see c_bitstr/5 +%% @see ann_c_bitstr/5 + +-spec ann_c_bitstr(anns(), cerl(), cerl(), cerl(), cerl(), cerl()) -> + c_bitstr(). + +ann_c_bitstr(As, Val, Size, Unit, Type, Flags) -> + #c_bitstr{val = Val, size = Size, unit = Unit, type = Type, + flags = Flags, anno = As}. + +%% @spec ann_c_bitstr(As::anns(), Value::cerl(), Size::cerl(), +%% Type::cerl(), Flags::cerl()) -> c_bitstr() +%% @equiv ann_c_bitstr(As, Value, Size, abstract(1), Type, Flags) + +-spec ann_c_bitstr(anns(), cerl(), cerl(), cerl(), cerl()) -> c_bitstr(). + +ann_c_bitstr(As, Value, Size, Type, Flags) -> + ann_c_bitstr(As, Value, Size, abstract(1), Type, Flags). + + +%% @spec update_c_bitstr(Old::c_bitstr(), Value::cerl(), Size::cerl(), +%% Unit::cerl(), Type::cerl(), Flags::cerl()) -> c_bitstr() +%% @see c_bitstr/5 +%% @see update_c_bitstr/5 + +-spec update_c_bitstr(c_bitstr(), cerl(), cerl(), cerl(), cerl(), cerl()) -> + c_bitstr(). + +update_c_bitstr(Node, Val, Size, Unit, Type, Flags) -> + #c_bitstr{val = Val, size = Size, unit = Unit, type = Type, + flags = Flags, anno = get_ann(Node)}. + + +%% @spec update_c_bitstr(Old::c_bitstr(), Value::cerl(), Size::cerl(), +%% Type::cerl(), Flags::cerl()) -> c_bitstr() +%% @equiv update_c_bitstr(Node, Value, Size, abstract(1), Type, Flags) + +-spec update_c_bitstr(c_bitstr(), cerl(), cerl(), cerl(), cerl()) -> c_bitstr(). + +update_c_bitstr(Node, Value, Size, Type, Flags) -> + update_c_bitstr(Node, Value, Size, abstract(1), Type, Flags). + +%% @spec is_c_bitstr(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is an abstract +%% bit-string template; otherwise false. +%% +%% @see c_bitstr/5 + +-spec is_c_bitstr(cerl()) -> boolean(). + +is_c_bitstr(#c_bitstr{}) -> + true; +is_c_bitstr(_) -> + false. + + +%% @spec bitstr_val(c_bitstr()) -> cerl() +%% +%% @doc Returns the value subtree of an abstract bit-string template. +%% +%% @see c_bitstr/5 + +-spec bitstr_val(c_bitstr()) -> cerl(). + +bitstr_val(Node) -> + Node#c_bitstr.val. + + +%% @spec bitstr_size(c_bitstr()) -> cerl() +%% +%% @doc Returns the size subtree of an abstract bit-string template. +%% +%% @see c_bitstr/5 + +-spec bitstr_size(c_bitstr()) -> cerl(). + +bitstr_size(Node) -> + Node#c_bitstr.size. + + +%% @spec bitstr_bitsize(c_bitstr()) -> any | all | utf | integer() +%% +%% @doc Returns the total size in bits of an abstract bit-string +%% template. If the size field is an integer literal, the result is the +%% product of the size and unit values; if the size field is the atom +%% literal all, the atom all is returned. +%% If the size is not a literal, the atom any is returned. +%% +%% @see c_bitstr/5 + +-spec bitstr_bitsize(c_bitstr()) -> 'all' | 'any' | 'utf' | non_neg_integer(). + +bitstr_bitsize(Node) -> + Size = Node#c_bitstr.size, + case is_literal(Size) of + true -> + case concrete(Size) of + all -> + all; + undefined -> + %% just an assertion below + "utf" ++ _ = atom_to_list(concrete(Node#c_bitstr.type)), + utf; + S when is_integer(S) -> + S * concrete(Node#c_bitstr.unit) + end; + false -> + any + end. + + +%% @spec bitstr_unit(c_bitstr()) -> cerl() +%% +%% @doc Returns the unit subtree of an abstract bit-string template. +%% +%% @see c_bitstr/5 + +-spec bitstr_unit(c_bitstr()) -> cerl(). + +bitstr_unit(Node) -> + Node#c_bitstr.unit. + + +%% @spec bitstr_type(c_bitstr()) -> cerl() +%% +%% @doc Returns the type subtree of an abstract bit-string template. +%% +%% @see c_bitstr/5 + +-spec bitstr_type(c_bitstr()) -> cerl(). + +bitstr_type(Node) -> + Node#c_bitstr.type. + + +%% @spec bitstr_flags(c_bitstr()) -> cerl() +%% +%% @doc Returns the flags subtree of an abstract bit-string template. +%% +%% @see c_bitstr/5 + +-spec bitstr_flags(c_bitstr()) -> cerl(). + +bitstr_flags(Node) -> + Node#c_bitstr.flags. + + +%% --------------------------------------------------------------------- + +%% @spec c_fun(Variables::[c_var()], Body::cerl()) -> c_fun() +%% +%% @doc Creates an abstract fun-expression. If Variables +%% is [V1, ..., Vn], the result represents "fun +%% (V1, ..., Vn) -> Body". All the +%% Vi must have type var. +%% +%% @see ann_c_fun/3 +%% @see update_c_fun/3 +%% @see is_c_fun/1 +%% @see fun_vars/1 +%% @see fun_body/1 +%% @see fun_arity/1 + +-spec c_fun([c_var()], cerl()) -> c_fun(). + +c_fun(Variables, Body) -> + #c_fun{vars = Variables, body = Body}. + + +%% @spec ann_c_fun(As::anns(), Variables::[c_var()], Body::cerl()) -> +%% c_fun() +%% @see c_fun/2 + +-spec ann_c_fun(anns(), [c_var()], cerl()) -> c_fun(). + +ann_c_fun(As, Variables, Body) -> + #c_fun{vars = Variables, body = Body, anno = As}. + + +%% @spec update_c_fun(Old::c_fun(), Variables::[c_var()], +%% Body::cerl()) -> c_fun() +%% @see c_fun/2 + +-spec update_c_fun(c_fun(), [c_var()], cerl()) -> c_fun(). + +update_c_fun(Node, Variables, Body) -> + #c_fun{vars = Variables, body = Body, anno = get_ann(Node)}. + + +%% @spec is_c_fun(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is an abstract +%% fun-expression, otherwise false. +%% +%% @see c_fun/2 + +-spec is_c_fun(cerl()) -> boolean(). + +is_c_fun(#c_fun{}) -> + true; % Now this is fun! +is_c_fun(_) -> + false. + + +%% @spec fun_vars(c_fun()) -> [c_var()] +%% +%% @doc Returns the list of parameter subtrees of an abstract +%% fun-expression. +%% +%% @see c_fun/2 +%% @see fun_arity/1 + +-spec fun_vars(c_fun()) -> [c_var()]. + +fun_vars(Node) -> + Node#c_fun.vars. + + +%% @spec fun_body(c_fun()) -> cerl() +%% +%% @doc Returns the body subtree of an abstract fun-expression. +%% +%% @see c_fun/2 + +-spec fun_body(c_fun()) -> cerl(). + +fun_body(Node) -> + Node#c_fun.body. + + +%% @spec fun_arity(Node::c_fun()) -> arity() +%% +%% @doc Returns the number of parameter subtrees of an abstract +%% fun-expression. +%% +%%

Note: this is equivalent to length(fun_vars(Node)), +%% but potentially more efficient.

+%% +%% @see c_fun/2 +%% @see fun_vars/1 + +-spec fun_arity(c_fun()) -> arity(). + +fun_arity(Node) -> + length(fun_vars(Node)). + + +%% --------------------------------------------------------------------- + +%% @spec c_seq(Argument::cerl(), Body::cerl()) -> c_seq() +%% +%% @doc Creates an abstract sequencing expression. The result +%% represents "do Argument Body". +%% +%% @see ann_c_seq/3 +%% @see update_c_seq/3 +%% @see is_c_seq/1 +%% @see seq_arg/1 +%% @see seq_body/1 + +-spec c_seq(cerl(), cerl()) -> c_seq(). + +c_seq(Argument, Body) -> + #c_seq{arg = Argument, body = Body}. + + +%% @spec ann_c_seq(As::anns(), Argument::cerl(), Body::cerl()) -> c_seq() +%% +%% @see c_seq/2 + +-spec ann_c_seq(anns(), cerl(), cerl()) -> c_seq(). + +ann_c_seq(As, Argument, Body) -> + #c_seq{arg = Argument, body = Body, anno = As}. + + +%% @spec update_c_seq(Old::c_seq(), Argument::cerl(), Body::cerl()) -> +%% c_seq() +%% @see c_seq/2 + +-spec update_c_seq(c_seq(), cerl(), cerl()) -> c_seq(). + +update_c_seq(Node, Argument, Body) -> + #c_seq{arg = Argument, body = Body, anno = get_ann(Node)}. + + +%% @spec is_c_seq(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is an abstract +%% sequencing expression, otherwise false. +%% +%% @see c_seq/2 + +-spec is_c_seq(cerl()) -> boolean(). + +is_c_seq(#c_seq{}) -> + true; +is_c_seq(_) -> + false. + + +%% @spec seq_arg(c_seq()) -> cerl() +%% +%% @doc Returns the argument subtree of an abstract sequencing +%% expression. +%% +%% @see c_seq/2 + +-spec seq_arg(c_seq()) -> cerl(). + +seq_arg(Node) -> + Node#c_seq.arg. + + +%% @spec seq_body(c_seq()) -> cerl() +%% +%% @doc Returns the body subtree of an abstract sequencing expression. +%% +%% @see c_seq/2 + +-spec seq_body(c_seq()) -> cerl(). + +seq_body(Node) -> + Node#c_seq.body. + + +%% --------------------------------------------------------------------- + +%% @spec c_let(Variables::[c_var()], Argument::cerl(), Body::cerl()) -> +%% c_let() +%% +%% @doc Creates an abstract let-expression. If Variables +%% is [V1, ..., Vn], the result represents "let +%% <V1, ..., Vn> = Argument in +%% Body". All the Vi must have type +%% var. +%% +%% @see ann_c_let/4 +%% @see update_c_let/4 +%% @see is_c_let/1 +%% @see let_vars/1 +%% @see let_arg/1 +%% @see let_body/1 +%% @see let_arity/1 + +-spec c_let([c_var()], cerl(), cerl()) -> c_let(). + +c_let(Variables, Argument, Body) -> + #c_let{vars = Variables, arg = Argument, body = Body}. + + +%% ann_c_let(As, Variables, Argument, Body) -> c_let() +%% @see c_let/3 + +-spec ann_c_let(anns(), [c_var()], cerl(), cerl()) -> c_let(). + +ann_c_let(As, Variables, Argument, Body) -> + #c_let{vars = Variables, arg = Argument, body = Body, anno = As}. + + +%% update_c_let(Old, Variables, Argument, Body) -> c_let() +%% @see c_let/3 + +-spec update_c_let(c_let(), [c_var()], cerl(), cerl()) -> c_let(). + +update_c_let(Node, Variables, Argument, Body) -> + #c_let{vars = Variables, arg = Argument, body = Body, + anno = get_ann(Node)}. + + +%% @spec is_c_let(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is an abstract +%% let-expression, otherwise false. +%% +%% @see c_let/3 + +-spec is_c_let(cerl()) -> boolean(). + +is_c_let(#c_let{}) -> + true; +is_c_let(_) -> + false. + + +%% @spec let_vars(c_let()) -> [c_var()] +%% +%% @doc Returns the list of left-hand side variables of an abstract +%% let-expression. +%% +%% @see c_let/3 +%% @see let_arity/1 + +-spec let_vars(c_let()) -> [c_var()]. + +let_vars(Node) -> + Node#c_let.vars. + + +%% @spec let_arg(c_let()) -> cerl() +%% +%% @doc Returns the argument subtree of an abstract let-expression. +%% +%% @see c_let/3 + +-spec let_arg(c_let()) -> cerl(). + +let_arg(Node) -> + Node#c_let.arg. + + +%% @spec let_body(c_let()) -> cerl() +%% +%% @doc Returns the body subtree of an abstract let-expression. +%% +%% @see c_let/3 + +-spec let_body(c_let()) -> cerl(). + +let_body(Node) -> + Node#c_let.body. + + +%% @spec let_arity(Node::c_let()) -> non_neg_integer() +%% +%% @doc Returns the number of left-hand side variables of an abstract +%% let-expression. +%% +%%

Note: this is equivalent to length(let_vars(Node)), +%% but potentially more efficient.

+%% +%% @see c_let/3 +%% @see let_vars/1 + +-spec let_arity(c_let()) -> non_neg_integer(). + +let_arity(Node) -> + length(let_vars(Node)). + + +%% --------------------------------------------------------------------- + +%% @spec c_letrec(Definitions::defs(), Body::cerl()) -> c_letrec() +%% +%% @doc Creates an abstract letrec-expression. If +%% Definitions is [{V1, F1}, ..., {Vn, Fn}], +%% the result represents "letrec V1 = F1 +%% ... Vn = Fn in Body. All the +%% Vi must have type var and represent +%% function names. All the Fi must have type +%% 'fun'. +%% +%% @see ann_c_letrec/3 +%% @see update_c_letrec/3 +%% @see is_c_letrec/1 +%% @see letrec_defs/1 +%% @see letrec_body/1 +%% @see letrec_vars/1 + +-spec c_letrec(defs(), cerl()) -> c_letrec(). + +c_letrec(Defs, Body) -> + #c_letrec{defs = Defs, body = Body}. + + +%% @spec ann_c_letrec(As::anns(), Definitions::defs(), +%% Body::cerl()) -> c_letrec() +%% @see c_letrec/2 + +-spec ann_c_letrec(anns(), defs(), cerl()) -> c_letrec(). + +ann_c_letrec(As, Defs, Body) -> + #c_letrec{defs = Defs, body = Body, anno = As}. + + +%% @spec update_c_letrec(Old::c_letrec(), Definitions::defs(), +%% Body::cerl()) -> c_letrec() +%% @see c_letrec/2 + +-spec update_c_letrec(c_letrec(), defs(), cerl()) -> c_letrec(). + +update_c_letrec(Node, Defs, Body) -> + #c_letrec{defs = Defs, body = Body, anno = get_ann(Node)}. + + +%% @spec is_c_letrec(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is an abstract +%% letrec-expression, otherwise false. +%% +%% @see c_letrec/2 + +-spec is_c_letrec(cerl()) -> boolean(). + +is_c_letrec(#c_letrec{}) -> + true; +is_c_letrec(_) -> + false. + + +%% @spec letrec_defs(Node::c_letrec()) -> defs() +%% +%% @doc Returns the list of definitions of an abstract +%% letrec-expression. If Node represents "letrec +%% V1 = F1 ... Vn = Fn in +%% Body", the returned value is [{V1, F1}, ..., +%% {Vn, Fn}]. +%% +%% @see c_letrec/2 + +-spec letrec_defs(c_letrec()) -> defs(). + +letrec_defs(Node) -> + Node#c_letrec.defs. + + +%% @spec letrec_body(c_letrec()) -> cerl() +%% +%% @doc Returns the body subtree of an abstract letrec-expression. +%% +%% @see c_letrec/2 + +-spec letrec_body(c_letrec()) -> cerl(). + +letrec_body(Node) -> + Node#c_letrec.body. + + +%% @spec letrec_vars(c_letrec()) -> [cerl()] +%% +%% @doc Returns the list of left-hand side function variable subtrees +%% of a letrec-expression. If Node represents +%% "letrec V1 = F1 ... Vn = +%% Fn in Body", the returned value is +%% [V1, ..., Vn]. +%% +%% @see c_letrec/2 + +-spec letrec_vars(c_letrec()) -> [cerl()]. + +letrec_vars(Node) -> + [F || {F, _} <- letrec_defs(Node)]. + + +%% --------------------------------------------------------------------- + +%% @spec c_case(Argument::cerl(), Clauses::[cerl()]) -> c_case() +%% +%% @doc Creates an abstract case-expression. If Clauses +%% is [C1, ..., Cn], the result represents "case +%% Argument of C1 ... Cn +%% end". Clauses must not be empty. +%% +%% @see ann_c_case/3 +%% @see update_c_case/3 +%% @see is_c_case/1 +%% @see c_clause/3 +%% @see case_arg/1 +%% @see case_clauses/1 +%% @see case_arity/1 + +-spec c_case(cerl(), [cerl()]) -> c_case(). + +c_case(Expr, Clauses) -> + #c_case{arg = Expr, clauses = Clauses}. + + +%% @spec ann_c_case(As::anns(), Argument::cerl(), +%% Clauses::[cerl()]) -> c_case() +%% @see c_case/2 + +-spec ann_c_case(anns(), cerl(), [cerl()]) -> c_case(). + +ann_c_case(As, Expr, Clauses) -> + #c_case{arg = Expr, clauses = Clauses, anno = As}. + + +%% @spec update_c_case(Old::cerl(), Argument::cerl(), +%% Clauses::[cerl()]) -> c_case() +%% @see c_case/2 + +-spec update_c_case(c_case(), cerl(), [cerl()]) -> c_case(). + +update_c_case(Node, Expr, Clauses) -> + #c_case{arg = Expr, clauses = Clauses, anno = get_ann(Node)}. + + +%% is_c_case(Node) -> boolean() +%% +%% Node = cerl() +%% +%% @doc Returns true if Node is an abstract +%% case-expression; otherwise false. +%% +%% @see c_case/2 + +-spec is_c_case(cerl()) -> boolean(). + +is_c_case(#c_case{}) -> + true; +is_c_case(_) -> + false. + + +%% @spec case_arg(c_case()) -> cerl() +%% +%% @doc Returns the argument subtree of an abstract case-expression. +%% +%% @see c_case/2 + +-spec case_arg(c_case()) -> cerl(). + +case_arg(Node) -> + Node#c_case.arg. + + +%% @spec case_clauses(c_case()) -> [cerl()] +%% +%% @doc Returns the list of clause subtrees of an abstract +%% case-expression. +%% +%% @see c_case/2 +%% @see case_arity/1 + +-spec case_clauses(c_case()) -> [cerl()]. + +case_clauses(Node) -> + Node#c_case.clauses. + + +%% @spec case_arity(Node::c_case()) -> non_neg_integer() +%% +%% @doc Equivalent to +%% clause_arity(hd(case_clauses(Node))), but potentially +%% more efficient. +%% +%% @see c_case/2 +%% @see case_clauses/1 +%% @see clause_arity/1 + +-spec case_arity(c_case()) -> non_neg_integer(). + +case_arity(Node) -> + clause_arity(hd(case_clauses(Node))). + + +%% --------------------------------------------------------------------- + +%% @spec c_clause(Patterns::[cerl()], Body::cerl()) -> c_clause() +%% @equiv c_clause(Patterns, c_atom(true), Body) +%% @see c_atom/1 + +-spec c_clause([cerl()], cerl()) -> c_clause(). + +c_clause(Patterns, Body) -> + c_clause(Patterns, c_atom(true), Body). + + +%% @spec c_clause(Patterns::[cerl()], Guard::cerl(), Body::cerl()) -> +%% c_clause() +%% +%% @doc Creates an an abstract clause. If Patterns is +%% [P1, ..., Pn], the result represents +%% "<P1, ..., Pn> when Guard -> +%% Body". +%% +%% @see c_clause/2 +%% @see ann_c_clause/4 +%% @see update_c_clause/4 +%% @see is_c_clause/1 +%% @see c_case/2 +%% @see c_receive/3 +%% @see clause_pats/1 +%% @see clause_guard/1 +%% @see clause_body/1 +%% @see clause_arity/1 +%% @see clause_vars/1 + +-spec c_clause([cerl()], cerl(), cerl()) -> c_clause(). + +c_clause(Patterns, Guard, Body) -> + #c_clause{pats = Patterns, guard = Guard, body = Body}. + + +%% @spec ann_c_clause(As::anns(), Patterns::[cerl()], +%% Body::cerl()) -> c_clause() +%% @equiv ann_c_clause(As, Patterns, c_atom(true), Body) +%% @see c_clause/3 + +-spec ann_c_clause(anns(), [cerl()], cerl()) -> c_clause(). + +ann_c_clause(As, Patterns, Body) -> + ann_c_clause(As, Patterns, c_atom(true), Body). + + +%% @spec ann_c_clause(As::anns(), Patterns::[cerl()], Guard::cerl(), +%% Body::cerl()) -> c_clause() +%% @see ann_c_clause/3 +%% @see c_clause/3 + +-spec ann_c_clause(anns(), [cerl()], cerl(), cerl()) -> c_clause(). + +ann_c_clause(As, Patterns, Guard, Body) -> + #c_clause{pats = Patterns, guard = Guard, body = Body, anno = As}. + + +%% @spec update_c_clause(Old::c_clause(), Patterns::[cerl()], +%% Guard::cerl(), Body::cerl()) -> c_clause() +%% @see c_clause/3 + +-spec update_c_clause(c_clause(), [cerl()], cerl(), cerl()) -> c_clause(). + +update_c_clause(Node, Patterns, Guard, Body) -> + #c_clause{pats = Patterns, guard = Guard, body = Body, + anno = get_ann(Node)}. + + +%% @spec is_c_clause(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is an abstract +%% clause, otherwise false. +%% +%% @see c_clause/3 + +-spec is_c_clause(cerl()) -> boolean(). + +is_c_clause(#c_clause{}) -> + true; +is_c_clause(_) -> + false. + + +%% @spec clause_pats(c_clause()) -> [cerl()] +%% +%% @doc Returns the list of pattern subtrees of an abstract clause. +%% +%% @see c_clause/3 +%% @see clause_arity/1 + +-spec clause_pats(c_clause()) -> [cerl()]. + +clause_pats(Node) -> + Node#c_clause.pats. + + +%% @spec clause_guard(c_clause()) -> cerl() +%% +%% @doc Returns the guard subtree of an abstract clause. +%% +%% @see c_clause/3 + +-spec clause_guard(c_clause()) -> cerl(). + +clause_guard(Node) -> + Node#c_clause.guard. + + +%% @spec clause_body(c_clause()) -> cerl() +%% +%% @doc Returns the body subtree of an abstract clause. +%% +%% @see c_clause/3 + +-spec clause_body(c_clause()) -> cerl(). + +clause_body(Node) -> + Node#c_clause.body. + + +%% @spec clause_arity(Node::c_clause()) -> non_neg_integer() +%% +%% @doc Returns the number of pattern subtrees of an abstract clause. +%% +%%

Note: this is equivalent to +%% length(clause_pats(Node)), but potentially more +%% efficient.

+%% +%% @see c_clause/3 +%% @see clause_pats/1 + +-spec clause_arity(c_clause()) -> non_neg_integer(). + +clause_arity(Node) -> + length(clause_pats(Node)). + + +%% @spec clause_vars(c_clause()) -> [cerl()] +%% +%% @doc Returns the list of all abstract variables in the patterns of +%% an abstract clause. The order of listing is not defined. +%% +%% @see c_clause/3 +%% @see pat_list_vars/1 + +-spec clause_vars(c_clause()) -> [cerl()]. + +clause_vars(Clause) -> + pat_list_vars(clause_pats(Clause)). + + +%% @spec pat_vars(Pattern::cerl()) -> [cerl()] +%% +%% @doc Returns the list of all abstract variables in a pattern. An +%% exception is thrown if Node does not represent a +%% well-formed Core Erlang clause pattern. The order of listing is not +%% defined. +%% +%% @see pat_list_vars/1 +%% @see clause_vars/1 + +-spec pat_vars(cerl()) -> [cerl()]. + +pat_vars(Node) -> + pat_vars(Node, []). + +pat_vars(Node, Vs) -> + case type(Node) of + var -> + [Node | Vs]; + literal -> + Vs; + cons -> + pat_vars(cons_hd(Node), pat_vars(cons_tl(Node), Vs)); + tuple -> + pat_list_vars(tuple_es(Node), Vs); + map -> + pat_list_vars(map_es(Node), Vs); + map_pair -> + %% map_pair_key is not a pattern var, excluded + pat_list_vars([map_pair_op(Node),map_pair_val(Node)],Vs); + binary -> + pat_list_vars(binary_segments(Node), Vs); + bitstr -> + %% bitstr_size is not a pattern var, excluded + pat_vars(bitstr_val(Node), Vs); + alias -> + pat_vars(alias_pat(Node), [alias_var(Node) | Vs]) + end. + + +%% @spec pat_list_vars(Patterns::[cerl()]) -> [cerl()] +%% +%% @doc Returns the list of all abstract variables in the given +%% patterns. An exception is thrown if some element in +%% Patterns does not represent a well-formed Core Erlang +%% clause pattern. The order of listing is not defined. +%% +%% @see pat_vars/1 +%% @see clause_vars/1 + +-spec pat_list_vars([cerl()]) -> [cerl()]. + +pat_list_vars(Ps) -> + pat_list_vars(Ps, []). + +pat_list_vars([P | Ps], Vs) -> + pat_list_vars(Ps, pat_vars(P, Vs)); +pat_list_vars([], Vs) -> + Vs. + + +%% --------------------------------------------------------------------- + +%% @spec c_alias(Variable::c_var(), Pattern::cerl()) -> c_alias() +%% +%% @doc Creates an abstract pattern alias. The result represents +%% "Variable = Pattern". +%% +%% @see ann_c_alias/3 +%% @see update_c_alias/3 +%% @see is_c_alias/1 +%% @see alias_var/1 +%% @see alias_pat/1 +%% @see c_clause/3 + +-spec c_alias(c_var(), cerl()) -> c_alias(). + +c_alias(Var, Pattern) -> + #c_alias{var = Var, pat = Pattern}. + + +%% @spec ann_c_alias(As::anns(), Variable::c_var(), +%% Pattern::cerl()) -> c_alias() +%% @see c_alias/2 + +-spec ann_c_alias(anns(), c_var(), cerl()) -> c_alias(). + +ann_c_alias(As, Var, Pattern) -> + #c_alias{var = Var, pat = Pattern, anno = As}. + + +%% @spec update_c_alias(Old::cerl(), Variable::c_var(), +%% Pattern::cerl()) -> c_alias() +%% @see c_alias/2 + +-spec update_c_alias(c_alias(), c_var(), cerl()) -> c_alias(). + +update_c_alias(Node, Var, Pattern) -> + #c_alias{var = Var, pat = Pattern, anno = get_ann(Node)}. + + +%% @spec is_c_alias(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is an abstract +%% pattern alias, otherwise false. +%% +%% @see c_alias/2 + +-spec is_c_alias(cerl()) -> boolean(). + +is_c_alias(#c_alias{}) -> + true; +is_c_alias(_) -> + false. + + +%% @spec alias_var(c_alias()) -> c_var() +%% +%% @doc Returns the variable subtree of an abstract pattern alias. +%% +%% @see c_alias/2 + +-spec alias_var(c_alias()) -> c_var(). + +alias_var(Node) -> + Node#c_alias.var. + + +%% @spec alias_pat(c_alias()) -> cerl() +%% +%% @doc Returns the pattern subtree of an abstract pattern alias. +%% +%% @see c_alias/2 + +-spec alias_pat(c_alias()) -> cerl(). + +alias_pat(Node) -> + Node#c_alias.pat. + + +%% --------------------------------------------------------------------- + +%% @spec c_receive(Clauses::[cerl()]) -> c_receive() +%% @equiv c_receive(Clauses, c_atom(infinity), c_atom(true)) +%% @see c_atom/1 + +-spec c_receive([cerl()]) -> c_receive(). + +c_receive(Clauses) -> + c_receive(Clauses, c_atom(infinity), c_atom(true)). + + +%% @spec c_receive(Clauses::[cerl()], Timeout::cerl(), +%% Action::cerl()) -> c_receive() +%% +%% @doc Creates an abstract receive-expression. If +%% Clauses is [C1, ..., Cn], the result +%% represents "receive C1 ... Cn after +%% Timeout -> Action end". +%% +%% @see c_receive/1 +%% @see ann_c_receive/4 +%% @see update_c_receive/4 +%% @see is_c_receive/1 +%% @see receive_clauses/1 +%% @see receive_timeout/1 +%% @see receive_action/1 + +-spec c_receive([cerl()], cerl(), cerl()) -> c_receive(). + +c_receive(Clauses, Timeout, Action) -> + #c_receive{clauses = Clauses, timeout = Timeout, action = Action}. + + +%% @spec ann_c_receive(As::anns(), Clauses::[cerl()]) -> c_receive() +%% @equiv ann_c_receive(As, Clauses, c_atom(infinity), c_atom(true)) +%% @see c_receive/3 +%% @see c_atom/1 + +-spec ann_c_receive(anns(), [cerl()]) -> c_receive(). + +ann_c_receive(As, Clauses) -> + ann_c_receive(As, Clauses, c_atom(infinity), c_atom(true)). + + +%% @spec ann_c_receive(As::anns(), Clauses::[cerl()], +%% Timeout::cerl(), Action::cerl()) -> c_receive() +%% @see ann_c_receive/2 +%% @see c_receive/3 + +-spec ann_c_receive(anns(), [cerl()], cerl(), cerl()) -> c_receive(). + +ann_c_receive(As, Clauses, Timeout, Action) -> + #c_receive{clauses = Clauses, timeout = Timeout, action = Action, + anno = As}. + + +%% @spec update_c_receive(Old::cerl(), Clauses::[cerl()], +%% Timeout::cerl(), Action::cerl()) -> c_receive() +%% @see c_receive/3 + +-spec update_c_receive(c_receive(), [cerl()], cerl(), cerl()) -> c_receive(). + +update_c_receive(Node, Clauses, Timeout, Action) -> + #c_receive{clauses = Clauses, timeout = Timeout, action = Action, + anno = get_ann(Node)}. + + +%% @spec is_c_receive(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is an abstract +%% receive-expression, otherwise false. +%% +%% @see c_receive/3 + +-spec is_c_receive(cerl()) -> boolean(). + +is_c_receive(#c_receive{}) -> + true; +is_c_receive(_) -> + false. + + +%% @spec receive_clauses(c_receive()) -> [cerl()] +%% +%% @doc Returns the list of clause subtrees of an abstract +%% receive-expression. +%% +%% @see c_receive/3 + +-spec receive_clauses(c_receive()) -> [cerl()]. + +receive_clauses(Node) -> + Node#c_receive.clauses. + + +%% @spec receive_timeout(c_receive()) -> cerl() +%% +%% @doc Returns the timeout subtree of an abstract receive-expression. +%% +%% @see c_receive/3 + +-spec receive_timeout(c_receive()) -> cerl(). + +receive_timeout(Node) -> + Node#c_receive.timeout. + + +%% @spec receive_action(c_receive()) -> cerl() +%% +%% @doc Returns the action subtree of an abstract receive-expression. +%% +%% @see c_receive/3 + +-spec receive_action(c_receive()) -> cerl(). + +receive_action(Node) -> + Node#c_receive.action. + + +%% --------------------------------------------------------------------- + +%% @spec c_apply(Operator::c_var(), Arguments::[cerl()]) -> c_apply() +%% +%% @doc Creates an abstract function application. If +%% Arguments is [A1, ..., An], the result +%% represents "apply Operator(A1, ..., +%% An)". +%% +%% @see ann_c_apply/3 +%% @see update_c_apply/3 +%% @see is_c_apply/1 +%% @see apply_op/1 +%% @see apply_args/1 +%% @see apply_arity/1 +%% @see c_call/3 +%% @see c_primop/2 + +-spec c_apply(c_var(), [cerl()]) -> c_apply(). + +c_apply(Operator, Arguments) -> + #c_apply{op = Operator, args = Arguments}. + + +%% @spec ann_c_apply(As::anns(), Operator::c_var(), +%% Arguments::[cerl()]) -> c_apply() +%% @see c_apply/2 + +-spec ann_c_apply(anns(), c_var(), [cerl()]) -> c_apply(). + +ann_c_apply(As, Operator, Arguments) -> + #c_apply{op = Operator, args = Arguments, anno = As}. + + +%% @spec update_c_apply(Old::c_apply(), Operator::cerl(), +%% Arguments::[cerl()]) -> c_apply() +%% @see c_apply/2 + +-spec update_c_apply(c_apply(), c_var(), [cerl()]) -> c_apply(). + +update_c_apply(Node, Operator, Arguments) -> + #c_apply{op = Operator, args = Arguments, anno = get_ann(Node)}. + + +%% @spec is_c_apply(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is an abstract +%% function application, otherwise false. +%% +%% @see c_apply/2 + +-spec is_c_apply(cerl()) -> boolean(). + +is_c_apply(#c_apply{}) -> + true; +is_c_apply(_) -> + false. + + +%% @spec apply_op(c_apply()) -> c_var() +%% +%% @doc Returns the operator subtree of an abstract function +%% application. +%% +%% @see c_apply/2 + +-spec apply_op(c_apply()) -> c_var(). + +apply_op(Node) -> + Node#c_apply.op. + + +%% @spec apply_args(c_apply()) -> [cerl()] +%% +%% @doc Returns the list of argument subtrees of an abstract function +%% application. +%% +%% @see c_apply/2 +%% @see apply_arity/1 + +-spec apply_args(c_apply()) -> [cerl()]. + +apply_args(Node) -> + Node#c_apply.args. + + +%% @spec apply_arity(Node::c_apply()) -> arity() +%% +%% @doc Returns the number of argument subtrees of an abstract +%% function application. +%% +%%

Note: this is equivalent to +%% length(apply_args(Node)), but potentially more +%% efficient.

+%% +%% @see c_apply/2 +%% @see apply_args/1 + +-spec apply_arity(c_apply()) -> arity(). + +apply_arity(Node) -> + length(apply_args(Node)). + + +%% --------------------------------------------------------------------- + +%% @spec c_call(Module::cerl(), Name::cerl(), Arguments::[cerl()]) -> +%% c_call() +%% +%% @doc Creates an abstract inter-module call. If +%% Arguments is [A1, ..., An], the result +%% represents "call Module:Name(A1, +%% ..., An)". +%% +%% @see ann_c_call/4 +%% @see update_c_call/4 +%% @see is_c_call/1 +%% @see call_module/1 +%% @see call_name/1 +%% @see call_args/1 +%% @see call_arity/1 +%% @see c_apply/2 +%% @see c_primop/2 + +-spec c_call(cerl(), cerl(), [cerl()]) -> c_call(). + +c_call(Module, Name, Arguments) -> + #c_call{module = Module, name = Name, args = Arguments}. + + +%% @spec ann_c_call(As::anns(), Module::cerl(), Name::cerl(), +%% Arguments::[cerl()]) -> c_call() +%% @see c_call/3 + +-spec ann_c_call(anns(), cerl(), cerl(), [cerl()]) -> c_call(). + +ann_c_call(As, Module, Name, Arguments) -> + #c_call{module = Module, name = Name, args = Arguments, anno = As}. + + +%% @spec update_c_call(Old::cerl(), Module::cerl(), Name::cerl(), +%% Arguments::[cerl()]) -> c_call() +%% @see c_call/3 + +-spec update_c_call(cerl(), cerl(), cerl(), [cerl()]) -> c_call(). + +update_c_call(Node, Module, Name, Arguments) -> + #c_call{module = Module, name = Name, args = Arguments, + anno = get_ann(Node)}. + + +%% @spec is_c_call(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is an abstract +%% inter-module call expression; otherwise false. +%% +%% @see c_call/3 + +-spec is_c_call(cerl()) -> boolean(). + +is_c_call(#c_call{}) -> + true; +is_c_call(_) -> + false. + + +%% @spec call_module(c_call()) -> cerl() +%% +%% @doc Returns the module subtree of an abstract inter-module call. +%% +%% @see c_call/3 + +-spec call_module(c_call()) -> cerl(). + +call_module(Node) -> + Node#c_call.module. + + +%% @spec call_name(c_call()) -> cerl() +%% +%% @doc Returns the name subtree of an abstract inter-module call. +%% +%% @see c_call/3 + +-spec call_name(c_call()) -> cerl(). + +call_name(Node) -> + Node#c_call.name. + + +%% @spec call_args(c_call()) -> [cerl()] +%% +%% @doc Returns the list of argument subtrees of an abstract +%% inter-module call. +%% +%% @see c_call/3 +%% @see call_arity/1 + +-spec call_args(c_call()) -> [cerl()]. + +call_args(Node) -> + Node#c_call.args. + + +%% @spec call_arity(Node::c_call()) -> arity() +%% +%% @doc Returns the number of argument subtrees of an abstract +%% inter-module call. +%% +%%

Note: this is equivalent to +%% length(call_args(Node)), but potentially more +%% efficient.

+%% +%% @see c_call/3 +%% @see call_args/1 + +-spec call_arity(c_call()) -> arity(). + +call_arity(Node) -> + length(call_args(Node)). + + +%% --------------------------------------------------------------------- + +%% @spec c_primop(Name::c_literal(), Arguments::[cerl()]) -> c_primop() +%% +%% @doc Creates an abstract primitive operation call. If +%% Arguments is [A1, ..., An], the result +%% represents "primop Name(A1, ..., +%% An)". Name must be an atom literal. +%% +%% @see ann_c_primop/3 +%% @see update_c_primop/3 +%% @see is_c_primop/1 +%% @see primop_name/1 +%% @see primop_args/1 +%% @see primop_arity/1 +%% @see c_apply/2 +%% @see c_call/3 + +-spec c_primop(c_literal(), [cerl()]) -> c_primop(). + +c_primop(Name, Arguments) -> + #c_primop{name = Name, args = Arguments}. + + +%% @spec ann_c_primop(As::anns(), Name::c_literal(), +%% Arguments::[cerl()]) -> c_primop() +%% @see c_primop/2 + +-spec ann_c_primop(anns(), c_literal(), [cerl()]) -> c_primop(). + +ann_c_primop(As, Name, Arguments) -> + #c_primop{name = Name, args = Arguments, anno = As}. + + +%% @spec update_c_primop(Old::cerl(), Name::c_literal(), +%% Arguments::[cerl()]) -> c_primop() +%% @see c_primop/2 + +-spec update_c_primop(cerl(), c_literal(), [cerl()]) -> c_primop(). + +update_c_primop(Node, Name, Arguments) -> + #c_primop{name = Name, args = Arguments, anno = get_ann(Node)}. + + +%% @spec is_c_primop(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is an abstract +%% primitive operation call, otherwise false. +%% +%% @see c_primop/2 + +-spec is_c_primop(cerl()) -> boolean(). + +is_c_primop(#c_primop{}) -> + true; +is_c_primop(_) -> + false. + + +%% @spec primop_name(c_primop()) -> c_literal() +%% +%% @doc Returns the name subtree of an abstract primitive operation +%% call. +%% +%% @see c_primop/2 + +-spec primop_name(c_primop()) -> c_literal(). + +primop_name(Node) -> + Node#c_primop.name. + + +%% @spec primop_args(c_primop()) -> [cerl()] +%% +%% @doc Returns the list of argument subtrees of an abstract primitive +%% operation call. +%% +%% @see c_primop/2 +%% @see primop_arity/1 + +-spec primop_args(c_primop()) -> [cerl()]. + +primop_args(Node) -> + Node#c_primop.args. + + +%% @spec primop_arity(Node::c_primop()) -> arity() +%% +%% @doc Returns the number of argument subtrees of an abstract +%% primitive operation call. +%% +%%

Note: this is equivalent to +%% length(primop_args(Node)), but potentially more +%% efficient.

+%% +%% @see c_primop/2 +%% @see primop_args/1 + +-spec primop_arity(c_primop()) -> arity(). + +primop_arity(Node) -> + length(primop_args(Node)). + + +%% --------------------------------------------------------------------- + +%% @spec c_try(Argument::cerl(), Variables::[c_var()], Body::cerl(), +%% ExceptionVars::[c_var()], Handler::cerl()) -> c_try() +%% +%% @doc Creates an abstract try-expression. If Variables is +%% [V1, ..., Vn] and ExceptionVars is +%% [X1, ..., Xm], the result represents "try +%% Argument of <V1, ..., Vn> -> +%% Body catch <X1, ..., Xm> -> +%% Handler". All the Vi and Xi +%% must have type var. +%% +%% @see ann_c_try/6 +%% @see update_c_try/6 +%% @see is_c_try/1 +%% @see try_arg/1 +%% @see try_vars/1 +%% @see try_body/1 +%% @see c_catch/1 + +-spec c_try(cerl(), [c_var()], cerl(), [c_var()], cerl()) -> c_try(). + +c_try(Expr, Vs, Body, Evs, Handler) -> + #c_try{arg = Expr, vars = Vs, body = Body, + evars = Evs, handler = Handler}. + + +%% @spec ann_c_try(As::[term()], Expression::cerl(), +%% Variables::[c_var()], Body::cerl(), +%% EVars::[c_var()], Handler::cerl()) -> c_try() +%% @see c_try/5 + +-spec ann_c_try(anns(), cerl(), [c_var()], cerl(), [c_var()], cerl()) -> + c_try(). + +ann_c_try(As, Expr, Vs, Body, Evs, Handler) -> + #c_try{arg = Expr, vars = Vs, body = Body, + evars = Evs, handler = Handler, anno = As}. + + +%% @spec update_c_try(Old::c_try(), Expression::cerl(), +%% Variables::[c_var()], Body::cerl(), +%% EVars::[c_var()], Handler::cerl()) -> cerl() +%% @see c_try/5 + +-spec update_c_try(c_try(), cerl(), [c_var()], cerl(), [c_var()], cerl()) -> + c_try(). + +update_c_try(Node, Expr, Vs, Body, Evs, Handler) -> + #c_try{arg = Expr, vars = Vs, body = Body, + evars = Evs, handler = Handler, anno = get_ann(Node)}. + + +%% @spec is_c_try(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is an abstract +%% try-expression, otherwise false. +%% +%% @see c_try/5 + +-spec is_c_try(cerl()) -> boolean(). + +is_c_try(#c_try{}) -> + true; +is_c_try(_) -> + false. + + +%% @spec try_arg(c_try()) -> cerl() +%% +%% @doc Returns the expression subtree of an abstract try-expression. +%% +%% @see c_try/5 + +-spec try_arg(c_try()) -> cerl(). + +try_arg(Node) -> + Node#c_try.arg. + + +%% @spec try_vars(c_try()) -> [c_var()] +%% +%% @doc Returns the list of success variable subtrees of an abstract +%% try-expression. +%% +%% @see c_try/5 + +-spec try_vars(c_try()) -> [c_var()]. + +try_vars(Node) -> + Node#c_try.vars. + + +%% @spec try_body(c_try()) -> cerl() +%% +%% @doc Returns the success body subtree of an abstract try-expression. +%% +%% @see c_try/5 + +-spec try_body(c_try()) -> cerl(). + +try_body(Node) -> + Node#c_try.body. + + +%% @spec try_evars(c_try()) -> [c_var()] +%% +%% @doc Returns the list of exception variable subtrees of an abstract +%% try-expression. +%% +%% @see c_try/5 + +-spec try_evars(c_try()) -> [c_var()]. + +try_evars(Node) -> + Node#c_try.evars. + + +%% @spec try_handler(c_try()) -> cerl() +%% +%% @doc Returns the exception body subtree of an abstract +%% try-expression. +%% +%% @see c_try/5 + +-spec try_handler(c_try()) -> cerl(). + +try_handler(Node) -> + Node#c_try.handler. + + +%% --------------------------------------------------------------------- + +%% @spec c_catch(Body::cerl()) -> c_catch() +%% +%% @doc Creates an abstract catch-expression. The result represents +%% "catch Body". +%% +%%

Note: catch-expressions can be rewritten as try-expressions, and +%% will eventually be removed from Core Erlang.

+%% +%% @see ann_c_catch/2 +%% @see update_c_catch/2 +%% @see is_c_catch/1 +%% @see catch_body/1 +%% @see c_try/5 + +-spec c_catch(cerl()) -> c_catch(). + +c_catch(Body) -> + #c_catch{body = Body}. + + +%% @spec ann_c_catch(As::anns(), Body::cerl()) -> c_catch() +%% @see c_catch/1 + +-spec ann_c_catch(anns(), cerl()) -> c_catch(). + +ann_c_catch(As, Body) -> + #c_catch{body = Body, anno = As}. + + +%% @spec update_c_catch(Old::c_catch(), Body::cerl()) -> c_catch() +%% @see c_catch/1 + +-spec update_c_catch(c_catch(), cerl()) -> c_catch(). + +update_c_catch(Node, Body) -> + #c_catch{body = Body, anno = get_ann(Node)}. + + +%% @spec is_c_catch(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node is an abstract +%% catch-expression, otherwise false. +%% +%% @see c_catch/1 + +-spec is_c_catch(cerl()) -> boolean(). + +is_c_catch(#c_catch{}) -> + true; +is_c_catch(_) -> + false. + + +%% @spec catch_body(Node::c_catch()) -> cerl() +%% +%% @doc Returns the body subtree of an abstract catch-expression. +%% +%% @see c_catch/1 + +-spec catch_body(c_catch()) -> cerl(). + +catch_body(Node) -> + Node#c_catch.body. + + +%% --------------------------------------------------------------------- + +%% @spec to_records(Tree::cerl()) -> record(record_types()) +%% +%% @doc Translates an abstract syntax tree to a corresponding explicit +%% record representation. The records are defined in the file +%% "cerl.hrl". +%% +%% @see type/1 +%% @see from_records/1 + +-spec to_records(cerl()) -> cerl(). + +to_records(Node) -> + Node. + +%% @spec from_records(Tree::record(record_types())) -> cerl() +%% +%% record_types() = c_alias | c_apply | c_binary | c_bitstr | c_call | +%% c_case | c_catch | c_clause | c_cons | c_fun | +%% c_let | c_letrec | c_literal | c_map | c_map_pair | +%% c_module | c_primop | c_receive | c_seq | +%% c_try | c_tuple | c_values | c_var +%% +%% @doc Translates an explicit record representation to a +%% corresponding abstract syntax tree. The records are defined in the +%% file "core_parse.hrl". +%% +%% @see type/1 +%% @see to_records/1 + +-spec from_records(cerl()) -> cerl(). + +from_records(Node) -> + Node. + + +%% --------------------------------------------------------------------- + +%% @spec is_data(Node::cerl()) -> boolean() +%% +%% @doc Returns true if Node represents a +%% data constructor, otherwise false. Data constructors +%% are cons cells, tuples, and atomic literals. +%% +%% @see data_type/1 +%% @see data_es/1 +%% @see data_arity/1 + +-spec is_data(cerl()) -> boolean(). + +is_data(#c_literal{}) -> + true; +is_data(#c_cons{}) -> + true; +is_data(#c_tuple{}) -> + true; +is_data(_) -> + false. + + +%% @spec data_type(Node::cerl()) -> dtype() +%% +%% dtype() = cons | tuple | {atomic, Value} +%% Value = integer() | float() | atom() | [] +%% +%% @doc Returns a type descriptor for a data constructor +%% node. (Cf. is_data/1.) This is mainly useful for +%% comparing types and for constructing new nodes of the same type +%% (cf. make_data/2). If Node represents an +%% integer, floating-point number, atom or empty list, the result is +%% {atomic, Value}, where Value is the value +%% of concrete(Node), otherwise the result is either +%% cons or tuple. +%% +%%

Type descriptors can be compared for equality or order (in the +%% Erlang term order), but remember that floating-point values should +%% in general never be tested for equality.

+%% +%% @see is_data/1 +%% @see make_data/2 +%% @see type/1 +%% @see concrete/1 + +-type value() :: integer() | float() | atom() | []. +-type dtype() :: 'cons' | 'tuple' | {'atomic', value()}. +-type c_lct() :: c_literal() | c_cons() | c_tuple(). + +-spec data_type(c_lct()) -> dtype(). + +data_type(#c_literal{val = V}) -> + case V of + [_ | _] -> + cons; + _ when is_tuple(V) -> + tuple; + _ -> + {atomic, V} + end; +data_type(#c_cons{}) -> + cons; +data_type(#c_tuple{}) -> + tuple. + +%% @spec data_es(Node::cerl()) -> [cerl()] +%% +%% @doc Returns the list of subtrees of a data constructor node. If +%% the arity of the constructor is zero, the result is the empty list. +%% +%%

Note: if data_type(Node) is cons, the +%% number of subtrees is exactly two. If data_type(Node) +%% is {atomic, Value}, the number of subtrees is +%% zero.

+%% +%% @see is_data/1 +%% @see data_type/1 +%% @see data_arity/1 +%% @see make_data/2 + +-spec data_es(c_lct()) -> [cerl()]. + +data_es(#c_literal{val = V}) -> + case V of + [Head | Tail] -> + [#c_literal{val = Head}, #c_literal{val = Tail}]; + _ when is_tuple(V) -> + make_lit_list(tuple_to_list(V)); + _ -> + [] + end; +data_es(#c_cons{hd = H, tl = T}) -> + [H, T]; +data_es(#c_tuple{es = Es}) -> + Es. + +%% @spec data_arity(Node::cerl()) -> non_neg_integer() +%% +%% @doc Returns the number of subtrees of a data constructor +%% node. This is equivalent to length(data_es(Node)), but +%% potentially more efficient. +%% +%% @see is_data/1 +%% @see data_es/1 + +-spec data_arity(c_lct()) -> non_neg_integer(). + +data_arity(#c_literal{val = V}) -> + case V of + [_ | _] -> + 2; + _ when is_tuple(V) -> + tuple_size(V); + _ -> + 0 + end; +data_arity(#c_cons{}) -> + 2; +data_arity(#c_tuple{es = Es}) -> + length(Es). + + +%% @spec make_data(Type::dtype(), Elements::[cerl()]) -> cerl() +%% +%% @doc Creates a data constructor node with the specified type and +%% subtrees. (Cf. data_type/1.) An exception is thrown +%% if the length of Elements is invalid for the given +%% Type; see data_es/1 for arity constraints +%% on constructor types. +%% +%% @see data_type/1 +%% @see data_es/1 +%% @see ann_make_data/3 +%% @see update_data/3 +%% @see make_data_skel/2 + +-spec make_data(dtype(), [cerl()]) -> c_lct(). + +make_data(CType, Es) -> + ann_make_data([], CType, Es). + + +%% @spec ann_make_data(As::anns(), Type::dtype(), +%% Elements::[cerl()]) -> cerl() +%% @see make_data/2 + +-spec ann_make_data(anns(), dtype(), [cerl()]) -> c_lct(). + +ann_make_data(As, {atomic, V}, []) -> #c_literal{val = V, anno = As}; +ann_make_data(As, cons, [H, T]) -> ann_c_cons(As, H, T); +ann_make_data(As, tuple, Es) -> ann_c_tuple(As, Es). + +%% @spec update_data(Old::cerl(), Type::dtype(), +%% Elements::[cerl()]) -> cerl() +%% @see make_data/2 + +-spec update_data(cerl(), dtype(), [cerl()]) -> c_lct(). + +update_data(Node, CType, Es) -> + ann_make_data(get_ann(Node), CType, Es). + + +%% @spec make_data_skel(Type::dtype(), Elements::[cerl()]) -> cerl() +%% +%% @doc Like make_data/2, but analogous to +%% c_tuple_skel/1 and c_cons_skel/2. +%% +%% @see ann_make_data_skel/3 +%% @see update_data_skel/3 +%% @see make_data/2 +%% @see c_tuple_skel/1 +%% @see c_cons_skel/2 + +-spec make_data_skel(dtype(), [cerl()]) -> c_lct(). + +make_data_skel(CType, Es) -> + ann_make_data_skel([], CType, Es). + + +%% @spec ann_make_data_skel(As::anns(), Type::dtype(), +%% Elements::[cerl()]) -> cerl() +%% @see make_data_skel/2 + +-spec ann_make_data_skel(anns(), dtype(), [cerl()]) -> c_lct(). + +ann_make_data_skel(As, {atomic, V}, []) -> #c_literal{val = V, anno = As}; +ann_make_data_skel(As, cons, [H, T]) -> ann_c_cons_skel(As, H, T); +ann_make_data_skel(As, tuple, Es) -> ann_c_tuple_skel(As, Es). + + +%% @spec update_data_skel(Old::cerl(), Type::dtype(), +%% Elements::[cerl()]) -> cerl() +%% @see make_data_skel/2 + +-spec update_data_skel(cerl(), dtype(), [cerl()]) -> c_lct(). + +update_data_skel(Node, CType, Es) -> + ann_make_data_skel(get_ann(Node), CType, Es). + + +%% --------------------------------------------------------------------- + +%% @spec subtrees(Node::cerl()) -> [[cerl()]] +%% +%% @doc Returns the grouped list of all subtrees of a node. If +%% Node is a leaf node (cf. is_leaf/1), this +%% is the empty list, otherwise the result is always a nonempty list, +%% containing the lists of subtrees of Node, in +%% left-to-right order as they occur in the printed program text, and +%% grouped by category. Often, each group contains only a single +%% subtree. +%% +%%

Depending on the type of Node, the size of some +%% groups may be variable (e.g., the group consisting of all the +%% elements of a tuple), while others always contain the same number +%% of elements - usually exactly one (e.g., the group containing the +%% argument expression of a case-expression). Note, however, that the +%% exact structure of the returned list (for a given node type) should +%% in general not be depended upon, since it might be subject to +%% change without notice.

+%% +%%

The function subtrees/1 and the constructor functions +%% make_tree/2 and update_tree/2 can be a +%% great help if one wants to traverse a syntax tree, visiting all its +%% subtrees, but treat nodes of the tree in a uniform way in most or all +%% cases. Using these functions makes this simple, and also assures that +%% your code is not overly sensitive to extensions of the syntax tree +%% data type, because any node types not explicitly handled by your code +%% can be left to a default case.

+%% +%%

For example: +%% 

+%%   postorder(F, Tree) ->
+%%       F(case subtrees(Tree) of
+%%           [] -> Tree;
+%%           List -> update_tree(Tree,
+%%                               [[postorder(F, Subtree)
+%%                                 || Subtree <- Group]
+%%                                || Group <- List])
+%%         end).
+%%
+%% maps the function F on Tree and all its +%% subtrees, doing a post-order traversal of the syntax tree. (Note +%% the use of update_tree/2 to preserve annotations.) For +%% a simple function like: +%% 
+%%   f(Node) ->
+%%       case type(Node) of
+%%           atom -> atom("a_" ++ atom_name(Node));
+%%           _ -> Node
+%%       end.
+%%
+%% the call postorder(fun f/1, Tree) will yield a new +%% representation of Tree in which all atom names have +%% been extended with the prefix "a_", but nothing else (including +%% annotations) has been changed.

+%% +%% @see is_leaf/1 +%% @see make_tree/2 +%% @see update_tree/2 + +-spec subtrees(cerl()) -> [[cerl()]]. + +subtrees(T) -> + case is_leaf(T) of + true -> + []; + false -> + case type(T) of + values -> + [values_es(T)]; + binary -> + [binary_segments(T)]; + bitstr -> + [[bitstr_val(T)], [bitstr_size(T)], + [bitstr_unit(T)], [bitstr_type(T)], + [bitstr_flags(T)]]; + cons -> + [[cons_hd(T)], [cons_tl(T)]]; + tuple -> + [tuple_es(T)]; + map -> + [map_es(T)]; + map_pair -> + [[map_pair_op(T)],[map_pair_key(T)],[map_pair_val(T)]]; + 'let' -> + [let_vars(T), [let_arg(T)], [let_body(T)]]; + seq -> + [[seq_arg(T)], [seq_body(T)]]; + apply -> + [[apply_op(T)], apply_args(T)]; + call -> + [[call_module(T)], [call_name(T)], + call_args(T)]; + primop -> + [[primop_name(T)], primop_args(T)]; + 'case' -> + [[case_arg(T)], case_clauses(T)]; + clause -> + [clause_pats(T), [clause_guard(T)], + [clause_body(T)]]; + alias -> + [[alias_var(T)], [alias_pat(T)]]; + 'fun' -> + [fun_vars(T), [fun_body(T)]]; + 'receive' -> + [receive_clauses(T), [receive_timeout(T)], + [receive_action(T)]]; + 'try' -> + [[try_arg(T)], try_vars(T), [try_body(T)], + try_evars(T), [try_handler(T)]]; + 'catch' -> + [[catch_body(T)]]; + letrec -> + Es = unfold_tuples(letrec_defs(T)), + [Es, [letrec_body(T)]]; + module -> + As = unfold_tuples(module_attrs(T)), + Es = unfold_tuples(module_defs(T)), + [[module_name(T)], module_exports(T), As, Es] + end + end. + + +%% @spec update_tree(Old::cerl(), Groups::[[cerl()]]) -> cerl() +%% +%% @doc Creates a syntax tree with the given subtrees, and the same +%% type and annotations as the Old node. This is +%% equivalent to ann_make_tree(get_ann(Node), type(Node), +%% Groups), but potentially more efficient. +%% +%% @see update_tree/3 +%% @see ann_make_tree/3 +%% @see get_ann/1 +%% @see type/1 + +-spec update_tree(cerl(), [[cerl()],...]) -> cerl(). + +update_tree(Node, Gs) -> + ann_make_tree(get_ann(Node), type(Node), Gs). + + +%% @spec update_tree(Old::cerl(), Type::ctype(), Groups::[[cerl()]]) -> +%% cerl() +%% +%% @doc Creates a syntax tree with the given type and subtrees, and +%% the same annotations as the Old node. This is +%% equivalent to ann_make_tree(get_ann(Node), Type, +%% Groups), but potentially more efficient. +%% +%% @see update_tree/2 +%% @see ann_make_tree/3 +%% @see get_ann/1 + +-spec update_tree(cerl(), ctype(), [[cerl()],...]) -> cerl(). + +update_tree(Node, Type, Gs) -> + ann_make_tree(get_ann(Node), Type, Gs). + + +%% @spec make_tree(Type::ctype(), Groups::[[cerl()]]) -> cerl() +%% +%% @doc Creates a syntax tree with the given type and subtrees. +%% Type must be a node type name +%% (cf. type/1) that does not denote a leaf node type +%% (cf. is_leaf/1). Groups must be a +%% nonempty list of groups of syntax trees, representing the +%% subtrees of a node of the given type, in left-to-right order as +%% they would occur in the printed program text, grouped by category +%% as done by subtrees/1. +%% +%%

The result of ann_make_tree(get_ann(Node), type(Node), +%% subtrees(Node)) (cf. update_tree/2) represents +%% the same source code text as the original Node, +%% assuming that subtrees(Node) yields a nonempty +%% list. However, it does not necessarily have the exact same data +%% representation as Node.

+%% +%% @see ann_make_tree/3 +%% @see type/1 +%% @see is_leaf/1 +%% @see subtrees/1 +%% @see update_tree/2 + +-spec make_tree(ctype(), [[cerl()],...]) -> cerl(). + +make_tree(Type, Gs) -> + ann_make_tree([], Type, Gs). + + +%% @spec ann_make_tree(As::anns(), Type::ctype(), +%% Groups::[[cerl()]]) -> cerl() +%% +%% @doc Creates a syntax tree with the given annotations, type and +%% subtrees. See make_tree/2 for details. +%% +%% @see make_tree/2 + +-spec ann_make_tree(anns(), ctype(), [[cerl()],...]) -> cerl(). + +ann_make_tree(As, values, [Es]) -> ann_c_values(As, Es); +ann_make_tree(As, binary, [Ss]) -> ann_c_binary(As, Ss); +ann_make_tree(As, bitstr, [[V],[S],[U],[T],[Fs]]) -> + ann_c_bitstr(As, V, S, U, T, Fs); +ann_make_tree(As, cons, [[H], [T]]) -> ann_c_cons(As, H, T); +ann_make_tree(As, tuple, [Es]) -> ann_c_tuple(As, Es); +ann_make_tree(As, map, [Es]) -> ann_c_map(As, Es); +ann_make_tree(As, map, [[A], Es]) -> ann_c_map(As, A, Es); +ann_make_tree(As, map_pair, [[Op], [K], [V]]) -> ann_c_map_pair(As, Op, K, V); +ann_make_tree(As, 'let', [Vs, [A], [B]]) -> ann_c_let(As, Vs, A, B); +ann_make_tree(As, seq, [[A], [B]]) -> ann_c_seq(As, A, B); +ann_make_tree(As, apply, [[Op], Es]) -> ann_c_apply(As, Op, Es); +ann_make_tree(As, call, [[M], [N], Es]) -> ann_c_call(As, M, N, Es); +ann_make_tree(As, primop, [[N], Es]) -> ann_c_primop(As, N, Es); +ann_make_tree(As, 'case', [[A], Cs]) -> ann_c_case(As, A, Cs); +ann_make_tree(As, clause, [Ps, [G], [B]]) -> ann_c_clause(As, Ps, G, B); +ann_make_tree(As, alias, [[V], [P]]) -> ann_c_alias(As, V, P); +ann_make_tree(As, 'fun', [Vs, [B]]) -> ann_c_fun(As, Vs, B); +ann_make_tree(As, 'receive', [Cs, [T], [A]]) -> + ann_c_receive(As, Cs, T, A); +ann_make_tree(As, 'try', [[E], Vs, [B], Evs, [H]]) -> + ann_c_try(As, E, Vs, B, Evs, H); +ann_make_tree(As, 'catch', [[B]]) -> ann_c_catch(As, B); +ann_make_tree(As, letrec, [Es, [B]]) -> + ann_c_letrec(As, fold_tuples(Es), B); +ann_make_tree(As, module, [[N], Xs, Es, Ds]) -> + ann_c_module(As, N, Xs, fold_tuples(Es), fold_tuples(Ds)). + + +%% --------------------------------------------------------------------- + +%% @spec meta(Tree::cerl()) -> cerl() +%% +%% @doc Creates a meta-representation of a syntax tree. The result +%% represents an Erlang expression "MetaTree" +%% which, if evaluated, will yield a new syntax tree representing the +%% same source code text as Tree (although the actual +%% data representation may be different). The expression represented +%% by MetaTree is implementation independent +%% with regard to the data structures used by the abstract syntax tree +%% implementation. +%% +%%

Any node in Tree whose node type is +%% var (cf. type/1), and whose list of +%% annotations (cf. get_ann/1) contains the atom +%% meta_var, will remain unchanged in the resulting tree, +%% except that exactly one occurrence of meta_var is +%% removed from its annotation list.

+%% +%%

The main use of the function meta/1 is to transform +%% a data structure Tree, which represents a piece of +%% program code, into a form that is representation independent +%% when printed. E.g., suppose Tree represents a +%% variable named "V". Then (assuming a function print/1 +%% for printing syntax trees), evaluating +%% print(abstract(Tree)) - simply using +%% abstract/1 to map the actual data structure onto a +%% syntax tree representation - would output a string that might look +%% something like "{var, ..., 'V'}", which is obviously +%% dependent on the implementation of the abstract syntax trees. This +%% could e.g. be useful for caching a syntax tree in a file. However, +%% in some situations like in a program generator generator (with two +%% "generator"), it may be unacceptable. Using +%% print(meta(Tree)) instead would output a +%% representation independent syntax tree generating +%% expression; in the above case, something like +%% "cerl:c_var('V')".

+%% +%%

The implementation tries to generate compact code with respect +%% to literals and lists.

+%% +%% @see abstract/1 +%% @see type/1 +%% @see get_ann/1 + +-spec meta(cerl()) -> cerl(). + +meta(Node) -> + %% First of all we check for metavariables: + case type(Node) of + var -> + case lists:member(meta_var, get_ann(Node)) of + false -> + meta_0(var, Node); + true -> + %% A meta-variable: remove the first found + %% 'meta_var' annotation, but otherwise leave + %% the node unchanged. + set_ann(Node, lists:delete(meta_var, get_ann(Node))) + end; + Type -> + meta_0(Type, Node) + end. + +meta_0(Type, Node) -> + case get_ann(Node) of + [] -> + meta_1(Type, Node); + As -> + meta_call(set_ann, [meta_1(Type, Node), abstract(As)]) + end. + +meta_1(literal, Node) -> + %% We handle atomic literals separately, to get a bit + %% more compact code. For the rest, we use 'abstract'. + case concrete(Node) of + V when is_atom(V) -> + meta_call(c_atom, [Node]); + V when is_integer(V) -> + meta_call(c_int, [Node]); + V when is_float(V) -> + meta_call(c_float, [Node]); + [] -> + meta_call(c_nil, []); + _ -> + meta_call(abstract, [Node]) + end; +meta_1(var, Node) -> + %% A normal variable or function name. + meta_call(c_var, [abstract(var_name(Node))]); +meta_1(values, Node) -> + meta_call(c_values, + [make_list(meta_list(values_es(Node)))]); +meta_1(binary, Node) -> + meta_call(c_binary, + [make_list(meta_list(binary_segments(Node)))]); +meta_1(bitstr, Node) -> + meta_call(c_bitstr, + [meta(bitstr_val(Node)), + meta(bitstr_size(Node)), + meta(bitstr_unit(Node)), + meta(bitstr_type(Node)), + meta(bitstr_flags(Node))]); +meta_1(cons, Node) -> + %% The list is split up if some sublist has annotatations. If + %% we get exactly one element, we generate a 'c_cons' call + %% instead of 'make_list' to reconstruct the node. + case split_list(Node) of + {[H], Node1} -> + meta_call(c_cons, [meta(H), meta(Node1)]); + {L, Node1} -> + meta_call(make_list, + [make_list(meta_list(L)), meta(Node1)]) + end; +meta_1(tuple, Node) -> + meta_call(c_tuple, + [make_list(meta_list(tuple_es(Node)))]); +meta_1('let', Node) -> + meta_call(c_let, + [make_list(meta_list(let_vars(Node))), + meta(let_arg(Node)), meta(let_body(Node))]); +meta_1(seq, Node) -> + meta_call(c_seq, + [meta(seq_arg(Node)), meta(seq_body(Node))]); +meta_1(apply, Node) -> + meta_call(c_apply, + [meta(apply_op(Node)), + make_list(meta_list(apply_args(Node)))]); +meta_1(call, Node) -> + meta_call(c_call, + [meta(call_module(Node)), meta(call_name(Node)), + make_list(meta_list(call_args(Node)))]); +meta_1(primop, Node) -> + meta_call(c_primop, + [meta(primop_name(Node)), + make_list(meta_list(primop_args(Node)))]); +meta_1('case', Node) -> + meta_call(c_case, + [meta(case_arg(Node)), + make_list(meta_list(case_clauses(Node)))]); +meta_1(clause, Node) -> + meta_call(c_clause, + [make_list(meta_list(clause_pats(Node))), + meta(clause_guard(Node)), + meta(clause_body(Node))]); +meta_1(alias, Node) -> + meta_call(c_alias, + [meta(alias_var(Node)), meta(alias_pat(Node))]); +meta_1('fun', Node) -> + meta_call(c_fun, + [make_list(meta_list(fun_vars(Node))), + meta(fun_body(Node))]); +meta_1('receive', Node) -> + meta_call(c_receive, + [make_list(meta_list(receive_clauses(Node))), + meta(receive_timeout(Node)), + meta(receive_action(Node))]); +meta_1('try', Node) -> + meta_call(c_try, + [meta(try_arg(Node)), + make_list(meta_list(try_vars(Node))), + meta(try_body(Node)), + make_list(meta_list(try_evars(Node))), + meta(try_handler(Node))]); +meta_1('catch', Node) -> + meta_call(c_catch, [meta(catch_body(Node))]); +meta_1(letrec, Node) -> + meta_call(c_letrec, + [make_list([c_tuple([meta(N), meta(F)]) + || {N, F} <- letrec_defs(Node)]), + meta(letrec_body(Node))]); +meta_1(module, Node) -> + meta_call(c_module, + [meta(module_name(Node)), + make_list(meta_list(module_exports(Node))), + make_list([c_tuple([meta(A), meta(V)]) + || {A, V} <- module_attrs(Node)]), + make_list([c_tuple([meta(N), meta(F)]) + || {N, F} <- module_defs(Node)])]). + +meta_call(F, As) -> + c_call(c_atom(?MODULE), c_atom(F), As). + +meta_list([T | Ts]) -> + [meta(T) | meta_list(Ts)]; +meta_list([]) -> + []. + +split_list(Node) -> + split_list(set_ann(Node, []), []). + +split_list(Node, L) -> + A = get_ann(Node), + case type(Node) of + cons when A =:= [] -> + split_list(cons_tl(Node), [cons_hd(Node) | L]); + _ -> + {lists:reverse(L), Node} + end. + + +%% --------------------------------------------------------------------- + +%% General utilities + +is_lit_list([#c_literal{} | Es]) -> + is_lit_list(Es); +is_lit_list([_ | _]) -> + false; +is_lit_list([]) -> + true. + +lit_list_vals([#c_literal{val = V} | Es]) -> + [V | lit_list_vals(Es)]; +lit_list_vals([]) -> + []. + +-spec make_lit_list([litval()]) -> [c_literal()]. + +make_lit_list([V | Vs]) -> + [#c_literal{val = V} | make_lit_list(Vs)]; +make_lit_list([]) -> + []. + +%% The following tests are the same as done by 'io_lib:char_list' and +%% 'io_lib:printable_list', respectively, but for a single character. + +is_char_value(V) when V >= $\000, V =< $\377 -> true; +is_char_value(_) -> false. + +is_print_char_value(V) when V >= $\040, V =< $\176 -> true; +is_print_char_value(V) when V >= $\240, V =< $\377 -> true; +is_print_char_value(V) when V =:= $\b -> true; +is_print_char_value(V) when V =:= $\d -> true; +is_print_char_value(V) when V =:= $\e -> true; +is_print_char_value(V) when V =:= $\f -> true; +is_print_char_value(V) when V =:= $\n -> true; +is_print_char_value(V) when V =:= $\r -> true; +is_print_char_value(V) when V =:= $\s -> true; +is_print_char_value(V) when V =:= $\t -> true; +is_print_char_value(V) when V =:= $\v -> true; +is_print_char_value(V) when V =:= $\" -> true; +is_print_char_value(V) when V =:= $\' -> true; %' stupid Emacs. +is_print_char_value(V) when V =:= $\\ -> true; +is_print_char_value(_) -> false. + +is_char_list([V | Vs]) when is_integer(V) -> + is_char_value(V) andalso is_char_list(Vs); +is_char_list([]) -> + true; +is_char_list(_) -> + false. + +is_print_char_list([V | Vs]) when is_integer(V) -> + is_print_char_value(V) andalso is_print_char_list(Vs); +is_print_char_list([]) -> + true; +is_print_char_list(_) -> + false. + +unfold_tuples([{X, Y} | Ps]) -> + [X, Y | unfold_tuples(Ps)]; +unfold_tuples([]) -> + []. + +fold_tuples([X, Y | Es]) -> + [{X, Y} | fold_tuples(Es)]; +fold_tuples([]) -> + []. diff --git a/lib/dialyzer/test/opaque_SUITE_data/src/recrec/core_parse.hrl b/lib/dialyzer/test/opaque_SUITE_data/src/recrec/core_parse.hrl new file mode 100644 index 0000000000..5823622f05 --- /dev/null +++ b/lib/dialyzer/test/opaque_SUITE_data/src/recrec/core_parse.hrl @@ -0,0 +1,122 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1999-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% +%% Purpose : Core Erlang syntax trees as records. + +%% It would be nice to incorporate some generic functions as well but +%% this could make including this file difficult. + +%% Note: the annotation list is *always* the first record field. +%% Thus it is possible to define the macros: +%% -define(get_ann(X), element(2, X)). +%% -define(set_ann(X, Y), setelement(2, X, Y)). + +%% The record definitions appear alphabetically + +-record(c_alias, {anno=[] :: cerl:anns(), + var :: cerl:c_var(), + pat :: cerl:cerl()}). + +-record(c_apply, {anno=[] :: cerl:anns(), + op :: cerl:c_var(), + args :: [cerl:cerl()]}). + +-record(c_binary, {anno=[] :: cerl:anns(), + segments :: [cerl:c_bitstr()]}). + +-record(c_bitstr, {anno=[], val, % val :: Tree, + size, % size :: Tree, + unit, % unit :: Tree, + type, % type :: Tree, + flags}). % flags :: Tree + +-record(c_call, {anno=[], module, % module :: cerl:cerl(), + name, % name :: cerl:cerl(), + args}). % args :: [cerl:cerl()] + +-record(c_case, {anno=[] :: cerl:anns(), + arg :: cerl:cerl(), + clauses :: [cerl:cerl()]}). + +-record(c_catch, {anno=[] :: cerl:anns(), body :: cerl:cerl()}). + +-record(c_clause, {anno=[] :: cerl:anns(), + pats, % :: [cerl:cerl()], % pats :: [Tree], + guard, % :: cerl:cerl(), % guard :: Tree, + body}). % :: cerl:cerl()}). % body :: Tree + +-record(c_cons, {anno=[] :: cerl:anns(), + hd :: cerl:cerl(), + tl :: cerl:cerl()}). + +-record(c_fun, {anno=[] :: cerl:anns(), + vars :: [cerl:c_var()], + body :: cerl:cerl()}). + +-record(c_let, {anno=[] :: cerl:anns(), + vars :: [cerl:c_var()], + arg :: cerl:cerl(), + body :: cerl:cerl()}). + +-record(c_letrec, {anno=[] :: cerl:anns(), + defs :: cerl:defs(), + body :: cerl:cerl()}). + +-record(c_literal, {anno=[] :: cerl:anns(), val :: cerl:litval()}). + +-record(c_map, {anno=[] :: cerl:anns(), + arg=#c_literal{val=#{}} :: cerl:c_var() | cerl:c_literal(), + es :: [cerl:c_map_pair()], + is_pat=false :: boolean()}). + +-record(c_map_pair, {anno=[] :: cerl:anns(), + op, %:: #c_literal{val::'assoc'} | #c_literal{val::'exact'}, + key, + val}). + +-record(c_module, {anno=[] :: cerl:anns(), + name :: cerl:c_literal(), + exports :: [cerl:c_var()], + attrs :: cerl:attrs(), + defs :: cerl:defs()}). + +-record(c_primop, {anno=[] :: cerl:anns(), + name :: cerl:c_literal(), + args :: [cerl:cerl()]}). + +-record(c_receive, {anno=[]:: cerl:anns(), + clauses, % clauses :: [Tree], + timeout, % timeout :: Tree, + action}). % action :: Tree + +-record(c_seq, {anno=[] :: cerl:anns(), + arg, % arg :: cerl:cerl(), + body}). % body :: cerl:cerl() + +-record(c_try, {anno=[], arg, % arg :: cerl:cerl(), + vars, % vars :: [cerl:c_var()], + body, % body :: cerl:cerl(), + evars, % evars :: [cerl:c_var()], + handler}). % handler :: cerl:cerl() + +-record(c_tuple, {anno=[] :: cerl:anns(), es :: [cerl:cerl()]}). + +-record(c_values, {anno=[] :: cerl:anns(), es :: [cerl:cerl()]}). + +-record(c_var, {anno=[] :: cerl:anns(), name :: cerl:var_name()}). diff --git a/lib/dialyzer/test/opaque_SUITE_data/src/recrec/dialyzer.hrl b/lib/dialyzer/test/opaque_SUITE_data/src/recrec/dialyzer.hrl new file mode 100644 index 0000000000..ea6a71217c --- /dev/null +++ b/lib/dialyzer/test/opaque_SUITE_data/src/recrec/dialyzer.hrl @@ -0,0 +1,180 @@ +%%% This is an -*- Erlang -*- file. +%%% +%%% %CopyrightBegin% +%%% +%%% Copyright Ericsson AB 2006-2015. All Rights Reserved. +%%% +%%% Licensed under the Apache License, Version 2.0 (the "License"); +%%% you may not use this file except in compliance with the License. +%%% You may obtain a copy of the License at +%%% +%%% http://www.apache.org/licenses/LICENSE-2.0 +%%% +%%% Unless required by applicable law or agreed to in writing, software +%%% distributed under the License is distributed on an "AS IS" BASIS, +%%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%%% See the License for the specific language governing permissions and +%%% limitations under the License. +%%% +%%% %CopyrightEnd% +%%% +%%%------------------------------------------------------------------- +%%% File : dialyzer.hrl +%%% Author : Tobias Lindahl +%%% Kostis Sagonas +%%% Description : Header file for Dialyzer. +%%% +%%% Created : 1 Oct 2004 by Kostis Sagonas +%%%------------------------------------------------------------------- + +-define(RET_NOTHING_SUSPICIOUS, 0). +-define(RET_INTERNAL_ERROR, 1). +-define(RET_DISCREPANCIES, 2). + +-type dial_ret() :: ?RET_NOTHING_SUSPICIOUS + | ?RET_INTERNAL_ERROR + | ?RET_DISCREPANCIES. + +%%-------------------------------------------------------------------- +%% Warning classification +%%-------------------------------------------------------------------- + +-define(WARN_RETURN_NO_RETURN, warn_return_no_exit). +-define(WARN_RETURN_ONLY_EXIT, warn_return_only_exit). +-define(WARN_NOT_CALLED, warn_not_called). +-define(WARN_NON_PROPER_LIST, warn_non_proper_list). +-define(WARN_FUN_APP, warn_fun_app). +-define(WARN_MATCHING, warn_matching). +-define(WARN_OPAQUE, warn_opaque). +-define(WARN_FAILING_CALL, warn_failing_call). +-define(WARN_BIN_CONSTRUCTION, warn_bin_construction). +-define(WARN_CONTRACT_TYPES, warn_contract_types). +-define(WARN_CONTRACT_SYNTAX, warn_contract_syntax). +-define(WARN_CONTRACT_NOT_EQUAL, warn_contract_not_equal). +-define(WARN_CONTRACT_SUBTYPE, warn_contract_subtype). +-define(WARN_CONTRACT_SUPERTYPE, warn_contract_supertype). +-define(WARN_CONTRACT_RANGE, warn_contract_range). +-define(WARN_CALLGRAPH, warn_callgraph). +-define(WARN_UNMATCHED_RETURN, warn_umatched_return). +-define(WARN_RACE_CONDITION, warn_race_condition). +-define(WARN_BEHAVIOUR, warn_behaviour). +-define(WARN_UNDEFINED_CALLBACK, warn_undefined_callbacks). +-define(WARN_UNKNOWN, warn_unknown). +-define(WARN_MAP_CONSTRUCTION, warn_map_construction). + +%% +%% The following type has double role: +%% 1. It is the set of warnings that will be collected. +%% 2. It is also the set of tags for warnings that will be returned. +%% +-type dial_warn_tag() :: ?WARN_RETURN_NO_RETURN | ?WARN_RETURN_ONLY_EXIT + | ?WARN_NOT_CALLED | ?WARN_NON_PROPER_LIST + | ?WARN_MATCHING | ?WARN_OPAQUE | ?WARN_FUN_APP + | ?WARN_FAILING_CALL | ?WARN_BIN_CONSTRUCTION + | ?WARN_CONTRACT_TYPES | ?WARN_CONTRACT_SYNTAX + | ?WARN_CONTRACT_NOT_EQUAL | ?WARN_CONTRACT_SUBTYPE + | ?WARN_CONTRACT_SUPERTYPE | ?WARN_CALLGRAPH + | ?WARN_UNMATCHED_RETURN | ?WARN_RACE_CONDITION + | ?WARN_BEHAVIOUR | ?WARN_CONTRACT_RANGE + | ?WARN_UNDEFINED_CALLBACK | ?WARN_UNKNOWN + | ?WARN_MAP_CONSTRUCTION. + +%% +%% This is the representation of each warning as they will be returned +%% to dialyzer's callers +%% +-type file_line() :: {file:filename(), non_neg_integer()}. +-type dial_warning() :: {dial_warn_tag(), file_line(), {atom(), [term()]}}. + +%% +%% This is the representation of each warning before suppressions have +%% been applied +%% +-type m_or_mfa() :: module() % warnings not associated with any function + | mfa(). +-type warning_info() :: {file:filename(), non_neg_integer(), m_or_mfa()}. +-type raw_warning() :: {dial_warn_tag(), warning_info(), {atom(), [term()]}}. + +%% +%% This is the representation of dialyzer's internal errors +%% +-type dial_error() :: any(). %% XXX: underspecified + +%%-------------------------------------------------------------------- +%% Basic types used either in the record definitions below or in other +%% parts of the application +%%-------------------------------------------------------------------- + +-type anal_type() :: 'succ_typings' | 'plt_build'. +-type anal_type1() :: anal_type() | 'plt_add' | 'plt_check' | 'plt_remove'. +-type contr_constr() :: {'subtype', erl_types:erl_type(), erl_types:erl_type()}. +-type contract_pair() :: {erl_types:erl_type(), [contr_constr()]}. +-type dial_define() :: {atom(), term()}. +-type dial_option() :: {atom(), term()}. +-type dial_options() :: [dial_option()]. +-type fopt() :: 'basename' | 'fullpath'. +-type format() :: 'formatted' | 'raw'. +-type label() :: non_neg_integer(). +-type dial_warn_tags():: ordsets:ordset(dial_warn_tag()). +-type rep_mode() :: 'quiet' | 'normal' | 'verbose'. +-type start_from() :: 'byte_code' | 'src_code'. +-type mfa_or_funlbl() :: label() | mfa(). +-type solver() :: 'v1' | 'v2'. + +%%-------------------------------------------------------------------- +%% Record declarations used by various files +%%-------------------------------------------------------------------- + +-type doc_plt() :: 'undefined' | dialyzer_plt:plt(). + +-record(analysis, {analysis_pid :: pid() | 'undefined', + type = succ_typings :: anal_type(), + defines = [] :: [dial_define()], + doc_plt :: doc_plt(), + files = [] :: [file:filename()], + include_dirs = [] :: [file:filename()], + start_from = byte_code :: start_from(), + plt :: dialyzer_plt:plt(), + use_contracts = true :: boolean(), + race_detection = false :: boolean(), + behaviours_chk = false :: boolean(), + timing = false :: boolean() | 'debug', + timing_server = none :: dialyzer_timing:timing_server(), + callgraph_file = "" :: file:filename(), + solvers :: [solver()]}). + +-record(options, {files = [] :: [file:filename()], + files_rec = [] :: [file:filename()], + analysis_type = succ_typings :: anal_type1(), + timing = false :: boolean() | 'debug', + defines = [] :: [dial_define()], + from = byte_code :: start_from(), + get_warnings = maybe :: boolean() | 'maybe', + init_plts = [] :: [file:filename()], + include_dirs = [] :: [file:filename()], + output_plt = none :: 'none' | file:filename(), + legal_warnings = ordsets:new() :: dial_warn_tags(), + report_mode = normal :: rep_mode(), + erlang_mode = false :: boolean(), + use_contracts = true :: boolean(), + output_file = none :: 'none' | file:filename(), + output_format = formatted :: format(), + filename_opt = basename :: fopt(), + callgraph_file = "" :: file:filename(), + check_plt = true :: boolean(), + solvers = [] :: [solver()]}). + +-record(contract, {contracts = [] :: [contract_pair()], + args = [] :: [erl_types:erl_type()], + forms = [] :: [{_, _}]}). + +%%-------------------------------------------------------------------- + +-define(timing(Server, Msg, Var, Expr), + begin + dialyzer_timing:start_stamp(Server, Msg), + Var = Expr, + dialyzer_timing:end_stamp(Server), + Var + end). +-define(timing(Server, Msg, Expr), ?timing(Server, Msg, _T, Expr)). diff --git a/lib/dialyzer/test/opaque_SUITE_data/src/recrec/dialyzer_dataflow.erl b/lib/dialyzer/test/opaque_SUITE_data/src/recrec/dialyzer_dataflow.erl new file mode 100644 index 0000000000..9399789464 --- /dev/null +++ b/lib/dialyzer/test/opaque_SUITE_data/src/recrec/dialyzer_dataflow.erl @@ -0,0 +1,3802 @@ +%% -*- erlang-indent-level: 2 -*- +%%-------------------------------------------------------------------- +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2006-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% + +%%%------------------------------------------------------------------- +%%% File : dialyzer_dataflow.erl +%%% Author : Tobias Lindahl +%%% Description : +%%% +%%% Created : 19 Apr 2005 by Tobias Lindahl +%%%------------------------------------------------------------------- + +-module(dialyzer_dataflow). + +-export([get_fun_types/5, get_warnings/5, format_args/3]). + +%% Data structure interfaces. +-export([state__add_warning/2, state__cleanup/1, + state__duplicate/1, dispose_state/1, + state__get_callgraph/1, state__get_races/1, + state__get_records/1, state__put_callgraph/2, + state__put_races/2, state__records_only/1, + state__find_function/2]). + +-export_type([state/0]). + +-include("dialyzer.hrl"). + +-import(erl_types, + [t_inf/2, t_inf/3, t_inf_lists/2, t_inf_lists/3, + t_inf_lists/3, t_is_equal/2, t_is_subtype/2, t_subtract/2, + t_sup/1, t_sup/2]). + +-import(erl_types, + [any_none/1, t_any/0, t_atom/0, t_atom/1, t_atom_vals/1, t_atom_vals/2, + t_binary/0, t_boolean/0, + t_bitstr/0, t_bitstr/2, t_bitstr_concat/1, t_bitstr_match/2, + t_cons/0, t_cons/2, t_cons_hd/2, t_cons_tl/2, + t_contains_opaque/2, + t_find_opaque_mismatch/3, t_float/0, t_from_range/2, t_from_term/1, + t_fun/0, t_fun/2, t_fun_args/1, t_fun_args/2, t_fun_range/1, + t_fun_range/2, t_integer/0, t_integers/1, + t_is_any/1, t_is_atom/1, t_is_atom/2, t_is_any_atom/3, + t_is_boolean/2, + t_is_integer/2, t_is_list/1, + t_is_nil/2, t_is_none/1, t_is_none_or_unit/1, + t_is_number/2, t_is_reference/2, t_is_pid/2, t_is_port/2, + t_is_unit/1, + t_limit/2, t_list/0, t_list_elements/2, + t_maybe_improper_list/0, t_module/0, + t_none/0, t_non_neg_integer/0, t_number/0, t_number_vals/2, + t_pid/0, t_port/0, t_product/1, t_reference/0, + t_to_string/2, t_to_tlist/1, + t_tuple/0, t_tuple/1, t_tuple_args/1, t_tuple_args/2, + t_tuple_subtypes/2, + t_unit/0, t_unopaque/2, + t_map/0, t_map/1, t_is_singleton/2 + ]). + +%%-define(DEBUG, true). +%%-define(DEBUG_PP, true). +%%-define(DEBUG_TIME, true). + +-ifdef(DEBUG). +-import(erl_types, [t_to_string/1]). +-define(debug(S_, L_), io:format(S_, L_)). +-else. +-define(debug(S_, L_), ok). +-endif. + +%%-------------------------------------------------------------------- + +-type type() :: erl_types:erl_type(). +-type types() :: erl_types:type_table(). + +-type curr_fun() :: 'undefined' | 'top' | mfa_or_funlbl(). + +-define(no_arg, no_arg). + +-define(TYPE_LIMIT, 3). + +-define(BITS, 128). + +%% Types with comment 'race' are due to dialyzer_races.erl. +-record(state, {callgraph :: dialyzer_callgraph:callgraph() + | 'undefined', % race + codeserver :: dialyzer_codeserver:codeserver() + | 'undefined', % race + envs :: env_tab() + | 'undefined', % race + fun_tab :: fun_tab() + | 'undefined', % race + fun_homes :: dict:dict(label(), mfa()) + | 'undefined', % race + plt :: dialyzer_plt:plt() + | 'undefined', % race + opaques :: [type()] + | 'undefined', % race + races = dialyzer_races:new() :: dialyzer_races:races(), + records = dict:new() :: types(), + tree_map :: dict:dict(label(), cerl:cerl()) + | 'undefined', % race + warning_mode = false :: boolean(), + warnings = [] :: [raw_warning()], + work :: {[_], [_], sets:set()} + | 'undefined', % race + module :: module(), + curr_fun :: curr_fun() + }). + +-record(map, {map = maps:new() :: type_tab(), + subst = maps:new() :: subst_tab(), + modified = [] :: [Key :: term()], + modified_stack = [] :: [{[Key :: term()],reference()}], + ref = undefined :: reference() | undefined}). + +-type env_tab() :: dict:dict(label(), #map{}). +-type fun_entry() :: {Args :: [type()], RetType :: type()}. +-type fun_tab() :: dict:dict('top' | label(), + {'not_handled', fun_entry()} | fun_entry()). +-type key() :: label() | cerl:cerl(). +-type type_tab() :: #{key() => type()}. +-type subst_tab() :: #{key() => cerl:cerl()}. + +%% Exported Types + +-opaque state() :: #state{}. + +%%-------------------------------------------------------------------- + +-type fun_types() :: dict:dict(label(), type()). + +-spec get_warnings(cerl:c_module(), dialyzer_plt:plt(), + dialyzer_callgraph:callgraph(), + dialyzer_codeserver:codeserver(), + types()) -> + {[raw_warning()], fun_types()}. + +get_warnings(Tree, Plt, Callgraph, Codeserver, Records) -> + State1 = analyze_module(Tree, Plt, Callgraph, Codeserver, Records, true), + State2 = state__renew_warnings(state__get_warnings(State1), State1), + State3 = state__get_race_warnings(State2), + {State3#state.warnings, state__all_fun_types(State3)}. + +-spec get_fun_types(cerl:c_module(), dialyzer_plt:plt(), + dialyzer_callgraph:callgraph(), + dialyzer_codeserver:codeserver(), + types()) -> fun_types(). + +get_fun_types(Tree, Plt, Callgraph, Codeserver, Records) -> + State = analyze_module(Tree, Plt, Callgraph, Codeserver, Records, false), + state__all_fun_types(State). + +%%% =========================================================================== +%%% +%%% The analysis. +%%% +%%% =========================================================================== + +analyze_module(Tree, Plt, Callgraph, Codeserver, Records, GetWarnings) -> + debug_pp(Tree, false), + Module = cerl:atom_val(cerl:module_name(Tree)), + TopFun = cerl:ann_c_fun([{label, top}], [], Tree), + State = state__new(Callgraph, Codeserver, TopFun, Plt, Module, Records), + State1 = state__race_analysis(not GetWarnings, State), + State2 = analyze_loop(State1), + case GetWarnings of + true -> + State3 = state__set_warning_mode(State2), + State4 = analyze_loop(State3), + dialyzer_races:race(State4); + false -> + State2 + end. + +analyze_loop(State) -> + case state__get_work(State) of + none -> state__set_curr_fun(undefined, State); + {Fun, NewState0} -> + NewState1 = state__set_curr_fun(get_label(Fun), NewState0), + {ArgTypes, IsCalled} = state__get_args_and_status(Fun, NewState1), + case not IsCalled of + true -> + ?debug("Not handling (not called) ~w: ~s\n", + [NewState1#state.curr_fun, + t_to_string(t_product(ArgTypes))]), + analyze_loop(NewState1); + false -> + case state__fun_env(Fun, NewState1) of + none -> + ?debug("Not handling (no env) ~w: ~s\n", + [NewState1#state.curr_fun, + t_to_string(t_product(ArgTypes))]), + analyze_loop(NewState1); + Map -> + ?debug("Handling fun ~p: ~s\n", + [NewState1#state.curr_fun, + t_to_string(state__fun_type(Fun, NewState1))]), + Vars = cerl:fun_vars(Fun), + Map1 = enter_type_lists(Vars, ArgTypes, Map), + Body = cerl:fun_body(Fun), + FunLabel = get_label(Fun), + IsRaceAnalysisEnabled = is_race_analysis_enabled(State), + NewState3 = + case IsRaceAnalysisEnabled of + true -> + NewState2 = state__renew_curr_fun( + state__lookup_name(FunLabel, NewState1), FunLabel, + NewState1), + state__renew_race_list([], 0, NewState2); + false -> NewState1 + end, + {NewState4, _Map2, BodyType} = + traverse(Body, Map1, NewState3), + ?debug("Done analyzing: ~w:~s\n", + [NewState1#state.curr_fun, + t_to_string(t_fun(ArgTypes, BodyType))]), + NewState5 = + case IsRaceAnalysisEnabled of + true -> renew_race_code(NewState4); + false -> NewState4 + end, + NewState6 = + state__update_fun_entry(Fun, ArgTypes, BodyType, NewState5), + ?debug("done adding stuff for ~w\n", + [state__lookup_name(get_label(Fun), State)]), + analyze_loop(NewState6) + end + end + end. + +traverse(Tree, Map, State) -> + ?debug("Handling ~p\n", [cerl:type(Tree)]), + %% debug_pp_map(Map), + case cerl:type(Tree) of + alias -> + %% This only happens when checking for illegal record patterns + %% so the handling is a bit rudimentary. + traverse(cerl:alias_pat(Tree), Map, State); + apply -> + handle_apply(Tree, Map, State); + binary -> + Segs = cerl:binary_segments(Tree), + {State1, Map1, SegTypes} = traverse_list(Segs, Map, State), + {State1, Map1, t_bitstr_concat(SegTypes)}; + bitstr -> + handle_bitstr(Tree, Map, State); + call -> + handle_call(Tree, Map, State); + 'case' -> + handle_case(Tree, Map, State); + 'catch' -> + {State1, _Map1, _} = traverse(cerl:catch_body(Tree), Map, State), + {State1, Map, t_any()}; + cons -> + handle_cons(Tree, Map, State); + 'fun' -> + Type = state__fun_type(Tree, State), + case state__warning_mode(State) of + true -> {State, Map, Type}; + false -> + State2 = state__add_work(get_label(Tree), State), + State3 = state__update_fun_env(Tree, Map, State2), + {State3, Map, Type} + end; + 'let' -> + handle_let(Tree, Map, State); + letrec -> + Defs = cerl:letrec_defs(Tree), + Body = cerl:letrec_body(Tree), + %% By not including the variables in scope we can assure that we + %% will get the current function type when using the variables. + FoldFun = fun({Var, Fun}, {AccState, AccMap}) -> + {NewAccState, NewAccMap0, FunType} = + traverse(Fun, AccMap, AccState), + NewAccMap = enter_type(Var, FunType, NewAccMap0), + {NewAccState, NewAccMap} + end, + {State1, Map1} = lists:foldl(FoldFun, {State, Map}, Defs), + traverse(Body, Map1, State1); + literal -> + Type = literal_type(Tree), + {State, Map, Type}; + module -> + handle_module(Tree, Map, State); + primop -> + Type = + case cerl:atom_val(cerl:primop_name(Tree)) of + match_fail -> t_none(); + raise -> t_none(); + bs_init_writable -> t_from_term(<<>>); + Other -> erlang:error({'Unsupported primop', Other}) + end, + {State, Map, Type}; + 'receive' -> + handle_receive(Tree, Map, State); + seq -> + Arg = cerl:seq_arg(Tree), + Body = cerl:seq_body(Tree), + {State1, Map1, ArgType} = SMA = traverse(Arg, Map, State), + case t_is_none_or_unit(ArgType) of + true -> + SMA; + false -> + State2 = + case + t_is_any(ArgType) + orelse t_is_simple(ArgType, State) + orelse is_call_to_send(Arg) + orelse is_lc_simple_list(Arg, ArgType, State) + of + true -> % do not warn in these cases + State1; + false -> + state__add_warning(State1, ?WARN_UNMATCHED_RETURN, Arg, + {unmatched_return, + [format_type(ArgType, State1)]}) + end, + traverse(Body, Map1, State2) + end; + 'try' -> + handle_try(Tree, Map, State); + tuple -> + handle_tuple(Tree, Map, State); + map -> + handle_map(Tree, Map, State); + values -> + Elements = cerl:values_es(Tree), + {State1, Map1, EsType} = traverse_list(Elements, Map, State), + Type = t_product(EsType), + {State1, Map1, Type}; + var -> + ?debug("Looking up unknown variable: ~p\n", [Tree]), + case state__lookup_type_for_letrec(Tree, State) of + error -> + LType = lookup_type(Tree, Map), + {State, Map, LType}; + {ok, Type} -> {State, Map, Type} + end; + Other -> + erlang:error({'Unsupported type', Other}) + end. + +traverse_list(Trees, Map, State) -> + traverse_list(Trees, Map, State, []). + +traverse_list([Tree|Tail], Map, State, Acc) -> + {State1, Map1, Type} = traverse(Tree, Map, State), + traverse_list(Tail, Map1, State1, [Type|Acc]); +traverse_list([], Map, State, Acc) -> + {State, Map, lists:reverse(Acc)}. + +%%________________________________________ +%% +%% Special instructions +%% + +handle_apply(Tree, Map, State) -> + Args = cerl:apply_args(Tree), + Op = cerl:apply_op(Tree), + {State0, Map1, ArgTypes} = traverse_list(Args, Map, State), + {State1, Map2, OpType} = traverse(Op, Map1, State0), + case any_none(ArgTypes) of + true -> + {State1, Map2, t_none()}; + false -> + FunList = + case state__lookup_call_site(Tree, State) of + error -> [external]; %% so that we go directly in the fallback + {ok, List} -> List + end, + FunInfoList = [{local, state__fun_info(Fun, State)} || Fun <- FunList], + case + handle_apply_or_call(FunInfoList, Args, ArgTypes, Map2, Tree, State1) + of + {had_external, State2} -> + %% Fallback: use whatever info we collected from traversing the op + %% instead of the result that has been generalized to t_any(). + Arity = length(Args), + OpType1 = t_inf(OpType, t_fun(Arity, t_any())), + case t_is_none(OpType1) of + true -> + Msg = {fun_app_no_fun, + [format_cerl(Op), format_type(OpType, State2), Arity]}, + State3 = state__add_warning(State2, ?WARN_FAILING_CALL, + Tree, Msg), + {State3, Map2, t_none()}; + false -> + NewArgs = t_inf_lists(ArgTypes, + t_fun_args(OpType1, 'universe')), + case any_none(NewArgs) of + true -> + Msg = {fun_app_args, + [format_args(Args, ArgTypes, State), + format_type(OpType, State)]}, + State3 = state__add_warning(State2, ?WARN_FAILING_CALL, + Tree, Msg), + {State3, enter_type(Op, OpType1, Map2), t_none()}; + false -> + Map3 = enter_type_lists(Args, NewArgs, Map2), + Range0 = t_fun_range(OpType1, 'universe'), + Range = + case t_is_unit(Range0) of + true -> t_none(); + false -> Range0 + end, + {State2, enter_type(Op, OpType1, Map3), Range} + end + end; + Normal -> Normal + end + end. + +handle_apply_or_call(FunInfoList, Args, ArgTypes, Map, Tree, State) -> + None = t_none(), + %% Call-site analysis may be inaccurate and consider more funs than those that + %% are actually possible. If all of them are incorrect, then warnings can be + %% emitted. If at least one fun is ok, however, then no warning is emitted, + %% just in case the bad ones are not really possible. The last argument is + %% used for this, with the following encoding: + %% Initial value: {none, []} + %% First fun checked: {one, } + %% More funs checked: {many, } + %% A '{one, []}' can only become '{many, []}'. + %% If at any point an fun does not add warnings, then the list is also + %% replaced with an empty list. + handle_apply_or_call(FunInfoList, Args, ArgTypes, Map, Tree, State, + [None || _ <- ArgTypes], None, false, {none, []}). + +handle_apply_or_call([{local, external}|Left], Args, ArgTypes, Map, Tree, State, + _AccArgTypes, _AccRet, _HadExternal, Warns) -> + {HowMany, _} = Warns, + NewHowMany = + case HowMany of + none -> one; + _ -> many + end, + NewWarns = {NewHowMany, []}, + handle_apply_or_call(Left, Args, ArgTypes, Map, Tree, State, + ArgTypes, t_any(), true, NewWarns); +handle_apply_or_call([{TypeOfApply, {Fun, Sig, Contr, LocalRet}}|Left], + Args, ArgTypes, Map, Tree, + #state{opaques = Opaques} = State, + AccArgTypes, AccRet, HadExternal, Warns) -> + Any = t_any(), + AnyArgs = [Any || _ <- Args], + GenSig = {AnyArgs, fun(_) -> t_any() end}, + {CArgs, CRange} = + case Contr of + {value, #contract{args = As} = C} -> + {As, fun(FunArgs) -> + dialyzer_contracts:get_contract_return(C, FunArgs) + end}; + none -> GenSig + end, + {BifArgs, BifRange} = + case TypeOfApply of + remote -> + {M, F, A} = Fun, + case erl_bif_types:is_known(M, F, A) of + true -> + BArgs = erl_bif_types:arg_types(M, F, A), + BRange = + fun(FunArgs) -> + erl_bif_types:type(M, F, A, FunArgs, Opaques) + end, + {BArgs, BRange}; + false -> + GenSig + end; + local -> GenSig + end, + {SigArgs, SigRange} = + case Sig of + {value, {SR, SA}} -> {SA, SR}; + none -> {AnyArgs, t_any()} + end, + + ?debug("--------------------------------------------------------\n", []), + ?debug("Fun: ~p\n", [state__lookup_name(Fun, State)]), + ?debug("Module ~p\n", [State#state.module]), + ?debug("CArgs ~s\n", [erl_types:t_to_string(t_product(CArgs))]), + ?debug("ArgTypes ~s\n", [erl_types:t_to_string(t_product(ArgTypes))]), + ?debug("BifArgs ~p\n", [erl_types:t_to_string(t_product(BifArgs))]), + + NewArgsSig = t_inf_lists(SigArgs, ArgTypes, Opaques), + ?debug("SigArgs ~s\n", [erl_types:t_to_string(t_product(SigArgs))]), + ?debug("NewArgsSig: ~s\n", [erl_types:t_to_string(t_product(NewArgsSig))]), + NewArgsContract = t_inf_lists(CArgs, ArgTypes, Opaques), + ?debug("NewArgsContract: ~s\n", + [erl_types:t_to_string(t_product(NewArgsContract))]), + NewArgsBif = t_inf_lists(BifArgs, ArgTypes, Opaques), + ?debug("NewArgsBif: ~s\n", [erl_types:t_to_string(t_product(NewArgsBif))]), + NewArgTypes0 = t_inf_lists(NewArgsSig, NewArgsContract), + NewArgTypes = t_inf_lists(NewArgTypes0, NewArgsBif, Opaques), + ?debug("NewArgTypes ~s\n", [erl_types:t_to_string(t_product(NewArgTypes))]), + ?debug("\n", []), + + BifRet = BifRange(NewArgTypes), + ContrRet = CRange(NewArgTypes), + RetWithoutContr = t_inf(SigRange, BifRet), + RetWithoutLocal = t_inf(ContrRet, RetWithoutContr), + + ?debug("RetWithoutContr: ~s\n",[erl_types:t_to_string(RetWithoutContr)]), + ?debug("RetWithoutLocal: ~s\n", [erl_types:t_to_string(RetWithoutLocal)]), + ?debug("BifRet: ~s\n", [erl_types:t_to_string(BifRange(NewArgTypes))]), + ?debug("SigRange: ~s\n", [erl_types:t_to_string(SigRange)]), + ?debug("ContrRet: ~s\n", [erl_types:t_to_string(ContrRet)]), + ?debug("LocalRet: ~s\n", [erl_types:t_to_string(LocalRet)]), + + State1 = + case is_race_analysis_enabled(State) of + true -> + Ann = cerl:get_ann(Tree), + File = get_file(Ann), + Line = abs(get_line(Ann)), + dialyzer_races:store_race_call(Fun, ArgTypes, Args, + {File, Line}, State); + false -> State + end, + FailedConj = any_none([RetWithoutLocal|NewArgTypes]), + IsFailBif = t_is_none(BifRange(BifArgs)), + IsFailSig = t_is_none(SigRange), + ?debug("FailedConj: ~p~n", [FailedConj]), + ?debug("IsFailBif: ~p~n", [IsFailBif]), + ?debug("IsFailSig: ~p~n", [IsFailSig]), + State2 = + case FailedConj andalso not (IsFailBif orelse IsFailSig) of + true -> + case t_is_none(RetWithoutLocal) andalso + not t_is_none(RetWithoutContr) andalso + not any_none(NewArgTypes) of + true -> + {value, C1} = Contr, + Contract = dialyzer_contracts:contract_to_string(C1), + {M1, F1, A1} = state__lookup_name(Fun, State), + ArgStrings = format_args(Args, ArgTypes, State), + CRet = erl_types:t_to_string(RetWithoutContr), + %% This Msg will be post_processed by dialyzer_succ_typings + Msg = + {contract_range, [Contract, M1, F1, A1, ArgStrings, CRet]}, + state__add_warning(State1, ?WARN_CONTRACT_RANGE, Tree, Msg); + false -> + FailedSig = any_none(NewArgsSig), + FailedContract = + any_none([CRange(NewArgsContract)|NewArgsContract]), + FailedBif = any_none([BifRange(NewArgsBif)|NewArgsBif]), + InfSig = t_inf(t_fun(SigArgs, SigRange), + t_fun(BifArgs, BifRange(BifArgs))), + FailReason = + apply_fail_reason(FailedSig, FailedBif, FailedContract), + Msg = get_apply_fail_msg(Fun, Args, ArgTypes, NewArgTypes, InfSig, + Contr, CArgs, State1, FailReason, Opaques), + WarnType = case Msg of + {call, _} -> ?WARN_FAILING_CALL; + {apply, _} -> ?WARN_FAILING_CALL; + {call_with_opaque, _} -> ?WARN_OPAQUE; + {call_without_opaque, _} -> ?WARN_OPAQUE; + {opaque_type_test, _} -> ?WARN_OPAQUE + end, + Frc = {erlang, is_record, 3} =:= state__lookup_name(Fun, State), + state__add_warning(State1, WarnType, Tree, Msg, Frc) + end; + false -> State1 + end, + State3 = + case TypeOfApply of + local -> + case state__is_escaping(Fun, State2) of + true -> State2; + false -> + ForwardArgs = [t_limit(X, ?TYPE_LIMIT) || X <- ArgTypes], + forward_args(Fun, ForwardArgs, State2) + end; + remote -> + add_bif_warnings(Fun, NewArgTypes, Tree, State2) + end, + NewAccArgTypes = + case FailedConj of + true -> AccArgTypes; + false -> [t_sup(X, Y) || {X, Y} <- lists:zip(NewArgTypes, AccArgTypes)] + end, + TotalRet = + case t_is_none(LocalRet) andalso t_is_unit(RetWithoutLocal) of + true -> RetWithoutLocal; + false -> t_inf(RetWithoutLocal, LocalRet) + end, + NewAccRet = t_sup(AccRet, TotalRet), + ?debug("NewAccRet: ~s\n", [t_to_string(NewAccRet)]), + {NewWarnings, State4} = state__remove_added_warnings(State, State3), + {HowMany, OldWarnings} = Warns, + NewWarns = + case HowMany of + none -> {one, NewWarnings}; + _ -> + case OldWarnings =:= [] of + true -> {many, []}; + false -> + case NewWarnings =:= [] of + true -> {many, []}; + false -> {many, NewWarnings ++ OldWarnings} + end + end + end, + handle_apply_or_call(Left, Args, ArgTypes, Map, Tree, + State4, NewAccArgTypes, NewAccRet, HadExternal, NewWarns); +handle_apply_or_call([], Args, _ArgTypes, Map, _Tree, State, + AccArgTypes, AccRet, HadExternal, {_, Warnings}) -> + State1 = state__add_warnings(Warnings, State), + case HadExternal of + false -> + NewMap = enter_type_lists(Args, AccArgTypes, Map), + {State1, NewMap, AccRet}; + true -> + {had_external, State1} + end. + +apply_fail_reason(FailedSig, FailedBif, FailedContract) -> + if + (FailedSig orelse FailedBif) andalso (not FailedContract) -> only_sig; + FailedContract andalso (not (FailedSig orelse FailedBif)) -> only_contract; + true -> both + end. + +get_apply_fail_msg(Fun, Args, ArgTypes, NewArgTypes, + Sig, Contract, ContrArgs, State, FailReason, Opaques) -> + ArgStrings = format_args(Args, ArgTypes, State), + ContractInfo = + case Contract of + {value, #contract{} = C} -> + {dialyzer_contracts:is_overloaded(C), + dialyzer_contracts:contract_to_string(C)}; + none -> {false, none} + end, + EnumArgTypes = lists:zip(lists:seq(1, length(NewArgTypes)), NewArgTypes), + ArgNs = [Arg || {Arg, Type} <- EnumArgTypes, t_is_none(Type)], + case state__lookup_name(Fun, State) of + {M, F, A} -> + case is_opaque_type_test_problem(Fun, Args, NewArgTypes, State) of + {yes, Arg, ArgType} -> + {opaque_type_test, [atom_to_list(F), ArgStrings, + format_arg(Arg), format_type(ArgType, State)]}; + no -> + SigArgs = t_fun_args(Sig), + BadOpaque = + opaque_problems([SigArgs, ContrArgs], ArgTypes, Opaques, ArgNs), + %% In fact *both* 'call_with_opaque' and + %% 'call_without_opaque' are possible. + case lists:keyfind(decl, 1, BadOpaque) of + {decl, BadArgs} -> + %% a structured term is used where an opaque is expected + ExpectedTriples = + case FailReason of + only_sig -> expected_arg_triples(BadArgs, SigArgs, State); + _ -> expected_arg_triples(BadArgs, ContrArgs, State) + end, + {call_without_opaque, [M, F, ArgStrings, ExpectedTriples]}; + false -> + case lists:keyfind(use, 1, BadOpaque) of + {use, BadArgs} -> + %% an opaque term is used where a structured term is expected + ExpectedArgs = + case FailReason of + only_sig -> SigArgs; + _ -> ContrArgs + end, + {call_with_opaque, [M, F, ArgStrings, BadArgs, ExpectedArgs]}; + false -> + case + erl_bif_types:opaque_args(M, F, A, ArgTypes, Opaques) + of + [] -> %% there is a structured term clash in some argument + {call, [M, F, ArgStrings, + ArgNs, FailReason, + format_sig_args(Sig, State), + format_type(t_fun_range(Sig), State), + ContractInfo]}; + Ns -> + {call_with_opaque, [M, F, ArgStrings, Ns, ContrArgs]} + end + end + end + end; + Label when is_integer(Label) -> + {apply, [ArgStrings, + ArgNs, FailReason, + format_sig_args(Sig, State), + format_type(t_fun_range(Sig), State), + ContractInfo]} + end. + +%% -> [{ElementI, [ArgN]}] where [ArgN] is a non-empty list of +%% arguments containing unknown opaque types and Element is 1 or 2. +opaque_problems(ContractOrSigList, ArgTypes, Opaques, ArgNs) -> + ArgElementList = find_unknown(ContractOrSigList, ArgTypes, Opaques, ArgNs), + F = fun(1) -> decl; (2) -> use end, + [{F(ElementI), lists:usort([ArgN || {ArgN, EI} <- ArgElementList, + EI =:= ElementI])} || + ElementI <- lists:usort([EI || {_, EI} <- ArgElementList])]. + +%% -> [{ArgN, ElementI}] where ElementI = 1 means there is an unknown +%% opaque type in argument ArgN of the the contract/signature, +%% and ElementI = 2 means that there is an unknown opaque type in +%% argument ArgN of the the (current) argument types. +find_unknown(ContractOrSigList, ArgTypes, Opaques, NoneArgNs) -> + ArgNs = lists:seq(1, length(ArgTypes)), + [{ArgN, ElementI} || + ContractOrSig <- ContractOrSigList, + {E1, E2, ArgN} <- lists:zip3(ContractOrSig, ArgTypes, ArgNs), + lists:member(ArgN, NoneArgNs), + ElementI <- erl_types:t_find_unknown_opaque(E1, E2, Opaques)]. + +is_opaque_type_test_problem(Fun, Args, ArgTypes, State) -> + case Fun of + {erlang, FN, 1} when FN =:= is_atom; FN =:= is_boolean; + FN =:= is_binary; FN =:= is_bitstring; + FN =:= is_float; FN =:= is_function; + FN =:= is_integer; FN =:= is_list; + FN =:= is_number; FN =:= is_pid; FN =:= is_port; + FN =:= is_reference; FN =:= is_tuple; + FN =:= is_map -> + type_test_opaque_arg(Args, ArgTypes, State#state.opaques); + {erlang, FN, 2} when FN =:= is_function -> + type_test_opaque_arg(Args, ArgTypes, State#state.opaques); + _ -> no + end. + +type_test_opaque_arg([], [], _Opaques) -> + no; +type_test_opaque_arg([Arg|Args], [ArgType|ArgTypes], Opaques) -> + case erl_types:t_has_opaque_subtype(ArgType, Opaques) of + true -> {yes, Arg, ArgType}; + false -> type_test_opaque_arg(Args, ArgTypes, Opaques) + end. + +expected_arg_triples(ArgNs, ArgTypes, State) -> + [begin + Arg = lists:nth(N, ArgTypes), + {N, Arg, format_type(Arg, State)} + end || N <- ArgNs]. + +add_bif_warnings({erlang, Op, 2}, [T1, T2] = Ts, Tree, State) + when Op =:= '=:='; Op =:= '==' -> + Opaques = State#state.opaques, + Inf = t_inf(T1, T2, Opaques), + case + t_is_none(Inf) andalso (not any_none(Ts)) + andalso (not is_int_float_eq_comp(T1, Op, T2, Opaques)) + of + true -> + %% Give priority to opaque warning (as usual). + case erl_types:t_find_unknown_opaque(T1, T2, Opaques) of + [] -> + Args = comp_format_args([], T1, Op, T2, State), + state__add_warning(State, ?WARN_MATCHING, Tree, {exact_eq, Args}); + Ns -> + Args = comp_format_args(Ns, T1, Op, T2, State), + state__add_warning(State, ?WARN_OPAQUE, Tree, {opaque_eq, Args}) + end; + false -> + State + end; +add_bif_warnings({erlang, Op, 2}, [T1, T2] = Ts, Tree, State) + when Op =:= '=/='; Op =:= '/=' -> + Opaques = State#state.opaques, + case + (not any_none(Ts)) + andalso (not is_int_float_eq_comp(T1, Op, T2, Opaques)) + of + true -> + case erl_types:t_find_unknown_opaque(T1, T2, Opaques) of + [] -> State; + Ns -> + Args = comp_format_args(Ns, T1, Op, T2, State), + state__add_warning(State, ?WARN_OPAQUE, Tree, {opaque_neq, Args}) + end; + false -> + State + end; +add_bif_warnings(_, _, _, State) -> + State. + +is_int_float_eq_comp(T1, Op, T2, Opaques) -> + (Op =:= '==' orelse Op =:= '/=') andalso + ((erl_types:t_is_float(T1, Opaques) + andalso t_is_integer(T2, Opaques)) orelse + (t_is_integer(T1, Opaques) + andalso erl_types:t_is_float(T2, Opaques))). + +comp_format_args([1|_], T1, Op, T2, State) -> + [format_type(T2, State), Op, format_type(T1, State)]; +comp_format_args(_, T1, Op, T2, State) -> + [format_type(T1, State), Op, format_type(T2, State)]. + +%%---------------------------------------- + +handle_bitstr(Tree, Map, State) -> + %% Construction of binaries. + Size = cerl:bitstr_size(Tree), + Val = cerl:bitstr_val(Tree), + BitstrType = cerl:concrete(cerl:bitstr_type(Tree)), + {State1, Map1, SizeType0} = traverse(Size, Map, State), + {State2, Map2, ValType0} = traverse(Val, Map1, State1), + case cerl:bitstr_bitsize(Tree) of + BitSz when BitSz =:= all orelse BitSz =:= utf -> + ValType = + case BitSz of + all -> + true = (BitstrType =:= binary), + t_inf(ValType0, t_bitstr()); + utf -> + true = lists:member(BitstrType, [utf8, utf16, utf32]), + t_inf(ValType0, t_integer()) + end, + Map3 = enter_type(Val, ValType, Map2), + case t_is_none(ValType) of + true -> + Msg = {bin_construction, ["value", + format_cerl(Val), format_cerl(Tree), + format_type(ValType0, State2)]}, + State3 = state__add_warning(State2, ?WARN_BIN_CONSTRUCTION, Val, Msg), + {State3, Map3, t_none()}; + false -> + {State2, Map3, t_bitstr()} + end; + BitSz when is_integer(BitSz) orelse BitSz =:= any -> + SizeType = t_inf(SizeType0, t_non_neg_integer()), + ValType = + case BitstrType of + binary -> t_inf(ValType0, t_bitstr()); + float -> t_inf(ValType0, t_number()); + integer -> t_inf(ValType0, t_integer()) + end, + case any_none([SizeType, ValType]) of + true -> + {Msg, Offending} = + case t_is_none(SizeType) of + true -> + {{bin_construction, + ["size", format_cerl(Size), format_cerl(Tree), + format_type(SizeType0, State2)]}, + Size}; + false -> + {{bin_construction, + ["value", format_cerl(Val), format_cerl(Tree), + format_type(ValType0, State2)]}, + Val} + end, + State3 = state__add_warning(State2, ?WARN_BIN_CONSTRUCTION, + Offending, Msg), + {State3, Map2, t_none()}; + false -> + UnitVal = cerl:concrete(cerl:bitstr_unit(Tree)), + Opaques = State2#state.opaques, + NumberVals = t_number_vals(SizeType, Opaques), + {State3, Type} = + case t_contains_opaque(SizeType, Opaques) of + true -> + Msg = {opaque_size, [format_type(SizeType, State2), + format_cerl(Size)]}, + {state__add_warning(State2, ?WARN_OPAQUE, Size, Msg), + t_none()}; + false -> + case NumberVals of + [OneSize] -> {State2, t_bitstr(0, OneSize * UnitVal)}; + unknown -> {State2, t_bitstr()}; + _ -> + MinSize = erl_types:number_min(SizeType, Opaques), + {State2, t_bitstr(UnitVal, UnitVal * MinSize)} + end + end, + Map3 = enter_type_lists([Val, Size, Tree], + [ValType, SizeType, Type], Map2), + {State3, Map3, Type} + end + end. + +%%---------------------------------------- + +handle_call(Tree, Map, State) -> + M = cerl:call_module(Tree), + F = cerl:call_name(Tree), + Args = cerl:call_args(Tree), + MFAList = [M, F|Args], + {State1, Map1, [MType0, FType0|As]} = traverse_list(MFAList, Map, State), + Opaques = State#state.opaques, + MType = t_inf(t_module(), MType0, Opaques), + FType = t_inf(t_atom(), FType0, Opaques), + Map2 = enter_type_lists([M, F], [MType, FType], Map1), + MOpaque = t_is_none(MType) andalso (not t_is_none(MType0)), + FOpaque = t_is_none(FType) andalso (not t_is_none(FType0)), + case any_none([MType, FType|As]) of + true -> + State2 = + if + MOpaque -> % This is a problem we just detected; not a known one + MS = format_cerl(M), + case t_is_none(t_inf(t_module(), MType0)) of + true -> + Msg = {app_call, [MS, format_cerl(F), + format_args(Args, As, State1), + MS, format_type(t_module(), State1), + format_type(MType0, State1)]}, + state__add_warning(State1, ?WARN_FAILING_CALL, Tree, Msg); + false -> + Msg = {opaque_call, [MS, format_cerl(F), + format_args(Args, As, State1), + MS, format_type(MType0, State1)]}, + state__add_warning(State1, ?WARN_FAILING_CALL, Tree, Msg) + end; + FOpaque -> + FS = format_cerl(F), + case t_is_none(t_inf(t_atom(), FType0)) of + true -> + Msg = {app_call, [format_cerl(M), FS, + format_args(Args, As, State1), + FS, format_type(t_atom(), State1), + format_type(FType0, State1)]}, + state__add_warning(State1, ?WARN_FAILING_CALL, Tree, Msg); + false -> + Msg = {opaque_call, [format_cerl(M), FS, + format_args(Args, As, State1), + FS, format_type(FType0, State1)]}, + state__add_warning(State1, ?WARN_FAILING_CALL, Tree, Msg) + end; + true -> State1 + end, + {State2, Map2, t_none()}; + false -> + case t_is_atom(MType) of + true -> + %% XXX: Consider doing this for all combinations of MF + case {t_atom_vals(MType), t_atom_vals(FType)} of + {[MAtom], [FAtom]} -> + FunInfo = [{remote, state__fun_info({MAtom, FAtom, length(Args)}, + State1)}], + handle_apply_or_call(FunInfo, Args, As, Map2, Tree, State1); + {_MAtoms, _FAtoms} -> + {State1, Map2, t_any()} + end; + false -> + {State1, Map2, t_any()} + end + end. + +%%---------------------------------------- + +handle_case(Tree, Map, State) -> + Arg = cerl:case_arg(Tree), + Clauses = filter_match_fail(cerl:case_clauses(Tree)), + {State1, Map1, ArgType} = SMA = traverse(Arg, Map, State), + case t_is_none_or_unit(ArgType) of + true -> SMA; + false -> + State2 = + case is_race_analysis_enabled(State) of + true -> + {RaceList, RaceListSize} = get_race_list_and_size(State1), + state__renew_race_list([beg_case|RaceList], + RaceListSize + 1, State1); + false -> State1 + end, + Map2 = join_maps_begin(Map1), + {MapList, State3, Type} = + handle_clauses(Clauses, Arg, ArgType, ArgType, State2, + [], Map2, [], []), + Map3 = join_maps_end(MapList, Map2), + debug_pp_map(Map3), + {State3, Map3, Type} + end. + +%%---------------------------------------- + +handle_cons(Tree, Map, State) -> + Hd = cerl:cons_hd(Tree), + Tl = cerl:cons_tl(Tree), + {State1, Map1, HdType} = traverse(Hd, Map, State), + {State2, Map2, TlType} = traverse(Tl, Map1, State1), + State3 = + case t_is_none(t_inf(TlType, t_list(), State2#state.opaques)) of + true -> + Msg = {improper_list_constr, [format_type(TlType, State2)]}, + state__add_warning(State2, ?WARN_NON_PROPER_LIST, Tree, Msg); + false -> + State2 + end, + Type = t_cons(HdType, TlType), + {State3, Map2, Type}. + +%%---------------------------------------- + +handle_let(Tree, Map, State) -> + IsRaceAnalysisEnabled = is_race_analysis_enabled(State), + Arg = cerl:let_arg(Tree), + Vars = cerl:let_vars(Tree), + {Map0, State0} = + case cerl:is_c_var(Arg) of + true -> + [Var] = Vars, + {enter_subst(Var, Arg, Map), + case IsRaceAnalysisEnabled of + true -> + {RaceList, RaceListSize} = get_race_list_and_size(State), + state__renew_race_list( + [dialyzer_races:let_tag_new(Var, Arg)|RaceList], + RaceListSize + 1, State); + false -> State + end}; + false -> {Map, State} + end, + Body = cerl:let_body(Tree), + {State1, Map1, ArgTypes} = SMA = traverse(Arg, Map0, State0), + State2 = + case IsRaceAnalysisEnabled andalso cerl:is_c_call(Arg) of + true -> + Mod = cerl:call_module(Arg), + Name = cerl:call_name(Arg), + case cerl:is_literal(Mod) andalso + cerl:concrete(Mod) =:= ets andalso + cerl:is_literal(Name) andalso + cerl:concrete(Name) =:= new of + true -> renew_race_public_tables(Vars, State1); + false -> State1 + end; + false -> State1 + end, + case t_is_none_or_unit(ArgTypes) of + true -> SMA; + false -> + Map2 = enter_type_lists(Vars, t_to_tlist(ArgTypes), Map1), + traverse(Body, Map2, State2) + end. + +%%---------------------------------------- + +handle_module(Tree, Map, State) -> + %% By not including the variables in scope we can assure that we + %% will get the current function type when using the variables. + Defs = cerl:module_defs(Tree), + PartFun = fun({_Var, Fun}) -> + state__is_escaping(get_label(Fun), State) + end, + {Defs1, Defs2} = lists:partition(PartFun, Defs), + Letrec = cerl:c_letrec(Defs1, cerl:c_int(42)), + {State1, Map1, _FunTypes} = traverse(Letrec, Map, State), + %% Also add environments for the other top-level functions. + VarTypes = [{Var, state__fun_type(Fun, State1)} || {Var, Fun} <- Defs], + EnvMap = enter_type_list(VarTypes, Map), + FoldFun = fun({_Var, Fun}, AccState) -> + state__update_fun_env(Fun, EnvMap, AccState) + end, + State2 = lists:foldl(FoldFun, State1, Defs2), + {State2, Map1, t_any()}. + +%%---------------------------------------- + +handle_receive(Tree, Map, State) -> + Clauses = filter_match_fail(cerl:receive_clauses(Tree)), + Timeout = cerl:receive_timeout(Tree), + State1 = + case is_race_analysis_enabled(State) of + true -> + {RaceList, RaceListSize} = get_race_list_and_size(State), + state__renew_race_list([beg_case|RaceList], + RaceListSize + 1, State); + false -> State + end, + {MapList, State2, ReceiveType} = + handle_clauses(Clauses, ?no_arg, t_any(), t_any(), State1, [], Map, + [], []), + Map1 = join_maps(MapList, Map), + {State3, Map2, TimeoutType} = traverse(Timeout, Map1, State2), + Opaques = State3#state.opaques, + case (t_is_atom(TimeoutType, Opaques) andalso + (t_atom_vals(TimeoutType, Opaques) =:= ['infinity'])) of + true -> + {State3, Map2, ReceiveType}; + false -> + Action = cerl:receive_action(Tree), + {State4, Map3, ActionType} = traverse(Action, Map, State3), + Map4 = join_maps([Map3, Map1], Map), + Type = t_sup(ReceiveType, ActionType), + {State4, Map4, Type} + end. + +%%---------------------------------------- + +handle_try(Tree, Map, State) -> + Arg = cerl:try_arg(Tree), + EVars = cerl:try_evars(Tree), + Vars = cerl:try_vars(Tree), + Body = cerl:try_body(Tree), + Handler = cerl:try_handler(Tree), + {State1, Map1, ArgType} = traverse(Arg, Map, State), + Map2 = mark_as_fresh(Vars, Map1), + {SuccState, SuccMap, SuccType} = + case bind_pat_vars(Vars, t_to_tlist(ArgType), [], Map2, State1) of + {error, _, _, _, _} -> + {State1, map__new(), t_none()}; + {SuccMap1, VarTypes} -> + %% Try to bind the argument. Will only succeed if + %% it is a simple structured term. + SuccMap2 = + case bind_pat_vars_reverse([Arg], [t_product(VarTypes)], [], + SuccMap1, State1) of + {error, _, _, _, _} -> SuccMap1; + {SM, _} -> SM + end, + traverse(Body, SuccMap2, State1) + end, + ExcMap1 = mark_as_fresh(EVars, Map), + {State2, ExcMap2, HandlerType} = traverse(Handler, ExcMap1, SuccState), + TryType = t_sup(SuccType, HandlerType), + {State2, join_maps([ExcMap2, SuccMap], Map1), TryType}. + +%%---------------------------------------- + +handle_map(Tree,Map,State) -> + Pairs = cerl:map_es(Tree), + Arg = cerl:map_arg(Tree), + {State1, Map1, ArgType} = traverse(Arg, Map, State), + ArgType1 = t_inf(t_map(), ArgType), + case t_is_none_or_unit(ArgType1) of + true -> + {State1, Map1, ArgType1}; + false -> + {State2, Map2, TypePairs, ExactKeys} = + traverse_map_pairs(Pairs, Map1, State1, t_none(), [], []), + InsertPair = fun({KV,assoc,_},Acc) -> erl_types:t_map_put(KV,Acc); + ({KV,exact,KVTree},Acc) -> + case t_is_none(T=erl_types:t_map_update(KV,Acc)) of + true -> throw({none, Acc, KV, KVTree}); + false -> T + end + end, + try lists:foldl(InsertPair, ArgType1, TypePairs) + of ResT -> + BindT = t_map([{K, t_any()} || K <- ExactKeys]), + case bind_pat_vars_reverse([Arg], [BindT], [], Map2, State2) of + {error, _, _, _, _} -> {State2, Map2, ResT}; + {Map3, _} -> {State2, Map3, ResT} + end + catch {none, MapType, {K,_}, KVTree} -> + Msg2 = {map_update, [format_type(MapType, State2), + format_type(K, State2)]}, + {state__add_warning(State2, ?WARN_MAP_CONSTRUCTION, KVTree, Msg2), + Map2, t_none()} + end + end. + +traverse_map_pairs([], Map, State, _ShadowKeys, PairAcc, KeyAcc) -> + {State, Map, lists:reverse(PairAcc), KeyAcc}; +traverse_map_pairs([Pair|Pairs], Map, State, ShadowKeys, PairAcc, KeyAcc) -> + Key = cerl:map_pair_key(Pair), + Val = cerl:map_pair_val(Pair), + Op = cerl:map_pair_op(Pair), + {State1, Map1, [K,V]} = traverse_list([Key,Val],Map,State), + KeyAcc1 = + case cerl:is_literal(Op) andalso cerl:concrete(Op) =:= exact andalso + t_is_singleton(K, State#state.opaques) andalso + t_is_none(t_inf(ShadowKeys, K)) of + true -> [K|KeyAcc]; + false -> KeyAcc + end, + traverse_map_pairs(Pairs, Map1, State1, t_sup(K, ShadowKeys), + [{{K,V},cerl:concrete(Op),Pair}|PairAcc], KeyAcc1). + +%%---------------------------------------- + +handle_tuple(Tree, Map, State) -> + Elements = cerl:tuple_es(Tree), + {State1, Map1, EsType} = traverse_list(Elements, Map, State), + TupleType = t_tuple(EsType), + case t_is_none(TupleType) of + true -> + {State1, Map1, t_none()}; + false -> + %% Let's find out if this is a record + case Elements of + [Tag|Left] -> + case cerl:is_c_atom(Tag) andalso is_literal_record(Tree) of + true -> + TagVal = cerl:atom_val(Tag), + case state__lookup_record(TagVal, length(Left), State1) of + error -> {State1, Map1, TupleType}; + {ok, RecType} -> + InfTupleType = t_inf(RecType, TupleType), + case t_is_none(InfTupleType) of + true -> + RecC = format_type(TupleType, State1), + FieldDiffs = format_field_diffs(TupleType, State1), + Msg = {record_constr, [RecC, FieldDiffs]}, + State2 = state__add_warning(State1, ?WARN_MATCHING, + Tree, Msg), + {State2, Map1, t_none()}; + false -> + case bind_pat_vars(Elements, t_tuple_args(RecType), + [], Map1, State1) of + {error, bind, ErrorPat, ErrorType, _} -> + Msg = {record_constr, + [TagVal, format_patterns(ErrorPat), + format_type(ErrorType, State1)]}, + State2 = state__add_warning(State1, ?WARN_MATCHING, + Tree, Msg), + {State2, Map1, t_none()}; + {error, opaque, ErrorPat, ErrorType, OpaqueType} -> + Msg = {opaque_match, + [format_patterns(ErrorPat), + format_type(ErrorType, State1), + format_type(OpaqueType, State1)]}, + State2 = state__add_warning(State1, ?WARN_OPAQUE, + Tree, Msg), + {State2, Map1, t_none()}; + {Map2, ETypes} -> + {State1, Map2, t_tuple(ETypes)} + end + end + end; + false -> + {State1, Map1, t_tuple(EsType)} + end; + [] -> + {State1, Map1, t_tuple([])} + end + end. + +%%---------------------------------------- +%% Clauses +%% +handle_clauses([C|Left], Arg, ArgType, OrigArgType, State, CaseTypes, MapIn, + Acc, ClauseAcc) -> + IsRaceAnalysisEnabled = is_race_analysis_enabled(State), + State1 = + case IsRaceAnalysisEnabled of + true -> + {RaceList, RaceListSize} = get_race_list_and_size(State), + state__renew_race_list( + [dialyzer_races:beg_clause_new(Arg, cerl:clause_pats(C), + cerl:clause_guard(C))| + RaceList], RaceListSize + 1, + State); + false -> State + end, + {State2, ClauseMap, BodyType, NewArgType} = + do_clause(C, Arg, ArgType, OrigArgType, MapIn, State1), + {NewClauseAcc, State3} = + case IsRaceAnalysisEnabled of + true -> + {RaceList1, RaceListSize1} = get_race_list_and_size(State2), + EndClause = dialyzer_races:end_clause_new(Arg, cerl:clause_pats(C), + cerl:clause_guard(C)), + {[EndClause|ClauseAcc], + state__renew_race_list([EndClause|RaceList1], + RaceListSize1 + 1, State2)}; + false -> {ClauseAcc, State2} + end, + {NewCaseTypes, NewAcc} = + case t_is_none(BodyType) of + true -> {CaseTypes, Acc}; + false -> {[BodyType|CaseTypes], [ClauseMap|Acc]} + end, + handle_clauses(Left, Arg, NewArgType, OrigArgType, State3, + NewCaseTypes, MapIn, NewAcc, NewClauseAcc); +handle_clauses([], _Arg, _ArgType, _OrigArgType, State, CaseTypes, _MapIn, Acc, + ClauseAcc) -> + State1 = + case is_race_analysis_enabled(State) of + true -> + {RaceList, RaceListSize} = get_race_list_and_size(State), + state__renew_race_list( + [dialyzer_races:end_case_new(ClauseAcc)|RaceList], + RaceListSize + 1, State); + false -> State + end, + {lists:reverse(Acc), State1, t_sup(CaseTypes)}. + +do_clause(C, Arg, ArgType0, OrigArgType, Map, State) -> + Pats = cerl:clause_pats(C), + Guard = cerl:clause_guard(C), + Body = cerl:clause_body(C), + State1 = + case is_race_analysis_enabled(State) of + true -> + state__renew_fun_args(Pats, State); + false -> State + end, + Map0 = mark_as_fresh(Pats, Map), + Map1 = if Arg =:= ?no_arg -> Map0; + true -> bind_subst(Arg, Pats, Map0) + end, + BindRes = + case t_is_none(ArgType0) of + true -> + {error, bind, Pats, ArgType0, ArgType0}; + false -> + ArgTypes = + case t_is_any(ArgType0) of + true -> [ArgType0 || _ <- Pats]; + false -> t_to_tlist(ArgType0) + end, + bind_pat_vars(Pats, ArgTypes, [], Map1, State1) + end, + case BindRes of + {error, ErrorType, NewPats, Type, OpaqueTerm} -> + ?debug("Failed binding pattern: ~s\nto ~s\n", + [cerl_prettypr:format(C), format_type(ArgType0, State1)]), + case state__warning_mode(State1) of + false -> + {State1, Map, t_none(), ArgType0}; + true -> + {Msg, Force} = + case t_is_none(ArgType0) of + true -> + PatString = format_patterns(Pats), + PatTypes = [PatString, format_type(OrigArgType, State1)], + %% See if this is covered by an earlier clause or if it + %% simply cannot match + OrigArgTypes = + case t_is_any(OrigArgType) of + true -> Any = t_any(), [Any || _ <- Pats]; + false -> t_to_tlist(OrigArgType) + end, + Tag = + case bind_pat_vars(Pats, OrigArgTypes, [], Map1, State1) of + {error, bind, _, _, _} -> pattern_match; + {error, record, _, _, _} -> record_match; + {error, opaque, _, _, _} -> opaque_match; + {_, _} -> pattern_match_cov + end, + {{Tag, PatTypes}, false}; + false -> + %% Try to find out if this is a default clause in a list + %% comprehension and supress this. A real Hack(tm) + Force0 = + case is_compiler_generated(cerl:get_ann(C)) of + true -> + case Pats of + [Pat] -> + case cerl:is_c_cons(Pat) of + true -> + not (cerl:is_c_var(cerl:cons_hd(Pat)) andalso + cerl:is_c_var(cerl:cons_tl(Pat)) andalso + cerl:is_literal(Guard) andalso + (cerl:concrete(Guard) =:= true)); + false -> + true + end; + [Pat0, Pat1] -> % binary comprehension + case cerl:is_c_cons(Pat0) of + true -> + not (cerl:is_c_var(cerl:cons_hd(Pat0)) andalso + cerl:is_c_var(cerl:cons_tl(Pat0)) andalso + cerl:is_c_var(Pat1) andalso + cerl:is_literal(Guard) andalso + (cerl:concrete(Guard) =:= true)); + false -> + true + end; + _ -> true + end; + false -> + true + end, + PatString = + case ErrorType of + bind -> format_patterns(Pats); + record -> format_patterns(NewPats); + opaque -> format_patterns(NewPats) + end, + PatTypes = case ErrorType of + bind -> [PatString, format_type(ArgType0, State1)]; + record -> [PatString, format_type(Type, State1)]; + opaque -> [PatString, format_type(Type, State1), + format_type(OpaqueTerm, State1)] + end, + FailedTag = case ErrorType of + bind -> pattern_match; + record -> record_match; + opaque -> opaque_match + end, + {{FailedTag, PatTypes}, Force0} + end, + WarnType = case Msg of + {opaque_match, _} -> ?WARN_OPAQUE; + {pattern_match, _} -> ?WARN_MATCHING; + {record_match, _} -> ?WARN_MATCHING; + {pattern_match_cov, _} -> ?WARN_MATCHING + end, + {state__add_warning(State1, WarnType, C, Msg, Force), + Map, t_none(), ArgType0} + end; + {Map2, PatTypes} -> + Map3 = + case Arg =:= ?no_arg of + true -> Map2; + false -> + %% Try to bind the argument. Will only succeed if + %% it is a simple structured term. + case bind_pat_vars_reverse([Arg], [t_product(PatTypes)], + [], Map2, State1) of + {error, _, _, _, _} -> Map2; + {NewMap, _} -> NewMap + end + end, + NewArgType = + case Arg =:= ?no_arg of + true -> ArgType0; + false -> + GenType = dialyzer_typesig:get_safe_underapprox(Pats, Guard), + t_subtract(t_product(t_to_tlist(ArgType0)), GenType) + end, + case bind_guard(Guard, Map3, State1) of + {error, Reason} -> + ?debug("Failed guard: ~s\n", + [cerl_prettypr:format(C, [{hook, cerl_typean:pp_hook()}])]), + PatString = format_patterns(Pats), + DefaultMsg = + case Pats =:= [] of + true -> {guard_fail, []}; + false -> + {guard_fail_pat, [PatString, format_type(ArgType0, State1)]} + end, + State2 = + case Reason of + none -> state__add_warning(State1, ?WARN_MATCHING, C, DefaultMsg); + {FailGuard, Msg} -> + case is_compiler_generated(cerl:get_ann(FailGuard)) of + false -> + WarnType = case Msg of + {guard_fail, _} -> ?WARN_MATCHING; + {neg_guard_fail, _} -> ?WARN_MATCHING; + {opaque_guard, _} -> ?WARN_OPAQUE + end, + state__add_warning(State1, WarnType, FailGuard, Msg); + true -> + state__add_warning(State1, ?WARN_MATCHING, C, Msg) + end + end, + {State2, Map, t_none(), NewArgType}; + Map4 -> + {RetState, RetMap, BodyType} = traverse(Body, Map4, State1), + {RetState, RetMap, BodyType, NewArgType} + end + end. + +bind_subst(Arg, Pats, Map) -> + case cerl:type(Arg) of + values -> + bind_subst_list(cerl:values_es(Arg), Pats, Map); + var -> + [Pat] = Pats, + enter_subst(Arg, Pat, Map); + _ -> + Map + end. + +bind_subst_list([Arg|ArgLeft], [Pat|PatLeft], Map) -> + NewMap = + case {cerl:type(Arg), cerl:type(Pat)} of + {var, var} -> enter_subst(Arg, Pat, Map); + {var, alias} -> enter_subst(Arg, cerl:alias_pat(Pat), Map); + {literal, literal} -> Map; + {T, T} -> bind_subst_list(lists:flatten(cerl:subtrees(Arg)), + lists:flatten(cerl:subtrees(Pat)), + Map); + _ -> Map + end, + bind_subst_list(ArgLeft, PatLeft, NewMap); +bind_subst_list([], [], Map) -> + Map. + +%%---------------------------------------- +%% Patterns +%% + +bind_pat_vars(Pats, Types, Acc, Map, State) -> + try + bind_pat_vars(Pats, Types, Acc, Map, State, false) + catch + throw:Error -> + %% Error = {error, bind | opaque | record, ErrorPats, ErrorType} + Error + end. + +bind_pat_vars_reverse(Pats, Types, Acc, Map, State) -> + try + bind_pat_vars(Pats, Types, Acc, Map, State, true) + catch + throw:Error -> + %% Error = {error, bind | opaque | record, ErrorPats, ErrorType} + Error + end. + +bind_pat_vars([Pat|PatLeft], [Type|TypeLeft], Acc, Map, State, Rev) -> + ?debug("Binding pat: ~w to ~s\n", [cerl:type(Pat), format_type(Type, State)] +), + Opaques = State#state.opaques, + {NewMap, TypeOut} = + case cerl:type(Pat) of + alias -> + %% Map patterns are more allowing than the type of their literal. We + %% must unfold AliasPat if it is a literal. + AliasPat = dialyzer_utils:refold_pattern(cerl:alias_pat(Pat)), + Var = cerl:alias_var(Pat), + Map1 = enter_subst(Var, AliasPat, Map), + {Map2, [PatType]} = bind_pat_vars([AliasPat], [Type], [], + Map1, State, Rev), + {enter_type(Var, PatType, Map2), PatType}; + binary -> + %% Cannot bind the binary if we are in reverse match since + %% binary patterns and binary construction are not symmetric. + case Rev of + true -> {Map, t_bitstr()}; + false -> + BinType = t_inf(t_bitstr(), Type, Opaques), + case t_is_none(BinType) of + true -> + case t_find_opaque_mismatch(t_bitstr(), Type, Opaques) of + {ok, T1, T2} -> + bind_error([Pat], T1, T2, opaque); + error -> + bind_error([Pat], Type, t_none(), bind) + end; + false -> + Segs = cerl:binary_segments(Pat), + {Map1, SegTypes} = bind_bin_segs(Segs, BinType, Map, State), + {Map1, t_bitstr_concat(SegTypes)} + end + end; + cons -> + Cons = t_inf(Type, t_cons(), Opaques), + case t_is_none(Cons) of + true -> + bind_opaque_pats(t_cons(), Type, Pat, State); + false -> + {Map1, [HdType, TlType]} = + bind_pat_vars([cerl:cons_hd(Pat), cerl:cons_tl(Pat)], + [t_cons_hd(Cons, Opaques), + t_cons_tl(Cons, Opaques)], + [], Map, State, Rev), + {Map1, t_cons(HdType, TlType)} + end; + literal -> + Pat0 = dialyzer_utils:refold_pattern(Pat), + case cerl:is_literal(Pat0) of + true -> + Literal = literal_type(Pat), + case t_is_none(t_inf(Literal, Type, Opaques)) of + true -> + bind_opaque_pats(Literal, Type, Pat, State); + false -> {Map, Literal} + end; + false -> + %% Retry with the unfolded pattern + {Map1, [PatType]} + = bind_pat_vars([Pat0], [Type], [], Map, State, Rev), + {Map1, PatType} + end; + map -> + MapT = t_inf(Type, t_map(), Opaques), + case t_is_none(MapT) of + true -> + bind_opaque_pats(t_map(), Type, Pat, State); + false -> + case Rev of + %% TODO: Reverse matching (propagating a matched subset back to a value) + true -> {Map, MapT}; + false -> + FoldFun = + fun(Pair, {MapAcc, ListAcc}) -> + %% Only exact (:=) can appear in patterns + exact = cerl:concrete(cerl:map_pair_op(Pair)), + Key = cerl:map_pair_key(Pair), + KeyType = + case cerl:type(Key) of + var -> + case state__lookup_type_for_letrec(Key, State) of + error -> lookup_type(Key, MapAcc); + {ok, RecType} -> RecType + end; + literal -> + literal_type(Key) + end, + Bind = erl_types:t_map_get(KeyType, MapT), + {MapAcc1, [ValType]} = + bind_pat_vars([cerl:map_pair_val(Pair)], + [Bind], [], MapAcc, State, Rev), + case t_is_singleton(KeyType, Opaques) of + true -> {MapAcc1, [{KeyType, ValType}|ListAcc]}; + false -> {MapAcc1, ListAcc} + end + end, + {Map1, Pairs} = lists:foldl(FoldFun, {Map, []}, cerl:map_es(Pat)), + {Map1, t_inf(MapT, t_map(Pairs))} + end + end; + tuple -> + Es = cerl:tuple_es(Pat), + {TypedRecord, Prototype} = + case Es of + [] -> {false, t_tuple([])}; + [Tag|Left] -> + case cerl:is_c_atom(Tag) andalso is_literal_record(Pat) of + true -> + TagAtom = cerl:atom_val(Tag), + case state__lookup_record(TagAtom, length(Left), State) of + error -> {false, t_tuple(length(Es))}; + {ok, Record} -> + [_Head|AnyTail] = [t_any() || _ <- Es], + UntypedRecord = t_tuple([t_atom(TagAtom)|AnyTail]), + {not t_is_equal(Record, UntypedRecord), Record} + end; + false -> {false, t_tuple(length(Es))} + end + end, + Tuple = t_inf(Prototype, Type, Opaques), + case t_is_none(Tuple) of + true -> + bind_opaque_pats(Prototype, Type, Pat, State); + false -> + SubTuples = t_tuple_subtypes(Tuple, Opaques), + %% Need to call the top function to get the try-catch wrapper + MapJ = join_maps_begin(Map), + Results = + case Rev of + true -> + [bind_pat_vars_reverse(Es, t_tuple_args(SubTuple, Opaques), + [], MapJ, State) + || SubTuple <- SubTuples]; + false -> + [bind_pat_vars(Es, t_tuple_args(SubTuple, Opaques), [], + MapJ, State) + || SubTuple <- SubTuples] + end, + case lists:keyfind(opaque, 2, Results) of + {error, opaque, _PatList, _Type, Opaque} -> + bind_error([Pat], Tuple, Opaque, opaque); + false -> + case [M || {M, _} <- Results, M =/= error] of + [] -> + case TypedRecord of + true -> bind_error([Pat], Tuple, Prototype, record); + false -> bind_error([Pat], Tuple, t_none(), bind) + end; + Maps -> + Map1 = join_maps_end(Maps, MapJ), + TupleType = t_sup([t_tuple(EsTypes) + || {M, EsTypes} <- Results, M =/= error]), + {Map1, TupleType} + end + end + end; + values -> + Es = cerl:values_es(Pat), + {Map1, EsTypes} = + bind_pat_vars(Es, t_to_tlist(Type), [], Map, State, Rev), + {Map1, t_product(EsTypes)}; + var -> + VarType1 = + case state__lookup_type_for_letrec(Pat, State) of + error -> lookup_type(Pat, Map); + {ok, RecType} -> RecType + end, + %% Must do inf when binding args to pats. Vars in pats are fresh. + VarType2 = t_inf(VarType1, Type, Opaques), + case t_is_none(VarType2) of + true -> + case t_find_opaque_mismatch(VarType1, Type, Opaques) of + {ok, T1, T2} -> + bind_error([Pat], T1, T2, opaque); + error -> + bind_error([Pat], Type, t_none(), bind) + end; + false -> + Map1 = enter_type(Pat, VarType2, Map), + {Map1, VarType2} + end; + _Other -> + %% Catch all is needed when binding args to pats + ?debug("Failed match for ~p\n", [_Other]), + bind_error([Pat], Type, t_none(), bind) + end, + bind_pat_vars(PatLeft, TypeLeft, [TypeOut|Acc], NewMap, State, Rev); +bind_pat_vars([], [], Acc, Map, _State, _Rev) -> + {Map, lists:reverse(Acc)}. + +bind_bin_segs(BinSegs, BinType, Map, State) -> + bind_bin_segs(BinSegs, BinType, [], Map, State). + +bind_bin_segs([Seg|Segs], BinType, Acc, Map, State) -> + Val = cerl:bitstr_val(Seg), + SegType = cerl:concrete(cerl:bitstr_type(Seg)), + UnitVal = cerl:concrete(cerl:bitstr_unit(Seg)), + case cerl:bitstr_bitsize(Seg) of + all -> + binary = SegType, [] = Segs, %% just an assert + T = t_inf(t_bitstr(UnitVal, 0), BinType), + {Map1, [Type]} = bind_pat_vars([Val], [T], [], Map, State, false), + Type1 = remove_local_opaque_types(Type, State#state.opaques), + bind_bin_segs(Segs, t_bitstr(0, 0), [Type1|Acc], Map1, State); + utf -> % XXX: possibly can be strengthened + true = lists:member(SegType, [utf8, utf16, utf32]), + {Map1, [_]} = bind_pat_vars([Val], [t_integer()], [], Map, State, false), + Type = t_binary(), + bind_bin_segs(Segs, BinType, [Type|Acc], Map1, State); + BitSz when is_integer(BitSz) orelse BitSz =:= any -> + Size = cerl:bitstr_size(Seg), + {Map1, [SizeType]} = + bind_pat_vars([Size], [t_non_neg_integer()], [], Map, State, false), + Opaques = State#state.opaques, + NumberVals = t_number_vals(SizeType, Opaques), + case t_contains_opaque(SizeType, Opaques) of + true -> bind_error([Seg], SizeType, t_none(), opaque); + false -> ok + end, + Type = + case NumberVals of + [OneSize] -> t_bitstr(0, UnitVal * OneSize); + _ -> % 'unknown' too + MinSize = erl_types:number_min(SizeType, Opaques), + t_bitstr(UnitVal, UnitVal * MinSize) + end, + ValConstr = + case SegType of + binary -> Type; %% The same constraints as for the whole bitstr + float -> t_float(); + integer -> + case NumberVals of + unknown -> t_integer(); + List -> + SizeVal = lists:max(List), + Flags = cerl:concrete(cerl:bitstr_flags(Seg)), + N = SizeVal * UnitVal, + case N >= ?BITS of + true -> + case lists:member(signed, Flags) of + true -> t_from_range(neg_inf, pos_inf); + false -> t_from_range(0, pos_inf) + end; + false -> + case lists:member(signed, Flags) of + true -> t_from_range(-(1 bsl (N - 1)), 1 bsl (N - 1) - 1); + false -> t_from_range(0, 1 bsl N - 1) + end + end + end + end, + {Map2, [_]} = bind_pat_vars([Val], [ValConstr], [], Map1, State, false), + NewBinType = t_bitstr_match(Type, BinType), + case t_is_none(NewBinType) of + true -> bind_error([Seg], BinType, t_none(), bind); + false -> bind_bin_segs(Segs, NewBinType, [Type|Acc], Map2, State) + end + end; +bind_bin_segs([], _BinType, Acc, Map, _State) -> + {Map, lists:reverse(Acc)}. + +bind_error(Pats, Type, OpaqueType, Error0) -> + Error = case {Error0, Pats} of + {bind, [Pat]} -> + case is_literal_record(Pat) of + true -> record; + false -> Error0 + end; + _ -> Error0 + end, + throw({error, Error, Pats, Type, OpaqueType}). + +-spec bind_opaque_pats(type(), type(), cerl:c_literal(), state()) -> + no_return(). + +bind_opaque_pats(GenType, Type, Pat, State) -> + case t_find_opaque_mismatch(GenType, Type, State#state.opaques) of + {ok, T1, T2} -> + bind_error([Pat], T1, T2, opaque); + error -> + bind_error([Pat], Type, t_none(), bind) + end. + +%%---------------------------------------- +%% Guards +%% + +bind_guard(Guard, Map, State) -> + try bind_guard(Guard, Map, maps:new(), pos, State) of + {Map1, _Type} -> Map1 + catch + throw:{fail, Warning} -> {error, Warning}; + throw:{fatal_fail, Warning} -> {error, Warning} + end. + +bind_guard(Guard, Map, Env, Eval, State) -> + ?debug("Handling ~w guard: ~s\n", + [Eval, cerl_prettypr:format(Guard, [{noann, true}])]), + case cerl:type(Guard) of + binary -> + {Map, t_binary()}; + 'case' -> + Arg = cerl:case_arg(Guard), + Clauses = cerl:case_clauses(Guard), + bind_guard_case_clauses(Arg, Clauses, Map, Env, Eval, State); + cons -> + Hd = cerl:cons_hd(Guard), + Tl = cerl:cons_tl(Guard), + {Map1, HdType} = bind_guard(Hd, Map, Env, dont_know, State), + {Map2, TlType} = bind_guard(Tl, Map1, Env, dont_know, State), + {Map2, t_cons(HdType, TlType)}; + literal -> + {Map, literal_type(Guard)}; + 'try' -> + Arg = cerl:try_arg(Guard), + [Var] = cerl:try_vars(Guard), + EVars = cerl:try_evars(Guard), + %%?debug("Storing: ~w\n", [Var]), + Map1 = join_maps_begin(Map), + Map2 = mark_as_fresh(EVars, Map1), + %% Visit handler first so we know if it should be ignored + {{HandlerMap, HandlerType}, HandlerE} = + try {bind_guard(cerl:try_handler(Guard), Map2, Env, Eval, State), none} + catch throw:HE -> + {{Map2, t_none()}, HE} + end, + BodyEnv = maps:put(get_label(Var), Arg, Env), + Wanted = case Eval of pos -> t_atom(true); neg -> t_atom(false); + dont_know -> t_any() end, + case t_is_none(t_inf(HandlerType, Wanted)) of + %% Handler won't save us; pretend it does not exist + true -> bind_guard(cerl:try_body(Guard), Map, BodyEnv, Eval, State); + false -> + {{BodyMap, BodyType}, BodyE} = + try {bind_guard(cerl:try_body(Guard), Map1, BodyEnv, + Eval, State), none} + catch throw:BE -> + {{Map1, t_none()}, BE} + end, + Map3 = join_maps_end([BodyMap, HandlerMap], Map1), + case t_is_none(Sup = t_sup(BodyType, HandlerType)) of + true -> + %% Pick a reason. N.B. We assume that the handler is always + %% compiler-generated if the body is; that way, we won't need to + %% check. + Fatality = case {BodyE, HandlerE} of + {{fatal_fail, _}, _} -> fatal_fail; + {_, {fatal_fail, _}} -> fatal_fail; + _ -> fail + end, + throw({Fatality, + case {BodyE, HandlerE} of + {{_, Rsn}, _} when Rsn =/= none -> Rsn; + {_, {_,Rsn}} -> Rsn; + _ -> none + end}); + false -> {Map3, Sup} + end + end; + tuple -> + Es0 = cerl:tuple_es(Guard), + {Map1, Es} = bind_guard_list(Es0, Map, Env, dont_know, State), + {Map1, t_tuple(Es)}; + map -> + case Eval of + dont_know -> handle_guard_map(Guard, Map, Env, State); + _PosOrNeg -> {Map, t_none()} %% Map exprs do not produce bools + end; + 'let' -> + Arg = cerl:let_arg(Guard), + [Var] = cerl:let_vars(Guard), + %%?debug("Storing: ~w\n", [Var]), + NewEnv = maps:put(get_label(Var), Arg, Env), + bind_guard(cerl:let_body(Guard), Map, NewEnv, Eval, State); + values -> + Es = cerl:values_es(Guard), + List = [bind_guard(V, Map, Env, dont_know, State) || V <- Es], + Type = t_product([T || {_, T} <- List]), + {Map, Type}; + var -> + ?debug("Looking for var(~w)...", [cerl_trees:get_label(Guard)]), + case maps:find(get_label(Guard), Env) of + error -> + ?debug("Did not find it\n", []), + Type = lookup_type(Guard, Map), + Constr = + case Eval of + pos -> t_atom(true); + neg -> t_atom(false); + dont_know -> Type + end, + Inf = t_inf(Constr, Type), + {enter_type(Guard, Inf, Map), Inf}; + {ok, Tree} -> + ?debug("Found it\n", []), + {Map1, Type} = bind_guard(Tree, Map, Env, Eval, State), + {enter_type(Guard, Type, Map1), Type} + end; + call -> + handle_guard_call(Guard, Map, Env, Eval, State) + end. + +handle_guard_call(Guard, Map, Env, Eval, State) -> + MFA = {cerl:atom_val(cerl:call_module(Guard)), + cerl:atom_val(cerl:call_name(Guard)), + cerl:call_arity(Guard)}, + case MFA of + {erlang, F, 1} when F =:= is_atom; F =:= is_boolean; + F =:= is_binary; F =:= is_bitstring; + F =:= is_float; F =:= is_function; + F =:= is_integer; F =:= is_list; F =:= is_map; + F =:= is_number; F =:= is_pid; F =:= is_port; + F =:= is_reference; F =:= is_tuple -> + handle_guard_type_test(Guard, F, Map, Env, Eval, State); + {erlang, is_function, 2} -> + handle_guard_is_function(Guard, Map, Env, Eval, State); + MFA when (MFA =:= {erlang, internal_is_record, 3}) or + (MFA =:= {erlang, is_record, 3}) -> + handle_guard_is_record(Guard, Map, Env, Eval, State); + {erlang, '=:=', 2} -> + handle_guard_eqeq(Guard, Map, Env, Eval, State); + {erlang, '==', 2} -> + handle_guard_eq(Guard, Map, Env, Eval, State); + {erlang, 'and', 2} -> + handle_guard_and(Guard, Map, Env, Eval, State); + {erlang, 'or', 2} -> + handle_guard_or(Guard, Map, Env, Eval, State); + {erlang, 'not', 1} -> + handle_guard_not(Guard, Map, Env, Eval, State); + {erlang, Comp, 2} when Comp =:= '<'; Comp =:= '=<'; + Comp =:= '>'; Comp =:= '>=' -> + handle_guard_comp(Guard, Comp, Map, Env, Eval, State); + _ -> + handle_guard_gen_fun(MFA, Guard, Map, Env, Eval, State) + end. + +handle_guard_gen_fun({M, F, A}, Guard, Map, Env, Eval, State) -> + Args = cerl:call_args(Guard), + {Map1, As} = bind_guard_list(Args, Map, Env, dont_know, State), + Opaques = State#state.opaques, + BifRet = erl_bif_types:type(M, F, A, As, Opaques), + case t_is_none(BifRet) of + true -> + %% Is this an error-bif? + case t_is_none(erl_bif_types:type(M, F, A)) of + true -> signal_guard_fail(Eval, Guard, As, State); + false -> signal_guard_fatal_fail(Eval, Guard, As, State) + end; + false -> + BifArgs = bif_args(M, F, A), + Map2 = enter_type_lists(Args, t_inf_lists(BifArgs, As, Opaques), Map1), + Ret = + case Eval of + pos -> t_inf(t_atom(true), BifRet); + neg -> t_inf(t_atom(false), BifRet); + dont_know -> BifRet + end, + case t_is_none(Ret) of + true -> + case Eval =:= pos of + true -> signal_guard_fail(Eval, Guard, As, State); + false -> throw({fail, none}) + end; + false -> {Map2, Ret} + end + end. + +handle_guard_type_test(Guard, F, Map, Env, Eval, State) -> + [Arg] = cerl:call_args(Guard), + {Map1, ArgType} = bind_guard(Arg, Map, Env, dont_know, State), + case bind_type_test(Eval, F, ArgType, State) of + error -> + ?debug("Type test: ~w failed\n", [F]), + signal_guard_fail(Eval, Guard, [ArgType], State); + {ok, NewArgType, Ret} -> + ?debug("Type test: ~w succeeded, NewType: ~s, Ret: ~s\n", + [F, t_to_string(NewArgType), t_to_string(Ret)]), + {enter_type(Arg, NewArgType, Map1), Ret} + end. + +bind_type_test(Eval, TypeTest, ArgType, State) -> + Type = case TypeTest of + is_atom -> t_atom(); + is_boolean -> t_boolean(); + is_binary -> t_binary(); + is_bitstring -> t_bitstr(); + is_float -> t_float(); + is_function -> t_fun(); + is_integer -> t_integer(); + is_list -> t_maybe_improper_list(); + is_map -> t_map(); + is_number -> t_number(); + is_pid -> t_pid(); + is_port -> t_port(); + is_reference -> t_reference(); + is_tuple -> t_tuple() + end, + case Eval of + pos -> + Inf = t_inf(Type, ArgType, State#state.opaques), + case t_is_none(Inf) of + true -> error; + false -> {ok, Inf, t_atom(true)} + end; + neg -> + Sub = t_subtract(ArgType, Type), + case t_is_none(Sub) of + true -> error; + false -> {ok, Sub, t_atom(false)} + end; + dont_know -> + {ok, ArgType, t_boolean()} + end. + +handle_guard_comp(Guard, Comp, Map, Env, Eval, State) -> + Args = cerl:call_args(Guard), + [Arg1, Arg2] = Args, + {Map1, ArgTypes} = bind_guard_list(Args, Map, Env, dont_know, State), + Opaques = State#state.opaques, + [Type1, Type2] = ArgTypes, + IsInt1 = t_is_integer(Type1, Opaques), + IsInt2 = t_is_integer(Type2, Opaques), + case {type(Arg1), type(Arg2)} of + {{literal, Lit1}, {literal, Lit2}} -> + case erlang:Comp(cerl:concrete(Lit1), cerl:concrete(Lit2)) of + true when Eval =:= pos -> {Map, t_atom(true)}; + true when Eval =:= dont_know -> {Map, t_atom(true)}; + true when Eval =:= neg -> {Map, t_atom(true)}; + false when Eval =:= pos -> + signal_guard_fail(Eval, Guard, ArgTypes, State); + false when Eval =:= dont_know -> {Map, t_atom(false)}; + false when Eval =:= neg -> {Map, t_atom(false)} + end; + {{literal, Lit1}, var} when IsInt1 andalso IsInt2 andalso (Eval =:= pos) -> + case bind_comp_literal_var(Lit1, Arg2, Type2, Comp, Map1, Opaques) of + error -> signal_guard_fail(Eval, Guard, ArgTypes, State); + {ok, NewMap} -> {NewMap, t_atom(true)} + end; + {var, {literal, Lit2}} when IsInt1 andalso IsInt2 andalso (Eval =:= pos) -> + case bind_comp_literal_var(Lit2, Arg1, Type1, invert_comp(Comp), + Map1, Opaques) of + error -> signal_guard_fail(Eval, Guard, ArgTypes, State); + {ok, NewMap} -> {NewMap, t_atom(true)} + end; + {_, _} -> + handle_guard_gen_fun({erlang, Comp, 2}, Guard, Map, Env, Eval, State) + end. + +invert_comp('=<') -> '>='; +invert_comp('<') -> '>'; +invert_comp('>=') -> '=<'; +invert_comp('>') -> '<'. + +bind_comp_literal_var(Lit, Var, VarType, CompOp, Map, Opaques) -> + LitVal = cerl:concrete(Lit), + NewVarType = + case t_number_vals(VarType, Opaques) of + unknown -> + Range = + case CompOp of + '=<' -> t_from_range(LitVal, pos_inf); + '<' -> t_from_range(LitVal + 1, pos_inf); + '>=' -> t_from_range(neg_inf, LitVal); + '>' -> t_from_range(neg_inf, LitVal - 1) + end, + t_inf(Range, VarType, Opaques); + NumberVals -> + NewNumberVals = [X || X <- NumberVals, erlang:CompOp(LitVal, X)], + t_integers(NewNumberVals) + end, + case t_is_none(NewVarType) of + true -> error; + false -> {ok, enter_type(Var, NewVarType, Map)} + end. + +handle_guard_is_function(Guard, Map, Env, Eval, State) -> + Args = cerl:call_args(Guard), + {Map1, ArgTypes0} = bind_guard_list(Args, Map, Env, dont_know, State), + [FunType0, ArityType0] = ArgTypes0, + Opaques = State#state.opaques, + ArityType = t_inf(ArityType0, t_integer(), Opaques), + case t_is_none(ArityType) of + true -> signal_guard_fail(Eval, Guard, ArgTypes0, State); + false -> + FunTypeConstr = + case t_number_vals(ArityType, State#state.opaques) of + unknown -> t_fun(); + Vals -> + t_sup([t_fun(lists:duplicate(X, t_any()), t_any()) || X <- Vals]) + end, + FunType = t_inf(FunType0, FunTypeConstr, Opaques), + case t_is_none(FunType) of + true -> + case Eval of + pos -> signal_guard_fail(Eval, Guard, ArgTypes0, State); + neg -> {Map1, t_atom(false)}; + dont_know -> {Map1, t_atom(false)} + end; + false -> + case Eval of + pos -> {enter_type_lists(Args, [FunType, ArityType], Map1), + t_atom(true)}; + neg -> {Map1, t_atom(false)}; + dont_know -> {Map1, t_boolean()} + end + end + end. + +handle_guard_is_record(Guard, Map, Env, Eval, State) -> + Args = cerl:call_args(Guard), + [Rec, Tag0, Arity0] = Args, + Tag = cerl:atom_val(Tag0), + Arity = cerl:int_val(Arity0), + {Map1, RecType} = bind_guard(Rec, Map, Env, dont_know, State), + ArityMin1 = Arity - 1, + Opaques = State#state.opaques, + Tuple = t_tuple([t_atom(Tag)|lists:duplicate(ArityMin1, t_any())]), + case t_is_none(t_inf(Tuple, RecType, Opaques)) of + true -> + case erl_types:t_has_opaque_subtype(RecType, Opaques) of + true -> + signal_guard_fail(Eval, Guard, + [RecType, t_from_term(Tag), + t_from_term(Arity)], + State); + false -> + case Eval of + pos -> signal_guard_fail(Eval, Guard, + [RecType, t_from_term(Tag), + t_from_term(Arity)], + State); + neg -> {Map1, t_atom(false)}; + dont_know -> {Map1, t_atom(false)} + end + end; + false -> + TupleType = + case state__lookup_record(Tag, ArityMin1, State) of + error -> Tuple; + {ok, Prototype} -> Prototype + end, + Type = t_inf(TupleType, RecType, State#state.opaques), + case t_is_none(Type) of + true -> + %% No special handling of opaque errors. + FArgs = "record " ++ format_type(RecType, State), + Msg = {record_matching, [FArgs, Tag]}, + throw({fail, {Guard, Msg}}); + false -> + case Eval of + pos -> {enter_type(Rec, Type, Map1), t_atom(true)}; + neg -> {Map1, t_atom(false)}; + dont_know -> {Map1, t_boolean()} + end + end + end. + +handle_guard_eq(Guard, Map, Env, Eval, State) -> + [Arg1, Arg2] = cerl:call_args(Guard), + case {type(Arg1), type(Arg2)} of + {{literal, Lit1}, {literal, Lit2}} -> + case cerl:concrete(Lit1) =:= cerl:concrete(Lit2) of + true -> + if + Eval =:= pos -> {Map, t_atom(true)}; + Eval =:= neg -> + ArgTypes = [t_from_term(cerl:concrete(Lit1)), + t_from_term(cerl:concrete(Lit2))], + signal_guard_fail(Eval, Guard, ArgTypes, State); + Eval =:= dont_know -> {Map, t_atom(true)} + end; + false -> + if + Eval =:= neg -> {Map, t_atom(false)}; + Eval =:= dont_know -> {Map, t_atom(false)}; + Eval =:= pos -> + ArgTypes = [t_from_term(cerl:concrete(Lit1)), + t_from_term(cerl:concrete(Lit2))], + signal_guard_fail(Eval, Guard, ArgTypes, State) + end + end; + {{literal, Lit1}, _} when Eval =:= pos -> + case cerl:concrete(Lit1) of + Atom when is_atom(Atom) -> + bind_eqeq_guard_lit_other(Guard, Lit1, Arg2, Map, Env, State); + [] -> + bind_eqeq_guard_lit_other(Guard, Lit1, Arg2, Map, Env, State); + _ -> + bind_eq_guard(Guard, Lit1, Arg2, Map, Env, Eval, State) + end; + {_, {literal, Lit2}} when Eval =:= pos -> + case cerl:concrete(Lit2) of + Atom when is_atom(Atom) -> + bind_eqeq_guard_lit_other(Guard, Lit2, Arg1, Map, Env, State); + [] -> + bind_eqeq_guard_lit_other(Guard, Lit2, Arg1, Map, Env, State); + _ -> + bind_eq_guard(Guard, Arg1, Lit2, Map, Env, Eval, State) + end; + {_, _} -> + bind_eq_guard(Guard, Arg1, Arg2, Map, Env, Eval, State) + end. + +bind_eq_guard(Guard, Arg1, Arg2, Map, Env, Eval, State) -> + {Map1, Type1} = bind_guard(Arg1, Map, Env, dont_know, State), + {Map2, Type2} = bind_guard(Arg2, Map1, Env, dont_know, State), + Opaques = State#state.opaques, + case + t_is_nil(Type1, Opaques) orelse t_is_nil(Type2, Opaques) + orelse t_is_atom(Type1, Opaques) orelse t_is_atom(Type2, Opaques) + of + true -> bind_eqeq_guard(Guard, Arg1, Arg2, Map, Env, Eval, State); + false -> + %% XXX. Is this test OK? + OpArgs = erl_types:t_find_unknown_opaque(Type1, Type2, Opaques), + case OpArgs =:= [] of + true -> + case Eval of + pos -> {Map2, t_atom(true)}; + neg -> {Map2, t_atom(false)}; + dont_know -> {Map2, t_boolean()} + end; + false -> + signal_guard_fail(Eval, Guard, [Type1, Type2], State) + end + end. + +handle_guard_eqeq(Guard, Map, Env, Eval, State) -> + [Arg1, Arg2] = cerl:call_args(Guard), + case {type(Arg1), type(Arg2)} of + {{literal, Lit1}, {literal, Lit2}} -> + + case cerl:concrete(Lit1) =:= cerl:concrete(Lit2) of + true -> + if Eval =:= neg -> + ArgTypes = [t_from_term(cerl:concrete(Lit1)), + t_from_term(cerl:concrete(Lit2))], + signal_guard_fail(Eval, Guard, ArgTypes, State); + Eval =:= pos -> {Map, t_atom(true)}; + Eval =:= dont_know -> {Map, t_atom(true)} + end; + false -> + if Eval =:= neg -> {Map, t_atom(false)}; + Eval =:= dont_know -> {Map, t_atom(false)}; + Eval =:= pos -> + ArgTypes = [t_from_term(cerl:concrete(Lit1)), + t_from_term(cerl:concrete(Lit2))], + signal_guard_fail(Eval, Guard, ArgTypes, State) + end + end; + {{literal, Lit1}, _} when Eval =:= pos -> + bind_eqeq_guard_lit_other(Guard, Lit1, Arg2, Map, Env, State); + {_, {literal, Lit2}} when Eval =:= pos -> + bind_eqeq_guard_lit_other(Guard, Lit2, Arg1, Map, Env, State); + {_, _} -> + bind_eqeq_guard(Guard, Arg1, Arg2, Map, Env, Eval, State) + end. + +bind_eqeq_guard(Guard, Arg1, Arg2, Map, Env, Eval, State) -> + {Map1, Type1} = bind_guard(Arg1, Map, Env, dont_know, State), + {Map2, Type2} = bind_guard(Arg2, Map1, Env, dont_know, State), + ?debug("Types are:~s =:= ~s\n", [t_to_string(Type1), + t_to_string(Type2)]), + Opaques = State#state.opaques, + Inf = t_inf(Type1, Type2, Opaques), + case t_is_none(Inf) of + true -> + OpArgs = erl_types:t_find_unknown_opaque(Type1, Type2, Opaques), + case OpArgs =:= [] of + true -> + case Eval of + neg -> {Map2, t_atom(false)}; + dont_know -> {Map2, t_atom(false)}; + pos -> signal_guard_fail(Eval, Guard, [Type1, Type2], State) + end; + false -> + signal_guard_fail(Eval, Guard, [Type1, Type2], State) + end; + false -> + case Eval of + pos -> + case {cerl:type(Arg1), cerl:type(Arg2)} of + {var, var} -> + Map3 = enter_subst(Arg1, Arg2, Map2), + Map4 = enter_type(Arg2, Inf, Map3), + {Map4, t_atom(true)}; + {var, _} -> + Map3 = enter_type(Arg1, Inf, Map2), + {Map3, t_atom(true)}; + {_, var} -> + Map3 = enter_type(Arg2, Inf, Map2), + {Map3, t_atom(true)}; + {_, _} -> + {Map2, t_atom(true)} + end; + neg -> + {Map2, t_atom(false)}; + dont_know -> + {Map2, t_boolean()} + end + end. + +bind_eqeq_guard_lit_other(Guard, Arg1, Arg2, Map, Env, State) -> + Eval = dont_know, + Opaques = State#state.opaques, + case cerl:concrete(Arg1) of + true -> + {_, Type} = MT = bind_guard(Arg2, Map, Env, pos, State), + case t_is_any_atom(true, Type, Opaques) of + true -> MT; + false -> + {_, Type0} = bind_guard(Arg2, Map, Env, Eval, State), + signal_guard_fail(Eval, Guard, [Type0, t_atom(true)], State) + end; + false -> + {Map1, Type} = bind_guard(Arg2, Map, Env, neg, State), + case t_is_any_atom(false, Type, Opaques) of + true -> {Map1, t_atom(true)}; + false -> + {_, Type0} = bind_guard(Arg2, Map, Env, Eval, State), + signal_guard_fail(Eval, Guard, [Type0, t_atom(false)], State) + end; + Term -> + LitType = t_from_term(Term), + {Map1, Type} = bind_guard(Arg2, Map, Env, Eval, State), + case t_is_subtype(LitType, Type) of + false -> signal_guard_fail(Eval, Guard, [Type, LitType], State); + true -> + case cerl:is_c_var(Arg2) of + true -> {enter_type(Arg2, LitType, Map1), t_atom(true)}; + false -> {Map1, t_atom(true)} + end + end + end. + +handle_guard_and(Guard, Map, Env, Eval, State) -> + [Arg1, Arg2] = cerl:call_args(Guard), + Opaques = State#state.opaques, + case Eval of + pos -> + {Map1, Type1} = bind_guard(Arg1, Map, Env, Eval, State), + case t_is_any_atom(true, Type1, Opaques) of + false -> signal_guard_fail(Eval, Guard, [Type1, t_any()], State); + true -> + {Map2, Type2} = bind_guard(Arg2, Map1, Env, Eval, State), + case t_is_any_atom(true, Type2, Opaques) of + false -> signal_guard_fail(Eval, Guard, [Type1, Type2], State); + true -> {Map2, t_atom(true)} + end + end; + neg -> + MapJ = join_maps_begin(Map), + {Map1, Type1} = + try bind_guard(Arg1, MapJ, Env, neg, State) + catch throw:{fail, _} -> bind_guard(Arg2, MapJ, Env, pos, State) + end, + {Map2, Type2} = + try bind_guard(Arg2, MapJ, Env, neg, State) + catch throw:{fail, _} -> bind_guard(Arg1, MapJ, Env, pos, State) + end, + case + t_is_any_atom(false, Type1, Opaques) + orelse t_is_any_atom(false, Type2, Opaques) + of + true -> {join_maps_end([Map1, Map2], MapJ), t_atom(false)}; + false -> signal_guard_fail(Eval, Guard, [Type1, Type2], State) + end; + dont_know -> + MapJ = join_maps_begin(Map), + {Map1, Type1} = bind_guard(Arg1, MapJ, Env, dont_know, State), + {Map2, Type2} = bind_guard(Arg2, MapJ, Env, dont_know, State), + Bool1 = t_inf(Type1, t_boolean()), + Bool2 = t_inf(Type2, t_boolean()), + case t_is_none(Bool1) orelse t_is_none(Bool2) of + true -> throw({fatal_fail, none}); + false -> + NewMap = join_maps_end([Map1, Map2], MapJ), + NewType = + case {t_atom_vals(Bool1, Opaques), t_atom_vals(Bool2, Opaques)} of + {['true'] , ['true'] } -> t_atom(true); + {['false'], _ } -> t_atom(false); + {_ , ['false']} -> t_atom(false); + {unknown , _ } -> + signal_guard_fail(Eval, Guard, [Type1, Type2], State); + {_ , unknown } -> + signal_guard_fail(Eval, Guard, [Type1, Type2], State); + {_ , _ } -> t_boolean() + + end, + {NewMap, NewType} + end + end. + +handle_guard_or(Guard, Map, Env, Eval, State) -> + [Arg1, Arg2] = cerl:call_args(Guard), + Opaques = State#state.opaques, + case Eval of + pos -> + MapJ = join_maps_begin(Map), + {Map1, Bool1} = + try bind_guard(Arg1, MapJ, Env, pos, State) + catch + throw:{fail,_} -> bind_guard(Arg1, MapJ, Env, dont_know, State) + end, + {Map2, Bool2} = + try bind_guard(Arg2, MapJ, Env, pos, State) + catch + throw:{fail,_} -> bind_guard(Arg2, MapJ, Env, dont_know, State) + end, + case + ((t_is_any_atom(true, Bool1, Opaques) + andalso t_is_boolean(Bool2, Opaques)) + orelse + (t_is_any_atom(true, Bool2, Opaques) + andalso t_is_boolean(Bool1, Opaques))) + of + true -> {join_maps_end([Map1, Map2], MapJ), t_atom(true)}; + false -> signal_guard_fail(Eval, Guard, [Bool1, Bool2], State) + end; + neg -> + {Map1, Type1} = bind_guard(Arg1, Map, Env, neg, State), + case t_is_any_atom(false, Type1, Opaques) of + false -> signal_guard_fail(Eval, Guard, [Type1, t_any()], State); + true -> + {Map2, Type2} = bind_guard(Arg2, Map1, Env, neg, State), + case t_is_any_atom(false, Type2, Opaques) of + false -> signal_guard_fail(Eval, Guard, [Type1, Type2], State); + true -> {Map2, t_atom(false)} + end + end; + dont_know -> + MapJ = join_maps_begin(Map), + {Map1, Type1} = bind_guard(Arg1, MapJ, Env, dont_know, State), + {Map2, Type2} = bind_guard(Arg2, MapJ, Env, dont_know, State), + Bool1 = t_inf(Type1, t_boolean()), + Bool2 = t_inf(Type2, t_boolean()), + case t_is_none(Bool1) orelse t_is_none(Bool2) of + true -> throw({fatal_fail, none}); + false -> + NewMap = join_maps_end([Map1, Map2], MapJ), + NewType = + case {t_atom_vals(Bool1, Opaques), t_atom_vals(Bool2, Opaques)} of + {['false'], ['false']} -> t_atom(false); + {['true'] , _ } -> t_atom(true); + {_ , ['true'] } -> t_atom(true); + {unknown , _ } -> + signal_guard_fail(Eval, Guard, [Type1, Type2], State); + {_ , unknown } -> + signal_guard_fail(Eval, Guard, [Type1, Type2], State); + {_ , _ } -> t_boolean() + end, + {NewMap, NewType} + end + end. + +handle_guard_not(Guard, Map, Env, Eval, State) -> + [Arg] = cerl:call_args(Guard), + Opaques = State#state.opaques, + case Eval of + neg -> + {Map1, Type} = bind_guard(Arg, Map, Env, pos, State), + case t_is_any_atom(true, Type, Opaques) of + true -> {Map1, t_atom(false)}; + false -> + {_, Type0} = bind_guard(Arg, Map, Env, Eval, State), + signal_guard_fail(Eval, Guard, [Type0], State) + end; + pos -> + {Map1, Type} = bind_guard(Arg, Map, Env, neg, State), + case t_is_any_atom(false, Type, Opaques) of + true -> {Map1, t_atom(true)}; + false -> + {_, Type0} = bind_guard(Arg, Map, Env, Eval, State), + signal_guard_fail(Eval, Guard, [Type0], State) + end; + dont_know -> + {Map1, Type} = bind_guard(Arg, Map, Env, dont_know, State), + Bool = t_inf(Type, t_boolean()), + case t_is_none(Bool) of + true -> throw({fatal_fail, none}); + false -> + case t_atom_vals(Bool, Opaques) of + ['true'] -> {Map1, t_atom(false)}; + ['false'] -> {Map1, t_atom(true)}; + [_, _] -> {Map1, Bool}; + unknown -> signal_guard_fail(Eval, Guard, [Type], State) + end + end + end. + +bind_guard_list(Guards, Map, Env, Eval, State) -> + bind_guard_list(Guards, Map, Env, Eval, State, []). + +bind_guard_list([G|Gs], Map, Env, Eval, State, Acc) -> + {Map1, T} = bind_guard(G, Map, Env, Eval, State), + bind_guard_list(Gs, Map1, Env, Eval, State, [T|Acc]); +bind_guard_list([], Map, _Env, _Eval, _State, Acc) -> + {Map, lists:reverse(Acc)}. + +handle_guard_map(Guard, Map, Env, State) -> + Pairs = cerl:map_es(Guard), + Arg = cerl:map_arg(Guard), + {Map1, ArgType0} = bind_guard(Arg, Map, Env, dont_know, State), + ArgType1 = t_inf(t_map(), ArgType0), + case t_is_none_or_unit(ArgType1) of + true -> {Map1, t_none()}; + false -> + {Map2, TypePairs} = bind_guard_map_pairs(Pairs, Map1, Env, State, []), + {Map2, lists:foldl(fun({KV,assoc},Acc) -> erl_types:t_map_put(KV,Acc); + ({KV,exact},Acc) -> erl_types:t_map_update(KV,Acc) + end, ArgType1, TypePairs)} + end. + +bind_guard_map_pairs([], Map, _Env, _State, PairAcc) -> + {Map, lists:reverse(PairAcc)}; +bind_guard_map_pairs([Pair|Pairs], Map, Env, State, PairAcc) -> + Key = cerl:map_pair_key(Pair), + Val = cerl:map_pair_val(Pair), + Op = cerl:map_pair_op(Pair), + {Map1, [K,V]} = bind_guard_list([Key,Val],Map,Env,dont_know,State), + bind_guard_map_pairs(Pairs, Map1, Env, State, + [{{K,V},cerl:concrete(Op)}|PairAcc]). + +-type eval() :: 'pos' | 'neg' | 'dont_know'. + +-spec signal_guard_fail(eval(), cerl:c_call(), [type()], + state()) -> no_return(). + +signal_guard_fail(Eval, Guard, ArgTypes, State) -> + signal_guard_failure(Eval, Guard, ArgTypes, fail, State). + +-spec signal_guard_fatal_fail(eval(), cerl:c_call(), [erl_types:erl_type()], + state()) -> no_return(). + +signal_guard_fatal_fail(Eval, Guard, ArgTypes, State) -> + signal_guard_failure(Eval, Guard, ArgTypes, fatal_fail, State). + +signal_guard_failure(Eval, Guard, ArgTypes, Tag, State) -> + Args = cerl:call_args(Guard), + F = cerl:atom_val(cerl:call_name(Guard)), + {M, F, A} = MFA = {cerl:atom_val(cerl:call_module(Guard)), F, length(Args)}, + Opaques = State#state.opaques, + {Kind, XInfo} = + case erl_bif_types:opaque_args(M, F, A, ArgTypes, Opaques) of + [] -> + {case Eval of + neg -> neg_guard_fail; + pos -> guard_fail; + dont_know -> guard_fail + end, + []}; + Ns -> {opaque_guard, [Ns]} + end, + FArgs = + case is_infix_op(MFA) of + true -> + [ArgType1, ArgType2] = ArgTypes, + [Arg1, Arg2] = Args, + [format_args_1([Arg1], [ArgType1], State), + atom_to_list(F), + format_args_1([Arg2], [ArgType2], State)] ++ XInfo; + false -> + [F, format_args(Args, ArgTypes, State)] + end, + Msg = {Kind, FArgs}, + throw({Tag, {Guard, Msg}}). + +is_infix_op({erlang, '=:=', 2}) -> true; +is_infix_op({erlang, '==', 2}) -> true; +is_infix_op({erlang, '=/=', 2}) -> true; +is_infix_op({erlang, '=/', 2}) -> true; +is_infix_op({erlang, '<', 2}) -> true; +is_infix_op({erlang, '=<', 2}) -> true; +is_infix_op({erlang, '>', 2}) -> true; +is_infix_op({erlang, '>=', 2}) -> true; +is_infix_op({M, F, A}) when is_atom(M), is_atom(F), + is_integer(A), 0 =< A, A =< 255 -> false. + +bif_args(M, F, A) -> + case erl_bif_types:arg_types(M, F, A) of + unknown -> lists:duplicate(A, t_any()); + List -> List + end. + +bind_guard_case_clauses(Arg, Clauses, Map0, Env, Eval, State) -> + Clauses1 = filter_fail_clauses(Clauses), + Map = join_maps_begin(Map0), + {GenMap, GenArgType} = bind_guard(Arg, Map, Env, dont_know, State), + bind_guard_case_clauses(GenArgType, GenMap, Arg, Clauses1, Map, Env, Eval, + t_none(), [], State). + +filter_fail_clauses([Clause|Left]) -> + case (cerl:clause_pats(Clause) =:= []) of + true -> + Body = cerl:clause_body(Clause), + case cerl:is_literal(Body) andalso (cerl:concrete(Body) =:= fail) orelse + cerl:is_c_primop(Body) andalso + (cerl:atom_val(cerl:primop_name(Body)) =:= match_fail) of + true -> filter_fail_clauses(Left); + false -> [Clause|filter_fail_clauses(Left)] + end; + false -> + [Clause|filter_fail_clauses(Left)] + end; +filter_fail_clauses([]) -> + []. + +bind_guard_case_clauses(GenArgType, GenMap, ArgExpr, [Clause|Left], + Map, Env, Eval, AccType, AccMaps, State) -> + Pats = cerl:clause_pats(Clause), + {NewMap0, ArgType} = + case Pats of + [Pat] -> + case cerl:is_literal(Pat) of + true -> + try + case cerl:concrete(Pat) of + true -> bind_guard(ArgExpr, Map, Env, pos, State); + false -> bind_guard(ArgExpr, Map, Env, neg, State); + _ -> {GenMap, GenArgType} + end + catch + throw:{fail, _} -> {none, GenArgType} + end; + false -> + {GenMap, GenArgType} + end; + _ -> {GenMap, GenArgType} + end, + NewMap1 = + case Pats =:= [] of + true -> NewMap0; + false -> + case t_is_none(ArgType) of + true -> none; + false -> + ArgTypes = case t_is_any(ArgType) of + true -> Any = t_any(), [Any || _ <- Pats]; + false -> t_to_tlist(ArgType) + end, + case bind_pat_vars(Pats, ArgTypes, [], NewMap0, State) of + {error, _, _, _, _} -> none; + {PatMap, _PatTypes} -> PatMap + end + end + end, + Guard = cerl:clause_guard(Clause), + GenPatType = dialyzer_typesig:get_safe_underapprox(Pats, Guard), + NewGenArgType = t_subtract(GenArgType, GenPatType), + case (NewMap1 =:= none) orelse t_is_none(GenArgType) of + true -> + bind_guard_case_clauses(NewGenArgType, GenMap, ArgExpr, Left, Map, Env, + Eval, AccType, AccMaps, State); + false -> + {NewAccType, NewAccMaps} = + try + {NewMap2, GuardType} = bind_guard(Guard, NewMap1, Env, pos, State), + case t_is_none(t_inf(t_atom(true), GuardType)) of + true -> throw({fail, none}); + false -> ok + end, + {NewMap3, CType} = bind_guard(cerl:clause_body(Clause), NewMap2, + Env, Eval, State), + Opaques = State#state.opaques, + case Eval of + pos -> + case t_is_any_atom(true, CType, Opaques) of + true -> ok; + false -> throw({fail, none}) + end; + neg -> + case t_is_any_atom(false, CType, Opaques) of + true -> ok; + false -> throw({fail, none}) + end; + dont_know -> + ok + end, + {t_sup(AccType, CType), [NewMap3|AccMaps]} + catch + throw:{fail, _What} -> {AccType, AccMaps} + end, + bind_guard_case_clauses(NewGenArgType, GenMap, ArgExpr, Left, Map, Env, + Eval, NewAccType, NewAccMaps, State) + end; +bind_guard_case_clauses(_GenArgType, _GenMap, _ArgExpr, [], Map, _Env, _Eval, + AccType, AccMaps, _State) -> + case t_is_none(AccType) of + true -> throw({fail, none}); + false -> {join_maps_end(AccMaps, Map), AccType} + end. + +%%% =========================================================================== +%%% +%%% Maps and types. +%%% +%%% =========================================================================== + +map__new() -> + #map{}. + +%% join_maps_begin pushes 'modified' to the stack; join_maps pops +%% 'modified' from the stack. + +join_maps_begin(#map{modified = M, modified_stack = S, ref = Ref} = Map) -> + Map#map{ref = make_ref(), modified = [], modified_stack = [{M,Ref} | S]}. + +join_maps_end(Maps, MapOut) -> + #map{ref = Ref, modified_stack = [{M1,R1} | S]} = MapOut, + true = lists:all(fun(M) -> M#map.ref =:= Ref end, Maps), % sanity + Keys0 = lists:usort(lists:append([M#map.modified || M <- Maps])), + #map{map = Map, subst = Subst} = MapOut, + Keys = [Key || + Key <- Keys0, + maps:is_key(Key, Map) orelse maps:is_key(Key, Subst)], + Out = case Maps of + [] -> join_maps(Maps, MapOut); + _ -> join_maps(Keys, Maps, MapOut) + end, + debug_join_check(Maps, MapOut, Out), + Out#map{ref = R1, + modified = Out#map.modified ++ M1, % duplicates possible + modified_stack = S}. + +join_maps(Maps, MapOut) -> + #map{map = Map, subst = Subst} = MapOut, + Keys = ordsets:from_list(maps:keys(Map) ++ maps:keys(Subst)), + join_maps(Keys, Maps, MapOut). + +join_maps(Keys, Maps, MapOut) -> + KTs = join_maps_collect(Keys, Maps, MapOut), + lists:foldl(fun({K, T}, M) -> enter_type(K, T, M) end, MapOut, KTs). + +join_maps_collect([Key|Left], Maps, MapOut) -> + Type = join_maps_one_key(Maps, Key, t_none()), + case t_is_equal(lookup_type(Key, MapOut), Type) of + true -> join_maps_collect(Left, Maps, MapOut); + false -> [{Key, Type} | join_maps_collect(Left, Maps, MapOut)] + end; +join_maps_collect([], _Maps, _MapOut) -> + []. + +join_maps_one_key([Map|Left], Key, AccType) -> + case t_is_any(AccType) of + true -> + %% We can stop here + AccType; + false -> + join_maps_one_key(Left, Key, t_sup(lookup_type(Key, Map), AccType)) + end; +join_maps_one_key([], _Key, AccType) -> + AccType. + +-ifdef(DEBUG). +debug_join_check(Maps, MapOut, Out) -> + #map{map = Map, subst = Subst} = Out, + #map{map = Map2, subst = Subst2} = join_maps(Maps, MapOut), + F = fun(D) -> lists:keysort(1, maps:to_list(D)) end, + [throw({bug, join_maps}) || + F(Map) =/= F(Map2) orelse F(Subst) =/= F(Subst2)]. +-else. +debug_join_check(_Maps, _MapOut, _Out) -> ok. +-endif. + +enter_type_lists([Key|KeyTail], [Val|ValTail], Map) -> + Map1 = enter_type(Key, Val, Map), + enter_type_lists(KeyTail, ValTail, Map1); +enter_type_lists([], [], Map) -> + Map. + +enter_type_list([{Key, Val}|Left], Map) -> + Map1 = enter_type(Key, Val, Map), + enter_type_list(Left, Map1); +enter_type_list([], Map) -> + Map. + +enter_type(Key, Val, MS) -> + case cerl:is_literal(Key) of + true -> MS; + false -> + case cerl:is_c_values(Key) of + true -> + Keys = cerl:values_es(Key), + case t_is_any(Val) orelse t_is_none(Val) of + true -> + enter_type_lists(Keys, [Val || _ <- Keys], MS); + false -> + enter_type_lists(Keys, t_to_tlist(Val), MS) + end; + false -> + #map{map = Map, subst = Subst} = MS, + KeyLabel = get_label(Key), + case maps:find(KeyLabel, Subst) of + {ok, NewKey} -> + ?debug("Binding ~p to ~p\n", [KeyLabel, NewKey]), + enter_type(NewKey, Val, MS); + error -> + ?debug("Entering ~p :: ~s\n", [KeyLabel, t_to_string(Val)]), + case maps:find(KeyLabel, Map) of + {ok, Value} -> + case erl_types:t_is_equal(Val, Value) of + true -> MS; + false -> store_map(KeyLabel, Val, MS) + end; + error -> store_map(KeyLabel, Val, MS) + end + end + end + end. + +store_map(Key, Val, #map{map = Map, ref = undefined} = MapRec) -> + MapRec#map{map = maps:put(Key, Val, Map)}; +store_map(Key, Val, #map{map = Map, modified = Mod} = MapRec) -> + MapRec#map{map = maps:put(Key, Val, Map), modified = [Key | Mod]}. + +enter_subst(Key, Val0, #map{subst = Subst} = MS) -> + KeyLabel = get_label(Key), + Val = dialyzer_utils:refold_pattern(Val0), + case cerl:is_literal(Val) of + true -> + store_map(KeyLabel, literal_type(Val), MS); + false -> + case cerl:is_c_var(Val) of + false -> MS; + true -> + ValLabel = get_label(Val), + case maps:find(ValLabel, Subst) of + {ok, NewVal} -> + enter_subst(Key, NewVal, MS); + error -> + if KeyLabel =:= ValLabel -> MS; + true -> + ?debug("Subst: storing ~p = ~p\n", [KeyLabel, ValLabel]), + store_subst(KeyLabel, ValLabel, MS) + end + end + end + end. + +store_subst(Key, Val, #map{subst = S, ref = undefined} = Map) -> + Map#map{subst = maps:put(Key, Val, S)}; +store_subst(Key, Val, #map{subst = S, modified = Mod} = Map) -> + Map#map{subst = maps:put(Key, Val, S), modified = [Key | Mod]}. + +lookup_type(Key, #map{map = Map, subst = Subst}) -> + lookup(Key, Map, Subst, t_none()). + +lookup(Key, Map, Subst, AnyNone) -> + case cerl:is_literal(Key) of + true -> literal_type(Key); + false -> + Label = get_label(Key), + case maps:find(Label, Subst) of + {ok, NewKey} -> lookup(NewKey, Map, Subst, AnyNone); + error -> + case maps:find(Label, Map) of + {ok, Val} -> Val; + error -> AnyNone + end + end + end. + +lookup_fun_sig(Fun, Callgraph, Plt) -> + MFAorLabel = + case dialyzer_callgraph:lookup_name(Fun, Callgraph) of + error -> Fun; + {ok, MFA} -> MFA + end, + dialyzer_plt:lookup(Plt, MFAorLabel). + +literal_type(Lit) -> + t_from_term(cerl:concrete(Lit)). + +mark_as_fresh([Tree|Left], Map) -> + SubTrees1 = lists:append(cerl:subtrees(Tree)), + {SubTrees2, Map1} = + case cerl:type(Tree) of + bitstr -> + %% The Size field is not fresh. + {SubTrees1 -- [cerl:bitstr_size(Tree)], Map}; + map_pair -> + %% The keys are not fresh + {SubTrees1 -- [cerl:map_pair_key(Tree)], Map}; + var -> + {SubTrees1, enter_type(Tree, t_any(), Map)}; + _ -> + {SubTrees1, Map} + end, + mark_as_fresh(SubTrees2 ++ Left, Map1); +mark_as_fresh([], Map) -> + Map. + +-ifdef(DEBUG). +debug_pp_map(#map{map = Map}=MapRec) -> + Keys = maps:keys(Map), + io:format("Map:\n", []), + lists:foreach(fun (Key) -> + io:format("\t~w :: ~s\n", + [Key, t_to_string(lookup_type(Key, MapRec))]) + end, Keys), + ok. +-else. +debug_pp_map(_Map) -> ok. +-endif. + +%%% =========================================================================== +%%% +%%% Utilities +%%% +%%% =========================================================================== + +get_label(L) when is_integer(L) -> + L; +get_label(T) -> + cerl_trees:get_label(T). + +t_is_simple(ArgType, State) -> + Opaques = State#state.opaques, + t_is_atom(ArgType, Opaques) orelse t_is_number(ArgType, Opaques) + orelse t_is_port(ArgType, Opaques) + orelse t_is_pid(ArgType, Opaques) orelse t_is_reference(ArgType, Opaques) + orelse t_is_nil(ArgType, Opaques). + +remove_local_opaque_types(Type, Opaques) -> + t_unopaque(Type, Opaques). + +%% t_is_structured(ArgType) -> +%% case t_is_nil(ArgType) of +%% true -> false; +%% false -> +%% SType = t_inf(t_sup([t_list(), t_tuple(), t_binary()]), ArgType), +%% t_is_equal(ArgType, SType) +%% end. + +is_call_to_send(Tree) -> + case cerl:is_c_call(Tree) of + false -> false; + true -> + Mod = cerl:call_module(Tree), + Name = cerl:call_name(Tree), + Arity = cerl:call_arity(Tree), + cerl:is_c_atom(Mod) + andalso cerl:is_c_atom(Name) + andalso is_send(cerl:atom_val(Name)) + andalso (cerl:atom_val(Mod) =:= erlang) + andalso (Arity =:= 2) + end. + +is_send('!') -> true; +is_send(send) -> true; +is_send(_) -> false. + +is_lc_simple_list(Tree, TreeType, State) -> + Opaques = State#state.opaques, + Ann = cerl:get_ann(Tree), + lists:member(list_comprehension, Ann) + andalso t_is_list(TreeType) + andalso t_is_simple(t_list_elements(TreeType, Opaques), State). + +filter_match_fail([Clause] = Cls) -> + Body = cerl:clause_body(Clause), + case cerl:type(Body) of + primop -> + case cerl:atom_val(cerl:primop_name(Body)) of + match_fail -> []; + raise -> []; + _ -> Cls + end; + _ -> Cls + end; +filter_match_fail([H|T]) -> + [H|filter_match_fail(T)]; +filter_match_fail([]) -> + %% This can actually happen, for example in + %% receive after 1 -> ok end + []. + +%%% =========================================================================== +%%% +%%% The State. +%%% +%%% =========================================================================== + +state__new(Callgraph, Codeserver, Tree, Plt, Module, Records) -> + Opaques = erl_types:t_opaque_from_records(Records), + {TreeMap, FunHomes} = build_tree_map(Tree, Callgraph), + Funs = dict:fetch_keys(TreeMap), + FunTab = init_fun_tab(Funs, dict:new(), TreeMap, Callgraph, Plt), + ExportedFuns = + [Fun || Fun <- Funs--[top], dialyzer_callgraph:is_escaping(Fun, Callgraph)], + Work = init_work(ExportedFuns), + Env = lists:foldl(fun(Fun, Env) -> dict:store(Fun, map__new(), Env) end, + dict:new(), Funs), + #state{callgraph = Callgraph, codeserver = Codeserver, + envs = Env, fun_tab = FunTab, fun_homes = FunHomes, opaques = Opaques, + plt = Plt, races = dialyzer_races:new(), records = Records, + warning_mode = false, warnings = [], work = Work, tree_map = TreeMap, + module = Module}. + +state__warning_mode(#state{warning_mode = WM}) -> + WM. + +state__set_warning_mode(#state{tree_map = TreeMap, fun_tab = FunTab, + races = Races} = State) -> + ?debug("==========\nStarting warning pass\n==========\n", []), + Funs = dict:fetch_keys(TreeMap), + State#state{work = init_work([top|Funs--[top]]), + fun_tab = FunTab, warning_mode = true, + races = dialyzer_races:put_race_analysis(true, Races)}. + +state__race_analysis(Analysis, #state{races = Races} = State) -> + State#state{races = dialyzer_races:put_race_analysis(Analysis, Races)}. + +state__renew_curr_fun(CurrFun, CurrFunLabel, + #state{races = Races} = State) -> + State#state{races = dialyzer_races:put_curr_fun(CurrFun, CurrFunLabel, + Races)}. + +state__renew_fun_args(Args, #state{races = Races} = State) -> + case state__warning_mode(State) of + true -> State; + false -> + State#state{races = dialyzer_races:put_fun_args(Args, Races)} + end. + +state__renew_race_list(RaceList, RaceListSize, + #state{races = Races} = State) -> + State#state{races = dialyzer_races:put_race_list(RaceList, RaceListSize, + Races)}. + +state__renew_warnings(Warnings, State) -> + State#state{warnings = Warnings}. + +-spec state__add_warning(raw_warning(), state()) -> state(). + +state__add_warning(Warn, #state{warnings = Warnings} = State) -> + State#state{warnings = [Warn|Warnings]}. + +state__add_warning(State, Tag, Tree, Msg) -> + state__add_warning(State, Tag, Tree, Msg, false). + +state__add_warning(#state{warning_mode = false} = State, _, _, _, _) -> + State; +state__add_warning(#state{warnings = Warnings, warning_mode = true} = State, + Tag, Tree, Msg, Force) -> + Ann = cerl:get_ann(Tree), + case Force of + true -> + WarningInfo = {get_file(Ann), + abs(get_line(Ann)), + State#state.curr_fun}, + Warn = {Tag, WarningInfo, Msg}, + ?debug("MSG ~s\n", [dialyzer:format_warning(Warn)]), + State#state{warnings = [Warn|Warnings]}; + false -> + case is_compiler_generated(Ann) of + true -> State; + false -> + WarningInfo = {get_file(Ann), get_line(Ann), State#state.curr_fun}, + Warn = {Tag, WarningInfo, Msg}, + case Tag of + ?WARN_CONTRACT_RANGE -> ok; + _ -> ?debug("MSG ~s\n", [dialyzer:format_warning(Warn)]) + end, + State#state{warnings = [Warn|Warnings]} + end + end. + +state__remove_added_warnings(OldState, NewState) -> + #state{warnings = OldWarnings} = OldState, + #state{warnings = NewWarnings} = NewState, + {NewWarnings -- OldWarnings, NewState#state{warnings = OldWarnings}}. + +state__add_warnings(Warns, #state{warnings = Warnings} = State) -> + State#state{warnings = Warns ++ Warnings}. + +-spec state__set_curr_fun(curr_fun(), state()) -> state(). + +state__set_curr_fun(undefined, State) -> + State#state{curr_fun = undefined}; +state__set_curr_fun(FunLbl, State) -> + State#state{curr_fun = find_function(FunLbl, State)}. + +-spec state__find_function(mfa_or_funlbl(), state()) -> mfa_or_funlbl(). + +state__find_function(FunLbl, State) -> + find_function(FunLbl, State). + +state__get_race_warnings(#state{races = Races} = State) -> + {Races1, State1} = dialyzer_races:get_race_warnings(Races, State), + State1#state{races = Races1}. + +state__get_warnings(#state{tree_map = TreeMap, fun_tab = FunTab, + callgraph = Callgraph, plt = Plt} = State) -> + FoldFun = + fun({top, _}, AccState) -> AccState; + ({FunLbl, Fun}, AccState) -> + AccState1 = state__set_curr_fun(FunLbl, AccState), + {NotCalled, Ret} = + case dict:fetch(get_label(Fun), FunTab) of + {not_handled, {_Args0, Ret0}} -> {true, Ret0}; + {_Args0, Ret0} -> {false, Ret0} + end, + case NotCalled of + true -> + case dialyzer_callgraph:lookup_name(FunLbl, Callgraph) of + error -> AccState1; + {ok, {_M, F, A}} -> + Msg = {unused_fun, [F, A]}, + state__add_warning(AccState1, ?WARN_NOT_CALLED, Fun, Msg) + end; + false -> + {Name, Contract} = + case dialyzer_callgraph:lookup_name(FunLbl, Callgraph) of + error -> {[], none}; + {ok, {_M, F, A} = MFA} -> + {[F, A], dialyzer_plt:lookup_contract(Plt, MFA)} + end, + case t_is_none(Ret) of + true -> + %% Check if the function has a contract that allows this. + Warn = + case Contract of + none -> not parent_allows_this(FunLbl, AccState1); + {value, C} -> + GenRet = dialyzer_contracts:get_contract_return(C), + not t_is_unit(GenRet) + end, + case Warn of + true -> + case classify_returns(Fun) of + no_match -> + Msg = {no_return, [no_match|Name]}, + state__add_warning(AccState1, ?WARN_RETURN_NO_RETURN, + Fun, Msg); + only_explicit -> + Msg = {no_return, [only_explicit|Name]}, + state__add_warning(AccState1, ?WARN_RETURN_ONLY_EXIT, + Fun, Msg); + only_normal -> + Msg = {no_return, [only_normal|Name]}, + state__add_warning(AccState1, ?WARN_RETURN_NO_RETURN, + Fun, Msg); + both -> + Msg = {no_return, [both|Name]}, + state__add_warning(AccState1, ?WARN_RETURN_NO_RETURN, + Fun, Msg) + end; + false -> + AccState + end; + false -> + AccState + end + end + end, + #state{warnings = Warn} = lists:foldl(FoldFun, State, dict:to_list(TreeMap)), + Warn. + +state__is_escaping(Fun, #state{callgraph = Callgraph}) -> + dialyzer_callgraph:is_escaping(Fun, Callgraph). + +state__lookup_type_for_letrec(Var, #state{callgraph = Callgraph} = State) -> + Label = get_label(Var), + case dialyzer_callgraph:lookup_letrec(Label, Callgraph) of + error -> error; + {ok, FunLabel} -> + {ok, state__fun_type(FunLabel, State)} + end. + +state__lookup_name({_, _, _} = MFA, #state{}) -> + MFA; +state__lookup_name(top, #state{}) -> + top; +state__lookup_name(Fun, #state{callgraph = Callgraph}) -> + case dialyzer_callgraph:lookup_name(Fun, Callgraph) of + {ok, MFA} -> MFA; + error -> Fun + end. + +state__lookup_record(Tag, Arity, #state{records = Records}) -> + case erl_types:lookup_record(Tag, Arity, Records) of + {ok, Fields} -> + RecType = + t_tuple([t_atom(Tag)| + [FieldType || {_FieldName, _Abstr, FieldType} <- Fields]]), + {ok, RecType}; + error -> + error + end. + +state__get_args_and_status(Tree, #state{fun_tab = FunTab}) -> + Fun = get_label(Tree), + case dict:find(Fun, FunTab) of + {ok, {not_handled, {ArgTypes, _}}} -> {ArgTypes, false}; + {ok, {ArgTypes, _}} -> {ArgTypes, true} + end. + +build_tree_map(Tree, Callgraph) -> + Fun = + fun(T, {Dict, Homes, FunLbls} = Acc) -> + case cerl:is_c_fun(T) of + true -> + FunLbl = get_label(T), + Dict1 = dict:store(FunLbl, T, Dict), + case catch dialyzer_callgraph:lookup_name(FunLbl, Callgraph) of + {ok, MFA} -> + F2 = + fun(Lbl, Dict0) -> + dict:store(Lbl, MFA, Dict0) + end, + Homes1 = lists:foldl(F2, Homes, [FunLbl|FunLbls]), + {Dict1, Homes1, []}; + _ -> + {Dict1, Homes, [FunLbl|FunLbls]} + end; + false -> + Acc + end + end, + Dict0 = dict:new(), + {Dict, Homes, _} = cerl_trees:fold(Fun, {Dict0, Dict0, []}, Tree), + {Dict, Homes}. + +init_fun_tab([top|Left], Dict, TreeMap, Callgraph, Plt) -> + NewDict = dict:store(top, {[], t_none()}, Dict), + init_fun_tab(Left, NewDict, TreeMap, Callgraph, Plt); +init_fun_tab([Fun|Left], Dict, TreeMap, Callgraph, Plt) -> + Arity = cerl:fun_arity(dict:fetch(Fun, TreeMap)), + FunEntry = + case dialyzer_callgraph:is_escaping(Fun, Callgraph) of + true -> + Args = lists:duplicate(Arity, t_any()), + case lookup_fun_sig(Fun, Callgraph, Plt) of + none -> {Args, t_unit()}; + {value, {RetType, _}} -> + case t_is_none(RetType) of + true -> {Args, t_none()}; + false -> {Args, t_unit()} + end + end; + false -> {not_handled, {lists:duplicate(Arity, t_none()), t_unit()}} + end, + NewDict = dict:store(Fun, FunEntry, Dict), + init_fun_tab(Left, NewDict, TreeMap, Callgraph, Plt); +init_fun_tab([], Dict, _TreeMap, _Callgraph, _Plt) -> + ?debug("DICT:~p\n",[dict:to_list(Dict)]), + Dict. + +state__update_fun_env(Tree, Map, #state{envs = Envs} = State) -> + NewEnvs = dict:store(get_label(Tree), Map, Envs), + State#state{envs = NewEnvs}. + +state__fun_env(Tree, #state{envs = Envs}) -> + Fun = get_label(Tree), + case dict:find(Fun, Envs) of + error -> none; + {ok, Map} -> Map + end. + +state__clean_not_called(#state{fun_tab = FunTab} = State) -> + NewFunTab = + dict:map(fun(top, Entry) -> Entry; + (_Fun, {not_handled, {Args, _}}) -> {Args, t_none()}; + (_Fun, Entry) -> Entry + end, FunTab), + State#state{fun_tab = NewFunTab}. + +state__all_fun_types(State) -> + #state{fun_tab = FunTab} = state__clean_not_called(State), + Tab1 = dict:erase(top, FunTab), + dict:map(fun(_Fun, {Args, Ret}) -> t_fun(Args, Ret)end, Tab1). + +state__fun_type(Fun, #state{fun_tab = FunTab}) -> + Label = + if is_integer(Fun) -> Fun; + true -> get_label(Fun) + end, + Entry = dict:find(Label, FunTab), + ?debug("FunType ~p:~p\n",[Label, Entry]), + case Entry of + {ok, {not_handled, {A, R}}} -> + t_fun(A, R); + {ok, {A, R}} -> + t_fun(A, R) + end. + +state__update_fun_entry(Tree, ArgTypes, Out0, + #state{fun_tab=FunTab, callgraph=CG, plt=Plt} = State)-> + Fun = get_label(Tree), + Out1 = + if Fun =:= top -> Out0; + true -> + case lookup_fun_sig(Fun, CG, Plt) of + {value, {SigRet, _}} -> t_inf(SigRet, Out0); + none -> Out0 + end + end, + Out = t_limit(Out1, ?TYPE_LIMIT), + {ok, {OldArgTypes, OldOut}} = dict:find(Fun, FunTab), + SameArgs = lists:all(fun({A, B}) -> erl_types:t_is_equal(A, B) + end, lists:zip(OldArgTypes, ArgTypes)), + SameOut = t_is_equal(OldOut, Out), + if + SameArgs, SameOut -> + ?debug("Fixpoint for ~w: ~s\n", + [state__lookup_name(Fun, State), + t_to_string(t_fun(ArgTypes, Out))]), + State; + true -> + %% Can only happen in self-recursive functions. + NewEntry = {OldArgTypes, Out}, + ?debug("New Entry for ~w: ~s\n", + [state__lookup_name(Fun, State), + t_to_string(t_fun(OldArgTypes, Out))]), + NewFunTab = dict:store(Fun, NewEntry, FunTab), + State1 = State#state{fun_tab = NewFunTab}, + state__add_work_from_fun(Tree, State1) + end. + +state__add_work_from_fun(_Tree, #state{warning_mode = true} = State) -> + State; +state__add_work_from_fun(Tree, #state{callgraph = Callgraph, + tree_map = TreeMap} = State) -> + case get_label(Tree) of + top -> State; + Label when is_integer(Label) -> + case dialyzer_callgraph:in_neighbours(Label, Callgraph) of + none -> State; + MFAList -> + LabelList = [dialyzer_callgraph:lookup_label(MFA, Callgraph) + || MFA <- MFAList], + %% Must filter the result for results in this module. + FilteredList = [L || {ok, L} <- LabelList, dict:is_key(L, TreeMap)], + ?debug("~w: Will try to add:~w\n", + [state__lookup_name(Label, State), MFAList]), + lists:foldl(fun(L, AccState) -> + state__add_work(L, AccState) + end, State, FilteredList) + end + end. + +state__add_work(external, State) -> + State; +state__add_work(top, State) -> + State; +state__add_work(Fun, #state{work = Work} = State) -> + NewWork = add_work(Fun, Work), + State#state{work = NewWork}. + +state__get_work(#state{work = Work, tree_map = TreeMap} = State) -> + case get_work(Work) of + none -> none; + {Fun, NewWork} -> + {dict:fetch(Fun, TreeMap), State#state{work = NewWork}} + end. + +state__lookup_call_site(Tree, #state{callgraph = Callgraph}) -> + Label = get_label(Tree), + dialyzer_callgraph:lookup_call_site(Label, Callgraph). + +state__fun_info(external, #state{}) -> + external; +state__fun_info({_, _, _} = MFA, #state{plt = PLT}) -> + {MFA, + dialyzer_plt:lookup(PLT, MFA), + dialyzer_plt:lookup_contract(PLT, MFA), + t_any()}; +state__fun_info(Fun, #state{callgraph = CG, fun_tab = FunTab, plt = PLT}) -> + {Sig, Contract} = + case dialyzer_callgraph:lookup_name(Fun, CG) of + error -> + {dialyzer_plt:lookup(PLT, Fun), none}; + {ok, MFA} -> + {dialyzer_plt:lookup(PLT, MFA), dialyzer_plt:lookup_contract(PLT, MFA)} + end, + LocalRet = + case dict:fetch(Fun, FunTab) of + {not_handled, {_Args, Ret}} -> Ret; + {_Args, Ret} -> Ret + end, + ?debug("LocalRet: ~s\n", [t_to_string(LocalRet)]), + {Fun, Sig, Contract, LocalRet}. + +forward_args(Fun, ArgTypes, #state{work = Work, fun_tab = FunTab} = State) -> + {OldArgTypes, OldOut, Fixpoint} = + case dict:find(Fun, FunTab) of + {ok, {not_handled, {OldArgTypes0, OldOut0}}} -> + {OldArgTypes0, OldOut0, false}; + {ok, {OldArgTypes0, OldOut0}} -> + {OldArgTypes0, OldOut0, + t_is_subtype(t_product(ArgTypes), t_product(OldArgTypes0))} + end, + case Fixpoint of + true -> State; + false -> + NewArgTypes = [t_sup(X, Y) || + {X, Y} <- lists:zip(ArgTypes, OldArgTypes)], + NewWork = add_work(Fun, Work), + ?debug("~w: forwarding args ~s\n", + [state__lookup_name(Fun, State), + t_to_string(t_product(NewArgTypes))]), + NewFunTab = dict:store(Fun, {NewArgTypes, OldOut}, FunTab), + State#state{work = NewWork, fun_tab = NewFunTab} + end. + +-spec state__cleanup(state()) -> state(). + +state__cleanup(#state{callgraph = Callgraph, + races = Races, + records = Records}) -> + #state{callgraph = dialyzer_callgraph:cleanup(Callgraph), + races = dialyzer_races:cleanup(Races), + records = Records}. + +-spec state__duplicate(state()) -> state(). + +state__duplicate(#state{callgraph = Callgraph} = State) -> + State#state{callgraph = dialyzer_callgraph:duplicate(Callgraph)}. + +-spec dispose_state(state()) -> ok. + +dispose_state(#state{callgraph = Callgraph}) -> + dialyzer_callgraph:dispose_race_server(Callgraph). + +-spec state__get_callgraph(state()) -> dialyzer_callgraph:callgraph(). + +state__get_callgraph(#state{callgraph = Callgraph}) -> + Callgraph. + +-spec state__get_races(state()) -> dialyzer_races:races(). + +state__get_races(#state{races = Races}) -> + Races. + +-spec state__get_records(state()) -> types(). + +state__get_records(#state{records = Records}) -> + Records. + +-spec state__put_callgraph(dialyzer_callgraph:callgraph(), state()) -> + state(). + +state__put_callgraph(Callgraph, State) -> + State#state{callgraph = Callgraph}. + +-spec state__put_races(dialyzer_races:races(), state()) -> state(). + +state__put_races(Races, State) -> + State#state{races = Races}. + +-spec state__records_only(state()) -> state(). + +state__records_only(#state{records = Records}) -> + #state{records = Records}. + +%%% =========================================================================== +%%% +%%% Races +%%% +%%% =========================================================================== + +is_race_analysis_enabled(#state{races = Races, callgraph = Callgraph}) -> + RaceDetection = dialyzer_callgraph:get_race_detection(Callgraph), + RaceAnalysis = dialyzer_races:get_race_analysis(Races), + RaceDetection andalso RaceAnalysis. + +get_race_list_and_size(#state{races = Races}) -> + dialyzer_races:get_race_list_and_size(Races). + +renew_race_code(#state{races = Races, callgraph = Callgraph, + warning_mode = WarningMode} = State) -> + case WarningMode of + true -> State; + false -> + NewCallgraph = dialyzer_callgraph:renew_race_code(Races, Callgraph), + State#state{callgraph = NewCallgraph} + end. + +renew_race_public_tables([Var], #state{races = Races, callgraph = Callgraph, + warning_mode = WarningMode} = State) -> + case WarningMode of + true -> State; + false -> + Table = dialyzer_races:get_new_table(Races), + case Table of + no_t -> State; + _Other -> + VarLabel = get_label(Var), + NewCallgraph = + dialyzer_callgraph:renew_race_public_tables(VarLabel, Callgraph), + State#state{callgraph = NewCallgraph} + end + end. + +%%% =========================================================================== +%%% +%%% Worklist +%%% +%%% =========================================================================== + +init_work(List) -> + {List, [], sets:from_list(List)}. + +get_work({[], [], _Set}) -> + none; +get_work({[H|T], Rev, Set}) -> + {H, {T, Rev, sets:del_element(H, Set)}}; +get_work({[], Rev, Set}) -> + get_work({lists:reverse(Rev), [], Set}). + +add_work(New, {List, Rev, Set} = Work) -> + case sets:is_element(New, Set) of + true -> Work; + false -> {List, [New|Rev], sets:add_element(New, Set)} + end. + +%%% =========================================================================== +%%% +%%% Utilities. +%%% +%%% =========================================================================== + +get_line([Line|_]) when is_integer(Line) -> Line; +get_line([_|Tail]) -> get_line(Tail); +get_line([]) -> -1. + +get_file([]) -> []; +get_file([{file, File}|_]) -> File; +get_file([_|Tail]) -> get_file(Tail). + +is_compiler_generated(Ann) -> + lists:member(compiler_generated, Ann) orelse (get_line(Ann) < 1). + +is_literal_record(Tree) -> + Ann = cerl:get_ann(Tree), + lists:member(record, Ann). + +-spec format_args([cerl:cerl()], [type()], state()) -> + nonempty_string(). + +format_args([], [], _State) -> + "()"; +format_args(ArgList0, TypeList, State) -> + ArgList = fold_literals(ArgList0), + "(" ++ format_args_1(ArgList, TypeList, State) ++ ")". + +format_args_1([Arg], [Type], State) -> + format_arg(Arg) ++ format_type(Type, State); +format_args_1([Arg|Args], [Type|Types], State) -> + String = + case cerl:is_literal(Arg) of + true -> format_cerl(Arg); + false -> format_arg(Arg) ++ format_type(Type, State) + end, + String ++ "," ++ format_args_1(Args, Types, State). + +format_arg(Arg) -> + Default = "", + case cerl:is_c_var(Arg) of + true -> + case cerl:var_name(Arg) of + Atom when is_atom(Atom) -> + case atom_to_list(Atom) of + "cor"++_ -> Default; + "rec"++_ -> Default; + Name -> Name ++ "::" + end; + _What -> Default + end; + false -> + Default + end. + +-spec format_type(type(), state()) -> string(). + +format_type(Type, #state{records = R}) -> + t_to_string(Type, R). + +-spec format_field_diffs(type(), state()) -> string(). + +format_field_diffs(RecConstruction, #state{records = R}) -> + erl_types:record_field_diffs_to_string(RecConstruction, R). + +-spec format_sig_args(type(), state()) -> string(). + +format_sig_args(Type, #state{opaques = Opaques} = State) -> + SigArgs = t_fun_args(Type, Opaques), + case SigArgs of + [] -> "()"; + [SArg|SArgs] -> + lists:flatten("(" ++ format_type(SArg, State) + ++ ["," ++ format_type(T, State) || T <- SArgs] ++ ")") + end. + +format_cerl(Tree) -> + cerl_prettypr:format(cerl:set_ann(Tree, []), + [{hook, dialyzer_utils:pp_hook()}, + {noann, true}, + {paper, 100000}, %% These guys strip + {ribbon, 100000} %% newlines. + ]). + +format_patterns(Pats0) -> + Pats = fold_literals(Pats0), + NewPats = map_pats(cerl:c_values(Pats)), + String = format_cerl(NewPats), + case Pats of + [PosVar] -> + case cerl:is_c_var(PosVar) andalso (cerl:var_name(PosVar) =/= '') of + true -> "variable "++String; + false -> "pattern "++String + end; + _ -> + "pattern "++String + end. + +map_pats(Pats) -> + Fun = fun(Tree) -> + case cerl:is_c_var(Tree) of + true -> + case cerl:var_name(Tree) of + Atom when is_atom(Atom) -> + case atom_to_list(Atom) of + "cor"++_ -> cerl:c_var(''); + "rec"++_ -> cerl:c_var(''); + _ -> cerl:set_ann(Tree, []) + end; + _What -> cerl:c_var('') + end; + false -> + cerl:set_ann(Tree, []) + end + end, + cerl_trees:map(Fun, Pats). + +fold_literals(TreeList) -> + [cerl:fold_literal(Tree) || Tree <- TreeList]. + +type(Tree) -> + Folded = cerl:fold_literal(Tree), + case cerl:type(Folded) of + literal -> {literal, Folded}; + Type -> Type + end. + +is_literal(Tree) -> + Folded = cerl:fold_literal(Tree), + case cerl:is_literal(Folded) of + true -> {yes, Folded}; + false -> no + end. + +parent_allows_this(FunLbl, #state{callgraph = Callgraph, plt = Plt} =State) -> + case state__is_escaping(FunLbl, State) of + false -> false; % if it isn't escaping it can't be a return value + true -> + case state__lookup_name(FunLbl, State) of + {_M, _F, _A} -> false; % if it has a name it is not a fun + _ -> + case dialyzer_callgraph:in_neighbours(FunLbl, Callgraph) of + [Parent] -> + case state__lookup_name(Parent, State) of + {_M, _F, _A} = PMFA -> + case dialyzer_plt:lookup_contract(Plt, PMFA) of + none -> false; + {value, C} -> + GenRet = dialyzer_contracts:get_contract_return(C), + case erl_types:t_is_fun(GenRet) of + false -> false; % element of structure? far-fetched... + true -> t_is_unit(t_fun_range(GenRet)) + end + end; + _ -> false % parent should have a name to have a contract + end; + _ -> false % called in other funs? far-fetched... + end + end + end. + +find_function({_, _, _} = MFA, _State) -> + MFA; +find_function(top, _State) -> + top; +find_function(FunLbl, #state{fun_homes = Homes}) -> + dict:fetch(FunLbl, Homes). + +classify_returns(Tree) -> + case find_terminals(cerl:fun_body(Tree)) of + {false, false} -> no_match; + {true, false} -> only_explicit; + {false, true} -> only_normal; + {true, true} -> both + end. + +find_terminals(Tree) -> + case cerl:type(Tree) of + apply -> {false, true}; + binary -> {false, true}; + bitstr -> {false, true}; + call -> + M0 = cerl:call_module(Tree), + F0 = cerl:call_name(Tree), + A = length(cerl:call_args(Tree)), + case {is_literal(M0), is_literal(F0)} of + {{yes, LitM}, {yes, LitF}} -> + M = cerl:concrete(LitM), + F = cerl:concrete(LitF), + case (erl_bif_types:is_known(M, F, A) + andalso t_is_none(erl_bif_types:type(M, F, A))) of + true -> {true, false}; + false -> {false, true} + end; + _ -> + %% We cannot make assumptions. Say that both are true. + {true, true} + end; + 'case' -> find_terminals_list(cerl:case_clauses(Tree)); + 'catch' -> find_terminals(cerl:catch_body(Tree)); + clause -> find_terminals(cerl:clause_body(Tree)); + cons -> {false, true}; + 'fun' -> {false, true}; + 'let' -> find_terminals(cerl:let_body(Tree)); + letrec -> find_terminals(cerl:letrec_body(Tree)); + literal -> {false, true}; + map -> {false, true}; + primop -> {false, false}; %% match_fail, etc. are not explicit exits. + 'receive' -> + Timeout = cerl:receive_timeout(Tree), + Clauses = cerl:receive_clauses(Tree), + case (cerl:is_literal(Timeout) andalso + (cerl:concrete(Timeout) =:= infinity)) of + true -> + if Clauses =:= [] -> {false, true}; %% A never ending receive. + true -> find_terminals_list(Clauses) + end; + false -> find_terminals_list([cerl:receive_action(Tree)|Clauses]) + end; + seq -> find_terminals(cerl:seq_body(Tree)); + 'try' -> + find_terminals_list([cerl:try_handler(Tree), cerl:try_body(Tree)]); + tuple -> {false, true}; + values -> {false, true}; + var -> {false, true} + end. + +find_terminals_list(List) -> + find_terminals_list(List, false, false). + +find_terminals_list([Tree|Left], Explicit1, Normal1) -> + {Explicit2, Normal2} = find_terminals(Tree), + case {Explicit1 or Explicit2, Normal1 or Normal2} of + {true, true} = Ans -> Ans; + {NewExplicit, NewNormal} -> + find_terminals_list(Left, NewExplicit, NewNormal) + end; +find_terminals_list([], Explicit, Normal) -> + {Explicit, Normal}. + +%%---------------------------------------------------------------------------- + +-ifdef(DEBUG_PP). +debug_pp(Tree, true) -> + io:put_chars(cerl_prettypr:format(Tree, [{hook, cerl_typean:pp_hook()}])), + io:nl(), + ok; +debug_pp(Tree, false) -> + io:put_chars(cerl_prettypr:format(strip_annotations(Tree))), + io:nl(), + ok. + +strip_annotations(Tree) -> + Fun = fun(T) -> + case cerl:type(T) of + var -> + cerl:set_ann(T, [{label, cerl_trees:get_label(T)}]); + 'fun' -> + cerl:set_ann(T, [{label, cerl_trees:get_label(T)}]); + _ -> + cerl:set_ann(T, []) + end + end, + cerl_trees:map(Fun, Tree). + +-else. + +debug_pp(_Tree, _UseHook) -> + ok. +-endif. diff --git a/lib/dialyzer/test/opaque_SUITE_data/src/recrec/dialyzer_races.erl b/lib/dialyzer/test/opaque_SUITE_data/src/recrec/dialyzer_races.erl new file mode 100644 index 0000000000..bb43d1dcb8 --- /dev/null +++ b/lib/dialyzer/test/opaque_SUITE_data/src/recrec/dialyzer_races.erl @@ -0,0 +1,2494 @@ +%% -*- erlang-indent-level: 2 -*- +%%----------------------------------------------------------------------- +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2008-2015. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% + +%%%---------------------------------------------------------------------- +%%% File : dialyzer_races.erl +%%% Author : Maria Christakis +%%% Description : Utility functions for race condition detection +%%% +%%% Created : 21 Nov 2008 by Maria Christakis +%%%---------------------------------------------------------------------- +-module(dialyzer_races). + +%% Race Analysis + +-export([store_race_call/5, race/1, get_race_warnings/2, format_args/4]). + +%% Record Interfaces + +-export([beg_clause_new/3, cleanup/1, end_case_new/1, end_clause_new/3, + get_curr_fun/1, get_curr_fun_args/1, get_new_table/1, + get_race_analysis/1, get_race_list/1, get_race_list_size/1, + get_race_list_and_size/1, + let_tag_new/2, new/0, put_curr_fun/3, put_fun_args/2, + put_race_analysis/2, put_race_list/3]). + +-export_type([races/0, core_vars/0]). + +-include("dialyzer.hrl"). + +%%% =========================================================================== +%%% +%%% Definitions +%%% +%%% =========================================================================== + +-define(local, 5). +-define(no_arg, no_arg). +-define(no_label, no_label). +-define(bypassed, bypassed). + +-define(WARN_WHEREIS_REGISTER, warn_whereis_register). +-define(WARN_WHEREIS_UNREGISTER, warn_whereis_unregister). +-define(WARN_ETS_LOOKUP_INSERT, warn_ets_lookup_insert). +-define(WARN_MNESIA_DIRTY_READ_WRITE, warn_mnesia_dirty_read_write). +-define(WARN_NO_WARN, warn_no_warn). + +%%% =========================================================================== +%%% +%%% Local Types +%%% +%%% =========================================================================== + +-type label_type() :: label() | [label()] | {label()} | ?no_label. +-type args() :: [label_type() | [string()]]. +-type core_vars() :: cerl:cerl() | ?no_arg | ?bypassed. +-type var_to_map1() :: core_vars() | [cerl:cerl()]. +-type var_to_map2() :: cerl:cerl() | [cerl:cerl()] | ?bypassed. +-type core_args() :: [core_vars()] | 'empty'. +-type op() :: 'bind' | 'unbind'. + +-type dep_calls() :: 'whereis' | 'ets_lookup' | 'mnesia_dirty_read'. +-type warn_calls() :: 'register' | 'unregister' | 'ets_insert' + | 'mnesia_dirty_write'. +-type call() :: 'whereis' | 'register' | 'unregister' | 'ets_new' + | 'ets_lookup' | 'ets_insert' | 'mnesia_dirty_read1' + | 'mnesia_dirty_read2' | 'mnesia_dirty_write1' + | 'mnesia_dirty_write2' | 'function_call'. +-type race_tag() :: 'whereis_register' | 'whereis_unregister' + | 'ets_lookup_insert' | 'mnesia_dirty_read_write'. + +%% The following type is similar to the raw_warning() type but has a +%% tag which is local to this module and is not propagated to outside +-type dial_race_warning() :: {race_warn_tag(), warning_info(), {atom(), [term()]}}. +-type race_warn_tag() :: ?WARN_WHEREIS_REGISTER | ?WARN_WHEREIS_UNREGISTER + | ?WARN_ETS_LOOKUP_INSERT | ?WARN_MNESIA_DIRTY_READ_WRITE. + +-record(beg_clause, {arg :: var_to_map1() | 'undefined', + pats :: var_to_map1() | 'undefined', + guard :: cerl:cerl() | 'undefined'}). +-record(end_clause, {arg :: var_to_map1() | 'undefined', + pats :: var_to_map1() | 'undefined', + guard :: cerl:cerl() | 'undefined'}). +-record(end_case, {clauses :: [#end_clause{}]}). +-record(curr_fun, {status :: 'in' | 'out' | 'undefined', + mfa :: dialyzer_callgraph:mfa_or_funlbl() + | 'undefined', + label :: label() | 'undefined', + def_vars :: [core_vars()] | 'undefined', + arg_types :: [erl_types:erl_type()] | 'undefined', + call_vars :: [core_vars()] | 'undefined', + var_map :: dict:dict() | 'undefined'}). +-record(dep_call, {call_name :: dep_calls(), + args :: args() | 'undefined', + arg_types :: [erl_types:erl_type()], + vars :: [core_vars()], + state :: dialyzer_dataflow:state(), + file_line :: file_line(), + var_map :: dict:dict() | 'undefined'}). +-record(fun_call, {caller :: dialyzer_callgraph:mfa_or_funlbl(), + callee :: dialyzer_callgraph:mfa_or_funlbl(), + arg_types :: [erl_types:erl_type()], + vars :: [core_vars()]}). +-record(let_tag, {var :: var_to_map1(), + arg :: var_to_map1()}). +-record(warn_call, {call_name :: warn_calls(), + args :: args(), + var_map :: dict:dict() | 'undefined'}). + +-type case_tags() :: 'beg_case' | #beg_clause{} | #end_clause{} | #end_case{}. +-type code() :: [#dep_call{} | #fun_call{} | #warn_call{} | + #curr_fun{} | #let_tag{} | case_tags() | race_tag()]. + +-type table_var() :: label() | ?no_label. +-type table() :: {'named', table_var(), [string()]} | 'other' | 'no_t'. + +-record(race_fun, {mfa :: mfa(), + args :: args(), + arg_types :: [erl_types:erl_type()], + vars :: [core_vars()], + file_line :: file_line(), + index :: non_neg_integer(), + fun_mfa :: dialyzer_callgraph:mfa_or_funlbl(), + fun_label :: label()}). + +-record(races, {curr_fun :: dialyzer_callgraph:mfa_or_funlbl() + | 'undefined', + curr_fun_label :: label() | 'undefined', + curr_fun_args = 'empty' :: core_args(), + new_table = 'no_t' :: table(), + race_list = [] :: code(), + race_list_size = 0 :: non_neg_integer(), + race_tags = [] :: [#race_fun{}], + %% true for fun types and warning mode + race_analysis = false :: boolean(), + race_warnings = [] :: [dial_race_warning()]}). + +%%% =========================================================================== +%%% +%%% Exported Types +%%% +%%% =========================================================================== + +-opaque races() :: #races{}. + +%%% =========================================================================== +%%% +%%% Race Analysis +%%% +%%% =========================================================================== + +-spec store_race_call(dialyzer_callgraph:mfa_or_funlbl(), + [erl_types:erl_type()], [core_vars()], + file_line(), dialyzer_dataflow:state()) -> + dialyzer_dataflow:state(). + +store_race_call(Fun, ArgTypes, Args, FileLine, State) -> + Races = dialyzer_dataflow:state__get_races(State), + CurrFun = Races#races.curr_fun, + CurrFunLabel = Races#races.curr_fun_label, + RaceTags = Races#races.race_tags, + CleanState = dialyzer_dataflow:state__records_only(State), + {NewRaceList, NewRaceListSize, NewRaceTags, NewTable} = + case CurrFun of + {_Module, module_info, A} when A =:= 0 orelse A =:= 1 -> + {[], 0, RaceTags, no_t}; + _Thing -> + RaceList = Races#races.race_list, + RaceListSize = Races#races.race_list_size, + case Fun of + {erlang, get_module_info, A} when A =:= 1 orelse A =:= 2 -> + {[], 0, RaceTags, no_t}; + {erlang, register, 2} -> + VarArgs = format_args(Args, ArgTypes, CleanState, register), + RaceFun = #race_fun{mfa = Fun, args = VarArgs, + arg_types = ArgTypes, vars = Args, + file_line = FileLine, index = RaceListSize, + fun_mfa = CurrFun, fun_label = CurrFunLabel}, + {[#warn_call{call_name = register, args = VarArgs}| + RaceList], RaceListSize + 1, [RaceFun|RaceTags], no_t}; + {erlang, unregister, 1} -> + VarArgs = format_args(Args, ArgTypes, CleanState, unregister), + RaceFun = #race_fun{mfa = Fun, args = VarArgs, + arg_types = ArgTypes, vars = Args, + file_line = FileLine, index = RaceListSize, + fun_mfa = CurrFun, fun_label = CurrFunLabel}, + {[#warn_call{call_name = unregister, args = VarArgs}| + RaceList], RaceListSize + 1, [RaceFun|RaceTags], no_t}; + {erlang, whereis, 1} -> + VarArgs = format_args(Args, ArgTypes, CleanState, whereis), + {[#dep_call{call_name = whereis, args = VarArgs, + arg_types = ArgTypes, vars = Args, + state = CleanState, file_line = FileLine}| + RaceList], RaceListSize + 1, RaceTags, no_t}; + {ets, insert, 2} -> + VarArgs = format_args(Args, ArgTypes, CleanState, ets_insert), + RaceFun = #race_fun{mfa = Fun, args = VarArgs, + arg_types = ArgTypes, vars = Args, + file_line = FileLine, index = RaceListSize, + fun_mfa = CurrFun, fun_label = CurrFunLabel}, + {[#warn_call{call_name = ets_insert, args = VarArgs}| + RaceList], RaceListSize + 1, [RaceFun|RaceTags], no_t}; + {ets, lookup, 2} -> + VarArgs = format_args(Args, ArgTypes, CleanState, ets_lookup), + {[#dep_call{call_name = ets_lookup, args = VarArgs, + arg_types = ArgTypes, vars = Args, + state = CleanState, file_line = FileLine}| + RaceList], RaceListSize + 1, RaceTags, no_t}; + {ets, new, 2} -> + VarArgs = format_args(Args, ArgTypes, CleanState, ets_new), + [VarArgs1, VarArgs2, _, Options] = VarArgs, + NewTable1 = + case lists:member("'public'", Options) of + true -> + case lists:member("'named_table'", Options) of + true -> + {named, VarArgs1, VarArgs2}; + false -> other + end; + false -> no_t + end, + {RaceList, RaceListSize, RaceTags, NewTable1}; + {mnesia, dirty_read, A} when A =:= 1 orelse A =:= 2 -> + VarArgs = + case A of + 1 -> + format_args(Args, ArgTypes, CleanState, mnesia_dirty_read1); + 2 -> + format_args(Args, ArgTypes, CleanState, mnesia_dirty_read2) + end, + {[#dep_call{call_name = mnesia_dirty_read, args = VarArgs, + arg_types = ArgTypes, vars = Args, + state = CleanState, file_line = FileLine}|RaceList], + RaceListSize + 1, RaceTags, no_t}; + {mnesia, dirty_write, A} when A =:= 1 orelse A =:= 2 -> + VarArgs = + case A of + 1 -> + format_args(Args, ArgTypes, CleanState, mnesia_dirty_write1); + 2 -> + format_args(Args, ArgTypes, CleanState, mnesia_dirty_write2) + end, + RaceFun = #race_fun{mfa = Fun, args = VarArgs, + arg_types = ArgTypes, vars = Args, + file_line = FileLine, index = RaceListSize, + fun_mfa = CurrFun, fun_label = CurrFunLabel}, + {[#warn_call{call_name = mnesia_dirty_write, + args = VarArgs}|RaceList], + RaceListSize + 1, [RaceFun|RaceTags], no_t}; + Int when is_integer(Int) -> + {[#fun_call{caller = CurrFun, callee = Int, arg_types = ArgTypes, + vars = Args}|RaceList], + RaceListSize + 1, RaceTags, no_t}; + _Other -> + Callgraph = dialyzer_dataflow:state__get_callgraph(State), + case digraph:vertex(dialyzer_callgraph:get_digraph(Callgraph), + Fun) of + {Fun, confirmed} -> + {[#fun_call{caller = CurrFun, callee = Fun, + arg_types = ArgTypes, vars = Args}|RaceList], + RaceListSize + 1, RaceTags, no_t}; + false -> + {RaceList, RaceListSize, RaceTags, no_t} + end + end + end, + state__renew_info(NewRaceList, NewRaceListSize, NewRaceTags, NewTable, State). + +-spec race(dialyzer_dataflow:state()) -> dialyzer_dataflow:state(). + +race(State) -> + Races = dialyzer_dataflow:state__get_races(State), + RaceTags = Races#races.race_tags, + RetState = + case RaceTags of + [] -> State; + [#race_fun{mfa = Fun, + args = VarArgs, arg_types = ArgTypes, + vars = Args, file_line = FileLine, + index = Index, fun_mfa = CurrFun, + fun_label = CurrFunLabel}|T] -> + Callgraph = dialyzer_dataflow:state__get_callgraph(State), + {ok, [_Args, Code]} = + dict:find(CurrFun, dialyzer_callgraph:get_race_code(Callgraph)), + RaceList = lists:reverse(Code), + RaceWarnTag = + case Fun of + {erlang, register, 2} -> ?WARN_WHEREIS_REGISTER; + {erlang, unregister, 1} -> ?WARN_WHEREIS_UNREGISTER; + {ets, insert, 2} -> ?WARN_ETS_LOOKUP_INSERT; + {mnesia, dirty_write, _A} -> ?WARN_MNESIA_DIRTY_READ_WRITE + end, + State1 = + state__renew_curr_fun(CurrFun, + state__renew_curr_fun_label(CurrFunLabel, + state__renew_race_list(lists:nthtail(length(RaceList) - Index, + RaceList), State))), + DepList = fixup_race_list(RaceWarnTag, VarArgs, State1), + {State2, RaceWarn} = + get_race_warn(Fun, Args, ArgTypes, DepList, State), + {File, Line} = FileLine, + CurrMFA = dialyzer_dataflow:state__find_function(CurrFun, State), + WarningInfo = {File, Line, CurrMFA}, + race( + state__add_race_warning( + state__renew_race_tags(T, State2), RaceWarn, RaceWarnTag, + WarningInfo)) + end, + state__renew_race_tags([], RetState). + +fixup_race_list(RaceWarnTag, WarnVarArgs, State) -> + Races = dialyzer_dataflow:state__get_races(State), + CurrFun = Races#races.curr_fun, + CurrFunLabel = Races#races.curr_fun_label, + RaceList = Races#races.race_list, + Callgraph = dialyzer_dataflow:state__get_callgraph(State), + Digraph = dialyzer_callgraph:get_digraph(Callgraph), + Calls = digraph:edges(Digraph), + RaceTag = + case RaceWarnTag of + ?WARN_WHEREIS_REGISTER -> whereis_register; + ?WARN_WHEREIS_UNREGISTER -> whereis_unregister; + ?WARN_ETS_LOOKUP_INSERT -> ets_lookup_insert; + ?WARN_MNESIA_DIRTY_READ_WRITE -> mnesia_dirty_read_write + end, + NewRaceList = [RaceTag|RaceList], + CleanState = dialyzer_dataflow:state__cleanup(State), + NewState = state__renew_race_list(NewRaceList, CleanState), + DepList1 = + fixup_race_forward_pullout(CurrFun, CurrFunLabel, Calls, + lists:reverse(NewRaceList), [], CurrFun, + WarnVarArgs, RaceWarnTag, dict:new(), + [], [], [], 2 * ?local, NewState), + Parents = fixup_race_backward(CurrFun, Calls, Calls, [], ?local), + UParents = lists:usort(Parents), + Filtered = filter_parents(UParents, UParents, Digraph), + NewParents = + case lists:member(CurrFun, Filtered) of + true -> Filtered; + false -> [CurrFun|Filtered] + end, + DepList2 = + fixup_race_list_helper(NewParents, Calls, CurrFun, WarnVarArgs, + RaceWarnTag, NewState), + dialyzer_dataflow:dispose_state(CleanState), + lists:usort(cleanup_dep_calls(DepList1 ++ DepList2)). + +fixup_race_list_helper(Parents, Calls, CurrFun, WarnVarArgs, RaceWarnTag, + State) -> + case Parents of + [] -> []; + [Head|Tail] -> + Callgraph = dialyzer_dataflow:state__get_callgraph(State), + Code = + case dict:find(Head, dialyzer_callgraph:get_race_code(Callgraph)) of + error -> []; + {ok, [_A, C]} -> C + end, + {ok, FunLabel} = dialyzer_callgraph:lookup_label(Head, Callgraph), + DepList1 = + fixup_race_forward_pullout(Head, FunLabel, Calls, Code, [], CurrFun, + WarnVarArgs, RaceWarnTag, dict:new(), + [], [], [], 2 * ?local, State), + DepList2 = + fixup_race_list_helper(Tail, Calls, CurrFun, WarnVarArgs, + RaceWarnTag, State), + DepList1 ++ DepList2 + end. + +%%% =========================================================================== +%%% +%%% Forward Analysis +%%% +%%% =========================================================================== + +fixup_race_forward_pullout(CurrFun, CurrFunLabel, Calls, Code, RaceList, + InitFun, WarnVarArgs, RaceWarnTag, RaceVarMap, + FunDefVars, FunCallVars, FunArgTypes, NestingLevel, + State) -> + TState = dialyzer_dataflow:state__duplicate(State), + {DepList, NewCurrFun, NewCurrFunLabel, NewCalls, + NewCode, NewRaceList, NewRaceVarMap, NewFunDefVars, + NewFunCallVars, NewFunArgTypes, NewNestingLevel} = + fixup_race_forward(CurrFun, CurrFunLabel, Calls, Code, RaceList, + InitFun, WarnVarArgs, RaceWarnTag, RaceVarMap, + FunDefVars, FunCallVars, FunArgTypes, NestingLevel, + cleanup_race_code(TState)), + dialyzer_dataflow:dispose_state(TState), + case NewCode of + [] -> DepList; + [#fun_call{caller = NewCurrFun, callee = Call, arg_types = FunTypes, + vars = FunArgs}|Tail] -> + Callgraph = dialyzer_dataflow:state__get_callgraph(State), + OkCall = {ok, Call}, + {Name, Label} = + case is_integer(Call) of + true -> + case dialyzer_callgraph:lookup_name(Call, Callgraph) of + error -> {OkCall, OkCall}; + N -> {N, OkCall} + end; + false -> + {OkCall, dialyzer_callgraph:lookup_label(Call, Callgraph)} + end, + {NewCurrFun1, NewCurrFunLabel1, NewCalls1, NewCode1, NewRaceList1, + NewRaceVarMap1, NewFunDefVars1, NewFunCallVars1, NewFunArgTypes1, + NewNestingLevel1} = + case Label =:= error of + true -> + {NewCurrFun, NewCurrFunLabel, NewCalls, Tail, NewRaceList, + NewRaceVarMap, NewFunDefVars, NewFunCallVars, NewFunArgTypes, + NewNestingLevel}; + false -> + {ok, Fun} = Name, + {ok, Int} = Label, + case dict:find(Fun, dialyzer_callgraph:get_race_code(Callgraph)) of + error -> + {NewCurrFun, NewCurrFunLabel, NewCalls, Tail, NewRaceList, + NewRaceVarMap, NewFunDefVars, NewFunCallVars, NewFunArgTypes, + NewNestingLevel}; + {ok, [Args, CodeB]} -> + Races = dialyzer_dataflow:state__get_races(State), + {RetCurrFun, RetCurrFunLabel, RetCalls, RetCode, + RetRaceList, RetRaceVarMap, RetFunDefVars, RetFunCallVars, + RetFunArgTypes, RetNestingLevel} = + fixup_race_forward_helper(NewCurrFun, + NewCurrFunLabel, Fun, Int, NewCalls, NewCalls, + [#curr_fun{status = out, mfa = NewCurrFun, + label = NewCurrFunLabel, + var_map = NewRaceVarMap, + def_vars = NewFunDefVars, + call_vars = NewFunCallVars, + arg_types = NewFunArgTypes}| + Tail], + NewRaceList, InitFun, FunArgs, FunTypes, RaceWarnTag, + NewRaceVarMap, NewFunDefVars, NewFunCallVars, + NewFunArgTypes, NewNestingLevel, Args, CodeB, + Races#races.race_list), + case RetCode of + [#curr_fun{}|_CodeTail] -> + {NewCurrFun, NewCurrFunLabel, RetCalls, RetCode, + RetRaceList, NewRaceVarMap, NewFunDefVars, + NewFunCallVars, NewFunArgTypes, RetNestingLevel}; + _Else -> + {RetCurrFun, RetCurrFunLabel, RetCalls, RetCode, + RetRaceList, RetRaceVarMap, RetFunDefVars, + RetFunCallVars, RetFunArgTypes, RetNestingLevel} + end + end + end, + DepList ++ + fixup_race_forward_pullout(NewCurrFun1, NewCurrFunLabel1, NewCalls1, + NewCode1, NewRaceList1, InitFun, WarnVarArgs, + RaceWarnTag, NewRaceVarMap1, NewFunDefVars1, + NewFunCallVars1, NewFunArgTypes1, + NewNestingLevel1, State) + end. + +fixup_race_forward(CurrFun, CurrFunLabel, Calls, Code, RaceList, + InitFun, WarnVarArgs, RaceWarnTag, RaceVarMap, + FunDefVars, FunCallVars, FunArgTypes, NestingLevel, + State) -> + case Code of + [] -> + {[], CurrFun, CurrFunLabel, Calls, Code, RaceList, RaceVarMap, + FunDefVars, FunCallVars, FunArgTypes, NestingLevel}; + [Head|Tail] -> + Callgraph = dialyzer_dataflow:state__get_callgraph(State), + {NewRL, DepList, NewNL, Return} = + case Head of + #dep_call{call_name = whereis} -> + case RaceWarnTag of + WarnWhereis when WarnWhereis =:= ?WARN_WHEREIS_REGISTER orelse + WarnWhereis =:= ?WARN_WHEREIS_UNREGISTER -> + {[Head#dep_call{var_map = RaceVarMap}|RaceList], + [], NestingLevel, false}; + _Other -> + {RaceList, [], NestingLevel, false} + end; + #dep_call{call_name = ets_lookup} -> + case RaceWarnTag of + ?WARN_ETS_LOOKUP_INSERT -> + {[Head#dep_call{var_map = RaceVarMap}|RaceList], + [], NestingLevel, false}; + _Other -> + {RaceList, [], NestingLevel, false} + end; + #dep_call{call_name = mnesia_dirty_read} -> + case RaceWarnTag of + ?WARN_MNESIA_DIRTY_READ_WRITE -> + {[Head#dep_call{var_map = RaceVarMap}|RaceList], + [], NestingLevel, false}; + _Other -> + {RaceList, [], NestingLevel, false} + end; + #warn_call{call_name = RegCall} when RegCall =:= register orelse + RegCall =:= unregister -> + case RaceWarnTag of + WarnWhereis when WarnWhereis =:= ?WARN_WHEREIS_REGISTER orelse + WarnWhereis =:= ?WARN_WHEREIS_UNREGISTER -> + {[Head#warn_call{var_map = RaceVarMap}|RaceList], + [], NestingLevel, false}; + _Other -> + {RaceList, [], NestingLevel, false} + end; + #warn_call{call_name = ets_insert} -> + case RaceWarnTag of + ?WARN_ETS_LOOKUP_INSERT -> + {[Head#warn_call{var_map = RaceVarMap}|RaceList], + [], NestingLevel, false}; + _Other -> + {RaceList, [], NestingLevel, false} + end; + #warn_call{call_name = mnesia_dirty_write} -> + case RaceWarnTag of + ?WARN_MNESIA_DIRTY_READ_WRITE -> + {[Head#warn_call{var_map = RaceVarMap}|RaceList], + [], NestingLevel, false}; + _Other -> + {RaceList, [], NestingLevel, false} + end; + #fun_call{caller = CurrFun, callee = InitFun} -> + {RaceList, [], NestingLevel, false}; + #fun_call{caller = CurrFun} -> + {RaceList, [], NestingLevel - 1, false}; + beg_case -> + {[Head|RaceList], [], NestingLevel, false}; + #beg_clause{} -> + {[#beg_clause{}|RaceList], [], NestingLevel, false}; + #end_clause{} -> + {[#end_clause{}|RaceList], [], NestingLevel, false}; + #end_case{} -> + {[Head|RaceList], [], NestingLevel, false}; + #let_tag{} -> + {RaceList, [], NestingLevel, false}; + #curr_fun{status = in, mfa = InitFun, + label = _InitFunLabel, var_map = _NewRVM, + def_vars = NewFDV, call_vars = NewFCV, + arg_types = _NewFAT} -> + {[#curr_fun{status = out, var_map = RaceVarMap, + def_vars = NewFDV, call_vars = NewFCV}| + RaceList], [], NestingLevel - 1, false}; + #curr_fun{status = in, def_vars = NewFDV, + call_vars = NewFCV} -> + {[#curr_fun{status = out, var_map = RaceVarMap, + def_vars = NewFDV, call_vars = NewFCV}| + RaceList], + [], NestingLevel - 1, false}; + #curr_fun{status = out} -> + {[#curr_fun{status = in, var_map = RaceVarMap}|RaceList], [], + NestingLevel + 1, false}; + RaceTag -> + PublicTables = dialyzer_callgraph:get_public_tables(Callgraph), + NamedTables = dialyzer_callgraph:get_named_tables(Callgraph), + WarnVarArgs1 = + var_type_analysis(FunDefVars, FunArgTypes, WarnVarArgs, + RaceWarnTag, RaceVarMap, + dialyzer_dataflow:state__records_only(State)), + {NewDepList, IsPublic, _Return} = + get_deplist_paths(RaceList, WarnVarArgs1, RaceWarnTag, + RaceVarMap, 0, PublicTables, NamedTables), + {NewHead, NewDepList1} = + case RaceTag of + whereis_register -> + {[#warn_call{call_name = register, args = WarnVarArgs, + var_map = RaceVarMap}], + NewDepList}; + whereis_unregister -> + {[#warn_call{call_name = unregister, args = WarnVarArgs, + var_map = RaceVarMap}], + NewDepList}; + ets_lookup_insert -> + NewWarnCall = + [#warn_call{call_name = ets_insert, args = WarnVarArgs, + var_map = RaceVarMap}], + [Tab, Names, _, _] = WarnVarArgs, + case IsPublic orelse + compare_var_list(Tab, PublicTables, RaceVarMap) + orelse + length(Names -- NamedTables) < length(Names) of + true -> + {NewWarnCall, NewDepList}; + false -> {NewWarnCall, []} + end; + mnesia_dirty_read_write -> + {[#warn_call{call_name = mnesia_dirty_write, + args = WarnVarArgs, var_map = RaceVarMap}], + NewDepList} + end, + {NewHead ++ RaceList, NewDepList1, NestingLevel, + is_last_race(RaceTag, InitFun, Tail, Callgraph)} + end, + {NewCurrFun, NewCurrFunLabel, NewCode, NewRaceList, NewRaceVarMap, + NewFunDefVars, NewFunCallVars, NewFunArgTypes, NewNestingLevel, + PullOut} = + case Head of + #fun_call{caller = CurrFun} -> + case NewNL =:= 0 of + true -> + {CurrFun, CurrFunLabel, Tail, NewRL, RaceVarMap, + FunDefVars, FunCallVars, FunArgTypes, NewNL, false}; + false -> + {CurrFun, CurrFunLabel, Code, NewRL, RaceVarMap, + FunDefVars, FunCallVars, FunArgTypes, NewNL, true} + end; + #beg_clause{arg = Arg, pats = Pats, guard = Guard} -> + {RaceVarMap1, RemoveClause} = + race_var_map_guard(Arg, Pats, Guard, RaceVarMap, bind), + case RemoveClause of + true -> + {RaceList2, + #curr_fun{mfa = CurrFun2, label = CurrFunLabel2, + var_map = RaceVarMap2, def_vars = FunDefVars2, + call_vars = FunCallVars2, arg_types = FunArgTypes2}, + Code2, NestingLevel2} = + remove_clause(NewRL, + #curr_fun{mfa = CurrFun, label = CurrFunLabel, + var_map = RaceVarMap1, + def_vars = FunDefVars, + call_vars = FunCallVars, + arg_types = FunArgTypes}, + Tail, NewNL), + {CurrFun2, CurrFunLabel2, Code2, RaceList2, + RaceVarMap2, FunDefVars2, FunCallVars2, FunArgTypes2, + NestingLevel2, false}; + false -> + {CurrFun, CurrFunLabel, Tail, NewRL, RaceVarMap1, + FunDefVars, FunCallVars, FunArgTypes, NewNL, false} + end; + #end_clause{arg = Arg, pats = Pats, guard = Guard} -> + {RaceVarMap1, _RemoveClause} = + race_var_map_guard(Arg, Pats, Guard, RaceVarMap, unbind), + {CurrFun, CurrFunLabel, Tail, NewRL, RaceVarMap1, + FunDefVars, FunCallVars, FunArgTypes, NewNL, + false}; + #end_case{clauses = Clauses} -> + RaceVarMap1 = + race_var_map_clauses(Clauses, RaceVarMap), + {CurrFun, CurrFunLabel, Tail, NewRL, RaceVarMap1, + FunDefVars, FunCallVars, FunArgTypes, NewNL, + false}; + #let_tag{var = Var, arg = Arg} -> + {CurrFun, CurrFunLabel, Tail, NewRL, + race_var_map(Var, Arg, RaceVarMap, bind), FunDefVars, + FunCallVars, FunArgTypes, NewNL, false}; + #curr_fun{mfa = CurrFun1, label = CurrFunLabel1, + var_map = RaceVarMap1, def_vars = FunDefVars1, + call_vars = FunCallVars1, arg_types = FunArgTypes1} -> + case NewNL =:= 0 of + true -> + {CurrFun, CurrFunLabel, + remove_nonlocal_functions(Tail, 1), NewRL, RaceVarMap, + FunDefVars, FunCallVars, FunArgTypes, NewNL, false}; + false -> + {CurrFun1, CurrFunLabel1, Tail, NewRL, RaceVarMap1, + FunDefVars1, FunCallVars1, FunArgTypes1, NewNL, false} + end; + _Thing -> + {CurrFun, CurrFunLabel, Tail, NewRL, RaceVarMap, + FunDefVars, FunCallVars, FunArgTypes, NewNL, false} + end, + case Return of + true -> + {DepList, NewCurrFun, NewCurrFunLabel, Calls, + [], NewRaceList, NewRaceVarMap, NewFunDefVars, + NewFunCallVars, NewFunArgTypes, NewNestingLevel}; + false -> + NewNestingLevel1 = + case NewNestingLevel =:= 0 of + true -> NewNestingLevel + 1; + false -> NewNestingLevel + end, + case PullOut of + true -> + {DepList, NewCurrFun, NewCurrFunLabel, Calls, + NewCode, NewRaceList, NewRaceVarMap, NewFunDefVars, + NewFunCallVars, NewFunArgTypes, NewNestingLevel1}; + false -> + {RetDepList, NewCurrFun1, NewCurrFunLabel1, NewCalls1, + NewCode1, NewRaceList1, NewRaceVarMap1, NewFunDefVars1, + NewFunCallVars1, NewFunArgTypes1, NewNestingLevel2} = + fixup_race_forward(NewCurrFun, NewCurrFunLabel, Calls, + NewCode, NewRaceList, InitFun, WarnVarArgs, + RaceWarnTag, NewRaceVarMap, NewFunDefVars, + NewFunCallVars, NewFunArgTypes, + NewNestingLevel1, State), + {DepList ++ RetDepList, NewCurrFun1, NewCurrFunLabel1, + NewCalls1, NewCode1, NewRaceList1, NewRaceVarMap1, + NewFunDefVars1, NewFunCallVars1, NewFunArgTypes1, + NewNestingLevel2} + end + end + end. + +get_deplist_paths(RaceList, WarnVarArgs, RaceWarnTag, RaceVarMap, CurrLevel, + PublicTables, NamedTables) -> + case RaceList of + [] -> {[], false, true}; + [Head|Tail] -> + case Head of + #end_case{} -> + {RaceList1, DepList1, IsPublic1, Continue1} = + handle_case(Tail, WarnVarArgs, RaceWarnTag, RaceVarMap, CurrLevel, + PublicTables, NamedTables), + case Continue1 of + true -> + {DepList2, IsPublic2, Continue2} = + get_deplist_paths(RaceList1, WarnVarArgs, RaceWarnTag, + RaceVarMap, CurrLevel, PublicTables, + NamedTables), + {DepList1 ++ DepList2, IsPublic1 orelse IsPublic2, Continue2}; + false -> {DepList1, IsPublic1, false} + end; + #beg_clause{} -> + get_deplist_paths(fixup_before_case_path(Tail), WarnVarArgs, + RaceWarnTag, RaceVarMap, CurrLevel, PublicTables, + NamedTables); + #curr_fun{status = in, var_map = RaceVarMap1} -> + {DepList, IsPublic, Continue} = + get_deplist_paths(Tail, WarnVarArgs, RaceWarnTag, RaceVarMap, + CurrLevel + 1, PublicTables, NamedTables), + IsPublic1 = + case RaceWarnTag of + ?WARN_ETS_LOOKUP_INSERT -> + [Tabs, Names, _, _] = WarnVarArgs, + IsPublic orelse + lists:any( + fun (T) -> + compare_var_list(T, PublicTables, RaceVarMap1) + end, Tabs) + orelse + length(Names -- NamedTables) < length(Names); + _ -> true + end, + {DepList, IsPublic1, Continue}; + #curr_fun{status = out, var_map = RaceVarMap1, def_vars = FunDefVars, + call_vars = FunCallVars} -> + WarnVarArgs1 = + var_analysis([format_arg(DefVar) || DefVar <- FunDefVars], + [format_arg(CallVar) || CallVar <- FunCallVars], + WarnVarArgs, RaceWarnTag), + {WarnVarArgs2, Stop} = + case RaceWarnTag of + ?WARN_WHEREIS_REGISTER -> + [WVA1, WVA2, WVA3, WVA4] = WarnVarArgs1, + Vars = + lists:flatten( + [find_all_bound_vars(V, RaceVarMap1) || V <- WVA1]), + case {Vars, CurrLevel} of + {[], 0} -> + {WarnVarArgs, true}; + {[], _} -> + {WarnVarArgs, false}; + _ -> + {[Vars, WVA2, WVA3, WVA4], false} + end; + ?WARN_WHEREIS_UNREGISTER -> + [WVA1, WVA2] = WarnVarArgs1, + Vars = + lists:flatten( + [find_all_bound_vars(V, RaceVarMap1) || V <- WVA1]), + case {Vars, CurrLevel} of + {[], 0} -> + {WarnVarArgs, true}; + {[], _} -> + {WarnVarArgs, false}; + _ -> + {[Vars, WVA2], false} + end; + ?WARN_ETS_LOOKUP_INSERT -> + [WVA1, WVA2, WVA3, WVA4] = WarnVarArgs1, + Vars1 = + lists:flatten( + [find_all_bound_vars(V1, RaceVarMap1) || V1 <- WVA1]), + Vars2 = + lists:flatten( + [find_all_bound_vars(V2, RaceVarMap1) || V2 <- WVA3]), + case {Vars1, Vars2, CurrLevel} of + {[], _, 0} -> + {WarnVarArgs, true}; + {[], _, _} -> + {WarnVarArgs, false}; + {_, [], 0} -> + {WarnVarArgs, true}; + {_, [], _} -> + {WarnVarArgs, false}; + _ -> + {[Vars1, WVA2, Vars2, WVA4], false} + end; + ?WARN_MNESIA_DIRTY_READ_WRITE -> + [WVA1, WVA2|T] = WarnVarArgs1, + Vars = + lists:flatten( + [find_all_bound_vars(V, RaceVarMap1) || V <- WVA1]), + case {Vars, CurrLevel} of + {[], 0} -> + {WarnVarArgs, true}; + {[], _} -> + {WarnVarArgs, false}; + _ -> + {[Vars, WVA2|T], false} + end + end, + case Stop of + true -> {[], false, false}; + false -> + CurrLevel1 = + case CurrLevel of + 0 -> CurrLevel; + _ -> CurrLevel - 1 + end, + get_deplist_paths(Tail, WarnVarArgs2, RaceWarnTag, RaceVarMap1, + CurrLevel1, PublicTables, NamedTables) + end; + #warn_call{call_name = RegCall, args = WarnVarArgs1, + var_map = RaceVarMap1} when RegCall =:= register orelse + RegCall =:= unregister -> + case compare_first_arg(WarnVarArgs, WarnVarArgs1, RaceVarMap1) of + true -> {[], false, false}; + NewWarnVarArgs -> + get_deplist_paths(Tail, NewWarnVarArgs, RaceWarnTag, RaceVarMap, + CurrLevel, PublicTables, NamedTables) + end; + #warn_call{call_name = ets_insert, args = WarnVarArgs1, + var_map = RaceVarMap1} -> + case compare_ets_insert(WarnVarArgs, WarnVarArgs1, RaceVarMap1) of + true -> {[], false, false}; + NewWarnVarArgs -> + get_deplist_paths(Tail, NewWarnVarArgs, RaceWarnTag, RaceVarMap, + CurrLevel, PublicTables, NamedTables) + end; + #warn_call{call_name = mnesia_dirty_write, args = WarnVarArgs1, + var_map = RaceVarMap1} -> + case compare_first_arg(WarnVarArgs, WarnVarArgs1, RaceVarMap1) of + true -> {[], false, false}; + NewWarnVarArgs -> + get_deplist_paths(Tail, NewWarnVarArgs, RaceWarnTag, RaceVarMap, + CurrLevel, PublicTables, NamedTables) + end; + #dep_call{var_map = RaceVarMap1} -> + {DepList, IsPublic, Continue} = + get_deplist_paths(Tail, WarnVarArgs, RaceWarnTag, RaceVarMap, + CurrLevel, PublicTables, NamedTables), + {refine_race(Head, WarnVarArgs, RaceWarnTag, DepList, RaceVarMap1), + IsPublic, Continue} + end + end. + +handle_case(RaceList, WarnVarArgs, RaceWarnTag, RaceVarMap, CurrLevel, + PublicTables, NamedTables) -> + case RaceList of + [] -> {[], [], false, true}; + [Head|Tail] -> + case Head of + #end_clause{} -> + {RestRaceList, DepList1, IsPublic1, Continue1} = + do_clause(Tail, WarnVarArgs, RaceWarnTag, RaceVarMap, CurrLevel, + PublicTables, NamedTables), + {RetRaceList, DepList2, IsPublic2, Continue2} = + handle_case(RestRaceList, WarnVarArgs, RaceWarnTag, RaceVarMap, + CurrLevel, PublicTables, NamedTables), + {RetRaceList, DepList1 ++ DepList2, IsPublic1 orelse IsPublic2, + Continue1 orelse Continue2}; + beg_case -> {Tail, [], false, false} + end + end. + +do_clause(RaceList, WarnVarArgs, RaceWarnTag, RaceVarMap, CurrLevel, + PublicTables, NamedTables) -> + {DepList, IsPublic, Continue} = + get_deplist_paths(fixup_case_path(RaceList, 0), WarnVarArgs, + RaceWarnTag, RaceVarMap, CurrLevel, + PublicTables, NamedTables), + {fixup_case_rest_paths(RaceList, 0), DepList, IsPublic, Continue}. + +fixup_case_path(RaceList, NestingLevel) -> + case RaceList of + [] -> []; + [Head|Tail] -> + {NewNestingLevel, Return} = + case Head of + beg_case -> {NestingLevel - 1, false}; + #end_case{} -> {NestingLevel + 1, false}; + #beg_clause{} -> + case NestingLevel =:= 0 of + true -> {NestingLevel, true}; + false -> {NestingLevel, false} + end; + _Other -> {NestingLevel, false} + end, + case Return of + true -> []; + false -> [Head|fixup_case_path(Tail, NewNestingLevel)] + end + end. + +%% Gets the race list before a case clause. +fixup_before_case_path(RaceList) -> + case RaceList of + [] -> []; + [Head|Tail] -> + case Head of + #end_clause{} -> + fixup_before_case_path(fixup_case_rest_paths(Tail, 0)); + beg_case -> Tail + end + end. + +fixup_case_rest_paths(RaceList, NestingLevel) -> + case RaceList of + [] -> []; + [Head|Tail] -> + {NewNestingLevel, Return} = + case Head of + beg_case -> {NestingLevel - 1, false}; + #end_case{} -> {NestingLevel + 1, false}; + #beg_clause{} -> + case NestingLevel =:= 0 of + true -> {NestingLevel, true}; + false -> {NestingLevel, false} + end; + _Other -> {NestingLevel, false} + end, + case Return of + true -> Tail; + false -> fixup_case_rest_paths(Tail, NewNestingLevel) + end + end. + +fixup_race_forward_helper(CurrFun, CurrFunLabel, Fun, FunLabel, + Calls, CallsToAnalyze, Code, RaceList, + InitFun, NewFunArgs, NewFunTypes, + RaceWarnTag, RaceVarMap, FunDefVars, + FunCallVars, FunArgTypes, NestingLevel, + Args, CodeB, StateRaceList) -> + case Calls of + [] -> + {NewRaceList, + #curr_fun{mfa = NewCurrFun, label = NewCurrFunLabel, + var_map = NewRaceVarMap, def_vars = NewFunDefVars, + call_vars = NewFunCallVars, arg_types = NewFunArgTypes}, + NewCode, NewNestingLevel} = + remove_clause(RaceList, + #curr_fun{mfa = CurrFun, label = CurrFunLabel, var_map = RaceVarMap, + def_vars = FunDefVars, call_vars = FunCallVars, + arg_types = FunArgTypes}, + Code, NestingLevel), + {NewCurrFun, NewCurrFunLabel, CallsToAnalyze, NewCode, NewRaceList, + NewRaceVarMap, NewFunDefVars, NewFunCallVars, NewFunArgTypes, + NewNestingLevel}; + [Head|Tail] -> + case Head of + {InitFun, InitFun} when CurrFun =:= InitFun, Fun =:= InitFun -> + NewCallsToAnalyze = lists:delete(Head, CallsToAnalyze), + NewRaceVarMap = + race_var_map(Args, NewFunArgs, RaceVarMap, bind), + RetC = + fixup_all_calls(InitFun, InitFun, FunLabel, Args, + CodeB ++ + [#curr_fun{status = out, mfa = InitFun, + label = CurrFunLabel, var_map = RaceVarMap, + def_vars = FunDefVars, call_vars = FunCallVars, + arg_types = FunArgTypes}], + Code, RaceVarMap), + NewCode = + fixup_all_calls(InitFun, InitFun, FunLabel, Args, + CodeB ++ + [#curr_fun{status = out, mfa = InitFun, + label = CurrFunLabel, var_map = NewRaceVarMap, + def_vars = Args, call_vars = NewFunArgs, + arg_types = NewFunTypes}], + [#curr_fun{status = in, mfa = Fun, + label = FunLabel, var_map = NewRaceVarMap, + def_vars = Args, call_vars = NewFunArgs, + arg_types = NewFunTypes}| + lists:reverse(StateRaceList)] ++ + RetC, NewRaceVarMap), + {InitFun, FunLabel, NewCallsToAnalyze, NewCode, RaceList, + NewRaceVarMap, Args, NewFunArgs, NewFunTypes, NestingLevel}; + {CurrFun, Fun} -> + NewCallsToAnalyze = lists:delete(Head, CallsToAnalyze), + NewRaceVarMap = race_var_map(Args, NewFunArgs, RaceVarMap, bind), + RetC = + case Fun of + InitFun -> + fixup_all_calls(CurrFun, Fun, FunLabel, Args, + lists:reverse(StateRaceList) ++ + [#curr_fun{status = out, mfa = CurrFun, + label = CurrFunLabel, var_map = RaceVarMap, + def_vars = FunDefVars, call_vars = FunCallVars, + arg_types = FunArgTypes}], + Code, RaceVarMap); + _Other1 -> + fixup_all_calls(CurrFun, Fun, FunLabel, Args, + CodeB ++ + [#curr_fun{status = out, mfa = CurrFun, + label = CurrFunLabel, var_map = RaceVarMap, + def_vars = FunDefVars, call_vars = FunCallVars, + arg_types = FunArgTypes}], + Code, RaceVarMap) + end, + NewCode = + case Fun of + InitFun -> + [#curr_fun{status = in, mfa = Fun, + label = FunLabel, var_map = NewRaceVarMap, + def_vars = Args, call_vars = NewFunArgs, + arg_types = NewFunTypes}| + lists:reverse(StateRaceList)] ++ RetC; + _ -> + [#curr_fun{status = in, mfa = Fun, + label = FunLabel, var_map = NewRaceVarMap, + def_vars = Args, call_vars = NewFunArgs, + arg_types = NewFunTypes}|CodeB] ++ + RetC + end, + {Fun, FunLabel, NewCallsToAnalyze, NewCode, RaceList, NewRaceVarMap, + Args, NewFunArgs, NewFunTypes, NestingLevel}; + {_TupleA, _TupleB} -> + fixup_race_forward_helper(CurrFun, CurrFunLabel, Fun, FunLabel, + Tail, CallsToAnalyze, Code, RaceList, InitFun, NewFunArgs, + NewFunTypes, RaceWarnTag, RaceVarMap, FunDefVars, FunCallVars, + FunArgTypes, NestingLevel, Args, CodeB, StateRaceList) + end + end. + +%%% =========================================================================== +%%% +%%% Backward Analysis +%%% +%%% =========================================================================== + +fixup_race_backward(CurrFun, Calls, CallsToAnalyze, Parents, Height) -> + case Height =:= 0 of + true -> Parents; + false -> + case Calls of + [] -> + case is_integer(CurrFun) orelse lists:member(CurrFun, Parents) of + true -> Parents; + false -> [CurrFun|Parents] + end; + [Head|Tail] -> + {Parent, TupleB} = Head, + case TupleB =:= CurrFun of + true -> % more paths are needed + NewCallsToAnalyze = lists:delete(Head, CallsToAnalyze), + NewParents = + fixup_race_backward(Parent, NewCallsToAnalyze, + NewCallsToAnalyze, Parents, Height - 1), + fixup_race_backward(CurrFun, Tail, NewCallsToAnalyze, NewParents, + Height); + false -> + fixup_race_backward(CurrFun, Tail, CallsToAnalyze, Parents, + Height) + end + end + end. + +%%% =========================================================================== +%%% +%%% Utilities +%%% +%%% =========================================================================== + +are_bound_labels(Label1, Label2, RaceVarMap) -> + case dict:find(Label1, RaceVarMap) of + error -> false; + {ok, Labels} -> + lists:member(Label2, Labels) orelse + are_bound_labels_helper(Labels, Label1, Label2, RaceVarMap) + end. + +are_bound_labels_helper(Labels, OldLabel, CompLabel, RaceVarMap) -> + case dict:size(RaceVarMap) of + 0 -> false; + _ -> + case Labels of + [] -> false; + [Head|Tail] -> + NewRaceVarMap = dict:erase(OldLabel, RaceVarMap), + are_bound_labels(Head, CompLabel, NewRaceVarMap) orelse + are_bound_labels_helper(Tail, Head, CompLabel, NewRaceVarMap) + end + end. + +are_bound_vars(Vars1, Vars2, RaceVarMap) -> + case is_list(Vars1) andalso is_list(Vars2) of + true -> + case Vars1 of + [] -> false; + [AHead|ATail] -> + case Vars2 of + [] -> false; + [PHead|PTail] -> + are_bound_vars(AHead, PHead, RaceVarMap) andalso + are_bound_vars(ATail, PTail, RaceVarMap) + end + end; + false -> + {NewVars1, NewVars2, IsList} = + case is_list(Vars1) of + true -> + case Vars1 of + [Var1] -> {Var1, Vars2, true}; + _Thing -> {Vars1, Vars2, false} + end; + false -> + case is_list(Vars2) of + true -> + case Vars2 of + [Var2] -> {Vars1, Var2, true}; + _Thing -> {Vars1, Vars2, false} + end; + false -> {Vars1, Vars2, true} + end + end, + case IsList of + true -> + case cerl:type(NewVars1) of + var -> + case cerl:type(NewVars2) of + var -> + ALabel = cerl_trees:get_label(NewVars1), + PLabel = cerl_trees:get_label(NewVars2), + are_bound_labels(ALabel, PLabel, RaceVarMap) orelse + are_bound_labels(PLabel, ALabel, RaceVarMap); + alias -> + are_bound_vars(NewVars1, cerl:alias_var(NewVars2), + RaceVarMap); + values -> + are_bound_vars(NewVars1, cerl:values_es(NewVars2), + RaceVarMap); + _Other -> false + end; + tuple -> + case cerl:type(NewVars2) of + tuple -> + are_bound_vars(cerl:tuple_es(NewVars1), + cerl:tuple_es(NewVars2), RaceVarMap); + alias -> + are_bound_vars(NewVars1, cerl:alias_var(NewVars2), + RaceVarMap); + values -> + are_bound_vars(NewVars1, cerl:values_es(NewVars2), + RaceVarMap); + _Other -> false + end; + cons -> + case cerl:type(NewVars2) of + cons -> + are_bound_vars(cerl:cons_hd(NewVars1), + cerl:cons_hd(NewVars2), RaceVarMap) + andalso + are_bound_vars(cerl:cons_tl(NewVars1), + cerl:cons_tl(NewVars2), RaceVarMap); + alias -> + are_bound_vars(NewVars1, cerl:alias_var(NewVars2), + RaceVarMap); + values -> + are_bound_vars(NewVars1, cerl:values_es(NewVars2), + RaceVarMap); + _Other -> false + end; + alias -> + case cerl:type(NewVars2) of + alias -> + are_bound_vars(cerl:alias_var(NewVars1), + cerl:alias_var(NewVars2), RaceVarMap); + _Other -> + are_bound_vars(cerl:alias_var(NewVars1), + NewVars2, RaceVarMap) + end; + values -> + case cerl:type(NewVars2) of + values -> + are_bound_vars(cerl:values_es(NewVars1), + cerl:values_es(NewVars2), RaceVarMap); + _Other -> + are_bound_vars(cerl:values_es(NewVars1), + NewVars2, RaceVarMap) + end; + _Other -> false + end; + false -> false + end + end. + +callgraph__renew_tables(Table, Callgraph) -> + case Table of + {named, NameLabel, Names} -> + PTablesToAdd = + case NameLabel of + ?no_label -> []; + _Other -> [NameLabel] + end, + NamesToAdd = filter_named_tables(Names), + PTables = dialyzer_callgraph:get_public_tables(Callgraph), + NTables = dialyzer_callgraph:get_named_tables(Callgraph), + dialyzer_callgraph:put_public_tables( + lists:usort(PTablesToAdd ++ PTables), + dialyzer_callgraph:put_named_tables( + NamesToAdd ++ NTables, Callgraph)); + _Other -> + Callgraph + end. + +cleanup_clause_code(#curr_fun{mfa = CurrFun} = CurrTuple, Code, + NestingLevel, LocalNestingLevel) -> + case Code of + [] -> {CurrTuple, []}; + [Head|Tail] -> + {NewLocalNestingLevel, NewNestingLevel, NewCurrTuple, Return} = + case Head of + beg_case -> + {LocalNestingLevel, NestingLevel + 1, CurrTuple, false}; + #end_case{} -> + {LocalNestingLevel, NestingLevel - 1, CurrTuple, false}; + #end_clause{} -> + case NestingLevel =:= 0 of + true -> + {LocalNestingLevel, NestingLevel, CurrTuple, true}; + false -> + {LocalNestingLevel, NestingLevel, CurrTuple, false} + end; + #fun_call{caller = CurrFun} -> + {LocalNestingLevel - 1, NestingLevel, CurrTuple, false}; + #curr_fun{status = in} -> + {LocalNestingLevel - 1, NestingLevel, Head, false}; + #curr_fun{status = out} -> + {LocalNestingLevel + 1, NestingLevel, Head, false}; + Other when Other =/= #fun_call{} -> + {LocalNestingLevel, NestingLevel, CurrTuple, false} + end, + case Return of + true -> {NewCurrTuple, Tail}; + false -> + cleanup_clause_code(NewCurrTuple, Tail, NewNestingLevel, + NewLocalNestingLevel) + end + end. + +cleanup_dep_calls(DepList) -> + case DepList of + [] -> []; + [#dep_call{call_name = CallName, arg_types = ArgTypes, + vars = Vars, state = State, file_line = FileLine}|T] -> + [#dep_call{call_name = CallName, arg_types = ArgTypes, + vars = Vars, state = State, file_line = FileLine}| + cleanup_dep_calls(T)] + end. + +cleanup_race_code(State) -> + Callgraph = dialyzer_dataflow:state__get_callgraph(State), + dialyzer_dataflow:state__put_callgraph( + dialyzer_callgraph:race_code_new(Callgraph), State). + +filter_named_tables(NamesList) -> + case NamesList of + [] -> []; + [Head|Tail] -> + NewHead = + case string:rstr(Head, "()") of + 0 -> [Head]; + _Other -> [] + end, + NewHead ++ filter_named_tables(Tail) + end. + +filter_parents(Parents, NewParents, Digraph) -> + case Parents of + [] -> NewParents; + [Head|Tail] -> + NewParents1 = filter_parents_helper1(Head, Tail, NewParents, Digraph), + filter_parents(Tail, NewParents1, Digraph) + end. + +filter_parents_helper1(First, Rest, NewParents, Digraph) -> + case Rest of + [] -> NewParents; + [Head|Tail] -> + NewParents1 = filter_parents_helper2(First, Head, NewParents, Digraph), + filter_parents_helper1(First, Tail, NewParents1, Digraph) + end. + +filter_parents_helper2(Parent1, Parent2, NewParents, Digraph) -> + case digraph:get_path(Digraph, Parent1, Parent2) of + false -> + case digraph:get_path(Digraph, Parent2, Parent1) of + false -> NewParents; + _Vertices -> NewParents -- [Parent1] + end; + _Vertices -> NewParents -- [Parent2] + end. + +find_all_bound_vars(Label, RaceVarMap) -> + case dict:find(Label, RaceVarMap) of + error -> [Label]; + {ok, Labels} -> + lists:usort(Labels ++ + find_all_bound_vars_helper(Labels, Label, RaceVarMap)) + end. + +find_all_bound_vars_helper(Labels, Label, RaceVarMap) -> + case dict:size(RaceVarMap) of + 0 -> []; + _ -> + case Labels of + [] -> []; + [Head|Tail] -> + NewRaceVarMap = dict:erase(Label, RaceVarMap), + find_all_bound_vars(Head, NewRaceVarMap) ++ + find_all_bound_vars_helper(Tail, Head, NewRaceVarMap) + end + end. + +fixup_all_calls(CurrFun, NextFun, NextFunLabel, Args, CodeToReplace, + Code, RaceVarMap) -> + case Code of + [] -> []; + [Head|Tail] -> + NewCode = + case Head of + #fun_call{caller = CurrFun, callee = Callee, + arg_types = FunArgTypes, vars = FunArgs} + when Callee =:= NextFun orelse Callee =:= NextFunLabel -> + RaceVarMap1 = race_var_map(Args, FunArgs, RaceVarMap, bind), + [#curr_fun{status = in, mfa = NextFun, label = NextFunLabel, + var_map = RaceVarMap1, def_vars = Args, + call_vars = FunArgs, arg_types = FunArgTypes}| + CodeToReplace]; + _Other -> [Head] + end, + RetCode = + fixup_all_calls(CurrFun, NextFun, NextFunLabel, Args, CodeToReplace, + Tail, RaceVarMap), + NewCode ++ RetCode + end. + +is_last_race(RaceTag, InitFun, Code, Callgraph) -> + case Code of + [] -> true; + [Head|Tail] -> + case Head of + RaceTag -> false; + #fun_call{callee = Fun} -> + FunName = + case is_integer(Fun) of + true -> + case dialyzer_callgraph:lookup_name(Fun, Callgraph) of + error -> Fun; + {ok, Name} -> Name + end; + false -> Fun + end, + Digraph = dialyzer_callgraph:get_digraph(Callgraph), + case FunName =:= InitFun orelse + digraph:get_path(Digraph, FunName, InitFun) of + false -> is_last_race(RaceTag, InitFun, Tail, Callgraph); + _Vertices -> false + end; + _Other -> is_last_race(RaceTag, InitFun, Tail, Callgraph) + end + end. + +lists_key_member(Member, List, N) when is_integer(Member) -> + case List of + [] -> 0; + [Head|Tail] -> + NewN = N + 1, + case Head of + Member -> NewN; + _Other -> lists_key_member(Member, Tail, NewN) + end + end; +lists_key_member(_M, _L, _N) -> + 0. + +lists_key_member_lists(MemberList, List) -> + case MemberList of + [] -> 0; + [Head|Tail] -> + case lists_key_member(Head, List, 0) of + 0 -> lists_key_member_lists(Tail, List); + Other -> Other + end + end. + +lists_key_members_lists(MemberList, List) -> + case MemberList of + [] -> []; + [Head|Tail] -> + lists:usort( + lists_key_members_lists_helper(Head, List, 1) ++ + lists_key_members_lists(Tail, List)) + end. + +lists_key_members_lists_helper(Elem, List, N) when is_integer(Elem) -> + case List of + [] -> []; + [Head|Tail] -> + NewHead = + case Head =:= Elem of + true -> [N]; + false -> [] + end, + NewHead ++ lists_key_members_lists_helper(Elem, Tail, N + 1) + end; +lists_key_members_lists_helper(_Elem, _List, _N) -> + [0]. + +lists_key_replace(N, List, NewMember) -> + {Before, [_|After]} = lists:split(N - 1, List), + Before ++ [NewMember|After]. + +lists_get(0, _List) -> ?no_label; +lists_get(N, List) -> lists:nth(N, List). + +refine_race(RaceCall, WarnVarArgs, RaceWarnTag, DependencyList, RaceVarMap) -> + case RaceWarnTag of + WarnWhereis when WarnWhereis =:= ?WARN_WHEREIS_REGISTER orelse + WarnWhereis =:= ?WARN_WHEREIS_UNREGISTER -> + case RaceCall of + #dep_call{call_name = ets_lookup} -> + DependencyList; + #dep_call{call_name = mnesia_dirty_read} -> + DependencyList; + #dep_call{call_name = whereis, args = VarArgs} -> + refine_race_helper(RaceCall, VarArgs, WarnVarArgs, RaceWarnTag, + DependencyList, RaceVarMap) + end; + ?WARN_ETS_LOOKUP_INSERT -> + case RaceCall of + #dep_call{call_name = whereis} -> + DependencyList; + #dep_call{call_name = mnesia_dirty_read} -> + DependencyList; + #dep_call{call_name = ets_lookup, args = VarArgs} -> + refine_race_helper(RaceCall, VarArgs, WarnVarArgs, RaceWarnTag, + DependencyList, RaceVarMap) + end; + ?WARN_MNESIA_DIRTY_READ_WRITE -> + case RaceCall of + #dep_call{call_name = whereis} -> + DependencyList; + #dep_call{call_name = ets_lookup} -> + DependencyList; + #dep_call{call_name = mnesia_dirty_read, args = VarArgs} -> + refine_race_helper(RaceCall, VarArgs, WarnVarArgs, RaceWarnTag, + DependencyList, RaceVarMap) + end + end. + +refine_race_helper(RaceCall, VarArgs, WarnVarArgs, RaceWarnTag, DependencyList, + RaceVarMap) -> + case compare_types(VarArgs, WarnVarArgs, RaceWarnTag, RaceVarMap) of + true -> [RaceCall|DependencyList]; + false -> DependencyList + end. + +remove_clause(RaceList, CurrTuple, Code, NestingLevel) -> + NewRaceList = fixup_case_rest_paths(RaceList, 0), + {NewCurrTuple, NewCode} = + cleanup_clause_code(CurrTuple, Code, 0, NestingLevel), + ReturnTuple = {NewRaceList, NewCurrTuple, NewCode, NestingLevel}, + case NewRaceList of + [beg_case|RTail] -> + case NewCode of + [#end_case{}|CTail] -> + remove_clause(RTail, NewCurrTuple, CTail, NestingLevel); + _Other -> ReturnTuple + end; + _Else -> ReturnTuple + end. + +remove_nonlocal_functions(Code, NestingLevel) -> + case Code of + [] -> []; + [H|T] -> + NewNL = + case H of + #curr_fun{status = in} -> + NestingLevel + 1; + #curr_fun{status = out} -> + NestingLevel - 1; + _Other -> + NestingLevel + end, + case NewNL =:= 0 of + true -> T; + false -> remove_nonlocal_functions(T, NewNL) + end + end. + +renew_curr_fun(CurrFun, Races) -> + Races#races{curr_fun = CurrFun}. + +renew_curr_fun_label(CurrFunLabel, Races) -> + Races#races{curr_fun_label = CurrFunLabel}. + +renew_race_list(RaceList, Races) -> + Races#races{race_list = RaceList}. + +renew_race_list_size(RaceListSize, Races) -> + Races#races{race_list_size = RaceListSize}. + +renew_race_tags(RaceTags, Races) -> + Races#races{race_tags = RaceTags}. + +renew_table(Table, Races) -> + Races#races{new_table = Table}. + +state__renew_curr_fun(CurrFun, State) -> + Races = dialyzer_dataflow:state__get_races(State), + dialyzer_dataflow:state__put_races(renew_curr_fun(CurrFun, Races), State). + +state__renew_curr_fun_label(CurrFunLabel, State) -> + Races = dialyzer_dataflow:state__get_races(State), + dialyzer_dataflow:state__put_races( + renew_curr_fun_label(CurrFunLabel, Races), State). + +state__renew_race_list(RaceList, State) -> + Races = dialyzer_dataflow:state__get_races(State), + dialyzer_dataflow:state__put_races(renew_race_list(RaceList, Races), State). + +state__renew_race_tags(RaceTags, State) -> + Races = dialyzer_dataflow:state__get_races(State), + dialyzer_dataflow:state__put_races(renew_race_tags(RaceTags, Races), State). + +state__renew_info(RaceList, RaceListSize, RaceTags, Table, State) -> + Callgraph = dialyzer_dataflow:state__get_callgraph(State), + Races = dialyzer_dataflow:state__get_races(State), + dialyzer_dataflow:state__put_callgraph( + callgraph__renew_tables(Table, Callgraph), + dialyzer_dataflow:state__put_races( + renew_table(Table, + renew_race_list(RaceList, + renew_race_list_size(RaceListSize, + renew_race_tags(RaceTags, Races)))), State)). + +%%% =========================================================================== +%%% +%%% Variable and Type Utilities +%%% +%%% =========================================================================== + +any_args(StrList) -> + case StrList of + [] -> false; + [Head|Tail] -> + case string:rstr(Head, "()") of + 0 -> any_args(Tail); + _Other -> true + end + end. + +-spec bind_dict_vars(label(), label(), dict:dict()) -> dict:dict(). + +bind_dict_vars(Key, Label, RaceVarMap) -> + case Key =:= Label of + true -> RaceVarMap; + false -> + case dict:find(Key, RaceVarMap) of + error -> dict:store(Key, [Label], RaceVarMap); + {ok, Labels} -> + case lists:member(Label, Labels) of + true -> RaceVarMap; + false -> dict:store(Key, [Label|Labels], RaceVarMap) + end + end + end. + +bind_dict_vars_list(Key, Labels, RaceVarMap) -> + case Labels of + [] -> RaceVarMap; + [Head|Tail] -> + bind_dict_vars_list(Key, Tail, bind_dict_vars(Key, Head, RaceVarMap)) + end. + +compare_ets_insert(OldWarnVarArgs, NewWarnVarArgs, RaceVarMap) -> + [Old1, Old2, Old3, Old4] = OldWarnVarArgs, + [New1, New2, New3, New4] = NewWarnVarArgs, + Bool = + case any_args(Old2) of + true -> compare_var_list(New1, Old1, RaceVarMap); + false -> + case any_args(New2) of + true -> compare_var_list(New1, Old1, RaceVarMap); + false -> compare_var_list(New1, Old1, RaceVarMap) + orelse (Old2 =:= New2) + end + end, + case Bool of + true -> + case any_args(Old4) of + true -> + case compare_list_vars(Old3, ets_list_args(New3), [], RaceVarMap) of + true -> true; + Args3 -> lists_key_replace(3, OldWarnVarArgs, Args3) + end; + false -> + case any_args(New4) of + true -> + case compare_list_vars(Old3, ets_list_args(New3), [], + RaceVarMap) of + true -> true; + Args3 -> lists_key_replace(3, OldWarnVarArgs, Args3) + end; + false -> + case compare_list_vars(Old3, ets_list_args(New3), [], + RaceVarMap) of + true -> true; + Args3 -> + lists_key_replace(4, + lists_key_replace(3, OldWarnVarArgs, Args3), Old4 -- New4) + end + end + end; + false -> OldWarnVarArgs + end. + +compare_first_arg(OldWarnVarArgs, NewWarnVarArgs, RaceVarMap) -> + [Old1, Old2|_OldT] = OldWarnVarArgs, + [New1, New2|_NewT] = NewWarnVarArgs, + case any_args(Old2) of + true -> + case compare_var_list(New1, Old1, RaceVarMap) of + true -> true; + false -> OldWarnVarArgs + end; + false -> + case any_args(New2) of + true -> + case compare_var_list(New1, Old1, RaceVarMap) of + true -> true; + false -> OldWarnVarArgs + end; + false -> + case compare_var_list(New1, Old1, RaceVarMap) of + true -> true; + false -> lists_key_replace(2, OldWarnVarArgs, Old2 -- New2) + end + end + end. + +compare_argtypes(ArgTypes, WarnArgTypes) -> + lists:any(fun (X) -> lists:member(X, WarnArgTypes) end, ArgTypes). + +%% Compares the argument types of the two suspicious calls. +compare_types(VarArgs, WarnVarArgs, RaceWarnTag, RaceVarMap) -> + case RaceWarnTag of + ?WARN_WHEREIS_REGISTER -> + [VA1, VA2] = VarArgs, + [WVA1, WVA2, _, _] = WarnVarArgs, + case any_args(VA2) of + true -> compare_var_list(VA1, WVA1, RaceVarMap); + false -> + case any_args(WVA2) of + true -> compare_var_list(VA1, WVA1, RaceVarMap); + false -> + compare_var_list(VA1, WVA1, RaceVarMap) orelse + compare_argtypes(VA2, WVA2) + end + end; + ?WARN_WHEREIS_UNREGISTER -> + [VA1, VA2] = VarArgs, + [WVA1, WVA2] = WarnVarArgs, + case any_args(VA2) of + true -> compare_var_list(VA1, WVA1, RaceVarMap); + false -> + case any_args(WVA2) of + true -> compare_var_list(VA1, WVA1, RaceVarMap); + false -> + compare_var_list(VA1, WVA1, RaceVarMap) orelse + compare_argtypes(VA2, WVA2) + end + end; + ?WARN_ETS_LOOKUP_INSERT -> + [VA1, VA2, VA3, VA4] = VarArgs, + [WVA1, WVA2, WVA3, WVA4] = WarnVarArgs, + Bool = + case any_args(VA2) of + true -> compare_var_list(VA1, WVA1, RaceVarMap); + false -> + case any_args(WVA2) of + true -> compare_var_list(VA1, WVA1, RaceVarMap); + false -> + compare_var_list(VA1, WVA1, RaceVarMap) orelse + compare_argtypes(VA2, WVA2) + end + end, + Bool andalso + (case any_args(VA4) of + true -> + compare_var_list(VA3, WVA3, RaceVarMap); + false -> + case any_args(WVA4) of + true -> + compare_var_list(VA3, WVA3, RaceVarMap); + false -> + compare_var_list(VA3, WVA3, RaceVarMap) orelse + compare_argtypes(VA4, WVA4) + end + end); + ?WARN_MNESIA_DIRTY_READ_WRITE -> + [VA1, VA2|_] = VarArgs, %% Two or four elements + [WVA1, WVA2|_] = WarnVarArgs, + case any_args(VA2) of + true -> compare_var_list(VA1, WVA1, RaceVarMap); + false -> + case any_args(WVA2) of + true -> compare_var_list(VA1, WVA1, RaceVarMap); + false -> + compare_var_list(VA1, WVA1, RaceVarMap) orelse + compare_argtypes(VA2, WVA2) + end + end + end. + +compare_list_vars(VarList1, VarList2, NewVarList1, RaceVarMap) -> + case VarList1 of + [] -> + case NewVarList1 of + [] -> true; + _Other -> NewVarList1 + end; + [Head|Tail] -> + NewHead = + case compare_var_list(Head, VarList2, RaceVarMap) of + true -> []; + false -> [Head] + end, + compare_list_vars(Tail, VarList2, NewHead ++ NewVarList1, RaceVarMap) + end. + +compare_vars(Var1, Var2, RaceVarMap) when is_integer(Var1), is_integer(Var2) -> + Var1 =:= Var2 orelse + are_bound_labels(Var1, Var2, RaceVarMap) orelse + are_bound_labels(Var2, Var1, RaceVarMap); +compare_vars(_Var1, _Var2, _RaceVarMap) -> + false. + +-spec compare_var_list(label_type(), [label_type()], dict:dict()) -> boolean(). + +compare_var_list(Var, VarList, RaceVarMap) -> + lists:any(fun (V) -> compare_vars(Var, V, RaceVarMap) end, VarList). + +ets_list_args(MaybeList) -> + case is_list(MaybeList) of + true -> + try [ets_tuple_args(T) || T <- MaybeList] + catch _:_ -> [?no_label] + end; + false -> [ets_tuple_args(MaybeList)] + end. + +ets_list_argtypes(ListStr) -> + ListStr1 = string:strip(ListStr, left, $[), + ListStr2 = string:strip(ListStr1, right, $]), + ListStr3 = string:strip(ListStr2, right, $.), + string:strip(ListStr3, right, $,). + +ets_tuple_args(MaybeTuple) -> + case is_tuple(MaybeTuple) of + true -> element(1, MaybeTuple); + false -> ?no_label + end. + +ets_tuple_argtypes2(TupleList, ElemList) -> + case TupleList of + [] -> ElemList; + [H|T] -> + ets_tuple_argtypes2(T, + ets_tuple_argtypes2_helper(H, [], 0) ++ ElemList) + end. + +ets_tuple_argtypes2_helper(TupleStr, ElemStr, NestingLevel) -> + case TupleStr of + [] -> []; + [H|T] -> + {NewElemStr, NewNestingLevel, Return} = + case H of + ${ when NestingLevel =:= 0 -> + {ElemStr, NestingLevel + 1, false}; + ${ -> + {[H|ElemStr], NestingLevel + 1, false}; + $[ -> + {[H|ElemStr], NestingLevel + 1, false}; + $( -> + {[H|ElemStr], NestingLevel + 1, false}; + $} -> + {[H|ElemStr], NestingLevel - 1, false}; + $] -> + {[H|ElemStr], NestingLevel - 1, false}; + $) -> + {[H|ElemStr], NestingLevel - 1, false}; + $, when NestingLevel =:= 1 -> + {lists:reverse(ElemStr), NestingLevel, true}; + _Other -> + {[H|ElemStr], NestingLevel, false} + end, + case Return of + true -> string:tokens(NewElemStr, " |"); + false -> + ets_tuple_argtypes2_helper(T, NewElemStr, NewNestingLevel) + end + end. + +ets_tuple_argtypes1(Str, Tuple, TupleList, NestingLevel) -> + case Str of + [] -> TupleList; + [H|T] -> + {NewTuple, NewNestingLevel, Add} = + case H of + ${ -> + {[H|Tuple], NestingLevel + 1, false}; + $} -> + case NestingLevel of + 1 -> + {[H|Tuple], NestingLevel - 1, true}; + _Else -> + {[H|Tuple], NestingLevel - 1, false} + end; + _Other1 when NestingLevel =:= 0 -> + {Tuple, NestingLevel, false}; + _Other2 -> + {[H|Tuple], NestingLevel, false} + end, + case Add of + true -> + ets_tuple_argtypes1(T, [], + [lists:reverse(NewTuple)|TupleList], + NewNestingLevel); + false -> + ets_tuple_argtypes1(T, NewTuple, TupleList, NewNestingLevel) + end + end. + +format_arg(?bypassed) -> ?no_label; +format_arg(Arg0) -> + Arg = cerl:fold_literal(Arg0), + case cerl:type(Arg) of + var -> cerl_trees:get_label(Arg); + tuple -> list_to_tuple([format_arg(A) || A <- cerl:tuple_es(Arg)]); + cons -> [format_arg(cerl:cons_hd(Arg))|format_arg(cerl:cons_tl(Arg))]; + alias -> format_arg(cerl:alias_var(Arg)); + literal -> + case cerl:is_c_nil(Arg) of + true -> []; + false -> ?no_label + end; + _Other -> ?no_label + end. + +-spec format_args([core_vars()], [erl_types:erl_type()], + dialyzer_dataflow:state(), call()) -> + args(). + +format_args([], [], _State, _Call) -> + []; +format_args(ArgList, TypeList, CleanState, Call) -> + format_args_2(format_args_1(ArgList, TypeList, CleanState), Call). + +format_args_1([Arg], [Type], CleanState) -> + [format_arg(Arg), format_type(Type, CleanState)]; +format_args_1([Arg|Args], [Type|Types], CleanState) -> + List = + case Arg =:= ?bypassed of + true -> [?no_label, format_type(Type, CleanState)]; + false -> + case cerl:is_literal(cerl:fold_literal(Arg)) of + true -> [?no_label, format_cerl(Arg)]; + false -> [format_arg(Arg), format_type(Type, CleanState)] + end + end, + List ++ format_args_1(Args, Types, CleanState). + +format_args_2(StrArgList, Call) -> + case Call of + whereis -> + lists_key_replace(2, StrArgList, + string:tokens(lists:nth(2, StrArgList), " |")); + register -> + lists_key_replace(2, StrArgList, + string:tokens(lists:nth(2, StrArgList), " |")); + unregister -> + lists_key_replace(2, StrArgList, + string:tokens(lists:nth(2, StrArgList), " |")); + ets_new -> + StrArgList1 = lists_key_replace(2, StrArgList, + string:tokens(lists:nth(2, StrArgList), " |")), + lists_key_replace(4, StrArgList1, + string:tokens(ets_list_argtypes(lists:nth(4, StrArgList1)), " |")); + ets_lookup -> + StrArgList1 = lists_key_replace(2, StrArgList, + string:tokens(lists:nth(2, StrArgList), " |")), + lists_key_replace(4, StrArgList1, + string:tokens(lists:nth(4, StrArgList1), " |")); + ets_insert -> + StrArgList1 = lists_key_replace(2, StrArgList, + string:tokens(lists:nth(2, StrArgList), " |")), + lists_key_replace(4, StrArgList1, + ets_tuple_argtypes2( + ets_tuple_argtypes1(lists:nth(4, StrArgList1), [], [], 0), + [])); + mnesia_dirty_read1 -> + lists_key_replace(2, StrArgList, + [mnesia_tuple_argtypes(T) || T <- string:tokens( + lists:nth(2, StrArgList), " |")]); + mnesia_dirty_read2 -> + lists_key_replace(2, StrArgList, + string:tokens(lists:nth(2, StrArgList), " |")); + mnesia_dirty_write1 -> + lists_key_replace(2, StrArgList, + [mnesia_record_tab(R) || R <- string:tokens( + lists:nth(2, StrArgList), " |")]); + mnesia_dirty_write2 -> + lists_key_replace(2, StrArgList, + string:tokens(lists:nth(2, StrArgList), " |")); + function_call -> StrArgList + end. + +format_cerl(Tree) -> + cerl_prettypr:format(cerl:set_ann(Tree, []), + [{hook, dialyzer_utils:pp_hook()}, + {noann, true}, + {paper, 100000}, + {ribbon, 100000} + ]). + +format_type(Type, State) -> + R = dialyzer_dataflow:state__get_records(State), + erl_types:t_to_string(Type, R). + +mnesia_record_tab(RecordStr) -> + case string:str(RecordStr, "#") =:= 1 of + true -> + "'" ++ + string:sub_string(RecordStr, 2, string:str(RecordStr, "{") - 1) ++ + "'"; + false -> RecordStr + end. + +mnesia_tuple_argtypes(TupleStr) -> + TupleStr1 = string:strip(TupleStr, left, ${), + [TupleStr2|_T] = string:tokens(TupleStr1, " ,"), + lists:flatten(string:tokens(TupleStr2, " |")). + +-spec race_var_map(var_to_map1(), var_to_map2(), dict:dict(), op()) -> + dict:dict(). + +race_var_map(Vars1, Vars2, RaceVarMap, Op) -> + case Vars1 =:= ?no_arg orelse Vars1 =:= ?bypassed + orelse Vars2 =:= ?bypassed of + true -> RaceVarMap; + false -> + case is_list(Vars1) andalso is_list(Vars2) of + true -> + case Vars1 of + [] -> RaceVarMap; + [AHead|ATail] -> + case Vars2 of + [] -> RaceVarMap; + [PHead|PTail] -> + NewRaceVarMap = race_var_map(AHead, PHead, RaceVarMap, Op), + race_var_map(ATail, PTail, NewRaceVarMap, Op) + end + end; + false -> + {NewVars1, NewVars2, Bool} = + case is_list(Vars1) of + true -> + case Vars1 of + [Var1] -> {Var1, Vars2, true}; + _Thing -> {Vars1, Vars2, false} + end; + false -> + case is_list(Vars2) of + true -> + case Vars2 of + [Var2] -> {Vars1, Var2, true}; + _Thing -> {Vars1, Vars2, false} + end; + false -> {Vars1, Vars2, true} + end + end, + case Bool of + true -> + case cerl:type(NewVars1) of + var -> + case cerl:type(NewVars2) of + var -> + ALabel = cerl_trees:get_label(NewVars1), + PLabel = cerl_trees:get_label(NewVars2), + case Op of + bind -> + TempRaceVarMap = + bind_dict_vars(ALabel, PLabel, RaceVarMap), + bind_dict_vars(PLabel, ALabel, TempRaceVarMap); + unbind -> + TempRaceVarMap = + unbind_dict_vars(ALabel, PLabel, RaceVarMap), + unbind_dict_vars(PLabel, ALabel, TempRaceVarMap) + end; + alias -> + race_var_map(NewVars1, cerl:alias_var(NewVars2), + RaceVarMap, Op); + values -> + race_var_map(NewVars1, cerl:values_es(NewVars2), + RaceVarMap, Op); + _Other -> RaceVarMap + end; + tuple -> + case cerl:type(NewVars2) of + tuple -> + race_var_map(cerl:tuple_es(NewVars1), + cerl:tuple_es(NewVars2), RaceVarMap, Op); + alias -> + race_var_map(NewVars1, cerl:alias_var(NewVars2), + RaceVarMap, Op); + values -> + race_var_map(NewVars1, cerl:values_es(NewVars2), + RaceVarMap, Op); + _Other -> RaceVarMap + end; + cons -> + case cerl:type(NewVars2) of + cons -> + NewRaceVarMap = race_var_map(cerl:cons_hd(NewVars1), + cerl:cons_hd(NewVars2), RaceVarMap, Op), + race_var_map(cerl:cons_tl(NewVars1), + cerl:cons_tl(NewVars2), NewRaceVarMap, Op); + alias -> + race_var_map(NewVars1, cerl:alias_var(NewVars2), + RaceVarMap, Op); + values -> + race_var_map(NewVars1, cerl:values_es(NewVars2), + RaceVarMap, Op); + _Other -> RaceVarMap + end; + alias -> + case cerl:type(NewVars2) of + alias -> + race_var_map(cerl:alias_var(NewVars1), + cerl:alias_var(NewVars2), RaceVarMap, Op); + _Other -> + race_var_map(cerl:alias_var(NewVars1), + NewVars2, RaceVarMap, Op) + end; + values -> + case cerl:type(NewVars2) of + values -> + race_var_map(cerl:values_es(NewVars1), + cerl:values_es(NewVars2), RaceVarMap, Op); + _Other -> + race_var_map(cerl:values_es(NewVars1), + NewVars2, RaceVarMap, Op) + end; + _Other -> RaceVarMap + end; + false -> RaceVarMap + end + end + end. + +race_var_map_clauses(Clauses, RaceVarMap) -> + case Clauses of + [] -> RaceVarMap; + [#end_clause{arg = Arg, pats = Pats, guard = Guard}|T] -> + {RaceVarMap1, _RemoveClause} = + race_var_map_guard(Arg, Pats, Guard, RaceVarMap, bind), + race_var_map_clauses(T, RaceVarMap1) + end. + +race_var_map_guard(Arg, Pats, Guard, RaceVarMap, Op) -> + {NewRaceVarMap, RemoveClause} = + case cerl:type(Guard) of + call -> + CallName = cerl:call_name(Guard), + case cerl:is_literal(CallName) of + true -> + case cerl:concrete(CallName) of + '=:=' -> + [Arg1, Arg2] = cerl:call_args(Guard), + {race_var_map(Arg1, Arg2, RaceVarMap, Op), false}; + '==' -> + [Arg1, Arg2] = cerl:call_args(Guard), + {race_var_map(Arg1, Arg2, RaceVarMap, Op), false}; + '=/=' -> + case Op of + bind -> + [Arg1, Arg2] = cerl:call_args(Guard), + {RaceVarMap, are_bound_vars(Arg1, Arg2, RaceVarMap)}; + unbind -> {RaceVarMap, false} + end; + _Other -> {RaceVarMap, false} + end; + false -> {RaceVarMap, false} + end; + _Other -> {RaceVarMap, false} + end, + {RaceVarMap1, RemoveClause1} = + race_var_map_guard_helper1(Arg, Pats, + race_var_map(Arg, Pats, NewRaceVarMap, Op), Op), + {RaceVarMap1, RemoveClause orelse RemoveClause1}. + +race_var_map_guard_helper1(Arg, Pats, RaceVarMap, Op) -> + case Arg =:= ?no_arg orelse Arg =:= ?bypassed of + true -> {RaceVarMap, false}; + false -> + case cerl:type(Arg) of + call -> + case Pats of + [NewPat] -> + ModName = cerl:call_module(Arg), + CallName = cerl:call_name(Arg), + case cerl:is_literal(ModName) andalso + cerl:is_literal(CallName) of + true -> + case {cerl:concrete(ModName), + cerl:concrete(CallName)} of + {erlang, '=:='} -> + race_var_map_guard_helper2(Arg, NewPat, true, + RaceVarMap, Op); + {erlang, '=='} -> + race_var_map_guard_helper2(Arg, NewPat, true, + RaceVarMap, Op); + {erlang, '=/='} -> + race_var_map_guard_helper2(Arg, NewPat, false, + RaceVarMap, Op); + _Else -> {RaceVarMap, false} + end; + false -> {RaceVarMap, false} + end; + _Other -> {RaceVarMap, false} + end; + _Other -> {RaceVarMap, false} + end + end. + +race_var_map_guard_helper2(Arg, Pat0, Bool, RaceVarMap, Op) -> + Pat = cerl:fold_literal(Pat0), + case cerl:type(Pat) of + literal -> + [Arg1, Arg2] = cerl:call_args(Arg), + case cerl:concrete(Pat) of + Bool -> + {race_var_map(Arg1, Arg2, RaceVarMap, Op), false}; + _Else -> + case Op of + bind -> + {RaceVarMap, are_bound_vars(Arg1, Arg2, RaceVarMap)}; + unbind -> {RaceVarMap, false} + end + end; + _Else -> {RaceVarMap, false} + end. + +unbind_dict_vars(Var, Var, RaceVarMap) -> + RaceVarMap; +unbind_dict_vars(Var1, Var2, RaceVarMap) -> + case dict:find(Var1, RaceVarMap) of + error -> RaceVarMap; + {ok, Labels} -> + case Labels of + [] -> dict:erase(Var1, RaceVarMap); + _Else -> + case lists:member(Var2, Labels) of + true -> + unbind_dict_vars(Var1, Var2, + bind_dict_vars_list(Var1, Labels -- [Var2], + dict:erase(Var1, RaceVarMap))); + false -> + unbind_dict_vars_helper(Labels, Var1, Var2, RaceVarMap) + end + end + end. + +unbind_dict_vars_helper(Labels, Key, CompLabel, RaceVarMap) -> + case dict:size(RaceVarMap) of + 0 -> RaceVarMap; + _ -> + case Labels of + [] -> RaceVarMap; + [Head|Tail] -> + NewRaceVarMap = + case are_bound_labels(Head, CompLabel, RaceVarMap) orelse + are_bound_labels(CompLabel, Head, RaceVarMap) of + true -> + bind_dict_vars_list(Key, Labels -- [Head], + dict:erase(Key, RaceVarMap)); + false -> RaceVarMap + end, + unbind_dict_vars_helper(Tail, Key, CompLabel, NewRaceVarMap) + end + end. + +var_analysis(FunDefArgs, FunCallArgs, WarnVarArgs, RaceWarnTag) -> + case RaceWarnTag of + ?WARN_WHEREIS_REGISTER -> + [WVA1, WVA2, WVA3, WVA4] = WarnVarArgs, + ArgNos = lists_key_members_lists(WVA1, FunDefArgs), + [[lists_get(N, FunCallArgs) || N <- ArgNos], WVA2, WVA3, WVA4]; + ?WARN_WHEREIS_UNREGISTER -> + [WVA1, WVA2] = WarnVarArgs, + ArgNos = lists_key_members_lists(WVA1, FunDefArgs), + [[lists_get(N, FunCallArgs) || N <- ArgNos], WVA2]; + ?WARN_ETS_LOOKUP_INSERT -> + [WVA1, WVA2, WVA3, WVA4] = WarnVarArgs, + ArgNos1 = lists_key_members_lists(WVA1, FunDefArgs), + ArgNos2 = lists_key_members_lists(WVA3, FunDefArgs), + [[lists_get(N1, FunCallArgs) || N1 <- ArgNos1], WVA2, + [lists_get(N2, FunCallArgs) || N2 <- ArgNos2], WVA4]; + ?WARN_MNESIA_DIRTY_READ_WRITE -> + [WVA1, WVA2|T] = WarnVarArgs, + ArgNos = lists_key_members_lists(WVA1, FunDefArgs), + [[lists_get(N, FunCallArgs) || N <- ArgNos], WVA2|T] + end. + +var_type_analysis(FunDefArgs, FunCallTypes, WarnVarArgs, RaceWarnTag, + RaceVarMap, CleanState) -> + FunVarArgs = format_args(FunDefArgs, FunCallTypes, CleanState, function_call), + case RaceWarnTag of + ?WARN_WHEREIS_REGISTER -> + [WVA1, WVA2, WVA3, WVA4] = WarnVarArgs, + Vars = find_all_bound_vars(WVA1, RaceVarMap), + case lists_key_member_lists(Vars, FunVarArgs) of + 0 -> [Vars, WVA2, WVA3, WVA4]; + N when is_integer(N) -> + NewWVA2 = string:tokens(lists:nth(N + 1, FunVarArgs), " |"), + [Vars, NewWVA2, WVA3, WVA4] + end; + ?WARN_WHEREIS_UNREGISTER -> + [WVA1, WVA2] = WarnVarArgs, + Vars = find_all_bound_vars(WVA1, RaceVarMap), + case lists_key_member_lists(Vars, FunVarArgs) of + 0 -> [Vars, WVA2]; + N when is_integer(N) -> + NewWVA2 = string:tokens(lists:nth(N + 1, FunVarArgs), " |"), + [Vars, NewWVA2] + end; + ?WARN_ETS_LOOKUP_INSERT -> + [WVA1, WVA2, WVA3, WVA4] = WarnVarArgs, + Vars1 = find_all_bound_vars(WVA1, RaceVarMap), + FirstVarArg = + case lists_key_member_lists(Vars1, FunVarArgs) of + 0 -> [Vars1, WVA2]; + N1 when is_integer(N1) -> + NewWVA2 = string:tokens(lists:nth(N1 + 1, FunVarArgs), " |"), + [Vars1, NewWVA2] + end, + Vars2 = + lists:flatten( + [find_all_bound_vars(A, RaceVarMap) || A <- ets_list_args(WVA3)]), + case lists_key_member_lists(Vars2, FunVarArgs) of + 0 -> FirstVarArg ++ [Vars2, WVA4]; + N2 when is_integer(N2) -> + NewWVA4 = + ets_tuple_argtypes2( + ets_tuple_argtypes1(lists:nth(N2 + 1, FunVarArgs), [], [], 0), + []), + FirstVarArg ++ [Vars2, NewWVA4] + + end; + ?WARN_MNESIA_DIRTY_READ_WRITE -> + [WVA1, WVA2|T] = WarnVarArgs, + Arity = + case T of + [] -> 1; + _Else -> 2 + end, + Vars = find_all_bound_vars(WVA1, RaceVarMap), + case lists_key_member_lists(Vars, FunVarArgs) of + 0 -> [Vars, WVA2|T]; + N when is_integer(N) -> + NewWVA2 = + case Arity of + 1 -> + [mnesia_record_tab(R) || R <- string:tokens( + lists:nth(2, FunVarArgs), " |")]; + 2 -> + string:tokens(lists:nth(N + 1, FunVarArgs), " |") + end, + [Vars, NewWVA2|T] + end + end. + +%%% =========================================================================== +%%% +%%% Warning Format Utilities +%%% +%%% =========================================================================== + +add_race_warning(Warn, #races{race_warnings = Warns} = Races) -> + Races#races{race_warnings = [Warn|Warns]}. + +get_race_warn(Fun, Args, ArgTypes, DepList, State) -> + {M, F, _A} = Fun, + case DepList of + [] -> {State, no_race}; + _Other -> + {State, {race_condition, [M, F, Args, ArgTypes, State, DepList]}} + end. + +-spec get_race_warnings(races(), dialyzer_dataflow:state()) -> + {races(), dialyzer_dataflow:state()}. + +get_race_warnings(#races{race_warnings = RaceWarnings}, State) -> + get_race_warnings_helper(RaceWarnings, State). + +get_race_warnings_helper(Warnings, State) -> + case Warnings of + [] -> + {dialyzer_dataflow:state__get_races(State), State}; + [H|T] -> + {RaceWarnTag, WarningInfo, {race_condition, [M, F, A, AT, S, DepList]}} = H, + Reason = + case RaceWarnTag of + ?WARN_WHEREIS_REGISTER -> + get_reason(lists:keysort(7, DepList), + "might fail due to a possible race condition " + "caused by its combination with "); + ?WARN_WHEREIS_UNREGISTER -> + get_reason(lists:keysort(7, DepList), + "might fail due to a possible race condition " + "caused by its combination with "); + ?WARN_ETS_LOOKUP_INSERT -> + get_reason(lists:keysort(7, DepList), + "might have an unintended effect due to " ++ + "a possible race condition " ++ + "caused by its combination with "); + ?WARN_MNESIA_DIRTY_READ_WRITE -> + get_reason(lists:keysort(7, DepList), + "might have an unintended effect due to " ++ + "a possible race condition " ++ + "caused by its combination with ") + end, + W = + {?WARN_RACE_CONDITION, WarningInfo, + {race_condition, + [M, F, dialyzer_dataflow:format_args(A, AT, S), Reason]}}, + get_race_warnings_helper(T, + dialyzer_dataflow:state__add_warning(W, State)) + end. + +get_reason(DependencyList, Reason) -> + case DependencyList of + [] -> ""; + [#dep_call{call_name = Call, arg_types = ArgTypes, vars = Args, + state = State, file_line = {File, Line}}|T] -> + R = + Reason ++ + case Call of + whereis -> "the erlang:whereis"; + ets_lookup -> "the ets:lookup"; + mnesia_dirty_read -> "the mnesia:dirty_read" + end ++ + dialyzer_dataflow:format_args(Args, ArgTypes, State) ++ + " call in " ++ + filename:basename(File) ++ + " on line " ++ + lists:flatten(io_lib:write(Line)), + case T of + [] -> R; + _ -> get_reason(T, R ++ ", ") + end + end. + +state__add_race_warning(State, RaceWarn, RaceWarnTag, WarningInfo) -> + case RaceWarn of + no_race -> State; + _Else -> + Races = dialyzer_dataflow:state__get_races(State), + Warn = {RaceWarnTag, WarningInfo, RaceWarn}, + dialyzer_dataflow:state__put_races(add_race_warning(Warn, Races), State) + end. + +%%% =========================================================================== +%%% +%%% Record Interfaces +%%% +%%% =========================================================================== + +-spec beg_clause_new(var_to_map1(), var_to_map1(), cerl:cerl()) -> + #beg_clause{}. + +beg_clause_new(Arg, Pats, Guard) -> + #beg_clause{arg = Arg, pats = Pats, guard = Guard}. + +-spec cleanup(races()) -> races(). + +cleanup(#races{race_list = RaceList}) -> + #races{race_list = RaceList}. + +-spec end_case_new([#end_clause{}]) -> #end_case{}. + +end_case_new(Clauses) -> + #end_case{clauses = Clauses}. + +-spec end_clause_new(var_to_map1(), var_to_map1(), cerl:cerl()) -> + #end_clause{}. + +end_clause_new(Arg, Pats, Guard) -> + #end_clause{arg = Arg, pats = Pats, guard = Guard}. + +-spec get_curr_fun(races()) -> dialyzer_callgraph:mfa_or_funlbl(). + +get_curr_fun(#races{curr_fun = CurrFun}) -> + CurrFun. + +-spec get_curr_fun_args(races()) -> core_args(). + +get_curr_fun_args(#races{curr_fun_args = CurrFunArgs}) -> + CurrFunArgs. + +-spec get_new_table(races()) -> table(). + +get_new_table(#races{new_table = Table}) -> + Table. + +-spec get_race_analysis(races()) -> boolean(). + +get_race_analysis(#races{race_analysis = RaceAnalysis}) -> + RaceAnalysis. + +-spec get_race_list(races()) -> code(). + +get_race_list(#races{race_list = RaceList}) -> + RaceList. + +-spec get_race_list_size(races()) -> non_neg_integer(). + +get_race_list_size(#races{race_list_size = RaceListSize}) -> + RaceListSize. + +-spec get_race_list_and_size(races()) -> {code(), non_neg_integer()}. + +get_race_list_and_size(#races{race_list = RaceList, + race_list_size = RaceListSize}) -> + {RaceList, RaceListSize}. + +-spec let_tag_new(var_to_map1(), var_to_map1()) -> #let_tag{}. + +let_tag_new(Var, Arg) -> + #let_tag{var = Var, arg = Arg}. + +-spec new() -> races(). + +new() -> #races{}. + +-spec put_curr_fun(dialyzer_callgraph:mfa_or_funlbl(), label(), races()) -> + races(). + +put_curr_fun(CurrFun, CurrFunLabel, Races) -> + Races#races{curr_fun = CurrFun, + curr_fun_label = CurrFunLabel, + curr_fun_args = empty}. + +-spec put_fun_args(core_args(), races()) -> races(). + +put_fun_args(Args, #races{curr_fun_args = CurrFunArgs} = Races) -> + case CurrFunArgs of + empty -> Races#races{curr_fun_args = Args}; + _Other -> Races + end. + +-spec put_race_analysis(boolean(), races()) -> + races(). + +put_race_analysis(Analysis, Races) -> + Races#races{race_analysis = Analysis}. + +-spec put_race_list(code(), non_neg_integer(), races()) -> + races(). + +put_race_list(RaceList, RaceListSize, Races) -> + Races#races{race_list = RaceList, race_list_size = RaceListSize}. diff --git a/lib/dialyzer/test/opaque_SUITE_data/src/recrec/erl_types.erl b/lib/dialyzer/test/opaque_SUITE_data/src/recrec/erl_types.erl new file mode 100644 index 0000000000..7826dada9d --- /dev/null +++ b/lib/dialyzer/test/opaque_SUITE_data/src/recrec/erl_types.erl @@ -0,0 +1,5741 @@ +%% -*- erlang-indent-level: 2 -*- +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2003-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% +%% ====================================================================== +%% Copyright (C) 2000-2003 Richard Carlsson +%% +%% ====================================================================== +%% Provides a representation of Erlang types. +%% +%% The initial author of this file is Richard Carlsson (2000-2004). +%% In July 2006, the type representation was totally re-designed by +%% Tobias Lindahl. This is the representation which is used currently. +%% In late 2008, Manouk Manoukian and Kostis Sagonas added support for +%% opaque types to the structure-based representation of types. +%% During February and March 2009, Kostis Sagonas significantly +%% cleaned up the type representation and added spec declarations. +%% +%% Author contact: richardc@it.uu.se, tobiasl@it.uu.se, kostis@cs.ntua.gr +%% ====================================================================== + +-module(erl_types). + +-export([any_none/1, + any_none_or_unit/1, + lookup_record/3, + max/2, + min/2, + number_max/1, number_max/2, + number_min/1, number_min/2, + t_abstract_records/2, + t_any/0, + t_arity/0, + t_atom/0, + t_atom/1, + t_atoms/1, + t_atom_vals/1, t_atom_vals/2, + t_binary/0, + t_bitstr/0, + t_bitstr/2, + t_bitstr_base/1, + t_bitstr_concat/1, + t_bitstr_concat/2, + t_bitstr_match/2, + t_bitstr_unit/1, + t_bitstrlist/0, + t_boolean/0, + t_byte/0, + t_char/0, + t_collect_vars/1, + t_cons/0, + t_cons/2, + t_cons_hd/1, t_cons_hd/2, + t_cons_tl/1, t_cons_tl/2, + t_contains_opaque/1, t_contains_opaque/2, + t_decorate_with_opaque/3, + t_elements/1, + t_find_opaque_mismatch/3, + t_find_unknown_opaque/3, + t_fixnum/0, + t_map/2, + t_non_neg_fixnum/0, + t_pos_fixnum/0, + t_float/0, + t_var_names/1, + t_form_to_string/1, + t_from_form/6, + t_from_form_without_remote/3, + t_check_record_fields/6, + t_from_range/2, + t_from_range_unsafe/2, + t_from_term/1, + t_fun/0, + t_fun/1, + t_fun/2, + t_fun_args/1, t_fun_args/2, + t_fun_arity/1, t_fun_arity/2, + t_fun_range/1, t_fun_range/2, + t_has_opaque_subtype/2, + t_has_var/1, + t_identifier/0, + %% t_improper_list/2, + t_inf/1, + t_inf/2, + t_inf/3, + t_inf_lists/2, + t_inf_lists/3, + t_integer/0, + t_integer/1, + t_non_neg_integer/0, + t_pos_integer/0, + t_integers/1, + t_iodata/0, + t_iolist/0, + t_is_any/1, + t_is_atom/1, t_is_atom/2, + t_is_any_atom/2, t_is_any_atom/3, + t_is_binary/1, t_is_binary/2, + t_is_bitstr/1, t_is_bitstr/2, + t_is_bitwidth/1, + t_is_boolean/1, t_is_boolean/2, + %% t_is_byte/1, + %% t_is_char/1, + t_is_cons/1, t_is_cons/2, + t_is_equal/2, + t_is_fixnum/1, + t_is_float/1, t_is_float/2, + t_is_fun/1, t_is_fun/2, + t_is_instance/2, + t_is_integer/1, t_is_integer/2, + t_is_list/1, + t_is_map/1, + t_is_map/2, + t_is_matchstate/1, + t_is_nil/1, t_is_nil/2, + t_is_non_neg_integer/1, + t_is_none/1, + t_is_none_or_unit/1, + t_is_number/1, t_is_number/2, + t_is_opaque/1, t_is_opaque/2, + t_is_pid/1, t_is_pid/2, + t_is_port/1, t_is_port/2, + t_is_maybe_improper_list/1, t_is_maybe_improper_list/2, + t_is_reference/1, t_is_reference/2, + t_is_singleton/1, + t_is_singleton/2, + t_is_string/1, + t_is_subtype/2, + t_is_tuple/1, t_is_tuple/2, + t_is_unit/1, + t_is_var/1, + t_limit/2, + t_list/0, + t_list/1, + t_list_elements/1, t_list_elements/2, + t_list_termination/1, t_list_termination/2, + t_map/0, + t_map/1, + t_map/3, + t_map_entries/2, t_map_entries/1, + t_map_def_key/2, t_map_def_key/1, + t_map_def_val/2, t_map_def_val/1, + t_map_get/2, t_map_get/3, + t_map_is_key/2, t_map_is_key/3, + t_map_update/2, t_map_update/3, + t_map_put/2, t_map_put/3, + t_matchstate/0, + t_matchstate/2, + t_matchstate_present/1, + t_matchstate_slot/2, + t_matchstate_slots/1, + t_matchstate_update_present/2, + t_matchstate_update_slot/3, + t_mfa/0, + t_module/0, + t_nil/0, + t_node/0, + t_none/0, + t_nonempty_list/0, + t_nonempty_list/1, + t_nonempty_string/0, + t_number/0, + t_number/1, + t_number_vals/1, t_number_vals/2, + t_opaque_from_records/1, + t_opaque_structure/1, + t_pid/0, + t_port/0, + t_maybe_improper_list/0, + %% t_maybe_improper_list/2, + t_product/1, + t_reference/0, + t_singleton_to_term/2, + t_string/0, + t_struct_from_opaque/2, + t_subst/2, + t_subtract/2, + t_subtract_list/2, + t_sup/1, + t_sup/2, + t_timeout/0, + t_to_string/1, + t_to_string/2, + t_to_tlist/1, + t_tuple/0, + t_tuple/1, + t_tuple_args/1, t_tuple_args/2, + t_tuple_size/1, t_tuple_size/2, + t_tuple_sizes/1, + t_tuple_subtypes/1, + t_tuple_subtypes/2, + t_unify/2, + t_unit/0, + t_unopaque/1, t_unopaque/2, + t_var/1, + t_var_name/1, + %% t_assign_variables_to_subtype/2, + type_is_defined/4, + record_field_diffs_to_string/2, + subst_all_vars_to_any/1, + lift_list_to_pos_empty/1, lift_list_to_pos_empty/2, + is_opaque_type/2, + is_erl_type/1, + atom_to_string/1, + var_table__new/0, + cache__new/0, + map_pairwise_merge/3 + ]). + +%%-define(DO_ERL_TYPES_TEST, true). +-compile({no_auto_import,[min/2,max/2]}). + +-ifdef(DO_ERL_TYPES_TEST). +-export([test/0]). +-else. +-define(NO_UNUSED, true). +-endif. + +-ifndef(NO_UNUSED). +-export([t_is_identifier/1]). +-endif. + +-export_type([erl_type/0, opaques/0, type_table/0, var_table/0, cache/0]). + +%%-define(DEBUG, true). + +-ifdef(DEBUG). +-define(debug(__A), __A). +-else. +-define(debug(__A), ok). +-endif. + +%%============================================================================= +%% +%% Definition of the type structure +%% +%%============================================================================= + +%%----------------------------------------------------------------------------- +%% Limits +%% + +-define(REC_TYPE_LIMIT, 2). +-define(EXPAND_DEPTH, 16). +-define(EXPAND_LIMIT, 10000). + +-define(TUPLE_TAG_LIMIT, 5). +-define(TUPLE_ARITY_LIMIT, 8). +-define(SET_LIMIT, 13). +-define(MAX_BYTE, 255). +-define(MAX_CHAR, 16#10ffff). + +-define(UNIT_MULTIPLIER, 8). + +-define(TAG_IMMED1_SIZE, 4). +-define(BITS, (erlang:system_info(wordsize) * 8) - ?TAG_IMMED1_SIZE). + +-define(MAX_TUPLE_SIZE, (1 bsl 10)). + +%%----------------------------------------------------------------------------- +%% Type tags and qualifiers +%% + +-define(atom_tag, atom). +-define(binary_tag, binary). +-define(function_tag, function). +-define(identifier_tag, identifier). +-define(list_tag, list). +-define(map_tag, map). +-define(matchstate_tag, matchstate). +-define(nil_tag, nil). +-define(number_tag, number). +-define(opaque_tag, opaque). +-define(product_tag, product). +-define(tuple_set_tag, tuple_set). +-define(tuple_tag, tuple). +-define(union_tag, union). +-define(var_tag, var). + +-type tag() :: ?atom_tag | ?binary_tag | ?function_tag | ?identifier_tag + | ?list_tag | ?map_tag | ?matchstate_tag | ?nil_tag | ?number_tag + | ?opaque_tag | ?product_tag + | ?tuple_tag | ?tuple_set_tag | ?union_tag | ?var_tag. + +-define(float_qual, float). +-define(integer_qual, integer). +-define(nonempty_qual, nonempty). +-define(pid_qual, pid). +-define(port_qual, port). +-define(reference_qual, reference). +-define(unknown_qual, unknown). + +-type qual() :: ?float_qual | ?integer_qual | ?nonempty_qual | ?pid_qual + | ?port_qual | ?reference_qual | ?unknown_qual | {_, _}. + +%%----------------------------------------------------------------------------- +%% The type representation +%% + +-define(any, any). +-define(none, none). +-define(unit, unit). +%% Generic constructor - elements can be many things depending on the tag. +-record(c, {tag :: tag(), + elements = [] :: term(), + qualifier = ?unknown_qual :: qual()}). + +-opaque erl_type() :: ?any | ?none | ?unit | #c{}. + +%%----------------------------------------------------------------------------- +%% Auxiliary types and convenient macros +%% + +-type parse_form() :: erl_parse:abstract_type(). +-type rng_elem() :: 'pos_inf' | 'neg_inf' | integer(). + +-record(int_set, {set :: [integer()]}). +-record(int_rng, {from :: rng_elem(), to :: rng_elem()}). +%% Note: the definition of #opaque{} was changed to 'mod' and 'name'; +%% it used to be an ordsets of {Mod, Name} pairs. The Dialyzer version +%% was updated to 2.7 due to this change. +-record(opaque, {mod :: module(), name :: atom(), + args = [] :: [erl_type()], struct :: erl_type()}). + +-define(atom(Set), #c{tag=?atom_tag, elements=Set}). +-define(bitstr(Unit, Base), #c{tag=?binary_tag, elements=[Unit,Base]}). +-define(float, ?number(?any, ?float_qual)). +-define(function(Domain, Range), #c{tag=?function_tag, + elements=[Domain, Range]}). +-define(identifier(Types), #c{tag=?identifier_tag, elements=Types}). +-define(integer(Types), ?number(Types, ?integer_qual)). +-define(int_range(From, To), ?integer(#int_rng{from=From, to=To})). +-define(int_set(Set), ?integer(#int_set{set=Set})). +-define(list(Types, Term, Size), #c{tag=?list_tag, elements=[Types,Term], + qualifier=Size}). +-define(nil, #c{tag=?nil_tag}). +-define(nonempty_list(Types, Term),?list(Types, Term, ?nonempty_qual)). +-define(number(Set, Qualifier), #c{tag=?number_tag, elements=Set, + qualifier=Qualifier}). +-define(map(Pairs,DefKey,DefVal), + #c{tag=?map_tag, elements={Pairs,DefKey,DefVal}}). +-define(opaque(Optypes), #c{tag=?opaque_tag, elements=Optypes}). +-define(product(Types), #c{tag=?product_tag, elements=Types}). +-define(tuple(Types, Arity, Qual), #c{tag=?tuple_tag, elements=Types, + qualifier={Arity, Qual}}). +-define(tuple_set(Tuples), #c{tag=?tuple_set_tag, elements=Tuples}). +-define(var(Id), #c{tag=?var_tag, elements=Id}). + +-define(matchstate(P, Slots), #c{tag=?matchstate_tag, elements=[P,Slots]}). +-define(any_matchstate, ?matchstate(t_bitstr(), ?any)). + +-define(byte, ?int_range(0, ?MAX_BYTE)). +-define(char, ?int_range(0, ?MAX_CHAR)). +-define(integer_pos, ?int_range(1, pos_inf)). +-define(integer_non_neg, ?int_range(0, pos_inf)). +-define(integer_neg, ?int_range(neg_inf, -1)). + +-type opaques() :: [erl_type()] | 'universe'. + +-type record_key() :: {'record', atom()}. +-type type_key() :: {'type' | 'opaque', mfa()}. +-type record_value() :: [{atom(), erl_parse:abstract_expr(), erl_type()}]. +-type type_value() :: {{module(), {file:name(), erl_anno:line()}, + erl_parse:abstract_type(), ArgNames :: [atom()]}, + erl_type()}. +-type type_table() :: dict:dict(record_key() | type_key(), + record_value() | type_value()). + +-opaque var_table() :: #{atom() => erl_type()}. + +%%----------------------------------------------------------------------------- +%% Unions +%% + +-define(union(List), #c{tag=?union_tag, elements=[_,_,_,_,_,_,_,_,_,_]=List}). + +-define(atom_union(T), ?union([T,?none,?none,?none,?none,?none,?none,?none,?none,?none])). +-define(bitstr_union(T), ?union([?none,T,?none,?none,?none,?none,?none,?none,?none,?none])). +-define(function_union(T), ?union([?none,?none,T,?none,?none,?none,?none,?none,?none,?none])). +-define(identifier_union(T), ?union([?none,?none,?none,T,?none,?none,?none,?none,?none,?none])). +-define(list_union(T), ?union([?none,?none,?none,?none,T,?none,?none,?none,?none,?none])). +-define(number_union(T), ?union([?none,?none,?none,?none,?none,T,?none,?none,?none,?none])). +-define(tuple_union(T), ?union([?none,?none,?none,?none,?none,?none,T,?none,?none,?none])). +-define(matchstate_union(T), ?union([?none,?none,?none,?none,?none,?none,?none,T,?none,?none])). +-define(opaque_union(T), ?union([?none,?none,?none,?none,?none,?none,?none,?none,T,?none])). +-define(map_union(T), ?union([?none,?none,?none,?none,?none,?none,?none,?none,?none,T])). +-define(integer_union(T), ?number_union(T)). +-define(float_union(T), ?number_union(T)). +-define(nil_union(T), ?list_union(T)). + + +%%============================================================================= +%% +%% Primitive operations such as type construction and type tests +%% +%%============================================================================= + +%%----------------------------------------------------------------------------- +%% Top and bottom +%% + +-spec t_any() -> erl_type(). + +t_any() -> + ?any. + +-spec t_is_any(erl_type()) -> boolean(). + +t_is_any(Type) -> + do_opaque(Type, 'universe', fun is_any/1). + +is_any(?any) -> true; +is_any(_) -> false. + +-spec t_none() -> erl_type(). + +t_none() -> + ?none. + +-spec t_is_none(erl_type()) -> boolean(). + +t_is_none(?none) -> true; +t_is_none(_) -> false. + +%%----------------------------------------------------------------------------- +%% Opaque types +%% + +-spec t_opaque(module(), atom(), [_], erl_type()) -> erl_type(). + +t_opaque(Mod, Name, Args, Struct) -> + O = #opaque{mod = Mod, name = Name, args = Args, struct = Struct}, + ?opaque(set_singleton(O)). + +-spec t_is_opaque(erl_type(), [erl_type()]) -> boolean(). + +t_is_opaque(?opaque(_) = Type, Opaques) -> + not is_opaque_type(Type, Opaques); +t_is_opaque(_Type, _Opaques) -> false. + +-spec t_is_opaque(erl_type()) -> boolean(). + +t_is_opaque(?opaque(_)) -> true; +t_is_opaque(_) -> false. + +-spec t_has_opaque_subtype(erl_type(), opaques()) -> boolean(). + +t_has_opaque_subtype(Type, Opaques) -> + do_opaque(Type, Opaques, fun has_opaque_subtype/1). + +has_opaque_subtype(?union(Ts)) -> + lists:any(fun t_is_opaque/1, Ts); +has_opaque_subtype(T) -> + t_is_opaque(T). + +-spec t_opaque_structure(erl_type()) -> erl_type(). + +t_opaque_structure(?opaque(Elements)) -> + t_sup([Struct || #opaque{struct = Struct} <- ordsets:to_list(Elements)]). + +-spec t_contains_opaque(erl_type()) -> boolean(). + +t_contains_opaque(Type) -> + t_contains_opaque(Type, []). + +%% Returns 'true' iff there is an opaque type that is *not* one of +%% the types of the second argument. + +-spec t_contains_opaque(erl_type(), [erl_type()]) -> boolean(). + +t_contains_opaque(?any, _Opaques) -> false; +t_contains_opaque(?none, _Opaques) -> false; +t_contains_opaque(?unit, _Opaques) -> false; +t_contains_opaque(?atom(_Set), _Opaques) -> false; +t_contains_opaque(?bitstr(_Unit, _Base), _Opaques) -> false; +t_contains_opaque(?float, _Opaques) -> false; +t_contains_opaque(?function(Domain, Range), Opaques) -> + t_contains_opaque(Domain, Opaques) + orelse t_contains_opaque(Range, Opaques); +t_contains_opaque(?identifier(_Types), _Opaques) -> false; +t_contains_opaque(?integer(_Types), _Opaques) -> false; +t_contains_opaque(?int_range(_From, _To), _Opaques) -> false; +t_contains_opaque(?int_set(_Set), _Opaques) -> false; +t_contains_opaque(?list(Type, Tail, _), Opaques) -> + t_contains_opaque(Type, Opaques) orelse t_contains_opaque(Tail, Opaques); +t_contains_opaque(?map(_, _, _) = Map, Opaques) -> + list_contains_opaque(map_all_types(Map), Opaques); +t_contains_opaque(?matchstate(_P, _Slots), _Opaques) -> false; +t_contains_opaque(?nil, _Opaques) -> false; +t_contains_opaque(?number(_Set, _Tag), _Opaques) -> false; +t_contains_opaque(?opaque(_)=T, Opaques) -> + not is_opaque_type(T, Opaques) + orelse t_contains_opaque(t_opaque_structure(T)); +t_contains_opaque(?product(Types), Opaques) -> + list_contains_opaque(Types, Opaques); +t_contains_opaque(?tuple(?any, _, _), _Opaques) -> false; +t_contains_opaque(?tuple(Types, _, _), Opaques) -> + list_contains_opaque(Types, Opaques); +t_contains_opaque(?tuple_set(_Set) = T, Opaques) -> + list_contains_opaque(t_tuple_subtypes(T), Opaques); +t_contains_opaque(?union(List), Opaques) -> + list_contains_opaque(List, Opaques); +t_contains_opaque(?var(_Id), _Opaques) -> false. + +-spec list_contains_opaque([erl_type()], [erl_type()]) -> boolean(). + +list_contains_opaque(List, Opaques) -> + lists:any(fun(E) -> t_contains_opaque(E, Opaques) end, List). + +%% t_find_opaque_mismatch/2 of two types should only be used if their +%% t_inf is t_none() due to some opaque type violation. +%% +%% The first argument of the function is the pattern and its second +%% argument the type we are matching against the pattern. + +-spec t_find_opaque_mismatch(erl_type(), erl_type(), [erl_type()]) -> + 'error' | {'ok', erl_type(), erl_type()}. + +t_find_opaque_mismatch(T1, T2, Opaques) -> + t_find_opaque_mismatch(T1, T2, T2, Opaques). + +t_find_opaque_mismatch(?any, _Type, _TopType, _Opaques) -> error; +t_find_opaque_mismatch(?none, _Type, _TopType, _Opaques) -> error; +t_find_opaque_mismatch(?list(T1, Tl1, _), ?list(T2, Tl2, _), TopType, Opaques) -> + t_find_opaque_mismatch_ordlists([T1, Tl1], [T2, Tl2], TopType, Opaques); +t_find_opaque_mismatch(T1, ?opaque(_) = T2, TopType, Opaques) -> + case is_opaque_type(T2, Opaques) of + false -> {ok, TopType, T2}; + true -> + t_find_opaque_mismatch(T1, t_opaque_structure(T2), TopType, Opaques) + end; +t_find_opaque_mismatch(?opaque(_) = T1, T2, TopType, Opaques) -> + %% The generated message is somewhat misleading: + case is_opaque_type(T1, Opaques) of + false -> {ok, TopType, T1}; + true -> + t_find_opaque_mismatch(t_opaque_structure(T1), T2, TopType, Opaques) + end; +t_find_opaque_mismatch(?product(T1), ?product(T2), TopType, Opaques) -> + t_find_opaque_mismatch_ordlists(T1, T2, TopType, Opaques); +t_find_opaque_mismatch(?tuple(T1, Arity, _), ?tuple(T2, Arity, _), + TopType, Opaques) -> + t_find_opaque_mismatch_ordlists(T1, T2, TopType, Opaques); +t_find_opaque_mismatch(?tuple(_, _, _) = T1, ?tuple_set(_) = T2, + TopType, Opaques) -> + Tuples1 = t_tuple_subtypes(T1), + Tuples2 = t_tuple_subtypes(T2), + t_find_opaque_mismatch_lists(Tuples1, Tuples2, TopType, Opaques); +t_find_opaque_mismatch(T1, ?union(U2), TopType, Opaques) -> + t_find_opaque_mismatch_lists([T1], U2, TopType, Opaques); +t_find_opaque_mismatch(_T1, _T2, _TopType, _Opaques) -> error. + +t_find_opaque_mismatch_ordlists(L1, L2, TopType, Opaques) -> + List = lists:zipwith(fun(T1, T2) -> + t_find_opaque_mismatch(T1, T2, TopType, Opaques) + end, L1, L2), + t_find_opaque_mismatch_list(List). + +t_find_opaque_mismatch_lists(L1, L2, _TopType, Opaques) -> + List = [t_find_opaque_mismatch(T1, T2, T2, Opaques) || T1 <- L1, T2 <- L2], + t_find_opaque_mismatch_list(List). + +t_find_opaque_mismatch_list([]) -> error; +t_find_opaque_mismatch_list([H|T]) -> + case H of + {ok, _T1, _T2} -> H; + error -> t_find_opaque_mismatch_list(T) + end. + +-spec t_find_unknown_opaque(erl_type(), erl_type(), opaques()) -> + [pos_integer()]. + +%% The nice thing about using two types and t_inf() as compared to +%% calling t_contains_opaque/2 is that the traversal stops when +%% there is a mismatch which means that unknown opaque types "below" +%% the mismatch are not found. +t_find_unknown_opaque(_T1, _T2, 'universe') -> []; +t_find_unknown_opaque(T1, T2, Opaques) -> + try t_inf(T1, T2, {match, Opaques}) of + _ -> [] + catch throw:{pos, Ns} -> Ns + end. + +-spec t_decorate_with_opaque(erl_type(), erl_type(), [erl_type()]) -> erl_type(). + +%% The first argument can contain opaque types. The second argument +%% is assumed to be taken from the contract. + +t_decorate_with_opaque(T1, T2, Opaques) -> + case t_is_equal(T1, T2) orelse not t_contains_opaque(T2) of + true -> T1; + false -> + T = t_inf(T1, T2), + case t_contains_opaque(T) of + false -> T1; + true -> + R = decorate(T1, T, Opaques), + ?debug(case catch t_is_equal(t_unopaque(R), t_unopaque(T1)) of + true -> ok; + false -> + io:format("T1 = ~p,\n", [T1]), + io:format("T2 = ~p,\n", [T2]), + io:format("O = ~p,\n", [Opaques]), + io:format("erl_types:t_decorate_with_opaque(T1,T2,O).\n"), + throw({error, "Failed to handle opaque types"}) + end), + R + end + end. + +decorate(Type, ?none, _Opaques) -> Type; +decorate(?function(Domain, Range), ?function(D, R), Opaques) -> + ?function(decorate(Domain, D, Opaques), decorate(Range, R, Opaques)); +decorate(?list(Types, Tail, Size), ?list(Ts, Tl, _Sz), Opaques) -> + ?list(decorate(Types, Ts, Opaques), decorate(Tail, Tl, Opaques), Size); +decorate(?product(Types), ?product(Ts), Opaques) -> + ?product(list_decorate(Types, Ts, Opaques)); +decorate(?tuple(_, _, _)=T, ?tuple(?any, _, _), _Opaques) -> T; +decorate(?tuple(?any, _, _)=T, ?tuple(_, _, _), _Opaques) -> T; +decorate(?tuple(Types, Arity, Tag), ?tuple(Ts, Arity, _), Opaques) -> + ?tuple(list_decorate(Types, Ts, Opaques), Arity, Tag); +decorate(?tuple_set(List), ?tuple(_, Arity, _) = T, Opaques) -> + decorate_tuple_sets(List, [{Arity, [T]}], Opaques); +decorate(?tuple_set(List), ?tuple_set(L), Opaques) -> + decorate_tuple_sets(List, L, Opaques); +decorate(?union(List), T, Opaques) when T =/= ?any -> + ?union(L) = force_union(T), + union_decorate(List, L, Opaques); +decorate(?opaque(_)=T, _, _Opaques) -> T; +decorate(T, ?union(L), Opaques) when T =/= ?any -> + ?union(List) = force_union(T), + union_decorate(List, L, Opaques); +decorate(Type, ?opaque(_)=T, Opaques) -> + decorate_with_opaque(Type, T, Opaques); +decorate(Type, _T, _Opaques) -> Type. + +%% Note: it is important that #opaque.struct is a subtype of the +%% opaque type. +decorate_with_opaque(Type, ?opaque(Set2), Opaques) -> + case decoration(set_to_list(Set2), Type, Opaques, [], false) of + {[], false} -> Type; + {List, All} when List =/= [] -> + NewType = ?opaque(ordsets:from_list(List)), + case All of + true -> NewType; + false -> t_sup(NewType, Type) + end + end. + +decoration([#opaque{struct = S} = Opaque|OpaqueTypes], Type, Opaques, + NewOpaqueTypes0, All) -> + IsOpaque = is_opaque_type2(Opaque, Opaques), + I = t_inf(Type, S), + case not IsOpaque orelse t_is_none(I) of + true -> decoration(OpaqueTypes, Type, Opaques, NewOpaqueTypes0, All); + false -> + NewOpaque = Opaque#opaque{struct = decorate(I, S, Opaques)}, + NewAll = All orelse t_is_equal(I, Type), + NewOpaqueTypes = [NewOpaque|NewOpaqueTypes0], + decoration(OpaqueTypes, Type, Opaques, NewOpaqueTypes, NewAll) + end; +decoration([], _Type, _Opaques, NewOpaqueTypes, All) -> + {NewOpaqueTypes, All}. + +-spec list_decorate([erl_type()], [erl_type()], opaques()) -> [erl_type()]. + +list_decorate(List, L, Opaques) -> + [decorate(Elem, E, Opaques) || {Elem, E} <- lists:zip(List, L)]. + +union_decorate(U1, U2, Opaques) -> + Union = union_decorate(U1, U2, Opaques, 0, []), + [A,B,F,I,L,N,T,M,_,Map] = U1, + [_,_,_,_,_,_,_,_,Opaque,_] = U2, + List = [A,B,F,I,L,N,T,M,Map], + DecList = [Dec || + E <- List, + not t_is_none(E), + not t_is_none(Dec = decorate(E, Opaque, Opaques))], + t_sup([Union|DecList]). + +union_decorate([?none|Left1], [_|Left2], Opaques, N, Acc) -> + union_decorate(Left1, Left2, Opaques, N, [?none|Acc]); +union_decorate([T1|Left1], [?none|Left2], Opaques, N, Acc) -> + union_decorate(Left1, Left2, Opaques, N+1, [T1|Acc]); +union_decorate([T1|Left1], [T2|Left2], Opaques, N, Acc) -> + union_decorate(Left1, Left2, Opaques, N+1, [decorate(T1, T2, Opaques)|Acc]); +union_decorate([], [], _Opaques, N, Acc) -> + if N =:= 0 -> ?none; + N =:= 1 -> + [Type] = [T || T <- Acc, T =/= ?none], + Type; + N >= 2 -> ?union(lists:reverse(Acc)) + end. + +decorate_tuple_sets(List, L, Opaques) -> + decorate_tuple_sets(List, L, Opaques, []). + +decorate_tuple_sets([{Arity, Tuples}|List], [{Arity, Ts}|L], Opaques, Acc) -> + DecTs = decorate_tuples_in_sets(Tuples, Ts, Opaques), + decorate_tuple_sets(List, L, Opaques, [{Arity, DecTs}|Acc]); +decorate_tuple_sets([ArTup|List], L, Opaques, Acc) -> + decorate_tuple_sets(List, L, Opaques, [ArTup|Acc]); +decorate_tuple_sets([], _L, _Opaques, Acc) -> + ?tuple_set(lists:reverse(Acc)). + +decorate_tuples_in_sets([?tuple(Elements, _, ?any)], Ts, Opaques) -> + NewList = [list_decorate(Elements, Es, Opaques) || ?tuple(Es, _, _) <- Ts], + case t_sup([t_tuple(Es) || Es <- NewList]) of + ?tuple_set([{_Arity, Tuples}]) -> Tuples; + ?tuple(_, _, _)=Tuple -> [Tuple] + end; +decorate_tuples_in_sets(Tuples, Ts, Opaques) -> + decorate_tuples_in_sets(Tuples, Ts, Opaques, []). + +decorate_tuples_in_sets([?tuple(Elements, Arity, Tag1) = T1|Tuples] = L1, + [?tuple(Es, Arity, Tag2)|Ts] = L2, Opaques, Acc) -> + if + Tag1 < Tag2 -> decorate_tuples_in_sets(Tuples, L2, Opaques, [T1|Acc]); + Tag1 > Tag2 -> decorate_tuples_in_sets(L1, Ts, Opaques, Acc); + Tag1 =:= Tag2 -> + NewElements = list_decorate(Elements, Es, Opaques), + NewAcc = [?tuple(NewElements, Arity, Tag1)|Acc], + decorate_tuples_in_sets(Tuples, Ts, Opaques, NewAcc) + end; +decorate_tuples_in_sets([T1|Tuples], L2, Opaques, Acc) -> + decorate_tuples_in_sets(Tuples, L2, Opaques, [T1|Acc]); +decorate_tuples_in_sets([], _L, _Opaques, Acc) -> + lists:reverse(Acc). + +-spec t_opaque_from_records(type_table()) -> [erl_type()]. + +t_opaque_from_records(RecDict) -> + OpaqueRecDict = + dict:filter(fun(Key, _Value) -> + case Key of + {opaque, _Name, _Arity} -> true; + _ -> false + end + end, RecDict), + OpaqueTypeDict = + dict:map(fun({opaque, Name, _Arity}, + {{Module, _FileLine, _Form, ArgNames}, _Type}) -> + %% Args = args_to_types(ArgNames), + %% List = lists:zip(ArgNames, Args), + %% TmpVarTab = maps:to_list(List), + %% Rep = t_from_form(Type, RecDict, TmpVarTab), + Rep = t_any(), % not used for anything right now + Args = [t_any() || _ <- ArgNames], + t_opaque(Module, Name, Args, Rep) + end, OpaqueRecDict), + [OpaqueType || {_Key, OpaqueType} <- dict:to_list(OpaqueTypeDict)]. + +%% Decompose opaque instances of type arg2 to structured types, in arg1 +%% XXX: Same as t_unopaque +-spec t_struct_from_opaque(erl_type(), [erl_type()]) -> erl_type(). + +t_struct_from_opaque(?function(Domain, Range), Opaques) -> + ?function(t_struct_from_opaque(Domain, Opaques), + t_struct_from_opaque(Range, Opaques)); +t_struct_from_opaque(?list(Types, Term, Size), Opaques) -> + ?list(t_struct_from_opaque(Types, Opaques), + t_struct_from_opaque(Term, Opaques), Size); +t_struct_from_opaque(?opaque(_) = T, Opaques) -> + case is_opaque_type(T, Opaques) of + true -> t_opaque_structure(T); + false -> T + end; +t_struct_from_opaque(?product(Types), Opaques) -> + ?product(list_struct_from_opaque(Types, Opaques)); +t_struct_from_opaque(?tuple(?any, _, _) = T, _Opaques) -> T; +t_struct_from_opaque(?tuple(Types, Arity, Tag), Opaques) -> + ?tuple(list_struct_from_opaque(Types, Opaques), Arity, Tag); +t_struct_from_opaque(?tuple_set(Set), Opaques) -> + NewSet = [{Sz, [t_struct_from_opaque(T, Opaques) || T <- Tuples]} + || {Sz, Tuples} <- Set], + ?tuple_set(NewSet); +t_struct_from_opaque(?union(List), Opaques) -> + t_sup(list_struct_from_opaque(List, Opaques)); +t_struct_from_opaque(Type, _Opaques) -> Type. + +list_struct_from_opaque(Types, Opaques) -> + [t_struct_from_opaque(Type, Opaques) || Type <- Types]. + +%%----------------------------------------------------------------------------- + +-type mod_records() :: dict:dict(module(), type_table()). + +%%----------------------------------------------------------------------------- +%% Unit type. Signals non termination. +%% + +-spec t_unit() -> erl_type(). + +t_unit() -> + ?unit. + +-spec t_is_unit(erl_type()) -> boolean(). + +t_is_unit(?unit) -> true; +t_is_unit(_) -> false. + +-spec t_is_none_or_unit(erl_type()) -> boolean(). + +t_is_none_or_unit(?none) -> true; +t_is_none_or_unit(?unit) -> true; +t_is_none_or_unit(_) -> false. + +%%----------------------------------------------------------------------------- +%% Atoms and the derived type boolean +%% + +-spec t_atom() -> erl_type(). + +t_atom() -> + ?atom(?any). + +-spec t_atom(atom()) -> erl_type(). + +t_atom(A) when is_atom(A) -> + ?atom(set_singleton(A)). + +-spec t_atoms([atom()]) -> erl_type(). + +t_atoms(List) when is_list(List) -> + t_sup([t_atom(A) || A <- List]). + +-spec t_atom_vals(erl_type()) -> 'unknown' | [atom(),...]. + +t_atom_vals(Type) -> + t_atom_vals(Type, 'universe'). + +-spec t_atom_vals(erl_type(), opaques()) -> 'unknown' | [atom(),...]. + +t_atom_vals(Type, Opaques) -> + do_opaque(Type, Opaques, fun atom_vals/1). + +atom_vals(?atom(?any)) -> unknown; +atom_vals(?atom(Set)) -> set_to_list(Set); +atom_vals(?opaque(_)) -> unknown; +atom_vals(Other) -> + ?atom(_) = Atm = t_inf(t_atom(), Other), + atom_vals(Atm). + +-spec t_is_atom(erl_type()) -> boolean(). + +t_is_atom(Type) -> + t_is_atom(Type, 'universe'). + +-spec t_is_atom(erl_type(), opaques()) -> boolean(). + +t_is_atom(Type, Opaques) -> + do_opaque(Type, Opaques, fun is_atom1/1). + +is_atom1(?atom(_)) -> true; +is_atom1(_) -> false. + +-spec t_is_any_atom(atom(), erl_type()) -> boolean(). + +t_is_any_atom(Atom, SomeAtomsType) -> + t_is_any_atom(Atom, SomeAtomsType, 'universe'). + +-spec t_is_any_atom(atom(), erl_type(), opaques()) -> boolean(). + +t_is_any_atom(Atom, SomeAtomsType, Opaques) -> + do_opaque(SomeAtomsType, Opaques, + fun(AtomsType) -> is_any_atom(Atom, AtomsType) end). + +is_any_atom(Atom, ?atom(?any)) when is_atom(Atom) -> false; +is_any_atom(Atom, ?atom(Set)) when is_atom(Atom) -> + set_is_singleton(Atom, Set); +is_any_atom(Atom, _) when is_atom(Atom) -> false. + +%%------------------------------------ + +-spec t_is_boolean(erl_type()) -> boolean(). + +t_is_boolean(Type) -> + t_is_boolean(Type, 'universe'). + +-spec t_is_boolean(erl_type(), opaques()) -> boolean(). + +t_is_boolean(Type, Opaques) -> + do_opaque(Type, Opaques, fun is_boolean/1). + +-spec t_boolean() -> erl_type(). + +t_boolean() -> + ?atom(set_from_list([false, true])). + +is_boolean(?atom(?any)) -> false; +is_boolean(?atom(Set)) -> + case set_size(Set) of + 1 -> set_is_element(true, Set) orelse set_is_element(false, Set); + 2 -> set_is_element(true, Set) andalso set_is_element(false, Set); + N when is_integer(N), N > 2 -> false + end; +is_boolean(_) -> false. + +%%----------------------------------------------------------------------------- +%% Binaries +%% + +-spec t_binary() -> erl_type(). + +t_binary() -> + ?bitstr(8, 0). + +-spec t_is_binary(erl_type()) -> boolean(). + +t_is_binary(Type) -> + t_is_binary(Type, 'universe'). + +-spec t_is_binary(erl_type(), opaques()) -> boolean(). + +t_is_binary(Type, Opaques) -> + do_opaque(Type, Opaques, fun is_binary/1). + +is_binary(?bitstr(U, B)) -> + ((U rem 8) =:= 0) andalso ((B rem 8) =:= 0); +is_binary(_) -> false. + +%%----------------------------------------------------------------------------- +%% Bitstrings +%% + +-spec t_bitstr() -> erl_type(). + +t_bitstr() -> + ?bitstr(1, 0). + +-spec t_bitstr(non_neg_integer(), non_neg_integer()) -> erl_type(). + +t_bitstr(U, B) -> + NewB = + if + U =:= 0 -> B; + B >= (U * (?UNIT_MULTIPLIER + 1)) -> + (B rem U) + U * ?UNIT_MULTIPLIER; + true -> + B + end, + ?bitstr(U, NewB). + +-spec t_bitstr_unit(erl_type()) -> non_neg_integer(). + +t_bitstr_unit(?bitstr(U, _)) -> U. + +-spec t_bitstr_base(erl_type()) -> non_neg_integer(). + +t_bitstr_base(?bitstr(_, B)) -> B. + +-spec t_bitstr_concat([erl_type()]) -> erl_type(). + +t_bitstr_concat(List) -> + t_bitstr_concat_1(List, t_bitstr(0, 0)). + +t_bitstr_concat_1([T|Left], Acc) -> + t_bitstr_concat_1(Left, t_bitstr_concat(Acc, T)); +t_bitstr_concat_1([], Acc) -> + Acc. + +-spec t_bitstr_concat(erl_type(), erl_type()) -> erl_type(). + +t_bitstr_concat(T1, T2) -> + T1p = t_inf(t_bitstr(), T1), + T2p = t_inf(t_bitstr(), T2), + bitstr_concat(t_unopaque(T1p), t_unopaque(T2p)). + +-spec t_bitstr_match(erl_type(), erl_type()) -> erl_type(). + +t_bitstr_match(T1, T2) -> + T1p = t_inf(t_bitstr(), T1), + T2p = t_inf(t_bitstr(), T2), + bitstr_match(t_unopaque(T1p), t_unopaque(T2p)). + +-spec t_is_bitstr(erl_type()) -> boolean(). + +t_is_bitstr(Type) -> + t_is_bitstr(Type, 'universe'). + +-spec t_is_bitstr(erl_type(), opaques()) -> boolean(). + +t_is_bitstr(Type, Opaques) -> + do_opaque(Type, Opaques, fun is_bitstr/1). + +is_bitstr(?bitstr(_, _)) -> true; +is_bitstr(_) -> false. + +%%----------------------------------------------------------------------------- +%% Matchstates +%% + +-spec t_matchstate() -> erl_type(). + +t_matchstate() -> + ?any_matchstate. + +-spec t_matchstate(erl_type(), non_neg_integer()) -> erl_type(). + +t_matchstate(Init, 0) -> + ?matchstate(Init, Init); +t_matchstate(Init, Max) when is_integer(Max) -> + Slots = [Init|[?none || _ <- lists:seq(1, Max)]], + ?matchstate(Init, t_product(Slots)). + +-spec t_is_matchstate(erl_type()) -> boolean(). + +t_is_matchstate(?matchstate(_, _)) -> true; +t_is_matchstate(_) -> false. + +-spec t_matchstate_present(erl_type()) -> erl_type(). + +t_matchstate_present(Type) -> + case t_inf(t_matchstate(), Type) of + ?matchstate(P, _) -> P; + _ -> ?none + end. + +-spec t_matchstate_slot(erl_type(), non_neg_integer()) -> erl_type(). + +t_matchstate_slot(Type, Slot) -> + RealSlot = Slot + 1, + case t_inf(t_matchstate(), Type) of + ?matchstate(_, ?any) -> ?any; + ?matchstate(_, ?product(Vals)) when length(Vals) >= RealSlot -> + lists:nth(RealSlot, Vals); + ?matchstate(_, ?product(_)) -> + ?none; + ?matchstate(_, SlotType) when RealSlot =:= 1 -> + SlotType; + _ -> + ?none + end. + +-spec t_matchstate_slots(erl_type()) -> erl_type(). + +t_matchstate_slots(?matchstate(_, Slots)) -> + Slots. + +-spec t_matchstate_update_present(erl_type(), erl_type()) -> erl_type(). + +t_matchstate_update_present(New, Type) -> + case t_inf(t_matchstate(), Type) of + ?matchstate(_, Slots) -> + ?matchstate(New, Slots); + _ -> ?none + end. + +-spec t_matchstate_update_slot(erl_type(), erl_type(), non_neg_integer()) -> erl_type(). + +t_matchstate_update_slot(New, Type, Slot) -> + RealSlot = Slot + 1, + case t_inf(t_matchstate(), Type) of + ?matchstate(Pres, Slots) -> + NewSlots = + case Slots of + ?any -> + ?any; + ?product(Vals) when length(Vals) >= RealSlot -> + NewTuple = setelement(RealSlot, list_to_tuple(Vals), New), + NewVals = tuple_to_list(NewTuple), + ?product(NewVals); + ?product(_) -> + ?none; + _ when RealSlot =:= 1 -> + New; + _ -> + ?none + end, + ?matchstate(Pres, NewSlots); + _ -> + ?none + end. + +%%----------------------------------------------------------------------------- +%% Functions +%% + +-spec t_fun() -> erl_type(). + +t_fun() -> + ?function(?any, ?any). + +-spec t_fun(erl_type()) -> erl_type(). + +t_fun(Range) -> + ?function(?any, Range). + +-spec t_fun([erl_type()] | arity(), erl_type()) -> erl_type(). + +t_fun(Domain, Range) when is_list(Domain) -> + ?function(?product(Domain), Range); +t_fun(Arity, Range) when is_integer(Arity), 0 =< Arity, Arity =< 255 -> + ?function(?product(lists:duplicate(Arity, ?any)), Range). + +-spec t_fun_args(erl_type()) -> 'unknown' | [erl_type()]. + +t_fun_args(Type) -> + t_fun_args(Type, 'universe'). + +-spec t_fun_args(erl_type(), opaques()) -> 'unknown' | [erl_type()]. + +t_fun_args(Type, Opaques) -> + do_opaque(Type, Opaques, fun fun_args/1). + +fun_args(?function(?any, _)) -> + unknown; +fun_args(?function(?product(Domain), _)) when is_list(Domain) -> + Domain. + +-spec t_fun_arity(erl_type()) -> 'unknown' | non_neg_integer(). + +t_fun_arity(Type) -> + t_fun_arity(Type, 'universe'). + +-spec t_fun_arity(erl_type(), opaques()) -> 'unknown' | non_neg_integer(). + +t_fun_arity(Type, Opaques) -> + do_opaque(Type, Opaques, fun fun_arity/1). + +fun_arity(?function(?any, _)) -> + unknown; +fun_arity(?function(?product(Domain), _)) -> + length(Domain). + +-spec t_fun_range(erl_type()) -> erl_type(). + +t_fun_range(Type) -> + t_fun_range(Type, 'universe'). + +-spec t_fun_range(erl_type(), opaques()) -> erl_type(). + +t_fun_range(Type, Opaques) -> + do_opaque(Type, Opaques, fun fun_range/1). + +fun_range(?function(_, Range)) -> + Range. + +-spec t_is_fun(erl_type()) -> boolean(). + +t_is_fun(Type) -> + t_is_fun(Type, 'universe'). + +-spec t_is_fun(erl_type(), opaques()) -> boolean(). + +t_is_fun(Type, Opaques) -> + do_opaque(Type, Opaques, fun is_fun/1). + +is_fun(?function(_, _)) -> true; +is_fun(_) -> false. + +%%----------------------------------------------------------------------------- +%% Identifiers. Includes ports, pids and refs. +%% + +-spec t_identifier() -> erl_type(). + +t_identifier() -> + ?identifier(?any). + +-ifdef(DO_ERL_TYPES_TEST). +-spec t_is_identifier(erl_type()) -> erl_type(). + +t_is_identifier(?identifier(_)) -> true; +t_is_identifier(_) -> false. +-endif. + +%%------------------------------------ + +-spec t_port() -> erl_type(). + +t_port() -> + ?identifier(set_singleton(?port_qual)). + +-spec t_is_port(erl_type()) -> boolean(). + +t_is_port(Type) -> + t_is_port(Type, 'universe'). + +-spec t_is_port(erl_type(), opaques()) -> boolean(). + +t_is_port(Type, Opaques) -> + do_opaque(Type, Opaques, fun is_port1/1). + +is_port1(?identifier(?any)) -> false; +is_port1(?identifier(Set)) -> set_is_singleton(?port_qual, Set); +is_port1(_) -> false. + +%%------------------------------------ + +-spec t_pid() -> erl_type(). + +t_pid() -> + ?identifier(set_singleton(?pid_qual)). + +-spec t_is_pid(erl_type()) -> boolean(). + +t_is_pid(Type) -> + t_is_pid(Type, 'universe'). + +-spec t_is_pid(erl_type(), opaques()) -> boolean(). + +t_is_pid(Type, Opaques) -> + do_opaque(Type, Opaques, fun is_pid1/1). + +is_pid1(?identifier(?any)) -> false; +is_pid1(?identifier(Set)) -> set_is_singleton(?pid_qual, Set); +is_pid1(_) -> false. + +%%------------------------------------ + +-spec t_reference() -> erl_type(). + +t_reference() -> + ?identifier(set_singleton(?reference_qual)). + +-spec t_is_reference(erl_type()) -> boolean(). + +t_is_reference(Type) -> + t_is_reference(Type, 'universe'). + +-spec t_is_reference(erl_type(), opaques()) -> boolean(). + +t_is_reference(Type, Opaques) -> + do_opaque(Type, Opaques, fun is_reference1/1). + +is_reference1(?identifier(?any)) -> false; +is_reference1(?identifier(Set)) -> set_is_singleton(?reference_qual, Set); +is_reference1(_) -> false. + +%%----------------------------------------------------------------------------- +%% Numbers are divided into floats, integers, chars and bytes. +%% + +-spec t_number() -> erl_type(). + +t_number() -> + ?number(?any, ?unknown_qual). + +-spec t_number(integer()) -> erl_type(). + +t_number(X) when is_integer(X) -> + t_integer(X). + +-spec t_is_number(erl_type()) -> boolean(). + +t_is_number(Type) -> + t_is_number(Type, 'universe'). + +-spec t_is_number(erl_type(), opaques()) -> boolean(). + +t_is_number(Type, Opaques) -> + do_opaque(Type, Opaques, fun is_number/1). + +is_number(?number(_, _)) -> true; +is_number(_) -> false. + +%% Currently, the type system collapses all floats to ?float and does +%% not keep any information about their values. As a result, the list +%% that this function returns contains only integers. + +-spec t_number_vals(erl_type()) -> 'unknown' | [integer(),...]. + +t_number_vals(Type) -> + t_number_vals(Type, 'universe'). + +-spec t_number_vals(erl_type(), opaques()) -> 'unknown' | [integer(),...]. + +t_number_vals(Type, Opaques) -> + do_opaque(Type, Opaques, fun number_vals/1). + +number_vals(?int_set(Set)) -> set_to_list(Set); +number_vals(?number(_, _)) -> unknown; +number_vals(?opaque(_)) -> unknown; +number_vals(Other) -> + Inf = t_inf(Other, t_number()), + false = t_is_none(Inf), % sanity check + number_vals(Inf). + +%%------------------------------------ + +-spec t_float() -> erl_type(). + +t_float() -> + ?float. + +-spec t_is_float(erl_type()) -> boolean(). + +t_is_float(Type) -> + t_is_float(Type, 'universe'). + +-spec t_is_float(erl_type(), opaques()) -> boolean(). + +t_is_float(Type, Opaques) -> + do_opaque(Type, Opaques, fun is_float1/1). + +is_float1(?float) -> true; +is_float1(_) -> false. + +%%------------------------------------ + +-spec t_integer() -> erl_type(). + +t_integer() -> + ?integer(?any). + +-spec t_integer(integer()) -> erl_type(). + +t_integer(I) when is_integer(I) -> + ?int_set(set_singleton(I)). + +-spec t_integers([integer()]) -> erl_type(). + +t_integers(List) when is_list(List) -> + t_sup([t_integer(I) || I <- List]). + +-spec t_is_integer(erl_type()) -> boolean(). + +t_is_integer(Type) -> + t_is_integer(Type, 'universe'). + +-spec t_is_integer(erl_type(), opaques()) -> boolean(). + +t_is_integer(Type, Opaques) -> + do_opaque(Type, Opaques, fun is_integer1/1). + +is_integer1(?integer(_)) -> true; +is_integer1(_) -> false. + +%%------------------------------------ + +-spec t_byte() -> erl_type(). + +t_byte() -> + ?byte. + +-ifdef(DO_ERL_TYPES_TEST). +-spec t_is_byte(erl_type()) -> boolean(). + +t_is_byte(?int_range(neg_inf, _)) -> false; +t_is_byte(?int_range(_, pos_inf)) -> false; +t_is_byte(?int_range(From, To)) + when is_integer(From), From >= 0, is_integer(To), To =< ?MAX_BYTE -> true; +t_is_byte(?int_set(Set)) -> + (set_min(Set) >= 0) andalso (set_max(Set) =< ?MAX_BYTE); +t_is_byte(_) -> false. +-endif. + +%%------------------------------------ + +-spec t_char() -> erl_type(). + +t_char() -> + ?char. + +-spec t_is_char(erl_type()) -> boolean(). + +t_is_char(?int_range(neg_inf, _)) -> false; +t_is_char(?int_range(_, pos_inf)) -> false; +t_is_char(?int_range(From, To)) + when is_integer(From), From >= 0, is_integer(To), To =< ?MAX_CHAR -> true; +t_is_char(?int_set(Set)) -> + (set_min(Set) >= 0) andalso (set_max(Set) =< ?MAX_CHAR); +t_is_char(_) -> false. + +%%----------------------------------------------------------------------------- +%% Lists +%% + +-spec t_cons() -> erl_type(). + +t_cons() -> + ?nonempty_list(?any, ?any). + +%% Note that if the tail argument can be a list, we must collapse the +%% content of the list to include both the content of the tail list +%% and the head of the cons. If for example the tail argument is any() +%% then there can be any list in the tail and the content of the +%% returned list must be any(). + +-spec t_cons(erl_type(), erl_type()) -> erl_type(). + +t_cons(?none, _) -> ?none; +t_cons(_, ?none) -> ?none; +t_cons(?unit, _) -> ?none; +t_cons(_, ?unit) -> ?none; +t_cons(Hd, ?nil) -> + ?nonempty_list(Hd, ?nil); +t_cons(Hd, ?list(Contents, Termination, _)) -> + ?nonempty_list(t_sup(Contents, Hd), Termination); +t_cons(Hd, Tail) -> + case cons_tail(t_inf(Tail, t_maybe_improper_list())) of + ?list(Contents, Termination, _Size) -> + %% Collapse the list part of the termination but keep the + %% non-list part intact. + NewTermination = t_sup(t_subtract(Tail, t_maybe_improper_list()), + Termination), + ?nonempty_list(t_sup(Hd, Contents), NewTermination); + ?nil -> ?nonempty_list(Hd, Tail); + ?none -> ?nonempty_list(Hd, Tail); + ?unit -> ?none + end. + +cons_tail(Type) -> + do_opaque(Type, 'universe', fun(T) -> T end). + +-spec t_is_cons(erl_type()) -> boolean(). + +t_is_cons(Type) -> + t_is_cons(Type, 'universe'). + +-spec t_is_cons(erl_type(), opaques()) -> boolean(). + +t_is_cons(Type, Opaques) -> + do_opaque(Type, Opaques, fun is_cons/1). + +is_cons(?nonempty_list(_, _)) -> true; +is_cons(_) -> false. + +-spec t_cons_hd(erl_type()) -> erl_type(). + +t_cons_hd(Type) -> + t_cons_hd(Type, 'universe'). + +-spec t_cons_hd(erl_type(), opaques()) -> erl_type(). + +t_cons_hd(Type, Opaques) -> + do_opaque(Type, Opaques, fun cons_hd/1). + +cons_hd(?nonempty_list(Contents, _Termination)) -> Contents. + +-spec t_cons_tl(erl_type()) -> erl_type(). + +t_cons_tl(Type) -> + t_cons_tl(Type, 'universe'). + +-spec t_cons_tl(erl_type(), opaques()) -> erl_type(). + +t_cons_tl(Type, Opaques) -> + do_opaque(Type, Opaques, fun cons_tl/1). + +cons_tl(?nonempty_list(_Contents, Termination) = T) -> + t_sup(Termination, T). + +-spec t_nil() -> erl_type(). + +t_nil() -> + ?nil. + +-spec t_is_nil(erl_type()) -> boolean(). + +t_is_nil(Type) -> + t_is_nil(Type, 'universe'). + +-spec t_is_nil(erl_type(), opaques()) -> boolean(). + +t_is_nil(Type, Opaques) -> + do_opaque(Type, Opaques, fun is_nil/1). + +is_nil(?nil) -> true; +is_nil(_) -> false. + +-spec t_list() -> erl_type(). + +t_list() -> + ?list(?any, ?nil, ?unknown_qual). + +-spec t_list(erl_type()) -> erl_type(). + +t_list(?none) -> ?none; +t_list(?unit) -> ?none; +t_list(Contents) -> + ?list(Contents, ?nil, ?unknown_qual). + +-spec t_list_elements(erl_type()) -> erl_type(). + +t_list_elements(Type) -> + t_list_elements(Type, 'universe'). + +-spec t_list_elements(erl_type(), opaques()) -> erl_type(). + +t_list_elements(Type, Opaques) -> + do_opaque(Type, Opaques, fun list_elements/1). + +list_elements(?list(Contents, _, _)) -> Contents; +list_elements(?nil) -> ?none. + +-spec t_list_termination(erl_type(), opaques()) -> erl_type(). + +t_list_termination(Type, Opaques) -> + do_opaque(Type, Opaques, fun t_list_termination/1). + +-spec t_list_termination(erl_type()) -> erl_type(). + +t_list_termination(?nil) -> ?nil; +t_list_termination(?list(_, Term, _)) -> Term. + +-spec t_is_list(erl_type()) -> boolean(). + +t_is_list(?list(_Contents, ?nil, _)) -> true; +t_is_list(?nil) -> true; +t_is_list(_) -> false. + +-spec t_nonempty_list() -> erl_type(). + +t_nonempty_list() -> + t_cons(?any, ?nil). + +-spec t_nonempty_list(erl_type()) -> erl_type(). + +t_nonempty_list(Type) -> + t_cons(Type, ?nil). + +-spec t_nonempty_string() -> erl_type(). + +t_nonempty_string() -> + t_nonempty_list(t_char()). + +-spec t_string() -> erl_type(). + +t_string() -> + t_list(t_char()). + +-spec t_is_string(erl_type()) -> boolean(). + +t_is_string(X) -> + t_is_list(X) andalso t_is_char(t_list_elements(X)). + +-spec t_maybe_improper_list() -> erl_type(). + +t_maybe_improper_list() -> + ?list(?any, ?any, ?unknown_qual). + +%% Should only be used if you know what you are doing. See t_cons/2 +-spec t_maybe_improper_list(erl_type(), erl_type()) -> erl_type(). + +t_maybe_improper_list(_Content, ?unit) -> ?none; +t_maybe_improper_list(?unit, _Termination) -> ?none; +t_maybe_improper_list(Content, Termination) -> + %% Safety check: would be nice to have but does not work with remote types + %% true = t_is_subtype(t_nil(), Termination), + ?list(Content, Termination, ?unknown_qual). + +-spec t_is_maybe_improper_list(erl_type()) -> boolean(). + +t_is_maybe_improper_list(Type) -> + t_is_maybe_improper_list(Type, 'universe'). + +-spec t_is_maybe_improper_list(erl_type(), opaques()) -> boolean(). + +t_is_maybe_improper_list(Type, Opaques) -> + do_opaque(Type, Opaques, fun is_maybe_improper_list/1). + +is_maybe_improper_list(?list(_, _, _)) -> true; +is_maybe_improper_list(?nil) -> true; +is_maybe_improper_list(_) -> false. + +%% %% Should only be used if you know what you are doing. See t_cons/2 +%% -spec t_improper_list(erl_type(), erl_type()) -> erl_type(). +%% +%% t_improper_list(?unit, _Termination) -> ?none; +%% t_improper_list(_Content, ?unit) -> ?none; +%% t_improper_list(Content, Termination) -> +%% %% Safety check: would be nice to have but does not work with remote types +%% %% false = t_is_subtype(t_nil(), Termination), +%% ?list(Content, Termination, ?any). + +-spec lift_list_to_pos_empty(erl_type(), opaques()) -> erl_type(). + +lift_list_to_pos_empty(Type, Opaques) -> + do_opaque(Type, Opaques, fun lift_list_to_pos_empty/1). + +-spec lift_list_to_pos_empty(erl_type()) -> erl_type(). + +lift_list_to_pos_empty(?nil) -> ?nil; +lift_list_to_pos_empty(?list(Content, Termination, _)) -> + ?list(Content, Termination, ?unknown_qual). + +%%----------------------------------------------------------------------------- +%% Maps +%% +%% Representation: +%% ?map(Pairs, DefaultKey, DefaultValue) +%% +%% Pairs is a sorted dictionary of types with a mandatoriness tag on each pair +%% (t_map_dict()). DefaultKey and DefaultValue are plain types. +%% +%% A map M belongs to this type iff +%% For each pair {KT, mandatory, VT} in Pairs, there exists a pair {K, V} in M +%% such that K \in KT and V \in VT. +%% For each pair {KT, optional, VT} in Pairs, either there exists no key K in +%% M s.t. K in KT, or there exists a pair {K, V} in M such that K \in KT and +%% V \in VT. +%% For each remaining pair {K, V} in M (where remaining means that there is no +%% key KT in Pairs s.t. K \in KT), K \in DefaultKey and V \in DefaultValue. +%% +%% Invariants: +%% * The keys in Pairs are singleton types. +%% * The values of Pairs must not be unit, and may only be none if the +%% mandatoriness tag is 'optional'. +%% * Optional must contain no pair {K,V} s.t. K is a subtype of DefaultKey and +%% V is equal to DefaultKey. +%% * DefaultKey must be the empty type iff DefaultValue is the empty type. +%% * DefaultKey must not be a singleton type. +%% * For every key K in Pairs, DefaultKey - K must not be representable; i.e. +%% t_subtract(DefaultKey, K) must return DefaultKey. +%% * For every pair {K, 'optional', ?none} in Pairs, K must be a subtype of +%% DefaultKey. +%% * Pairs must be sorted and not contain any duplicate keys. +%% +%% These invariants ensure that equal map types are represented by equal terms. + +-define(mand, mandatory). +-define(opt, optional). + +-type t_map_mandatoriness() :: ?mand | ?opt. +-type t_map_pair() :: {erl_type(), t_map_mandatoriness(), erl_type()}. +-type t_map_dict() :: [t_map_pair()]. + +-spec t_map() -> erl_type(). + +t_map() -> + t_map([], t_any(), t_any()). + +-spec t_map([{erl_type(), erl_type()}]) -> erl_type(). + +t_map(L) -> + lists:foldl(fun t_map_put/2, t_map(), L). + +-spec t_map(t_map_dict(), erl_type(), erl_type()) -> erl_type(). + +t_map(Pairs0, DefK0, DefV0) -> + DefK1 = lists:foldl(fun({K,_,_},Acc)->t_subtract(Acc,K)end, DefK0, Pairs0), + {DefK2, DefV1} = + case t_is_none_or_unit(DefK1) orelse t_is_none_or_unit(DefV0) of + true -> {?none, ?none}; + false -> {DefK1, DefV0} + end, + {Pairs1, DefK, DefV} + = case is_singleton_type(DefK2) of + true -> {mapdict_insert({DefK2, ?opt, DefV1}, Pairs0), ?none, ?none}; + false -> {Pairs0, DefK2, DefV1} + end, + Pairs = normalise_map_optionals(Pairs1, DefK, DefV), + %% Validate invariants of the map representation. + %% Since we needed to iterate over the arguments in order to normalise anyway, + %% we might as well save us some future pain and do this even without + %% define(DEBUG, true). + try + validate_map_elements(Pairs) + catch error:badarg -> error(badarg, [Pairs0,DefK0,DefV0]); + error:{badarg, E} -> error({badarg, E}, [Pairs0,DefK0,DefV0]) + end, + ?map(Pairs, DefK, DefV). + +normalise_map_optionals([], _, _) -> []; +normalise_map_optionals([E={K,?opt,?none}|T], DefK, DefV) -> + Diff = t_subtract(DefK, K), + case t_is_subtype(K, DefK) andalso DefK =:= Diff of + true -> [E|normalise_map_optionals(T, DefK, DefV)]; + false -> normalise_map_optionals(T, Diff, DefV) + end; +normalise_map_optionals([E={K,?opt,V}|T], DefK, DefV) -> + case t_is_equal(V, DefV) andalso t_is_subtype(K, DefK) of + true -> normalise_map_optionals(T, DefK, DefV); + false -> [E|normalise_map_optionals(T, DefK, DefV)] + end; +normalise_map_optionals([E|T], DefK, DefV) -> + [E|normalise_map_optionals(T, DefK, DefV)]. + +validate_map_elements([{_,?mand,?none}|_]) -> error({badarg, none_in_mand}); +validate_map_elements([{K1,_,_}|Rest=[{K2,_,_}|_]]) -> + case is_singleton_type(K1) andalso K1 < K2 of + false -> error(badarg); + true -> validate_map_elements(Rest) + end; +validate_map_elements([{K,_,_}]) -> + case is_singleton_type(K) of + false -> error(badarg); + true -> true + end; +validate_map_elements([]) -> true. + +-spec t_is_map(erl_type()) -> boolean(). + +t_is_map(Type) -> + t_is_map(Type, 'universe'). + +-spec t_is_map(erl_type(), opaques()) -> boolean(). + +t_is_map(Type, Opaques) -> + do_opaque(Type, Opaques, fun is_map1/1). + +is_map1(?map(_, _, _)) -> true; +is_map1(_) -> false. + +-spec t_map_entries(erl_type()) -> t_map_dict(). + +t_map_entries(M) -> + t_map_entries(M, 'universe'). + +-spec t_map_entries(erl_type(), opaques()) -> t_map_dict(). + +t_map_entries(M, Opaques) -> + do_opaque(M, Opaques, fun map_entries/1). + +map_entries(?map(Pairs,_,_)) -> + Pairs. + +-spec t_map_def_key(erl_type()) -> erl_type(). + +t_map_def_key(M) -> + t_map_def_key(M, 'universe'). + +-spec t_map_def_key(erl_type(), opaques()) -> erl_type(). + +t_map_def_key(M, Opaques) -> + do_opaque(M, Opaques, fun map_def_key/1). + +map_def_key(?map(_,DefK,_)) -> + DefK. + +-spec t_map_def_val(erl_type()) -> erl_type(). + +t_map_def_val(M) -> + t_map_def_val(M, 'universe'). + +-spec t_map_def_val(erl_type(), opaques()) -> erl_type(). + +t_map_def_val(M, Opaques) -> + do_opaque(M, Opaques, fun map_def_val/1). + +map_def_val(?map(_,_,DefV)) -> + DefV. + +-spec mapdict_store(t_map_pair(), t_map_dict()) -> t_map_dict(). + +mapdict_store(E={K,_,_}, [{K,_,_}|T]) -> [E|T]; +mapdict_store(E1={K1,_,_}, [E2={K2,_,_}|T]) when K1 > K2 -> + [E2|mapdict_store(E1, T)]; +mapdict_store(E={_,_,_}, T) -> [E|T]. + +-spec mapdict_insert(t_map_pair(), t_map_dict()) -> t_map_dict(). + +mapdict_insert(E={K,_,_}, D=[{K,_,_}|_]) -> error(badarg, [E, D]); +mapdict_insert(E1={K1,_,_}, [E2={K2,_,_}|T]) when K1 > K2 -> + [E2|mapdict_insert(E1, T)]; +mapdict_insert(E={_,_,_}, T) -> [E|T]. + +%% Merges the pairs of two maps together. Missing pairs become (?opt, DefV) or +%% (?opt, ?none), depending on whether K \in DefK. +-spec map_pairwise_merge(fun((erl_type(), + t_map_mandatoriness(), erl_type(), + t_map_mandatoriness(), erl_type()) + -> t_map_pair() | false), + erl_type(), erl_type()) -> t_map_dict(). +map_pairwise_merge(F, ?map(APairs, ADefK, ADefV), + ?map(BPairs, BDefK, BDefV)) -> + map_pairwise_merge(F, APairs, ADefK, ADefV, BPairs, BDefK, BDefV). + +map_pairwise_merge(_, [], _, _, [], _, _) -> []; +map_pairwise_merge(F, As0, ADefK, ADefV, Bs0, BDefK, BDefV) -> + {K1, AMNess1, AV1, As1, BMNess1, BV1, Bs1} = + case {As0, Bs0} of + {[{K,AMNess,AV}|As], [{K, BMNess,BV}|Bs]} -> + {K, AMNess, AV, As, BMNess, BV, Bs}; + {[{K,AMNess,AV}|As], [{BK,_, _ }|_]=Bs} when K < BK -> + {K, AMNess, AV, As, ?opt, mapmerge_otherv(K, BDefK, BDefV), Bs}; + {As, [{K, BMNess,BV}|Bs]} -> + {K, ?opt, mapmerge_otherv(K, ADefK, ADefV), As, BMNess, BV, Bs}; + {[{K,AMNess,AV}|As], []=Bs} -> + {K, AMNess, AV, As, ?opt, mapmerge_otherv(K, BDefK, BDefV), Bs} + end, + MK = K1, %% Rename to make clear that we are matching below + case F(K1, AMNess1, AV1, BMNess1, BV1) of + false -> map_pairwise_merge(F,As1,ADefK,ADefV,Bs1,BDefK,BDefV); + {MK,_,_}=M -> [M|map_pairwise_merge(F,As1,ADefK,ADefV,Bs1,BDefK,BDefV)] + end. + +%% Folds over the pairs in two maps simultaneously in reverse key order. Missing +%% pairs become (?opt, DefV) or (?opt, ?none), depending on whether K \in DefK. +-spec map_pairwise_merge_foldr(fun((erl_type(), + t_map_mandatoriness(), erl_type(), + t_map_mandatoriness(), erl_type(), + Acc) -> Acc), + Acc, erl_type(), erl_type()) -> Acc. + +map_pairwise_merge_foldr(F, AccIn, ?map(APairs, ADefK, ADefV), + ?map(BPairs, BDefK, BDefV)) -> + map_pairwise_merge_foldr(F, AccIn, APairs, ADefK, ADefV, BPairs, BDefK, BDefV). + +map_pairwise_merge_foldr(_, Acc, [], _, _, [], _, _) -> Acc; +map_pairwise_merge_foldr(F, AccIn, As0, ADefK, ADefV, Bs0, BDefK, BDefV) -> + {K1, AMNess1, AV1, As1, BMNess1, BV1, Bs1} = + case {As0, Bs0} of + {[{K,AMNess,AV}|As], [{K,BMNess,BV}|Bs]} -> + {K, AMNess, AV, As, BMNess, BV, Bs}; + {[{K,AMNess,AV}|As], [{BK,_, _ }|_]=Bs} when K < BK -> + {K, AMNess, AV, As, ?opt, mapmerge_otherv(K, BDefK, BDefV), Bs}; + {As, [{K,BMNess,BV}|Bs]} -> + {K, ?opt, mapmerge_otherv(K, ADefK, ADefV), As, BMNess, BV, Bs}; + {[{K,AMNess,AV}|As], []=Bs} -> + {K, AMNess, AV, As, ?opt, mapmerge_otherv(K, BDefK, BDefV), Bs} + end, + F(K1, AMNess1, AV1, BMNess1, BV1, + map_pairwise_merge_foldr(F,AccIn,As1,ADefK,ADefV,Bs1,BDefK,BDefV)). + +%% By observing that a missing pair in a map is equivalent to an optional pair, +%% with ?none or DefV value, depending on whether K \in DefK, we can simplify +%% merging by denormalising the map pairs temporarily, removing all 'false' +%% cases, at the cost of the creation of more tuples: +mapmerge_otherv(K, ODefK, ODefV) -> + case t_inf(K, ODefK) of + ?none -> ?none; + _KOrOpaque -> ODefV + end. + +-spec t_map_put({erl_type(), erl_type()}, erl_type()) -> erl_type(). + +t_map_put(KV, Map) -> + t_map_put(KV, Map, 'universe'). + +-spec t_map_put({erl_type(), erl_type()}, erl_type(), opaques()) -> erl_type(). + +t_map_put(KV, Map, Opaques) -> + do_opaque(Map, Opaques, fun(UM) -> map_put(KV, UM, Opaques) end). + +%% Key and Value are *not* unopaqued, but the map is +map_put(_, ?none, _) -> ?none; +map_put({Key, Value}, ?map(Pairs,DefK,DefV), Opaques) -> + case t_is_none_or_unit(Key) orelse t_is_none_or_unit(Value) of + true -> ?none; + false -> + case is_singleton_type(Key) of + true -> + t_map(mapdict_store({Key, ?mand, Value}, Pairs), DefK, DefV); + false -> + t_map([{K, MNess, case t_is_none(t_inf(K, Key, Opaques)) of + true -> V; + false -> t_sup(V, Value) + end} || {K, MNess, V} <- Pairs], + t_sup(DefK, Key), + t_sup(DefV, Value)) + end + end. + +-spec t_map_update({erl_type(), erl_type()}, erl_type()) -> erl_type(). + +t_map_update(KV, Map) -> + t_map_update(KV, Map, 'universe'). + +-spec t_map_update({erl_type(), erl_type()}, erl_type(), opaques()) -> erl_type(). + +t_map_update(_, ?none, _) -> ?none; +t_map_update(KV={Key, _}, M, Opaques) -> + case t_is_subtype(t_atom('true'), t_map_is_key(Key, M, Opaques)) of + false -> ?none; + true -> t_map_put(KV, M, Opaques) + end. + +-spec t_map_get(erl_type(), erl_type()) -> erl_type(). + +t_map_get(Key, Map) -> + t_map_get(Key, Map, 'universe'). + +-spec t_map_get(erl_type(), erl_type(), opaques()) -> erl_type(). + +t_map_get(Key, Map, Opaques) -> + do_opaque(Map, Opaques, + fun(UM) -> + do_opaque(Key, Opaques, fun(UK) -> map_get(UK, UM) end) + end). + +map_get(_, ?none) -> ?none; +map_get(Key, ?map(Pairs, DefK, DefV)) -> + DefRes = + case t_do_overlap(DefK, Key) of + false -> t_none(); + true -> DefV + end, + case is_singleton_type(Key) of + false -> + lists:foldl(fun({K, _, V}, Res) -> + case t_do_overlap(K, Key) of + false -> Res; + true -> t_sup(Res, V) + end + end, DefRes, Pairs); + true -> + case lists:keyfind(Key, 1, Pairs) of + false -> DefRes; + {_, _, ValType} -> ValType + end + end. + +-spec t_map_is_key(erl_type(), erl_type()) -> erl_type(). + +t_map_is_key(Key, Map) -> + t_map_is_key(Key, Map, 'universe'). + +-spec t_map_is_key(erl_type(), erl_type(), opaques()) -> erl_type(). + +t_map_is_key(Key, Map, Opaques) -> + do_opaque(Map, Opaques, + fun(UM) -> + do_opaque(Key, Opaques, fun(UK) -> map_is_key(UK, UM) end) + end). + +map_is_key(_, ?none) -> ?none; +map_is_key(Key, ?map(Pairs, DefK, _DefV)) -> + case is_singleton_type(Key) of + true -> + case lists:keyfind(Key, 1, Pairs) of + {Key, ?mand, _} -> t_atom(true); + {Key, ?opt, ?none} -> t_atom(false); + {Key, ?opt, _} -> t_boolean(); + false -> + case t_do_overlap(DefK, Key) of + false -> t_atom(false); + true -> t_boolean() + end + end; + false -> + case t_do_overlap(DefK, Key) + orelse lists:any(fun({_,_,?none}) -> false; + ({K,_,_}) -> t_do_overlap(K, Key) + end, Pairs) + of + true -> t_boolean(); + false -> t_atom(false) + end + end. + +%%----------------------------------------------------------------------------- +%% Tuples +%% + +-spec t_tuple() -> erl_type(). + +t_tuple() -> + ?tuple(?any, ?any, ?any). + +-spec t_tuple(non_neg_integer() | [erl_type()]) -> erl_type(). + +t_tuple(N) when is_integer(N), N > ?MAX_TUPLE_SIZE -> + t_tuple(); +t_tuple(N) when is_integer(N) -> + ?tuple(lists:duplicate(N, ?any), N, ?any); +t_tuple(List) -> + case any_none_or_unit(List) of + true -> t_none(); + false -> + Arity = length(List), + case get_tuple_tags(List) of + [Tag] -> ?tuple(List, Arity, Tag); %% Tag can also be ?any here + TagList -> + SortedTagList = lists:sort(TagList), + Tuples = [?tuple([T|tl(List)], Arity, T) || T <- SortedTagList], + ?tuple_set([{Arity, Tuples}]) + end + end. + +-spec get_tuple_tags([erl_type()]) -> [erl_type(),...]. + +get_tuple_tags([Tag|_]) -> + do_opaque(Tag, 'universe', fun tuple_tags/1); +get_tuple_tags(_) -> [?any]. + +tuple_tags(?atom(?any)) -> [?any]; +tuple_tags(?atom(Set)) -> + case set_size(Set) > ?TUPLE_TAG_LIMIT of + true -> [?any]; + false -> [t_atom(A) || A <- set_to_list(Set)] + end; +tuple_tags(_) -> [?any]. + +%% to be used for a tuple with known types for its arguments (not ?any) +-spec t_tuple_args(erl_type()) -> [erl_type()]. + +t_tuple_args(Type) -> + t_tuple_args(Type, 'universe'). + +%% to be used for a tuple with known types for its arguments (not ?any) +-spec t_tuple_args(erl_type(), opaques()) -> [erl_type()]. + +t_tuple_args(Type, Opaques) -> + do_opaque(Type, Opaques, fun tuple_args/1). + +tuple_args(?tuple(Args, _, _)) when is_list(Args) -> Args. + +%% to be used for a tuple with a known size (not ?any) +-spec t_tuple_size(erl_type()) -> non_neg_integer(). + +t_tuple_size(Type) -> + t_tuple_size(Type, 'universe'). + +%% to be used for a tuple with a known size (not ?any) +-spec t_tuple_size(erl_type(), opaques()) -> non_neg_integer(). + +t_tuple_size(Type, Opaques) -> + do_opaque(Type, Opaques, fun tuple_size1/1). + +tuple_size1(?tuple(_, Size, _)) when is_integer(Size) -> Size. + +-spec t_tuple_sizes(erl_type()) -> 'unknown' | [non_neg_integer(),...]. + +t_tuple_sizes(Type) -> + do_opaque(Type, 'universe', fun tuple_sizes/1). + +tuple_sizes(?tuple(?any, ?any, ?any)) -> unknown; +tuple_sizes(?tuple(_, Size, _)) when is_integer(Size) -> [Size]; +tuple_sizes(?tuple_set(List)) -> [Size || {Size, _} <- List]. + +-spec t_tuple_subtypes(erl_type(), opaques()) -> + 'unknown' | [erl_type(),...]. + +t_tuple_subtypes(Type, Opaques) -> + Fun = fun(?tuple_set(List)) -> + t_tuple_subtypes_tuple_list(List, Opaques); + (?opaque(_)) -> unknown; + (T) -> t_tuple_subtypes(T) + end, + do_opaque(Type, Opaques, Fun). + +t_tuple_subtypes_tuple_list(List, Opaques) -> + lists:append([t_tuple_subtypes_list(Tuples, Opaques) || + {_Size, Tuples} <- List]). + +t_tuple_subtypes_list(List, Opaques) -> + ListOfLists = [t_tuple_subtypes(E, Opaques) || E <- List, E =/= ?none], + lists:append([L || L <- ListOfLists, L =/= 'unknown']). + +-spec t_tuple_subtypes(erl_type()) -> 'unknown' | [erl_type(),...]. + +%% XXX. Not the same as t_tuple_subtypes(T, 'universe')... +t_tuple_subtypes(?tuple(?any, ?any, ?any)) -> unknown; +t_tuple_subtypes(?tuple(_, _, _) = T) -> [T]; +t_tuple_subtypes(?tuple_set(List)) -> + lists:append([Tuples || {_Size, Tuples} <- List]). + +-spec t_is_tuple(erl_type()) -> boolean(). + +t_is_tuple(Type) -> + t_is_tuple(Type, 'universe'). + +-spec t_is_tuple(erl_type(), opaques()) -> boolean(). + +t_is_tuple(Type, Opaques) -> + do_opaque(Type, Opaques, fun is_tuple1/1). + +is_tuple1(?tuple(_, _, _)) -> true; +is_tuple1(?tuple_set(_)) -> true; +is_tuple1(_) -> false. + +%%----------------------------------------------------------------------------- +%% Non-primitive types, including some handy syntactic sugar types +%% + +-spec t_bitstrlist() -> erl_type(). + +t_bitstrlist() -> + t_iolist(1, t_bitstr()). + +-spec t_arity() -> erl_type(). + +t_arity() -> + t_from_range(0, 255). % was t_byte(). + +-spec t_pos_integer() -> erl_type(). + +t_pos_integer() -> + t_from_range(1, pos_inf). + +-spec t_non_neg_integer() -> erl_type(). + +t_non_neg_integer() -> + t_from_range(0, pos_inf). + +-spec t_is_non_neg_integer(erl_type()) -> boolean(). + +t_is_non_neg_integer(?integer(_) = T) -> + t_is_subtype(T, t_non_neg_integer()); +t_is_non_neg_integer(_) -> false. + +-spec t_neg_integer() -> erl_type(). + +t_neg_integer() -> + t_from_range(neg_inf, -1). + +-spec t_fixnum() -> erl_type(). + +t_fixnum() -> + t_integer(). % Gross over-approximation + +-spec t_pos_fixnum() -> erl_type(). + +t_pos_fixnum() -> + t_pos_integer(). % Gross over-approximation + +-spec t_non_neg_fixnum() -> erl_type(). + +t_non_neg_fixnum() -> + t_non_neg_integer(). % Gross over-approximation + +-spec t_mfa() -> erl_type(). + +t_mfa() -> + t_tuple([t_atom(), t_atom(), t_arity()]). + +-spec t_module() -> erl_type(). + +t_module() -> + t_atom(). + +-spec t_node() -> erl_type(). + +t_node() -> + t_atom(). + +-spec t_iodata() -> erl_type(). + +t_iodata() -> + t_sup(t_iolist(), t_binary()). + +-spec t_iolist() -> erl_type(). + +t_iolist() -> + t_iolist(1, t_binary()). + +%% Added a second argument which currently is t_binary() | t_bitstr() +-spec t_iolist(non_neg_integer(), erl_type()) -> erl_type(). + +t_iolist(N, T) when N > 0 -> + t_maybe_improper_list(t_sup([t_iolist(N-1, T), T, t_byte()]), + t_sup(T, t_nil())); +t_iolist(0, T) -> + t_maybe_improper_list(t_any(), t_sup(T, t_nil())). + +-spec t_timeout() -> erl_type(). + +t_timeout() -> + t_sup(t_non_neg_integer(), t_atom('infinity')). + +%%------------------------------------ + +%% ?none is allowed in products. A product of size 1 is not a product. + +-spec t_product([erl_type()]) -> erl_type(). + +t_product([T]) -> T; +t_product(Types) when is_list(Types) -> + ?product(Types). + +%% This function is intended to be the inverse of the one above. +%% It should NOT be used with ?any, ?none or ?unit as input argument. + +-spec t_to_tlist(erl_type()) -> [erl_type()]. + +t_to_tlist(?product(Types)) -> Types; +t_to_tlist(T) when T =/= ?any orelse T =/= ?none orelse T =/= ?unit -> [T]. + +%%------------------------------------ + +-spec t_var(atom() | integer()) -> erl_type(). + +t_var(Atom) when is_atom(Atom) -> ?var(Atom); +t_var(Int) when is_integer(Int) -> ?var(Int). + +-spec t_is_var(erl_type()) -> boolean(). + +t_is_var(?var(_)) -> true; +t_is_var(_) -> false. + +-spec t_var_name(erl_type()) -> atom() | integer(). + +t_var_name(?var(Id)) -> Id. + +-spec t_has_var(erl_type()) -> boolean(). + +t_has_var(?var(_)) -> true; +t_has_var(?function(Domain, Range)) -> + t_has_var(Domain) orelse t_has_var(Range); +t_has_var(?list(Contents, Termination, _)) -> + t_has_var(Contents) orelse t_has_var(Termination); +t_has_var(?product(Types)) -> t_has_var_list(Types); +t_has_var(?tuple(?any, ?any, ?any)) -> false; +t_has_var(?tuple(Elements, _, _)) -> + t_has_var_list(Elements); +t_has_var(?tuple_set(_) = T) -> + t_has_var_list(t_tuple_subtypes(T)); +t_has_var(?map(_, DefK, _)= Map) -> + t_has_var_list(map_all_values(Map)) orelse + t_has_var(DefK); +t_has_var(?opaque(Set)) -> + %% Assume variables in 'args' are also present i 'struct' + t_has_var_list([O#opaque.struct || O <- set_to_list(Set)]); +t_has_var(?union(List)) -> + t_has_var_list(List); +t_has_var(_) -> false. + +-spec t_has_var_list([erl_type()]) -> boolean(). + +t_has_var_list([T|Ts]) -> + t_has_var(T) orelse t_has_var_list(Ts); +t_has_var_list([]) -> false. + +-spec t_collect_vars(erl_type()) -> [erl_type()]. + +t_collect_vars(T) -> + t_collect_vars(T, []). + +-spec t_collect_vars(erl_type(), [erl_type()]) -> [erl_type()]. + +t_collect_vars(?var(_) = Var, Acc) -> + ordsets:add_element(Var, Acc); +t_collect_vars(?function(Domain, Range), Acc) -> + ordsets:union(t_collect_vars(Domain, Acc), t_collect_vars(Range, [])); +t_collect_vars(?list(Contents, Termination, _), Acc) -> + ordsets:union(t_collect_vars(Contents, Acc), t_collect_vars(Termination, [])); +t_collect_vars(?product(Types), Acc) -> + t_collect_vars_list(Types, Acc); +t_collect_vars(?tuple(?any, ?any, ?any), Acc) -> + Acc; +t_collect_vars(?tuple(Types, _, _), Acc) -> + t_collect_vars_list(Types, Acc); +t_collect_vars(?tuple_set(_) = TS, Acc) -> + t_collect_vars_list(t_tuple_subtypes(TS), Acc); +t_collect_vars(?map(_, DefK, _) = Map, Acc0) -> + Acc = t_collect_vars_list(map_all_values(Map), Acc0), + t_collect_vars(DefK, Acc); +t_collect_vars(?opaque(Set), Acc) -> + %% Assume variables in 'args' are also present i 'struct' + t_collect_vars_list([O#opaque.struct || O <- set_to_list(Set)], Acc); +t_collect_vars(?union(List), Acc) -> + t_collect_vars_list(List, Acc); +t_collect_vars(_, Acc) -> + Acc. + +t_collect_vars_list([T|Ts], Acc0) -> + Acc = t_collect_vars(T, Acc0), + t_collect_vars_list(Ts, Acc); +t_collect_vars_list([], Acc) -> Acc. + +%%============================================================================= +%% +%% Type construction from Erlang terms. +%% +%%============================================================================= + +%%----------------------------------------------------------------------------- +%% Make a type from a term. No type depth is enforced. +%% + +-spec t_from_term(term()) -> erl_type(). + +t_from_term([H|T]) -> t_cons(t_from_term(H), t_from_term(T)); +t_from_term([]) -> t_nil(); +t_from_term(T) when is_atom(T) -> t_atom(T); +t_from_term(T) when is_bitstring(T) -> t_bitstr(0, erlang:bit_size(T)); +t_from_term(T) when is_float(T) -> t_float(); +t_from_term(T) when is_function(T) -> + {arity, Arity} = erlang:fun_info(T, arity), + t_fun(Arity, t_any()); +t_from_term(T) when is_integer(T) -> t_integer(T); +t_from_term(T) when is_map(T) -> + Pairs = [{t_from_term(K), ?mand, t_from_term(V)} + || {K, V} <- maps:to_list(T)], + {Stons, Rest} = lists:partition(fun({K,_,_}) -> is_singleton_type(K) end, + Pairs), + {DefK, DefV} + = lists:foldl(fun({K,_,V},{AK,AV}) -> {t_sup(K,AK), t_sup(V,AV)} end, + {t_none(), t_none()}, Rest), + t_map(lists:keysort(1, Stons), DefK, DefV); +t_from_term(T) when is_pid(T) -> t_pid(); +t_from_term(T) when is_port(T) -> t_port(); +t_from_term(T) when is_reference(T) -> t_reference(); +t_from_term(T) when is_tuple(T) -> + t_tuple([t_from_term(E) || E <- tuple_to_list(T)]). + +%%----------------------------------------------------------------------------- +%% Integer types from a range. +%%----------------------------------------------------------------------------- + +%%-define(USE_UNSAFE_RANGES, true). + +-spec t_from_range(rng_elem(), rng_elem()) -> erl_type(). + +-ifdef(USE_UNSAFE_RANGES). + +t_from_range(X, Y) -> + t_from_range_unsafe(X, Y). + +-else. + +t_from_range(neg_inf, pos_inf) -> t_integer(); +t_from_range(neg_inf, Y) when is_integer(Y), Y < 0 -> ?integer_neg; +t_from_range(neg_inf, Y) when is_integer(Y), Y >= 0 -> t_integer(); +t_from_range(X, pos_inf) when is_integer(X), X >= 1 -> ?integer_pos; +t_from_range(X, pos_inf) when is_integer(X), X >= 0 -> ?integer_non_neg; +t_from_range(X, pos_inf) when is_integer(X), X < 0 -> t_integer(); +t_from_range(X, Y) when is_integer(X), is_integer(Y), X > Y -> t_none(); +t_from_range(X, Y) when is_integer(X), is_integer(Y) -> + case ((Y - X) < ?SET_LIMIT) of + true -> t_integers(lists:seq(X, Y)); + false -> + case X >= 0 of + false -> + if Y < 0 -> ?integer_neg; + true -> t_integer() + end; + true -> + if Y =< ?MAX_BYTE, X >= 1 -> ?int_range(1, ?MAX_BYTE); + Y =< ?MAX_BYTE -> t_byte(); + Y =< ?MAX_CHAR, X >= 1 -> ?int_range(1, ?MAX_CHAR); + Y =< ?MAX_CHAR -> t_char(); + X >= 1 -> ?integer_pos; + X >= 0 -> ?integer_non_neg + end + end + end; +t_from_range(pos_inf, neg_inf) -> t_none(). + +-endif. + +-spec t_from_range_unsafe(rng_elem(), rng_elem()) -> erl_type(). + +t_from_range_unsafe(neg_inf, pos_inf) -> t_integer(); +t_from_range_unsafe(neg_inf, Y) -> ?int_range(neg_inf, Y); +t_from_range_unsafe(X, pos_inf) -> ?int_range(X, pos_inf); +t_from_range_unsafe(X, Y) when is_integer(X), is_integer(Y), X =< Y -> + if (Y - X) < ?SET_LIMIT -> t_integers(lists:seq(X, Y)); + true -> ?int_range(X, Y) + end; +t_from_range_unsafe(X, Y) when is_integer(X), is_integer(Y) -> t_none(); +t_from_range_unsafe(pos_inf, neg_inf) -> t_none(). + +-spec t_is_fixnum(erl_type()) -> boolean(). + +t_is_fixnum(?int_range(neg_inf, _)) -> false; +t_is_fixnum(?int_range(_, pos_inf)) -> false; +t_is_fixnum(?int_range(From, To)) -> + is_fixnum(From) andalso is_fixnum(To); +t_is_fixnum(?int_set(Set)) -> + is_fixnum(set_min(Set)) andalso is_fixnum(set_max(Set)); +t_is_fixnum(_) -> false. + +-spec is_fixnum(integer()) -> boolean(). + +is_fixnum(N) when is_integer(N) -> + Bits = ?BITS, + (N =< ((1 bsl (Bits - 1)) - 1)) andalso (N >= -(1 bsl (Bits - 1))). + +infinity_geq(pos_inf, _) -> true; +infinity_geq(_, pos_inf) -> false; +infinity_geq(_, neg_inf) -> true; +infinity_geq(neg_inf, _) -> false; +infinity_geq(A, B) -> A >= B. + +-spec t_is_bitwidth(erl_type()) -> boolean(). + +t_is_bitwidth(?int_range(neg_inf, _)) -> false; +t_is_bitwidth(?int_range(_, pos_inf)) -> false; +t_is_bitwidth(?int_range(From, To)) -> + infinity_geq(From, 0) andalso infinity_geq(?BITS, To); +t_is_bitwidth(?int_set(Set)) -> + infinity_geq(set_min(Set), 0) andalso infinity_geq(?BITS, set_max(Set)); +t_is_bitwidth(_) -> false. + +-spec number_min(erl_type()) -> rng_elem(). + +number_min(Type) -> + number_min(Type, 'universe'). + +-spec number_min(erl_type(), opaques()) -> rng_elem(). + +number_min(Type, Opaques) -> + do_opaque(Type, Opaques, fun number_min2/1). + +number_min2(?int_range(From, _)) -> From; +number_min2(?int_set(Set)) -> set_min(Set); +number_min2(?number(?any, _Tag)) -> neg_inf. + +-spec number_max(erl_type()) -> rng_elem(). + +number_max(Type) -> + number_max(Type, 'universe'). + +-spec number_max(erl_type(), opaques()) -> rng_elem(). + +number_max(Type, Opaques) -> + do_opaque(Type, Opaques, fun number_max2/1). + +number_max2(?int_range(_, To)) -> To; +number_max2(?int_set(Set)) -> set_max(Set); +number_max2(?number(?any, _Tag)) -> pos_inf. + +%% -spec int_range(rgn_elem(), rng_elem()) -> erl_type(). +%% +%% int_range(neg_inf, pos_inf) -> t_integer(); +%% int_range(neg_inf, To) -> ?int_range(neg_inf, To); +%% int_range(From, pos_inf) -> ?int_range(From, pos_inf); +%% int_range(From, To) when From =< To -> t_from_range(From, To); +%% int_range(From, To) when To < From -> ?none. + +in_range(_, ?int_range(neg_inf, pos_inf)) -> true; +in_range(X, ?int_range(From, pos_inf)) -> X >= From; +in_range(X, ?int_range(neg_inf, To)) -> X =< To; +in_range(X, ?int_range(From, To)) -> (X >= From) andalso (X =< To). + +-spec min(rng_elem(), rng_elem()) -> rng_elem(). + +min(neg_inf, _) -> neg_inf; +min(_, neg_inf) -> neg_inf; +min(pos_inf, Y) -> Y; +min(X, pos_inf) -> X; +min(X, Y) when X =< Y -> X; +min(_, Y) -> Y. + +-spec max(rng_elem(), rng_elem()) -> rng_elem(). + +max(neg_inf, Y) -> Y; +max(X, neg_inf) -> X; +max(pos_inf, _) -> pos_inf; +max(_, pos_inf) -> pos_inf; +max(X, Y) when X =< Y -> Y; +max(X, _) -> X. + +expand_range_from_set(Range = ?int_range(From, To), Set) -> + Min = min(set_min(Set), From), + Max = max(set_max(Set), To), + if From =:= Min, To =:= Max -> Range; + true -> t_from_range(Min, Max) + end. + +%%============================================================================= +%% +%% Lattice operations +%% +%%============================================================================= + +%%----------------------------------------------------------------------------- +%% Supremum +%% + +-spec t_sup([erl_type()]) -> erl_type(). + +t_sup([]) -> ?none; +t_sup(Ts) -> + case lists:any(fun is_any/1, Ts) of + true -> ?any; + false -> + t_sup1(Ts, []) + end. + +t_sup1([H1, H2|T], L) -> + t_sup1(T, [t_sup(H1, H2)|L]); +t_sup1([T], []) -> subst_all_vars_to_any(T); +t_sup1(Ts, L) -> + t_sup1(Ts++L, []). + +-spec t_sup(erl_type(), erl_type()) -> erl_type(). + +t_sup(?any, _) -> ?any; +t_sup(_, ?any) -> ?any; +t_sup(?none, T) -> T; +t_sup(T, ?none) -> T; +t_sup(?unit, T) -> T; +t_sup(T, ?unit) -> T; +t_sup(T, T) -> subst_all_vars_to_any(T); +t_sup(?var(_), _) -> ?any; +t_sup(_, ?var(_)) -> ?any; +t_sup(?atom(Set1), ?atom(Set2)) -> + ?atom(set_union(Set1, Set2)); +t_sup(?bitstr(U1, B1), ?bitstr(U2, B2)) -> + t_bitstr(gcd(gcd(U1, U2), abs(B1-B2)), lists:min([B1, B2])); +t_sup(?function(Domain1, Range1), ?function(Domain2, Range2)) -> + %% The domain is either a product or any. + ?function(t_sup(Domain1, Domain2), t_sup(Range1, Range2)); +t_sup(?identifier(Set1), ?identifier(Set2)) -> + ?identifier(set_union(Set1, Set2)); +t_sup(?opaque(Set1), ?opaque(Set2)) -> + sup_opaque(set_to_list(ordsets:union(Set1, Set2))); +%%Disallow unions with opaque types +%%t_sup(T1=?opaque(_,_,_), T2) -> +%% io:format("Debug: t_sup executed with args ~w and ~w~n",[T1, T2]), ?none; +%%t_sup(T1, T2=?opaque(_,_,_)) -> +%% io:format("Debug: t_sup executed with args ~w and ~w~n",[T1, T2]), ?none; +t_sup(?matchstate(Pres1, Slots1), ?matchstate(Pres2, Slots2)) -> + ?matchstate(t_sup(Pres1, Pres2), t_sup(Slots1, Slots2)); +t_sup(?nil, ?nil) -> ?nil; +t_sup(?nil, ?list(Contents, Termination, _)) -> + ?list(Contents, t_sup(?nil, Termination), ?unknown_qual); +t_sup(?list(Contents, Termination, _), ?nil) -> + ?list(Contents, t_sup(?nil, Termination), ?unknown_qual); +t_sup(?list(Contents1, Termination1, Size1), + ?list(Contents2, Termination2, Size2)) -> + NewSize = + case {Size1, Size2} of + {?unknown_qual, ?unknown_qual} -> ?unknown_qual; + {?unknown_qual, ?nonempty_qual} -> ?unknown_qual; + {?nonempty_qual, ?unknown_qual} -> ?unknown_qual; + {?nonempty_qual, ?nonempty_qual} -> ?nonempty_qual + end, + NewContents = t_sup(Contents1, Contents2), + NewTermination = t_sup(Termination1, Termination2), + TmpList = t_cons(NewContents, NewTermination), + case NewSize of + ?nonempty_qual -> TmpList; + ?unknown_qual -> + ?list(FinalContents, FinalTermination, _) = TmpList, + ?list(FinalContents, FinalTermination, ?unknown_qual) + end; +t_sup(?number(_, _), ?number(?any, ?unknown_qual) = T) -> T; +t_sup(?number(?any, ?unknown_qual) = T, ?number(_, _)) -> T; +t_sup(?float, ?float) -> ?float; +t_sup(?float, ?integer(_)) -> t_number(); +t_sup(?integer(_), ?float) -> t_number(); +t_sup(?integer(?any) = T, ?integer(_)) -> T; +t_sup(?integer(_), ?integer(?any) = T) -> T; +t_sup(?int_set(Set1), ?int_set(Set2)) -> + case set_union(Set1, Set2) of + ?any -> + t_from_range(min(set_min(Set1), set_min(Set2)), + max(set_max(Set1), set_max(Set2))); + Set -> ?int_set(Set) + end; +t_sup(?int_range(From1, To1), ?int_range(From2, To2)) -> + t_from_range(min(From1, From2), max(To1, To2)); +t_sup(Range = ?int_range(_, _), ?int_set(Set)) -> + expand_range_from_set(Range, Set); +t_sup(?int_set(Set), Range = ?int_range(_, _)) -> + expand_range_from_set(Range, Set); +t_sup(?product(Types1), ?product(Types2)) -> + L1 = length(Types1), + L2 = length(Types2), + if L1 =:= L2 -> ?product(t_sup_lists(Types1, Types2)); + true -> ?any + end; +t_sup(?product(_), _) -> + ?any; +t_sup(_, ?product(_)) -> + ?any; +t_sup(?tuple(?any, ?any, ?any) = T, ?tuple(_, _, _)) -> T; +t_sup(?tuple(_, _, _), ?tuple(?any, ?any, ?any) = T) -> T; +t_sup(?tuple(?any, ?any, ?any) = T, ?tuple_set(_)) -> T; +t_sup(?tuple_set(_), ?tuple(?any, ?any, ?any) = T) -> T; +t_sup(?tuple(Elements1, Arity, Tag1) = T1, + ?tuple(Elements2, Arity, Tag2) = T2) -> + if Tag1 =:= Tag2 -> t_tuple(t_sup_lists(Elements1, Elements2)); + Tag1 =:= ?any -> t_tuple(t_sup_lists(Elements1, Elements2)); + Tag2 =:= ?any -> t_tuple(t_sup_lists(Elements1, Elements2)); + Tag1 < Tag2 -> ?tuple_set([{Arity, [T1, T2]}]); + Tag1 > Tag2 -> ?tuple_set([{Arity, [T2, T1]}]) + end; +t_sup(?tuple(_, Arity1, _) = T1, ?tuple(_, Arity2, _) = T2) -> + sup_tuple_sets([{Arity1, [T1]}], [{Arity2, [T2]}]); +t_sup(?tuple_set(List1), ?tuple_set(List2)) -> + sup_tuple_sets(List1, List2); +t_sup(?tuple_set(List1), T2 = ?tuple(_, Arity, _)) -> + sup_tuple_sets(List1, [{Arity, [T2]}]); +t_sup(?tuple(_, Arity, _) = T1, ?tuple_set(List2)) -> + sup_tuple_sets([{Arity, [T1]}], List2); +t_sup(?map(_, ADefK, ADefV) = A, ?map(_, BDefK, BDefV) = B) -> + Pairs = + map_pairwise_merge( + fun(K, MNess, V1, MNess, V2) -> {K, MNess, t_sup(V1, V2)}; + (K, _, V1, _, V2) -> {K, ?opt, t_sup(V1, V2)} + end, A, B), + t_map(Pairs, t_sup(ADefK, BDefK), t_sup(ADefV, BDefV)); +t_sup(T1, T2) -> + ?union(U1) = force_union(T1), + ?union(U2) = force_union(T2), + sup_union(U1, U2). + +sup_opaque([]) -> ?none; +sup_opaque(List) -> + L = sup_opaq(List), + ?opaque(ordsets:from_list(L)). + +sup_opaq(L0) -> + L1 = [{{Mod,Name,Args}, T} || + #opaque{mod = Mod, name = Name, args = Args}=T <- L0], + F = family(L1), + [supl(Ts) || {_, Ts} <- F]. + +supl([O]) -> O; +supl(Ts) -> supl(Ts, t_none()). + +supl([#opaque{struct = S}=O|L], S0) -> + S1 = t_sup(S, S0), + case L =:= [] of + true -> O#opaque{struct = S1}; + false -> supl(L, S1) + end. + +-spec t_sup_lists([erl_type()], [erl_type()]) -> [erl_type()]. + +t_sup_lists([T1|Left1], [T2|Left2]) -> + [t_sup(T1, T2)|t_sup_lists(Left1, Left2)]; +t_sup_lists([], []) -> + []. + +sup_tuple_sets(L1, L2) -> + TotalArities = ordsets:union([Arity || {Arity, _} <- L1], + [Arity || {Arity, _} <- L2]), + if length(TotalArities) > ?TUPLE_ARITY_LIMIT -> t_tuple(); + true -> + case sup_tuple_sets(L1, L2, []) of + [{_Arity, [OneTuple = ?tuple(_, _, _)]}] -> OneTuple; + List -> ?tuple_set(List) + end + end. + +sup_tuple_sets([{Arity, Tuples1}|Left1], [{Arity, Tuples2}|Left2], Acc) -> + NewAcc = [{Arity, sup_tuples_in_set(Tuples1, Tuples2)}|Acc], + sup_tuple_sets(Left1, Left2, NewAcc); +sup_tuple_sets([{Arity1, _} = T1|Left1] = L1, + [{Arity2, _} = T2|Left2] = L2, Acc) -> + if Arity1 < Arity2 -> sup_tuple_sets(Left1, L2, [T1|Acc]); + Arity1 > Arity2 -> sup_tuple_sets(L1, Left2, [T2|Acc]) + end; +sup_tuple_sets([], L2, Acc) -> lists:reverse(Acc, L2); +sup_tuple_sets(L1, [], Acc) -> lists:reverse(Acc, L1). + +sup_tuples_in_set([?tuple(_, _, ?any) = T], L) -> + [t_tuple(sup_tuple_elements([T|L]))]; +sup_tuples_in_set(L, [?tuple(_, _, ?any) = T]) -> + [t_tuple(sup_tuple_elements([T|L]))]; +sup_tuples_in_set(L1, L2) -> + FoldFun = fun(?tuple(_, _, Tag), AccTag) -> t_sup(Tag, AccTag) end, + TotalTag0 = lists:foldl(FoldFun, ?none, L1), + TotalTag = lists:foldl(FoldFun, TotalTag0, L2), + case TotalTag of + ?atom(?any) -> + %% We will reach the set limit. Widen now. + [t_tuple(sup_tuple_elements(L1 ++ L2))]; + ?atom(Set) -> + case set_size(Set) > ?TUPLE_TAG_LIMIT of + true -> + %% We will reach the set limit. Widen now. + [t_tuple(sup_tuple_elements(L1 ++ L2))]; + false -> + %% We can go on and build the tuple set. + sup_tuples_in_set(L1, L2, []) + end + end. + +sup_tuple_elements([?tuple(Elements, _, _)|L]) -> + lists:foldl(fun (?tuple(Es, _, _), Acc) -> t_sup_lists(Es, Acc) end, + Elements, L). + +sup_tuples_in_set([?tuple(Elements1, Arity, Tag1) = T1|Left1] = L1, + [?tuple(Elements2, Arity, Tag2) = T2|Left2] = L2, Acc) -> + if + Tag1 < Tag2 -> sup_tuples_in_set(Left1, L2, [T1|Acc]); + Tag1 > Tag2 -> sup_tuples_in_set(L1, Left2, [T2|Acc]); + Tag2 =:= Tag2 -> NewElements = t_sup_lists(Elements1, Elements2), + NewAcc = [?tuple(NewElements, Arity, Tag1)|Acc], + sup_tuples_in_set(Left1, Left2, NewAcc) + end; +sup_tuples_in_set([], L2, Acc) -> lists:reverse(Acc, L2); +sup_tuples_in_set(L1, [], Acc) -> lists:reverse(Acc, L1). + +sup_union(U1, U2) -> + sup_union(U1, U2, 0, []). + +sup_union([?none|Left1], [?none|Left2], N, Acc) -> + sup_union(Left1, Left2, N, [?none|Acc]); +sup_union([T1|Left1], [T2|Left2], N, Acc) -> + sup_union(Left1, Left2, N+1, [t_sup(T1, T2)|Acc]); +sup_union([], [], N, Acc) -> + if N =:= 0 -> ?none; + N =:= 1 -> + [Type] = [T || T <- Acc, T =/= ?none], + Type; + N =:= length(Acc) -> ?any; + true -> ?union(lists:reverse(Acc)) + end. + +force_union(T = ?atom(_)) -> ?atom_union(T); +force_union(T = ?bitstr(_, _)) -> ?bitstr_union(T); +force_union(T = ?function(_, _)) -> ?function_union(T); +force_union(T = ?identifier(_)) -> ?identifier_union(T); +force_union(T = ?list(_, _, _)) -> ?list_union(T); +force_union(T = ?nil) -> ?list_union(T); +force_union(T = ?number(_, _)) -> ?number_union(T); +force_union(T = ?opaque(_)) -> ?opaque_union(T); +force_union(T = ?map(_,_,_)) -> ?map_union(T); +force_union(T = ?tuple(_, _, _)) -> ?tuple_union(T); +force_union(T = ?tuple_set(_)) -> ?tuple_union(T); +force_union(T = ?matchstate(_, _)) -> ?matchstate_union(T); +force_union(T = ?union(_)) -> T. + +%%----------------------------------------------------------------------------- +%% An attempt to write the inverse operation of t_sup/1 -- XXX: INCOMPLETE !! +%% + +-spec t_elements(erl_type()) -> [erl_type()]. + +t_elements(?none) -> []; +t_elements(?unit) -> []; +t_elements(?any = T) -> [T]; +t_elements(?nil = T) -> [T]; +t_elements(?atom(?any) = T) -> [T]; +t_elements(?atom(Atoms)) -> + [t_atom(A) || A <- Atoms]; +t_elements(?bitstr(_, _) = T) -> [T]; +t_elements(?function(_, _) = T) -> [T]; +t_elements(?identifier(?any) = T) -> [T]; +t_elements(?identifier(IDs)) -> + [?identifier([T]) || T <- IDs]; +t_elements(?list(_, _, _) = T) -> [T]; +t_elements(?number(_, _) = T) -> + case T of + ?number(?any, ?unknown_qual) -> + [?float, ?integer(?any)]; + ?float -> [T]; + ?integer(?any) -> [T]; + ?int_range(_, _) -> [T]; + ?int_set(Set) -> + [t_integer(I) || I <- Set] + end; +t_elements(?opaque(_) = T) -> + do_elements(T); +t_elements(?map(_,_,_) = T) -> [T]; +t_elements(?tuple(_, _, _) = T) -> [T]; +t_elements(?tuple_set(_) = TS) -> + case t_tuple_subtypes(TS) of + unknown -> []; + Elems -> Elems + end; +t_elements(?union(_) = T) -> + do_elements(T); +t_elements(?var(_)) -> [?any]. %% yes, vars exist -- what else to do here? +%% t_elements(T) -> +%% io:format("T_ELEMENTS => ~p\n", [T]). + +do_elements(Type0) -> + case do_opaque(Type0, 'universe', fun(T) -> T end) of + ?union(List) -> lists:append([t_elements(T) || T <- List]); + Type -> t_elements(Type) + end. + +%%----------------------------------------------------------------------------- +%% Infimum +%% + +-spec t_inf([erl_type()]) -> erl_type(). + +t_inf([H1, H2|T]) -> + case t_inf(H1, H2) of + ?none -> ?none; + NewH -> t_inf([NewH|T]) + end; +t_inf([H]) -> H; +t_inf([]) -> ?none. + +-spec t_inf(erl_type(), erl_type()) -> erl_type(). + +t_inf(T1, T2) -> + t_inf(T1, T2, 'universe'). + +%% 'match' should be used from t_find_unknown_opaque() only +-type t_inf_opaques() :: opaques() | {'match', [erl_type() | 'universe']}. + +-spec t_inf(erl_type(), erl_type(), t_inf_opaques()) -> erl_type(). + +t_inf(?var(_), ?var(_), _Opaques) -> ?any; +t_inf(?var(_), T, _Opaques) -> subst_all_vars_to_any(T); +t_inf(T, ?var(_), _Opaques) -> subst_all_vars_to_any(T); +t_inf(?any, T, _Opaques) -> subst_all_vars_to_any(T); +t_inf(T, ?any, _Opaques) -> subst_all_vars_to_any(T); +t_inf(?none, _, _Opaques) -> ?none; +t_inf(_, ?none, _Opaques) -> ?none; +t_inf(?unit, _, _Opaques) -> ?unit; % ?unit cases should appear below ?none +t_inf(_, ?unit, _Opaques) -> ?unit; +t_inf(T, T, _Opaques) -> subst_all_vars_to_any(T); +t_inf(?atom(Set1), ?atom(Set2), _) -> + case set_intersection(Set1, Set2) of + ?none -> ?none; + NewSet -> ?atom(NewSet) + end; +t_inf(?bitstr(U1, B1), ?bitstr(0, B2), _Opaques) -> + if B2 >= B1 andalso (B2-B1) rem U1 =:= 0 -> t_bitstr(0, B2); + true -> ?none + end; +t_inf(?bitstr(0, B1), ?bitstr(U2, B2), _Opaques) -> + if B1 >= B2 andalso (B1-B2) rem U2 =:= 0 -> t_bitstr(0, B1); + true -> ?none + end; +t_inf(?bitstr(U1, B1), ?bitstr(U1, B1), _Opaques) -> + t_bitstr(U1, B1); +t_inf(?bitstr(U1, B1), ?bitstr(U2, B2), _Opaques) when U2 > U1 -> + inf_bitstr(U2, B2, U1, B1); +t_inf(?bitstr(U1, B1), ?bitstr(U2, B2), _Opaques) -> + inf_bitstr(U1, B1, U2, B2); +t_inf(?function(Domain1, Range1), ?function(Domain2, Range2), Opaques) -> + case t_inf(Domain1, Domain2, Opaques) of + ?none -> ?none; + Domain -> ?function(Domain, t_inf(Range1, Range2, Opaques)) + end; +t_inf(?identifier(Set1), ?identifier(Set2), _Opaques) -> + case set_intersection(Set1, Set2) of + ?none -> ?none; + Set -> ?identifier(Set) + end; +t_inf(?map(_, ADefK, ADefV) = A, ?map(_, BDefK, BDefV) = B, _Opaques) -> + %% Because it simplifies the anonymous function, we allow Pairs to temporarily + %% contain mandatory pairs with none values, since all such cases should + %% result in a none result. + Pairs = + map_pairwise_merge( + %% For optional keys in both maps, when the infinimum is none, we have + %% essentially concluded that K must not be a key in the map. + fun(K, ?opt, V1, ?opt, V2) -> {K, ?opt, t_inf(V1, V2)}; + %% When a key is optional in one map, but mandatory in another, it + %% becomes mandatory in the infinumum + (K, _, V1, _, V2) -> {K, ?mand, t_inf(V1, V2)} + end, A, B), + %% If the infinimum of any mandatory values is ?none, the entire map infinimum + %% is ?none. + case lists:any(fun({_,?mand,?none})->true; ({_,_,_}) -> false end, Pairs) of + true -> t_none(); + false -> t_map(Pairs, t_inf(ADefK, BDefK), t_inf(ADefV, BDefV)) + end; +t_inf(?matchstate(Pres1, Slots1), ?matchstate(Pres2, Slots2), _Opaques) -> + ?matchstate(t_inf(Pres1, Pres2), t_inf(Slots1, Slots2)); +t_inf(?nil, ?nil, _Opaques) -> ?nil; +t_inf(?nil, ?nonempty_list(_, _), _Opaques) -> + ?none; +t_inf(?nonempty_list(_, _), ?nil, _Opaques) -> + ?none; +t_inf(?nil, ?list(_Contents, Termination, _), Opaques) -> + t_inf(?nil, t_unopaque(Termination), Opaques); +t_inf(?list(_Contents, Termination, _), ?nil, Opaques) -> + t_inf(?nil, t_unopaque(Termination), Opaques); +t_inf(?list(Contents1, Termination1, Size1), + ?list(Contents2, Termination2, Size2), Opaques) -> + case t_inf(Termination1, Termination2, Opaques) of + ?none -> ?none; + Termination -> + case t_inf(Contents1, Contents2, Opaques) of + ?none -> + %% If none of the lists are nonempty, then the infimum is nil. + case (Size1 =:= ?unknown_qual) andalso (Size2 =:= ?unknown_qual) of + true -> t_nil(); + false -> ?none + end; + Contents -> + Size = + case {Size1, Size2} of + {?unknown_qual, ?unknown_qual} -> ?unknown_qual; + {?unknown_qual, ?nonempty_qual} -> ?nonempty_qual; + {?nonempty_qual, ?unknown_qual} -> ?nonempty_qual; + {?nonempty_qual, ?nonempty_qual} -> ?nonempty_qual + end, + ?list(Contents, Termination, Size) + end + end; +t_inf(?number(_, _) = T1, ?number(_, _) = T2, _Opaques) -> + case {T1, T2} of + {T, T} -> T; + {_, ?number(?any, ?unknown_qual)} -> T1; + {?number(?any, ?unknown_qual), _} -> T2; + {?float, ?integer(_)} -> ?none; + {?integer(_), ?float} -> ?none; + {?integer(?any), ?integer(_)} -> T2; + {?integer(_), ?integer(?any)} -> T1; + {?int_set(Set1), ?int_set(Set2)} -> + case set_intersection(Set1, Set2) of + ?none -> ?none; + Set -> ?int_set(Set) + end; + {?int_range(From1, To1), ?int_range(From2, To2)} -> + t_from_range(max(From1, From2), min(To1, To2)); + {Range = ?int_range(_, _), ?int_set(Set)} -> + %% io:format("t_inf range, set args ~p ~p ~n", [T1, T2]), + Ans2 = + case set_filter(fun(X) -> in_range(X, Range) end, Set) of + ?none -> ?none; + NewSet -> ?int_set(NewSet) + end, + %% io:format("Ans2 ~p ~n", [Ans2]), + Ans2; + {?int_set(Set), ?int_range(_, _) = Range} -> + case set_filter(fun(X) -> in_range(X, Range) end, Set) of + ?none -> ?none; + NewSet -> ?int_set(NewSet) + end + end; +t_inf(?product(Types1), ?product(Types2), Opaques) -> + L1 = length(Types1), + L2 = length(Types2), + if L1 =:= L2 -> ?product(t_inf_lists(Types1, Types2, Opaques)); + true -> ?none + end; +t_inf(?product(_), _, _Opaques) -> + ?none; +t_inf(_, ?product(_), _Opaques) -> + ?none; +t_inf(?tuple(?any, ?any, ?any), ?tuple(_, _, _) = T, _Opaques) -> + subst_all_vars_to_any(T); +t_inf(?tuple(_, _, _) = T, ?tuple(?any, ?any, ?any), _Opaques) -> + subst_all_vars_to_any(T); +t_inf(?tuple(?any, ?any, ?any), ?tuple_set(_) = T, _Opaques) -> + subst_all_vars_to_any(T); +t_inf(?tuple_set(_) = T, ?tuple(?any, ?any, ?any), _Opaques) -> + subst_all_vars_to_any(T); +t_inf(?tuple(Elements1, Arity, _Tag1), ?tuple(Elements2, Arity, _Tag2), Opaques) -> + case t_inf_lists_strict(Elements1, Elements2, Opaques) of + bottom -> ?none; + NewElements -> t_tuple(NewElements) + end; +t_inf(?tuple_set(List1), ?tuple_set(List2), Opaques) -> + inf_tuple_sets(List1, List2, Opaques); +t_inf(?tuple_set(List), ?tuple(_, Arity, _) = T, Opaques) -> + inf_tuple_sets(List, [{Arity, [T]}], Opaques); +t_inf(?tuple(_, Arity, _) = T, ?tuple_set(List), Opaques) -> + inf_tuple_sets(List, [{Arity, [T]}], Opaques); +%% be careful: here and in the next clause T can be ?opaque +t_inf(?union(U1), T, Opaques) -> + ?union(U2) = force_union(T), + inf_union(U1, U2, Opaques); +t_inf(T, ?union(U2), Opaques) -> + ?union(U1) = force_union(T), + inf_union(U1, U2, Opaques); +t_inf(?opaque(Set1), ?opaque(Set2), Opaques) -> + inf_opaque(Set1, Set2, Opaques); +t_inf(?opaque(_) = T1, T2, Opaques) -> + inf_opaque1(T2, T1, 1, Opaques); +t_inf(T1, ?opaque(_) = T2, Opaques) -> + inf_opaque1(T1, T2, 2, Opaques); +%% and as a result, the cases for ?opaque should appear *after* ?union +t_inf(#c{}, #c{}, _) -> + ?none. + +inf_opaque1(T1, ?opaque(Set2)=T2, Pos, Opaques) -> + case Opaques =:= 'universe' orelse inf_is_opaque_type(T2, Pos, Opaques) of + false -> ?none; + true -> + List2 = set_to_list(Set2), + case inf_collect(T1, List2, Opaques, []) of + [] -> ?none; + OpL -> ?opaque(ordsets:from_list(OpL)) + end + end. + +inf_is_opaque_type(T, Pos, {match, Opaques}) -> + is_opaque_type(T, Opaques) orelse throw({pos, [Pos]}); +inf_is_opaque_type(T, _Pos, Opaques) -> + is_opaque_type(T, Opaques). + +inf_collect(T1, [T2|List2], Opaques, OpL) -> + #opaque{struct = S2} = T2, + case t_inf(T1, S2, Opaques) of + ?none -> inf_collect(T1, List2, Opaques, OpL); + Inf -> + Op = T2#opaque{struct = Inf}, + inf_collect(T1, List2, Opaques, [Op|OpL]) + end; +inf_collect(_T1, [], _Opaques, OpL) -> + OpL. + +combine(S, T1, T2) -> + #opaque{mod = Mod1, name = Name1, args = Args1} = T1, + #opaque{mod = Mod2, name = Name2, args = Args2} = T2, + Comb1 = comb(Mod1, Name1, Args1, S, T1), + case is_compat_opaque_names({Mod1, Name1, Args1}, {Mod2, Name2, Args2}) of + true -> Comb1; + false -> Comb1 ++ comb(Mod2, Name2, Args2, S, T2) + end. + +comb(Mod, Name, Args, S, T) -> + case can_combine_opaque_names(Mod, Name, Args, S) of + true -> + ?opaque(Set) = S, + Set; + false -> + [T#opaque{struct = S}] + end. + +can_combine_opaque_names(Mod1, Name1, Args1, + ?opaque([#opaque{mod = Mod2, name = Name2, args = Args2}])) -> + is_compat_opaque_names({Mod1, Name1, Args1}, {Mod2, Name2, Args2}); +can_combine_opaque_names(_, _, _, _) -> false. + +%% Combining two lists this way can be very time consuming... +%% Note: two parameterized opaque types are not the same if their +%% actual parameters differ +inf_opaque(Set1, Set2, Opaques) -> + List1 = inf_look_up(Set1, Opaques), + List2 = inf_look_up(Set2, Opaques), + List0 = [combine(Inf, T1, T2) || + {Is1, ModNameArgs1, T1} <- List1, + {Is2, ModNameArgs2, T2} <- List2, + not t_is_none(Inf = inf_opaque_types(Is1, ModNameArgs1, T1, + Is2, ModNameArgs2, T2, + Opaques))], + List = lists:sort(lists:append(List0)), + sup_opaque(List). + +%% Optimization: do just one lookup. +inf_look_up(Set, Opaques) -> + [{Opaques =:= 'universe' orelse inf_is_opaque_type2(T, Opaques), + {M, N, Args}, T} || + #opaque{mod = M, name = N, args = Args} = T <- set_to_list(Set)]. + +inf_is_opaque_type2(T, {match, Opaques}) -> + is_opaque_type2(T, Opaques); +inf_is_opaque_type2(T, Opaques) -> + is_opaque_type2(T, Opaques). + +inf_opaque_types(IsOpaque1, ModNameArgs1, T1, + IsOpaque2, ModNameArgs2, T2, Opaques) -> + #opaque{struct = S1}=T1, + #opaque{struct = S2}=T2, + case + Opaques =:= 'universe' orelse + is_compat_opaque_names(ModNameArgs1, ModNameArgs2) + of + true -> t_inf(S1, S2, Opaques); + false -> + case {IsOpaque1, IsOpaque2} of + {true, true} -> t_inf(S1, S2, Opaques); + {true, false} -> t_inf(S1, ?opaque(set_singleton(T2)), Opaques); + {false, true} -> t_inf(?opaque(set_singleton(T1)), S2, Opaques); + {false, false} when element(1, Opaques) =:= match -> + throw({pos, [1, 2]}); + {false, false} -> t_none() + end + end. + +is_compat_opaque_names(ModNameArgs, ModNameArgs) -> true; +is_compat_opaque_names({Mod,Name,Args1}, {Mod,Name,Args2}) -> + is_compat_args(Args1, Args2); +is_compat_opaque_names(_, _) -> false. + +is_compat_args([A1|Args1], [A2|Args2]) -> + is_compat_arg(A1, A2) andalso is_compat_args(Args1, Args2); +is_compat_args([], []) -> true; +is_compat_args(_, _) -> false. + +is_compat_arg(A1, A2) -> + is_specialization(A1, A2) orelse is_specialization(A2, A1). + +-spec is_specialization(erl_type(), erl_type()) -> boolean(). + +%% Returns true if the first argument is a specialization of the +%% second argument in the sense that every type is a specialization of +%% any(). For example, {_,_} is a specialization of any(), but not of +%% tuple(). Does not handle variables, but any() and unions (sort of). + +is_specialization(T, T) -> true; +is_specialization(_, ?any) -> true; +is_specialization(?any, _) -> false; +is_specialization(?function(Domain1, Range1), ?function(Domain2, Range2)) -> + (is_specialization(Domain1, Domain2) andalso + is_specialization(Range1, Range2)); +is_specialization(?list(Contents1, Termination1, Size1), + ?list(Contents2, Termination2, Size2)) -> + (Size1 =:= Size2 andalso + is_specialization(Contents1, Contents2) andalso + is_specialization(Termination1, Termination2)); +is_specialization(?product(Types1), ?product(Types2)) -> + specialization_list(Types1, Types2); +is_specialization(?tuple(?any, ?any, ?any), ?tuple(_, _, _)) -> false; +is_specialization(?tuple(_, _, _), ?tuple(?any, ?any, ?any)) -> false; +is_specialization(?tuple(Elements1, Arity, _), + ?tuple(Elements2, Arity, _)) when Arity =/= ?any -> + specialization_list(Elements1, Elements2); +is_specialization(?tuple_set([{Arity, List}]), + ?tuple(Elements2, Arity, _)) when Arity =/= ?any -> + specialization_list(sup_tuple_elements(List), Elements2); +is_specialization(?tuple(Elements1, Arity, _), + ?tuple_set([{Arity, List}])) when Arity =/= ?any -> + specialization_list(Elements1, sup_tuple_elements(List)); +is_specialization(?tuple_set(List1), ?tuple_set(List2)) -> + try + specialization_list_list([sup_tuple_elements(T) || {_Arity, T} <- List1], + [sup_tuple_elements(T) || {_Arity, T} <- List2]) + catch _:_ -> false + end; +is_specialization(?union(List1)=T1, ?union(List2)=T2) -> + case specialization_union2(T1, T2) of + {yes, Type1, Type2} -> is_specialization(Type1, Type2); + no -> specialization_list(List1, List2) + end; +is_specialization(?union(List), T2) -> + case unify_union(List) of + {yes, Type} -> is_specialization(Type, T2); + no -> false + end; +is_specialization(T1, ?union(List)) -> + case unify_union(List) of + {yes, Type} -> is_specialization(T1, Type); + no -> false + end; +is_specialization(?opaque(_) = T1, T2) -> + is_specialization(t_opaque_structure(T1), T2); +is_specialization(T1, ?opaque(_) = T2) -> + is_specialization(T1, t_opaque_structure(T2)); +is_specialization(?var(_), _) -> exit(error); +is_specialization(_, ?var(_)) -> exit(error); +is_specialization(?none, _) -> false; +is_specialization(_, ?none) -> false; +is_specialization(?unit, _) -> false; +is_specialization(_, ?unit) -> false; +is_specialization(#c{}, #c{}) -> false. + +specialization_list_list(LL1, LL2) -> + length(LL1) =:= length(LL2) andalso specialization_list_list1(LL1, LL2). + +specialization_list_list1([], []) -> true; +specialization_list_list1([L1|LL1], [L2|LL2]) -> + specialization_list(L1, L2) andalso specialization_list_list1(LL1, LL2). + +specialization_list(L1, L2) -> + length(L1) =:= length(L2) andalso specialization_list1(L1, L2). + +specialization_list1([], []) -> true; +specialization_list1([T1|L1], [T2|L2]) -> + is_specialization(T1, T2) andalso specialization_list1(L1, L2). + +specialization_union2(?union(List1)=T1, ?union(List2)=T2) -> + case {unify_union(List1), unify_union(List2)} of + {{yes, Type1}, {yes, Type2}} -> {yes, Type1, Type2}; + {{yes, Type1}, no} -> {yes, Type1, T2}; + {no, {yes, Type2}} -> {yes, T1, Type2}; + {no, no} -> no + end. + +-spec t_inf_lists([erl_type()], [erl_type()]) -> [erl_type()]. + +t_inf_lists(L1, L2) -> + t_inf_lists(L1, L2, 'universe'). + +-spec t_inf_lists([erl_type()], [erl_type()], t_inf_opaques()) -> [erl_type()]. + +t_inf_lists(L1, L2, Opaques) -> + t_inf_lists(L1, L2, [], Opaques). + +-spec t_inf_lists([erl_type()], [erl_type()], [erl_type()], [erl_type()]) -> [erl_type()]. + +t_inf_lists([T1|Left1], [T2|Left2], Acc, Opaques) -> + t_inf_lists(Left1, Left2, [t_inf(T1, T2, Opaques)|Acc], Opaques); +t_inf_lists([], [], Acc, _Opaques) -> + lists:reverse(Acc). + +%% Infimum of lists with strictness. +%% If any element is the ?none type, the value 'bottom' is returned. + +-spec t_inf_lists_strict([erl_type()], [erl_type()], [erl_type()]) -> 'bottom' | [erl_type()]. + +t_inf_lists_strict(L1, L2, Opaques) -> + t_inf_lists_strict(L1, L2, [], Opaques). + +-spec t_inf_lists_strict([erl_type()], [erl_type()], [erl_type()], [erl_type()]) -> 'bottom' | [erl_type()]. + +t_inf_lists_strict([T1|Left1], [T2|Left2], Acc, Opaques) -> + case t_inf(T1, T2, Opaques) of + ?none -> bottom; + T -> t_inf_lists_strict(Left1, Left2, [T|Acc], Opaques) + end; +t_inf_lists_strict([], [], Acc, _Opaques) -> + lists:reverse(Acc). + +inf_tuple_sets(L1, L2, Opaques) -> + case inf_tuple_sets(L1, L2, [], Opaques) of + [] -> ?none; + [{_Arity, [?tuple(_, _, _) = OneTuple]}] -> OneTuple; + List -> ?tuple_set(List) + end. + +inf_tuple_sets([{Arity, Tuples1}|Ts1], [{Arity, Tuples2}|Ts2], Acc, Opaques) -> + case inf_tuples_in_sets(Tuples1, Tuples2, Opaques) of + [] -> inf_tuple_sets(Ts1, Ts2, Acc, Opaques); + [?tuple_set([{Arity, NewTuples}])] -> + inf_tuple_sets(Ts1, Ts2, [{Arity, NewTuples}|Acc], Opaques); + NewTuples -> inf_tuple_sets(Ts1, Ts2, [{Arity, NewTuples}|Acc], Opaques) + end; +inf_tuple_sets([{Arity1, _}|Ts1] = L1, [{Arity2, _}|Ts2] = L2, Acc, Opaques) -> + if Arity1 < Arity2 -> inf_tuple_sets(Ts1, L2, Acc, Opaques); + Arity1 > Arity2 -> inf_tuple_sets(L1, Ts2, Acc, Opaques) + end; +inf_tuple_sets([], _, Acc, _Opaques) -> lists:reverse(Acc); +inf_tuple_sets(_, [], Acc, _Opaques) -> lists:reverse(Acc). + +inf_tuples_in_sets([?tuple(Elements1, _, ?any)], L2, Opaques) -> + NewList = [t_inf_lists_strict(Elements1, Elements2, Opaques) + || ?tuple(Elements2, _, _) <- L2], + [t_tuple(Es) || Es <- NewList, Es =/= bottom]; +inf_tuples_in_sets(L1, [?tuple(Elements2, _, ?any)], Opaques) -> + NewList = [t_inf_lists_strict(Elements1, Elements2, Opaques) + || ?tuple(Elements1, _, _) <- L1], + [t_tuple(Es) || Es <- NewList, Es =/= bottom]; +inf_tuples_in_sets(L1, L2, Opaques) -> + inf_tuples_in_sets2(L1, L2, [], Opaques). + +inf_tuples_in_sets2([?tuple(Elements1, Arity, Tag)|Ts1], + [?tuple(Elements2, Arity, Tag)|Ts2], Acc, Opaques) -> + case t_inf_lists_strict(Elements1, Elements2, Opaques) of + bottom -> inf_tuples_in_sets2(Ts1, Ts2, Acc, Opaques); + NewElements -> + inf_tuples_in_sets2(Ts1, Ts2, [?tuple(NewElements, Arity, Tag)|Acc], + Opaques) + end; +inf_tuples_in_sets2([?tuple(_, _, Tag1)|Ts1] = L1, + [?tuple(_, _, Tag2)|Ts2] = L2, Acc, Opaques) -> + if Tag1 < Tag2 -> inf_tuples_in_sets2(Ts1, L2, Acc, Opaques); + Tag1 > Tag2 -> inf_tuples_in_sets2(L1, Ts2, Acc, Opaques) + end; +inf_tuples_in_sets2([], _, Acc, _Opaques) -> lists:reverse(Acc); +inf_tuples_in_sets2(_, [], Acc, _Opaques) -> lists:reverse(Acc). + +inf_union(U1, U2, Opaques) -> + OpaqueFun = + fun(Union1, Union2, InfFun) -> + [_,_,_,_,_,_,_,_,Opaque,_] = Union1, + [A,B,F,I,L,N,T,M,_,Map] = Union2, + List = [A,B,F,I,L,N,T,M,Map], + inf_union_collect(List, Opaque, InfFun, [], []) + end, + {O1, ThrowList1} = + OpaqueFun(U1, U2, fun(E, Opaque) -> t_inf(Opaque, E, Opaques) end), + {O2, ThrowList2} + = OpaqueFun(U2, U1, fun(E, Opaque) -> t_inf(E, Opaque, Opaques) end), + {Union, ThrowList3} = inf_union(U1, U2, 0, [], [], Opaques), + ThrowList = lists:merge3(ThrowList1, ThrowList2, ThrowList3), + case t_sup([O1, O2, Union]) of + ?none when ThrowList =/= [] -> throw({pos, lists:usort(ThrowList)}); + Sup -> Sup + end. + +inf_union_collect([], _Opaque, _InfFun, InfList, ThrowList) -> + {t_sup(InfList), lists:usort(ThrowList)}; +inf_union_collect([?none|L], Opaque, InfFun, InfList, ThrowList) -> + inf_union_collect(L, Opaque, InfFun, [?none|InfList], ThrowList); +inf_union_collect([E|L], Opaque, InfFun, InfList, ThrowList) -> + try InfFun(E, Opaque)of + Inf -> + inf_union_collect(L, Opaque, InfFun, [Inf|InfList], ThrowList) + catch throw:{pos, Ns} -> + inf_union_collect(L, Opaque, InfFun, InfList, Ns ++ ThrowList) + end. + +inf_union([?none|Left1], [?none|Left2], N, Acc, ThrowList, Opaques) -> + inf_union(Left1, Left2, N, [?none|Acc], ThrowList, Opaques); +inf_union([T1|Left1], [T2|Left2], N, Acc, ThrowList, Opaques) -> + try t_inf(T1, T2, Opaques) of + ?none -> inf_union(Left1, Left2, N, [?none|Acc], ThrowList, Opaques); + T -> inf_union(Left1, Left2, N+1, [T|Acc], ThrowList, Opaques) + catch throw:{pos, Ns} -> + inf_union(Left1, Left2, N, [?none|Acc], Ns ++ ThrowList, Opaques) + end; +inf_union([], [], N, Acc, ThrowList, _Opaques) -> + if N =:= 0 -> {?none, ThrowList}; + N =:= 1 -> + [Type] = [T || T <- Acc, T =/= ?none], + {Type, ThrowList}; + N >= 2 -> {?union(lists:reverse(Acc)), ThrowList} + end. + +inf_bitstr(U1, B1, U2, B2) -> + GCD = gcd(U1, U2), + case (B2-B1) rem GCD of + 0 -> + U = (U1*U2) div GCD, + B = findfirst(0, 0, U1, B1, U2, B2), + t_bitstr(U, B); + _ -> + ?none + end. + +findfirst(N1, N2, U1, B1, U2, B2) -> + Val1 = U1*N1+B1, + Val2 = U2*N2+B2, + if Val1 =:= Val2 -> + Val1; + Val1 > Val2 -> + findfirst(N1, N2+1, U1, B1, U2, B2); + Val1 < Val2 -> + findfirst(N1+1, N2, U1, B1, U2, B2) + end. + +%%----------------------------------------------------------------------------- +%% Substitution of variables +%% + +-type subst_table() :: #{any() => erl_type()}. + +-spec t_subst(erl_type(), subst_table()) -> erl_type(). + +t_subst(T, Map) -> + case t_has_var(T) of + true -> t_subst_aux(T, Map); + false -> T + end. + +-spec subst_all_vars_to_any(erl_type()) -> erl_type(). + +subst_all_vars_to_any(T) -> + t_subst(T, #{}). + +t_subst_aux(?var(Id), Map) -> + case maps:find(Id, Map) of + error -> ?any; + {ok, Type} -> Type + end; +t_subst_aux(?list(Contents, Termination, Size), Map) -> + case t_subst_aux(Contents, Map) of + ?none -> ?none; + NewContents -> + %% Be careful here to make the termination collapse if necessary. + case t_subst_aux(Termination, Map) of + ?nil -> ?list(NewContents, ?nil, Size); + ?any -> ?list(NewContents, ?any, Size); + Other -> + ?list(NewContents2, NewTermination, _) = t_cons(NewContents, Other), + ?list(NewContents2, NewTermination, Size) + end + end; +t_subst_aux(?function(Domain, Range), Map) -> + ?function(t_subst_aux(Domain, Map), t_subst_aux(Range, Map)); +t_subst_aux(?product(Types), Map) -> + ?product([t_subst_aux(T, Map) || T <- Types]); +t_subst_aux(?tuple(?any, ?any, ?any) = T, _Map) -> + T; +t_subst_aux(?tuple(Elements, _Arity, _Tag), Map) -> + t_tuple([t_subst_aux(E, Map) || E <- Elements]); +t_subst_aux(?tuple_set(_) = TS, Map) -> + t_sup([t_subst_aux(T, Map) || T <- t_tuple_subtypes(TS)]); +t_subst_aux(?map(Pairs, DefK, DefV), Map) -> + t_map([{K, MNess, t_subst_aux(V, Map)} || {K, MNess, V} <- Pairs], + t_subst_aux(DefK, Map), t_subst_aux(DefV, Map)); +t_subst_aux(?opaque(Es), Map) -> + List = [Opaque#opaque{args = [t_subst_aux(Arg, Map) || Arg <- Args], + struct = t_subst_aux(S, Map)} || + Opaque = #opaque{args = Args, struct = S} <- set_to_list(Es)], + ?opaque(ordsets:from_list(List)); +t_subst_aux(?union(List), Map) -> + ?union([t_subst_aux(E, Map) || E <- List]); +t_subst_aux(T, _Map) -> + T. + +%%----------------------------------------------------------------------------- +%% Unification +%% + +-type t_unify_ret() :: {erl_type(), [{_, erl_type()}]}. + +-spec t_unify(erl_type(), erl_type()) -> t_unify_ret(). + +t_unify(T1, T2) -> + {T, VarMap} = t_unify(T1, T2, #{}), + {t_subst(T, VarMap), lists:keysort(1, maps:to_list(VarMap))}. + +t_unify(?var(Id) = T, ?var(Id), VarMap) -> + {T, VarMap}; +t_unify(?var(Id1) = T, ?var(Id2), VarMap) -> + case maps:find(Id1, VarMap) of + error -> + case maps:find(Id2, VarMap) of + error -> {T, VarMap#{Id2 => T}}; + {ok, Type} -> t_unify(T, Type, VarMap) + end; + {ok, Type1} -> + case maps:find(Id2, VarMap) of + error -> {Type1, VarMap#{Id2 => T}}; + {ok, Type2} -> t_unify(Type1, Type2, VarMap) + end + end; +t_unify(?var(Id), Type, VarMap) -> + case maps:find(Id, VarMap) of + error -> {Type, VarMap#{Id => Type}}; + {ok, VarType} -> t_unify(VarType, Type, VarMap) + end; +t_unify(Type, ?var(Id), VarMap) -> + case maps:find(Id, VarMap) of + error -> {Type, VarMap#{Id => Type}}; + {ok, VarType} -> t_unify(VarType, Type, VarMap) + end; +t_unify(?function(Domain1, Range1), ?function(Domain2, Range2), VarMap) -> + {Domain, VarMap1} = t_unify(Domain1, Domain2, VarMap), + {Range, VarMap2} = t_unify(Range1, Range2, VarMap1), + {?function(Domain, Range), VarMap2}; +t_unify(?list(Contents1, Termination1, Size), + ?list(Contents2, Termination2, Size), VarMap) -> + {Contents, VarMap1} = t_unify(Contents1, Contents2, VarMap), + {Termination, VarMap2} = t_unify(Termination1, Termination2, VarMap1), + {?list(Contents, Termination, Size), VarMap2}; +t_unify(?product(Types1), ?product(Types2), VarMap) -> + {Types, VarMap1} = unify_lists(Types1, Types2, VarMap), + {?product(Types), VarMap1}; +t_unify(?tuple(?any, ?any, ?any) = T, ?tuple(?any, ?any, ?any), VarMap) -> + {T, VarMap}; +t_unify(?tuple(Elements1, Arity, _), + ?tuple(Elements2, Arity, _), VarMap) when Arity =/= ?any -> + {NewElements, VarMap1} = unify_lists(Elements1, Elements2, VarMap), + {t_tuple(NewElements), VarMap1}; +t_unify(?tuple_set([{Arity, _}]) = T1, + ?tuple(_, Arity, _) = T2, VarMap) when Arity =/= ?any -> + unify_tuple_set_and_tuple1(T1, T2, VarMap); +t_unify(?tuple(_, Arity, _) = T1, + ?tuple_set([{Arity, _}]) = T2, VarMap) when Arity =/= ?any -> + unify_tuple_set_and_tuple2(T1, T2, VarMap); +t_unify(?tuple_set(List1) = T1, ?tuple_set(List2) = T2, VarMap) -> + try + unify_lists(lists:append([T || {_Arity, T} <- List1]), + lists:append([T || {_Arity, T} <- List2]), VarMap) + of + {Tuples, NewVarMap} -> {t_sup(Tuples), NewVarMap} + catch _:_ -> throw({mismatch, T1, T2}) + end; +t_unify(?map(_, ADefK, ADefV) = A, ?map(_, BDefK, BDefV) = B, VarMap0) -> + {DefK, VarMap1} = t_unify(ADefK, BDefK, VarMap0), + {DefV, VarMap2} = t_unify(ADefV, BDefV, VarMap1), + {Pairs, VarMap} = + map_pairwise_merge_foldr( + fun(K, MNess, V1, MNess, V2, {Pairs0, VarMap3}) -> + %% We know that the keys unify and do not contain variables, or they + %% would not be singletons + %% TODO: Should V=?none (known missing keys) be handled special? + {V, VarMap4} = t_unify(V1, V2, VarMap3), + {[{K,MNess,V}|Pairs0], VarMap4}; + (K, _, V1, _, V2, {Pairs0, VarMap3}) -> + %% One mandatory and one optional; what should be done in this case? + {V, VarMap4} = t_unify(V1, V2, VarMap3), + {[{K,?mand,V}|Pairs0], VarMap4} + end, {[], VarMap2}, A, B), + {t_map(Pairs, DefK, DefV), VarMap}; +t_unify(?opaque(_) = T1, ?opaque(_) = T2, VarMap) -> + t_unify(t_opaque_structure(T1), t_opaque_structure(T2), VarMap); +t_unify(T1, ?opaque(_) = T2, VarMap) -> + t_unify(T1, t_opaque_structure(T2), VarMap); +t_unify(?opaque(_) = T1, T2, VarMap) -> + t_unify(t_opaque_structure(T1), T2, VarMap); +t_unify(T, T, VarMap) -> + {T, VarMap}; +t_unify(?union(_)=T1, ?union(_)=T2, VarMap) -> + {Type1, Type2} = unify_union2(T1, T2), + t_unify(Type1, Type2, VarMap); +t_unify(?union(_)=T1, T2, VarMap) -> + t_unify(unify_union1(T1, T1, T2), T2, VarMap); +t_unify(T1, ?union(_)=T2, VarMap) -> + t_unify(T1, unify_union1(T2, T1, T2), VarMap); +t_unify(T1, T2, _) -> + throw({mismatch, T1, T2}). + +unify_union2(?union(List1)=T1, ?union(List2)=T2) -> + case {unify_union(List1), unify_union(List2)} of + {{yes, Type1}, {yes, Type2}} -> {Type1, Type2}; + {{yes, Type1}, no} -> {Type1, T2}; + {no, {yes, Type2}} -> {T1, Type2}; + {no, no} -> throw({mismatch, T1, T2}) + end. + +unify_union1(?union(List), T1, T2) -> + case unify_union(List) of + {yes, Type} -> Type; + no -> throw({mismatch, T1, T2}) + end. + +unify_union(List) -> + [A,B,F,I,L,N,T,M,O,Map] = List, + if O =:= ?none -> no; + true -> + S = t_opaque_structure(O), + {yes, t_sup([A,B,F,I,L,N,T,M,S,Map])} + end. + +-spec is_opaque_type(erl_type(), [erl_type()]) -> boolean(). + +%% An opaque type is a union of types. Returns true iff any of the type +%% names (Module and Name) of the first argument (the opaque type to +%% check) occurs in any of the opaque types of the second argument. +is_opaque_type(?opaque(Elements), Opaques) -> + lists:any(fun(Opaque) -> is_opaque_type2(Opaque, Opaques) end, Elements). + +is_opaque_type2(#opaque{mod = Mod1, name = Name1, args = Args1}, Opaques) -> + F1 = fun(?opaque(Es)) -> + F2 = fun(#opaque{mod = Mod, name = Name, args = Args}) -> + is_type_name(Mod1, Name1, Args1, Mod, Name, Args) + end, + lists:any(F2, Es) + end, + lists:any(F1, Opaques). + +is_type_name(Mod, Name, Args1, Mod, Name, Args2) -> + length(Args1) =:= length(Args2); +is_type_name(_Mod1, _Name1, _Args1, _Mod2, _Name2, _Args2) -> + false. + +%% Two functions since t_unify is not symmetric. +unify_tuple_set_and_tuple1(?tuple_set([{Arity, List}]), + ?tuple(Elements2, Arity, _), VarMap) -> + %% Can only work if the single tuple has variables at correct places. + %% Collapse the tuple set. + {NewElements, VarMap1} = + unify_lists(sup_tuple_elements(List), Elements2, VarMap), + {t_tuple(NewElements), VarMap1}. + +unify_tuple_set_and_tuple2(?tuple(Elements2, Arity, _), + ?tuple_set([{Arity, List}]), VarMap) -> + %% Can only work if the single tuple has variables at correct places. + %% Collapse the tuple set. + {NewElements, VarMap1} = + unify_lists(Elements2, sup_tuple_elements(List), VarMap), + {t_tuple(NewElements), VarMap1}. + +unify_lists(L1, L2, VarMap) -> + unify_lists(L1, L2, VarMap, []). + +unify_lists([T1|Left1], [T2|Left2], VarMap, Acc) -> + {NewT, NewVarMap} = t_unify(T1, T2, VarMap), + unify_lists(Left1, Left2, NewVarMap, [NewT|Acc]); +unify_lists([], [], VarMap, Acc) -> + {lists:reverse(Acc), VarMap}. + +%%t_assign_variables_to_subtype(T1, T2) -> +%% try +%% Dict = assign_vars(T1, T2, dict:new()), +%% {ok, dict:map(fun(_Param, List) -> t_sup(List) end, Dict)} +%% catch +%% throw:error -> error +%% end. + +%%assign_vars(_, ?var(_), _Dict) -> +%% erlang:error("Variable in right hand side of assignment"); +%%assign_vars(?any, _, Dict) -> +%% Dict; +%%assign_vars(?var(_) = Var, Type, Dict) -> +%% store_var(Var, Type, Dict); +%%assign_vars(?function(Domain1, Range1), ?function(Domain2, Range2), Dict) -> +%% DomainList = +%% case Domain2 of +%% ?any -> []; +%% ?product(List) -> List +%% end, +%% case any_none([Range2|DomainList]) of +%% true -> throw(error); +%% false -> +%% Dict1 = assign_vars(Domain1, Domain2, Dict), +%% assign_vars(Range1, Range2, Dict1) +%% end; +%%assign_vars(?list(_Contents, _Termination, ?any), ?nil, Dict) -> +%% Dict; +%%assign_vars(?list(Contents1, Termination1, Size1), +%% ?list(Contents2, Termination2, Size2), Dict) -> +%% Dict1 = assign_vars(Contents1, Contents2, Dict), +%% Dict2 = assign_vars(Termination1, Termination2, Dict1), +%% case {Size1, Size2} of +%% {S, S} -> Dict2; +%% {?any, ?nonempty_qual} -> Dict2; +%% {_, _} -> throw(error) +%% end; +%%assign_vars(?product(Types1), ?product(Types2), Dict) -> +%% case length(Types1) =:= length(Types2) of +%% true -> assign_vars_lists(Types1, Types2, Dict); +%% false -> throw(error) +%% end; +%%assign_vars(?tuple(?any, ?any, ?any), ?tuple(?any, ?any, ?any), Dict) -> +%% Dict; +%%assign_vars(?tuple(?any, ?any, ?any), ?tuple(_, _, _), Dict) -> +%% Dict; +%%assign_vars(?tuple(Elements1, Arity, _), +%% ?tuple(Elements2, Arity, _), Dict) when Arity =/= ?any -> +%% assign_vars_lists(Elements1, Elements2, Dict); +%%assign_vars(?tuple_set(_) = T, ?tuple_set(List2), Dict) -> +%% %% All Rhs tuples must already be subtypes of Lhs, so we can take +%% %% each one separatly. +%% assign_vars_lists([T || _ <- List2], List2, Dict); +%%assign_vars(?tuple(?any, ?any, ?any), ?tuple_set(_), Dict) -> +%% Dict; +%%assign_vars(?tuple(_, Arity, _) = T1, ?tuple_set(List), Dict) -> +%% case reduce_tuple_tags(List) of +%% [Tuple = ?tuple(_, Arity, _)] -> assign_vars(T1, Tuple, Dict); +%% _ -> throw(error) +%% end; +%%assign_vars(?tuple_set(List), ?tuple(_, Arity, Tag) = T2, Dict) -> +%% case [T || ?tuple(_, Arity1, Tag1) = T <- List, +%% Arity1 =:= Arity, Tag1 =:= Tag] of +%% [] -> throw(error); +%% [T1] -> assign_vars(T1, T2, Dict) +%% end; +%%assign_vars(?union(U1), T2, Dict) -> +%% ?union(U2) = force_union(T2), +%% assign_vars_lists(U1, U2, Dict); +%%assign_vars(T, T, Dict) -> +%% Dict; +%%assign_vars(T1, T2, Dict) -> +%% case t_is_subtype(T2, T1) of +%% false -> throw(error); +%% true -> Dict +%% end. + +%%assign_vars_lists([T1|Left1], [T2|Left2], Dict) -> +%% assign_vars_lists(Left1, Left2, assign_vars(T1, T2, Dict)); +%%assign_vars_lists([], [], Dict) -> +%% Dict. + +%%store_var(?var(Id), Type, Dict) -> +%% case dict:find(Id, Dict) of +%% error -> dict:store(Id, [Type], Dict); +%% {ok, _VarType0} -> dict:update(Id, fun(X) -> [Type|X] end, Dict) +%% end. + +%%----------------------------------------------------------------------------- +%% Subtraction. +%% +%% Note that the subtraction is an approximation since we do not have +%% negative types. Also, tuples and products should be handled using +%% the cartesian product of the elements, but this is not feasible to +%% do. +%% +%% Example: {a|b,c|d}\{a,d} = {a,c}|{a,d}|{b,c}|{b,d} \ {a,d} = +%% = {a,c}|{b,c}|{b,d} = {a|b,c|d} +%% +%% Instead, we can subtract if all elements but one becomes none after +%% subtracting element-wise. +%% +%% Example: {a|b,c|d}\{a|b,d} = {a,c}|{a,d}|{b,c}|{b,d} \ {a,d}|{b,d} = +%% = {a,c}|{b,c} = {a|b,c} + +-spec t_subtract_list(erl_type(), [erl_type()]) -> erl_type(). + +t_subtract_list(T1, [T2|Left]) -> + t_subtract_list(t_subtract(T1, T2), Left); +t_subtract_list(T, []) -> + T. + +-spec t_subtract(erl_type(), erl_type()) -> erl_type(). + +t_subtract(_, ?any) -> ?none; +t_subtract(T, ?var(_)) -> T; +t_subtract(?any, _) -> ?any; +t_subtract(?var(_) = T, _) -> T; +t_subtract(T, ?unit) -> T; +t_subtract(?unit, _) -> ?unit; +t_subtract(?none, _) -> ?none; +t_subtract(T, ?none) -> T; +t_subtract(?atom(Set1), ?atom(Set2)) -> + case set_subtract(Set1, Set2) of + ?none -> ?none; + Set -> ?atom(Set) + end; +t_subtract(?bitstr(U1, B1), ?bitstr(U2, B2)) -> + subtract_bin(t_bitstr(U1, B1), t_inf(t_bitstr(U1, B1), t_bitstr(U2, B2))); +t_subtract(?function(_, _) = T1, ?function(_, _) = T2) -> + case t_is_subtype(T1, T2) of + true -> ?none; + false -> T1 + end; +t_subtract(?identifier(Set1), ?identifier(Set2)) -> + case set_subtract(Set1, Set2) of + ?none -> ?none; + Set -> ?identifier(Set) + end; +t_subtract(?opaque(_)=T1, ?opaque(_)=T2) -> + opaque_subtract(T1, t_opaque_structure(T2)); +t_subtract(?opaque(_)=T1, T2) -> + opaque_subtract(T1, T2); +t_subtract(T1, ?opaque(_)=T2) -> + t_subtract(T1, t_opaque_structure(T2)); +t_subtract(?matchstate(Pres1, Slots1), ?matchstate(Pres2, _Slots2)) -> + Pres = t_subtract(Pres1, Pres2), + case t_is_none(Pres) of + true -> ?none; + false -> ?matchstate(Pres, Slots1) + end; +t_subtract(?matchstate(Present, Slots), _) -> + ?matchstate(Present, Slots); +t_subtract(?nil, ?nil) -> + ?none; +t_subtract(?nil, ?nonempty_list(_, _)) -> + ?nil; +t_subtract(?nil, ?list(_, _, _)) -> + ?none; +t_subtract(?list(Contents, Termination, _Size) = T, ?nil) -> + case Termination =:= ?nil of + true -> ?nonempty_list(Contents, Termination); + false -> T + end; +t_subtract(?list(Contents1, Termination1, Size1) = T, + ?list(Contents2, Termination2, Size2)) -> + case t_is_subtype(Contents1, Contents2) of + true -> + case t_is_subtype(Termination1, Termination2) of + true -> + case {Size1, Size2} of + {?nonempty_qual, ?unknown_qual} -> ?none; + {?unknown_qual, ?nonempty_qual} -> ?nil; + {S, S} -> ?none + end; + false -> + %% If the termination is not covered by the subtracted type + %% we cannot really say anything about the result. + T + end; + false -> + %% All contents must be covered if there is going to be any + %% change to the list. + T + end; +t_subtract(?float, ?float) -> ?none; +t_subtract(?number(_, _) = T1, ?float) -> t_inf(T1, t_integer()); +t_subtract(?float, ?number(_Set, Tag)) -> + case Tag of + ?unknown_qual -> ?none; + _ -> ?float + end; +t_subtract(?number(_, _), ?number(?any, ?unknown_qual)) -> ?none; +t_subtract(?number(_, _) = T1, ?integer(?any)) -> t_inf(?float, T1); +t_subtract(?int_set(Set1), ?int_set(Set2)) -> + case set_subtract(Set1, Set2) of + ?none -> ?none; + Set -> ?int_set(Set) + end; +t_subtract(?int_range(From1, To1) = T1, ?int_range(_, _) = T2) -> + case t_inf(T1, T2) of + ?none -> T1; + ?int_range(From1, To1) -> ?none; + ?int_range(neg_inf, To) -> t_from_range(To + 1, To1); + ?int_range(From, pos_inf) -> t_from_range(From1, From - 1); + ?int_range(From, To) -> t_sup(t_from_range(From1, From - 1), + t_from_range(To + 1, To)) + end; +t_subtract(?int_range(From, To) = T1, ?int_set(Set)) -> + NewFrom = case set_is_element(From, Set) of + true -> From + 1; + false -> From + end, + NewTo = case set_is_element(To, Set) of + true -> To - 1; + false -> To + end, + if (NewFrom =:= From) and (NewTo =:= To) -> T1; + true -> t_from_range(NewFrom, NewTo) + end; +t_subtract(?int_set(Set), ?int_range(From, To)) -> + case set_filter(fun(X) -> not ((X =< From) orelse (X >= To)) end, Set) of + ?none -> ?none; + NewSet -> ?int_set(NewSet) + end; +t_subtract(?integer(?any) = T1, ?integer(_)) -> T1; +t_subtract(?number(_, _) = T1, ?number(_, _)) -> T1; +t_subtract(?tuple(_, _, _), ?tuple(?any, ?any, ?any)) -> ?none; +t_subtract(?tuple_set(_), ?tuple(?any, ?any, ?any)) -> ?none; +t_subtract(?tuple(?any, ?any, ?any) = T1, ?tuple_set(_)) -> T1; +t_subtract(?tuple(Elements1, Arity1, _Tag1) = T1, + ?tuple(Elements2, Arity2, _Tag2)) -> + if Arity1 =/= Arity2 -> T1; + Arity1 =:= Arity2 -> + NewElements = t_subtract_lists(Elements1, Elements2), + case [E || E <- NewElements, E =/= ?none] of + [] -> ?none; + [_] -> t_tuple(replace_nontrivial_element(Elements1, NewElements)); + _ -> T1 + end + end; +t_subtract(?tuple_set(List1) = T1, ?tuple(_, Arity, _) = T2) -> + case orddict:find(Arity, List1) of + error -> T1; + {ok, List2} -> + TuplesLeft0 = [Tuple || {_Arity, Tuple} <- orddict:erase(Arity, List1)], + TuplesLeft1 = lists:append(TuplesLeft0), + t_sup([t_subtract(L, T2) || L <- List2] ++ TuplesLeft1) + end; +t_subtract(?tuple(_, Arity, _) = T1, ?tuple_set(List1)) -> + case orddict:find(Arity, List1) of + error -> T1; + {ok, List2} -> t_inf([t_subtract(T1, L) || L <- List2]) + end; +t_subtract(?tuple_set(_) = T1, ?tuple_set(_) = T2) -> + t_sup([t_subtract(T, T2) || T <- t_tuple_subtypes(T1)]); +t_subtract(?product(Elements1) = T1, ?product(Elements2)) -> + Arity1 = length(Elements1), + Arity2 = length(Elements2), + if Arity1 =/= Arity2 -> T1; + Arity1 =:= Arity2 -> + NewElements = t_subtract_lists(Elements1, Elements2), + case [E || E <- NewElements, E =/= ?none] of + [] -> ?none; + [_] -> t_product(replace_nontrivial_element(Elements1, NewElements)); + _ -> T1 + end + end; +t_subtract(?map(APairs, ADefK, ADefV) = A, ?map(_, BDefK, BDefV) = B) -> + case t_is_subtype(ADefK, BDefK) andalso t_is_subtype(ADefV, BDefV) of + false -> A; + true -> + %% We fold over the maps to produce a list of constraints, where + %% constraints are additional key-value pairs to put in Pairs. Only one + %% constraint need to be applied to produce a type that excludes the + %% right-hand-side type, so if more than one constraint is produced, we + %% just return the left-hand-side argument. + %% + %% Each case of the fold may either conclude that + %% * The arguments constrain A at least as much as B, i.e. that A so far + %% is a subtype of B. In that case they return false + %% * That for the particular arguments, A being a subtype of B does not + %% hold, but the infinimum of A and B is nonempty, and by narrowing a + %% pair in A, we can create a type that excludes some elements in the + %% infinumum. In that case, they will return that pair. + %% * That for the particular arguments, A being a subtype of B does not + %% hold, and either the infinumum of A and B is empty, or it is not + %% possible with the current representation to create a type that + %% excludes elements from B without also excluding elements that are + %% only in A. In that case, it will return the pair from A unchanged. + case + map_pairwise_merge( + %% If V1 is a subtype of V2, the case that K does not exist in A + %% remain. + fun(K, ?opt, V1, ?mand, V2) -> {K, ?opt, t_subtract(V1, V2)}; + (K, _, V1, _, V2) -> + %% If we subtract an optional key, that leaves a mandatory key + case t_subtract(V1, V2) of + ?none -> false; + Partial -> {K, ?mand, Partial} + end + end, A, B) + of + %% We produce a list of keys that are constrained. As only one of + %% these should apply at a time, we can't represent the difference if + %% more than one constraint is produced. If we applied all of them, + %% that would make an underapproximation, which we must not do. + [] -> ?none; %% A is a subtype of B + [E] -> t_map(mapdict_store(E, APairs), ADefK, ADefV); + _ -> A + end + end; +t_subtract(?product(P1), _) -> + ?product(P1); +t_subtract(T, ?product(_)) -> + T; +t_subtract(?union(U1), ?union(U2)) -> + subtract_union(U1, U2); +t_subtract(T1, T2) -> + ?union(U1) = force_union(T1), + ?union(U2) = force_union(T2), + subtract_union(U1, U2). + +-spec opaque_subtract(erl_type(), erl_type()) -> erl_type(). + +opaque_subtract(?opaque(Set1), T2) -> + List = [T1#opaque{struct = Sub} || + #opaque{struct = S1}=T1 <- set_to_list(Set1), + not t_is_none(Sub = t_subtract(S1, T2))], + case List of + [] -> ?none; + _ -> ?opaque(ordsets:from_list(List)) + end. + +-spec t_subtract_lists([erl_type()], [erl_type()]) -> [erl_type()]. + +t_subtract_lists(L1, L2) -> + t_subtract_lists(L1, L2, []). + +-spec t_subtract_lists([erl_type()], [erl_type()], [erl_type()]) -> [erl_type()]. + +t_subtract_lists([T1|Left1], [T2|Left2], Acc) -> + t_subtract_lists(Left1, Left2, [t_subtract(T1, T2)|Acc]); +t_subtract_lists([], [], Acc) -> + lists:reverse(Acc). + +-spec subtract_union([erl_type(),...], [erl_type(),...]) -> erl_type(). + +subtract_union(U1, U2) -> + [A1,B1,F1,I1,L1,N1,T1,M1,O1,Map1] = U1, + [A2,B2,F2,I2,L2,N2,T2,M2,O2,Map2] = U2, + List1 = [A1,B1,F1,I1,L1,N1,T1,M1,?none,Map1], + List2 = [A2,B2,F2,I2,L2,N2,T2,M2,?none,Map2], + Sub1 = subtract_union(List1, List2, 0, []), + O = if O1 =:= ?none -> O1; + true -> t_subtract(O1, ?union(U2)) + end, + Sub2 = if O2 =:= ?none -> Sub1; + true -> t_subtract(Sub1, t_opaque_structure(O2)) + end, + t_sup(O, Sub2). + +-spec subtract_union([erl_type()], [erl_type()], non_neg_integer(), [erl_type()]) -> erl_type(). + +subtract_union([T1|Left1], [T2|Left2], N, Acc) -> + case t_subtract(T1, T2) of + ?none -> subtract_union(Left1, Left2, N, [?none|Acc]); + T -> subtract_union(Left1, Left2, N+1, [T|Acc]) + end; +subtract_union([], [], 0, _Acc) -> + ?none; +subtract_union([], [], 1, Acc) -> + [T] = [X || X <- Acc, X =/= ?none], + T; +subtract_union([], [], N, Acc) when is_integer(N), N > 1 -> + ?union(lists:reverse(Acc)). + +replace_nontrivial_element(El1, El2) -> + replace_nontrivial_element(El1, El2, []). + +replace_nontrivial_element([T1|Left1], [?none|Left2], Acc) -> + replace_nontrivial_element(Left1, Left2, [T1|Acc]); +replace_nontrivial_element([_|Left1], [T2|_], Acc) -> + lists:reverse(Acc) ++ [T2|Left1]. + +subtract_bin(?bitstr(U1, B1), ?bitstr(U1, B1)) -> + ?none; +subtract_bin(?bitstr(U1, B1), ?none) -> + t_bitstr(U1, B1); +subtract_bin(?bitstr(U1, B1), ?bitstr(0, B1)) -> + t_bitstr(U1, B1+U1); +subtract_bin(?bitstr(U1, B1), ?bitstr(U1, B2)) -> + if (B1+U1) =/= B2 -> t_bitstr(0, B1); + true -> t_bitstr(U1, B1) + end; +subtract_bin(?bitstr(U1, B1), ?bitstr(U2, B2)) -> + if (2 * U1) =:= U2 -> + if B1 =:= B2 -> + t_bitstr(U2, B1+U1); + (B1 + U1) =:= B2 -> + t_bitstr(U2, B1); + true -> + t_bitstr(U1, B1) + end; + true -> + t_bitstr(U1, B1) + end. + +%%----------------------------------------------------------------------------- +%% Relations +%% + +-spec t_is_equal(erl_type(), erl_type()) -> boolean(). + +t_is_equal(T, T) -> true; +t_is_equal(_, _) -> false. + +-spec t_is_subtype(erl_type(), erl_type()) -> boolean(). + +t_is_subtype(T1, T2) -> + Inf = t_inf(T1, T2), + subtype_is_equal(T1, Inf). + +%% The subtype relation has to behave correctly irrespective of opaque +%% types. +subtype_is_equal(T, T) -> true; +subtype_is_equal(T1, T2) -> + t_is_equal(case t_contains_opaque(T1) of + true -> t_unopaque(T1); + false -> T1 + end, + case t_contains_opaque(T2) of + true -> t_unopaque(T2); + false -> T2 + end). + +-spec t_is_instance(erl_type(), erl_type()) -> boolean(). + +%% XXX. To be removed. +t_is_instance(ConcreteType, Type) -> + t_is_subtype(ConcreteType, t_unopaque(Type)). + +-spec t_do_overlap(erl_type(), erl_type()) -> boolean(). + +t_do_overlap(TypeA, TypeB) -> + not (t_is_none_or_unit(t_inf(TypeA, TypeB))). + +-spec t_unopaque(erl_type()) -> erl_type(). + +t_unopaque(T) -> + t_unopaque(T, 'universe'). + +-spec t_unopaque(erl_type(), opaques()) -> erl_type(). + +t_unopaque(?opaque(_) = T, Opaques) -> + case Opaques =:= 'universe' orelse is_opaque_type(T, Opaques) of + true -> t_unopaque(t_opaque_structure(T), Opaques); + false -> T + end; +t_unopaque(?list(ElemT, Termination, Sz), Opaques) -> + ?list(t_unopaque(ElemT, Opaques), t_unopaque(Termination, Opaques), Sz); +t_unopaque(?tuple(?any, _, _) = T, _) -> T; +t_unopaque(?tuple(ArgTs, Sz, Tag), Opaques) when is_list(ArgTs) -> + NewArgTs = [t_unopaque(A, Opaques) || A <- ArgTs], + ?tuple(NewArgTs, Sz, Tag); +t_unopaque(?tuple_set(Set), Opaques) -> + NewSet = [{Sz, [t_unopaque(T, Opaques) || T <- Tuples]} + || {Sz, Tuples} <- Set], + ?tuple_set(NewSet); +t_unopaque(?product(Types), Opaques) -> + ?product([t_unopaque(T, Opaques) || T <- Types]); +t_unopaque(?function(Domain, Range), Opaques) -> + ?function(t_unopaque(Domain, Opaques), t_unopaque(Range, Opaques)); +t_unopaque(?union([A,B,F,I,L,N,T,M,O,Map]), Opaques) -> + UL = t_unopaque(L, Opaques), + UT = t_unopaque(T, Opaques), + UF = t_unopaque(F, Opaques), + UM = t_unopaque(M, Opaques), + UMap = t_unopaque(Map, Opaques), + {OF,UO} = case t_unopaque(O, Opaques) of + ?opaque(_) = O1 -> {O1, []}; + Type -> {?none, [Type]} + end, + t_sup([?union([A,B,UF,I,UL,N,UT,UM,OF,UMap])|UO]); +t_unopaque(?map(Pairs,DefK,DefV), Opaques) -> + t_map([{K, MNess, t_unopaque(V, Opaques)} || {K, MNess, V} <- Pairs], + t_unopaque(DefK, Opaques), + t_unopaque(DefV, Opaques)); +t_unopaque(T, _) -> + T. + +%%----------------------------------------------------------------------------- +%% K-depth abstraction. +%% +%% t_limit/2 is the exported function, which checks the type of the +%% second argument and calls the module local t_limit_k/2 function. +%% + +-spec t_limit(erl_type(), integer()) -> erl_type(). + +t_limit(Term, K) when is_integer(K) -> + t_limit_k(Term, K). + +t_limit_k(_, K) when K =< 0 -> ?any; +t_limit_k(?tuple(?any, ?any, ?any) = T, _K) -> T; +t_limit_k(?tuple(Elements, Arity, _), K) -> + if K =:= 1 -> t_tuple(Arity); + true -> t_tuple([t_limit_k(E, K-1) || E <- Elements]) + end; +t_limit_k(?tuple_set(_) = T, K) -> + t_sup([t_limit_k(Tuple, K) || Tuple <- t_tuple_subtypes(T)]); +t_limit_k(?list(Elements, Termination, Size), K) -> + NewTermination = + if K =:= 1 -> + %% We do not want to lose the termination information. + t_limit_k(Termination, K); + true -> t_limit_k(Termination, K - 1) + end, + NewElements = t_limit_k(Elements, K - 1), + TmpList = t_cons(NewElements, NewTermination), + case Size of + ?nonempty_qual -> TmpList; + ?unknown_qual -> + ?list(NewElements1, NewTermination1, _) = TmpList, + ?list(NewElements1, NewTermination1, ?unknown_qual) + end; +t_limit_k(?function(Domain, Range), K) -> + %% The domain is either a product or any() so we do not decrease the K. + ?function(t_limit_k(Domain, K), t_limit_k(Range, K-1)); +t_limit_k(?product(Elements), K) -> + ?product([t_limit_k(X, K - 1) || X <- Elements]); +t_limit_k(?union(Elements), K) -> + ?union([t_limit_k(X, K) || X <- Elements]); +t_limit_k(?opaque(Es), K) -> + List = [begin + NewS = t_limit_k(S, K), + Opaque#opaque{struct = NewS} + end || #opaque{struct = S} = Opaque <- set_to_list(Es)], + ?opaque(ordsets:from_list(List)); +t_limit_k(?map(Pairs0, DefK0, DefV0), K) -> + Fun = fun({EK, MNess, EV}, {Exact, DefK1, DefV1}) -> + LV = t_limit_k(EV, K - 1), + case t_limit_k(EK, K - 1) of + EK -> {[{EK,MNess,LV}|Exact], DefK1, DefV1}; + LK -> {Exact, t_sup(LK, DefK1), t_sup(LV, DefV1)} + end + end, + {Pairs, DefK2, DefV2} = lists:foldr(Fun, {[], DefK0, DefV0}, Pairs0), + t_map(Pairs, t_limit_k(DefK2, K - 1), t_limit_k(DefV2, K - 1)); +t_limit_k(T, _K) -> T. + +%%============================================================================ +%% +%% Abstract records. Used for comparing contracts. +%% +%%============================================================================ + +-spec t_abstract_records(erl_type(), type_table()) -> erl_type(). + +t_abstract_records(?list(Contents, Termination, Size), RecDict) -> + case t_abstract_records(Contents, RecDict) of + ?none -> ?none; + NewContents -> + %% Be careful here to make the termination collapse if necessary. + case t_abstract_records(Termination, RecDict) of + ?nil -> ?list(NewContents, ?nil, Size); + ?any -> ?list(NewContents, ?any, Size); + Other -> + ?list(NewContents2, NewTermination, _) = t_cons(NewContents, Other), + ?list(NewContents2, NewTermination, Size) + end + end; +t_abstract_records(?function(Domain, Range), RecDict) -> + ?function(t_abstract_records(Domain, RecDict), + t_abstract_records(Range, RecDict)); +t_abstract_records(?product(Types), RecDict) -> + ?product([t_abstract_records(T, RecDict) || T <- Types]); +t_abstract_records(?union(Types), RecDict) -> + t_sup([t_abstract_records(T, RecDict) || T <- Types]); +t_abstract_records(?tuple(?any, ?any, ?any) = T, _RecDict) -> + T; +t_abstract_records(?tuple(Elements, Arity, ?atom(_) = Tag), RecDict) -> + [TagAtom] = atom_vals(Tag), + case lookup_record(TagAtom, Arity - 1, RecDict) of + error -> t_tuple([t_abstract_records(E, RecDict) || E <- Elements]); + {ok, Fields} -> t_tuple([Tag|[T || {_Name, _Abstr, T} <- Fields]]) + end; +t_abstract_records(?tuple(Elements, _Arity, _Tag), RecDict) -> + t_tuple([t_abstract_records(E, RecDict) || E <- Elements]); +t_abstract_records(?tuple_set(_) = Tuples, RecDict) -> + t_sup([t_abstract_records(T, RecDict) || T <- t_tuple_subtypes(Tuples)]); +t_abstract_records(?opaque(_)=Type, RecDict) -> + t_abstract_records(t_opaque_structure(Type), RecDict); +t_abstract_records(T, _RecDict) -> + T. + +%% Map over types. Depth first. Used by the contract checker. ?list is +%% not fully implemented so take care when changing the type in Termination. + +-spec t_map(fun((erl_type()) -> erl_type()), erl_type()) -> erl_type(). + +t_map(Fun, ?list(Contents, Termination, Size)) -> + Fun(?list(t_map(Fun, Contents), t_map(Fun, Termination), Size)); +t_map(Fun, ?function(Domain, Range)) -> + Fun(?function(t_map(Fun, Domain), t_map(Fun, Range))); +t_map(Fun, ?product(Types)) -> + Fun(?product([t_map(Fun, T) || T <- Types])); +t_map(Fun, ?union(Types)) -> + Fun(t_sup([t_map(Fun, T) || T <- Types])); +t_map(Fun, ?tuple(?any, ?any, ?any) = T) -> + Fun(T); +t_map(Fun, ?tuple(Elements, _Arity, _Tag)) -> + Fun(t_tuple([t_map(Fun, E) || E <- Elements])); +t_map(Fun, ?tuple_set(_) = Tuples) -> + Fun(t_sup([t_map(Fun, T) || T <- t_tuple_subtypes(Tuples)])); +t_map(Fun, ?opaque(Set)) -> + L = [Opaque#opaque{struct = NewS} || + #opaque{struct = S} = Opaque <- set_to_list(Set), + not t_is_none(NewS = t_map(Fun, S))], + Fun(case L of + [] -> ?none; + _ -> ?opaque(ordsets:from_list(L)) + end); +t_map(Fun, ?map(Pairs,DefK,DefV)) -> + %% TODO: + Fun(t_map(Pairs, Fun(DefK), Fun(DefV))); +t_map(Fun, T) -> + Fun(T). + +%%============================================================================= +%% +%% Prettyprinter +%% +%%============================================================================= + +-spec t_to_string(erl_type()) -> string(). + +t_to_string(T) -> + t_to_string(T, dict:new()). + +-spec t_to_string(erl_type(), type_table()) -> string(). + +t_to_string(?any, _RecDict) -> + "any()"; +t_to_string(?none, _RecDict) -> + "none()"; +t_to_string(?unit, _RecDict) -> + "no_return()"; +t_to_string(?atom(?any), _RecDict) -> + "atom()"; +t_to_string(?atom(Set), _RecDict) -> + case set_size(Set) of + 2 -> + case set_is_element(true, Set) andalso set_is_element(false, Set) of + true -> "boolean()"; + false -> set_to_string(Set) + end; + _ -> + set_to_string(Set) + end; +t_to_string(?bitstr(0, 0), _RecDict) -> + "<<>>"; +t_to_string(?bitstr(8, 0), _RecDict) -> + "binary()"; +t_to_string(?bitstr(1, 0), _RecDict) -> + "bitstring()"; +t_to_string(?bitstr(0, B), _RecDict) -> + flat_format("<<_:~w>>", [B]); +t_to_string(?bitstr(U, 0), _RecDict) -> + flat_format("<<_:_*~w>>", [U]); +t_to_string(?bitstr(U, B), _RecDict) -> + flat_format("<<_:~w,_:_*~w>>", [B, U]); +t_to_string(?function(?any, ?any), _RecDict) -> + "fun()"; +t_to_string(?function(?any, Range), RecDict) -> + "fun((...) -> " ++ t_to_string(Range, RecDict) ++ ")"; +t_to_string(?function(?product(ArgList), Range), RecDict) -> + "fun((" ++ comma_sequence(ArgList, RecDict) ++ ") -> " + ++ t_to_string(Range, RecDict) ++ ")"; +t_to_string(?identifier(Set), _RecDict) -> + case Set of + ?any -> "identifier()"; + _ -> + string:join([flat_format("~w()", [T]) || T <- set_to_list(Set)], " | ") + end; +t_to_string(?opaque(Set), RecDict) -> + string:join([opaque_type(Mod, Name, Args, S, RecDict) || + #opaque{mod = Mod, name = Name, struct = S, args = Args} + <- set_to_list(Set)], + " | "); +t_to_string(?matchstate(Pres, Slots), RecDict) -> + flat_format("ms(~s,~s)", [t_to_string(Pres, RecDict), + t_to_string(Slots,RecDict)]); +t_to_string(?nil, _RecDict) -> + "[]"; +t_to_string(?nonempty_list(Contents, Termination), RecDict) -> + ContentString = t_to_string(Contents, RecDict), + case Termination of + ?nil -> + case Contents of + ?char -> "nonempty_string()"; + _ -> "["++ContentString++",...]" + end; + ?any -> + %% Just a safety check. + case Contents =:= ?any of + true -> ok; + false -> + %% XXX. See comment below. + %% erlang:error({illegal_list, ?nonempty_list(Contents, Termination)}) + ok + end, + "nonempty_maybe_improper_list()"; + _ -> + case t_is_subtype(t_nil(), Termination) of + true -> + "nonempty_maybe_improper_list("++ContentString++"," + ++t_to_string(Termination, RecDict)++")"; + false -> + "nonempty_improper_list("++ContentString++"," + ++t_to_string(Termination, RecDict)++")" + end + end; +t_to_string(?list(Contents, Termination, ?unknown_qual), RecDict) -> + ContentString = t_to_string(Contents, RecDict), + case Termination of + ?nil -> + case Contents of + ?char -> "string()"; + _ -> "["++ContentString++"]" + end; + ?any -> + %% Just a safety check. + %% XXX. Types such as "maybe_improper_list(integer(), any())" + %% are OK, but cannot be printed!? + case Contents =:= ?any of + true -> ok; + false -> + ok + %% L = ?list(Contents, Termination, ?unknown_qual), + %% erlang:error({illegal_list, L}) + end, + "maybe_improper_list()"; + _ -> + case t_is_subtype(t_nil(), Termination) of + true -> + "maybe_improper_list("++ContentString++"," + ++t_to_string(Termination, RecDict)++")"; + false -> + "improper_list("++ContentString++"," + ++t_to_string(Termination, RecDict)++")" + end + end; +t_to_string(?int_set(Set), _RecDict) -> + set_to_string(Set); +t_to_string(?byte, _RecDict) -> "byte()"; +t_to_string(?char, _RecDict) -> "char()"; +t_to_string(?integer_pos, _RecDict) -> "pos_integer()"; +t_to_string(?integer_non_neg, _RecDict) -> "non_neg_integer()"; +t_to_string(?integer_neg, _RecDict) -> "neg_integer()"; +t_to_string(?int_range(From, To), _RecDict) -> + flat_format("~w..~w", [From, To]); +t_to_string(?integer(?any), _RecDict) -> "integer()"; +t_to_string(?float, _RecDict) -> "float()"; +t_to_string(?number(?any, ?unknown_qual), _RecDict) -> "number()"; +t_to_string(?product(List), RecDict) -> + "<" ++ comma_sequence(List, RecDict) ++ ">"; +t_to_string(?map([],?any,?any), _RecDict) -> "map()"; +t_to_string(?map(Pairs0,DefK,DefV), RecDict) -> + {Pairs, ExtraEl} = + case {DefK, DefV} of + {?none, ?none} -> {Pairs0, []}; + _ -> {Pairs0 ++ [{DefK,?opt,DefV}], []} + end, + Tos = fun(T) -> case T of + ?any -> "_"; + _ -> t_to_string(T, RecDict) + end end, + StrMand = [{Tos(K),Tos(V)}||{K,?mand,V}<-Pairs], + StrOpt = [{Tos(K),Tos(V)}||{K,?opt,V}<-Pairs], + "#{" ++ string:join([K ++ ":=" ++ V||{K,V}<-StrMand] + ++ [K ++ "=>" ++ V||{K,V}<-StrOpt] + ++ ExtraEl, ", ") ++ "}"; +t_to_string(?tuple(?any, ?any, ?any), _RecDict) -> "tuple()"; +t_to_string(?tuple(Elements, _Arity, ?any), RecDict) -> + "{" ++ comma_sequence(Elements, RecDict) ++ "}"; +t_to_string(?tuple(Elements, Arity, Tag), RecDict) -> + [TagAtom] = atom_vals(Tag), + case lookup_record(TagAtom, Arity-1, RecDict) of + error -> "{" ++ comma_sequence(Elements, RecDict) ++ "}"; + {ok, FieldNames} -> + record_to_string(TagAtom, Elements, FieldNames, RecDict) + end; +t_to_string(?tuple_set(_) = T, RecDict) -> + union_sequence(t_tuple_subtypes(T), RecDict); +t_to_string(?union(Types), RecDict) -> + union_sequence([T || T <- Types, T =/= ?none], RecDict); +t_to_string(?var(Id), _RecDict) when is_atom(Id) -> + flat_format("~s", [atom_to_list(Id)]); +t_to_string(?var(Id), _RecDict) when is_integer(Id) -> + flat_format("var(~w)", [Id]). + + +record_to_string(Tag, [_|Fields], FieldNames, RecDict) -> + FieldStrings = record_fields_to_string(Fields, FieldNames, RecDict, []), + "#" ++ atom_to_string(Tag) ++ "{" ++ string:join(FieldStrings, ",") ++ "}". + +record_fields_to_string([F|Fs], [{FName, _Abstr, DefType}|FDefs], + RecDict, Acc) -> + NewAcc = + case + t_is_equal(F, t_any()) orelse + (t_is_any_atom('undefined', F) andalso + not t_is_none(t_inf(F, DefType))) + of + true -> Acc; + false -> + StrFV = atom_to_string(FName) ++ "::" ++ t_to_string(F, RecDict), + [StrFV|Acc] + end, + record_fields_to_string(Fs, FDefs, RecDict, NewAcc); +record_fields_to_string([], [], _RecDict, Acc) -> + lists:reverse(Acc). + +-spec record_field_diffs_to_string(erl_type(), type_table()) -> string(). + +record_field_diffs_to_string(?tuple([_|Fs], Arity, Tag), RecDict) -> + [TagAtom] = atom_vals(Tag), + {ok, FieldNames} = lookup_record(TagAtom, Arity-1, RecDict), + %% io:format("RecCElems = ~p\nRecTypes = ~p\n", [Fs, FieldNames]), + FieldDiffs = field_diffs(Fs, FieldNames, RecDict, []), + string:join(FieldDiffs, " and "). + +field_diffs([F|Fs], [{FName, _Abstr, DefType}|FDefs], RecDict, Acc) -> + %% Don't care about opaqueness for now. + NewAcc = + case not t_is_none(t_inf(F, DefType)) of + true -> Acc; + false -> + Str = atom_to_string(FName) ++ "::" ++ t_to_string(DefType, RecDict), + [Str|Acc] + end, + field_diffs(Fs, FDefs, RecDict, NewAcc); +field_diffs([], [], _, Acc) -> + lists:reverse(Acc). + +comma_sequence(Types, RecDict) -> + List = [case T =:= ?any of + true -> "_"; + false -> t_to_string(T, RecDict) + end || T <- Types], + string:join(List, ","). + +union_sequence(Types, RecDict) -> + List = [t_to_string(T, RecDict) || T <- Types], + string:join(List, " | "). + +-ifdef(DEBUG). +opaque_type(Mod, Name, _Args, S, RecDict) -> + ArgsString = comma_sequence(_Args, RecDict), + String = t_to_string(S, RecDict), + opaque_name(Mod, Name, ArgsString) ++ "[" ++ String ++ "]". +-else. +opaque_type(Mod, Name, Args, _S, RecDict) -> + ArgsString = comma_sequence(Args, RecDict), + opaque_name(Mod, Name, ArgsString). +-endif. + +opaque_name(Mod, Name, Extra) -> + S = mod_name(Mod, Name), + flat_format("~s(~s)", [S, Extra]). + +mod_name(Mod, Name) -> + flat_format("~w:~w", [Mod, Name]). + +%%============================================================================= +%% +%% Build a type from parse forms. +%% +%%============================================================================= + +-type type_names() :: [type_key() | record_key()]. + +-type mta() :: {module(), atom(), arity()}. +-type mra() :: {module(), atom(), arity()}. +-type site() :: {'type', mta()} | {'spec', mfa()} | {'record', mra()}. +-type cache_key() :: {module(), atom(), expand_depth(), + [erl_type()], type_names()}. +-opaque cache() :: #{cache_key() => {erl_type(), expand_limit()}}. + +-spec t_from_form(parse_form(), sets:set(mfa()), site(), mod_records(), + var_table(), cache()) -> {erl_type(), cache()}. + +t_from_form(Form, ExpTypes, Site, RecDict, VarTab, Cache) -> + t_from_form1(Form, ExpTypes, Site, RecDict, VarTab, Cache). + +%% Replace external types with with none(). +-spec t_from_form_without_remote(parse_form(), site(), type_table()) -> + {erl_type(), cache()}. + +t_from_form_without_remote(Form, Site, TypeTable) -> + Module = site_module(Site), + RecDict = dict:from_list([{Module, TypeTable}]), + ExpTypes = replace_by_none, + VarTab = var_table__new(), + Cache = cache__new(), + t_from_form1(Form, ExpTypes, Site, RecDict, VarTab, Cache). + +%% REC_TYPE_LIMIT is used for limiting the depth of recursive types. +%% EXPAND_LIMIT is used for limiting the size of types by +%% limiting the number of elements of lists within one type form. +%% EXPAND_DEPTH is used in conjunction with EXPAND_LIMIT to make the +%% types balanced (unions will otherwise collapse to any()) by limiting +%% the depth the same way as t_limit/2 does. + +-type expand_limit() :: integer(). + +-type expand_depth() :: integer(). + +-record(from_form, {site :: site(), + xtypes :: sets:set(mfa()) | 'replace_by_none', + mrecs :: mod_records(), + vtab :: var_table(), + tnames :: type_names()}). + +-spec t_from_form1(parse_form(), sets:set(mfa()) | 'replace_by_none', + site(), mod_records(), var_table(), cache()) -> + {erl_type(), cache()}. + +t_from_form1(Form, ET, Site, MR, V, C) -> + TypeNames = initial_typenames(Site), + State = #from_form{site = Site, + xtypes = ET, + mrecs = MR, + vtab = V, + tnames = TypeNames}, + L = ?EXPAND_LIMIT, + {T1, L1, C1} = from_form(Form, State, ?EXPAND_DEPTH, L, C), + if + L1 =< 0 -> + from_form_loop(Form, State, 1, L, C1); + true -> + {T1, C1} + end. + +initial_typenames({type, _MTA}=Site) -> [Site]; +initial_typenames({spec, _MFA}) -> []; +initial_typenames({record, _MRA}) -> []. + +from_form_loop(Form, State, D, Limit, C) -> + {T1, L1, C1} = from_form(Form, State, D, Limit, C), + Delta = Limit - L1, + if + %% Save some time by assuming next depth will exceed the limit. + Delta * 8 > Limit -> + {T1, C1}; + true -> + D1 = D + 1, + from_form_loop(Form, State, D1, Limit, C1) + end. + +-spec from_form(parse_form(), + #from_form{}, + expand_depth(), + expand_limit(), + cache()) -> {erl_type(), expand_limit(), cache()}. + +%% If there is something wrong with parse_form() +%% throw({error, io_lib:chars()} is called; +%% for unknown remote types +%% self() ! {self(), ext_types, {RemMod, Name, ArgsLen}} +%% is called, unless 'replace_by_none' is given. +%% +%% It is assumed that site_module(S) can be found in MR. + +from_form(_, _S, D, L, C) when D =< 0 ; L =< 0 -> + {t_any(), L, C}; +from_form({var, _L, '_'}, _S, _D, L, C) -> + {t_any(), L, C}; +from_form({var, _L, Name}, S, _D, L, C) -> + V = S#from_form.vtab, + case maps:find(Name, V) of + error -> {t_var(Name), L, C}; + {ok, Val} -> {Val, L, C} + end; +from_form({ann_type, _L, [_Var, Type]}, S, D, L, C) -> + from_form(Type, S, D, L, C); +from_form({paren_type, _L, [Type]}, S, D, L, C) -> + from_form(Type, S, D, L, C); +from_form({remote_type, _L, [{atom, _, Module}, {atom, _, Type}, Args]}, + S, D, L, C) -> + remote_from_form(Module, Type, Args, S, D, L, C); +from_form({atom, _L, Atom}, _S, _D, L, C) -> + {t_atom(Atom), L, C}; +from_form({integer, _L, Int}, _S, _D, L, C) -> + {t_integer(Int), L, C}; +from_form({op, _L, _Op, _Arg} = Op, _S, _D, L, C) -> + case erl_eval:partial_eval(Op) of + {integer, _, Val} -> + {t_integer(Val), L, C}; + _ -> throw({error, io_lib:format("Unable to evaluate type ~w\n", [Op])}) + end; +from_form({op, _L, _Op, _Arg1, _Arg2} = Op, _S, _D, L, C) -> + case erl_eval:partial_eval(Op) of + {integer, _, Val} -> + {t_integer(Val), L, C}; + _ -> throw({error, io_lib:format("Unable to evaluate type ~w\n", [Op])}) + end; +from_form({type, _L, any, []}, _S, _D, L, C) -> + {t_any(), L, C}; +from_form({type, _L, arity, []}, _S, _D, L, C) -> + {t_arity(), L, C}; +from_form({type, _L, atom, []}, _S, _D, L, C) -> + {t_atom(), L, C}; +from_form({type, _L, binary, []}, _S, _D, L, C) -> + {t_binary(), L, C}; +from_form({type, _L, binary, [Base, Unit]} = Type, _S, _D, L, C) -> + case {erl_eval:partial_eval(Base), erl_eval:partial_eval(Unit)} of + {{integer, _, B}, {integer, _, U}} when B >= 0, U >= 0 -> + {t_bitstr(U, B), L, C}; + _ -> throw({error, io_lib:format("Unable to evaluate type ~w\n", [Type])}) + end; +from_form({type, _L, bitstring, []}, _S, _D, L, C) -> + {t_bitstr(), L, C}; +from_form({type, _L, bool, []}, _S, _D, L, C) -> + {t_boolean(), L, C}; % XXX: Temporarily +from_form({type, _L, boolean, []}, _S, _D, L, C) -> + {t_boolean(), L, C}; +from_form({type, _L, byte, []}, _S, _D, L, C) -> + {t_byte(), L, C}; +from_form({type, _L, char, []}, _S, _D, L, C) -> + {t_char(), L, C}; +from_form({type, _L, float, []}, _S, _D, L, C) -> + {t_float(), L, C}; +from_form({type, _L, function, []}, _S, _D, L, C) -> + {t_fun(), L, C}; +from_form({type, _L, 'fun', []}, _S, _D, L, C) -> + {t_fun(), L, C}; +from_form({type, _L, 'fun', [{type, _, any}, Range]}, S, D, L, C) -> + {T, L1, C1} = from_form(Range, S, D - 1, L - 1, C), + {t_fun(T), L1, C1}; +from_form({type, _L, 'fun', [{type, _, product, Domain}, Range]}, + S, D, L, C) -> + {Dom1, L1, C1} = list_from_form(Domain, S, D, L, C), + {Ran1, L2, C2} = from_form(Range, S, D, L1, C1), + {t_fun(Dom1, Ran1), L2, C2}; +from_form({type, _L, identifier, []}, _S, _D, L, C) -> + {t_identifier(), L, C}; +from_form({type, _L, integer, []}, _S, _D, L, C) -> + {t_integer(), L, C}; +from_form({type, _L, iodata, []}, _S, _D, L, C) -> + {t_iodata(), L, C}; +from_form({type, _L, iolist, []}, _S, _D, L, C) -> + {t_iolist(), L, C}; +from_form({type, _L, list, []}, _S, _D, L, C) -> + {t_list(), L, C}; +from_form({type, _L, list, [Type]}, S, D, L, C) -> + {T, L1, C1} = from_form(Type, S, D - 1, L - 1, C), + {t_list(T), L1, C1}; +from_form({type, _L, map, any}, S, D, L, C) -> + builtin_type(map, t_map(), S, D, L, C); +from_form({type, _L, map, List}, S, D0, L, C) -> + {Pairs1, L5, C5} = + fun PairsFromForm(_, L1, C1) when L1 =< 0 -> {[{?any,?opt,?any}], L1, C1}; + PairsFromForm([], L1, C1) -> {[], L1, C1}; + PairsFromForm([{type, _, Oper, [KF, VF]}|T], L1, C1) -> + D = D0 - 1, + {Key, L2, C2} = from_form(KF, S, D, L1, C1), + {Val, L3, C3} = from_form(VF, S, D, L2, C2), + {Pairs0, L4, C4} = PairsFromForm(T, L3 - 1, C3), + case Oper of + map_field_assoc -> {[{Key,?opt, Val}|Pairs0], L4, C4}; + map_field_exact -> {[{Key,?mand,Val}|Pairs0], L4, C4} + end + end(List, L, C), + try + {Pairs, DefK, DefV} = map_from_form(Pairs1, [], [], [], ?none, ?none), + {t_map(Pairs, DefK, DefV), L5, C5} + catch none -> {t_none(), L5, C5} + end; +from_form({type, _L, mfa, []}, _S, _D, L, C) -> + {t_mfa(), L, C}; +from_form({type, _L, module, []}, _S, _D, L, C) -> + {t_module(), L, C}; +from_form({type, _L, nil, []}, _S, _D, L, C) -> + {t_nil(), L, C}; +from_form({type, _L, neg_integer, []}, _S, _D, L, C) -> + {t_neg_integer(), L, C}; +from_form({type, _L, non_neg_integer, []}, _S, _D, L, C) -> + {t_non_neg_integer(), L, C}; +from_form({type, _L, no_return, []}, _S, _D, L, C) -> + {t_unit(), L, C}; +from_form({type, _L, node, []}, _S, _D, L, C) -> + {t_node(), L, C}; +from_form({type, _L, none, []}, _S, _D, L, C) -> + {t_none(), L, C}; +from_form({type, _L, nonempty_list, []}, _S, _D, L, C) -> + {t_nonempty_list(), L, C}; +from_form({type, _L, nonempty_list, [Type]}, S, D, L, C) -> + {T, L1, C1} = from_form(Type, S, D, L - 1, C), + {t_nonempty_list(T), L1, C1}; +from_form({type, _L, nonempty_improper_list, [Cont, Term]}, S, D, L, C) -> + {T1, L1, C1} = from_form(Cont, S, D, L - 1, C), + {T2, L2, C2} = from_form(Term, S, D, L1, C1), + {t_cons(T1, T2), L2, C2}; +from_form({type, _L, nonempty_maybe_improper_list, []}, _S, _D, L, C) -> + {t_cons(?any, ?any), L, C}; +from_form({type, _L, nonempty_maybe_improper_list, [Cont, Term]}, + S, D, L, C) -> + {T1, L1, C1} = from_form(Cont, S, D, L - 1, C), + {T2, L2, C2} = from_form(Term, S, D, L1, C1), + {t_cons(T1, T2), L2, C2}; +from_form({type, _L, nonempty_string, []}, _S, _D, L, C) -> + {t_nonempty_string(), L, C}; +from_form({type, _L, number, []}, _S, _D, L, C) -> + {t_number(), L, C}; +from_form({type, _L, pid, []}, _S, _D, L, C) -> + {t_pid(), L, C}; +from_form({type, _L, port, []}, _S, _D, L, C) -> + {t_port(), L, C}; +from_form({type, _L, pos_integer, []}, _S, _D, L, C) -> + {t_pos_integer(), L, C}; +from_form({type, _L, maybe_improper_list, []}, _S, _D, L, C) -> + {t_maybe_improper_list(), L, C}; +from_form({type, _L, maybe_improper_list, [Content, Termination]}, + S, D, L, C) -> + {T1, L1, C1} = from_form(Content, S, D, L - 1, C), + {T2, L2, C2} = from_form(Termination, S, D, L1, C1), + {t_maybe_improper_list(T1, T2), L2, C2}; +from_form({type, _L, product, Elements}, S, D, L, C) -> + {Lst, L1, C1} = list_from_form(Elements, S, D - 1, L, C), + {t_product(Lst), L1, C1}; +from_form({type, _L, range, [From, To]} = Type, _S, _D, L, C) -> + case {erl_eval:partial_eval(From), erl_eval:partial_eval(To)} of + {{integer, _, FromVal}, {integer, _, ToVal}} -> + {t_from_range(FromVal, ToVal), L, C}; + _ -> throw({error, io_lib:format("Unable to evaluate type ~w\n", [Type])}) + end; +from_form({type, _L, record, [Name|Fields]}, S, D, L, C) -> + record_from_form(Name, Fields, S, D, L, C); +from_form({type, _L, reference, []}, _S, _D, L, C) -> + {t_reference(), L, C}; +from_form({type, _L, string, []}, _S, _D, L, C) -> + {t_string(), L, C}; +from_form({type, _L, term, []}, _S, _D, L, C) -> + {t_any(), L, C}; +from_form({type, _L, timeout, []}, _S, _D, L, C) -> + {t_timeout(), L, C}; +from_form({type, _L, tuple, any}, _S, _D, L, C) -> + {t_tuple(), L, C}; +from_form({type, _L, tuple, Args}, S, D, L, C) -> + {Lst, L1, C1} = list_from_form(Args, S, D - 1, L, C), + {t_tuple(Lst), L1, C1}; +from_form({type, _L, union, Args}, S, D, L, C) -> + {Lst, L1, C1} = list_from_form(Args, S, D, L, C), + {t_sup(Lst), L1, C1}; +from_form({user_type, _L, Name, Args}, S, D, L, C) -> + type_from_form(Name, Args, S, D, L, C); +from_form({type, _L, Name, Args}, S, D, L, C) -> + %% Compatibility: modules compiled before Erlang/OTP 18.0. + type_from_form(Name, Args, S, D, L, C); +from_form({opaque, _L, Name, {Mod, Args, Rep}}, _S, _D, L, C) -> + %% XXX. To be removed. + {t_opaque(Mod, Name, Args, Rep), L, C}. + +builtin_type(Name, Type, S, D, L, C) -> + #from_form{site = Site, mrecs = MR} = S, + M = site_module(Site), + case dict:find(M, MR) of + {ok, R} -> + case lookup_type(Name, 0, R) of + {_, {{_M, _FL, _F, _A}, _T}} -> + type_from_form(Name, [], S, D, L, C); + error -> + {Type, L, C} + end; + error -> + {Type, L, C} + end. + +type_from_form(Name, Args, S, D, L, C) -> + #from_form{site = Site, mrecs = MR, tnames = TypeNames} = S, + ArgsLen = length(Args), + Module = site_module(Site), + TypeName = {type, {Module, Name, ArgsLen}}, + case can_unfold_more(TypeName, TypeNames) of + true -> + {ok, R} = dict:find(Module, MR), + type_from_form1(Name, Args, ArgsLen, R, TypeName, TypeNames, + S, D, L, C); + false -> + {t_any(), L, C} + end. + +type_from_form1(Name, Args, ArgsLen, R, TypeName, TypeNames, S, D, L, C) -> + case lookup_type(Name, ArgsLen, R) of + {Tag, {{Module, _FileName, Form, ArgNames}, Type}} -> + NewTypeNames = [TypeName|TypeNames], + S1 = S#from_form{tnames = NewTypeNames}, + {ArgTypes, L1, C1} = list_from_form(Args, S1, D, L, C), + CKey = cache_key(Module, Name, ArgTypes, TypeNames, D), + case cache_find(CKey, C) of + {CachedType, DeltaL} -> + {CachedType, L1 - DeltaL, C}; + error -> + List = lists:zip(ArgNames, ArgTypes), + TmpV = maps:from_list(List), + S2 = S1#from_form{site = TypeName, vtab = TmpV}, + Fun = fun(DD, LL) -> from_form(Form, S2, DD, LL, C1) end, + {NewType, L3, C3} = + case Tag of + type -> + recur_limit(Fun, D, L1, TypeName, TypeNames); + opaque -> + {Rep, L2, C2} = recur_limit(Fun, D, L1, TypeName, TypeNames), + Rep1 = choose_opaque_type(Rep, Type), + Rep2 = case cannot_have_opaque(Rep1, TypeName, TypeNames) of + true -> Rep1; + false -> + ArgTypes2 = subst_all_vars_to_any_list(ArgTypes), + t_opaque(Module, Name, ArgTypes2, Rep1) + end, + {Rep2, L2, C2} + end, + C4 = cache_put(CKey, NewType, L1 - L3, C3), + {NewType, L3, C4} + end; + error -> + Msg = io_lib:format("Unable to find type ~w/~w\n", + [Name, ArgsLen]), + throw({error, Msg}) + end. + +remote_from_form(RemMod, Name, Args, S, D, L, C) -> + #from_form{xtypes = ET, mrecs = MR, tnames = TypeNames} = S, + if + ET =:= replace_by_none -> + {t_none(), L, C}; + true -> + ArgsLen = length(Args), + MFA = {RemMod, Name, ArgsLen}, + case dict:find(RemMod, MR) of + error -> + self() ! {self(), ext_types, MFA}, + {t_any(), L, C}; + {ok, RemDict} -> + case sets:is_element(MFA, ET) of + true -> + RemType = {type, MFA}, + case can_unfold_more(RemType, TypeNames) of + true -> + remote_from_form1(RemMod, Name, Args, ArgsLen, RemDict, + RemType, TypeNames, S, D, L, C); + false -> + {t_any(), L, C} + end; + false -> + self() ! {self(), ext_types, {RemMod, Name, ArgsLen}}, + {t_any(), L, C} + end + end + end. + +remote_from_form1(RemMod, Name, Args, ArgsLen, RemDict, RemType, TypeNames, + S, D, L, C) -> + case lookup_type(Name, ArgsLen, RemDict) of + {Tag, {{Mod, _FileLine, Form, ArgNames}, Type}} -> + NewTypeNames = [RemType|TypeNames], + S1 = S#from_form{tnames = NewTypeNames}, + {ArgTypes, L1, C1} = list_from_form(Args, S1, D, L, C), + CKey = cache_key(RemMod, Name, ArgTypes, TypeNames, D), + %% case error of + case cache_find(CKey, C) of + {CachedType, DeltaL} -> + {CachedType, L - DeltaL, C}; + error -> + List = lists:zip(ArgNames, ArgTypes), + TmpVarTab = maps:from_list(List), + S2 = S1#from_form{site = RemType, vtab = TmpVarTab}, + Fun = fun(DD, LL) -> from_form(Form, S2, DD, LL, C1) end, + {NewType, L3, C3} = + case Tag of + type -> + recur_limit(Fun, D, L1, RemType, TypeNames); + opaque -> + {NewRep, L2, C2} = recur_limit(Fun, D, L1, RemType, TypeNames), + NewRep1 = choose_opaque_type(NewRep, Type), + NewRep2 = + case cannot_have_opaque(NewRep1, RemType, TypeNames) of + true -> NewRep1; + false -> + ArgTypes2 = subst_all_vars_to_any_list(ArgTypes), + t_opaque(Mod, Name, ArgTypes2, NewRep1) + end, + {NewRep2, L2, C2} + end, + C4 = cache_put(CKey, NewType, L1 - L3, C3), + {NewType, L3, C4} + end; + error -> + Msg = io_lib:format("Unable to find remote type ~w:~w()\n", + [RemMod, Name]), + throw({error, Msg}) + end. + +subst_all_vars_to_any_list(Types) -> + [subst_all_vars_to_any(Type) || Type <- Types]. + +%% Opaque types (both local and remote) are problematic when it comes +%% to the limits (TypeNames, D, and L). The reason is that if any() is +%% substituted for a more specialized subtype of an opaque type, the +%% property stated along with decorate_with_opaque() (the type has to +%% be a subtype of the declared type) no longer holds. +%% +%% The less than perfect remedy: if the opaque type created from a +%% form is not a subset of the declared type, the declared type is +%% used instead, effectively bypassing the limits, and potentially +%% resulting in huge types. +choose_opaque_type(Type, DeclType) -> + case + t_is_subtype(subst_all_vars_to_any(Type), + subst_all_vars_to_any(DeclType)) + of + true -> Type; + false -> DeclType + end. + +record_from_form({atom, _, Name}, ModFields, S, D0, L0, C) -> + #from_form{site = Site, mrecs = MR, tnames = TypeNames} = S, + RecordType = {record, Name}, + case can_unfold_more(RecordType, TypeNames) of + true -> + M = site_module(Site), + {ok, R} = dict:find(M, MR), + case lookup_record(Name, R) of + {ok, DeclFields} -> + NewTypeNames = [RecordType|TypeNames], + Site1 = {record, {M, Name, length(DeclFields)}}, + S1 = S#from_form{site = Site1, tnames = NewTypeNames}, + Fun = fun(D, L) -> + {GetModRec, L1, C1} = + get_mod_record(ModFields, DeclFields, S1, D, L, C), + case GetModRec of + {error, FieldName} -> + throw({error, + io_lib:format("Illegal declaration of #~w{~w}\n", + [Name, FieldName])}); + {ok, NewFields} -> + S2 = S1#from_form{vtab = var_table__new()}, + {NewFields1, L2, C2} = + fields_from_form(NewFields, S2, D, L1, C1), + Rec = t_tuple( + [t_atom(Name)|[Type + || {_FieldName, Type} <- NewFields1]]), + {Rec, L2, C2} + end + end, + recur_limit(Fun, D0, L0, RecordType, TypeNames); + error -> + throw({error, io_lib:format("Unknown record #~w{}\n", [Name])}) + end; + false -> + {t_any(), L0, C} + end. + +get_mod_record([], DeclFields, _S, _D, L, C) -> + {{ok, DeclFields}, L, C}; +get_mod_record(ModFields, DeclFields, S, D, L, C) -> + DeclFieldsDict = lists:keysort(1, DeclFields), + {ModFieldsDict, L1, C1} = build_field_dict(ModFields, S, D, L, C), + case get_mod_record_types(DeclFieldsDict, ModFieldsDict, []) of + {error, _FieldName} = Error -> {Error, L1, C1}; + {ok, FinalKeyDict} -> + Fields = [lists:keyfind(FieldName, 1, FinalKeyDict) + || {FieldName, _, _} <- DeclFields], + {{ok, Fields}, L1, C1} + end. + +build_field_dict(FieldTypes, S, D, L, C) -> + build_field_dict(FieldTypes, S, D, L, C, []). + +build_field_dict([{type, _, field_type, [{atom, _, Name}, Type]}|Left], + S, D, L, C, Acc) -> + {T, L1, C1} = from_form(Type, S, D, L - 1, C), + NewAcc = [{Name, Type, T}|Acc], + build_field_dict(Left, S, D, L1, C1, NewAcc); +build_field_dict([], _S, _D, L, C, Acc) -> + {lists:keysort(1, Acc), L, C}. + +get_mod_record_types([{FieldName, _Abstr, _DeclType}|Left1], + [{FieldName, TypeForm, ModType}|Left2], + Acc) -> + get_mod_record_types(Left1, Left2, [{FieldName, TypeForm, ModType}|Acc]); +get_mod_record_types([{FieldName1, _Abstr, _DeclType} = DT|Left1], + [{FieldName2, _FormType, _ModType}|_] = List2, + Acc) when FieldName1 < FieldName2 -> + get_mod_record_types(Left1, List2, [DT|Acc]); +get_mod_record_types(Left1, [], Acc) -> + {ok, lists:keysort(1, Left1++Acc)}; +get_mod_record_types(_, [{FieldName2, _FormType, _ModType}|_], _Acc) -> + {error, FieldName2}. + +%% It is important to create a limited version of the record type +%% since nested record types can otherwise easily result in huge +%% terms. +fields_from_form([], _S, _D, L, C) -> + {[], L, C}; +fields_from_form([{Name, Abstr, _Type}|Tail], S, D, L, C) -> + {T, L1, C1} = from_form(Abstr, S, D, L, C), + {F, L2, C2} = fields_from_form(Tail, S, D, L1, C1), + {[{Name, T}|F], L2, C2}. + +list_from_form([], _S, _D, L, C) -> + {[], L, C}; +list_from_form([H|Tail], S, D, L, C) -> + {H1, L1, C1} = from_form(H, S, D, L - 1, C), + {T1, L2, C2} = list_from_form(Tail, S, D, L1, C1), + {[H1|T1], L2, C2}. + +%% Sorts, combines non-singleton pairs, and applies precendence and +%% mandatoriness rules. +map_from_form([], ShdwPs, MKs, Pairs, DefK, DefV) -> + verify_possible(MKs, ShdwPs), + {promote_to_mand(MKs, Pairs), DefK, DefV}; +map_from_form([{SKey,MNess,Val}|SPairs], ShdwPs0, MKs0, Pairs0, DefK0, DefV0) -> + Key = lists:foldl(fun({K,_},S)->t_subtract(S,K)end, SKey, ShdwPs0), + ShdwPs = case Key of ?none -> ShdwPs0; _ -> [{Key,Val}|ShdwPs0] end, + MKs = case MNess of ?mand -> [SKey|MKs0]; ?opt -> MKs0 end, + if MNess =:= ?mand, SKey =:= ?none -> throw(none); + true -> ok + end, + {Pairs, DefK, DefV} = + case is_singleton_type(Key) of + true -> + MNess1 = case Val =:= ?none of true -> ?opt; false -> MNess end, + {mapdict_insert({Key,MNess1,Val}, Pairs0), DefK0, DefV0}; + false -> + case Key =:= ?none orelse Val =:= ?none of + true -> {Pairs0, DefK0, DefV0}; + false -> {Pairs0, t_sup(DefK0, Key), t_sup(DefV0, Val)} + end + end, + map_from_form(SPairs, ShdwPs, MKs, Pairs, DefK, DefV). + +%% Verifies that all mandatory keys are possible, throws 'none' otherwise +verify_possible(MKs, ShdwPs) -> + lists:foreach(fun(M) -> verify_possible_1(M, ShdwPs) end, MKs). + +verify_possible_1(M, ShdwPs) -> + case lists:any(fun({K,_}) -> t_inf(M, K) =/= ?none end, ShdwPs) of + true -> ok; + false -> throw(none) + end. + +-spec promote_to_mand([erl_type()], t_map_dict()) -> t_map_dict(). + +promote_to_mand(_, []) -> []; +promote_to_mand(MKs, [E={K,_,V}|T]) -> + [case lists:any(fun(M) -> t_is_equal(K,M) end, MKs) of + true -> {K, ?mand, V}; + false -> E + end|promote_to_mand(MKs, T)]. + +-define(RECUR_EXPAND_LIMIT, 10). +-define(RECUR_EXPAND_DEPTH, 2). + +%% If more of the limited resources is spent on the non-recursive +%% forms, more warnings are found. And the analysis is also a bit +%% faster. +%% +%% Setting REC_TYPE_LIMIT to 1 would work also work well. + +recur_limit(Fun, D, L, _, _) when L =< ?RECUR_EXPAND_DEPTH, + D =< ?RECUR_EXPAND_LIMIT -> + Fun(D, L); +recur_limit(Fun, D, L, TypeName, TypeNames) -> + case is_recursive(TypeName, TypeNames) of + true -> + {T, L1, C1} = Fun(?RECUR_EXPAND_DEPTH, ?RECUR_EXPAND_LIMIT), + {T, L - L1, C1}; + false -> + Fun(D, L) + end. + +-spec t_check_record_fields(parse_form(), sets:set(mfa()), site(), + mod_records(), var_table(), cache()) -> cache(). + +t_check_record_fields(Form, ExpTypes, Site, RecDict, VarTable, Cache) -> + State = #from_form{site = Site, + xtypes = ExpTypes, + mrecs = RecDict, + vtab = VarTable, + tnames = []}, + check_record_fields(Form, State, Cache). + +-spec check_record_fields(parse_form(), #from_form{}, cache()) -> cache(). + +%% If there is something wrong with parse_form() +%% throw({error, io_lib:chars()} is called. + +check_record_fields({var, _L, _}, _S, C) -> C; +check_record_fields({ann_type, _L, [_Var, Type]}, S, C) -> + check_record_fields(Type, S, C); +check_record_fields({paren_type, _L, [Type]}, S, C) -> + check_record_fields(Type, S, C); +check_record_fields({remote_type, _L, [{atom, _, _}, {atom, _, _}, Args]}, + S, C) -> + list_check_record_fields(Args, S, C); +check_record_fields({atom, _L, _}, _S, C) -> C; +check_record_fields({integer, _L, _}, _S, C) -> C; +check_record_fields({op, _L, _Op, _Arg}, _S, C) -> C; +check_record_fields({op, _L, _Op, _Arg1, _Arg2}, _S, C) -> C; +check_record_fields({type, _L, tuple, any}, _S, C) -> C; +check_record_fields({type, _L, map, any}, _S, C) -> C; +check_record_fields({type, _L, binary, [_Base, _Unit]}, _S, C) -> C; +check_record_fields({type, _L, 'fun', [{type, _, any}, Range]}, S, C) -> + check_record_fields(Range, S, C); +check_record_fields({type, _L, range, [_From, _To]}, _S, C) -> C; +check_record_fields({type, _L, record, [Name|Fields]}, S, C) -> + check_record(Name, Fields, S, C); +check_record_fields({type, _L, _, Args}, S, C) -> + list_check_record_fields(Args, S, C); +check_record_fields({user_type, _L, _Name, Args}, S, C) -> + list_check_record_fields(Args, S, C). + +check_record({atom, _, Name}, ModFields, S, C) -> + #from_form{site = Site, mrecs = MR} = S, + M = site_module(Site), + {ok, R} = dict:find(M, MR), + {ok, DeclFields} = lookup_record(Name, R), + case check_fields(Name, ModFields, DeclFields, S, C) of + {error, FieldName} -> + throw({error, io_lib:format("Illegal declaration of #~w{~w}\n", + [Name, FieldName])}); + C1 -> C1 + end. + +check_fields(RecName, [{type, _, field_type, [{atom, _, Name}, Abstr]}|Left], + DeclFields, S, C) -> + #from_form{site = Site0, xtypes = ET, mrecs = MR, vtab = V} = S, + M = site_module(Site0), + Site = {record, {M, RecName, length(DeclFields)}}, + {Type, C1} = t_from_form(Abstr, ET, Site, MR, V, C), + {Name, _, DeclType} = lists:keyfind(Name, 1, DeclFields), + TypeNoVars = subst_all_vars_to_any(Type), + case t_is_subtype(TypeNoVars, DeclType) of + false -> {error, Name}; + true -> check_fields(RecName, Left, DeclFields, S, C1) + end; +check_fields(_RecName, [], _Decl, _S, C) -> + C. + +list_check_record_fields([], _S, C) -> + C; +list_check_record_fields([H|Tail], S, C) -> + C1 = check_record_fields(H, S, C), + list_check_record_fields(Tail, S, C1). + +site_module({_, {Module, _, _}}) -> + Module. + +-spec cache__new() -> cache(). + +cache__new() -> + maps:new(). + +-spec cache_key(module(), atom(), [erl_type()], + type_names(), expand_depth()) -> cache_key(). + +%% If TypeNames is left out from the key, the cache is smaller, and +%% the form-to-type translation is faster. But it would be a shame if, +%% for example, any() is used, where a more complex type should be +%% used. There is also a slight risk of creating unnecessarily big +%% types. + +cache_key(Module, Name, ArgTypes, TypeNames, D) -> + {Module, Name, D, ArgTypes, TypeNames}. + +-spec cache_find(cache_key(), cache()) -> + {erl_type(), expand_limit()} | 'error'. + +cache_find(Key, Cache) -> + case maps:find(Key, Cache) of + {ok, Value} -> + Value; + error -> + error + end. + +-spec cache_put(cache_key(), erl_type(), expand_limit(), cache()) -> cache(). + +cache_put(_Key, _Type, DeltaL, Cache) when DeltaL < 0 -> + %% The type is truncated; do not reuse it. + Cache; +cache_put(Key, Type, DeltaL, Cache) -> + maps:put(Key, {Type, DeltaL}, Cache). + +-spec t_var_names([erl_type()]) -> [atom()]. + +t_var_names([{var, _, Name}|L]) when L =/= '_' -> + [Name|t_var_names(L)]; +t_var_names([]) -> + []. + +-spec t_form_to_string(parse_form()) -> string(). + +t_form_to_string({var, _L, '_'}) -> "_"; +t_form_to_string({var, _L, Name}) -> atom_to_list(Name); +t_form_to_string({atom, _L, Atom}) -> + io_lib:write_string(atom_to_list(Atom), $'); % To quote or not to quote... ' +t_form_to_string({integer, _L, Int}) -> integer_to_list(Int); +t_form_to_string({op, _L, _Op, _Arg} = Op) -> + case erl_eval:partial_eval(Op) of + {integer, _, _} = Int -> t_form_to_string(Int); + _ -> io_lib:format("Badly formed type ~w", [Op]) + end; +t_form_to_string({op, _L, _Op, _Arg1, _Arg2} = Op) -> + case erl_eval:partial_eval(Op) of + {integer, _, _} = Int -> t_form_to_string(Int); + _ -> io_lib:format("Badly formed type ~w", [Op]) + end; +t_form_to_string({ann_type, _L, [Var, Type]}) -> + t_form_to_string(Var) ++ "::" ++ t_form_to_string(Type); +t_form_to_string({paren_type, _L, [Type]}) -> + flat_format("(~s)", [t_form_to_string(Type)]); +t_form_to_string({remote_type, _L, [{atom, _, Mod}, {atom, _, Name}, Args]}) -> + ArgString = "(" ++ string:join(t_form_to_string_list(Args), ",") ++ ")", + flat_format("~w:~w", [Mod, Name]) ++ ArgString; +t_form_to_string({type, _L, arity, []}) -> "arity()"; +t_form_to_string({type, _L, binary, []}) -> "binary()"; +t_form_to_string({type, _L, binary, [Base, Unit]} = Type) -> + case {erl_eval:partial_eval(Base), erl_eval:partial_eval(Unit)} of + {{integer, _, B}, {integer, _, U}} -> + %% the following mirrors the clauses of t_to_string/2 + case {U, B} of + {0, 0} -> "<<>>"; + {8, 0} -> "binary()"; + {1, 0} -> "bitstring()"; + {0, B} -> flat_format("<<_:~w>>", [B]); + {U, 0} -> flat_format("<<_:_*~w>>", [U]); + {U, B} -> flat_format("<<_:~w,_:_*~w>>", [B, U]) + end; + _ -> io_lib:format("Badly formed bitstr type ~w", [Type]) + end; +t_form_to_string({type, _L, bitstring, []}) -> "bitstring()"; +t_form_to_string({type, _L, 'fun', []}) -> "fun()"; +t_form_to_string({type, _L, 'fun', [{type, _, any}, Range]}) -> + "fun(...) -> " ++ t_form_to_string(Range); +t_form_to_string({type, _L, 'fun', [{type, _, product, Domain}, Range]}) -> + "fun((" ++ string:join(t_form_to_string_list(Domain), ",") ++ ") -> " + ++ t_form_to_string(Range) ++ ")"; +t_form_to_string({type, _L, iodata, []}) -> "iodata()"; +t_form_to_string({type, _L, iolist, []}) -> "iolist()"; +t_form_to_string({type, _L, list, [Type]}) -> + "[" ++ t_form_to_string(Type) ++ "]"; +t_form_to_string({type, _L, map, any}) -> "map()"; +t_form_to_string({type, _L, map, Args}) -> + "#{" ++ string:join(t_form_to_string_list(Args), ",") ++ "}"; +t_form_to_string({type, _L, map_field_assoc, [Key, Val]}) -> + t_form_to_string(Key) ++ "=>" ++ t_form_to_string(Val); +t_form_to_string({type, _L, map_field_exact, [Key, Val]}) -> + t_form_to_string(Key) ++ ":=" ++ t_form_to_string(Val); +t_form_to_string({type, _L, mfa, []}) -> "mfa()"; +t_form_to_string({type, _L, module, []}) -> "module()"; +t_form_to_string({type, _L, node, []}) -> "node()"; +t_form_to_string({type, _L, nonempty_list, [Type]}) -> + "[" ++ t_form_to_string(Type) ++ ",...]"; +t_form_to_string({type, _L, nonempty_string, []}) -> "nonempty_string()"; +t_form_to_string({type, _L, product, Elements}) -> + "<" ++ string:join(t_form_to_string_list(Elements), ",") ++ ">"; +t_form_to_string({type, _L, range, [From, To]} = Type) -> + case {erl_eval:partial_eval(From), erl_eval:partial_eval(To)} of + {{integer, _, FromVal}, {integer, _, ToVal}} -> + flat_format("~w..~w", [FromVal, ToVal]); + _ -> flat_format("Badly formed type ~w",[Type]) + end; +t_form_to_string({type, _L, record, [{atom, _, Name}]}) -> + flat_format("#~w{}", [Name]); +t_form_to_string({type, _L, record, [{atom, _, Name}|Fields]}) -> + FieldString = string:join(t_form_to_string_list(Fields), ","), + flat_format("#~w{~s}", [Name, FieldString]); +t_form_to_string({type, _L, field_type, [{atom, _, Name}, Type]}) -> + flat_format("~w::~s", [Name, t_form_to_string(Type)]); +t_form_to_string({type, _L, term, []}) -> "term()"; +t_form_to_string({type, _L, timeout, []}) -> "timeout()"; +t_form_to_string({type, _L, tuple, any}) -> "tuple()"; +t_form_to_string({type, _L, tuple, Args}) -> + "{" ++ string:join(t_form_to_string_list(Args), ",") ++ "}"; +t_form_to_string({type, _L, union, Args}) -> + string:join(t_form_to_string_list(Args), " | "); +t_form_to_string({type, _L, Name, []} = T) -> + try + M = mod, + D0 = dict:new(), + MR = dict:from_list([{M, D0}]), + Site = {type, {M,Name,0}}, + V = var_table__new(), + C = cache__new(), + State = #from_form{site = Site, + xtypes = sets:new(), + mrecs = MR, + vtab = V, + tnames = []}, + {T1, _, _} = from_form(T, State, _Deep=1000, _ALot=1000000, C), + t_to_string(T1) + catch throw:{error, _} -> atom_to_string(Name) ++ "()" + end; +t_form_to_string({user_type, _L, Name, List}) -> + flat_format("~w(~s)", + [Name, string:join(t_form_to_string_list(List), ",")]); +t_form_to_string({type, L, Name, List}) -> + %% Compatibility: modules compiled before Erlang/OTP 18.0. + t_form_to_string({user_type, L, Name, List}). + +t_form_to_string_list(List) -> + t_form_to_string_list(List, []). + +t_form_to_string_list([H|T], Acc) -> + t_form_to_string_list(T, [t_form_to_string(H)|Acc]); +t_form_to_string_list([], Acc) -> + lists:reverse(Acc). + +-spec atom_to_string(atom()) -> string(). + +atom_to_string(Atom) -> + flat_format("~w", [Atom]). + +%%============================================================================= +%% +%% Utilities +%% +%%============================================================================= + +-spec any_none([erl_type()]) -> boolean(). + +any_none([?none|_Left]) -> true; +any_none([_|Left]) -> any_none(Left); +any_none([]) -> false. + +-spec any_none_or_unit([erl_type()]) -> boolean(). + +any_none_or_unit([?none|_]) -> true; +any_none_or_unit([?unit|_]) -> true; +any_none_or_unit([_|Left]) -> any_none_or_unit(Left); +any_none_or_unit([]) -> false. + +-spec is_erl_type(any()) -> boolean(). + +is_erl_type(?any) -> true; +is_erl_type(?none) -> true; +is_erl_type(?unit) -> true; +is_erl_type(#c{}) -> true; +is_erl_type(_) -> false. + +-spec lookup_record(atom(), type_table()) -> + 'error' | {'ok', [{atom(), parse_form(), erl_type()}]}. + +lookup_record(Tag, RecDict) when is_atom(Tag) -> + case dict:find({record, Tag}, RecDict) of + {ok, {_FileLine, [{_Arity, Fields}]}} -> + {ok, Fields}; + {ok, {_FileLine, List}} when is_list(List) -> + %% This will have to do, since we do not know which record we + %% are looking for. + error; + error -> + error + end. + +-spec lookup_record(atom(), arity(), type_table()) -> + 'error' | {'ok', [{atom(), parse_form(), erl_type()}]}. + +lookup_record(Tag, Arity, RecDict) when is_atom(Tag) -> + case dict:find({record, Tag}, RecDict) of + {ok, {_FileLine, [{Arity, Fields}]}} -> {ok, Fields}; + {ok, {_FileLine, OrdDict}} -> orddict:find(Arity, OrdDict); + error -> error + end. + +-spec lookup_type(_, _, _) -> {'type' | 'opaque', type_value()} | 'error'. +lookup_type(Name, Arity, RecDict) -> + case dict:find({type, Name, Arity}, RecDict) of + error -> + case dict:find({opaque, Name, Arity}, RecDict) of + error -> error; + {ok, Found} -> {opaque, Found} + end; + {ok, Found} -> {type, Found} + end. + +-spec type_is_defined('type' | 'opaque', atom(), arity(), type_table()) -> + boolean(). + +type_is_defined(TypeOrOpaque, Name, Arity, RecDict) -> + dict:is_key({TypeOrOpaque, Name, Arity}, RecDict). + +cannot_have_opaque(Type, TypeName, TypeNames) -> + t_is_none(Type) orelse is_recursive(TypeName, TypeNames). + +is_recursive(TypeName, TypeNames) -> + lists:member(TypeName, TypeNames). + +can_unfold_more(TypeName, TypeNames) -> + Fun = fun(E, Acc) -> case E of TypeName -> Acc + 1; _ -> Acc end end, + lists:foldl(Fun, 0, TypeNames) < ?REC_TYPE_LIMIT. + +-spec do_opaque(erl_type(), opaques(), fun((_) -> T)) -> T. + +%% Probably a little faster than calling t_unopaque/2. +%% Unions that are due to opaque types are unopaqued. +do_opaque(?opaque(_) = Type, Opaques, Pred) -> + case Opaques =:= 'universe' orelse is_opaque_type(Type, Opaques) of + true -> do_opaque(t_opaque_structure(Type), Opaques, Pred); + false -> Pred(Type) + end; +do_opaque(?union(List) = Type, Opaques, Pred) -> + [A,B,F,I,L,N,T,M,O,Map] = List, + if O =:= ?none -> Pred(Type); + true -> + case Opaques =:= 'universe' orelse is_opaque_type(O, Opaques) of + true -> + S = t_opaque_structure(O), + do_opaque(t_sup([A,B,F,I,L,N,T,M,S,Map]), Opaques, Pred); + false -> Pred(Type) + end + end; +do_opaque(Type, _Opaques, Pred) -> + Pred(Type). + +map_all_values(?map(Pairs,_,DefV)) -> + [DefV|[V || {V, _, _} <- Pairs]]. + +map_all_keys(?map(Pairs,DefK,_)) -> + [DefK|[K || {_, _, K} <- Pairs]]. + +map_all_types(M) -> + map_all_keys(M) ++ map_all_values(M). + +%% Tests if a type has exactly one possible value. +-spec t_is_singleton(erl_type()) -> boolean(). + +t_is_singleton(Type) -> + t_is_singleton(Type, 'universe'). + +-spec t_is_singleton(erl_type(), opaques()) -> boolean(). + +t_is_singleton(Type, Opaques) -> + do_opaque(Type, Opaques, fun is_singleton_type/1). + +%% Incomplete; not all representable singleton types are included. +is_singleton_type(?nil) -> true; +is_singleton_type(?atom(?any)) -> false; +is_singleton_type(?atom(Set)) -> + ordsets:size(Set) =:= 1; +is_singleton_type(?int_range(V, V)) -> true; +is_singleton_type(?int_set(Set)) -> + ordsets:size(Set) =:= 1; +is_singleton_type(?tuple(Types, Arity, _)) when is_integer(Arity) -> + lists:all(fun is_singleton_type/1, Types); +is_singleton_type(?tuple_set([{Arity, [OnlyTuple]}])) when is_integer(Arity) -> + is_singleton_type(OnlyTuple); +is_singleton_type(?map(Pairs, ?none, ?none)) -> + lists:all(fun({_,MNess,V}) -> MNess =:= ?mand andalso is_singleton_type(V) + end, Pairs); +is_singleton_type(_) -> + false. + +%% Returns the only possible value of a singleton type. +-spec t_singleton_to_term(erl_type(), opaques()) -> term(). + +t_singleton_to_term(Type, Opaques) -> + do_opaque(Type, Opaques, fun singleton_type_to_term/1). + +singleton_type_to_term(?nil) -> []; +singleton_type_to_term(?atom(Set)) when Set =/= ?any -> + case ordsets:size(Set) of + 1 -> hd(ordsets:to_list(Set)); + _ -> error(badarg) + end; +singleton_type_to_term(?int_range(V, V)) -> V; +singleton_type_to_term(?int_set(Set)) -> + case ordsets:size(Set) of + 1 -> hd(ordsets:to_list(Set)); + _ -> error(badarg) + end; +singleton_type_to_term(?tuple(Types, Arity, _)) when is_integer(Arity) -> + lists:map(fun singleton_type_to_term/1, Types); +singleton_type_to_term(?tuple_set([{Arity, [OnlyTuple]}])) + when is_integer(Arity) -> + singleton_type_to_term(OnlyTuple); +singleton_type_to_term(?map(Pairs, ?none, ?none)) -> + maps:from_list([{singleton_type_to_term(K), singleton_type_to_term(V)} + || {K,?mand,V} <- Pairs]). + +%% ----------------------------------- +%% Set +%% + +set_singleton(Element) -> + ordsets:from_list([Element]). + +set_is_singleton(Element, Set) -> + set_singleton(Element) =:= Set. + +set_is_element(Element, Set) -> + ordsets:is_element(Element, Set). + +set_union(?any, _) -> ?any; +set_union(_, ?any) -> ?any; +set_union(S1, S2) -> + case ordsets:union(S1, S2) of + S when length(S) =< ?SET_LIMIT -> S; + _ -> ?any + end. + +%% The intersection and subtraction can return ?none. +%% This should always be handled right away since ?none is not a valid set. +%% However, ?any is considered a valid set. + +set_intersection(?any, S) -> S; +set_intersection(S, ?any) -> S; +set_intersection(S1, S2) -> + case ordsets:intersection(S1, S2) of + [] -> ?none; + S -> S + end. + +set_subtract(_, ?any) -> ?none; +set_subtract(?any, _) -> ?any; +set_subtract(S1, S2) -> + case ordsets:subtract(S1, S2) of + [] -> ?none; + S -> S + end. + +set_from_list(List) -> + case length(List) of + L when L =< ?SET_LIMIT -> ordsets:from_list(List); + L when L > ?SET_LIMIT -> ?any + end. + +set_to_list(Set) -> + ordsets:to_list(Set). + +set_filter(Fun, Set) -> + case ordsets:filter(Fun, Set) of + [] -> ?none; + NewSet -> NewSet + end. + +set_size(Set) -> + ordsets:size(Set). + +set_to_string(Set) -> + L = [case is_atom(X) of + true -> io_lib:write_string(atom_to_list(X), $'); % stupid emacs ' + false -> flat_format("~w", [X]) + end || X <- set_to_list(Set)], + string:join(L, " | "). + +set_min([H|_]) -> H. + +set_max(Set) -> + hd(lists:reverse(Set)). + +flat_format(F, S) -> + lists:flatten(io_lib:format(F, S)). + +%%============================================================================= +%% +%% Utilities for the binary type +%% +%%============================================================================= + +-spec gcd(integer(), integer()) -> integer(). + +gcd(A, B) when B > A -> + gcd1(B, A); +gcd(A, B) -> + gcd1(A, B). + +-spec gcd1(integer(), integer()) -> integer(). + +gcd1(A, 0) -> A; +gcd1(A, B) -> + case A rem B of + 0 -> B; + X -> gcd1(B, X) + end. + +-spec bitstr_concat(erl_type(), erl_type()) -> erl_type(). + +bitstr_concat(?none, _) -> ?none; +bitstr_concat(_, ?none) -> ?none; +bitstr_concat(?bitstr(U1, B1), ?bitstr(U2, B2)) -> + t_bitstr(gcd(U1, U2), B1+B2). + +-spec bitstr_match(erl_type(), erl_type()) -> erl_type(). + +bitstr_match(?none, _) -> ?none; +bitstr_match(_, ?none) -> ?none; +bitstr_match(?bitstr(0, B1), ?bitstr(0, B2)) when B1 =< B2 -> + t_bitstr(0, B2-B1); +bitstr_match(?bitstr(0, _B1), ?bitstr(0, _B2)) -> + ?none; +bitstr_match(?bitstr(0, B1), ?bitstr(U2, B2)) when B1 =< B2 -> + t_bitstr(U2, B2-B1); +bitstr_match(?bitstr(0, B1), ?bitstr(U2, B2)) -> + t_bitstr(U2, handle_base(U2, B2-B1)); +bitstr_match(?bitstr(_, B1), ?bitstr(0, B2)) when B1 > B2 -> + ?none; +bitstr_match(?bitstr(U1, B1), ?bitstr(U2, B2)) -> + GCD = gcd(U1, U2), + t_bitstr(GCD, handle_base(GCD, B2-B1)). + +-spec handle_base(integer(), integer()) -> integer(). + +handle_base(Unit, Pos) when Pos >= 0 -> + Pos rem Unit; +handle_base(Unit, Neg) -> + (Unit+(Neg rem Unit)) rem Unit. + +family(L) -> + R = sofs:relation(L), + F = sofs:relation_to_family(R), + sofs:to_external(F). + +%%============================================================================= +%% +%% Interface functions for abstract data types defined in this module +%% +%%============================================================================= + +-spec var_table__new() -> var_table(). + +var_table__new() -> + maps:new(). + +%%============================================================================= +%% Consistency-testing function(s) below +%%============================================================================= + +-ifdef(DO_ERL_TYPES_TEST). + +test() -> + Atom1 = t_atom(), + Atom2 = t_atom(foo), + Atom3 = t_atom(bar), + true = t_is_atom(Atom2), + + True = t_atom(true), + False = t_atom(false), + Bool = t_boolean(), + true = t_is_boolean(True), + true = t_is_boolean(Bool), + false = t_is_boolean(Atom1), + + Binary = t_binary(), + true = t_is_binary(Binary), + + Bitstr = t_bitstr(), + true = t_is_bitstr(Bitstr), + + Bitstr1 = t_bitstr(7, 3), + true = t_is_bitstr(Bitstr1), + false = t_is_binary(Bitstr1), + + Bitstr2 = t_bitstr(16, 8), + true = t_is_bitstr(Bitstr2), + true = t_is_binary(Bitstr2), + + ?bitstr(8, 16) = t_subtract(t_bitstr(4, 12), t_bitstr(8, 12)), + ?bitstr(8, 16) = t_subtract(t_bitstr(4, 12), t_bitstr(8, 12)), + + Int1 = t_integer(), + Int2 = t_integer(1), + Int3 = t_integer(16#ffffffff), + true = t_is_integer(Int2), + true = t_is_byte(Int2), + false = t_is_byte(Int3), + false = t_is_byte(t_from_range(-1, 1)), + true = t_is_byte(t_from_range(1, ?MAX_BYTE)), + + Tuple1 = t_tuple(), + Tuple2 = t_tuple(3), + Tuple3 = t_tuple([Atom1, Int1]), + Tuple4 = t_tuple([Tuple1, Tuple2]), + Tuple5 = t_tuple([Tuple3, Tuple4]), + Tuple6 = t_limit(Tuple5, 2), + Tuple7 = t_limit(Tuple5, 3), + true = t_is_tuple(Tuple1), + + Port = t_port(), + Pid = t_pid(), + Ref = t_reference(), + Identifier = t_identifier(), + false = t_is_reference(Port), + true = t_is_identifier(Port), + + Function1 = t_fun(), + Function2 = t_fun(Pid), + Function3 = t_fun([], Pid), + Function4 = t_fun([Port, Pid], Pid), + Function5 = t_fun([Pid, Atom1], Int2), + true = t_is_fun(Function3), + + List1 = t_list(), + List2 = t_list(t_boolean()), + List3 = t_cons(t_boolean(), List2), + List4 = t_cons(t_boolean(), t_atom()), + List5 = t_cons(t_boolean(), t_nil()), + List6 = t_cons_tl(List5), + List7 = t_sup(List4, List5), + List8 = t_inf(List7, t_list()), + List9 = t_cons(), + List10 = t_cons_tl(List9), + true = t_is_boolean(t_cons_hd(List5)), + true = t_is_list(List5), + false = t_is_list(List4), + + Product1 = t_product([Atom1, Atom2]), + Product2 = t_product([Atom3, Atom1]), + Product3 = t_product([Atom3, Atom2]), + + Union1 = t_sup(Atom2, Atom3), + Union2 = t_sup(Tuple2, Tuple3), + Union3 = t_sup(Int2, Atom3), + Union4 = t_sup(Port, Pid), + Union5 = t_sup(Union4, Int1), + Union6 = t_sup(Function1, Function2), + Union7 = t_sup(Function4, Function5), + Union8 = t_sup(True, False), + true = t_is_boolean(Union8), + Union9 = t_sup(Int2, t_integer(2)), + true = t_is_byte(Union9), + Union10 = t_sup(t_tuple([t_atom(true), ?any]), + t_tuple([t_atom(false), ?any])), + + ?any = t_sup(Product3, Function5), + + Atom3 = t_inf(Union3, Atom1), + Union2 = t_inf(Union2, Tuple1), + Int2 = t_inf(Int1, Union3), + Union4 = t_inf(Union4, Identifier), + Port = t_inf(Union5, Port), + Function4 = t_inf(Union7, Function4), + ?none = t_inf(Product2, Atom1), + Product3 = t_inf(Product1, Product2), + Function5 = t_inf(Union7, Function5), + true = t_is_byte(t_inf(Union9, t_number())), + true = t_is_char(t_inf(Union9, t_number())), + + io:format("3? ~p ~n", [?int_set([3])]), + + RecDict = dict:store({foo, 2}, [bar, baz], dict:new()), + Record1 = t_from_term({foo, [1,2], {1,2,3}}), + + Types = [ + Atom1, + Atom2, + Atom3, + Binary, + Int1, + Int2, + Tuple1, + Tuple2, + Tuple3, + Tuple4, + Tuple5, + Tuple6, + Tuple7, + Ref, + Port, + Pid, + Identifier, + List1, + List2, + List3, + List4, + List5, + List6, + List7, + List8, + List9, + List10, + Function1, + Function2, + Function3, + Function4, + Function5, + Product1, + Product2, + Record1, + Union1, + Union2, + Union3, + Union4, + Union5, + Union6, + Union7, + Union8, + Union10, + t_inf(Union10, t_tuple([t_atom(true), t_integer()])) + ], + io:format("~p\n", [[t_to_string(X, RecDict) || X <- Types]]). + +-endif. -- cgit v1.2.3 From 5ac2943cee51f0f9e453243bb94e637378d7c838 Mon Sep 17 00:00:00 2001 From: Hans Bolinder Date: Thu, 22 Sep 2016 10:36:14 +0200 Subject: dialyzer: Fix opaque bug The "decoration" of opaque types works better than before when opaque types are used by other opaque types. --- lib/dialyzer/test/opaque_SUITE_data/results/para | 6 +- .../src/hipe_vectors/hipe_ig_moves.erl | 83 +++++++++++++ .../src/hipe_vectors/hipe_vectors.erl | 136 +++++++++++++++++++++ 3 files changed, 222 insertions(+), 3 deletions(-) create mode 100644 lib/dialyzer/test/opaque_SUITE_data/src/hipe_vectors/hipe_ig_moves.erl create mode 100644 lib/dialyzer/test/opaque_SUITE_data/src/hipe_vectors/hipe_vectors.erl (limited to 'lib/dialyzer') diff --git a/lib/dialyzer/test/opaque_SUITE_data/results/para b/lib/dialyzer/test/opaque_SUITE_data/results/para index 8fe67e39ad..b23d0cae3a 100644 --- a/lib/dialyzer/test/opaque_SUITE_data/results/para +++ b/lib/dialyzer/test/opaque_SUITE_data/results/para @@ -19,9 +19,9 @@ para3.erl:55: Invalid type specification for function para3:t2/0. The success ty para3.erl:65: The attempt to match a term of type {{{{{para3_adt:ot1(_,_,_,_,_)}}}}} against the pattern {{{{{17}}}}} breaks the opaqueness of para3_adt:ot1(_,_,_,_,_) para3.erl:68: The pattern {{{{17}}}} can never match the type {{{{{para3_adt:ot1(_,_,_,_,_)}}}}} para3.erl:74: Invalid type specification for function para3:exp_adt/0. The success typing is () -> 3 -para4.erl:21: Invalid type specification for function para4:a/1. The success typing is (dict:dict(atom() | integer(),atom() | integer()) | para4:d_all()) -> [{atom() | integer(),atom() | integer()}] -para4.erl:26: Invalid type specification for function para4:i/1. The success typing is (dict:dict(atom() | integer(),atom() | integer()) | para4:d_all()) -> [{atom() | integer(),atom() | integer()}] -para4.erl:31: Invalid type specification for function para4:t/1. The success typing is (dict:dict(atom() | integer(),atom() | integer()) | para4:d_all()) -> [{atom() | integer(),atom() | integer()}] +para4.erl:21: Invalid type specification for function para4:a/1. The success typing is (para4:d_all() | para4:d_atom()) -> [{atom() | integer(),atom() | integer()}] +para4.erl:26: Invalid type specification for function para4:i/1. The success typing is (para4:d_all() | para4:d_integer()) -> [{atom() | integer(),atom() | integer()}] +para4.erl:31: Invalid type specification for function para4:t/1. The success typing is (para4:d_all() | para4:d_tuple()) -> [{atom() | integer(),atom() | integer()}] para4.erl:59: Attempt to test for equality between a term of type para4_adt:t(atom() | integer()) and a term of opaque type para4_adt:t(integer()) para4.erl:64: Attempt to test for equality between a term of type para4_adt:t(atom() | integer()) and a term of opaque type para4_adt:t(atom()) para4.erl:69: Attempt to test for equality between a term of type para4_adt:int(1 | 2 | 3 | 4) and a term of opaque type para4_adt:int(1 | 2) diff --git a/lib/dialyzer/test/opaque_SUITE_data/src/hipe_vectors/hipe_ig_moves.erl b/lib/dialyzer/test/opaque_SUITE_data/src/hipe_vectors/hipe_ig_moves.erl new file mode 100644 index 0000000000..2a70606dab --- /dev/null +++ b/lib/dialyzer/test/opaque_SUITE_data/src/hipe_vectors/hipe_ig_moves.erl @@ -0,0 +1,83 @@ +%% -*- erlang-indent-level: 2 -*- +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2001-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% +%%============================================================================= + +-module(hipe_ig_moves). +-export([new/1, + new_move/3, + get_moves/1]). + +%%----------------------------------------------------------------------------- +%% The main data structure; its fields are: +%% - movelist : mapping from temp to set of associated move numbers +%% - nrmoves : number of distinct move instructions seen so far +%% - moveinsns : list of move instructions, in descending move number order +%% - moveset : set of move instructions + +-record(ig_moves, {movelist :: movelist(), + nrmoves = 0 :: non_neg_integer(), + moveinsns = [] :: [{_,_}], + moveset = gb_sets:empty() :: gb_sets:set()}). + +-type movelist() :: hipe_vectors:vector(ordsets:ordset(non_neg_integer())). + +%%----------------------------------------------------------------------------- + +-spec new(non_neg_integer()) -> #ig_moves{}. + +new(NrTemps) -> + MoveList = hipe_vectors:new(NrTemps, ordsets:new()), + #ig_moves{movelist = MoveList}. + +-spec new_move(_, _, #ig_moves{}) -> #ig_moves{}. + +new_move(Dst, Src, IG_moves) -> + MoveSet = IG_moves#ig_moves.moveset, + MoveInsn = {Dst, Src}, + case gb_sets:is_member(MoveInsn, MoveSet) of + true -> + IG_moves; + false -> + MoveNr = IG_moves#ig_moves.nrmoves, + Movelist0 = IG_moves#ig_moves.movelist, + Movelist1 = add_movelist(MoveNr, Dst, + add_movelist(MoveNr, Src, Movelist0)), + IG_moves#ig_moves{nrmoves = MoveNr+1, + movelist = Movelist1, + moveinsns = [MoveInsn|IG_moves#ig_moves.moveinsns], + moveset = gb_sets:insert(MoveInsn, MoveSet)} + end. + +-spec add_movelist(non_neg_integer(), non_neg_integer(), movelist()) + -> movelist(). + +add_movelist(MoveNr, Temp, MoveList) -> + AssocMoves = hipe_vectors:get(MoveList, Temp), + %% XXX: MoveNr does not occur in moveList[Temp], but the new list must be an + %% ordset due to the ordsets:union in hipe_coalescing_regalloc:combine(). + hipe_vectors:set(MoveList, Temp, ordsets:add_element(MoveNr, AssocMoves)). + +-spec get_moves(#ig_moves{}) -> {movelist(), non_neg_integer(), tuple()}. + +get_moves(IG_moves) -> % -> {MoveList, NrMoves, MoveInsns} + {IG_moves#ig_moves.movelist, + IG_moves#ig_moves.nrmoves, + list_to_tuple(lists:reverse(IG_moves#ig_moves.moveinsns))}. diff --git a/lib/dialyzer/test/opaque_SUITE_data/src/hipe_vectors/hipe_vectors.erl b/lib/dialyzer/test/opaque_SUITE_data/src/hipe_vectors/hipe_vectors.erl new file mode 100644 index 0000000000..279f244586 --- /dev/null +++ b/lib/dialyzer/test/opaque_SUITE_data/src/hipe_vectors/hipe_vectors.erl @@ -0,0 +1,136 @@ +%% -*- erlang-indent-level: 2 -*- +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2001-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% VECTORS IN ERLANG +%% +%% Abstract interface to vectors, indexed from 0 to size-1. + +-module(hipe_vectors). +-export([new/2, + set/3, + get/2, + size/1, + vector_to_list/1, + %% list_to_vector/1, + list/1]). + +%%-define(USE_TUPLES, true). +%%-define(USE_GBTREES, true). +-define(USE_ARRAYS, true). + +-type vector() :: vector(_). +-export_type([vector/0, vector/1]). + +-spec new(non_neg_integer(), V) -> vector(E) when V :: E. +-spec set(vector(E), non_neg_integer(), V :: E) -> vector(E). +-spec get(vector(E), non_neg_integer()) -> E. +-spec size(vector(_)) -> non_neg_integer(). +-spec vector_to_list(vector(E)) -> [E]. +%% -spec list_to_vector([E]) -> vector(E). +-spec list(vector(E)) -> [{non_neg_integer(), E}]. + +%% --------------------------------------------------------------------- + +-ifdef(USE_TUPLES). +-opaque vector(_) :: tuple(). + +new(N, V) -> + erlang:make_tuple(N, V). + +size(V) -> erlang:tuple_size(V). + +list(Vec) -> + index(tuple_to_list(Vec), 0). + +index([X|Xs],N) -> + [{N,X} | index(Xs,N+1)]; +index([],_) -> + []. + +%% list_to_vector(Xs) -> +%% list_to_tuple(Xs). + +vector_to_list(V) -> + tuple_to_list(V). + +set(Vec, Ix, V) -> + setelement(Ix+1, Vec, V). + +get(Vec, Ix) -> element(Ix+1, Vec). + +-endif. %% ifdef USE_TUPLES + +%% --------------------------------------------------------------------- + +-ifdef(USE_GBTREES). +-opaque vector(E) :: gb_trees:tree(non_neg_integer(), E). + +new(N, V) when is_integer(N), N >= 0 -> + gb_trees:from_orddict(mklist(N, V)). + +mklist(N, V) -> + mklist(0, N, V). + +mklist(M, N, V) when M < N -> + [{M, V} | mklist(M+1, N, V)]; +mklist(_, _, _) -> + []. + +size(V) -> gb_trees:size(V). + +list(Vec) -> + gb_trees:to_list(Vec). + +%% list_to_vector(Xs) -> +%% gb_trees:from_orddict(index(Xs, 0)). +%% +%% index([X|Xs], N) -> +%% [{N, X} | index(Xs, N+1)]; +%% index([],_) -> +%% []. + +vector_to_list(V) -> + gb_trees:values(V). + +set(Vec, Ix, V) -> + gb_trees:update(Ix, V, Vec). + +get(Vec, Ix) -> + gb_trees:get(Ix, Vec). + +-endif. %% ifdef USE_GBTREES + +%% --------------------------------------------------------------------- + +-ifdef(USE_ARRAYS). +-opaque vector(E) :: array:array(E). +%%-type vector(E) :: array:array(E). % Work around dialyzer bug + +new(N, V) -> array:new(N, {default, V}). +size(V) -> array:size(V). +list(Vec) -> array:to_orddict(Vec). +%% list_to_vector(Xs) -> array:from_list(Xs). +vector_to_list(V) -> array:to_list(V). +set(Vec, Ix, V) -> array:set(Ix, V, Vec). +get(Vec, Ix) -> array:get(Ix, Vec). + +-endif. %% ifdef USE_ARRAYS -- cgit v1.2.3