%%
%% %CopyrightBegin%
%%
%% Copyright Ericsson AB 2000-2010. 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(xref_compiler).
-include("xref.hrl").
%-define(debug, true).
-ifdef(debug).
-define(FORMAT(P, A), io:format(P, A)).
-define(CALL(F), F).
-else.
-define(FORMAT(P, A), ok).
-define(CALL(F), ok).
-endif.
-export([compile/2]).
-export([update_graph_counter/3]).
-export([format_error/1]).
-import(lists,
[concat/1, foldl/3, nthtail/2, reverse/1, sort/1, sublist/2]).
-import(sofs,
[composite/2, difference/2, empty_set/0, from_term/1,
intersection/2, is_empty_set/1, multiple_relative_product/2,
projection/2, relation/1, relation_to_family/1,
restriction/2, specification/2, substitution/2,
to_external/1, union/2, union_of_family/1]).
%%
%% Exported functions
%%
compile(Chars, Table) ->
case xref_scanner:scan(Chars) of
{ok, Tokens} ->
case xref_parser:parse(Tokens) of
{ok, ParseTree} ->
?FORMAT("ParseTree ~p~n", [ParseTree]),
case catch statements(ParseTree, Table) of
E={error, _, _} ->
E;
{ok, UV, P} ->
%% User variables to be.
Table1 = user_vars(UV, Table),
?CALL(statistics(runtime)),
Reply = i(P, Table1),
?CALL({_, Time} = statistics(runtime)),
?FORMAT("Result in ~p ms~n",[Time]),
Reply
end;
{error, {Line, _Module, Error}} ->
error({parse_error, Line, Error})
end;
{error, Info, Line} ->
error({parse_error, Line, Info})
end.
format_error({error, Module, Error}) ->
Module:format_error(Error);
format_error({parse_error, Line, Error}) ->
format_parse_error(Error, format_line(Line));
format_error({variable_reassigned, Expr}) ->
io_lib:format("Variable assigned more than once: ~s~n", [Expr]);
format_error({unknown_variable, Name}) ->
io_lib:format("Variable ~p used before set~n", [Name]);
format_error({type_error, Expr}) ->
io_lib:format("Operator applied to argument(s) of different or "
"invalid type(s): ~s~n", [Expr]);
format_error({type_mismatch, Expr1, Expr2}) ->
io_lib:format("Constants of different types: ~s, ~s~n",
[Expr1, Expr2]);
format_error({unknown_constant, Constant}) ->
io_lib:format("Unknown constant ~s~n", [Constant]);
format_error(E) ->
io_lib:format("~p~n", [E]).
%%
%% Local functions
%%
user_vars([{{user,Name}, Val} | UV], Table) ->
user_vars(UV, dict:store(Name, Val, Table));
user_vars([_V | UV], Table) ->
user_vars(UV, Table);
user_vars([], Table) ->
Table.
statements(Stmts, Table) ->
statements(Stmts, Table, [], []).
statements([Stmt={assign, VarType, Name, E} | Stmts0], Table, L, UV) ->
case dict:find(Name, Table) of
{ok, _} ->
throw_error({variable_reassigned, xref_parser:t2s(Stmt)});
error ->
{Type, OType, NewE} = t_expr(E, Table),
Val = #xref_var{name = Name, vtype = VarType,
otype = OType, type = Type},
NewTable = dict:store(Name, Val, Table),
Stmts = if Stmts0 =:= [] -> [{variable, Name}]; true -> Stmts0 end,
Variable = {VarType, Name},
Put = {put, Variable, NewE},
statements(Stmts, NewTable, [Put | L], [{Variable,Val} | UV])
end;
statements([Expr], Table, L, UV) ->
{Type, OType, NewE} = t_expr(Expr, Table),
E1 = un_familiarize(Type, OType, NewE),
NE = case {Type, OType} of
%% Edges with empty sets of line numbers are removed.
{{line, _}, edge} ->
{relation_to_family, E1};
{_Type, edge_closure} ->
%% Fake a closure usage, just to make sure it is destroyed.
E2 = {fun graph_access/2, E1, E1},
{fun(_E) -> 'closure()' end, E2};
_Else -> E1
end,
{ok, UV, stats(L, NE)}.
stats([{put, V, X} | Ss], E) ->
stats(Ss, {put, V, X, E});
stats([], E) ->
E.
t_expr(E, Table) ->
{expr, Type, OType, E1} = check_expr(E, Table),
?FORMAT("TExpr:~n~p~n",[E1]),
E2 = convert(E1),
?FORMAT("After conversion:~n~p~n",[E2]),
{Type, OType, E2}.
%%% check_expr/2 translates Expr in xref_parser.yrl into TExpr:
%%%
%%% TExpr = {expr, Type, ObjectType, Expr}
%%% Expr = {constants, [Constant]}
%%% | {variable, {VarType, VarName}}
%%% | {call, Call, Expr}
%%% | {call, Call, Expr, Expr}
%%% | {call, restriction, integer(), Expr, Expr}
%%% | {convert, ObjectType, Type, Type}
%%% | {convert, Type, Type}
%%% Constant = atom() | {atom(), atom()} | MFA | {MFA, MFA}
%%% Call = atom() % function in the sofs module
%%% | fun()
%%% Type = {line, LineType} | function | module | application | release
%%% | number
%%% LineType = line | local_call | external_call | export_call | all_line_call
%%% VarType = predef | user | tmp
%%% ObjectType = vertex | vertex_set | edge | edge_set | edge_closure | path
%%% | number
%%% MFA = {atom(), atom(), integer()}
%% -> TExpr
check_expr({list, L}, Table) ->
check_constants(L, Table);
check_expr({tuple, L}, Table) ->
{expr, Type, vertex, _Consts} = check_constants(L, Table),
Cs = reverse(constant_vertices(L, [])),
{expr, Type, path, {constants, Cs}};
check_expr({variable, Name}, Table) ->
case dict:find(Name, Table) of
{ok, #xref_var{vtype = VarType, otype = OType, type = Type}} ->
V0 = {variable, {VarType, Name}},
V = case {VarType, Type, OType} of
{predef, release, _} -> V0;
{predef, application, _} -> V0;
{predef, module, _} -> V0;
{predef, function, vertex} -> V0;
{predef, function, edge} -> {call, union_of_family, V0};
_Else -> V0
end,
{expr, Type, OType, V};
error ->
throw_error({unknown_variable, Name})
end;
check_expr({type, {type, _Type}, E}, Table) ->
check_expr(E, Table);
check_expr(Expr={type, {convert, NewType0}, E}, Table) ->
NewType = what_type(NewType0),
{expr, OldType, OType, NE} = check_expr(E, Table),
ok = check_conversion(OType, OldType, NewType, Expr),
{expr, NewType, OType, {convert, OType, OldType, NewType, NE}};
check_expr(Expr={set, SOp, E}, Table) ->
{expr, Type, OType0, E1} = check_expr(E, Table),
OType = case {OType0, SOp} of
{edge, range} -> vertex;
{edge, domain} -> vertex;
{edge, weak} -> edge;
{edge, strict} -> edge;
{edge_set, range} -> vertex_set;
{edge_set, domain} -> vertex_set;
{edge_set, weak} -> edge_set;
{edge_set, strict} -> edge_set;
_ ->
throw_error({type_error, xref_parser:t2s(Expr)})
end,
Op = set_op(SOp),
NE = function_vertices_to_family(Type, OType, {call, Op, E1}),
{expr, Type, OType, NE};
check_expr(Expr={graph, Op, E}, Table) ->
{expr, Type, NOType, E1} = check_expr(E, Table),
case Type of
{line, _LineType} ->
throw_error({type_error, xref_parser:t2s(Expr)});
_Else ->
ok
end,
OType =
case {NOType, Op} of
{edge, components} -> vertex_set;
{edge, condensation} -> edge_set;
{edge, closure} -> edge_closure;
{edge_closure, components} -> vertex_set;
{edge_closure, condensation} -> edge_set;
{edge_closure, closure} -> edge_closure;
%% Neither need nor want these ones:
%% {edge_set, closure} -> edge_set_closure;
%% {edge_set, components} -> vertex_set_set;
_ ->
throw_error({type_error, xref_parser:t2s(Expr)})
end,
E2 = {convert, NOType, edge_closure, E1},
NE = case Op of
closure -> E2;
_Op -> use_of_closure(Op, E2)
end,
{expr, Type, OType, NE};
check_expr(Expr={numeric, '#', E}, Table) ->
{expr, Type, OType, E1} = check_expr(E, Table),
case OType of
vertex -> ok;
vertex_set -> ok;
edge -> ok;
edge_set -> ok;
_Else -> throw_error({type_error, xref_parser:t2s(Expr)})
end,
NE = {convert, OType, Type, number, E1},
{expr, number, number, {call, no_elements, NE}};
check_expr(Expr={set, SOp, E1, E2}, Table) ->
%% sets and numbers...
{expr, Type1, OType1, NE1} = check_expr(E1, Table),
{expr, Type2, OType2, NE2} = check_expr(E2, Table),
OType = case {OType1, OType2} of
{vertex, vertex} -> vertex;
{edge, edge} -> edge;
{number, number} -> number;
_ -> throw_error({type_error, xref_parser:t2s(Expr)})
end,
case OType of
number ->
{expr, number, number, {call, ari_op(SOp), NE1, NE2}};
_Else -> % set
{Type, NewE1, NewE2} =
case {type_ord(Type1), type_ord(Type2)} of
{T1, T2} when T1 =:= T2 ->
%% Example: if Type1 = {line, line} and
%% Type2 = {line, export_line}, then this is not
%% correct, but works:
{Type1, NE1, NE2};
{T1, T2} when T1 < 2; T2 < 2 ->
throw_error({type_error, xref_parser:t2s(Expr)});
{T1, T2} when T1 > T2 ->
{Type2, {convert, OType, Type1, Type2, NE1}, NE2};
{T1, T2} when T1 < T2 ->
{Type1, NE1, {convert, OType, Type2, Type1, NE2}}
end,
Op = set_op(SOp, Type, OType),
{expr, Type, OType, {call, Op, NewE1, NewE2}}
end;
check_expr(Expr={restr, ROp, E1, E2}, Table) ->
{expr, Type1, OType1, NE1} = check_expr(E1, Table),
{expr, Type2, OType2, NE2} = check_expr(E2, Table),
case {Type1, Type2} of
{{line, _LineType1}, _Type2} ->
throw_error({type_error, xref_parser:t2s(Expr)});
{_Type1, {line, _LineType2}} ->
throw_error({type_error, xref_parser:t2s(Expr)});
_ ->
ok
end,
case {OType1, OType2} of
{edge, vertex} when ROp =:= '|||' ->
{expr, _, _, R1} = restriction('|', E1, Type1, NE1, Type2, NE2),
{expr, _, _, R2} = restriction('||', E1, Type1, NE1, Type2, NE2),
{expr, Type1, edge, {call, intersection, R1, R2}};
{edge, vertex} ->
restriction(ROp, E1, Type1, NE1, Type2, NE2);
{edge_closure, vertex} when ROp =:= '|||' ->
{expr, _, _, R1} =
closure_restriction('|', Type1, Type2, OType2, NE1, NE2),
{expr, _, _, R2} =
closure_restriction('||', Type1, Type2, OType2, NE1, NE2),
{expr, Type1, edge, {call, intersection, R1, R2}};
{edge_closure, vertex} ->
closure_restriction(ROp, Type1, Type2, OType2, NE1, NE2);
_ ->
throw_error({type_error, xref_parser:t2s(Expr)})
end;
check_expr(Expr={path, E1, E2}, Table) ->
{expr, Type1, OType1a, E1a} = check_expr(E1, Table),
{expr, Type2, OType2, E2a} = check_expr(E2, Table),
case {Type1, Type2} of
{{line, _LineType1}, _Type2} ->
throw_error({type_error, xref_parser:t2s(Expr)});
{_Type1, {line, _LineType2}} ->
throw_error({type_error, xref_parser:t2s(Expr)});
_Else ->
ok
end,
E2b = {convert, OType2, Type2, Type1, E2a},
{OType1, NE1} = path_arg(OType1a, E1a),
NE2 = case {OType1, OType2} of
{path, edge} -> {convert, OType2, edge_closure, E2b};
{path, edge_closure} when Type1 =:= Type2 -> E2b;
_ -> throw_error({type_error, xref_parser:t2s(Expr)})
end,
{expr, Type1, path, use_of_closure(path, NE2, NE1)};
check_expr({regexpr, RExpr, Type0}, _Table) ->
%% Using the "universal" variables is not optimal as regards speed,
%% but it is simple...
Type = what_type(Type0),
V = case Type of
function -> v;
module -> 'M';
application -> 'A';
release -> 'R'
end,
Var = {variable, {predef, V}},
Call = {call, fun(E, V2) -> xref_utils:regexpr(E, V2) end,
{constants, RExpr}, Var},
{expr, Type, vertex, Call};
check_expr(C={constant, _Type, _OType, _C}, Table) ->
check_constants([C], Table).
path_arg(edge, E={constants, C}) ->
case to_external(C) of
[{V1,V2}] -> {path, {constants, [V1, V2]}};
_ -> {edge, E}
end;
path_arg(OType, E) ->
{OType, E}.
check_conversion(OType, Type1, Type2, Expr) ->
case conversions(OType, Type1, Type2) of
ok -> ok;
not_ok -> throw_error({type_error, xref_parser:t2s(Expr)})
end.
%% Allowed conversions.
conversions(_OType, {line, LineType}, {line, LineType}) -> ok;
conversions(edge, {line, _}, {line, all_line_call}) -> ok;
conversions(edge, From, {line, Line})
when is_atom(From), Line =/= all_line_call -> ok;
conversions(vertex, From, {line, line}) when is_atom(From) -> ok;
conversions(vertex, From, To) when is_atom(From), is_atom(To) -> ok;
conversions(edge, From, To) when is_atom(From), is_atom(To) -> ok;
%% "Extra":
conversions(edge, {line, Line}, To)
when is_atom(To), Line =/= all_line_call -> ok;
conversions(vertex, {line, line}, To) when is_atom(To) -> ok;
conversions(_OType, _From, _To) -> not_ok.
set_op(union, {line, _LineType}, edge) -> family_union;
set_op(intersection, {line, _LineType}, edge) -> family_intersection;
set_op(difference, {line, _LineType}, edge) -> family_difference;
set_op(union, function, vertex) -> family_union;
set_op(intersection, function, vertex) -> family_intersection;
set_op(difference, function, vertex) -> family_difference;
set_op(SOp, _Type, _OType) -> SOp.
set_op(weak) -> weak_relation;
set_op(strict) -> strict_relation;
set_op(Op) -> Op.
ari_op(union) -> fun(X, Y) -> X + Y end;
ari_op(intersection) -> fun(X, Y) -> X * Y end;
ari_op(difference) -> fun(X, Y) -> X - Y end.
restriction(ROp, E1, Type1, NE1, Type2, NE2) ->
{Column, _} = restr_op(ROp),
case NE1 of
{call, union_of_family, _E} when ROp =:= '|' ->
restriction(Column, Type1, E1, Type2, NE2);
{call, union_of_family, _E} when ROp =:= '||' ->
E1p = {inverse, E1},
restriction(Column, Type1, E1p, Type2, NE2);
_ ->
NE2a = {convert, vertex, Type2, Type1, NE2},
NE2b = family_to_function_vertices(Type1, vertex, NE2a),
{expr, Type1, edge, {call, restriction, Column, NE1, NE2b}}
end.
restriction(Column, Type1, VE, Type2, E2) when Type1 =:= function ->
M = {convert, vertex, Type2, module, E2},
Restr = {call, union_of_family, {call, restriction, VE, M}},
C = {convert, vertex, Type2, Type1, E2},
F = family_to_function_vertices(Type1, vertex, C),
{expr, Type1, edge, {call, restriction, Column, Restr, F}}.
closure_restriction(Op, Type1, Type2, OType2, E1, E2) ->
{_, Fun} = restr_op(Op),
E2a = {convert, OType2, Type2, Type1, E2},
E2b = family_to_function_vertices(Type1, vertex, E2a),
{expr, Type1, edge, use_of_closure(Fun, E1, E2b)}.
restr_op('|') -> {1, call};
restr_op('||') -> {2, use}.
%% Closures (digraphs) must be deleted, but not too soon. A wrapper
%% is inserted here for every use of a closure, to make sure that a
%% 'save' and an 'unput' instruction are inserted for every digraph, in
%% particular the temporary ones. The 'unput' instruction must occur
%% _after_ the call to the function that uses the digraph (the default
%% is that it is inserted _before_ the call).
use_of_closure(Op, C) ->
access_of_closure(C, {call, fun(X) -> xref_utils:Op(X) end, C}).
use_of_closure(Op, C, E) ->
access_of_closure(C, {call, fun(X, Y) -> xref_utils:Op(X, Y) end, C, E}).
access_of_closure(C, E) ->
{call, fun graph_access/2, C, E}.
check_constants(Cs=[C={constant, Type0, OType, _Con} | Cs1], Table) ->
check_mix(Cs1, Type0, OType, C),
Types = case Type0 of
unknown -> ['Rel', 'App', 'Mod'];
T -> [T]
end,
case split(Types, Cs, Table) of
[{TypeToBe, _Cs}] ->
S = from_term([Con || {constant, _T, _OT, Con} <- Cs]),
Type = what_type(TypeToBe),
E = function_vertices_to_family(Type, OType, {constants, S}),
{expr, Type, OType, E};
[{Type1, [C1|_]}, {Type2, [C2|_]} | _] ->
throw_error({type_mismatch,
make_vertex(Type1, C1),
make_vertex(Type2, C2)})
end.
check_mix([C={constant, 'Fun', OType, _Con} | Cs], 'Fun', OType, _C0) ->
check_mix(Cs, 'Fun', OType, C);
check_mix([C={constant, Type, OType, _Con} | Cs], Type0, OType, _C0)
when Type =/= 'Fun', Type0 =/= 'Fun' ->
check_mix(Cs, Type, OType, C);
check_mix([C | _], _Type0, _OType0, C0) ->
throw_error({type_mismatch, xref_parser:t2s(C0), xref_parser:t2s(C)});
check_mix([], _Type0, _OType0, _C0) ->
ok.
split(Types, Cs, Table) ->
Vs = from_term(constant_vertices(Cs, [])),
split(Types, Vs, empty_set(), unknown, Table, []).
split([Type | Types], Vs, AllSoFar, _Type, Table, L) ->
S0 = known_vertices(Type, Vs, Table),
S = difference(S0, AllSoFar),
case is_empty_set(S) of
true ->
split(Types, Vs, AllSoFar, Type, Table, L);
false ->
All = union(AllSoFar, S0),
split(Types, Vs, All, Type, Table,
[{Type, to_external(S)} | L])
end;
split([], Vs, All, Type, _Table, L) ->
case to_external(difference(Vs, All)) of
[] -> L;
[C|_] -> throw_error({unknown_constant, make_vertex(Type, C)})
end.
make_vertex(Type, C) ->
xref_parser:t2s({constant, Type, vertex, C}).
constant_vertices([{constant, _Type, edge, {A,B}} | Cs], L) ->
constant_vertices(Cs, [A, B | L]);
constant_vertices([{constant, _Type, vertex, V} | Cs], L) ->
constant_vertices(Cs, [V | L]);
constant_vertices([], L) ->
L.
known_vertices('Fun', Cs, T) ->
M = projection(1, Cs),
F = union_of_family(restriction(fetch_value(v, T), M)),
union(bifs(Cs), intersection(Cs, F));
known_vertices('Mod', Cs, T) ->
intersection(Cs, fetch_value('M', T));
known_vertices('App', Cs, T) ->
intersection(Cs, fetch_value('A', T));
known_vertices('Rel', Cs, T) ->
intersection(Cs, fetch_value('R', T)).
bifs(Cs) ->
specification({external,
fun({M,F,A}) -> xref_utils:is_builtin(M, F, A) end},
Cs).
function_vertices_to_family(function, vertex, E) ->
{call, partition_family, 1, E};
function_vertices_to_family(_Type, _OType, E) ->
E.
family_to_function_vertices(function, vertex, E) ->
{call, union_of_family, E};
family_to_function_vertices(_Type, _OType, E) ->
E.
-define(Q(E), {quote, E}).
convert({inverse, {variable, Variable}}) ->
{get, {inverse, var_name(Variable)}};
convert({variable, Variable}) ->
{get, var_name(Variable)};
convert({convert, FromOType, ToOType, E}) ->
convert(convert(E), FromOType, ToOType);
convert({convert, OType, FromType, ToType, E}) ->
convert(convert(E), OType, FromType, ToType);
convert({call, Op, E}) ->
{Op, convert(E)};
convert({call, Op, E1, E2}) ->
{Op, convert(E1), convert(E2)};
convert({call, Op, E1, E2, E3}) ->
{Op, convert(E1), convert(E2), convert(E3)};
convert({constants, Constants}) ->
?Q(Constants);
convert(I) when is_integer(I) ->
?Q(I).
var_name({predef, VarName}) -> VarName;
var_name(Variable) -> Variable.
convert(E, OType, OType) ->
E;
convert(E, edge, edge_closure) ->
{fun(S) -> xref_utils:closure(S) end, E}.
convert(E, OType, FromType, number) ->
un_familiarize(FromType, OType, E);
convert(E, OType, FromType, ToType) ->
case {type_ord(FromType), type_ord(ToType)} of
{FT, To} when FT =:= To ->
E;
{FT, ToT} when FT > ToT ->
special(OType, FromType, ToType, E);
{FT, ToT} when FT < ToT ->
general(OType, FromType, ToType, E)
end.
-define(T(V), {tmp, V}).
general(_ObjectType, FromType, ToType, X) when FromType =:= ToType ->
X;
general(edge, {line, _LineType}, ToType, LEs) ->
VEs = {projection, ?Q({external, fun({V1V2,_Ls}) -> V1V2 end}), LEs},
general(edge, function, ToType, VEs);
general(edge, function, ToType, VEs) ->
MEs = {projection,
?Q({external, fun({{M1,_,_},{M2,_,_}}) -> {M1,M2} end}),
VEs},
general(edge, module, ToType, MEs);
general(edge, module, ToType, MEs) ->
AEs = {image, {get, me2ae}, MEs},
general(edge, application, ToType, AEs);
general(edge, application, release, AEs) ->
{image, {get, ae}, AEs};
general(vertex, {line, _LineType}, ToType, L) ->
V = {partition_family, ?Q(1), {domain, L}},
general(vertex, function, ToType, V);
general(vertex, function, ToType, V) ->
M = {domain, V},
general(vertex, module, ToType, M);
general(vertex, module, ToType, M) ->
A = {image, {get, m2a}, M},
general(vertex, application, ToType, A);
general(vertex, application, release, A) ->
{image, {get, a2r}, A}.
special(_ObjectType, FromType, ToType, X) when FromType =:= ToType ->
X;
special(edge, {line, _LineType}, {line, all_line_call}, Calls) ->
{put, ?T(mods),
{projection,
?Q({external, fun({{{M1,_,_},{M2,_,_}},_}) -> {M1,M2} end}),
Calls},
{put, ?T(def_at),
{union, {image, {get, def_at},
{union, {domain, {get, ?T(mods)}},
{range, {get, ?T(mods)}}}}},
{fun funs_to_lines/2,
{get, ?T(def_at)}, Calls}}};
special(edge, function, {line, LineType}, VEs) ->
Var = if
LineType =:= line -> call_at;
LineType =:= export_call -> e_call_at;
LineType =:= local_call -> l_call_at;
LineType =:= external_call -> x_call_at
end,
line_edges(VEs, Var);
special(edge, module, ToType, MEs) ->
VEs = {image,
{projection,
?Q({external, fun(FE={{M1,_,_},{M2,_,_}}) -> {{M1,M2},FE} end}),
{union,
{image, {get, e},
{projection, ?Q({external, fun({M1,_M2}) -> M1 end}), MEs}}}},
MEs},
special(edge, function, ToType, VEs);
special(edge, application, ToType, AEs) ->
MEs = {inverse_image, {get, me2ae}, AEs},
special(edge, module, ToType, MEs);
special(edge, release, ToType, REs) ->
AEs = {inverse_image, {get, ae}, REs},
special(edge, application, ToType, AEs);
special(vertex, function, {line, _LineType}, V) ->
{restriction,
{union_of_family, {restriction, {get, def_at}, {domain, V}}},
{union_of_family, V}};
special(vertex, module, ToType, M) ->
V = {restriction, {get, v}, M},
special(vertex, function, ToType, V);
special(vertex, application, ToType, A) ->
M = {inverse_image, {get, m2a}, A},
special(vertex, module, ToType, M);
special(vertex, release, ToType, R) ->
A = {inverse_image, {get, a2r}, R},
special(vertex, application, ToType, A).
line_edges(VEs, CallAt) ->
{put, ?T(ves), VEs,
{put, ?T(m1),
{projection, ?Q({external, fun({{M1,_,_},_}) -> M1 end}),
{get, ?T(ves)}},
{image, {projection, ?Q({external, fun(C={VV,_L}) -> {VV,C} end}),
{union, {image, {get, CallAt}, {get, ?T(m1)}}}},
{get, ?T(ves)}}}}.
%% {(((v1,l1),(v2,l2)),l) :
%% (v1,l1) in DefAt and (v2,l2) in DefAt and ((v1,v2),L) in CallAt}
funs_to_lines(DefAt, CallAt) ->
T1 = multiple_relative_product({DefAt, DefAt}, projection(1, CallAt)),
T2 = composite(substitution(1, T1), CallAt),
Fun = fun({{{V1,V2},{L1,L2}},Ls}) -> {{{V1,L1},{V2,L2}},Ls} end,
projection({external, Fun}, T2).
what_type('Rel') -> release;
what_type('App') -> application;
what_type('Mod') -> module;
what_type('Fun') -> function;
what_type('Lin') -> {line, line};
what_type('LLin') -> {line, local_call};
what_type('XLin') -> {line, external_call};
what_type('ELin') -> {line, export_call};
what_type('XXL') -> {line, all_line_call}.
type_ord({line, all_line_call}) -> 0;
type_ord({line, _LT}) -> 1;
type_ord(function) -> 2;
type_ord(module) -> 3;
type_ord(application) -> 4;
type_ord(release) -> 5.
%% While evaluating, sets of vertices are represented as families.
%% Sets of edges are not families, but plain sets (this might change).
%% Calls (with line numbers) are "straightened" out here, but will be
%% families again shortly, unless just counted.
un_familiarize(function, vertex, E) ->
{union_of_family, E};
un_familiarize({line, _}, edge, E) ->
{family_to_relation, E};
un_familiarize(_Type, _OType, E) ->
E.
%% Expressions are evaluated using a stack and tail recursion.
%% Common subexpressions are evaluated once only, using a table for
%% storing temporary results.
%% (Using a table _and_ a stack is perhaps not a very good way of
%% doing things.)
i(E, Table) ->
Start = 1,
{N, _NE, _NI, NT} = find_nodes(E, Start, dict:new()),
{Vs, UVs0, L} = save_vars(dict:to_list(NT), NT, [], [], []),
VarsToSave = to_external(relation_to_family(relation(Vs))),
Fun = fun({NN,S}, D) ->
dict:store(NN, {extra,S,dict:fetch(NN, D)}, D)
end,
D = foldl(Fun, dict:from_list(L), VarsToSave),
UVs = reverse(sort(UVs0)),
{_D, Is0} = make_instructions(N, UVs, D),
Is = insert_unput(Is0),
?FORMAT("Instructions:~n~p~n~n~n", [Is]),
%% Well, compiles _and_ evaluates...
evaluate(Is, Table, []).
%% Traverses the expression tree in postorder, giving a unique number
%% to each node. A table is created, and common subexpressions found.
find_nodes(E={quote,_}, I, T) ->
find_node(E, I, T);
find_nodes({get, Var}, I, T) ->
find_node({var,Var}, I, T);
find_nodes({put, Var, E1, E2}, I, T) ->
{_NE1_N, NE1, I1, T1} = find_nodes(E1, I, T),
%% Now NE1 is considered used once, which is wrong. Fixed below.
NT = dict:store({var, Var}, NE1, T1),
find_nodes(E2, I1, NT);
find_nodes(Tuple, I, T) when is_tuple(Tuple) ->
[Tag0 | L] = tuple_to_list(Tuple),
Fun = fun(A, {L0, I0, T0}) ->
{NA, _E, NI, NT} = find_nodes(A, I0, T0),
{[NA | L0], NI, NT}
end,
{NL, NI, T1} = foldl(Fun, {[], I, T}, L),
Tag = case Tag0 of
_ when is_function(Tag0) -> Tag0;
_ when is_atom(Tag0) -> {sofs, Tag0}
end,
find_node({apply, Tag, NL}, NI, T1).
find_node(E, I, T) ->
case dict:find(E, T) of
{ok, {reuse, N}} ->
{N, E, I, T};
{ok, N} when is_integer(N) ->
{N, E, I, dict:store(E, {reuse, N}, T)};
{ok, E1} ->
find_node(E1, I, T);
error ->
{I, E, I+1, dict:store(E, I, T)}
end.
%% Creates save instructions for those values (stored on the stack while
%% evaluating) that are to be used after the result has been popped.
save_vars([{I, {reuse,N}} | DL], D, Vs, UVs, L) ->
save_vars(DL, D, [{N, {save, {tmp, N}}} | Vs], UVs, [{N, I} | L]);
save_vars([{I, N} | DL], D, Vs, UVs, L) when is_integer(N) ->
save_vars(DL, D, Vs, UVs, [{N, I} | L]);
save_vars([{{var,V={user,_}}, I} | DL], D, Vs, UVs, L) ->
N = case dict:fetch(I, D) of
{reuse, N0} -> N0;
N0 -> N0
end,
save_vars(DL, D, [{N, {save, V}} | Vs], [N | UVs], L);
save_vars([{{var,{tmp,_}}, _I} | DL], D, Vs, UVs, L) ->
save_vars(DL, D, Vs, UVs, L);
save_vars([], _D, Vs, UVs, L) ->
{Vs, UVs, L}.
%% Traverses the expression again, this time using more or less the
%% inverse of the table created by find_nodes. The first time a node
%% is visited, its children are traversed, the following times a
%% get instructions are inserted (using the saved value).
make_instructions(N, UserVars, D) ->
{D1, Is0} = make_instrs(N, D, []),
%% Assignments the results of which are not used by the final
%% expression are handled here. Instructions are created for user
%% variables only (assignment of a closure is handled properly
%% without further action).
make_more_instrs(UserVars, D1, Is0).
make_more_instrs([UV | UVs], D, Is) ->
case dict:find(UV, D) of
error ->
make_more_instrs(UVs, D, Is);
_Else ->
{ND, NIs} = make_instrs(UV, D, Is),
make_more_instrs(UVs, ND, [pop | NIs])
end;
make_more_instrs([], D, Is) ->
{D, Is}.
make_instrs(N, D, Is) ->
case dict:find(N, D) of
{ok, {extra, Save, Val}} ->
{D1, Is1} = make_instr(Val, D, Is),
{dict:erase(N, D1), Save ++ Is1};
{ok, Val} ->
{D1, Is1} = make_instr(Val, D, Is),
{dict:erase(N, D1), Is1};
error ->
{D, [{get, {tmp, N}} | Is]}
end.
make_instr({var, V}, D, Is) ->
{D, [{get, V} | Is]};
make_instr(Q = {quote, _T}, D, Is) ->
{D, [Q | Is]};
make_instr({apply, MF, Ns}, D, Is) ->
Fun = fun(N, {D0, Is0}) -> make_instrs(N, D0, Is0) end,
{D1, Is1} = foldl(Fun, {D, Is}, Ns),
{D1, [{apply, MF, length(Ns)} | Is1]}.
%% Makes sure that temporary results are removed from the table as soon
%% as they are no longer needed.
%% Assignments may create extra save instructions, which are removed here.
insert_unput(L) ->
insert_unput(L, dict:new(), []).
insert_unput([I={get, V={tmp, _}} | Is], D, L) ->
case dict:find(V, D) of
{ok, _} -> insert_unput(Is, D, [I | L]);
error -> insert_unput(Is, dict:store(V, [], D), [I, {unput, V} | L])
end;
insert_unput([I={save, V={tmp,_}} | Is], D, L) ->
case dict:find(V, D) of
{ok, _} ->
insert_unput(Is, dict:erase(V, D), [I | L]);
error ->
%% Extra save removed.
insert_unput(Is, dict:erase(V, D), L)
end;
insert_unput([I | Is], D, L) ->
insert_unput(Is, D, [I | L]);
insert_unput([], _D, L) ->
L.
graph_access(_G, V) ->
%% _G may have been deleted by an unput already
V.
evaluate([{apply, MF, NoAs} | P], T, S) ->
Args = sublist(S, NoAs),
NewS = nthtail(NoAs, S),
?FORMAT("Applying ~p/~p~n", [MF,NoAs]),
evaluate(P, T, [apply(MF, Args) | NewS]);
evaluate([{quote, Val} | P], T, S) ->
evaluate(P, T, [Val | S]);
evaluate([{get, Var} | P], T, S) when is_atom(Var) -> % predefined
Value = fetch_value(Var, T),
Val = case Value of
{R, _} -> R; % relation
_ -> Value % simple set
end,
evaluate(P, T, [Val | S]);
evaluate([{get, {inverse, Var}} | P], T, S) -> % predefined, inverse
{_, R} = fetch_value(Var, T),
evaluate(P, T, [R | S]);
evaluate([{get, {user, Var}} | P], T, S) ->
Val = fetch_value(Var, T),
evaluate(P, T, [Val | S]);
evaluate([{get, Var} | P], T, S) -> % tmp
evaluate(P, T, [dict:fetch(Var, T) | S]);
evaluate([{save, Var={tmp, _}} | P], T, S=[Val | _]) ->
T1 = update_graph_counter(Val, +1, T),
evaluate(P, dict:store(Var, Val, T1), S);
evaluate([{save, {user, Name}} | P], T, S=[Val | _]) ->
#xref_var{vtype = user, otype = OType, type = Type} = dict:fetch(Name, T),
NewVar = #xref_var{name = Name, value = Val,
vtype = user, otype = OType, type = Type},
T1 = update_graph_counter(Val, +1, T),
NT = dict:store(Name, NewVar, T1),
evaluate(P, NT, S);
evaluate([{unput, Var} | P], T, S) ->
T1 = update_graph_counter(dict:fetch(Var, T), -1, T),
evaluate(P, dict:erase(Var, T1), S);
evaluate([pop | P], T, [_ | S]) ->
evaluate(P, T, S);
evaluate([], T, [R]) ->
{T, R}.
%% (PossibleGraph, 1 | -1, dict()) -> dict()
%% Use the same table for everything... Here: Reference counters for digraphs.
update_graph_counter(Value, Inc, T) ->
case catch digraph:info(Value) of
Info when is_list(Info) ->
case dict:find(Value, T) of
{ok, 1} when Inc =:= -1 ->
true = digraph:delete(Value),
dict:erase(Value, T);
{ok, C} ->
dict:store(Value, C+Inc, T);
error when Inc =:= 1 ->
dict:store(Value, 1, T)
end;
_EXIT ->
T
end.
fetch_value(V, D) ->
#xref_var{value = Value} = dict:fetch(V, D),
Value.
format_parse_error(["invalid_regexp", String, Error], Line) ->
io_lib:format("Invalid regular expression \"~s\"~s: ~s~n",
[String, Line, lists:flatten(Error)]);
format_parse_error(["invalid_regexp_variable", Var], Line) ->
io_lib:format("Invalid wildcard variable ~p~s "
"(only '_' is allowed)~n", [Var, Line]);
format_parse_error(["missing_type", Expr], Line) ->
io_lib:format("Missing type of regular expression ~s~s~n",
[Expr, Line]);
format_parse_error(["type_mismatch", Expr], Line) ->
io_lib:format("Type does not match structure of constant~s: ~s~n",
[Line, Expr]);
format_parse_error(["invalid_operator", Op], Line) ->
io_lib:format("Invalid operator ~p~s~n", [Op, Line]);
format_parse_error(Error, Line) ->
io_lib:format("Parse error~s: ~s~n", [Line, lists:flatten(Error)]).
format_line(-1) ->
" at end of string";
format_line(0) ->
"";
format_line(Line) when is_integer(Line) ->
concat([" on line ", Line]).
throw_error(Reason) ->
throw(error(Reason)).
error(Reason) ->
{error, ?MODULE, Reason}.
