The R13B03 release.OTP_R13B03

1 files changed, 492 insertions, 0 deletions

diff --git a/lib/dialyzer/src/dialyzer_contracts.erl b/lib/dialyzer/src/dialyzer_contracts.erl
new file mode 100644
index 0000000000..e2680bb03d
--- /dev/null
+++ b/lib/dialyzer/src/dialyzer_contracts.erl
@@ -0,0 +1,492 @@
+%% -*- erlang-indent-level: 2 -*-
+%%-----------------------------------------------------------------------
+%% %CopyrightBegin%
+%% 
+%% Copyright Ericsson AB 2007-2009. All Rights Reserved.
+%% 
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%% 
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%% 
+%% %CopyrightEnd%
+%%
+
+-module(dialyzer_contracts).
+
+-export([check_contract/2,
+	 check_contracts/3, 
+	 contracts_without_fun/3,
+	 contract_to_string/1,
+	 get_invalid_contract_warnings/3,
+	 get_contract_args/1,
+	 get_contract_return/1,
+	 get_contract_return/2,
+	 %% get_contract_signature/1,
+	 is_overloaded/1,
+	 process_contract_remote_types/1,
+	 store_tmp_contract/5]).
+
+%%-----------------------------------------------------------------------
+
+-include("dialyzer.hrl").
+
+%%-----------------------------------------------------------------------
+%% Types used in other parts of the system below
+%%-----------------------------------------------------------------------
+
+-type file_contract() :: {file_line(), #contract{}}.
+
+-type plt_contracts() :: [{mfa(), #contract{}}]. % actually, an orddict()
+
+%%-----------------------------------------------------------------------
+%% Internal record for contracts whose components have not been processed
+%% to expand records and/or remote types that they might contain.
+%%-----------------------------------------------------------------------
+
+-type tmp_contract_fun() :: fun((dict()) -> contract_pair()).
+
+-record(tmp_contract, {contract_funs = [] :: [tmp_contract_fun()],
+		       forms	     = [] :: [{_, _}]}).
+
+%%-----------------------------------------------------------------------
+
+%%-define(DEBUG, true).
+
+-ifdef(DEBUG).
+-define(debug(X__, Y__), io:format(X__, Y__)).
+-else.
+-define(debug(X__, Y__), ok).
+-endif.
+
+%%-----------------------------------------------------------------------
+
+-spec get_contract_return(#contract{}) -> erl_types:erl_type().
+
+get_contract_return(#contract{contracts = Cs, args = GenArgs}) ->
+  process_contracts(Cs, GenArgs).
+
+-spec get_contract_return(#contract{}, [erl_types:erl_type()]) -> erl_types:erl_type().
+
+get_contract_return(#contract{contracts = Cs}, Args) ->
+  process_contracts(Cs, Args).
+
+-spec get_contract_args(#contract{}) -> [erl_types:erl_type()].
+
+get_contract_args(#contract{args = Args}) ->
+  Args.
+
+-spec get_contract_signature(#contract{}) -> erl_types:erl_type().
+
+get_contract_signature(#contract{contracts = Cs, args = GeneralDomain}) ->
+  Range = process_contracts(Cs, GeneralDomain),
+  erl_types:t_fun(GeneralDomain, Range).
+
+-spec is_overloaded(#contract{}) -> boolean().
+
+is_overloaded(#contract{contracts = Cs}) ->
+  case Cs of
+    [_] -> true;
+    [_,_|_] -> false
+  end.
+
+-spec contract_to_string(#contract{}) -> string().
+
+contract_to_string(#contract{forms = Forms}) ->
+  contract_to_string_1(Forms).
+
+contract_to_string_1([{Contract, []}]) ->
+  strip_fun(erl_types:t_form_to_string(Contract));
+contract_to_string_1([{Contract, []}|Rest]) ->
+  strip_fun(erl_types:t_form_to_string(Contract)) ++ "\n    ; " 
+    ++ contract_to_string_1(Rest);
+contract_to_string_1([{Contract, Constraints}]) ->
+  strip_fun(erl_types:t_form_to_string(Contract)) ++ " when " 
+    ++ constraints_to_string(Constraints);
+contract_to_string_1([{Contract, Constraints}|Rest]) ->
+  strip_fun(erl_types:t_form_to_string(Contract)) ++ " when " 
+    ++ constraints_to_string(Constraints) ++ ";" ++
+    contract_to_string_1(Rest).
+
+strip_fun("fun(" ++ String) ->
+  butlast(String).
+
+butlast([]) -> [];
+butlast([_]) -> [];
+butlast([H|T]) -> [H|butlast(T)].
+
+constraints_to_string([]) ->
+  "";
+constraints_to_string([{type, _, constraint, [{atom, _, What}, Types]}]) ->
+  atom_to_list(What) ++ "(" ++
+    sequence([erl_types:t_form_to_string(T) || T <- Types], ",") ++ ")";
+constraints_to_string([{type, _, constraint, [{atom, _, What}, Types]}|Rest]) ->
+  atom_to_list(What) ++ "(" ++
+    sequence([erl_types:t_form_to_string(T) || T <- Types], ",") 
+    ++ "), " ++ constraints_to_string(Rest).
+
+sequence([], _Delimiter) -> "";
+sequence([H], _Delimiter) -> H;
+sequence([H|T], Delimiter) -> H ++ Delimiter ++ sequence(T, Delimiter).
+
+-spec process_contract_remote_types(dialyzer_codeserver:codeserver()) ->
+	  dialyzer_codeserver:codeserver().
+
+process_contract_remote_types(CodeServer) ->
+  TmpContractDict = dialyzer_codeserver:get_temp_contracts(CodeServer),
+  RecordDict = dialyzer_codeserver:get_records(CodeServer),
+  ContractFun =
+    fun({_M, _F, _A}, {File, #tmp_contract{contract_funs = CFuns, forms = Forms}}) ->
+	NewCs = [CFun(RecordDict) || CFun <- CFuns],
+	Args = general_domain(NewCs),
+	{File, #contract{contracts = NewCs, args = Args, forms = Forms}}
+    end,
+  ModuleFun =
+    fun(_ModuleName, ContractDict) ->
+	dict:map(ContractFun, ContractDict)
+    end,
+  NewContractDict = dict:map(ModuleFun, TmpContractDict),
+  dialyzer_codeserver:finalize_contracts(NewContractDict, CodeServer).
+  
+-spec check_contracts([{mfa(), file_contract()}],
+		      dialyzer_callgraph:callgraph(), dict()) -> plt_contracts().
+
+check_contracts(Contracts, Callgraph, FunTypes) ->
+  FoldFun =
+    fun(Label, Type, NewContracts) -> 
+	{ok, {M,F,A} = MFA} = dialyzer_callgraph:lookup_name(Label, Callgraph),
+	case orddict:find(MFA, Contracts) of
+	  {ok, {_FileLine, Contract}} -> 
+	    case check_contract(Contract, Type) of
+	      ok ->
+		case erl_bif_types:is_known(M, F, A) of
+		  true ->
+		    %% Disregard the contracts since 
+		    %% this is a known function.
+		    NewContracts;
+		  false ->
+		    [{MFA, Contract}|NewContracts]
+		end;
+	      {error, _Error} -> NewContracts
+	    end;
+	  error -> NewContracts
+	end
+    end,
+  dict:fold(FoldFun, [], FunTypes).
+
+%% Checks all components of a contract
+-spec check_contract(#contract{}, erl_types:erl_type()) -> 'ok' | {'error', term()}.
+
+check_contract(#contract{contracts = Contracts}, SuccType) ->
+  try 
+    Contracts1 = [{Contract, insert_constraints(Constraints, dict:new())} 
+		  || {Contract, Constraints} <- Contracts],
+    Contracts2 = [erl_types:t_subst(Contract, Dict)
+		  || {Contract, Dict} <- Contracts1],
+    GenDomains = [erl_types:t_fun_args(C) || C <- Contracts2],
+    case check_domains(GenDomains) of
+      error ->
+	{error, {overlapping_contract, []}};
+      ok ->
+	InfList = [erl_types:t_inf(Contract, SuccType, opaque) 
+		   || Contract <- Contracts2],
+	check_contract_inf_list(InfList, SuccType)
+    end
+  catch throw:{error, _} = Error -> Error
+  end.
+
+check_domains([_]) -> ok;
+check_domains([Dom|Doms]) ->
+  Fun = fun(D) ->
+	    erl_types:any_none_or_unit(erl_types:t_inf_lists(Dom, D, opaque))
+	end,
+  case lists:all(Fun, Doms) of
+    true -> check_domains(Doms);
+    false -> error
+  end.
+
+%% Allow a contract if one of the overloaded contracts is possible.
+%% We used to be more strict, e.g., all overloaded contracts had to be
+%% possible.
+check_contract_inf_list([FunType|Left], SuccType) ->
+  FunArgs = erl_types:t_fun_args(FunType),
+  case lists:any(fun erl_types:t_is_none_or_unit/1, FunArgs) of
+    true -> check_contract_inf_list(Left, SuccType);
+    false ->
+      STRange = erl_types:t_fun_range(SuccType),
+      case erl_types:t_is_none_or_unit(STRange) of
+	true -> ok;
+	false -> 
+	  Range = erl_types:t_fun_range(FunType),
+	  case erl_types:t_is_none(erl_types:t_inf(STRange, Range, opaque)) of
+	    true -> check_contract_inf_list(Left, SuccType);
+	    false -> ok
+	  end
+      end
+  end;
+check_contract_inf_list([], _SuccType) ->
+  {error, invalid_contract}.
+
+%% This is the heart of the "range function"
+-spec process_contracts([contract_pair()], [erl_types:erl_type()]) -> erl_types:erl_type().
+
+process_contracts(OverContracts, Args) ->
+  process_contracts(OverContracts, Args, erl_types:t_none()).
+  
+process_contracts([OverContract|Left], Args, AccRange) ->
+  NewAccRange = 
+    case process_contract(OverContract, Args) of
+      error -> AccRange;
+      {ok, Range} -> erl_types:t_sup(AccRange, Range)
+    end,
+  process_contracts(Left, Args, NewAccRange);
+process_contracts([], _Args, AccRange) ->
+  AccRange.
+
+-spec process_contract(contract_pair(), [erl_types:erl_type()]) -> 'error' | {'ok', erl_types:erl_type()}.
+
+process_contract({Contract, Constraints}, CallTypes0) ->
+  CallTypesFun = erl_types:t_fun(CallTypes0, erl_types:t_any()),
+  ContArgsFun = erl_types:t_fun(erl_types:t_fun_args(Contract), 
+				erl_types:t_any()),
+  ?debug("Instance: Contract:  ~s\n          Arguments: ~s\n",
+	 [erl_types:t_to_string(ContArgsFun), 
+	  erl_types:t_to_string(CallTypesFun)]),
+  case solve_constraints(ContArgsFun, CallTypesFun, Constraints) of 
+    {ok, VarDict} ->
+      {ok, erl_types:t_subst(erl_types:t_fun_range(Contract), VarDict)};
+    error -> error
+  end.
+
+solve_constraints(Contract, Call, Constraints) ->
+  %% First make sure the call follows the constraints
+  CDict = insert_constraints(Constraints, dict:new()),
+  Contract1 = erl_types:t_subst(Contract, CDict),
+  %% Just a safe over-approximation. 
+  %% TODO: Find the types for type variables properly
+  ContrArgs = erl_types:t_fun_args(Contract1),
+  CallArgs = erl_types:t_fun_args(Call),
+  InfList = erl_types:t_inf_lists(ContrArgs, CallArgs),
+  case erl_types:any_none_or_unit(InfList) of
+    true -> error;
+    false -> {ok, CDict}
+  end.
+  %%Inf = erl_types:t_inf(Contract1, Call),
+  %% Then unify with the constrained call type.
+  %%  ?debug("Call: ~s\n", [erl_types:t_to_string(Call)]),
+  %%  ?debug("Contract: ~s\n", [erl_types:t_to_string(Contract)]),
+  %%  ?debug("Contract1: ~s\n", [erl_types:t_to_string(Contract1)]),
+  %%  ?debug("Inf: ~s\n", [erl_types:t_to_string(Inf)]),
+  %%  erl_types:t_assign_variables_to_subtype(Contract, Inf).
+
+%% Checks the contracts for functions that are not implemented
+-spec contracts_without_fun(dict(), [_], dialyzer_callgraph:callgraph()) -> [dial_warning()].
+
+contracts_without_fun(Contracts, AllFuns0, Callgraph) ->
+  AllFuns1 = [{dialyzer_callgraph:lookup_name(Label, Callgraph), Arity} 
+	      || {Label, Arity} <- AllFuns0],
+  AllFuns2 = [{M, F, A} || {{ok, {M, F, _}}, A} <- AllFuns1],
+  AllContractMFAs = dict:fetch_keys(Contracts),
+  ErrorContractMFAs = AllContractMFAs -- AllFuns2,
+  [warn_spec_missing_fun(MFA, Contracts) || MFA <- ErrorContractMFAs].
+
+warn_spec_missing_fun({M, F, A} = MFA, Contracts) ->
+  {FileLine, _Contract} = dict:fetch(MFA, Contracts),
+  {?WARN_CONTRACT_SYNTAX, FileLine, {spec_missing_fun, [M, F, A]}}.
+
+%% This treats the "when" constraints. It will be extended, we hope.
+insert_constraints([{subtype, Type1, Type2}|Left], Dict) ->
+  case erl_types:t_is_var(Type1) of
+    true ->
+      Name = erl_types:t_var_name(Type1),
+      Dict1 = case dict:find(Name, Dict) of
+		error ->
+		  dict:store(Name, Type2, Dict);
+		{ok, VarType} ->
+		  dict:store(Name, erl_types:t_inf(VarType, Type2), Dict)
+	      end,
+      insert_constraints(Left, Dict1);
+    false ->
+      %% A lot of things should change to add supertypes
+      throw({error, io_lib:format("First argument of is_subtype constraint "
+				  "must be a type variable\n", [])})
+  end;
+insert_constraints([], Dict) -> Dict.
+
+-spec store_tmp_contract(mfa(), file_line(), [_], dict(), dict()) -> dict().
+
+store_tmp_contract(MFA, FileLine, TypeSpec, SpecDict, RecordsDict) ->
+  %% io:format("contract from form: ~p\n", [TypeSpec]),
+  TmpContract = contract_from_form(TypeSpec, RecordsDict),
+  %% io:format("contract: ~p\n", [Contract]),
+  dict:store(MFA, {FileLine, TmpContract}, SpecDict).
+
+contract_from_form(Forms, RecDict) ->
+  {CFuns, Forms1} = contract_from_form(Forms, RecDict, [], []),
+  #tmp_contract{contract_funs = CFuns, forms = Forms1}.
+
+contract_from_form([{type, _, 'fun', [_, _]} = Form | Left], RecDict, 
+		   TypeAcc, FormAcc) ->
+  TypeFun = 
+    fun(AllRecords) ->
+	Type = erl_types:t_from_form(Form, RecDict),
+	NewType = erl_types:t_solve_remote(Type, AllRecords),
+	{NewType, []}
+    end,
+  NewTypeAcc = [TypeFun | TypeAcc],
+  NewFormAcc = [{Form, []} | FormAcc],
+  contract_from_form(Left, RecDict, NewTypeAcc, NewFormAcc);
+contract_from_form([{type, _L1, bounded_fun, 
+		     [{type, _L2, 'fun', [_, _]} = Form, Constr]}| Left],
+		   RecDict, TypeAcc, FormAcc) ->
+  TypeFun = 
+    fun(AllRecords) ->
+	Constr1 = [constraint_from_form(C, RecDict, AllRecords) || C <- Constr],
+	VarDict = insert_constraints(Constr1, dict:new()),
+	Type = erl_types:t_from_form(Form, RecDict, VarDict),
+	NewType = erl_types:t_solve_remote(Type, AllRecords),
+	{NewType, Constr1}
+    end,  
+  NewTypeAcc = [TypeFun | TypeAcc],
+  NewFormAcc = [{Form, Constr} | FormAcc],
+  contract_from_form(Left, RecDict, NewTypeAcc, NewFormAcc);
+contract_from_form([], _RecDict, TypeAcc, FormAcc) -> 
+  {lists:reverse(TypeAcc), lists:reverse(FormAcc)}.
+
+constraint_from_form({type, _, constraint, [{atom, _, is_subtype}, 
+					    [Type1, Type2]]}, RecDict, AllRecords) ->
+  T1 = erl_types:t_from_form(Type1, RecDict),
+  T2 = erl_types:t_from_form(Type2, RecDict),
+  T3 = erl_types:t_solve_remote(T1, AllRecords),
+  T4 = erl_types:t_solve_remote(T2, AllRecords),
+  {subtype, T3, T4};
+constraint_from_form({type, _, constraint, [{atom,_,Name}, List]}, _RecDict, _) ->
+  N = length(List),
+  throw({error, io_lib:format("Unsupported type guard ~w/~w\n", [Name, N])}).
+
+%% Gets the most general domain of a list of domains of all 
+%% the overloaded contracts
+
+general_domain(List) ->
+  general_domain(List, erl_types:t_none()).
+
+general_domain([{Sig, Constraints}|Left], AccSig) ->
+  Dict = insert_constraints(Constraints, dict:new()),
+  Sig1 = erl_types:t_subst(Sig, Dict),
+  general_domain(Left, erl_types:t_sup(AccSig, Sig1));
+general_domain([], AccSig) ->
+  %% Get rid of all variables in the domain.
+  AccSig1 = erl_types:subst_all_vars_to_any(AccSig),
+  erl_types:t_fun_args(AccSig1).
+
+-spec get_invalid_contract_warnings([module()], dialyzer_codeserver:codeserver(), dialyzer_plt:plt()) -> [dial_warning()].
+
+get_invalid_contract_warnings(Modules, CodeServer, Plt) ->
+  get_invalid_contract_warnings_modules(Modules, CodeServer, Plt, []).
+
+get_invalid_contract_warnings_modules([Mod|Mods], CodeServer, Plt, Acc) ->
+  Contracts1 = dialyzer_codeserver:lookup_mod_contracts(Mod, CodeServer),
+  Contracts2 = dict:to_list(Contracts1),
+  Records = dialyzer_codeserver:lookup_mod_records(Mod, CodeServer),
+  NewAcc = get_invalid_contract_warnings_funs(Contracts2, Plt, Records, Acc),
+  get_invalid_contract_warnings_modules(Mods, CodeServer, Plt, NewAcc);
+get_invalid_contract_warnings_modules([], _CodeServer, _Plt, Acc) ->
+  Acc.
+
+get_invalid_contract_warnings_funs([{MFA, {FileLine, Contract}}|Left], 
+				   Plt, RecDict, Acc) ->
+  case dialyzer_plt:lookup(Plt, MFA) of
+    none ->
+      %% This must be a contract for a non-available function. Just accept it.
+      get_invalid_contract_warnings_funs(Left, Plt, RecDict, Acc);
+    {value, {Ret, Args}} ->
+      Sig = erl_types:t_fun(Args, Ret),
+      NewAcc =
+	case check_contract(Contract, Sig) of
+	  {error, invalid_contract} ->
+	    [invalid_contract_warning(MFA, FileLine, Sig, RecDict)|Acc];
+	  {error, Msg} ->
+	    [{?WARN_CONTRACT_SYNTAX, FileLine, Msg}|Acc];
+	  ok ->
+	    {M, F, A} = MFA,
+	    CSig0 = get_contract_signature(Contract),
+	    CSig = erl_types:subst_all_vars_to_any(CSig0),
+	    case erl_bif_types:is_known(M, F, A) of
+	      true ->
+		%% This is strictly for contracts of functions also in
+		%% erl_bif_types
+		BifArgs = erl_bif_types:arg_types(M, F, A),
+		BifRet = erl_bif_types:type(M, F, A),
+		BifSig = erl_types:t_fun(BifArgs, BifRet),
+		case check_contract(Contract, BifSig) of
+		  {error, _} -> 
+		    [invalid_contract_warning(MFA, FileLine, BifSig, RecDict)
+		     |Acc];
+		  ok ->
+		    picky_contract_check(CSig, BifSig, MFA, FileLine, 
+					 Contract, RecDict, Acc)
+		end;
+	      false ->
+		picky_contract_check(CSig, Sig, MFA, FileLine, Contract, 
+				     RecDict, Acc)
+	    end
+	end,
+      get_invalid_contract_warnings_funs(Left, Plt, RecDict, NewAcc)
+  end;
+get_invalid_contract_warnings_funs([], _Plt, _RecDict, Acc) ->
+  Acc.
+
+invalid_contract_warning({M, F, A}, FileLine, Type, RecDict) ->
+  {?WARN_CONTRACT_TYPES, FileLine,
+   {invalid_contract, [M, F, A, dialyzer_utils:format_sig(Type, RecDict)]}}.
+
+picky_contract_check(CSig0, Sig0, MFA, FileLine, Contract, RecDict, Acc) ->
+  CSig = erl_types:t_abstract_records(CSig0, RecDict),
+  Sig = erl_types:t_abstract_records(Sig0, RecDict),
+  case erl_types:t_is_equal(CSig, Sig) of
+    true -> Acc;
+    false -> 
+      case (erl_types:t_is_none(erl_types:t_fun_range(Sig)) andalso
+	    erl_types:t_is_unit(erl_types:t_fun_range(CSig))) of
+	true -> Acc;
+	false ->
+	  case extra_contract_warning(MFA, FileLine, Contract, 
+				      CSig, Sig, RecDict) of
+	    no_warning -> Acc;
+	    {warning, Warning} -> [Warning|Acc]
+	  end
+      end
+  end.
+
+extra_contract_warning({M, F, A}, FileLine, Contract, CSig, Sig, RecDict) ->
+  SigString = lists:flatten(dialyzer_utils:format_sig(Sig, RecDict)),
+  ContractString0 = lists:flatten(dialyzer_utils:format_sig(CSig, RecDict)),
+  case SigString =:= ContractString0 of
+    true ->
+      %% The only difference is in record fields containing 'undefined' or not.
+      no_warning;
+    false ->
+      ContractString = contract_to_string(Contract),
+      {Tag, Msg} =
+	case erl_types:t_is_subtype(CSig, Sig) of
+	  true -> 
+	    {?WARN_CONTRACT_SUBTYPE, 
+	     {contract_subtype, [M, F, A, ContractString, SigString]}};
+	  false ->
+	    case erl_types:t_is_subtype(Sig, CSig) of
+	      true ->
+		{?WARN_CONTRACT_SUPERTYPE, 
+		 {contract_supertype, [M, F, A, ContractString, SigString]}};
+	      false ->
+		{?WARN_CONTRACT_NOT_EQUAL, 
+		 {contract_diff, [M, F, A, ContractString, SigString]}}
+	    end
+	end,
+      {warning, {Tag, FileLine, Msg}}
+  end.