diff options
Diffstat (limited to 'lib')
30 files changed, 18829 insertions, 639 deletions
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/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 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. +%% +%% <p> This module defines an abstract data type for representing Core +%% Erlang source code as syntax trees.</p> +%% +%% <p>A recommended starting point for the first-time user is the +%% documentation of the function <a +%% href="#type-1"><code>type/1</code></a>.</p> +%% +%% <h3><b>NOTES:</b></h3> +%% +%% <p>This module deals with the composition and decomposition of +%% <em>syntactic</em> 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.</p> +%% +%% <p>Currently, the internal data structure used is the same as +%% the record-based data structures used traditionally in the Beam +%% compiler.</p> +%% +%% <p>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, <em>with +%% the following exceptions</em>: no syntax tree is represented by a +%% single atom, such as <code>none</code>, by a list constructor +%% <code>[X | Y]</code>, or by the empty list <code>[]</code>. This +%% can be relied on when writing functions that operate on syntax +%% trees.</p> +%% +%% @type cerl(). An abstract Core Erlang syntax tree. +%% +%% <p>Every abstract syntax tree has a <em>type</em>, given by the +%% function <a href="#type-1"><code>type/1</code></a>. In addition, +%% each syntax tree has a list of <em>user annotations</em> (cf. <a +%% href="#get_ann-1"><code>get_ann/1</code></a>), which are included +%% in the Core Erlang syntax.</p> + +-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 <code>Node</code>. Current node types +%% are: +%% +%% <p><center><table border="1"> +%% <tr> +%% <td>alias</td> +%% <td>apply</td> +%% <td>binary</td> +%% <td>bitstr</td> +%% <td>call</td> +%% <td>case</td> +%% <td>catch</td> +%% <td>clause</td> +%% </tr><tr> +%% <td>cons</td> +%% <td>fun</td> +%% <td>let</td> +%% <td>letrec</td> +%% <td>literal</td> +%% <td>map</td> +%% <td>map_pair</td> +%% <td>module</td> +%% </tr><tr> +%% <td>primop</td> +%% <td>receive</td> +%% <td>seq</td> +%% <td>try</td> +%% <td>tuple</td> +%% <td>values</td> +%% <td>var</td> +%% </tr> +%% </table></center></p> +%% +%% <p>Note: The name of the primary constructor function for a node +%% type is always the name of the type itself, prefixed by +%% "<code>c_</code>"; recognizer predicates are correspondingly +%% prefixed by "<code>is_c_</code>". Furthermore, to simplify +%% preservation of annotations (cf. <code>get_ann/1</code>), there are +%% analogous constructor functions prefixed by "<code>ann_c_</code>" +%% and "<code>update_c_</code>", for setting the annotation list of +%% the new node to either a specific value or to the annotations of an +%% existing node, respectively.</p> +%% +%% @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 <code>true</code> if <code>Node</code> is a leaf node, +%% otherwise <code>false</code>. The current leaf node types are +%% <code>literal</code> and <code>var</code>. +%% +%% <p>Note: all literals (cf. <code>is_literal/1</code>) are leaf +%% nodes, even if they represent structured (constant) values such as +%% <code>{foo, [bar, baz]}</code>. Also note that variables are leaf +%% nodes but not literals.</p> +%% +%% @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 <code>Node</code> to +%% <code>Annotations</code>. +%% +%% @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 <code>Annotations</code> to the list of user +%% annotations of <code>Node</code>. +%% +%% <p>Note: this is equivalent to <code>set_ann(Node, Annotations ++ +%% get_ann(Node))</code>, but potentially more efficient.</p> +%% +%% @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 <code>Source</code> +%% to <code>Target</code>. +%% +%% <p>Note: this is equivalent to <code>set_ann(Target, +%% get_ann(Source))</code>, but potentially more efficient.</p> +%% +%% @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. +%% <code>Term</code> 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. +%% +%% <p>Note: This is a constant time operation.</p> +%% +%% @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 <code>true</code> if <code>Term</code> can be +%% represented as a literal, otherwise <code>false</code>. This +%% function takes time proportional to the size of <code>Term</code>. +%% +%% @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 <code>Node</code> does not represent a +%% literal term. +%% +%% <p>Note: This is a constant time operation.</p> +%% +%% @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 <code>true</code> if <code>Node</code> represents a +%% literal term, otherwise <code>false</code>. This function returns +%% <code>true</code> if and only if the value of +%% <code>concrete(Node)</code> is defined. +%% +%% <p>Note: This is a constant time operation.</p> +%% +%% @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 <code>c_cons_skel/2</code>, +%% <code>c_tuple_skel/1</code> or <code>unfold_literal/1</code> were +%% used in the construction of <code>Node</code>, and you want to revert +%% to the normal "folded" representation of literals. If +%% <code>Node</code> represents a tuple or list constructor, its +%% elements are rewritten recursively, and the node is reconstructed +%% using <code>c_cons/2</code> or <code>c_tuple/1</code>, respectively; +%% otherwise, <code>Node</code> 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 +%% <code>Node</code> represents a literal tuple or list constructor, its +%% elements are rewritten recursively, and the node is reconstructed +%% using <code>c_cons_skel/2</code> or <code>c_tuple_skel/1</code>, +%% respectively; otherwise, <code>Node</code> 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 +%% <pre> +%% module <em>Name</em> [<em>E1</em>, ..., <em>Ek</em>] +%% attributes [<em>K1</em> = <em>T1</em>, ..., +%% <em>Km</em> = <em>Tm</em>] +%% <em>V1</em> = <em>F1</em> +%% ... +%% <em>Vn</em> = <em>Fn</em> +%% end</pre> +%% +%% if <code>Exports</code> = <code>[E1, ..., Ek]</code>, +%% <code>Attributes</code> = <code>[{K1, T1}, ..., {Km, Tm}]</code>, +%% and <code>Definitions</code> = <code>[{V1, F1}, ..., {Vn, +%% Fn}]</code>. +%% +%% <p><code>Name</code> and all the <code>Ki</code> must be atom +%% literals, and all the <code>Ti</code> must be constant literals. All +%% the <code>Vi</code> and <code>Ei</code> must have type +%% <code>var</code> and represent function names. All the +%% <code>Fi</code> must have type <code>'fun'</code>.</p> +%% +%% @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 <code>true</code> if <code>Node</code> is an abstract +%% module definition, otherwise <code>false</code>. +%% +%% @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 +%% <code>Value</code>. +%% +%% @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 <code>true</code> if <code>Node</code> represents an +%% integer literal, otherwise <code>false</code>. +%% @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 +%% <code>Value</code>. +%% +%% @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 <code>true</code> if <code>Node</code> represents a +%% floating-point literal, otherwise <code>false</code>. +%% @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 <code>Name</code>. +%% +%% <p>Note: passing a string as argument to this function causes a +%% corresponding atom to be created for the internal representation.</p> +%% +%% @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 <code>true</code> if <code>Node</code> represents an +%% atom literal, otherwise <code>false</code>. +%% +%% @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. +%% +%% <p>Note that an abstract atom may have several literal +%% representations, and that the representation yielded by this +%% function is not fixed; e.g., +%% <code>atom_lit(c_atom("a\012b"))</code> could yield the string +%% <code>"\'a\\nb\'"</code>.</p> +%% +%% @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 <code>char()</code> as a subset of +%% <code>integer()</code>, this function is equivalent to +%% <code>c_int/1</code>. 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 +%% "<code>$<em>Char</em></code>", where <code>Char</code> 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 <code>true</code> if <code>Node</code> may represent a +%% character literal, otherwise <code>false</code>. +%% +%% <p>If the local implementation of Erlang defines +%% <code>char()</code> as a subset of <code>integer()</code>, then +%% <code>is_c_int(<em>Node</em>)</code> will also yield +%% <code>true</code>.</p> +%% +%% @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 <code>true</code> if <code>Node</code> may represent a +%% "printing" character, otherwise <code>false</code>. (Cf. +%% <code>is_c_char/1</code>.) A "printing" character has either a +%% given graphical representation, or a "named" escape sequence such +%% as "<code>\n</code>". 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 <code>$</code> +%% 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. <code>is_c_string/1</code>), but is typically more +%% efficient. The lexical representation of a string is +%% "<code>"<em>Chars</em>"</code>", where <code>Chars</code> 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 <code>true</code> if <code>Node</code> may represent a +%% string literal, otherwise <code>false</code>. Strings are defined +%% as lists of characters; see <code>is_c_char/1</code> 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 <code>true</code> if <code>Node</code> may represent a +%% string literal containing only "printing" characters, otherwise +%% <code>false</code>. See <code>is_c_string/1</code> and +%% <code>is_print_char/1</code> 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 +%% <code>"..."</code>. 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 +%% "<code>[]</code>". 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 <code>true</code> if <code>Node</code> is an abstract +%% empty list, otherwise <code>false</code>. + +-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 +%% "<code>[<em>Head</em> | <em>Tail</em>]</code>". Note that if both +%% <code>Head</code> and <code>Tail</code> have type +%% <code>literal</code>, then the result will also have type +%% <code>literal</code>, and annotations on <code>Head</code> and +%% <code>Tail</code> are lost. +%% +%% <p>Recall that in Erlang, the tail element of a list constructor is +%% not necessarily a list.</p> +%% +%% @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 +%% <code>cons</code>, representing "<code>[<em>Head</em> | +%% <em>Tail</em>]</code>". +%% +%% <p>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 +%% <code>is_literal/1</code> will yield <code>false</code> and +%% <code>concrete/1</code> will fail if passed the result from this +%% function.</p> +%% +%% <p><code>fold_literal/1</code> can be used to revert a node to the +%% normal-form representation.</p> +%% +%% @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 <code>true</code> if <code>Node</code> is an abstract +%% list constructor, otherwise <code>false</code>. + +-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. +%% +%% <p>Recall that the tail does not necessarily represent a proper +%% list.</p> +%% +%% @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 <code>true</code> if <code>Node</code> represents a +%% proper list, otherwise <code>false</code>. A proper list is either +%% the empty list <code>[]</code>, or a cons cell <code>[<em>Head</em> | +%% <em>Tail</em>]</code>, where recursively <code>Tail</code> is a +%% proper list. +%% +%% <p>Note: Because <code>Node</code> is a syntax tree, the actual +%% run-time values corresponding to its subtrees may often be partially +%% or completely unknown. Thus, if <code>Node</code> represents e.g. +%% "<code>[... | Ns]</code>" (where <code>Ns</code> is a variable), then +%% the function will return <code>false</code>, because it is not known +%% whether <code>Ns</code> will be bound to a list at run-time. If +%% <code>Node</code> instead represents e.g. "<code>[1, 2, 3]</code>" or +%% "<code>[A | []]</code>", then the function will return +%% <code>true</code>.</p> +%% +%% @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. +%% <code>Node</code> must represent a proper list. E.g., if +%% <code>Node</code> represents "<code>[<em>X1</em>, <em>X2</em> | +%% [<em>X3</em>, <em>X4</em> | []]</code>", then +%% <code>list_elements(Node)</code> yields the list <code>[X1, X2, X3, +%% X4]</code>. +%% +%% @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. +%% <code>Node</code> must represent a proper list. E.g., if +%% <code>Node</code> represents "<code>[X1 | [X2, X3 | [X4, X5, +%% X6]]]</code>", then <code>list_length(Node)</code> returns the +%% integer 6. +%% +%% <p>Note: this is equivalent to +%% <code>length(list_elements(Node))</code>, but potentially more +%% efficient.</p> +%% +%% @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 <code>List</code> +%% and the optional <code>Tail</code>. If <code>Tail</code> is +%% <code>none</code>, the result will represent a nil-terminated list, +%% otherwise it represents "<code>[... | <em>Tail</em>]</code>". +%% +%% @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 <code>true</code> if <code>Node</code> is an abstract +%% map constructor, otherwise <code>false</code>. + +-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 <code>Elements</code> is +%% <code>[E1, ..., En]</code>, the result represents +%% "<code>{<em>E1</em>, ..., <em>En</em>}</code>". Note that if all +%% nodes in <code>Elements</code> have type <code>literal</code>, or if +%% <code>Elements</code> is empty, then the result will also have type +%% <code>literal</code> and annotations on nodes in +%% <code>Elements</code> are lost. +%% +%% <p>Recall that Erlang has distinct 1-tuples, i.e., <code>{X}</code> +%% is always distinct from <code>X</code> itself.</p> +%% +%% @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 <code>tuple</code>, +%% representing "<code>{<em>E1</em>, ..., <em>En</em>}</code>", if +%% <code>Elements</code> is <code>[E1, ..., En]</code>. +%% +%% <p>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 +%% <code>is_literal/1</code> will yield <code>false</code> and +%% <code>concrete/1</code> will fail if passed the result from this +%% function.</p> +%% +%% <p><code>fold_literal/1</code> can be used to revert a node to the +%% normal-form representation.</p> +%% +%% @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 <code>true</code> if <code>Node</code> is an abstract +%% tuple, otherwise <code>false</code>. +%% +%% @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. +%% +%% <p>Note: this is equivalent to <code>length(tuple_es(Node))</code>, +%% but potentially more efficient.</p> +%% +%% @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 <code>Name</code> parameter. +%% +%% <p>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 <code>{A, N}</code> represent +%% function name variables "<code><em>A</em>/<em>N</em></code>"; these +%% are special variables which may be bound only in the function +%% definitions of a module or a <code>letrec</code>. They may not be +%% bound in <code>let</code> expressions and cannot occur in clause +%% patterns. The atom <code>A</code> in a function name may be any +%% atom; the integer <code>N</code> must be nonnegative. The functions +%% <code>c_fname/2</code> etc. are utilities for handling function +%% name variables.</p> +%% +%% <p>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 <code>42</code> could be formatted as +%% "<code>_42</code>", an atom <code>'Xxx'</code> simply as +%% "<code>Xxx</code>", and an atom <code>foo</code> as +%% "<code>_foo</code>". However, one must assure that any two valid +%% distinct names are never mapped to the same strings. Tuples such +%% as <code>{foo, 2}</code> representing function names can simply by +%% formatted as "<code>'foo'/2</code>", with no risk of conflicts.</p> +%% +%% @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 <code>true</code> if <code>Node</code> is an abstract +%% variable, otherwise <code>false</code>. +%% +%% @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 <code>update_c_fname/3</code>, but takes the arity from +%% <code>Node</code>. +%% @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 <code>true</code> if <code>Node</code> is an abstract +%% function name variable, otherwise <code>false</code>. +%% +%% @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 <code>Elements</code> is +%% <code>[E1, ..., En]</code>, the result represents +%% "<code><<em>E1</em>, ..., <em>En</em>></code>". +%% +%% @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 <code>true</code> if <code>Node</code> is an abstract +%% value list; otherwise <code>false</code>. +%% +%% @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. +%% +%% <p>Note: This is equivalent to +%% <code>length(values_es(Node))</code>, but potentially more +%% efficient.</p> +%% +%% @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 <em>segments</em> of arbitrary lengths (in number of bits), +%% such that the sum of the lengths is evenly divisible by 8. If +%% <code>Segments</code> is <code>[S1, ..., Sn]</code>, the result +%% represents "<code>#{<em>S1</em>, ..., <em>Sn</em>}#</code>". All the +%% <code>Si</code> must have type <code>bitstr</code>. +%% +%% @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 <code>true</code> if <code>Node</code> is an abstract +%% binary-template; otherwise <code>false</code>. +%% +%% @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 "<code>#<<em>Value</em>>(<em>Size</em>, +%% <em>Unit</em>, <em>Type</em>, <em>Flags</em>)</code>", where +%% <code>Unit</code> must represent a positive integer constant, +%% <code>Type</code> must represent a constant atom (one of +%% <code>'integer'</code>, <code>'float'</code>, or +%% <code>'binary'</code>), and <code>Flags</code> must represent a +%% constant list <code>"[<em>F1</em>, ..., <em>Fn</em>]"</code> where +%% all the <code>Fi</code> 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 <code>true</code> if <code>Node</code> is an abstract +%% bit-string template; otherwise <code>false</code>. +%% +%% @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 <code>all</code>, the atom <code>all</code> is returned. +%% If the size is not a literal, the atom <code>any</code> 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 <code>Variables</code> +%% is <code>[V1, ..., Vn]</code>, the result represents "<code>fun +%% (<em>V1</em>, ..., <em>Vn</em>) -> <em>Body</em></code>". All the +%% <code>Vi</code> must have type <code>var</code>. +%% +%% @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 <code>true</code> if <code>Node</code> is an abstract +%% fun-expression, otherwise <code>false</code>. +%% +%% @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. +%% +%% <p>Note: this is equivalent to <code>length(fun_vars(Node))</code>, +%% but potentially more efficient.</p> +%% +%% @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 "<code>do <em>Argument</em> <em>Body</em></code>". +%% +%% @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 <code>true</code> if <code>Node</code> is an abstract +%% sequencing expression, otherwise <code>false</code>. +%% +%% @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 <code>Variables</code> +%% is <code>[V1, ..., Vn]</code>, the result represents "<code>let +%% <<em>V1</em>, ..., <em>Vn</em>> = <em>Argument</em> in +%% <em>Body</em></code>". All the <code>Vi</code> must have type +%% <code>var</code>. +%% +%% @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 <code>true</code> if <code>Node</code> is an abstract +%% let-expression, otherwise <code>false</code>. +%% +%% @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. +%% +%% <p>Note: this is equivalent to <code>length(let_vars(Node))</code>, +%% but potentially more efficient.</p> +%% +%% @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 +%% <code>Definitions</code> is <code>[{V1, F1}, ..., {Vn, Fn}]</code>, +%% the result represents "<code>letrec <em>V1</em> = <em>F1</em> +%% ... <em>Vn</em> = <em>Fn</em> in <em>Body</em></code>. All the +%% <code>Vi</code> must have type <code>var</code> and represent +%% function names. All the <code>Fi</code> must have type +%% <code>'fun'</code>. +%% +%% @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 <code>true</code> if <code>Node</code> is an abstract +%% letrec-expression, otherwise <code>false</code>. +%% +%% @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 <code>Node</code> represents "<code>letrec +%% <em>V1</em> = <em>F1</em> ... <em>Vn</em> = <em>Fn</em> in +%% <em>Body</em></code>", the returned value is <code>[{V1, F1}, ..., +%% {Vn, Fn}]</code>. +%% +%% @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 <code>Node</code> represents +%% "<code>letrec <em>V1</em> = <em>F1</em> ... <em>Vn</em> = +%% <em>Fn</em> in <em>Body</em></code>", the returned value is +%% <code>[V1, ..., Vn]</code>. +%% +%% @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 <code>Clauses</code> +%% is <code>[C1, ..., Cn]</code>, the result represents "<code>case +%% <em>Argument</em> of <em>C1</em> ... <em>Cn</em> +%% end</code>". <code>Clauses</code> 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 <code>true</code> if <code>Node</code> is an abstract +%% case-expression; otherwise <code>false</code>. +%% +%% @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 +%% <code>clause_arity(hd(case_clauses(Node)))</code>, 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 <code>Patterns</code> is +%% <code>[P1, ..., Pn]</code>, the result represents +%% "<code><<em>P1</em>, ..., <em>Pn</em>> when <em>Guard</em> -> +%% <em>Body</em></code>". +%% +%% @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 <code>true</code> if <code>Node</code> is an abstract +%% clause, otherwise <code>false</code>. +%% +%% @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. +%% +%% <p>Note: this is equivalent to +%% <code>length(clause_pats(Node))</code>, but potentially more +%% efficient.</p> +%% +%% @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 <code>Node</code> 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 +%% <code>Patterns</code> 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 +%% "<code><em>Variable</em> = <em>Pattern</em></code>". +%% +%% @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 <code>true</code> if <code>Node</code> is an abstract +%% pattern alias, otherwise <code>false</code>. +%% +%% @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 +%% <code>Clauses</code> is <code>[C1, ..., Cn]</code>, the result +%% represents "<code>receive <em>C1</em> ... <em>Cn</em> after +%% <em>Timeout</em> -> <em>Action</em> end</code>". +%% +%% @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 <code>true</code> if <code>Node</code> is an abstract +%% receive-expression, otherwise <code>false</code>. +%% +%% @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 +%% <code>Arguments</code> is <code>[A1, ..., An]</code>, the result +%% represents "<code>apply <em>Operator</em>(<em>A1</em>, ..., +%% <em>An</em>)</code>". +%% +%% @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 <code>true</code> if <code>Node</code> is an abstract +%% function application, otherwise <code>false</code>. +%% +%% @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. +%% +%% <p>Note: this is equivalent to +%% <code>length(apply_args(Node))</code>, but potentially more +%% efficient.</p> +%% +%% @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 +%% <code>Arguments</code> is <code>[A1, ..., An]</code>, the result +%% represents "<code>call <em>Module</em>:<em>Name</em>(<em>A1</em>, +%% ..., <em>An</em>)</code>". +%% +%% @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 <code>true</code> if <code>Node</code> is an abstract +%% inter-module call expression; otherwise <code>false</code>. +%% +%% @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. +%% +%% <p>Note: this is equivalent to +%% <code>length(call_args(Node))</code>, but potentially more +%% efficient.</p> +%% +%% @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 +%% <code>Arguments</code> is <code>[A1, ..., An]</code>, the result +%% represents "<code>primop <em>Name</em>(<em>A1</em>, ..., +%% <em>An</em>)</code>". <code>Name</code> 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 <code>true</code> if <code>Node</code> is an abstract +%% primitive operation call, otherwise <code>false</code>. +%% +%% @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. +%% +%% <p>Note: this is equivalent to +%% <code>length(primop_args(Node))</code>, but potentially more +%% efficient.</p> +%% +%% @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 <code>Variables</code> is +%% <code>[V1, ..., Vn]</code> and <code>ExceptionVars</code> is +%% <code>[X1, ..., Xm]</code>, the result represents "<code>try +%% <em>Argument</em> of <<em>V1</em>, ..., <em>Vn</em>> -> +%% <em>Body</em> catch <<em>X1</em>, ..., <em>Xm</em>> -> +%% <em>Handler</em></code>". All the <code>Vi</code> and <code>Xi</code> +%% must have type <code>var</code>. +%% +%% @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 <code>true</code> if <code>Node</code> is an abstract +%% try-expression, otherwise <code>false</code>. +%% +%% @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 +%% "<code>catch <em>Body</em></code>". +%% +%% <p>Note: catch-expressions can be rewritten as try-expressions, and +%% will eventually be removed from Core Erlang.</p> +%% +%% @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 <code>true</code> if <code>Node</code> is an abstract +%% catch-expression, otherwise <code>false</code>. +%% +%% @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 +%% "<code>cerl.hrl</code>". +%% +%% @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 "<code>core_parse.hrl</code>". +%% +%% @see type/1 +%% @see to_records/1 + +-spec from_records(cerl()) -> cerl(). + +from_records(Node) -> + Node. + + +%% --------------------------------------------------------------------- + +%% @spec is_data(Node::cerl()) -> boolean() +%% +%% @doc Returns <code>true</code> if <code>Node</code> represents a +%% data constructor, otherwise <code>false</code>. 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. <code>is_data/1</code>.) This is mainly useful for +%% comparing types and for constructing new nodes of the same type +%% (cf. <code>make_data/2</code>). If <code>Node</code> represents an +%% integer, floating-point number, atom or empty list, the result is +%% <code>{atomic, Value}</code>, where <code>Value</code> is the value +%% of <code>concrete(Node)</code>, otherwise the result is either +%% <code>cons</code> or <code>tuple</code>. +%% +%% <p>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.</p> +%% +%% @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. +%% +%% <p>Note: if <code>data_type(Node)</code> is <code>cons</code>, the +%% number of subtrees is exactly two. If <code>data_type(Node)</code> +%% is <code>{atomic, Value}</code>, the number of subtrees is +%% zero.</p> +%% +%% @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 <code>length(data_es(Node))</code>, 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. <code>data_type/1</code>.) An exception is thrown +%% if the length of <code>Elements</code> is invalid for the given +%% <code>Type</code>; see <code>data_es/1</code> 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 <code>make_data/2</code>, but analogous to +%% <code>c_tuple_skel/1</code> and <code>c_cons_skel/2</code>. +%% +%% @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 +%% <code>Node</code> is a leaf node (cf. <code>is_leaf/1</code>), this +%% is the empty list, otherwise the result is always a nonempty list, +%% containing the lists of subtrees of <code>Node</code>, 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. +%% +%% <p>Depending on the type of <code>Node</code>, 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.</p> +%% +%% <p>The function <code>subtrees/1</code> and the constructor functions +%% <code>make_tree/2</code> and <code>update_tree/2</code> 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.</p> +%% +%% <p>For example: +%% <pre> +%% postorder(F, Tree) -> +%% F(case subtrees(Tree) of +%% [] -> Tree; +%% List -> update_tree(Tree, +%% [[postorder(F, Subtree) +%% || Subtree <- Group] +%% || Group <- List]) +%% end). +%% </pre> +%% maps the function <code>F</code> on <code>Tree</code> and all its +%% subtrees, doing a post-order traversal of the syntax tree. (Note +%% the use of <code>update_tree/2</code> to preserve annotations.) For +%% a simple function like: +%% <pre> +%% f(Node) -> +%% case type(Node) of +%% atom -> atom("a_" ++ atom_name(Node)); +%% _ -> Node +%% end. +%% </pre> +%% the call <code>postorder(fun f/1, Tree)</code> will yield a new +%% representation of <code>Tree</code> in which all atom names have +%% been extended with the prefix "a_", but nothing else (including +%% annotations) has been changed.</p> +%% +%% @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 <code>Old</code> node. This is +%% equivalent to <code>ann_make_tree(get_ann(Node), type(Node), +%% Groups)</code>, 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 <code>Old</code> node. This is +%% equivalent to <code>ann_make_tree(get_ann(Node), Type, +%% Groups)</code>, 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. +%% <code>Type</code> must be a node type name +%% (cf. <code>type/1</code>) that does not denote a leaf node type +%% (cf. <code>is_leaf/1</code>). <code>Groups</code> must be a +%% <em>nonempty</em> 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 <code>subtrees/1</code>. +%% +%% <p>The result of <code>ann_make_tree(get_ann(Node), type(Node), +%% subtrees(Node))</code> (cf. <code>update_tree/2</code>) represents +%% the same source code text as the original <code>Node</code>, +%% assuming that <code>subtrees(Node)</code> yields a nonempty +%% list. However, it does not necessarily have the exact same data +%% representation as <code>Node</code>.</p> +%% +%% @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 <code>make_tree/2</code> 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 "<code><em>MetaTree</em></code>" +%% which, if evaluated, will yield a new syntax tree representing the +%% same source code text as <code>Tree</code> (although the actual +%% data representation may be different). The expression represented +%% by <code>MetaTree</code> is <em>implementation independent</em> +%% with regard to the data structures used by the abstract syntax tree +%% implementation. +%% +%% <p>Any node in <code>Tree</code> whose node type is +%% <code>var</code> (cf. <code>type/1</code>), and whose list of +%% annotations (cf. <code>get_ann/1</code>) contains the atom +%% <code>meta_var</code>, will remain unchanged in the resulting tree, +%% except that exactly one occurrence of <code>meta_var</code> is +%% removed from its annotation list.</p> +%% +%% <p>The main use of the function <code>meta/1</code> is to transform +%% a data structure <code>Tree</code>, which represents a piece of +%% program code, into a form that is <em>representation independent +%% when printed</em>. E.g., suppose <code>Tree</code> represents a +%% variable named "V". Then (assuming a function <code>print/1</code> +%% for printing syntax trees), evaluating +%% <code>print(abstract(Tree))</code> - simply using +%% <code>abstract/1</code> to map the actual data structure onto a +%% syntax tree representation - would output a string that might look +%% something like "<code>{var, ..., 'V'}</code>", 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 +%% <code>print(meta(Tree))</code> instead would output a +%% <em>representation independent</em> syntax tree generating +%% expression; in the above case, something like +%% "<code>cerl:c_var('V')</code>".</p> +%% +%% <p>The implementation tries to generate compact code with respect +%% to literals and lists.</p> +%% +%% @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 <[email protected]> +%%% Kostis Sagonas <[email protected]> +%%% Description : Header file for Dialyzer. +%%% +%%% Created : 1 Oct 2004 by Kostis Sagonas <[email protected]> +%%%------------------------------------------------------------------- + +-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 <[email protected]> +%%% Description : +%%% +%%% Created : 19 Apr 2005 by Tobias Lindahl <[email protected]> +%%%------------------------------------------------------------------- + +-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, <List of warns>} + %% More funs checked: {many, <List of warns>} + %% 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 <[email protected]> +%%% Description : Utility functions for race condition detection +%%% +%%% Created : 21 Nov 2008 by Maria Christakis <[email protected]> +%%%---------------------------------------------------------------------- +-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. +%% +%% ====================================================================== + +-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. diff --git a/lib/erl_docgen/src/docgen_edoc_xml_cb.erl b/lib/erl_docgen/src/docgen_edoc_xml_cb.erl index 4f3af1f767..13ff0a139d 100644 --- a/lib/erl_docgen/src/docgen_edoc_xml_cb.erl +++ b/lib/erl_docgen/src/docgen_edoc_xml_cb.erl @@ -111,7 +111,16 @@ root_attributes(Element, Opts) -> Enc -> Enc end, - [#xmlAttribute{name=encoding, value=Encoding}]. + [#xmlAttribute{name=encoding, value=reformat_encoding(Encoding)}]. + +%% epp:default_encoding/0 returns 'utf8' +reformat_encoding(utf8) -> "UTF-8"; +reformat_encoding(List) when is_list(List) -> + case string:to_lower(List) of + "utf8" -> "UTF-8"; + _ -> List + end; +reformat_encoding(Other) -> Other. layout_chapter(#xmlElement{name=overview, content=Es}) -> Title = get_text(title, Es), diff --git a/lib/hipe/cerl/erl_types.erl b/lib/hipe/cerl/erl_types.erl index 15f7b793a1..9ef119ba46 100644 --- a/lib/hipe/cerl/erl_types.erl +++ b/lib/hipe/cerl/erl_types.erl @@ -611,9 +611,13 @@ t_decorate_with_opaque(T1, T2, Opaques) -> false -> T1; true -> R = decorate(T1, T, Opaques), - ?debug(case catch t_is_equal(t_unopaque(R), t_unopaque(T1)) of - true -> ok; - false -> + ?debug(case catch + not t_is_equal(t_unopaque(R), t_unopaque(T1)) + orelse + t_is_equal(T1, T) andalso not t_is_equal(T1, R) + of + false -> ok; + _ -> io:format("T1 = ~p,\n", [T1]), io:format("T2 = ~p,\n", [T2]), io:format("O = ~p,\n", [Opaques]), @@ -642,7 +646,6 @@ decorate(?tuple_set(List), ?tuple_set(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); @@ -656,7 +659,7 @@ 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)), + NewType = sup_opaque(List), case All of true -> NewType; false -> t_sup(NewType, Type) @@ -670,9 +673,10 @@ decoration([#opaque{struct = S} = Opaque|OpaqueTypes], Type, Opaques, 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)}, + NewI = decorate(I, S, Opaques), + NewOpaque = combine(NewI, [Opaque]), NewAll = All orelse t_is_equal(I, Type), - NewOpaqueTypes = [NewOpaque|NewOpaqueTypes0], + NewOpaqueTypes = NewOpaque ++ NewOpaqueTypes0, decoration(OpaqueTypes, Type, Opaques, NewOpaqueTypes, NewAll) end; decoration([], _Type, _Opaques, NewOpaqueTypes, All) -> @@ -2991,27 +2995,21 @@ 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) + case is_compat_opaque_names(T1, T2) of + true -> combine(S, [T1]); + false -> combine(S, [T1, 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. +combine(?opaque(Set), Ts) -> + [comb2(O, T) || O <- Set, T <- Ts]; +combine(S, Ts) -> + [T#opaque{struct = S} || T <- Ts]. -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. +comb2(O, T) -> + case is_compat_opaque_names(O, T) of + true -> O; + false -> T#opaque{struct = ?opaque(set_singleton(O))} + end. %% Combining two lists this way can be very time consuming... %% Note: two parameterized opaque types are not the same if their @@ -3020,32 +3018,27 @@ 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)), + {Is1, T1} <- List1, + {Is2, T2} <- List2, + not t_is_none(Inf = inf_opaque_types(Is1, T1, Is2, T2, Opaques))], + List = 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)]. + [{Opaques =:= 'universe' orelse inf_is_opaque_type2(T, Opaques), T} || + 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) -> +inf_opaque_types(IsOpaque1, T1, IsOpaque2, T2, Opaques) -> #opaque{struct = S1}=T1, #opaque{struct = S2}=T2, case - Opaques =:= 'universe' orelse - is_compat_opaque_names(ModNameArgs1, ModNameArgs2) + Opaques =:= 'universe' orelse is_compat_opaque_names(T1, T2) of true -> t_inf(S1, S2, Opaques); false -> @@ -3059,10 +3052,15 @@ inf_opaque_types(IsOpaque1, ModNameArgs1, T1, 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_opaque_names(Opaque1, Opaque2) -> + #opaque{mod = Mod1, name = Name1, args = Args1} = Opaque1, + #opaque{mod = Mod2, name = Name2, args = Args2} = Opaque2, + case {{Mod1, Name1, Args1}, {Mod2, Name2, Args2}} of + {ModNameArgs, ModNameArgs} -> true; + {{Mod, Name, Args1}, {Mod, Name, Args2}} -> + is_compat_args(Args1, Args2); + _ -> false + end. is_compat_args([A1|Args1], [A2|Args2]) -> is_compat_arg(A1, A2) andalso is_compat_args(Args1, Args2); @@ -3109,6 +3107,10 @@ is_specialization(?tuple_set(List1), ?tuple_set(List2)) -> [sup_tuple_elements(T) || {_Arity, T} <- List2]) catch _:_ -> 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(?union(List1)=T1, ?union(List2)=T2) -> case specialization_union2(T1, T2) of {yes, Type1, Type2} -> is_specialization(Type1, Type2); @@ -3124,10 +3126,6 @@ is_specialization(T1, ?union(List)) -> {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; @@ -4482,28 +4480,31 @@ t_from_form1(Form, ET, Site, MR, V, C) -> vtab = V, tnames = TypeNames}, L = ?EXPAND_LIMIT, - {T1, L1, C1} = from_form(Form, State, ?EXPAND_DEPTH, L, C), + {T0, L0, C0} = from_form(Form, State, ?EXPAND_DEPTH, L, C), if - L1 =< 0 -> - from_form_loop(Form, State, 1, L, C1); + L0 =< 0 -> + {T1, _, C1} = from_form(Form, State, 1, L, C0), + from_form_loop(Form, State, 2, L, C1, T1); true -> - {T1, C1} + {T0, C0} end. initial_typenames({type, _MTA}=Site) -> [Site]; initial_typenames({spec, _MFA}) -> []; initial_typenames({record, _MRA}) -> []. -from_form_loop(Form, State, D, Limit, C) -> +from_form_loop(Form, State, D, Limit, C, T0) -> {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. + L1 =< 0 -> + {T0, C1}; Delta * 8 > Limit -> + %% Save some time by assuming next depth will exceed the limit. {T1, C1}; true -> D1 = D + 1, - from_form_loop(Form, State, D1, Limit, C1) + from_form_loop(Form, State, D1, Limit, C1, T1) end. -spec from_form(parse_form(), diff --git a/lib/inets/src/ftp/ftp.erl b/lib/inets/src/ftp/ftp.erl index 8bad91bf98..6868b75eff 100644 --- a/lib/inets/src/ftp/ftp.erl +++ b/lib/inets/src/ftp/ftp.erl @@ -108,6 +108,7 @@ -define(DBG(F,A), 'n/a'). %%-define(DBG(F,A), io:format(F,A)). +%%-define(DBG(F,A), if is_list(F) -> ct:pal(F,A); is_atom(F)->ct:pal(atom_to_list(F),A) end). %%%========================================================================= %%% API - CLIENT FUNCTIONS @@ -2361,14 +2362,17 @@ send_message({ssl, Socket}, Message) -> activate_ctrl_connection(#state{csock = Socket, ctrl_data = {<<>>, _, _}}) -> activate_connection(Socket); activate_ctrl_connection(#state{csock = Socket}) -> + activate_connection(Socket), %% We have already received at least part of the next control message, %% that has been saved in ctrl_data, process this first. - self() ! {tcp, unwrap_socket(Socket), <<>>}. + self() ! {socket_type(Socket), unwrap_socket(Socket), <<>>}. unwrap_socket({tcp,Socket}) -> Socket; unwrap_socket({ssl,Socket}) -> Socket; unwrap_socket(Socket) -> Socket. +socket_type({tcp,_Socket}) -> tcp; +socket_type({ssl,_Socket}) -> ssl. activate_data_connection(#state{dsock = Socket} = State) -> activate_connection(Socket), diff --git a/lib/inets/src/ftp/ftp_response.erl b/lib/inets/src/ftp/ftp_response.erl index 7533bc4550..d54d97dc91 100644 --- a/lib/inets/src/ftp/ftp_response.erl +++ b/lib/inets/src/ftp/ftp_response.erl @@ -90,19 +90,23 @@ parse_lines(<<C1, C2, C3, ?WHITE_SPACE, Bin/binary>>, Lines, start) -> parse_lines(Bin, [?WHITE_SPACE, C3, C2, C1 | Lines], finish); %% Last line found -parse_lines(<<C1, C2, C3, ?WHITE_SPACE, Rest/binary>>, Lines, {C1, C2, C3}) -> - parse_lines(Rest, [?WHITE_SPACE, C3, C2, C1 | Lines], finish); +parse_lines(<<?CR, ?LF, C1, C2, C3, ?WHITE_SPACE, Rest/binary>>, Lines, {C1, C2, C3}) -> + parse_lines(Rest, [?WHITE_SPACE, C3, C2, C1, ?LF, ?CR | Lines], finish); %% Potential end found wait for more data -parse_lines(<<C1, C2, C3>> = Bin, Lines, {C1, C2, C3}) -> +parse_lines(<<?CR, ?LF, C1, C2, C3>> = Bin, Lines, {C1, C2, C3}) -> {continue, {Bin, Lines, {C1, C2, C3}}}; %% Intermidate line begining with status code -parse_lines(<<C1, C2, C3, Rest/binary>>, Lines, {C1, C2, C3}) -> - parse_lines(Rest, [C3, C2, C1 | Lines], {C1, C2, C3}); +parse_lines(<<?CR, ?LF, C1, C2, C3, Rest/binary>>, Lines, {C1, C2, C3}) -> + parse_lines(Rest, [C3, C2, C1, ?LF, ?CR | Lines], {C1, C2, C3}); %% Potential last line wait for more data -parse_lines(<<C1, C2>> = Data, Lines, {C1, C2, _} = StatusCode) -> +parse_lines(<<?CR, ?LF, C1, C2>> = Data, Lines, {C1, C2, _} = StatusCode) -> {continue, {Data, Lines, StatusCode}}; -parse_lines(<<C1>> = Data, Lines, {C1, _, _} = StatusCode) -> +parse_lines(<<?CR, ?LF, C1>> = Data, Lines, {C1, _, _} = StatusCode) -> + {continue, {Data, Lines, StatusCode}}; +parse_lines(<<?CR, ?LF>> = Data, Lines, {_,_,_} = StatusCode) -> + {continue, {Data, Lines, StatusCode}}; +parse_lines(<<?LF>> = Data, Lines, {_,_,_} = StatusCode) -> {continue, {Data, Lines, StatusCode}}; parse_lines(<<>> = Data, Lines, {_,_,_} = StatusCode) -> {continue, {Data, Lines, StatusCode}}; diff --git a/lib/inets/test/ftp_format_SUITE.erl b/lib/inets/test/ftp_format_SUITE.erl index a33b31f46f..95d594a44b 100644 --- a/lib/inets/test/ftp_format_SUITE.erl +++ b/lib/inets/test/ftp_format_SUITE.erl @@ -38,8 +38,8 @@ all() -> groups() -> [{ftp_response, [], [ftp_150, ftp_200, ftp_220, ftp_226, ftp_257, ftp_331, - ftp_425, ftp_other_status_codes, ftp_multiple_lines, - ftp_multipel_ctrl_messages]}]. + ftp_425, ftp_other_status_codes, ftp_multiple_lines_status_in_msg, + ftp_multiple_lines, ftp_multipel_ctrl_messages]}]. init_per_suite(Config) -> Config. @@ -141,6 +141,15 @@ ftp_425(Config) when is_list(Config) -> {trans_neg_compl, _} = ftp_response:interpret(Msg), ok. +ftp_multiple_lines_status_in_msg() -> + [{doc, "check that multiple lines gets parsed correct, even if we have " + " the status code within the msg being sent"}]. +ftp_multiple_lines_status_in_msg(Config) when is_list(Config) -> + ML = "230-User usr-230 is logged in\r\n" ++ + "230 OK. Current directory is /\r\n", + {ok, ML, <<>>} = ftp_response:parse_lines(list_to_binary(ML), [], start), + ok. + ftp_multiple_lines() -> [{doc, "Especially check multiple lines devided in significant places"}]. ftp_multiple_lines(Config) when is_list(Config) -> diff --git a/lib/ssh/doc/src/notes.xml b/lib/ssh/doc/src/notes.xml index f6ad8d8dea..f5a67bc00e 100644 --- a/lib/ssh/doc/src/notes.xml +++ b/lib/ssh/doc/src/notes.xml @@ -30,6 +30,38 @@ <file>notes.xml</file> </header> +<section><title>Ssh 4.3.6</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + Re-negotiation problems with OpenSSH client solved.</p> + <p> + Own Id: OTP-13972</p> + </item> + </list> + </section> + +</section> + +<section><title>Ssh 4.3.5</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + If a client illegaly sends an info-line and then + immediatly closes the TCP-connection, a badmatch + exception was raised.</p> + <p> + Own Id: OTP-13966</p> + </item> + </list> + </section> + +</section> + <section><title>Ssh 4.3.4</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/ssh/src/ssh_connection_handler.erl b/lib/ssh/src/ssh_connection_handler.erl index abfba4baf1..dd414894d4 100644 --- a/lib/ssh/src/ssh_connection_handler.erl +++ b/lib/ssh/src/ssh_connection_handler.erl @@ -525,7 +525,7 @@ handle_event(_, _Event, {init_error,Error}, _) -> %% The very first event that is sent when the we are set as controlling process of Socket handle_event(_, socket_control, {hello,_}, D) -> VsnMsg = ssh_transport:hello_version_msg(string_version(D#data.ssh_params)), - ok = send_bytes(VsnMsg, D), + send_bytes(VsnMsg, D), case inet:getopts(Socket=D#data.socket, [recbuf]) of {ok, [{recbuf,Size}]} -> %% Set the socket to the hello text line handling mode: @@ -545,12 +545,13 @@ handle_event(_, {info_line,_Line}, {hello,Role}, D) -> case Role of client -> %% The server may send info lines to the client before the version_exchange + %% RFC4253/4.2 inet:setopts(D#data.socket, [{active, once}]), keep_state_and_data; server -> %% But the client may NOT send them to the server. Openssh answers with cleartext, %% and so do we - ok = send_bytes("Protocol mismatch.", D), + send_bytes("Protocol mismatch.", D), {stop, {shutdown,"Protocol mismatch in version exchange. Client sent info lines."}} end; @@ -565,7 +566,7 @@ handle_event(_, {version_exchange,Version}, {hello,Role}, D) -> {active, once}, {recbuf, D#data.inet_initial_recbuf_size}]), {KeyInitMsg, SshPacket, Ssh} = ssh_transport:key_exchange_init_msg(Ssh1), - ok = send_bytes(SshPacket, D), + send_bytes(SshPacket, D), {next_state, {kexinit,Role,init}, D#data{ssh_params = Ssh, key_exchange_init_msg = KeyInitMsg}}; not_supported -> @@ -583,7 +584,7 @@ handle_event(_, {#ssh_msg_kexinit{}=Kex, Payload}, {kexinit,Role,ReNeg}, Ssh1 = ssh_transport:key_init(peer_role(Role), D#data.ssh_params, Payload), Ssh = case ssh_transport:handle_kexinit_msg(Kex, OwnKex, Ssh1) of {ok, NextKexMsg, Ssh2} when Role==client -> - ok = send_bytes(NextKexMsg, D), + send_bytes(NextKexMsg, D), Ssh2; {ok, Ssh2} when Role==server -> Ssh2 @@ -596,43 +597,43 @@ handle_event(_, {#ssh_msg_kexinit{}=Kex, Payload}, {kexinit,Role,ReNeg}, %%%---- diffie-hellman handle_event(_, #ssh_msg_kexdh_init{} = Msg, {key_exchange,server,ReNeg}, D) -> {ok, KexdhReply, Ssh1} = ssh_transport:handle_kexdh_init(Msg, D#data.ssh_params), - ok = send_bytes(KexdhReply, D), + send_bytes(KexdhReply, D), {ok, NewKeys, Ssh} = ssh_transport:new_keys_message(Ssh1), - ok = send_bytes(NewKeys, D), + send_bytes(NewKeys, D), {next_state, {new_keys,server,ReNeg}, D#data{ssh_params=Ssh}}; handle_event(_, #ssh_msg_kexdh_reply{} = Msg, {key_exchange,client,ReNeg}, D) -> {ok, NewKeys, Ssh} = ssh_transport:handle_kexdh_reply(Msg, D#data.ssh_params), - ok = send_bytes(NewKeys, D), + send_bytes(NewKeys, D), {next_state, {new_keys,client,ReNeg}, D#data{ssh_params=Ssh}}; %%%---- diffie-hellman group exchange handle_event(_, #ssh_msg_kex_dh_gex_request{} = Msg, {key_exchange,server,ReNeg}, D) -> {ok, GexGroup, Ssh} = ssh_transport:handle_kex_dh_gex_request(Msg, D#data.ssh_params), - ok = send_bytes(GexGroup, D), + send_bytes(GexGroup, D), {next_state, {key_exchange_dh_gex_init,server,ReNeg}, D#data{ssh_params=Ssh}}; handle_event(_, #ssh_msg_kex_dh_gex_request_old{} = Msg, {key_exchange,server,ReNeg}, D) -> {ok, GexGroup, Ssh} = ssh_transport:handle_kex_dh_gex_request(Msg, D#data.ssh_params), - ok = send_bytes(GexGroup, D), + send_bytes(GexGroup, D), {next_state, {key_exchange_dh_gex_init,server,ReNeg}, D#data{ssh_params=Ssh}}; handle_event(_, #ssh_msg_kex_dh_gex_group{} = Msg, {key_exchange,client,ReNeg}, D) -> {ok, KexGexInit, Ssh} = ssh_transport:handle_kex_dh_gex_group(Msg, D#data.ssh_params), - ok = send_bytes(KexGexInit, D), + send_bytes(KexGexInit, D), {next_state, {key_exchange_dh_gex_reply,client,ReNeg}, D#data{ssh_params=Ssh}}; %%%---- elliptic curve diffie-hellman handle_event(_, #ssh_msg_kex_ecdh_init{} = Msg, {key_exchange,server,ReNeg}, D) -> {ok, KexEcdhReply, Ssh1} = ssh_transport:handle_kex_ecdh_init(Msg, D#data.ssh_params), - ok = send_bytes(KexEcdhReply, D), + send_bytes(KexEcdhReply, D), {ok, NewKeys, Ssh} = ssh_transport:new_keys_message(Ssh1), - ok = send_bytes(NewKeys, D), + send_bytes(NewKeys, D), {next_state, {new_keys,server,ReNeg}, D#data{ssh_params=Ssh}}; handle_event(_, #ssh_msg_kex_ecdh_reply{} = Msg, {key_exchange,client,ReNeg}, D) -> {ok, NewKeys, Ssh} = ssh_transport:handle_kex_ecdh_reply(Msg, D#data.ssh_params), - ok = send_bytes(NewKeys, D), + send_bytes(NewKeys, D), {next_state, {new_keys,client,ReNeg}, D#data{ssh_params=Ssh}}; @@ -640,9 +641,9 @@ handle_event(_, #ssh_msg_kex_ecdh_reply{} = Msg, {key_exchange,client,ReNeg}, D) handle_event(_, #ssh_msg_kex_dh_gex_init{} = Msg, {key_exchange_dh_gex_init,server,ReNeg}, D) -> {ok, KexGexReply, Ssh1} = ssh_transport:handle_kex_dh_gex_init(Msg, D#data.ssh_params), - ok = send_bytes(KexGexReply, D), + send_bytes(KexGexReply, D), {ok, NewKeys, Ssh} = ssh_transport:new_keys_message(Ssh1), - ok = send_bytes(NewKeys, D), + send_bytes(NewKeys, D), {next_state, {new_keys,server,ReNeg}, D#data{ssh_params=Ssh}}; @@ -650,7 +651,7 @@ handle_event(_, #ssh_msg_kex_dh_gex_init{} = Msg, {key_exchange_dh_gex_init,serv handle_event(_, #ssh_msg_kex_dh_gex_reply{} = Msg, {key_exchange_dh_gex_reply,client,ReNeg}, D) -> {ok, NewKeys, Ssh1} = ssh_transport:handle_kex_dh_gex_reply(Msg, D#data.ssh_params), - ok = send_bytes(NewKeys, D), + send_bytes(NewKeys, D), {next_state, {new_keys,client,ReNeg}, D#data{ssh_params=Ssh1}}; @@ -662,7 +663,7 @@ handle_event(_, #ssh_msg_newkeys{} = Msg, {new_keys,Role,init}, D) -> Ssh = case Role of client -> {MsgReq, Ssh2} = ssh_auth:service_request_msg(Ssh1), - ok = send_bytes(MsgReq, D), + send_bytes(MsgReq, D), Ssh2; server -> Ssh1 @@ -670,8 +671,9 @@ handle_event(_, #ssh_msg_newkeys{} = Msg, {new_keys,Role,init}, D) -> {next_state, {service_request,Role}, D#data{ssh_params=Ssh}}; %% Subsequent key exchange rounds (renegotiation): -handle_event(_, #ssh_msg_newkeys{}, {new_keys,Role,renegotiate}, D) -> - {next_state, {connected,Role}, D}; +handle_event(_, #ssh_msg_newkeys{} = Msg, {new_keys,Role,renegotiate}, D) -> + {ok, Ssh} = ssh_transport:handle_new_keys(Msg, D#data.ssh_params), + {next_state, {connected,Role}, D#data{ssh_params=Ssh}}; %%% ######## {service_request, client|server} @@ -680,7 +682,7 @@ handle_event(_, Msg = #ssh_msg_service_request{name=ServiceName}, StateName = {s "ssh-userauth" -> Ssh0 = #ssh{session_id=SessionId} = D#data.ssh_params, {ok, {Reply, Ssh}} = ssh_auth:handle_userauth_request(Msg, SessionId, Ssh0), - ok = send_bytes(Reply, D), + send_bytes(Reply, D), {next_state, {userauth,server}, D#data{ssh_params = Ssh}}; _ -> @@ -692,7 +694,7 @@ handle_event(_, Msg = #ssh_msg_service_request{name=ServiceName}, StateName = {s handle_event(_, #ssh_msg_service_accept{name = "ssh-userauth"}, {service_request,client}, #data{ssh_params = #ssh{service="ssh-userauth"} = Ssh0} = State) -> {Msg, Ssh} = ssh_auth:init_userauth_request_msg(Ssh0), - ok = send_bytes(Msg, State), + send_bytes(Msg, State), {next_state, {userauth,client}, State#data{auth_user = Ssh#ssh.user, ssh_params = Ssh}}; @@ -709,7 +711,7 @@ handle_event(_, %% Probably the very first userauth_request but we deny unauthorized login {not_authorized, _, {Reply,Ssh}} = ssh_auth:handle_userauth_request(Msg, Ssh0#ssh.session_id, Ssh0), - ok = send_bytes(Reply, D), + send_bytes(Reply, D), {keep_state, D#data{ssh_params = Ssh}}; {"ssh-connection", "ssh-connection", Method} -> @@ -719,7 +721,7 @@ handle_event(_, %% Yepp! we support this method case ssh_auth:handle_userauth_request(Msg, Ssh0#ssh.session_id, Ssh0) of {authorized, User, {Reply, Ssh}} -> - ok = send_bytes(Reply, D), + send_bytes(Reply, D), D#data.starter ! ssh_connected, connected_fun(User, Method, D), {next_state, {connected,server}, @@ -727,11 +729,11 @@ handle_event(_, ssh_params = Ssh#ssh{authenticated = true}}}; {not_authorized, {User, Reason}, {Reply, Ssh}} when Method == "keyboard-interactive" -> retry_fun(User, Reason, D), - ok = send_bytes(Reply, D), + send_bytes(Reply, D), {next_state, {userauth_keyboard_interactive,server}, D#data{ssh_params = Ssh}}; {not_authorized, {User, Reason}, {Reply, Ssh}} -> retry_fun(User, Reason, D), - ok = send_bytes(Reply, D), + send_bytes(Reply, D), {keep_state, D#data{ssh_params = Ssh}} end; false -> @@ -1512,7 +1514,8 @@ send_msg(Msg, State=#data{ssh_params=Ssh0}) when is_tuple(Msg) -> State#data{ssh_params=Ssh}. send_bytes(Bytes, #data{socket = Socket, transport_cb = Transport}) -> - Transport:send(Socket, Bytes). + _ = Transport:send(Socket, Bytes), + ok. handle_version({2, 0} = NumVsn, StrVsn, Ssh0) -> Ssh = counterpart_versions(NumVsn, StrVsn, Ssh0), diff --git a/lib/ssh/test/Makefile b/lib/ssh/test/Makefile index 6ce6d6f537..3fca78237c 100644 --- a/lib/ssh/test/Makefile +++ b/lib/ssh/test/Makefile @@ -52,7 +52,8 @@ MODULES= \ ssh_echo_server \ ssh_peername_sockname_server \ ssh_test_cli \ - ssh_relay + ssh_relay \ + ssh_eqc_event_handler HRL_FILES_NEEDED_IN_TEST= \ $(ERL_TOP)/lib/ssh/test/ssh_test_lib.hrl \ diff --git a/lib/ssh/test/property_test/ssh_eqc_client_info_timing.erl b/lib/ssh/test/property_test/ssh_eqc_client_info_timing.erl new file mode 100644 index 0000000000..c07140dc43 --- /dev/null +++ b/lib/ssh/test/property_test/ssh_eqc_client_info_timing.erl @@ -0,0 +1,92 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2004-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(ssh_eqc_client_info_timing). + +-compile(export_all). + +-proptest(eqc). +-proptest([triq,proper]). + +-ifndef(EQC). +-ifndef(PROPER). +-ifndef(TRIQ). +-define(EQC,true). +%%-define(PROPER,true). +%%-define(TRIQ,true). +-endif. +-endif. +-endif. + +-ifdef(EQC). +-include_lib("eqc/include/eqc.hrl"). +-define(MOD_eqc,eqc). + +-else. +-ifdef(PROPER). +-include_lib("proper/include/proper.hrl"). +-define(MOD_eqc,proper). + +-else. +-ifdef(TRIQ). +-define(MOD_eqc,triq). +-include_lib("triq/include/triq.hrl"). + +-endif. +-endif. +-endif. + + +%%% Properties: + +prop_seq(_Config) -> + {ok,Pid} = ssh_eqc_event_handler:add_report_handler(), + {_, _, Port} = init_daemon(), + numtests(1000, + ?FORALL(Delay, choose(0,100),%% Micro seconds + try + send_bad_sequence(Port, Delay, Pid), + not any_relevant_error_report(Pid) + catch + C:E -> io:format('~p:~p~n',[C,E]), + false + end + )). + +send_bad_sequence(Port, Delay, Pid) -> + {ok,S} = gen_tcp:connect("localhost",Port,[]), + gen_tcp:send(S,"Illegal info-string\r\n"), + ssh_test_lib:sleep_microsec(Delay), + gen_tcp:close(S). + +any_relevant_error_report(Pid) -> + {ok, Reports} = ssh_eqc_event_handler:get_reports(Pid), + lists:any(fun({error_report,_,{_,supervisor_report,L}}) when is_list(L) -> + lists:member({reason,{badmatch,{error,closed}}}, L); + (_) -> + false + end, Reports). + +%%%================================================================ +init_daemon() -> + ok = begin ssh:stop(), ssh:start() end, + ssh_test_lib:daemon([]). + diff --git a/lib/ssh/test/ssh_eqc_event_handler.erl b/lib/ssh/test/ssh_eqc_event_handler.erl new file mode 100644 index 0000000000..233965012a --- /dev/null +++ b/lib/ssh/test/ssh_eqc_event_handler.erl @@ -0,0 +1,43 @@ +-module(ssh_eqc_event_handler). + +-compile(export_all). + +-behaviour(gen_event). + +add_report_handler() -> + error_logger:add_report_handler(?MODULE, [self(),Ref=make_ref()]), + receive + {event_handler_started,HandlerPid,Ref} -> + {ok,HandlerPid} + end. + +get_reports(Pid) -> + Pid ! {get_reports,self(),Ref=make_ref()}, + receive + {reports,Reports,Ref} -> + {ok,Reports} + end. + +%%%================================================================ + +-record(state, { + reports = [] + }). + +%% error_logger:add_report_handler(ssh_eqc_event_handler, [self()]). + +init([CallerPid,Ref]) -> + CallerPid ! {event_handler_started,self(),Ref}, + {ok, #state{}}. + +handle_event(Event, State) -> + {ok, State#state{reports = [Event|State#state.reports]}}. + +handle_info({get_reports,From,Ref}, State) -> + From ! {reports, lists:reverse(State#state.reports), Ref}, + {ok, State#state{reports=[]}}. + +handle_call(_Request, State) -> {ok,reply,State}. +terminate(_Arg, _State) -> stop. + +code_change(_OldVsn, State, _Extra) -> {ok, State}. diff --git a/lib/ssh/test/ssh_property_test_SUITE.erl b/lib/ssh/test/ssh_property_test_SUITE.erl index c8aabcedb7..7ba2732a88 100644 --- a/lib/ssh/test/ssh_property_test_SUITE.erl +++ b/lib/ssh/test/ssh_property_test_SUITE.erl @@ -38,6 +38,7 @@ -include_lib("common_test/include/ct.hrl"). all() -> [{group, messages}, + client_sends_info_timing, {group, client_server} ]. @@ -106,3 +107,9 @@ client_server_parallel_multi(Config) -> ssh_eqc_client_server:prop_parallel_multi(Config), Config ). + +client_sends_info_timing(Config) -> + ct_property_test:quickcheck( + ssh_eqc_client_info_timing:prop_seq(Config), + Config + ). diff --git a/lib/ssh/test/ssh_protocol_SUITE.erl b/lib/ssh/test/ssh_protocol_SUITE.erl index 4fac1f718a..93d0bc2eb0 100644 --- a/lib/ssh/test/ssh_protocol_SUITE.erl +++ b/lib/ssh/test/ssh_protocol_SUITE.erl @@ -48,6 +48,7 @@ suite() -> all() -> [{group,tool_tests}, + client_info_line, {group,kex}, {group,service_requests}, {group,authentication}, @@ -575,6 +576,36 @@ client_handles_keyboard_interactive_0_pwds(Config) -> ). + +%%%-------------------------------------------------------------------- +client_info_line(_Config) -> + %% A client must not send an info-line. If it does, the server should handle + %% handle this gracefully + {ok,Pid} = ssh_eqc_event_handler:add_report_handler(), + {_, _, Port} = ssh_test_lib:daemon([]), + + %% Fake client: + {ok,S} = gen_tcp:connect("localhost",Port,[]), + gen_tcp:send(S,"An illegal info-string\r\n"), + gen_tcp:close(S), + + %% wait for server to react: + timer:sleep(1000), + + %% check if a badmatch was received: + {ok, Reports} = ssh_eqc_event_handler:get_reports(Pid), + case lists:any(fun({error_report,_,{_,supervisor_report,L}}) when is_list(L) -> + lists:member({reason,{badmatch,{error,closed}}}, L); + (_) -> + false + end, Reports) of + true -> + ct:fail("Bad error report on info_line from client"); + false -> + ok + end. + + %%%================================================================ %%%==== Internal functions ======================================== %%%================================================================ diff --git a/lib/ssh/test/ssh_test_lib.erl b/lib/ssh/test/ssh_test_lib.erl index 6233680dce..6fd401d182 100644 --- a/lib/ssh/test/ssh_test_lib.erl +++ b/lib/ssh/test/ssh_test_lib.erl @@ -208,6 +208,16 @@ reply(TestCase, Result) -> rcv_expected(Expect, SshPort, Timeout) -> receive + {SshPort, Recvd} when is_function(Expect) -> + case Expect(Recvd) of + true -> + ct:log("Got expected ~p from ~p",[Recvd,SshPort]), + catch port_close(SshPort), + rcv_lingering(50); + false -> + ct:log("Got UNEXPECTED ~p~n",[Recvd]), + rcv_expected(Expect, SshPort, Timeout) + end; {SshPort, Expect} -> ct:log("Got expected ~p from ~p",[Expect,SshPort]), catch port_close(SshPort), @@ -767,3 +777,28 @@ open_port(Arg1, ExtraOpts) -> use_stdio, overlapped_io, hide %only affects windows | ExtraOpts]). + +%%%---------------------------------------------------------------- +%%% Sleeping + +%%% Milli sec +sleep_millisec(Nms) -> receive after Nms -> ok end. + +%%% Micro sec +sleep_microsec(Nus) -> + busy_wait(Nus, erlang:system_time(microsecond)). + +busy_wait(Nus, T0) -> + T = erlang:system_time(microsecond) - T0, + Tleft = Nus - T, + if + Tleft > 2000 -> + sleep_millisec((Tleft-1500) div 1000), % μs -> ms + busy_wait(Nus,T0); + Tleft > 1 -> + busy_wait(Nus, T0); + true -> + T + end. + +%%%---------------------------------------------------------------- diff --git a/lib/ssh/test/ssh_to_openssh_SUITE.erl b/lib/ssh/test/ssh_to_openssh_SUITE.erl index a914938c41..f481e9c1ce 100644 --- a/lib/ssh/test/ssh_to_openssh_SUITE.erl +++ b/lib/ssh/test/ssh_to_openssh_SUITE.erl @@ -58,7 +58,8 @@ groups() -> erlang_client_openssh_server_nonexistent_subsystem ]}, {erlang_server, [], [erlang_server_openssh_client_public_key_dsa, - erlang_server_openssh_client_public_key_rsa + erlang_server_openssh_client_public_key_rsa, + erlang_server_openssh_client_renegotiate ]} ]. @@ -386,6 +387,41 @@ erlang_server_openssh_client_public_key_X(Config, PubKeyAlg) -> ssh:stop_daemon(Pid). %%-------------------------------------------------------------------- +%% Test that the Erlang/OTP server can renegotiate with openSSH +erlang_server_openssh_client_renegotiate(Config) -> + PubKeyAlg = ssh_rsa, + SystemDir = proplists:get_value(data_dir, Config), + PrivDir = proplists:get_value(priv_dir, Config), + KnownHosts = filename:join(PrivDir, "known_hosts"), + {Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir}, + {public_key_alg, PubKeyAlg}, + {failfun, fun ssh_test_lib:failfun/2}]), + + ct:sleep(500), + + DataFile = filename:join(PrivDir, "renegotiate_openssh_client.data"), + Data = lists:duplicate(32000, $a), + ok = file:write_file(DataFile, Data), + + Cmd = "ssh -p " ++ integer_to_list(Port) ++ + " -o UserKnownHostsFile=" ++ KnownHosts ++ + " -o RekeyLimit=20K" ++ + " " ++ Host ++ " < " ++ DataFile, + OpenSsh = ssh_test_lib:open_port({spawn, Cmd}), + + Expect = fun({data,R}) -> + try lists:prefix(binary_to_list(R), Data) + catch + _:_ -> false + end; + (_) -> + false + end, + + ssh_test_lib:rcv_expected(Expect, OpenSsh, ?TIMEOUT), + ssh:stop_daemon(Pid). + +%%-------------------------------------------------------------------- erlang_client_openssh_server_password() -> [{doc, "Test client password option"}]. erlang_client_openssh_server_password(Config) when is_list(Config) -> diff --git a/lib/ssh/vsn.mk b/lib/ssh/vsn.mk index 536e559514..c023429056 100644 --- a/lib/ssh/vsn.mk +++ b/lib/ssh/vsn.mk @@ -1,5 +1,5 @@ #-*-makefile-*- ; force emacs to enter makefile-mode -SSH_VSN = 4.3.4 +SSH_VSN = 4.3.6 APP_VSN = "ssh-$(SSH_VSN)" diff --git a/lib/ssl/test/ssl_basic_SUITE.erl b/lib/ssl/test/ssl_basic_SUITE.erl index 322f93b94c..1be43c56c4 100644 --- a/lib/ssl/test/ssl_basic_SUITE.erl +++ b/lib/ssl/test/ssl_basic_SUITE.erl @@ -364,6 +364,16 @@ init_per_testcase(TestCase, Config) when TestCase == psk_cipher_suites; ct:timetrap({seconds, 60}), Config; +init_per_testcase(version_option, Config) -> + ssl_test_lib:ct_log_supported_protocol_versions(Config), + ct:timetrap({seconds, 10}), + Config; + +init_per_testcase(reuse_session, Config) -> + ssl_test_lib:ct_log_supported_protocol_versions(Config), + ct:timetrap({seconds, 10}), + Config; + init_per_testcase(rizzo, Config) -> ssl_test_lib:ct_log_supported_protocol_versions(Config), ct:timetrap({seconds, 40}), diff --git a/lib/stdlib/doc/src/gen_statem.xml b/lib/stdlib/doc/src/gen_statem.xml index 3322571b2c..64267c2af5 100644 --- a/lib/stdlib/doc/src/gen_statem.xml +++ b/lib/stdlib/doc/src/gen_statem.xml @@ -54,7 +54,8 @@ <p> This is a new behavior in Erlang/OTP 19.0. It has been thoroughly reviewed, is stable enough - to be used by at least two heavy OTP applications, and is here to stay. + to be used by at least two heavy OTP applications, + and is here to stay. Depending on user feedback, we do not expect but can find it necessary to make minor not backward compatible changes into Erlang/OTP 20.0. @@ -70,6 +71,7 @@ <item>The state can be any term.</item> <item>Events can be postponed.</item> <item>Events can be self-generated.</item> + <item>Automatic state enter code can be called.</item> <item>A reply can be sent from a later state.</item> <item>There can be multiple <c>sys</c> traceable replies.</item> </list> @@ -125,9 +127,9 @@ erlang:'!' -----> Module:StateName/3 is not regarded as an error but as a valid return from all callback functions. </p> - <marker id="state_function"/> + <marker id="state callback"/> <p> - The "<em>state function</em>" for a specific + The "<em>state callback</em>" for a specific <seealso marker="#type-state">state</seealso> in a <c>gen_statem</c> is the callback function that is called for all events in this state. It is selected depending on which @@ -139,7 +141,7 @@ erlang:'!' -----> Module:StateName/3 When the <seealso marker="#type-callback_mode"><em>callback mode</em></seealso> is <c>state_functions</c>, the state must be an atom and - is used as the state function name; see + is used as the state callback name; see <seealso marker="#Module:StateName/3"><c>Module:StateName/3</c></seealso>. This gathers all code for a specific state in one function as the <c>gen_statem</c> engine @@ -152,7 +154,7 @@ erlang:'!' -----> Module:StateName/3 When the <seealso marker="#type-callback_mode"><em>callback mode</em></seealso> is <c>handle_event_function</c>, the state can be any term - and the state function name is + and the state callback name is <seealso marker="#Module:handle_event/4"><c>Module:handle_event/4</c></seealso>. This makes it easy to branch depending on state or event as you desire. Be careful about which events you handle in which @@ -162,8 +164,8 @@ erlang:'!' -----> Module:StateName/3 <p> The <c>gen_statem</c> enqueues incoming events in order of arrival and presents these to the - <seealso marker="#state_function">state function</seealso> - in that order. The state function can postpone an event + <seealso marker="#state callback">state callback</seealso> + in that order. The state callback can postpone an event so it is not retried in the current state. After a state change the queue restarts with the postponed events. </p> @@ -175,12 +177,12 @@ erlang:'!' -----> Module:StateName/3 to entering a new receive statement. </p> <p> - The <seealso marker="#state_function">state function</seealso> + The <seealso marker="#state callback">state callback</seealso> can insert events using the <seealso marker="#type-action"><c>action()</c></seealso> <c>next_event</c> and such an event is inserted as the next to present - to the state function. That is, as if it is + to the state callback. That is, as if it is the oldest incoming event. A dedicated <seealso marker="#type-event_type"><c>event_type()</c></seealso> <c>internal</c> can be used for such events making them impossible @@ -193,9 +195,19 @@ erlang:'!' -----> Module:StateName/3 <seealso marker="gen_fsm"><c>gen_fsm</c></seealso> to force processing an inserted event before others. </p> + <p> + The <c>gen_statem</c> engine can automatically + make a specialized call to the + <seealso marker="#state callback">state callback</seealso> + whenever a new state is entered; see + <seealso marker="#type-state_enter"><c>state_enter()</c></seealso>. + This is for writing code common to all state entries. + Another way to do it is to insert events at state transitions, + but you have to do so everywhere it is needed. + </p> <note> <p>If you in <c>gen_statem</c>, for example, postpone - an event in one state and then call another state function + an event in one state and then call another state callback of yours, you have not changed states and hence the postponed event is not retried, which is logical but can be confusing. </p> @@ -224,7 +236,7 @@ erlang:'!' -----> Module:StateName/3 The <c>gen_statem</c> process can go into hibernation; see <seealso marker="proc_lib#hibernate/3"><c>proc_lib:hibernate/3</c></seealso>. It is done when a - <seealso marker="#state_function">state function</seealso> or + <seealso marker="#state callback">state callback</seealso> or <seealso marker="#Module:init/1"><c>Module:init/1</c></seealso> specifies <c>hibernate</c> in the returned <seealso marker="#type-action"><c>Actions</c></seealso> @@ -282,7 +294,7 @@ init([]) -> {ok,State,Data}. callback_mode() -> state_functions. -%%% State function(s) +%%% state callback(s) off({call,From}, push, Data) -> %% Go to 'on', increment count and reply @@ -336,7 +348,7 @@ ok <code type="erl"> callback_mode() -> handle_event_function. -%%% State function(s) +%%% state callback(s) handle_event({call,From}, push, off, Data) -> %% Go to 'on', increment count and reply @@ -470,6 +482,10 @@ handle_event(_, _, State, Data) -> <name name="state"/> <desc> <p> + If the + <seealso marker="#type-callback_mode"><em>callback mode</em></seealso> + is <c>handle_event_function</c>, + the state can be any term. After a state change (<c>NextState =/= State</c>), all postponed events are retried. </p> @@ -483,6 +499,8 @@ handle_event(_, _, State, Data) -> <seealso marker="#type-callback_mode"><em>callback mode</em></seealso> is <c>state_functions</c>, the state must be of this type. + After a state change (<c>NextState =/= State</c>), + all postponed events are retried. </p> </desc> </datatype> @@ -515,7 +533,22 @@ handle_event(_, _, State, Data) -> Type <c>info</c> originates from regular process messages sent to the <c>gen_statem</c>. Also, the state machine implementation can generate events of types - <c>timeout</c> and <c>internal</c> to itself. + <c>timeout</c>, <c>state_timeout</c>, <c>enter</c>, + and <c>internal</c> to itself. + </p> + </desc> + </datatype> + <datatype> + <name name="callback_mode_result"/> + <desc> + <p> + This is the return type from + <seealso marker="#Module:callback_mode/0"><c>Module:callback_mode/0</c></seealso> + and selects + <seealso marker="#type-callback_mode">callback mode</seealso> + and whether to do + <seealso marker="#type-state_enter">state enter calls</seealso>, + or not. </p> </desc> </datatype> @@ -551,13 +584,58 @@ handle_event(_, _, State, Data) -> </desc> </datatype> <datatype> + <name name="state_enter"/> + <desc> + <p> + If the state machine should use <em>state enter calls</em> + is selected when starting the <c>gen_statem</c> + and after code change using the return value from + <seealso marker="#Module:callback_mode/0"><c>Module:callback_mode/0</c></seealso>. + </p> + <p> + If + <seealso marker="#Module:callback_mode/0"><c>Module:callback_mode/0</c></seealso> + returns a list containing <c>state_enter</c>, + the <c>gen_statem</c> engine will, at every state change, + call the + <seealso marker="#state callback">state callback</seealso> + with arguments <c>(enter, OldState, Data)</c>. + This may look like an event but is really a call + performed after the previous state callback returned + and before any event is delivered to the new state callback. + See + <seealso marker="#Module:StateName/3"><c>Module:StateName/3</c></seealso> + and + <seealso marker="#Module:handle_event/4"><c>Module:handle_event/4</c></seealso>. + </p> + <p> + If + <seealso marker="#Module:callback_mode/0"><c>Module:callback_mode/0</c></seealso> + does not return such a list, no state enter calls are done. + </p> + <p> + If + <seealso marker="#Module:code_change/4"><c>Module:code_change/4</c></seealso> + should transform the state to a state with a different + name it is still regarded as the same state so this + does not cause a state enter call. + </p> + <p> + Note that a state enter call <em>will</em> be done + right before entering the initial state even though this + formally is not a state change. + In this case <c>OldState</c> will be the same as <c>State</c>, + which can not happen for a subsequent state change. + </p> + </desc> + </datatype> + <datatype> <name name="transition_option"/> <desc> <p> Transition options can be set by <seealso marker="#type-action">actions</seealso> - and they modify the following in how - the state transition is done: + and they modify how the state transition is done: </p> <list type="ordered"> <item> @@ -586,27 +664,46 @@ handle_event(_, _, State, Data) -> All events stored with <seealso marker="#type-action"><c>action()</c></seealso> <c>next_event</c> - are inserted in the queue to be processed before - all other events. + are inserted to be processed before the other queued events. + </p> + </item> + <item> + <p> + If the state changes or is the initial state, and + <seealso marker="#type-state_enter"><em>state enter calls</em></seealso> + are used, the <c>gen_statem</c> calls + the new state callback with arguments + <seealso marker="#type-state_enter">(enter, OldState, Data)</seealso>. + Any + <seealso marker="#type-enter_action"><c>actions</c></seealso> + returned from this call are handled as if they were + appended to the actions + returned by the state callback that changed states. </p> </item> <item> <p> - If an + If there are enqueued events the (possibly new) + <seealso marker="#state callback">state callback</seealso> + is called with the oldest enqueued event, + and we start again from the top of this list. + </p> + </item> + <item> + <p> + Timeout timers + <seealso marker="#type-state_timeout"><c>state_timeout()</c></seealso> + and <seealso marker="#type-event_timeout"><c>event_timeout()</c></seealso> - is set through - <seealso marker="#type-action"><c>action()</c></seealso> - <c>timeout</c>, - an event timer can be started or a time-out zero event - can be enqueued. + are handled. This may lead to a time-out zero event + being generated to the + <seealso marker="#state callback">state callback</seealso> + and we start again from the top of this list. </p> </item> <item> <p> - The (possibly new) - <seealso marker="#state_function">state function</seealso> - is called with the oldest enqueued event if there is any, - otherwise the <c>gen_statem</c> goes into <c>receive</c> + Otherwise the <c>gen_statem</c> goes into <c>receive</c> or hibernation (if <seealso marker="#type-hibernate"><c>hibernate()</c></seealso> @@ -614,8 +711,11 @@ handle_event(_, _, State, Data) -> to wait for the next message. In hibernation the next non-system event awakens the <c>gen_statem</c>, or rather the next incoming message awakens the <c>gen_statem</c>, - but if it is a system event - it goes right back into hibernation. + but if it is a system event it goes right back into hibernation. + When a new message arrives the + <seealso marker="#state callback">state callback</seealso> + is called with the corresponding event, + and we start again from the top of this list. </p> </item> </list> @@ -657,34 +757,65 @@ handle_event(_, _, State, Data) -> <seealso marker="#type-event_type"><c>event_type()</c></seealso> <c>timeout</c> after this time (in milliseconds) unless another - event arrives in which case this time-out is cancelled. - Notice that a retried or inserted event - counts like a new in this respect. + event arrives or has arrived + in which case this time-out is cancelled. + Note that a retried, inserted or state time-out zero + events counts as arrived. </p> <p> If the value is <c>infinity</c>, no timer is started, as - it never triggers anyway. + it never would trigger anyway. </p> <p> - If the value is <c>0</c>, the time-out event is immediately enqueued - unless there already are enqueued events, as the - time-out is then immediately cancelled. - This is a feature ensuring that a time-out <c>0</c> event - is processed before any not yet received external event. + If the value is <c>0</c> no timer is actually started, + instead the the time-out event is enqueued to ensure + that it gets processed before any not yet + received external event. </p> <p> - Notice that it is not possible or needed to cancel this time-out, + Note that it is not possible or needed to cancel this time-out, as it is cancelled automatically by any other event. </p> </desc> </datatype> <datatype> + <name name="state_timeout"/> + <desc> + <p> + Generates an event of + <seealso marker="#type-event_type"><c>event_type()</c></seealso> + <c>state_timeout</c> + after this time (in milliseconds) unless the <c>gen_statem</c> + changes states (<c>NewState =/= OldState</c>) + which case this time-out is cancelled. + </p> + <p> + If the value is <c>infinity</c>, no timer is started, as + it never would trigger anyway. + </p> + <p> + If the value is <c>0</c> no timer is actually started, + instead the the time-out event is enqueued to ensure + that it gets processed before any not yet + received external event. + </p> + <p> + Setting this timer while it is running will restart it with + the new time-out value. Therefore it is possible to cancel + this timeout by setting it to <c>infinity</c>. + </p> + </desc> + </datatype> + <datatype> <name name="action"/> <desc> <p> These state transition actions can be invoked by returning them from the - <seealso marker="#state_function">state function</seealso>, from + <seealso marker="#state callback">state callback</seealso> + when it is called with an + <seealso marker="#type-event_type">event</seealso>, + from <seealso marker="#Module:init/1"><c>Module:init/1</c></seealso> or by giving them to <seealso marker="#enter_loop/5"><c>enter_loop/5,6</c></seealso>. @@ -698,8 +829,8 @@ handle_event(_, _, State, Data) -> override any previous of the same type, so the last in the containing list wins. For example, the last - <seealso marker="#type-event_timeout"><c>event_timeout()</c></seealso> - overrides any other <c>event_timeout()</c> in the list. + <seealso marker="#type-postpone"><c>postpone()</c></seealso> + overrides any previous <c>postpone()</c> in the list. </p> <taglist> <tag><c>postpone</c></tag> @@ -716,6 +847,53 @@ handle_event(_, _, State, Data) -> as there is no event to postpone in those cases. </p> </item> + <tag><c>next_event</c></tag> + <item> + <p> + Stores the specified <c><anno>EventType</anno></c> + and <c><anno>EventContent</anno></c> for insertion after all + actions have been executed. + </p> + <p> + The stored events are inserted in the queue as the next to process + before any already queued events. The order of these stored events + is preserved, so the first <c>next_event</c> in the containing + list becomes the first to process. + </p> + <p> + An event of type + <seealso marker="#type-event_type"><c>internal</c></seealso> + is to be used when you want to reliably distinguish + an event inserted this way from any external event. + </p> + </item> + </taglist> + </desc> + </datatype> + <datatype> + <name name="enter_action"/> + <desc> + <p> + These state transition actions can be invoked by + returning them from the + <seealso marker="#state callback">state callback</seealso>, from + <seealso marker="#Module:init/1"><c>Module:init/1</c></seealso> + or by giving them to + <seealso marker="#enter_loop/5"><c>enter_loop/5,6</c></seealso>. + </p> + <p> + Actions are executed in the containing list order. + </p> + <p> + Actions that set + <seealso marker="#type-transition_option">transition options</seealso> + override any previous of the same type, + so the last in the containing list wins. + For example, the last + <seealso marker="#type-event_timeout"><c>event_timeout()</c></seealso> + overrides any previous <c>event_timeout()</c> in the list. + </p> + <taglist> <tag><c>hibernate</c></tag> <item> <p> @@ -731,7 +909,7 @@ handle_event(_, _, State, Data) -> Short for <c>{timeout,Timeout,Timeout}</c>, that is, the time-out message is the time-out time. This form exists to make the - <seealso marker="#state_function">state function</seealso> + <seealso marker="#state callback">state callback</seealso> return value <c>{next_state,NextState,NewData,Timeout}</c> allowed like for <c>gen_fsm</c>'s <seealso marker="gen_fsm#Module:StateName/2"><c>Module:StateName/2</c></seealso>. @@ -746,30 +924,13 @@ handle_event(_, _, State, Data) -> to <c><anno>Time</anno></c> with <c><anno>EventContent</anno></c>. </p> </item> - <tag><c>reply_action()</c></tag> - <item> - <p> - Replies to a caller. - </p> - </item> - <tag><c>next_event</c></tag> + <tag><c>state_timeout</c></tag> <item> <p> - Stores the specified <c><anno>EventType</anno></c> - and <c><anno>EventContent</anno></c> for insertion after all - actions have been executed. - </p> - <p> - The stored events are inserted in the queue as the next to process - before any already queued events. The order of these stored events - is preserved, so the first <c>next_event</c> in the containing - list becomes the first to process. - </p> - <p> - An event of type - <seealso marker="#type-event_type"><c>internal</c></seealso> - is to be used when you want to reliably distinguish - an event inserted this way from any external event. + Sets the + <seealso marker="#type-transition_option"><c>transition_option()</c></seealso> + <seealso marker="#type-state_timeout"><c>state_timeout()</c></seealso> + to <c><anno>Time</anno></c> with <c><anno>EventContent</anno></c>. </p> </item> </taglist> @@ -779,39 +940,70 @@ handle_event(_, _, State, Data) -> <name name="reply_action"/> <desc> <p> - Replies to a caller waiting for a reply in + This state transition action can be invoked by + returning it from the + <seealso marker="#state callback">state callback</seealso>, from + <seealso marker="#Module:init/1"><c>Module:init/1</c></seealso> + or by giving it to + <seealso marker="#enter_loop/5"><c>enter_loop/5,6</c></seealso>. + </p> + <p> + It replies to a caller waiting for a reply in <seealso marker="#call/2"><c>call/2</c></seealso>. <c><anno>From</anno></c> must be the term from argument <seealso marker="#type-event_type"><c>{call,<anno>From</anno>}</c></seealso> - to the - <seealso marker="#state_function">state function</seealso>. + in a call to a + <seealso marker="#state callback">state callback</seealso>. + </p> + <p> + Note that using this action from + <seealso marker="#Module:init/1"><c>Module:init/1</c></seealso> + or + <seealso marker="#enter_loop/5"><c>enter_loop/5,6</c></seealso> + would be weird on the border of whichcraft + since there has been no earlier call to a + <seealso marker="#state callback">state callback</seealso> + in this server. </p> </desc> </datatype> <datatype> - <name name="state_function_result"/> + <name name="state_enter_result"/> <desc> + <p> + <c><anno>State</anno></c> is the current state + and it can not be changed since the state callback + was called with a + <seealso marker="#type-state_enter"><em>state enter call</em></seealso>. + </p> <taglist> <tag><c>next_state</c></tag> <item> <p> The <c>gen_statem</c> does a state transition to - <c><anno>NextStateName</anno></c> - (which can be the same as the current state), + <c><anno>State</anno></c>, which has to be + the current state, sets <c><anno>NewData</anno></c>, and executes all <c><anno>Actions</anno></c>. </p> </item> </taglist> - <p> - All these terms are tuples or atoms and this property - will hold in any future version of <c>gen_statem</c>. - </p> </desc> </datatype> <datatype> - <name name="handle_event_result"/> + <name name="event_handler_result"/> <desc> + <p> + <c><anno>StateType</anno></c> is + <seealso marker="#type-state_name"><c>state_name()</c></seealso> + if + <seealso marker="#type-callback_mode"><em>callback mode</em></seealso> + is <c>state_functions</c>, or + <seealso marker="#type-state"><c>state()</c></seealso> + if + <seealso marker="#type-callback_mode"><em>callback mode</em></seealso> + is <c>handle_event_function</c>. + </p> <taglist> <tag><c>next_state</c></tag> <item> @@ -824,35 +1016,21 @@ handle_event(_, _, State, Data) -> </p> </item> </taglist> - <p> - All these terms are tuples or atoms and this property - will hold in any future version of <c>gen_statem</c>. - </p> </desc> </datatype> <datatype> - <name name="common_state_callback_result"/> + <name name="state_callback_result"/> <desc> + <p> + <c><anno>ActionType</anno></c> is + <seealso marker="#type-enter_action"><c>enter_action()</c></seealso> + if the state callback was called with a + <seealso marker="#type-state_enter"><em>state enter call</em></seealso> + and + <seealso marker="#type-action"><c>action()</c></seealso> + if the state callback was called with an event. + </p> <taglist> - <tag><c>stop</c></tag> - <item> - <p> - Terminates the <c>gen_statem</c> by calling - <seealso marker="#Module:terminate/3"><c>Module:terminate/3</c></seealso> - with <c>Reason</c> and - <c><anno>NewData</anno></c>, if specified. - </p> - </item> - <tag><c>stop_and_reply</c></tag> - <item> - <p> - Sends all <c><anno>Replies</anno></c>, - then terminates the <c>gen_statem</c> by calling - <seealso marker="#Module:terminate/3"><c>Module:terminate/3</c></seealso> - with <c>Reason</c> and - <c><anno>NewData</anno></c>, if specified. - </p> - </item> <tag><c>keep_state</c></tag> <item> <p> @@ -875,6 +1053,25 @@ handle_event(_, _, State, Data) -> <c>{next_state,CurrentState,CurrentData,<anno>Actions</anno>}</c>. </p> </item> + <tag><c>stop</c></tag> + <item> + <p> + Terminates the <c>gen_statem</c> by calling + <seealso marker="#Module:terminate/3"><c>Module:terminate/3</c></seealso> + with <c>Reason</c> and + <c><anno>NewData</anno></c>, if specified. + </p> + </item> + <tag><c>stop_and_reply</c></tag> + <item> + <p> + Sends all <c><anno>Replies</anno></c>, + then terminates the <c>gen_statem</c> by calling + <seealso marker="#Module:terminate/3"><c>Module:terminate/3</c></seealso> + with <c>Reason</c> and + <c><anno>NewData</anno></c>, if specified. + </p> + </item> </taglist> <p> All these terms are tuples or atoms and this property @@ -896,14 +1093,14 @@ handle_event(_, _, State, Data) -> by sending a request and waiting until its reply arrives. The <c>gen_statem</c> calls the - <seealso marker="#state_function">state function</seealso> with + <seealso marker="#state callback">state callback</seealso> with <seealso marker="#type-event_type"><c>event_type()</c></seealso> <c>{call,From}</c> and event content <c><anno>Request</anno></c>. </p> <p> A <c><anno>Reply</anno></c> is generated when a - <seealso marker="#state_function">state function</seealso> + <seealso marker="#state callback">state callback</seealso> returns with <c>{reply,From,<anno>Reply</anno>}</c> as one <seealso marker="#type-action"><c>action()</c></seealso>, @@ -919,18 +1116,40 @@ handle_event(_, _, State, Data) -> </p> <note> <p> - For <c><anno>Timeout</anno> =/= infinity</c>, + For <c><anno>Timeout</anno> < infinity</c>, to avoid getting a late reply in the caller's - inbox, this function spawns a proxy process that + inbox if the caller should catch exceptions, + this function spawns a proxy process that does the call. A late reply gets delivered to the dead proxy process, hence gets discarded. This is less efficient than using - <c><anno>Timeout</anno> =:= infinity</c>. + <c><anno>Timeout</anno> == infinity</c>. </p> </note> <p> - The call can fail, for example, if the <c>gen_statem</c> dies - before or during this function call. + <c><anno>Timeout</anno></c> can also be a tuple + <c>{clean_timeout,<anno>T</anno>}</c> or + <c>{dirty_timeout,<anno>T</anno>}</c>, where + <c><anno>T</anno></c> is the timeout time. + <c>{clean_timeout,<anno>T</anno>}</c> works like + just <c>T</c> described in the note above + and uses a proxy process for <c>T < infinity</c>, + while <c>{dirty_timeout,<anno>T</anno>}</c> + bypasses the proxy process which is more lightweight. + </p> + <note> + <p> + If you combine catching exceptions from this function + with <c>{dirty_timeout,<anno>T</anno>}</c> + to avoid that the calling process dies when the call + times out, you will have to be prepared to handle + a late reply. + So why not just allow the calling process to die? + </p> + </note> + <p> + The call can also fail, for example, if the <c>gen_statem</c> + dies before or during this function call. </p> </desc> </func> @@ -946,7 +1165,7 @@ handle_event(_, _, State, Data) -> ignoring if the destination node or <c>gen_statem</c> does not exist. The <c>gen_statem</c> calls the - <seealso marker="#state_function">state function</seealso> with + <seealso marker="#state callback">state callback</seealso> with <seealso marker="#type-event_type"><c>event_type()</c></seealso> <c>cast</c> and event content <c><anno>Msg</anno></c>. @@ -1060,17 +1279,18 @@ handle_event(_, _, State, Data) -> <seealso marker="#call/2"><c>call/2</c></seealso> when the reply cannot be defined in the return value of a - <seealso marker="#state_function">state function</seealso>. + <seealso marker="#state callback">state callback</seealso>. </p> <p> <c><anno>From</anno></c> must be the term from argument <seealso marker="#type-event_type"><c>{call,<anno>From</anno>}</c></seealso> to the - <seealso marker="#state_function">state function</seealso>. - <c><anno>From</anno></c> and <c><anno>Reply</anno></c> - can also be specified using a - <seealso marker="#type-reply_action"><c>reply_action()</c></seealso> - and multiple replies with a list of them. + <seealso marker="#state callback">state callback</seealso>. + A reply or multiple replies canalso be sent + using one or several + <seealso marker="#type-reply_action"><c>reply_action()</c></seealso>s + from a + <seealso marker="#state callback">state callback</seealso>. </p> <note> <p> @@ -1266,7 +1486,9 @@ handle_event(_, _, State, Data) -> <type> <v> CallbackMode = - <seealso marker="#type-callback_mode">callback_mode()</seealso> + <seealso marker="#type-callback_mode">callback_mode()</seealso> | + [ <seealso marker="#type-callback_mode">callback_mode()</seealso> + | <seealso marker="#type-state_enter">state_enter()</seealso> ] </v> </type> <desc> @@ -1278,8 +1500,9 @@ handle_event(_, _, State, Data) -> for efficiency reasons, so this function is only called once after server start and after code change, but before the first - <seealso marker="#state_function">state function</seealso> - is called. More occasions may be added in future versions + <seealso marker="#state callback">state callback</seealso> + in the current code version is called. + More occasions may be added in future versions of <c>gen_statem</c>. </p> <p> @@ -1291,12 +1514,18 @@ handle_event(_, _, State, Data) -> <seealso marker="#Module:code_change/4"><c>Module:code_change/4</c></seealso> returns. </p> + <p> + The <c>CallbackMode</c> is either just + <seealso marker="#type-callback_mode"><c>callback_mode()</c></seealso> + or a list containing + <seealso marker="#type-callback_mode"><c>callback_mode()</c></seealso> + and possibly the atom + <seealso marker="#type-state_enter"><c>state_enter</c></seealso>. + </p> <note> <p> - If this function's body does not consist of solely one of two - possible - <seealso marker="#type-callback_mode">atoms</seealso> - the callback module is doing something strange. + If this function's body does not return an inline constant + value the callback module is doing something strange. </p> </note> </desc> @@ -1416,7 +1645,7 @@ handle_event(_, _, State, Data) -> The <seealso marker="#type-action"><c>Actions</c></seealso> are executed when entering the first <seealso marker="#type-state">state</seealso> just as for a - <seealso marker="#state_function">state function</seealso>. + <seealso marker="#state callback">state callback</seealso>. </p> <p> If the initialization fails, @@ -1512,7 +1741,8 @@ handle_event(_, _, State, Data) -> </p> <p> The function is to return <c>Status</c>, a term that - changes the details of the current state and status of + contains the appropriate details + of the current state and status of the <c>gen_statem</c>. There are no restrictions on the form <c>Status</c> can take, but for the <seealso marker="sys#get_status/1"><c>sys:get_status/1,2</c></seealso> @@ -1536,11 +1766,17 @@ handle_event(_, _, State, Data) -> </func> <func> + <name>Module:StateName(enter, OldState, Data) -> + StateEnterResult(StateName) + </name> <name>Module:StateName(EventType, EventContent, Data) -> StateFunctionResult </name> - <name>Module:handle_event(EventType, EventContent, - State, Data) -> HandleEventResult + <name>Module:handle_event(enter, OldState, State, Data) -> + StateEnterResult + </name> + <name>Module:handle_event(EventType, EventContent, State, Data) -> + HandleEventResult </name> <fsummary>Handle an event.</fsummary> <type> @@ -1558,12 +1794,20 @@ handle_event(_, _, State, Data) -> <seealso marker="#type-data">data()</seealso> </v> <v> + StateEnterResult(StateName) = + <seealso marker="#type-state_enter_result">state_enter_result(StateName)</seealso> + </v> + <v> StateFunctionResult = - <seealso marker="#type-state_function_result">state_function_result()</seealso> + <seealso marker="#type-event_handler_result">event_handler_result</seealso>(<seealso marker="#type-state_name">state_name()</seealso>) + </v> + <v> + StateEnterResult = + <seealso marker="#type-state_enter_result">state_enter_result</seealso>(<seealso marker="#type-state">state()</seealso>) </v> <v> HandleEventResult = - <seealso marker="#type-handle_event_result">handle_event_result()</seealso> + <seealso marker="#type-event_handler_result">event_handler_result</seealso>(<seealso marker="#type-state">state()</seealso>) </v> </type> <desc> @@ -1582,7 +1826,7 @@ handle_event(_, _, State, Data) -> <seealso marker="#type-event_type"><c>{call,From}</c></seealso>, the caller waits for a reply. The reply can be sent from this or from any other - <seealso marker="#state_function">state function</seealso> + <seealso marker="#state callback">state callback</seealso> by returning with <c>{reply,From,Reply}</c> in <seealso marker="#type-action"><c>Actions</c></seealso>, in <seealso marker="#type-reply_action"><c>Replies</c></seealso>, @@ -1606,6 +1850,24 @@ handle_event(_, _, State, Data) -> see <seealso marker="#type-action"><c>action()</c></seealso>. </p> <p> + When the <c>gen_statem</c> runs with + <seealso marker="#type-state_enter">state enter calls</seealso>, + these functions are also called with arguments + <c>(enter, OldState, ...)</c> whenever the state changes. + In this case there are some restrictions on the + <seealso marker="#type-enter_action">actions</seealso> + that may be returned: + <seealso marker="#type-postpone"><c>postpone()</c></seealso> + and + <seealso marker="#type-action"><c>{next_event,_,_}</c></seealso> + are not allowed. + You may also not change states from this call. + Should you return <c>{next_state,NextState, ...}</c> + with <c>NextState =/= State</c> the <c>gen_statem</c> crashes. + You are advised to use <c>{keep_state,...}</c> or + <c>keep_state_and_data</c>. + </p> + <p> Note the fact that you can use <seealso marker="erts:erlang#throw/1"><c>throw</c></seealso> to return the result, which can be useful. diff --git a/lib/stdlib/src/gen_statem.erl b/lib/stdlib/src/gen_statem.erl index 3b3477b282..17d1ebecec 100644 --- a/lib/stdlib/src/gen_statem.erl +++ b/lib/stdlib/src/gen_statem.erl @@ -44,15 +44,20 @@ -export( [wakeup_from_hibernate/3]). -%% Type exports for templates +%% Type exports for templates and callback modules -export_type( [event_type/0, - callback_mode/0, + init_result/0, + callback_mode_result/0, state_function_result/0, handle_event_result/0, + state_enter_result/1, + event_handler_result/1, + reply_action/0, + enter_action/0, action/0]). -%% Fix problem for doc build +%% Type that is exported just to be documented -export_type([transition_option/0]). %%%========================================================================== @@ -63,7 +68,7 @@ {To :: pid(), Tag :: term()}. % Reply-to specifier for call -type state() :: - state_name() | % For StateName/3 callback functios + state_name() | % For StateName/3 callback functions term(). % For handle_event/4 callback function -type state_name() :: atom(). @@ -72,9 +77,12 @@ -type event_type() :: {'call',From :: from()} | 'cast' | - 'info' | 'timeout' | 'internal'. + 'info' | 'timeout' | 'state_timeout' | 'internal'. +-type callback_mode_result() :: + callback_mode() | [callback_mode() | state_enter()]. -type callback_mode() :: 'state_functions' | 'handle_event_function'. +-type state_enter() :: 'state_enter'. -type transition_option() :: postpone() | hibernate() | event_timeout(). @@ -89,6 +97,10 @@ %% Generate a ('timeout', EventContent, ...) event after Time %% unless some other event is delivered Time :: timeout(). +-type state_timeout() :: + %% Generate a ('state_timeout', EventContent, ...) event after Time + %% unless the state is changed + Time :: timeout(). -type action() :: %% During a state change: @@ -108,44 +120,67 @@ 'postpone' | % Set the postpone option {'postpone', Postpone :: postpone()} | %% + %% All 'next_event' events are kept in a list and then + %% inserted at state changes so the first in the + %% action() list is the first to be delivered. + {'next_event', % Insert event as the next to handle + EventType :: event_type(), + EventContent :: term()} | + enter_action(). +-type enter_action() :: 'hibernate' | % Set the hibernate option {'hibernate', Hibernate :: hibernate()} | %% (Timeout :: event_timeout()) | % {timeout,Timeout} - {'timeout', % Set the event timeout option + {'timeout', % Set the event_timeout option Time :: event_timeout(), EventContent :: term()} | + {'state_timeout', % Set the state_timeout option + Time :: state_timeout(), EventContent :: term()} | %% - reply_action() | - %% - %% All 'next_event' events are kept in a list and then - %% inserted at state changes so the first in the - %% action() list is the first to be delivered. - {'next_event', % Insert event as the next to handle - EventType :: event_type(), - EventContent :: term()}. + reply_action(). -type reply_action() :: {'reply', % Reply to a caller From :: from(), Reply :: term()}. +-type init_result() :: + {ok, state(), data()} | + {ok, state(), data(), [action()] | action()} | + 'ignore' | + {'stop', Reason :: term()}. + +%% Old, not advertised -type state_function_result() :: - {'next_state', % {next_state,NextStateName,NewData,[]} - NextStateName :: state_name(), + event_handler_result(state_name()). +-type handle_event_result() :: + event_handler_result(state()). +%% +-type state_enter_result(StateType) :: + {'next_state', % {next_state,NextState,NewData,[]} + State :: StateType, NewData :: data()} | {'next_state', % State transition, maybe to the same state - NextStateName :: state_name(), + State :: StateType, NewData :: data(), - Actions :: [action()] | action()} | - common_state_callback_result(). --type handle_event_result() :: + Actions :: [enter_action()] | enter_action()} | + state_callback_result(enter_action()). +-type event_handler_result(StateType) :: {'next_state', % {next_state,NextState,NewData,[]} - NextState :: state(), + NextState :: StateType, NewData :: data()} | {'next_state', % State transition, maybe to the same state - NextState :: state(), + NextState :: StateType, NewData :: data(), Actions :: [action()] | action()} | - common_state_callback_result(). --type common_state_callback_result() :: + state_callback_result(action()). +-type state_callback_result(ActionType) :: + {'keep_state', % {keep_state,NewData,[]} + NewData :: data()} | + {'keep_state', % Keep state, change data + NewData :: data(), + Actions :: [ActionType] | ActionType} | + 'keep_state_and_data' | % {keep_state_and_data,[]} + {'keep_state_and_data', % Keep state and data -> only actions + Actions :: [ActionType] | ActionType} | 'stop' | % {stop,normal} {'stop', % Stop the server Reason :: term()} | @@ -158,32 +193,20 @@ {'stop_and_reply', % Reply then stop the server Reason :: term(), Replies :: [reply_action()] | reply_action(), - NewData :: data()} | - {'keep_state', % {keep_state,NewData,[]} - NewData :: data()} | - {'keep_state', % Keep state, change data - NewData :: data(), - Actions :: [action()] | action()} | - 'keep_state_and_data' | % {keep_state_and_data,[]} - {'keep_state_and_data', % Keep state and data -> only actions - Actions :: [action()] | action()}. + NewData :: data()}. %% The state machine init function. It is called only once and %% the server is not running until this function has returned %% an {ok, ...} tuple. Thereafter the state callbacks are called %% for all events to this server. --callback init(Args :: term()) -> - {ok, state(), data()} | - {ok, state(), data(), [action()] | action()} | - 'ignore' | - {'stop', Reason :: term()}. +-callback init(Args :: term()) -> init_result(). %% This callback shall return the callback mode of the callback module. %% %% It is called once after init/0 and code_change/4 but before %% the first state callback StateName/3 or handle_event/4. --callback callback_mode() -> callback_mode(). +-callback callback_mode() -> callback_mode_result(). %% Example state callback for StateName = 'state_name' %% when callback_mode() =:= state_functions. @@ -194,19 +217,28 @@ %% StateName/3 callbacks and terminate/3, so the state name %% 'terminate' is unusable in this mode. -callback state_name( - event_type(), + 'enter', + OldStateName :: state_name(), + Data :: data()) -> + state_enter_result('state_name'); + (event_type(), EventContent :: term(), Data :: data()) -> - state_function_result(). + event_handler_result(state_name()). %% %% State callback for all states %% when callback_mode() =:= handle_event_function. -callback handle_event( - event_type(), + 'enter', + OldState :: state(), + State :: state(), % Current state + Data :: data()) -> + state_enter_result(state()); + (event_type(), EventContent :: term(), State :: state(), % Current state Data :: data()) -> - handle_event_result(). + event_handler_result(state()). %% Clean up before the server terminates. -callback terminate( @@ -385,53 +417,79 @@ call(ServerRef, Request) -> -spec call( ServerRef :: server_ref(), Request :: term(), - Timeout :: timeout()) -> + Timeout :: + timeout() | + {'clean_timeout',T :: timeout()} | + {'dirty_timeout',T :: timeout()}) -> Reply :: term(). -call(ServerRef, Request, infinity) -> - try gen:call(ServerRef, '$gen_call', Request, infinity) of - {ok,Reply} -> - Reply - catch - Class:Reason -> - erlang:raise( - Class, - {Reason,{?MODULE,call,[ServerRef,Request,infinity]}}, - erlang:get_stacktrace()) - end; call(ServerRef, Request, Timeout) -> - %% Call server through proxy process to dodge any late reply - Ref = make_ref(), - Self = self(), - Pid = spawn( - fun () -> - Self ! - try gen:call( - ServerRef, '$gen_call', Request, Timeout) of - Result -> - {Ref,Result} - catch Class:Reason -> - {Ref,Class,Reason,erlang:get_stacktrace()} - end - end), - Mref = monitor(process, Pid), - receive - {Ref,Result} -> - demonitor(Mref, [flush]), - case Result of + case parse_timeout(Timeout) of + {dirty_timeout,T} -> + try gen:call(ServerRef, '$gen_call', Request, T) of {ok,Reply} -> Reply + catch + Class:Reason -> + erlang:raise( + Class, + {Reason,{?MODULE,call,[ServerRef,Request,Timeout]}}, + erlang:get_stacktrace()) + end; + {clean_timeout,T} -> + %% Call server through proxy process to dodge any late reply + Ref = make_ref(), + Self = self(), + Pid = spawn( + fun () -> + Self ! + try gen:call( + ServerRef, '$gen_call', Request, T) of + Result -> + {Ref,Result} + catch Class:Reason -> + {Ref,Class,Reason, + erlang:get_stacktrace()} + end + end), + Mref = monitor(process, Pid), + receive + {Ref,Result} -> + demonitor(Mref, [flush]), + case Result of + {ok,Reply} -> + Reply + end; + {Ref,Class,Reason,Stacktrace} -> + demonitor(Mref, [flush]), + erlang:raise( + Class, + {Reason,{?MODULE,call,[ServerRef,Request,Timeout]}}, + Stacktrace); + {'DOWN',Mref,_,_,Reason} -> + %% There is a theoretical possibility that the + %% proxy process gets killed between try--of and ! + %% so this clause is in case of that + exit(Reason) end; - {Ref,Class,Reason,Stacktrace} -> - demonitor(Mref, [flush]), - erlang:raise( - Class, - {Reason,{?MODULE,call,[ServerRef,Request,Timeout]}}, - Stacktrace); - {'DOWN',Mref,_,_,Reason} -> - %% There is a theoretical possibility that the - %% proxy process gets killed between try--of and ! - %% so this clause is in case of that - exit(Reason) + Error when is_atom(Error) -> + erlang:error(Error, [ServerRef,Request,Timeout]) + end. + +parse_timeout(Timeout) -> + case Timeout of + {clean_timeout,infinity} -> + {dirty_timeout,infinity}; + {clean_timeout,_} -> + Timeout; + {dirty_timeout,_} -> + Timeout; + {_,_} -> + %% Be nice and throw a badarg for speling errors + badarg; + infinity -> + {dirty_timeout,infinity}; + T -> + {clean_timeout,T} end. %% Reply from a state machine callback to whom awaits in call/2 @@ -517,8 +575,9 @@ enter(Module, Opts, State, Data, Server, Actions, Parent) -> %% The values should already have been type checked Name = gen:get_proc_name(Server), Debug = gen:debug_options(Name, Opts), - P = Events = [], - Event = {internal,initial_state}, + Events = [], + P = [], + Event = {internal,init_state}, %% We enforce {postpone,false} to ensure that %% our fake Event gets discarded, thought it might get logged NewActions = @@ -530,19 +589,31 @@ enter(Module, Opts, State, Data, Server, Actions, Parent) -> end, S = #{ callback_mode => undefined, + state_enter => false, module => Module, name => Name, - %% All fields below will be replaced according to the arguments to - %% loop_event_actions/10 when it finally loops back to loop/3 state => State, data => Data, postponed => P, - hibernate => false, - timer => undefined}, + %% The rest of the fields are set from to the arguments to + %% loop_event_actions/9 when it finally loops back to loop/3 + %% in loop_events_done/9 + %% + %% Marker for initial state, cleared immediately when used + init_state => true + }, NewDebug = sys_debug(Debug, S, State, {enter,Event,State}), - loop_event_actions( - Parent, NewDebug, S, Events, - State, Data, P, Event, State, NewActions). + case call_callback_mode(S) of + {ok,NewS} -> + StateTimer = undefined, + loop_event_actions( + Parent, NewDebug, NewS, StateTimer, + Events, Event, State, Data, NewActions); + {Class,Reason,Stacktrace} -> + terminate( + Class, Reason, Stacktrace, + NewDebug, S, [Event|Events]) + end. %%%========================================================================== %%% gen callbacks @@ -563,7 +634,9 @@ init_it(Starter, Parent, ServerRef, Module, Args, Opts) -> proc_lib:init_ack(Starter, {error,Reason}), error_info( Class, Reason, Stacktrace, - #{name => Name, callback_mode => undefined}, + #{name => Name, + callback_mode => undefined, + state_enter => false}, [], [], undefined), erlang:raise(Class, Reason, Stacktrace) end. @@ -594,7 +667,9 @@ init_result(Starter, Parent, ServerRef, Module, Result, Opts) -> proc_lib:init_ack(Starter, {error,Error}), error_info( error, Error, ?STACKTRACE(), - #{name => Name, callback_mode => undefined}, + #{name => Name, + callback_mode => undefined, + state_enter => false}, [], [], undefined), exit(Error) end. @@ -605,12 +680,10 @@ init_result(Starter, Parent, ServerRef, Module, Result, Opts) -> system_continue(Parent, Debug, S) -> loop(Parent, Debug, S). -system_terminate( - Reason, _Parent, Debug, - #{state := State, data := Data, postponed := P} = S) -> +system_terminate(Reason, _Parent, Debug, S) -> terminate( exit, Reason, ?STACKTRACE(), - Debug, S, [], State, Data, P). + Debug, S, []). system_code_change( #{module := Module, @@ -647,7 +720,7 @@ system_replace_state( format_status( Opt, [PDict,SysState,Parent,Debug, - #{name := Name, postponed := P, state := State, data := Data} = S]) -> + #{name := Name, postponed := P} = S]) -> Header = gen:format_status_header("Status for state machine", Name), Log = sys:get_debug(log, Debug, []), [{header,Header}, @@ -656,7 +729,7 @@ format_status( {"Parent",Parent}, {"Logged Events",Log}, {"Postponed",P}]} | - case format_status(Opt, PDict, S, State, Data) of + case format_status(Opt, PDict, S) of L when is_list(L) -> L; T -> [T] end]. @@ -732,7 +805,8 @@ loop(Parent, Debug, #{hibernate := Hibernate} = S) -> end. %% Entry point for wakeup_from_hibernate/3 -loop_receive(Parent, Debug, #{timer := Timer} = S) -> +loop_receive( + Parent, Debug, #{timer := Timer, state_timer := StateTimer} = S) -> receive Msg -> case Msg of @@ -743,34 +817,23 @@ loop_receive(Parent, Debug, #{timer := Timer} = S) -> sys:handle_system_msg( Req, Pid, Parent, ?MODULE, Debug, S, Hibernate); {'EXIT',Parent,Reason} = EXIT -> - #{state := State, data := Data, postponed := P} = S, %% EXIT is not a 2-tuple and therefore %% not an event and has no event_type(), %% but this will stand out in the crash report... terminate( - exit, Reason, ?STACKTRACE(), - Debug, S, [EXIT], State, Data, P); - {timeout,Timer,Content} when Timer =/= undefined -> + exit, Reason, ?STACKTRACE(), Debug, S, [EXIT]); + {timeout,Timer,Content} + when Timer =/= undefined -> loop_receive_result( - Parent, Debug, S, {timeout,Content}); + Parent, Debug, S, StateTimer, + {timeout,Content}); + {timeout,StateTimer,Content} + when StateTimer =/= undefined -> + loop_receive_result( + Parent, Debug, S, undefined, + {state_timeout,Content}); _ -> - %% Cancel Timer if running - case Timer of - undefined -> - ok; - _ -> - case erlang:cancel_timer(Timer) of - TimeLeft when is_integer(TimeLeft) -> - ok; - false -> - receive - {timeout,Timer,_} -> - ok - after 0 -> - ok - end - end - end, + cancel_timer(Timer), Event = case Msg of {'$gen_call',From,Request} -> @@ -780,112 +843,185 @@ loop_receive(Parent, Debug, #{timer := Timer} = S) -> _ -> {info,Msg} end, - loop_receive_result(Parent, Debug, S, Event) + loop_receive_result( + Parent, Debug, S, StateTimer, Event) end end. -loop_receive_result( - Parent, Debug, - #{state := State, - data := Data, - postponed := P} = S, - Event) -> - %% The engine state map S is now dismantled - %% and will not be restored until we return to loop/3. - %% - %% The fields 'callback_mode', 'module', and 'name' are still valid. - %% The fields 'state', 'data', and 'postponed' are held in arguments. - %% The fields 'timer' and 'hibernate' will be recalculated. +loop_receive_result(Parent, Debug, #{state := State} = S, StateTimer, Event) -> + %% The fields 'timer', 'state_timer' and 'hibernate' + %% are now invalid in state map S - they will be recalculated + %% and restored when we return to loop/3 %% NewDebug = sys_debug(Debug, S, State, {in,Event}), %% Here the queue of not yet handled events is created Events = [], Hibernate = false, - loop_event( - Parent, NewDebug, S, Events, State, Data, P, Event, Hibernate). + loop_event(Parent, NewDebug, S, StateTimer, Events, Event, Hibernate). %% Process the event queue, or if it is empty %% loop back to loop/3 to receive a new event loop_events( - Parent, Debug, S, [Event|Events], - State, Data, P, Hibernate, _Timeout) -> + Parent, Debug, S, StateTimeout, + [Event|Events], _Timeout, State, Data, P, Hibernate) -> %% - %% If there was a state timer requested we just ignore that + %% If there was an event timer requested we just ignore that %% since we have events to handle which cancels the timer loop_event( - Parent, Debug, S, Events, State, Data, P, Event, Hibernate); + Parent, Debug, S, StateTimeout, + Events, Event, State, Data, P, Hibernate); loop_events( - Parent, Debug, S, [], - State, Data, P, Hibernate, Timeout) -> + Parent, Debug, S, {state_timeout,Time,EventContent}, + [] = Events, Timeout, State, Data, P, Hibernate) -> + if + Time =:= 0 -> + %% Simulate an immediate timeout + %% so we do not get the timeout message + %% after any received event + %% + %% This faked event will cancel + %& any not yet started event timer + Event = {state_timeout,EventContent}, + StateTimer = undefined, + loop_event( + Parent, Debug, S, StateTimer, + Events, Event, State, Data, P, Hibernate); + true -> + StateTimer = erlang:start_timer(Time, self(), EventContent), + loop_events( + Parent, Debug, S, StateTimer, + Events, Timeout, State, Data, P, Hibernate) + end; +loop_events( + Parent, Debug, S, StateTimer, + [] = Events, Timeout, State, Data, P, Hibernate) -> case Timeout of {timeout,0,EventContent} -> - %% Immediate timeout - simulate it + %% Simulate an immediate timeout %% so we do not get the timeout message %% after any received event + %% + Event = {timeout,EventContent}, loop_event( - Parent, Debug, S, [], - State, Data, P, {timeout,EventContent}, Hibernate); + Parent, Debug, S, StateTimer, + Events, Event, State, Data, P, Hibernate); {timeout,Time,EventContent} -> - %% Actually start a timer Timer = erlang:start_timer(Time, self(), EventContent), loop_events_done( - Parent, Debug, S, Timer, State, Data, P, Hibernate); + Parent, Debug, S, StateTimer, + State, Data, P, Hibernate, Timer); undefined -> - %% No state timeout has been requested + %% No event timeout has been requested Timer = undefined, loop_events_done( - Parent, Debug, S, Timer, State, Data, P, Hibernate) + Parent, Debug, S, StateTimer, + State, Data, P, Hibernate, Timer) end. -%% -loop_events_done(Parent, Debug, S, Timer, State, Data, P, Hibernate) -> + +%% Back to the top +loop_events_done( + Parent, Debug, S, StateTimer, + State, Data, P, Hibernate, Timer) -> NewS = S#{ state := State, data := Data, postponed := P, - hibernate := Hibernate, - timer := Timer}, + hibernate => Hibernate, + timer => Timer, + state_timer => StateTimer}, loop(Parent, Debug, NewS). -loop_event( - Parent, Debug, + + +call_callback_mode(#{module := Module} = S) -> + try Module:callback_mode() of + CallbackMode -> + callback_mode_result(S, CallbackMode) + catch + CallbackMode -> + callback_mode_result(S, CallbackMode); + error:undef -> + %% Process undef to check for the simple mistake + %% of calling a nonexistent state function + %% to make the undef more precise + case erlang:get_stacktrace() of + [{Module,callback_mode,[]=Args,_} + |Stacktrace] -> + {error, + {undef_callback,{Module,callback_mode,Args}}, + Stacktrace}; + Stacktrace -> + {error,undef,Stacktrace} + end; + Class:Reason -> + {Class,Reason,erlang:get_stacktrace()} + end. + +callback_mode_result(S, CallbackMode) -> + case + parse_callback_mode( + if + is_atom(CallbackMode) -> + [CallbackMode]; + true -> + CallbackMode + end, undefined, false) + of + {undefined,_} -> + {error, + {bad_return_from_callback_mode,CallbackMode}, + ?STACKTRACE()}; + {CBMode,StateEnter} -> + {ok, + S#{ + callback_mode := CBMode, + state_enter := StateEnter}} + end. + +parse_callback_mode([], CBMode, StateEnter) -> + {CBMode,StateEnter}; +parse_callback_mode([H|T], CBMode, StateEnter) -> + case callback_mode(H) of + true -> + parse_callback_mode(T, H, StateEnter); + false -> + case H of + state_enter -> + parse_callback_mode(T, CBMode, true); + _ -> + {undefined,StateEnter} + end + end; +parse_callback_mode(_, _CBMode, StateEnter) -> + {undefined,StateEnter}. + +call_state_function( + #{callback_mode := undefined} = S, + Type, Content, State, Data) -> + case call_callback_mode(S) of + {ok,NewS} -> + call_state_function(NewS, Type, Content, State, Data); + Error -> + Error + end; +call_state_function( #{callback_mode := CallbackMode, module := Module} = S, - Events, - State, Data, P, {Type,Content} = Event, Hibernate) -> - %% - %% If Hibernate is true here it can only be - %% because it was set from an event action - %% and we did not go into hibernation since there - %% were events in queue, so we do what the user - %% might depend on i.e collect garbage which - %% would have happened if we actually hibernated - %% and immediately was awakened - Hibernate andalso garbage_collect(), - %% + Type, Content, State, Data) -> try case CallbackMode of - undefined -> - Module:callback_mode(); state_functions -> erlang:apply(Module, State, [Type,Content,Data]); handle_event_function -> Module:handle_event(Type, Content, State, Data) end of - Result when CallbackMode =:= undefined -> - loop_event_callback_mode( - Parent, Debug, S, Events, State, Data, P, Event, Result); Result -> - loop_event_result( - Parent, Debug, S, Events, State, Data, P, Event, Result) + {ok,Result,S} catch - Result when CallbackMode =:= undefined -> - loop_event_callback_mode( - Parent, Debug, S, Events, State, Data, P, Event, Result); Result -> - loop_event_result( - Parent, Debug, S, Events, State, Data, P, Event, Result); + {ok,Result,S}; error:badarg -> case erlang:get_stacktrace() of [{erlang,apply, @@ -895,329 +1031,425 @@ loop_event( when CallbackMode =:= state_functions -> %% We get here e.g if apply fails %% due to State not being an atom - terminate( - error, - {undef_state_function,{Module,State,Args}}, - Stacktrace, - Debug, S, [Event|Events], State, Data, P); + {error, + {undef_state_function,{Module,State,Args}}, + Stacktrace}; Stacktrace -> - terminate( - error, badarg, Stacktrace, - Debug, S, [Event|Events], State, Data, P) + {error,badarg,Stacktrace} end; error:undef -> %% Process undef to check for the simple mistake %% of calling a nonexistent state function %% to make the undef more precise case erlang:get_stacktrace() of - [{Module,callback_mode,[]=Args,_} - |Stacktrace] - when CallbackMode =:= undefined -> - terminate( - error, - {undef_callback,{Module,callback_mode,Args}}, - Stacktrace, - Debug, S, [Event|Events], State, Data, P); [{Module,State,[Type,Content,Data]=Args,_} |Stacktrace] when CallbackMode =:= state_functions -> - terminate( - error, - {undef_state_function,{Module,State,Args}}, - Stacktrace, - Debug, S, [Event|Events], State, Data, P); + {error, + {undef_state_function,{Module,State,Args}}, + Stacktrace}; [{Module,handle_event,[Type,Content,State,Data]=Args,_} |Stacktrace] when CallbackMode =:= handle_event_function -> - terminate( - error, - {undef_state_function,{Module,handle_event,Args}}, - Stacktrace, - Debug, S, [Event|Events], State, Data, P); + {error, + {undef_state_function,{Module,handle_event,Args}}, + Stacktrace}; Stacktrace -> - terminate( - error, undef, Stacktrace, - Debug, S, [Event|Events], State, Data, P) + {error,undef,Stacktrace} end; Class:Reason -> - Stacktrace = erlang:get_stacktrace(), - terminate( - Class, Reason, Stacktrace, - Debug, S, [Event|Events], State, Data, P) + {Class,Reason,erlang:get_stacktrace()} end. -%% Interpret callback_mode() result -loop_event_callback_mode( - Parent, Debug, S, Events, State, Data, P, Event, CallbackMode) -> - case callback_mode(CallbackMode) of - true -> - Hibernate = false, % We have already GC:ed recently - loop_event( - Parent, Debug, - S#{callback_mode := CallbackMode}, - Events, - State, Data, P, Event, Hibernate); - false -> +%% Update S and continue +loop_event( + Parent, Debug, S, StateTimer, + Events, Event, State, Data, P, Hibernate) -> + NewS = + S#{ + state := State, + data := Data, + postponed := P}, + loop_event(Parent, Debug, NewS, StateTimer, Events, Event, Hibernate). + +loop_event( + Parent, Debug, #{state := State, data := Data} = S, StateTimer, + Events, {Type,Content} = Event, Hibernate) -> + %% + %% If Hibernate is true here it can only be + %% because it was set from an event action + %% and we did not go into hibernation since there + %% were events in queue, so we do what the user + %% might rely on i.e collect garbage which + %% would have happened if we actually hibernated + %% and immediately was awakened + Hibernate andalso garbage_collect(), + case call_state_function(S, Type, Content, State, Data) of + {ok,Result,NewS} -> + {NewData,NextState,Actions} = + parse_event_result( + true, Debug, NewS, Result, + Events, Event, State, Data), + loop_event_actions( + Parent, Debug, S, StateTimer, + Events, Event, NextState, NewData, Actions); + {Class,Reason,Stacktrace} -> terminate( - error, - {bad_return_from_callback_mode,CallbackMode}, - ?STACKTRACE(), - Debug, S, [Event|Events], State, Data, P) + Class, Reason, Stacktrace, Debug, S, [Event|Events]) end. %% Interpret all callback return variants -loop_event_result( - Parent, Debug, S, Events, State, Data, P, Event, Result) -> +parse_event_result( + AllowStateChange, Debug, S, Result, Events, Event, State, Data) -> case Result of stop -> terminate( - exit, normal, ?STACKTRACE(), - Debug, S, [Event|Events], State, Data, P); + exit, normal, ?STACKTRACE(), Debug, S, [Event|Events]); {stop,Reason} -> terminate( - exit, Reason, ?STACKTRACE(), - Debug, S, [Event|Events], State, Data, P); + exit, Reason, ?STACKTRACE(), Debug, S, [Event|Events]); {stop,Reason,NewData} -> terminate( exit, Reason, ?STACKTRACE(), - Debug, S, [Event|Events], State, NewData, P); + Debug, S#{data := NewData}, [Event|Events]); {stop_and_reply,Reason,Replies} -> Q = [Event|Events], reply_then_terminate( exit, Reason, ?STACKTRACE(), - Debug, S, Q, State, Data, P, Replies); + Debug, S, Q, Replies); {stop_and_reply,Reason,Replies,NewData} -> Q = [Event|Events], reply_then_terminate( exit, Reason, ?STACKTRACE(), - Debug, S, Q, State, NewData, P, Replies); - {next_state,NextState,NewData} -> - loop_event_actions( - Parent, Debug, S, Events, - State, NewData, P, Event, NextState, []); - {next_state,NextState,NewData,Actions} -> - loop_event_actions( - Parent, Debug, S, Events, - State, NewData, P, Event, NextState, Actions); + Debug, S#{data := NewData}, Q, Replies); + {next_state,State,NewData} -> + {NewData,State,[]}; + {next_state,NextState,NewData} when AllowStateChange -> + {NewData,NextState,[]}; + {next_state,State,NewData,Actions} -> + {NewData,State,Actions}; + {next_state,NextState,NewData,Actions} when AllowStateChange -> + {NewData,NextState,Actions}; {keep_state,NewData} -> - loop_event_actions( - Parent, Debug, S, Events, - State, NewData, P, Event, State, []); + {NewData,State,[]}; {keep_state,NewData,Actions} -> - loop_event_actions( - Parent, Debug, S, Events, - State, NewData, P, Event, State, Actions); + {NewData,State,Actions}; keep_state_and_data -> - loop_event_actions( - Parent, Debug, S, Events, - State, Data, P, Event, State, []); + {Data,State,[]}; {keep_state_and_data,Actions} -> - loop_event_actions( - Parent, Debug, S, Events, - State, Data, P, Event, State, Actions); + {Data,State,Actions}; _ -> terminate( error, {bad_return_from_state_function,Result}, ?STACKTRACE(), - Debug, S, [Event|Events], State, Data, P) + Debug, S, [Event|Events]) end. -loop_event_actions( - Parent, Debug, S, Events, State, NewData, P, Event, NextState, Actions) -> - Postpone = false, % Shall we postpone this event; boolean() +parse_enter_actions( + Debug, S, State, Actions, + Hibernate, Timeout, StateTimeout) -> + Postpone = forbidden, + NextEvents = forbidden, + parse_actions( + Debug, S, State, listify(Actions), + Hibernate, Timeout, StateTimeout, Postpone, NextEvents). + +parse_actions(Debug, S, State, Actions) -> Hibernate = false, Timeout = undefined, + StateTimeout = undefined, + Postpone = false, NextEvents = [], - loop_event_actions( - Parent, Debug, S, Events, State, NewData, P, Event, NextState, - if - is_list(Actions) -> - Actions; - true -> - [Actions] - end, - Postpone, Hibernate, Timeout, NextEvents). + parse_actions( + Debug, S, State, listify(Actions), + Hibernate, Timeout, StateTimeout, Postpone, NextEvents). %% -%% Process all actions -loop_event_actions( - Parent, Debug, S, Events, - State, NewData, P, Event, NextState, [Action|Actions], - Postpone, Hibernate, Timeout, NextEvents) -> +parse_actions( + Debug, _S, _State, [], + Hibernate, Timeout, StateTimeout, Postpone, NextEvents) -> + {ok,Debug,Hibernate,Timeout,StateTimeout,Postpone,NextEvents}; +parse_actions( + Debug, S, State, [Action|Actions], + Hibernate, Timeout, StateTimeout, Postpone, NextEvents) -> case Action of %% Actual actions {reply,From,Reply} -> case from(From) of true -> NewDebug = do_reply(Debug, S, State, From, Reply), - loop_event_actions( - Parent, NewDebug, S, Events, - State, NewData, P, Event, NextState, Actions, - Postpone, Hibernate, Timeout, NextEvents); + parse_actions( + NewDebug, S, State, Actions, + Hibernate, Timeout, StateTimeout, + Postpone, NextEvents); false -> - terminate( - error, - {bad_action_from_state_function,Action}, - ?STACKTRACE(), - Debug, S, [Event|Events], State, NewData, P) - end; - {next_event,Type,Content} -> - case event_type(Type) of - true -> - NewDebug = - sys_debug(Debug, S, State, {in,{Type,Content}}), - loop_event_actions( - Parent, NewDebug, S, Events, - State, NewData, P, Event, NextState, Actions, - Postpone, Hibernate, Timeout, - [{Type,Content}|NextEvents]); - false -> - terminate( - error, - {bad_action_from_state_function,Action}, - ?STACKTRACE(), - Debug, S, [Event|Events], State, NewData, P) + {error, + {bad_action_from_state_function,Action}, + ?STACKTRACE()} end; %% Actions that set options - {postpone,NewPostpone} when is_boolean(NewPostpone) -> - loop_event_actions( - Parent, Debug, S, Events, - State, NewData, P, Event, NextState, Actions, - NewPostpone, Hibernate, Timeout, NextEvents); - {postpone,_} -> - terminate( - error, - {bad_action_from_state_function,Action}, - ?STACKTRACE(), - Debug, S, [Event|Events], State, NewData, P); - postpone -> - loop_event_actions( - Parent, Debug, S, Events, - State, NewData, P, Event, NextState, Actions, - true, Hibernate, Timeout, NextEvents); {hibernate,NewHibernate} when is_boolean(NewHibernate) -> - loop_event_actions( - Parent, Debug, S, Events, - State, NewData, P, Event, NextState, Actions, - Postpone, NewHibernate, Timeout, NextEvents); + parse_actions( + Debug, S, State, Actions, + NewHibernate, Timeout, StateTimeout, Postpone, NextEvents); {hibernate,_} -> - terminate( - error, - {bad_action_from_state_function,Action}, - ?STACKTRACE(), - Debug, S, [Event|Events], State, NewData, P); + {error, + {bad_action_from_state_function,Action}, + ?STACKTRACE()}; hibernate -> - loop_event_actions( - Parent, Debug, S, Events, - State, NewData, P, Event, NextState, Actions, - Postpone, true, Timeout, NextEvents); + parse_actions( + Debug, S, State, Actions, + true, Timeout, StateTimeout, Postpone, NextEvents); + {state_timeout,Time,_} = NewStateTimeout + when is_integer(Time), Time >= 0; + Time =:= infinity -> + parse_actions( + Debug, S, State, Actions, + Hibernate, Timeout, NewStateTimeout, Postpone, NextEvents); + {state_timeout,_,_} -> + {error, + {bad_action_from_state_function,Action}, + ?STACKTRACE()}; {timeout,infinity,_} -> % Clear timer - it will never trigger - loop_event_actions( - Parent, Debug, S, Events, - State, NewData, P, Event, NextState, Actions, - Postpone, Hibernate, undefined, NextEvents); + parse_actions( + Debug, S, State, Actions, + Hibernate, undefined, StateTimeout, Postpone, NextEvents); {timeout,Time,_} = NewTimeout when is_integer(Time), Time >= 0 -> - loop_event_actions( - Parent, Debug, S, Events, - State, NewData, P, Event, NextState, Actions, - Postpone, Hibernate, NewTimeout, NextEvents); + parse_actions( + Debug, S, State, Actions, + Hibernate, NewTimeout, StateTimeout, Postpone, NextEvents); {timeout,_,_} -> - terminate( - error, - {bad_action_from_state_function,Action}, - ?STACKTRACE(), - Debug, S, [Event|Events], State, NewData, P); + {error, + {bad_action_from_state_function,Action}, + ?STACKTRACE()}; infinity -> % Clear timer - it will never trigger - loop_event_actions( - Parent, Debug, S, Events, - State, NewData, P, Event, NextState, Actions, - Postpone, Hibernate, undefined, NextEvents); + parse_actions( + Debug, S, State, Actions, + Hibernate, undefined, StateTimeout, Postpone, NextEvents); Time when is_integer(Time), Time >= 0 -> NewTimeout = {timeout,Time,Time}, - loop_event_actions( - Parent, Debug, S, Events, - State, NewData, P, Event, NextState, Actions, - Postpone, Hibernate, NewTimeout, NextEvents); + parse_actions( + Debug, S, State, Actions, + Hibernate, NewTimeout, StateTimeout, Postpone, NextEvents); + {postpone,NewPostpone} + when is_boolean(NewPostpone), Postpone =/= forbidden -> + parse_actions( + Debug, S, State, Actions, + Hibernate, Timeout, StateTimeout, NewPostpone, NextEvents); + {postpone,_} -> + {error, + {bad_action_from_state_function,Action}, + ?STACKTRACE()}; + postpone when Postpone =/= forbidden -> + parse_actions( + Debug, S, State, Actions, + Hibernate, Timeout, StateTimeout, true, NextEvents); + {next_event,Type,Content} -> + case event_type(Type) of + true when NextEvents =/= forbidden -> + NewDebug = + sys_debug(Debug, S, State, {in,{Type,Content}}), + parse_actions( + NewDebug, S, State, Actions, + Hibernate, Timeout, StateTimeout, + Postpone, [{Type,Content}|NextEvents]); + _ -> + {error, + {bad_action_from_state_function,Action}, + ?STACKTRACE()} + end; _ -> - terminate( - error, - {bad_action_from_state_function,Action}, - ?STACKTRACE(), - Debug, S, [Event|Events], State, NewData, P) - end; -%% -%% End of actions list + {error, + {bad_action_from_state_function,Action}, + ?STACKTRACE()} + end. + loop_event_actions( - Parent, Debug, S, Events, - State, NewData, P0, Event, NextState, [], - Postpone, Hibernate, Timeout, NextEvents) -> + Parent, Debug, + #{state := State, state_enter := StateEnter} = S, StateTimer, + Events, Event, NextState, NewData, Actions) -> + case parse_actions(Debug, S, State, Actions) of + {ok,NewDebug,Hibernate,Timeout,StateTimeout,Postpone,NextEvents} -> + if + StateEnter, NextState =/= State -> + loop_event_enter( + Parent, NewDebug, S, StateTimer, + Events, Event, NextState, NewData, + Hibernate, Timeout, StateTimeout, Postpone, NextEvents); + StateEnter -> + case maps:is_key(init_state, S) of + true -> + %% Avoid infinite loop in initial state + %% with state entry events + NewS = maps:remove(init_state, S), + loop_event_enter( + Parent, NewDebug, NewS, StateTimer, + Events, Event, NextState, NewData, + Hibernate, Timeout, StateTimeout, + Postpone, NextEvents); + false -> + loop_event_result( + Parent, NewDebug, S, StateTimer, + Events, Event, NextState, NewData, + Hibernate, Timeout, StateTimeout, + Postpone, NextEvents) + end; + true -> + loop_event_result( + Parent, NewDebug, S, StateTimer, + Events, Event, NextState, NewData, + Hibernate, Timeout, StateTimeout, Postpone, NextEvents) + end; + {Class,Reason,Stacktrace} -> + terminate( + Class, Reason, Stacktrace, + Debug, S#{data := NewData}, [Event|Events]) + end. + +loop_event_enter( + Parent, Debug, #{state := State} = S, StateTimer, + Events, Event, NextState, NewData, + Hibernate, Timeout, StateTimeout, Postpone, NextEvents) -> + case call_state_function(S, enter, State, NextState, NewData) of + {ok,Result,NewS} -> + {NewerData,_,Actions} = + parse_event_result( + false, Debug, NewS, Result, + Events, Event, NextState, NewData), + loop_event_enter_actions( + Parent, Debug, NewS, StateTimer, + Events, Event, NextState, NewerData, + Hibernate, Timeout, StateTimeout, Postpone, NextEvents, Actions); + {Class,Reason,Stacktrace} -> + terminate( + Class, Reason, Stacktrace, + Debug, S#{state := NextState, data := NewData}, + [Event|Events]) + end. + +loop_event_enter_actions( + Parent, Debug, S, StateTimer, + Events, Event, NextState, NewData, + Hibernate, Timeout, StateTimeout, Postpone, NextEvents, Actions) -> + case + parse_enter_actions( + Debug, S, NextState, Actions, + Hibernate, Timeout, StateTimeout) + of + {ok,NewDebug,NewHibernate,NewTimeout,NewStateTimeout,_,_} -> + loop_event_result( + Parent, NewDebug, S, StateTimer, + Events, Event, NextState, NewData, + NewHibernate, NewTimeout, NewStateTimeout, Postpone, NextEvents); + {Class,Reason,Stacktrace} -> + terminate( + Class, Reason, Stacktrace, + Debug, S#{state := NextState, data := NewData}, + [Event|Events]) + end. + +loop_event_result( + Parent, Debug, + #{state := State, postponed := P_0} = S, StateTimer, + Events, Event, NextState, NewData, + Hibernate, Timeout, StateTimeout, Postpone, NextEvents) -> %% %% All options have been collected and next_events are buffered. %% Do the actual state transition. %% - P1 = % Move current event to postponed if Postpone + NewStateTimeout = + case StateTimeout of + {state_timeout,Time,_} -> + %% New timeout -> cancel timer + case StateTimer of + {state_timeout,_,_} -> + ok; + _ -> + cancel_timer(StateTimer) + end, + case Time of + infinity -> + undefined; + _ -> + StateTimeout + end; + undefined when NextState =/= State -> + %% State change -> cancel timer + case StateTimer of + {state_timeout,_,_} -> + ok; + _ -> + cancel_timer(StateTimer) + end, + undefined; + undefined -> + StateTimer + end, + %% + P_1 = % Move current event to postponed if Postpone case Postpone of true -> - [Event|P0]; + [Event|P_0]; false -> - P0 + P_0 end, - {Q2,P} = % Move all postponed events to queue if state change + {Events_1,NewP} = % Move all postponed events to queue if state change if NextState =:= State -> - {Events,P1}; + {Events,P_1}; true -> - {lists:reverse(P1, Events),[]} + {lists:reverse(P_1, Events),[]} end, %% Place next events first in queue - Q = lists:reverse(NextEvents, Q2), + NewEvents = lists:reverse(NextEvents, Events_1), %% NewDebug = sys_debug( Debug, S, State, case Postpone of true -> - {postpone,Event,NextState}; + {postpone,Event,State}; false -> - {consume,Event,NextState} + {consume,Event,State} end), + %% loop_events( - Parent, NewDebug, S, Q, NextState, NewData, P, Hibernate, Timeout). + Parent, NewDebug, S, NewStateTimeout, + NewEvents, Timeout, NextState, NewData, NewP, Hibernate). %%--------------------------------------------------------------------------- %% Server helpers reply_then_terminate( Class, Reason, Stacktrace, - Debug, S, Q, State, Data, P, Replies) -> + Debug, #{state := State} = S, Q, Replies) -> if is_list(Replies) -> do_reply_then_terminate( Class, Reason, Stacktrace, - Debug, S, Q, State, Data, P, Replies); + Debug, S, Q, Replies, State); true -> do_reply_then_terminate( Class, Reason, Stacktrace, - Debug, S, Q, State, Data, P, [Replies]) + Debug, S, Q, [Replies], State) end. %% do_reply_then_terminate( - Class, Reason, Stacktrace, Debug, S, Q, State, Data, P, []) -> - terminate(Class, Reason, Stacktrace, Debug, S, Q, State, Data, P); + Class, Reason, Stacktrace, Debug, S, Q, [], _State) -> + terminate(Class, Reason, Stacktrace, Debug, S, Q); do_reply_then_terminate( - Class, Reason, Stacktrace, Debug, S, Q, State, Data, P, [R|Rs]) -> + Class, Reason, Stacktrace, Debug, S, Q, [R|Rs], State) -> case R of {reply,{_To,_Tag}=From,Reply} -> NewDebug = do_reply(Debug, S, State, From, Reply), do_reply_then_terminate( - Class, Reason, Stacktrace, - NewDebug, S, Q, State, Data, P, Rs); + Class, Reason, Stacktrace, NewDebug, S, Q, Rs, State); _ -> terminate( error, {bad_reply_action_from_state_function,R}, ?STACKTRACE(), - Debug, S, Q, State, Data, P) + Debug, S, Q) end. do_reply(Debug, S, State, From, Reply) -> @@ -1227,7 +1459,9 @@ do_reply(Debug, S, State, From, Reply) -> terminate( Class, Reason, Stacktrace, - Debug, #{module := Module} = S, Q, State, Data, P) -> + Debug, + #{module := Module, state := State, data := Data, postponed := P} = S, + Q) -> try Module:terminate(Reason, State, Data) of _ -> ok catch @@ -1236,7 +1470,7 @@ terminate( ST = erlang:get_stacktrace(), error_info( C, R, ST, S, Q, P, - format_status(terminate, get(), S, State, Data)), + format_status(terminate, get(), S)), sys:print_log(Debug), erlang:raise(C, R, ST) end, @@ -1247,7 +1481,7 @@ terminate( _ -> error_info( Class, Reason, Stacktrace, S, Q, P, - format_status(terminate, get(), S, State, Data)), + format_status(terminate, get(), S)), sys:print_log(Debug) end, case Stacktrace of @@ -1259,7 +1493,9 @@ terminate( error_info( Class, Reason, Stacktrace, - #{name := Name, callback_mode := CallbackMode}, + #{name := Name, + callback_mode := CallbackMode, + state_enter := StateEnter}, Q, P, FmtData) -> {FixedReason,FixedStacktrace} = case Stacktrace of @@ -1286,6 +1522,13 @@ error_info( end; _ -> {Reason,Stacktrace} end, + CBMode = + case StateEnter of + true -> + [CallbackMode,state_enter]; + false -> + CallbackMode + end, error_logger:format( "** State machine ~p terminating~n" ++ case Q of @@ -1312,8 +1555,9 @@ error_info( [] -> []; [Event|_] -> [Event] end] ++ - [FmtData,Class,FixedReason, - CallbackMode] ++ + [FmtData, + Class,FixedReason, + CBMode] ++ case Q of [_|[_|_] = Events] -> [Events]; _ -> [] @@ -1329,7 +1573,9 @@ error_info( %% Call Module:format_status/2 or return a default value -format_status(Opt, PDict, #{module := Module}, State, Data) -> +format_status( + Opt, PDict, + #{module := Module, state := State, data := Data}) -> case erlang:function_exported(Module, format_status, 2) of true -> try Module:format_status(Opt, [PDict,State,Data]) @@ -1353,3 +1599,24 @@ format_status_default(Opt, State, Data) -> _ -> [{data,[{"State",StateData}]}] end. + +listify(Item) when is_list(Item) -> + Item; +listify(Item) -> + [Item]. + +cancel_timer(undefined) -> + ok; +cancel_timer(TRef) -> + case erlang:cancel_timer(TRef) of + false -> + %% We have to assume that TRef is the ref of a running timer + %% and if so the timer has expired + %% hence we must wait for the timeout message + receive + {timeout,TRef,_} -> + ok + end; + _TimeLeft -> + ok + end. diff --git a/lib/stdlib/test/gen_statem_SUITE.erl b/lib/stdlib/test/gen_statem_SUITE.erl index 1d1417c2e6..28f9ab81fe 100644 --- a/lib/stdlib/test/gen_statem_SUITE.erl +++ b/lib/stdlib/test/gen_statem_SUITE.erl @@ -37,7 +37,8 @@ all() -> {group, stop_handle_event}, {group, abnormal}, {group, abnormal_handle_event}, - shutdown, stop_and_reply, event_order, code_change, + shutdown, stop_and_reply, state_enter, event_order, + state_timeout, code_change, {group, sys}, hibernate, enter_loop]. @@ -57,7 +58,7 @@ tcs(start) -> tcs(stop) -> [stop1, stop2, stop3, stop4, stop5, stop6, stop7, stop8, stop9, stop10]; tcs(abnormal) -> - [abnormal1, abnormal2]; + [abnormal1, abnormal1clean, abnormal1dirty, abnormal2]; tcs(sys) -> [sys1, call_format_status, error_format_status, terminate_crash_format, @@ -451,8 +452,52 @@ abnormal1(Config) -> gen_statem:call(Name, {delayed_answer,1000}, 10), Reason), ok = gen_statem:stop(Name), + ?t:sleep(1100), ok = verify_empty_msgq(). +%% Check that time outs in calls work +abnormal1clean(Config) -> + Name = abnormal1clean, + LocalSTM = {local,Name}, + + {ok, _Pid} = + gen_statem:start(LocalSTM, ?MODULE, start_arg(Config, []), []), + + %% timeout call. + delayed = + gen_statem:call(Name, {delayed_answer,1}, {clean_timeout,100}), + {timeout,_} = + ?EXPECT_FAILURE( + gen_statem:call( + Name, {delayed_answer,1000}, {clean_timeout,10}), + Reason), + ok = gen_statem:stop(Name), + ?t:sleep(1100), + ok = verify_empty_msgq(). + +%% Check that time outs in calls work +abnormal1dirty(Config) -> + Name = abnormal1dirty, + LocalSTM = {local,Name}, + + {ok, _Pid} = + gen_statem:start(LocalSTM, ?MODULE, start_arg(Config, []), []), + + %% timeout call. + delayed = + gen_statem:call(Name, {delayed_answer,1}, {dirty_timeout,100}), + {timeout,_} = + ?EXPECT_FAILURE( + gen_statem:call( + Name, {delayed_answer,1000}, {dirty_timeout,10}), + Reason), + ok = gen_statem:stop(Name), + ?t:sleep(1100), + case flush() of + [{Ref,delayed}] when is_reference(Ref) -> + ok + end. + %% Check that bad return values makes the stm crash. Note that we must %% trap exit since we must link to get the real bad_return_ error abnormal2(Config) -> @@ -512,7 +557,8 @@ stop_and_reply(_Config) -> {stop_and_reply,Reason, [R1,{reply,From2,Reply2}]} end}, - {ok,STM} = gen_statem:start_link(?MODULE, {map_statem,Machine}, []), + {ok,STM} = + gen_statem:start_link(?MODULE, {map_statem,Machine,[]}, []), Self = self(), Tag1 = make_ref(), @@ -537,6 +583,61 @@ stop_and_reply(_Config) -> +state_enter(_Config) -> + process_flag(trap_exit, true), + Self = self(), + + Machine = + %% Abusing the internal format of From... + #{init => + fun () -> + {ok,start,1} + end, + start => + fun (enter, Prev, N) -> + Self ! {enter,start,Prev,N}, + {keep_state,N + 1}; + (internal, Prev, N) -> + Self ! {internal,start,Prev,N}, + {keep_state,N + 1}; + ({call,From}, echo, N) -> + {next_state,wait,N + 1,{reply,From,{echo,start,N}}}; + ({call,From}, {stop,Reason}, N) -> + {stop_and_reply,Reason,[{reply,From,{stop,N}}],N + 1} + end, + wait => + fun (enter, Prev, N) -> + Self ! {enter,wait,Prev,N}, + {keep_state,N + 1}; + ({call,From}, echo, N) -> + {next_state,start,N + 1, + [{next_event,internal,wait}, + {reply,From,{echo,wait,N}}]} + end}, + {ok,STM} = + gen_statem:start_link( + ?MODULE, {map_statem,Machine,[state_enter]}, []), + + [{enter,start,start,1}] = flush(), + {echo,start,2} = gen_statem:call(STM, echo), + [{enter,wait,start,3}] = flush(), + {wait,[4|_]} = sys:get_state(STM), + {echo,wait,4} = gen_statem:call(STM, echo), + [{enter,start,wait,5},{internal,start,wait,6}] = flush(), + {stop,7} = gen_statem:call(STM, {stop,bye}), + [{'EXIT',STM,bye}] = flush(), + + {noproc,_} = + ?EXPECT_FAILURE(gen_statem:call(STM, hej), Reason), + case flush() of + [] -> + ok; + Other2 -> + ct:fail({unexpected,Other2}) + end. + + + event_order(_Config) -> process_flag(trap_exit, true), @@ -579,7 +680,7 @@ event_order(_Config) -> Result end}, - {ok,STM} = gen_statem:start_link(?MODULE, {map_statem,Machine}, []), + {ok,STM} = gen_statem:start_link(?MODULE, {map_statem,Machine,[]}, []), Self = self(), Tag1 = make_ref(), gen_statem:cast(STM, {reply,{Self,Tag1},ok1}), @@ -609,6 +710,83 @@ event_order(_Config) -> +state_timeout(_Config) -> + process_flag(trap_exit, true), + + Machine = + #{init => + fun () -> + {ok,start,0} + end, + start => + fun + ({call,From}, {go,Time}, 0) -> + self() ! message_to_self, + {next_state, state1, {Time,From}, + %% Verify that internal events goes before external + [{state_timeout,Time,1}, + {next_event,internal,1}]} + end, + state1 => + fun + (internal, 1, Data) -> + %% Verify that a state change cancels timeout 1 + {next_state, state2, Data, + [{timeout,0,2}, + {state_timeout,0,2}, + {next_event,internal,2}]} + end, + state2 => + fun + (internal, 2, Data) -> + %% Verify that {state_timeout,0,_} + %% comes after next_event and that + %% {timeout,0,_} is cancelled by + %% {state_timeout,0,_} + {keep_state, {ok,2,Data}, + [{timeout,0,3}]}; + (state_timeout, 2, {ok,2,{Time,From}}) -> + {next_state, state3, 3, + [{reply,From,ok}, + {state_timeout,Time,3}]} + end, + state3 => + fun + (info, message_to_self, 3) -> + {keep_state, '3'}; + ({call,From}, check, '3') -> + {keep_state, From}; + (state_timeout, 3, From) -> + {stop_and_reply, normal, + {reply,From,ok}} + end}, + + {ok,STM} = gen_statem:start_link(?MODULE, {map_statem,Machine,[]}, []), + TRef = erlang:start_timer(1000, self(), kull), + ok = gen_statem:call(STM, {go,500}), + ok = gen_statem:call(STM, check), + receive + {timeout,TRef,kull} -> + ct:fail(late_timeout) + after 0 -> + receive + {timeout,TRef,kull} -> + ok + after 1000 -> + ct:fail(no_check_timeout) + end + end, + receive + {'EXIT',STM,normal} -> + ok + after 500 -> + ct:fail(did_not_stop) + end, + + verify_empty_msgq(). + + + sys1(Config) -> {ok,Pid} = gen_statem:start(?MODULE, start_arg(Config, []), []), {status, Pid, {module,gen_statem}, _} = sys:get_status(Pid), @@ -1271,9 +1449,9 @@ init({callback_mode,CallbackMode,Arg}) -> ets:new(?MODULE, [named_table,private]), ets:insert(?MODULE, {callback_mode,CallbackMode}), init(Arg); -init({map_statem,#{init := Init}=Machine}) -> +init({map_statem,#{init := Init}=Machine,Modes}) -> ets:new(?MODULE, [named_table,private]), - ets:insert(?MODULE, {callback_mode,handle_event_function}), + ets:insert(?MODULE, {callback_mode,[handle_event_function|Modes]}), case Init() of {ok,State,Data,Ops} -> {ok,State,[Data|Machine],Ops}; diff --git a/lib/tools/emacs/erlang-skels.el b/lib/tools/emacs/erlang-skels.el index 0284c9d686..eeba7f34e9 100644 --- a/lib/tools/emacs/erlang-skels.el +++ b/lib/tools/emacs/erlang-skels.el @@ -904,7 +904,7 @@ Please see the function `tempo-define-template'.") "%% @doc" n "%% Define the callback_mode() for this callback module." n (erlang-skel-separator-end 2) - "-spec callback_mode() -> gen_statem:callback_mode()." n + "-spec callback_mode() -> gen_statem:callback_mode_result()." n "callback_mode() -> state_functions." n n (erlang-skel-separator-start 2) @@ -931,14 +931,16 @@ Please see the function `tempo-define-template'.") "%% Whenever a gen_statem receives an event, the function " n "%% with the name of the current state (StateName) " n "%% is called to handle the event." n - "%%" n - "%% NOTE: If there is an exported function handle_event/4, it is called" n - "%% instead of StateName/3 functions like this!" n (erlang-skel-separator-end 2) - "-spec state_name(" n> - "gen_statem:event_type(), Msg :: term()," n> + "-spec state_name('enter'," n> + "OldState :: atom()," n> + "Data :: term()) ->" n> + "gen_statem:state_enter_result('state_name');" n> + "(gen_statem:event_type()," n> + "Msg :: term()," n> "Data :: term()) ->" n> - "gen_statem:state_function_result()." n + "gen_statem:event_handler_result(atom())." n + ;; "state_name({call,Caller}, _Msg, Data) ->" n> "{next_state, state_name, Data, [{reply,Caller,ok}]}." n n @@ -1015,7 +1017,7 @@ Please see the function `tempo-define-template'.") "%% @doc" n "%% Define the callback_mode() for this callback module." n (erlang-skel-separator-end 2) - "-spec callback_mode() -> gen_statem:callback_mode()." n + "-spec callback_mode() -> gen_statem:callback_mode_result()." n "callback_mode() -> handle_event_function." n n (erlang-skel-separator-start 2) @@ -1039,14 +1041,18 @@ Please see the function `tempo-define-template'.") "%% @private" n "%% @doc" n "%% This function is called for every event a gen_statem receives." n - "%%" n - "%% NOTE: If there is no exported function handle_event/4," n - "%% StateName/3 functions are called instead!" n (erlang-skel-separator-end 2) - "-spec handle_event(" n> - "gen_statem:event_type(), Msg :: term()," n> - "State :: term(), Data :: term()) ->" n> - "gen_statem:handle_event_result()." n + "-spec handle_event('enter'," n> + "OldState :: term()," n> + "State :: term()," n> + "Data :: term()) ->" n> + "gen_statem:state_enter_result(term());" n> + "(gen_statem:event_type()," n> + "Msg :: term()," n> + "State :: term()," n> + "Data :: term()) ->" n> + "gen_statem:event_handler_result(term())." n + ;; "handle_event({call,From}, _Msg, State, Data) ->" n> "{next_state, State, Data, [{reply,From,ok}]}." n n |