[m-rev.] [reuse] diff+question: change aliasing type
Nancy Mazur
Nancy.Mazur at cs.kuleuven.ac.be
Mon Jun 28 16:55:46 AEST 2004
Zoltan,
in the change below I moved some code that transforms 'aliasing' types back to
strings to prog_data, so that it can be used in the "attributes_to_strings"
procedure. The problem is that in the implementation of these transformation
procedures, I rely on some procedures from module mercury_to_mercury. Hence, I
introduce a circular dependency. I know this is not good, but I don't see a way
to avoid this, unless I transform aliasing-types to bare minimal strings,
instead of the complete user-declared-aliasing?
Any ideas on that?
Nancy
===================================================================
Estimated hours taken: 4
Branches: reuse
Change the type for "aliasing" to be in terms of the public "aliases_domain"
type, instead of the private "alias_as" type. Move the parsing routines for
this type to prog_io_pasr, and the routines to transform them back into
strings to prog_data (needed by attributes_to_strings/3). Adapt all the
procedures handling the aliasing type appropriately. This also means that
procedures for renaming aliases_domain-elements (used within make_hlds). These
procedures are put in prog_io_pasr (which makes the choice for the name
"prog_io_pasr" unfortunate, given that renaming is not related to io).
make_hlds.m:
pa_alias_as.m:
pa_run.m:
prog_data.m:
prog_io_pasr.m:
prog_io_pragma.m:
Index: make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.347.2.25
diff -u -r1.347.2.25 make_hlds.m
--- make_hlds.m 25 Jun 2004 02:33:43 -0000 1.347.2.25
+++ make_hlds.m 28 Jun 2004 06:32:41 -0000
@@ -99,6 +99,7 @@
:- import_module parse_tree__prog_io, parse_tree__prog_io_goal.
:- import_module parse_tree__prog_io_dcg, parse_tree__prog_io_util.
+:- import_module parse_tree__prog_io_pasr.
:- import_module parse_tree__prog_out, parse_tree__mercury_to_mercury.
:- import_module parse_tree__prog_util, parse_tree__inst.
:- import_module parse_tree__modules, parse_tree__module_qual.
@@ -5892,21 +5893,30 @@
rename_aliasing(ActualAliasing, ActualHVs, FormalHVs, FormalTypes,
TVarSet, FormalAliasing):-
ActualAliasing = aliasing(MaybeActualTypes, _, ActualAlias),
-
map__from_corresponding_lists(ActualHVs, FormalHVs, VarMapping),
- pa_alias_as__rename(VarMapping, ActualAlias, Alias0),
(
MaybeActualTypes = yes(ActualTypes)
->
- pa_alias_as__rename_types(ActualTypes, FormalTypes,
- Alias0, FormalAlias),
+ assoc_list__from_corresponding_lists(ActualTypes,
+ FormalTypes, FromToTypes),
+ list__foldl(
+ (pred(P::in, S0::in, S::out) is det :-
+ P = F - T,
+ (
+ term__unify(F, T, S0, S1)
+ -> S = S1
+ ; S = S0
+ )), FromToTypes, map__init, Substitution),
+ MaybeTypeMap = yes(Substitution),
term__vars_list(FormalTypes, FormalTVars),
set__list_to_set(FormalTVars, TSet),
varset__select(TVarSet, TSet, FormalVarSet)
- ;
- FormalAlias = Alias0,
+ ;
+ MaybeTypeMap = no,
FormalVarSet = varset__init
),
+ rename_aliases_domain(VarMapping, MaybeTypeMap, ActualAlias,
+ FormalAlias),
% NB: MaybeActualTypes are not needed after this renaming
FormalAliasing = aliasing(yes(FormalTypes), FormalVarSet, FormalAlias).
Index: pa_alias_as.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/Attic/pa_alias_as.m,v
retrieving revision 1.1.2.41
diff -u -r1.1.2.41 pa_alias_as.m
--- pa_alias_as.m 27 Jun 2004 10:45:25 -0000 1.1.2.41
+++ pa_alias_as.m 28 Jun 2004 06:32:42 -0000
@@ -218,22 +218,6 @@
alias_as::in, alias_as::out) is det.
%-----------------------------------------------------------------------------%
-% Parsing routines.
-%-----------------------------------------------------------------------------%
- % Parse the used declared aliases (pragma aliasing).
- % XXX This routine is definitely on the wrong place and should be moved
- % to parse_tree somewhere, once the aliasing type is defined without
- % the alias_as type.
-:- pred parse_user_declared_aliases(term::in, varset::in,
- aliasing::out) is semidet.
-
- % Reconvert the (parsed) user declared aliasing information to a
- % printable string.
-:- pred to_user_declared_aliases(aliasing::in, prog_varset::in,
- string::out) is det.
-
-%-----------------------------------------------------------------------------%
% Computing the live data structure set using alias information.
% XXX This procedure should go into sr_live by providing a routine to convert
% alias_as types to lists of pairs of data structures.
@@ -680,7 +664,7 @@
:- mode from_foreign_code(in, in, in, in, in, in, in, in, in, out) is det.
from_foreign_code(HLDS, _ProcInfo, PredId, ProcId, GoalInfo, Attrs, Vars,
- MaybeModes, Types, Alias):-
+ MaybeModes, Types, AliasAs):-
module_info_pred_proc_info(HLDS, proc(PredId, ProcId),
_PredInfo, PragmaProcInfo),
(
@@ -691,7 +675,7 @@
% Typecheck the aliasing:
(
proc_info_headvars(PragmaProcInfo, FormalVars),
- typecheck_user_annotated_alias(HLDS, FormalVars,
+ typecheck_user_aliases_domain(HLDS, FormalVars,
Types, UserAlias)
->
Alias = UserAlias
@@ -710,9 +694,10 @@
format_context(Context, ContextStr),
string__append_list(["pragma_foreign_code:",
" (",ContextStr, ")"], Msg),
- pa_alias_as__top(Msg, Alias)
+ Alias = top([Msg])
)
- ).
+ ),
+ from_aliases_domain_to_alias_as(Alias, AliasAs).
predict_bottom_alias(HLDS, Vars, Modes, Types):-
@@ -741,7 +726,7 @@
proc_info_varset(ProcInfo, VarSet),
goal_info_get_context(GoalInfo, Context),
format_context(Context, ContextStr),
- to_user_declared_aliases(Aliasing, VarSet, AliasingString),
+ to_user_declared_aliasing(Aliasing, VarSet, AliasingString),
string__append_list(
["\n", ContextStr,
": Type error in user declared aliasing. \n",
@@ -750,19 +735,20 @@
Msg),
require__error(Msg).
-:- pred typecheck_user_annotated_alias(module_info::in, list(prog_var)::in,
- list(type)::in, alias_as::in) is semidet.
-typecheck_user_annotated_alias(_, _, _, bottom).
-typecheck_user_annotated_alias(_, _, _, top(_)).
-typecheck_user_annotated_alias(ModuleInfo, Vars, Types, real_as(AliasSet)):-
+:- pred typecheck_user_aliases_domain(module_info::in,
+ list(prog_var)::in,
+ list(type)::in, aliases_domain::in) is semidet.
+typecheck_user_aliases_domain(_, _, _, bottom).
+typecheck_user_aliases_domain(_, _, _, top(_)).
+typecheck_user_aliases_domain(ModuleInfo, Vars, Types, real(Aliases)):-
map__from_corresponding_lists(Vars, Types, VarTypes),
- to_pair_alias_list(AliasSet, AliasList),
- typecheck_user_annotated_alias_2(ModuleInfo, VarTypes, AliasList).
-
-:- pred typecheck_user_annotated_alias_2(module_info::in,
- map(prog_var, type)::in, list(alias)::in) is semidet.
-typecheck_user_annotated_alias_2(_, _, []).
-typecheck_user_annotated_alias_2(ModuleInfo, VarTypes, [Alias | Rest]):-
+ list__takewhile(
+ typecheck_user_annotated_alias(ModuleInfo, VarTypes),
+ Aliases, _, []).
+
+:- pred typecheck_user_annotated_alias(module_info::in,
+ map(prog_var, type)::in, alias::in) is semidet.
+typecheck_user_annotated_alias(ModuleInfo, VarTypes, Alias):-
Alias = Data1 - Data2,
type_unify(
type_of_node_with_vartypes(ModuleInfo, VarTypes, Data1),
@@ -770,10 +756,8 @@
[],
map__init,
Substitution),
- map__is_empty(Substitution),
- typecheck_user_annotated_alias_2(ModuleInfo, VarTypes, Rest).
+ map__is_empty(Substitution).
-
:- pred maybe_modes_to_modes(list(maybe(pair(string, mode))), list(mode)).
:- mode maybe_modes_to_modes(in, out) is semidet.
@@ -891,180 +875,6 @@
ASout = ASin
).
-%-----------------------------------------------------------------------------%
-% parsing routines for user declared aliases
-%-----------------------------------------------------------------------------%
-
-parse_user_declared_aliases(term__functor(term__atom("no_aliasing"), [], _),
- _VarSet, Aliasing):-
- pa_alias_as__init(BottomAlias),
- Aliasing = aliasing(no, varset__init, BottomAlias).
-parse_user_declared_aliases(term__functor(term__atom("unknown_aliasing"),
- [], Context), _VarSet, Aliasing):-
- format_context(Context, ContextString),
- string__append_list(["user declared top (", ContextString, ")"], Msg),
- pa_alias_as__top(Msg, TopAlias),
- Aliasing = aliasing(no, varset__init, TopAlias).
-parse_user_declared_aliases(term__functor(term__atom("alias"),
- [TypesTerm,AliasTerm], _), VarSet, Aliasing):-
- (
- TypesTerm = term__functor(term__atom("yes"),
- ListTypesTerms, _),
- term__vars_list(ListTypesTerms, TypeVars),
- set__list_to_set(TypeVars, SetTypeVars),
- varset__select(VarSet, SetTypeVars, TypeVarSet0),
- varset__coerce(TypeVarSet0, TypeVarSet),
-
- list__map(term__coerce, ListTypesTerms, Types),
- MaybeTypes = yes(Types)
- ;
- TypesTerm = term__functor(term__atom("no"),[],_),
- MaybeTypes = no,
- varset__init(TypeVarSet)
- ),
- parse_user_declared_aliases_2(AliasTerm, AliasAs),
- Aliasing = aliasing(MaybeTypes, TypeVarSet, AliasAs).
-
-
-:- pred parse_user_declared_aliases_2(term::in, alias_as::out) is det.
-parse_user_declared_aliases_2(ListTerm, AliasAS):-
- (
- parse_list_term(ListTerm, AllTerms)
- ->
- list__map(parse_single_user_declared_alias,
- AllTerms, AliasList),
- from_pair_alias_list(AliasList, AliasSet),
- wrap(AliasSet, AliasAS)
- ;
- error("(pa_alias_as) parse_user_declared_aliases_2: term not a functor")
- ).
-
-:- pred parse_list_term(term::in, list(term)::out) is semidet.
-parse_list_term(ListTerm, Terms):-
- ListTerm = term__functor(term__atom(Cons), Args, _),
- (
- Cons = "[|]"
- ->
- Args = [FirstTerm, RestTerm],
- parse_list_term(RestTerm, RestList),
- Terms = [FirstTerm | RestList]
- ;
- Cons = "[]"
- ->
- Terms = []
- ;
- fail
- ).
-
-:- pred parse_single_user_declared_alias(term::in, alias::out) is det.
-parse_single_user_declared_alias(Term, Alias):-
- (
- Term = term__functor(term__atom("-"), [Left, Right], _)
- ->
- % Left and Right have shape "cel(ProgVar, Types)"
- parse_user_datastruct(Left, LeftData),
- parse_user_datastruct(Right, RightData),
- Alias = LeftData - RightData
- ;
- error("(pa_alias_as) parse_single_user_declared_alias: wrong functor.")
- ).
-
-:- pred parse_user_datastruct(term::in,
- prog_data__datastruct::out) is det.
-parse_user_datastruct(Term, Data):-
- (
- Term = term__functor(term__atom("cel"),
- [VarTerm, TypesTerm], Context)
- ->
- (
- VarTerm = term__variable(GenericVar),
- term__coerce_var(GenericVar, ProgVar)
- ->
- (
- parse_list_term(TypesTerm, ListTypesTerms)
- ->
- list__map(term__coerce, ListTypesTerms, Types),
- pa_selector__init(Types, Selector),
- pa_datastruct__init(ProgVar, Selector, Data)
- ;
- format_context(Context, ContextString),
- string__append_list([
- "(pa_alias_as) parse_user_datastruct: ",
- "error in declared selector (",
- ContextString, ")"], Msg),
- error(Msg)
-
- )
- ;
- format_context(Context, ContextString),
- string__append_list([
- "(pa_alias_as) parse_user_datastruct: ",
- "error in declared alias (",
- ContextString, ")"], Msg),
- error(Msg)
- )
- ;
- error("(pa_alias_as) parse_user_datastruct: wrong datastructure description -- should be cel/2")
- ).
-
-
-to_user_declared_aliases(aliasing(_, _, bottom), _, "no_aliasing").
-to_user_declared_aliases(aliasing(_, _, top(_)), _, "unknown_aliasing").
-% to_user_declared_aliases(aliasing(_, _, real_as(_)), _, "alias(no, [])").
-% to_user_declared_aliases(aliasing(MaybeTypes, real_as(_)),
-% ProgVarSet, String):-
-to_user_declared_aliases( aliasing(MaybeTypes, TypeVarSet, real_as(AliasSet)),
- ProgVarSet, String):-
- (
- MaybeTypes = yes(Types)
- ->
- TypesString0 = mercury_type_list_to_string(TypeVarSet, Types),
- string__append_list(["yes(", TypesString0, ")"],
- TypesString)
- ;
- TypesString = "no"
- ),
- to_pair_alias_list(AliasSet, AliasList),
- alias_list_to_user_declared_aliases(AliasList,
- ProgVarSet, TypeVarSet, AliasString0),
- string__append_list(["[",AliasString0,"]"], AliasString),
-
- string__append_list(["alias(", TypesString, ", ",
- AliasString, ")"], String).
-
-:- pred alias_list_to_user_declared_aliases(list(alias)::in,
- prog_varset::in, tvarset::in, string::out) is det.
-alias_list_to_user_declared_aliases([], _, _, "").
-alias_list_to_user_declared_aliases([Alias|Rest], ProgVarSet, TypeVarSet,
- String):-
- alias_to_user_declared_alias(Alias, ProgVarSet, TypeVarSet,
- AliasString),
- (
- Rest = []
- ->
- String = AliasString
- ;
- alias_list_to_user_declared_aliases(Rest, ProgVarSet,
- TypeVarSet, RestString),
- string__append_list([AliasString, ", ", RestString],
- String)
- ).
-
-:- pred alias_to_user_declared_alias(alias::in, prog_varset::in,
- tvarset::in, string::out) is det.
-alias_to_user_declared_alias(Alias, ProgVarSet, TypeVarSet, String):-
- Alias = Data0 - Data1,
- prog_io_pasr__to_user_declared_datastruct(ProgVarSet, TypeVarSet,
- Data0, Data0String),
- prog_io_pasr__to_user_declared_datastruct(ProgVarSet, TypeVarSet,
- Data1, Data1String),
- string__append_list([Data0String, " - ", Data1String],
- String).
-
-
-
-%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
% Extra
Index: pa_run.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/Attic/pa_run.m,v
retrieving revision 1.1.2.34
diff -u -r1.1.2.34 pa_run.m
--- pa_run.m 27 Jun 2004 10:06:29 -0000 1.1.2.34
+++ pa_run.m 28 Jun 2004 06:32:43 -0000
@@ -809,6 +809,5 @@
{ pred_info_typevarset(PredInfo, TVarSet) },
print_interface_maybe_aliases_domain(ProgVarSet, TVarSet,
MaybeAliases),
-
io__write_string(").\n").
Index: prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.58.2.19
diff -u -r1.58.2.19 prog_data.m
--- prog_data.m 25 Jun 2004 02:33:51 -0000 1.58.2.19
+++ prog_data.m 28 Jun 2004 06:32:44 -0000
@@ -30,8 +30,6 @@
:- import_module recompilation.
:- import_module bool, list, assoc_list, map, set, varset, term, std_util.
% XXX Dependencies moeten weg!!
-:- import_module possible_alias.
-:- import_module possible_alias__pa_alias_as.
:- import_module structure_reuse.
:- import_module structure_reuse__sr_data.
@@ -485,7 +483,7 @@
% This set is restricted to the head variables
% of the procedure the reuse condition refers
% to.
- alias_headvars :: aliases
+ alias_headvars :: aliases_domain
% The set of aliases existing at the moment
% where the reuse_nodes become dead. These
% aliases are also restricted to the
@@ -721,6 +719,9 @@
pragma_foreign_proc_attributes).
:- mode set_aliasing(in, in, out) is det.
+:- pred to_user_declared_aliasing(aliasing::in, prog_varset::in,
+ string::out) is det.
+
:- pred set_purity(pragma_foreign_proc_attributes, purity,
pragma_foreign_proc_attributes).
:- mode set_purity(in, in, out) is det.
@@ -758,15 +759,15 @@
; tabled_for_io_unitize
; tabled_for_descendant_io.
-% :- type aliasing
-% ---> no_aliasing
-% ; unknown_aliasing.
:- type aliasing
- ---> aliasing(maybe(list(type)), % this is only needed when the
- % user expresses aliases in terms
- % of type-variables.
- tvarset,
- pa_alias_as__alias_as).
+ ---> aliasing(
+ maybe_types:: maybe(list(type)),
+ % this is only needed when the
+ % user expresses aliases in terms
+ % of type-variables.
+ typevarset:: tvarset,
+ aliases:: aliases_domain
+ ).
:- type pragma_var
---> pragma_var(prog_var, string, mode).
@@ -1186,8 +1187,11 @@
:- implementation.
-:- import_module string.
+:- import_module string, require.
:- import_module check_hlds__purity.
+ % XXX circular dependency!
+:- import_module parse_tree__mercury_to_mercury.
+
:- type pragma_foreign_proc_attributes
---> attributes(
@@ -1209,7 +1213,7 @@
default_attributes(Language,
attributes(Language, may_call_mercury, not_thread_safe,
not_tabled_for_io, Aliasing, impure, no, [])):-
- pa_alias_as__top("Default top", TopAlias),
+ TopAlias = top(["Default top"]),
Aliasing = aliasing(no, varset__init, TopAlias).
may_call_mercury(Attrs, Attrs ^ may_call_mercury).
@@ -1280,7 +1284,7 @@
TabledForIO = not_tabled_for_io,
TabledForIOStr = "not_tabled_for_io"
),
- to_user_declared_aliases(Aliasing, ProgVarSet, AliasingStr),
+ to_user_declared_aliasing(Aliasing, ProgVarSet, AliasingStr),
(
Purity = pure,
PurityStrList = ["promise_pure"]
@@ -1304,4 +1308,83 @@
extra_attribute_to_string(max_stack_size(Size)) =
"max_stack_size(" ++ string__int_to_string(Size) ++ ")".
+%-----------------------------------------------------------------------------%
+% Transform to string routines.
+
+:- pred to_user_declared_selector(tvarset::in, selector::in,
+ string::out) is det.
+:- pred to_user_declared_datastruct(prog_varset::in, tvarset::in,
+ datastruct::in, string::out) is det.
+to_user_declared_selector(TVarSet, Selector, String):-
+ (
+ Selector = []
+ ->
+ String = "[]"
+ ;
+ list__map(us_to_user_declared(TVarSet),
+ Selector, SelectorStrings),
+ string__append_list(["[",
+ string__join_list(",", SelectorStrings),
+ "]"], String)
+ ).
+
+:- pred us_to_user_declared(tvarset::in, unit_sel::in, string::out) is det.
+us_to_user_declared(_, ns(_, _), _):-
+ Msg = "(pa_selector) us_to_user_declared, expected type-selectors.",
+ require__error(Msg).
+us_to_user_declared(TVarSet, ts(Type), String) :-
+ String = mercury_type_to_string(TVarSet, Type).
+
+%-----------------------------------------------------------------------------%
+% 2. datastruct.
+to_user_declared_datastruct(ProgVarSet, TypeVarSet, Data, String):-
+ Data = selected_cel(ProgVar, Selector),
+ varset__lookup_name(ProgVarSet, ProgVar, ProgName),
+ to_user_declared_selector(TypeVarSet, Selector,
+ SelectorString),
+ string__append_list(["cel(", ProgName, ", ", SelectorString, ")"],
+ String).
+
+%-----------------------------------------------------------------------------%
+% 3. alias
+:- pred to_user_declared_alias(prog_varset::in, tvarset::in,
+ alias::in, string::out) is det.
+to_user_declared_alias(ProgVarSet, TypeVarSet, Alias, String):-
+ Alias = Data0 - Data1,
+ to_user_declared_datastruct(ProgVarSet, TypeVarSet,
+ Data0, Data0String),
+ to_user_declared_datastruct(ProgVarSet, TypeVarSet,
+ Data1, Data1String),
+ string__append_list([Data0String, " - ", Data1String],
+ String).
+%-----------------------------------------------------------------------------%
+% 3. aliases
+
+:- pred to_user_declared_aliases(prog_varset::in, tvarset::in,
+ list(alias)::in, string::out) is det.
+to_user_declared_aliases(ProgVarSet, TypeVarSet, Aliases, String) :-
+ list__map(to_user_declared_alias(ProgVarSet, TypeVarSet),
+ Aliases, AliasesStrings),
+ string__append_list(["[",
+ string__join_list(",", AliasesStrings),
+ "]"], String).
+
+to_user_declared_aliasing(aliasing(_, _, bottom), _, "no_aliasing").
+to_user_declared_aliasing(aliasing(_, _, top(_)), _, "unknown_aliasing").
+to_user_declared_aliasing(aliasing(MaybeTypes, TypeVarSet, real(Aliases)),
+ ProgVarSet, String):-
+ (
+ MaybeTypes = yes(Types)
+ ->
+ TypesString0 = mercury_type_list_to_string(TypeVarSet, Types),
+ string__append_list(["yes(", TypesString0, ")"],
+ TypesString)
+ ;
+ TypesString = "no"
+ ),
+ to_user_declared_aliases(ProgVarSet, TypeVarSet, Aliases, AliasString),
+ string__append_list(["alias(", TypesString, ", ",
+ AliasString, ")"], String).
+
+
%-----------------------------------------------------------------------------%
Index: prog_io_pasr.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/Attic/prog_io_pasr.m,v
retrieving revision 1.1.2.4
diff -u -r1.1.2.4 prog_io_pasr.m
--- prog_io_pasr.m 27 Jun 2004 10:45:26 -0000 1.1.2.4
+++ prog_io_pasr.m 28 Jun 2004 06:32:44 -0000
@@ -14,8 +14,27 @@
:- import_module parse_tree__prog_data.
-:- import_module io, term, std_util, list.
+:- import_module io, term, std_util, list, varset, map.
+% XXX prog_io_pasr shows to be a bad name, if it also contains procedures to
+% transform the aliases types, like the renaming below.
+%-----------------------------------------------------------------------------%
+% Renaming
+%-----------------------------------------------------------------------------%
+:- pred rename_selector(substitution(tvar_type)::in,
+ selector::in, selector::out) is det.
+:- pred rename_datastruct(map(prog_var, prog_var)::in,
+ maybe(substitution(tvar_type))::in,
+ datastruct::in, datastruct::out) is det.
+:- pred rename_alias(map(prog_var, prog_var)::in,
+ maybe(substitution(tvar_type))::in,
+ alias::in, alias::out) is det.
+:- pred rename_aliases(map(prog_var, prog_var)::in,
+ maybe(substitution(tvar_type))::in,
+ aliases::in, aliases::out) is det.
+:- pred rename_aliases_domain(map(prog_var, prog_var)::in,
+ maybe(substitution(tvar_type))::in,
+ aliases_domain::in, aliases_domain::out) is det.
%-----------------------------------------------------------------------------%
% Printing routines.
%-----------------------------------------------------------------------------%
@@ -65,25 +84,6 @@
maybe(aliases_domain)::in,
io__state::di, io__state::uo) is det.
-
-%-----------------------------------------------------------------------------%
-% Transform to string routines.
-
-% 1. selectors
- % The same as print_selector, yet returns a string instead of printing
- % the result to stdout.
-:- pred selector_to_string(tvarset::in, selector::in, string::out) is det.
-
- % User declared selectors are constrained to type selectors only. Hence
- % this procedure will give an error when a normal selector is
- % encountered.
-:- pred to_user_declared_selector(tvarset::in, selector::in,
- string::out) is det.
-
-% 2. datastructs.
-:- pred to_user_declared_datastruct(prog_varset::in, tvarset::in,
- datastruct::in, string::out) is det.
-
%-----------------------------------------------------------------------------%
% Parsing routines.
%-----------------------------------------------------------------------------%
@@ -100,6 +100,9 @@
:- pred parse_aliases_domain(term(T)::in, aliases_domain::out) is det.
:- pred parse_aliases_domain_from_list(list(term(T))::in,
aliases_domain::out) is det.
+ % Parse the used declared aliases (pragma aliasing).
+:- pred parse_user_declared_aliasing(term::in, varset::in,
+ aliasing::out) is semidet.
:- pred format_context(term__context::in, string::out) is det.
%-----------------------------------------------------------------------------%
@@ -111,9 +114,77 @@
:- import_module parse_tree__mercury_to_mercury.
:- import_module parse_tree__prog_io.
-:- import_module string, require, bool, varset, std_util, int.
+:- import_module string, require, bool, varset, std_util, int, set.
%-----------------------------------------------------------------------------%
+:- pred rename_unit_selector(substitution(tvar_type)::in,
+ unit_sel::in, unit_sel::out) is det.
+rename_unit_selector(Subst, US0, US) :-
+ (
+ US0 = ns(_,_),
+ US = US0
+ ;
+ US0 = ts(Type0),
+ term__apply_substitution(Type0, Subst, Type),
+ US = ts(Type)
+ ).
+rename_selector(TypeSubst, Sel0, Sel) :-
+ list__map(rename_unit_selector(TypeSubst), Sel0, Sel).
+
+rename_datastruct(ProgMap, MaybeTypeSubst, Data0, Data) :-
+ Data0 = selected_cel(Var0, Sel0),
+ map__lookup(ProgMap, Var0, Var),
+ (
+ MaybeTypeSubst = yes(TypeSubst),
+ rename_selector(TypeSubst, Sel0, Sel)
+ ;
+ MaybeTypeSubst = no,
+ Sel = Sel0
+ ),
+ Data = selected_cel(Var, Sel).
+rename_alias(ProgMap, MaybeTypeSubst, A0 - B0, A - B) :-
+ rename_datastruct(ProgMap, MaybeTypeSubst, A0, A),
+ rename_datastruct(ProgMap, MaybeTypeSubst, B0, B).
+
+rename_aliases(ProgMap, MaybeTypeSubst, Aliases0, Aliases) :-
+ list__map(rename_alias(ProgMap, MaybeTypeSubst), Aliases0, Aliases).
+
+rename_aliases_domain(_, _, top(M), top(M)).
+rename_aliases_domain(_, _, bottom, bottom).
+rename_aliases_domain(ProgMap, MaybeTypeSubst, real(Aliases0), real(Aliases)):-
+ rename_aliases(ProgMap, MaybeTypeSubst, Aliases0, Aliases).
+%-----------------------------------------------------------------------------%
+
+:- pred selector_to_string(tvarset::in, selector::in, string::out) is det.
+selector_to_string(TVarSet, Selector, String):-
+ (
+ Selector = []
+ ->
+ String = "[]"
+ ;
+ list__map(us_to_string(TVarSet),
+ Selector, SelectorStrings),
+ string__append_list(["[",
+ string__join_list(",", SelectorStrings),
+ "]"], String)
+ ).
+
+:- pred us_to_string(tvarset::in, unit_sel::in, string::out) is det.
+us_to_string(_, ns(ConsId, Index), StringSelector):-
+ hlds_data__cons_id_arity(ConsId, Arity),
+ string__append_list(["sel(",
+ mercury_cons_id_to_string(ConsId, needs_brackets),
+ ",",
+ int_to_string(Arity),
+ ",",
+ int_to_string(Index),
+ ")"], StringSelector).
+
+us_to_string(TVarSet, ts(TypeSel), StringSelector):-
+ string__append_list(["typesel(",
+ mercury_term_to_string(TypeSel, TVarSet, bool__no),
+ ")"], StringSelector).
+
print_selector(TVarSet, Selector, !IO) :-
selector_to_string(TVarSet, Selector, String),
io__write_string(String, !IO).
@@ -190,7 +261,8 @@
io__write_string("not_available", !IO).
print_interface_maybe_aliases_domain(ProgVarSet, TVarSet, yes(Aliases), !IO) :-
io__write_string("yes(", !IO),
- print_aliases_domain(ProgVarSet, TVarSet, no, Aliases, !IO).
+ print_aliases_domain(ProgVarSet, TVarSet, no, Aliases, !IO),
+ io__write_string(")", !IO).
print_aliases_domain(ProgVarSet, TVarSet, MaybeThreshold, Aliases, !IO) :-
(
@@ -206,67 +278,6 @@
).
%-----------------------------------------------------------------------------%
-to_user_declared_selector(TVarSet, Selector, String):-
- (
- Selector = []
- ->
- String = "[]"
- ;
- list__map(us_to_user_declared(TVarSet),
- Selector, SelectorStrings),
- string__append_list(["[",
- string__join_list(",", SelectorStrings),
- "]"], String)
- ).
-
-selector_to_string(TVarSet, Selector, String):-
- (
- Selector = []
- ->
- String = "[]"
- ;
- list__map(us_to_string(TVarSet),
- Selector, SelectorStrings),
- string__append_list(["[",
- string__join_list(",", SelectorStrings),
- "]"], String)
- ).
-
-:- pred us_to_string(tvarset::in, unit_sel::in, string::out) is det.
-us_to_string(_, ns(ConsId, Index), StringSelector):-
- hlds_data__cons_id_arity(ConsId, Arity),
- string__append_list(["sel(",
- mercury_cons_id_to_string(ConsId, needs_brackets),
- ",",
- int_to_string(Arity),
- ",",
- int_to_string(Index),
- ")"], StringSelector).
-
-us_to_string(TVarSet, ts(TypeSel), StringSelector):-
- string__append_list(["typesel(",
- mercury_term_to_string(TypeSel, TVarSet, bool__no),
- ")"], StringSelector).
-
-:- pred us_to_user_declared(tvarset::in, unit_sel::in, string::out) is det.
-us_to_user_declared(_, ns(_, _), _):-
- Msg = "(pa_selector) us_to_user_declared, expected type-selectors.",
- require__error(Msg).
-us_to_user_declared(TVarSet, ts(Type), String) :-
- String = mercury_type_to_string(TVarSet, Type).
-
-%-----------------------------------------------------------------------------%
-% 2. datastruct.
-to_user_declared_datastruct(ProgVarSet, TypeVarSet, Data, String):-
- Data = selected_cel(ProgVar, Selector),
- varset__lookup_name(ProgVarSet, ProgVar, ProgName),
- to_user_declared_selector(TypeVarSet, Selector,
- SelectorString),
- string__append_list(["cel(", ProgName, ", ", SelectorString, ")"],
- String).
-
-
-%-----------------------------------------------------------------------------%
% Parsing routines.
%-----------------------------------------------------------------------------%
%
@@ -496,3 +507,134 @@
" should be yes/1"], Msg),
error(Msg)
).
+
+:- pred parse_user_declared_datastruct(term::in, datastruct::out) is det.
+parse_user_declared_datastruct(Term, Data):-
+ (
+ Term = term__functor(term__atom("cel"),
+ [VarTerm, TypesTerm], Context)
+ ->
+ (
+ VarTerm = term__variable(GenericVar),
+ term__coerce_var(GenericVar, ProgVar)
+ ->
+ (
+ split_terms(TypesTerm, ListTypesTerms)
+ ->
+ list__map(term__coerce, ListTypesTerms, Types),
+ Data = selected_cel(ProgVar,
+ typeselector_init(Types))
+ ;
+ format_context(Context, ContextString),
+ string__append_list([
+ "(prog_io_pasr) ",
+ "parse_user_declared_datastruct: ",
+ "error in declared selector (",
+ ContextString, ")"], Msg),
+ error(Msg)
+
+ )
+ ;
+ format_context(Context, ContextString),
+ string__append_list([
+ "(prog_io_pasr) ",
+ "parse_user_declared_datastruct: ",
+ "error in declared alias (",
+ ContextString, ")"], Msg),
+ error(Msg)
+ )
+ ;
+ string__append_list(["(prog_io_pasr) ",
+ "parse_user_datastruct: ",
+ "wrong datastructure description ",
+ "-- should be cel/2"], Msg),
+ error(Msg)
+ ).
+
+:- pred parse_user_declared_alias(term::in, alias::out) is det.
+parse_user_declared_alias(Term, Alias):-
+ (
+ Term = term__functor(term__atom("-"), [Left, Right], _)
+ ->
+ % Left and Right have shape "cel(ProgVar, Types)"
+ parse_user_declared_datastruct(Left, LeftData),
+ parse_user_declared_datastruct(Right, RightData),
+ Alias = LeftData - RightData
+ ;
+ string__append_list(["(prog_io_pasr) ",
+ "parse_user_declared_alias: ",
+ "wrong functor."], Msg),
+ error(Msg)
+ ).
+
+:- pred parse_user_declared_aliases(term::in, aliases_domain::out) is det.
+parse_user_declared_aliases(ListTerm, AliasDomain):-
+ (
+ split_terms(ListTerm, AllTerms)
+ ->
+ list__map(parse_user_declared_alias,
+ AllTerms, Aliases),
+ AliasDomain = real(Aliases)
+ ;
+ string__append_list(["(prog_io_pasr) ",
+ "parse_user_declared_aliases: ",
+ "term not a functor."], Msg),
+ error(Msg)
+ ).
+
+:- pred split_terms(term::in, list(term)::out) is semidet.
+split_terms(ListTerm, Terms):-
+ ListTerm = term__functor(term__atom(Cons), Args, _),
+ (
+ Cons = "[|]"
+ ->
+ Args = [FirstTerm, RestTerm],
+ split_terms(RestTerm, RestList),
+ Terms = [FirstTerm | RestList]
+ ;
+ Cons = "[]"
+ ->
+ Terms = []
+ ;
+ fail
+ ).
+
+ % bottom
+parse_user_declared_aliasing(term__functor(term__atom("no_aliasing"), [], _),
+ _VarSet, Aliasing):-
+ Aliasing = aliasing(no, varset__init, bottom).
+ % top
+parse_user_declared_aliasing(term__functor(term__atom("unknown_aliasing"),
+ [], Context), _VarSet, Aliasing):-
+ format_context(Context, ContextString),
+ string__append_list(["user declared top (", ContextString, ")"], Msg),
+ TopAlias = top([Msg]),
+ Aliasing = aliasing(no, varset__init, TopAlias).
+parse_user_declared_aliasing(term__functor(term__atom("alias"),
+ [TypesTerm,AliasTerm], _), VarSet, Aliasing):-
+ (
+ TypesTerm = term__functor(term__atom("yes"),
+ ListTypesTerms, _),
+ term__vars_list(ListTypesTerms, TypeVars),
+ set__list_to_set(TypeVars, SetTypeVars),
+ varset__select(VarSet, SetTypeVars, TypeVarSet0),
+ varset__coerce(TypeVarSet0, TypeVarSet),
+
+ list__map(term__coerce, ListTypesTerms, Types),
+ MaybeTypes = yes(Types)
+ ;
+ TypesTerm = term__functor(term__atom("no"),[],_),
+ MaybeTypes = no,
+ varset__init(TypeVarSet)
+ ),
+ parse_user_declared_aliases(AliasTerm, AliasAs),
+ Aliasing = aliasing(MaybeTypes, TypeVarSet, AliasAs).
+
+
+:- func typeselector_init(list(type)) = selector.
+typeselector_init(Types) = Selector :-
+ list__map(
+ pred(T::in, US::out) is det :-
+ US = ts(T),
+ Types,
+ Selector).
Index: prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.23.2.17
diff -u -r1.23.2.17 prog_io_pragma.m
--- prog_io_pragma.m 27 Jun 2004 10:45:26 -0000 1.23.2.17
+++ prog_io_pragma.m 28 Jun 2004 06:32:46 -0000
@@ -1413,7 +1413,7 @@
:- mode parse_aliasing(in, in, out) is semidet.
parse_aliasing(Term, VarSet, Aliasing):-
- pa_alias_as__parse_user_declared_aliases(Term, VarSet, Aliasing).
+ prog_io_pasr__parse_user_declared_aliasing(Term, VarSet, Aliasing).
:- pred parse_max_stack_size(term::in, int::out) is semidet.
--
nancy.mazur at cs.kuleuven.ac.be ------------ Katholieke Universiteit Leuven -
tel: +32-16-327596 - fax: +32-16-327996 ------- Dept. of Computer Science -
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list