diff - module qualified cons_ids
Simon TAYLOR
stayl at students.cs.mu.oz.au
Sat Feb 15 18:19:35 AEDT 1997
Hi Fergus,
This diff implements module qualification of cons_ids.
Simon
Estimated hours taken: 15
Module qualification of constructors.
compiler/modes.m
compiler/unique_modes.m
compiler/modecheck_unify.m
compiler/modecheck_call.m
Enable propagate_type_info_into_modes.
Use type information to module qualify cons_ids.
compiler/mode_util.m
Use propagate_type_information_into_modes to module qualify cons_ids
in bound insts.
typed_ground/2 and free/1 insts are not yet generated.
Avoid expanding insts when propagating type information, since
that is not yet useful.
I still need to fix the handling of
inst_matches_{initial, final, binding}(
ground(_, _), bound(_, [all_functors_in_the_type]))
compiler/typecheck.m
Don't assume a module qualified cons_id is a function call
or higher-order pred constant.
compiler/modes.m
compiler/unique_modes.m
compiler/modecheck_unify.m
compiler/instmap.m
compiler/inst_match.m
Remove some unnecessary conversion between cons_ids and consts.
compiler/typecheck.m
compiler/mode_errors.m
Strip builtin qualifiers from cons_ids.
compiler/mercury_to_mercury.m
Output module qualified cons_ids.
compiler/prog_io.m
compiler/prog_io_util.m
Module qualify constructors in type definitions.
Parse qualified cons_ids in bound insts.
compiler/hlds_data.m
Remove cons_id_to_const/3, since it doesn't make much sense any more.
Add cons_id_arity/2 and cons_id_and_args_to_term/3.
compiler/det_util.m
Handle module qualified cons_ids in det_util__interpret_unify.
compiler/code_util.m
Remove some dead code in code_util__cons_id_to_tag to do with
tags for higher-order terms.
compiler/polymorphism.m
Module qualify type_info cons_ids.
Index: compiler/base_type_layout.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/base_type_layout.m,v
retrieving revision 1.10
diff -u -r1.10 base_type_layout.m
--- base_type_layout.m 1997/02/04 01:22:12 1.10
+++ base_type_layout.m 1997/02/12 00:34:42
@@ -914,8 +914,8 @@
base_type_layout__get_cons_args(LayoutInfo, ConsId, TypeArgs) :-
base_type_layout__get_cons_table(LayoutInfo, ConsTable),
base_type_layout__get_type_id(LayoutInfo, TypeId),
- map__lookup(ConsTable, ConsId, HldsConsList),
(
+ map__search(ConsTable, ConsId, HldsConsList),
list__filter(lambda([X::in] is semidet, (
X = hlds__cons_defn(_, TypeId, _))),
HldsConsList,
Index: compiler/code_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/code_util.m,v
retrieving revision 1.78
diff -u -r1.78 code_util.m
--- code_util.m 1997/01/29 00:47:46 1.78
+++ code_util.m 1997/02/12 03:34:39
@@ -639,53 +639,16 @@
code_util__cons_id_to_tag(pred_const(P,M), _, _, pred_closure_tag(P,M)).
code_util__cons_id_to_tag(base_type_info_const(M,T,A), _, _,
base_type_info_constant(M,T,A)).
-code_util__cons_id_to_tag(cons(qualified(_, _), _), _, _, _) :-
- % should have been transformed into a function call or pred_const.
- error("code_util__cons_id_to_tag - qualified cons_id").
-code_util__cons_id_to_tag(cons(unqualified(Name), Arity),
- Type, ModuleInfo, Tag) :-
+code_util__cons_id_to_tag(cons(Name, Arity), Type, ModuleInfo, Tag) :-
(
% handle the `character' type specially
Type = term__functor(term__atom("character"), [], _),
- string__char_to_string(Char, Name)
+ Name = unqualified(ConsName),
+ string__char_to_string(Char, ConsName)
->
char__to_int(Char, CharCode),
Tag = int_constant(CharCode)
;
- % handle higher-order types specially
- type_is_higher_order(Type, PredOrFunc, PredArgTypes)
- ->
- list__length(PredArgTypes, PredArity),
- module_info_get_predicate_table(ModuleInfo, PredicateTable),
- TotalArity is Arity + PredArity,
- (
- predicate_table_search_pf_name_arity(
- PredicateTable, PredOrFunc, Name, TotalArity,
- PredIds)
- ->
- ( PredIds = [PredId] ->
- predicate_table_get_preds(PredicateTable,
- Preds),
- map__lookup(Preds, PredId, PredInfo),
- pred_info_procedures(PredInfo, Procs),
- map__keys(Procs, ProcIds),
- ( ProcIds = [ProcId] ->
- Tag = pred_closure_tag(PredId, ProcId)
- ;
- error("sorry, not implemented: taking address of predicate or function with multiple modes")
- )
- ;
- % cons_id ought to include the module
- % prefix, so that we could use
- % predicate_table__search_pf_m_n_a to
- % prevent this from happening
- error("code_util__cons_id_to_tag: ambiguous pred or func")
- )
- ;
- % the type-checker should ensure that this never happens
- error("code_util__cons_id_to_tag: invalid pred or func")
- )
- ;
% Use the type to determine the type_id
( type_to_type_id(Type, TypeId0, _) ->
TypeId = TypeId0
@@ -710,7 +673,7 @@
)
),
% Finally look up the cons_id in the table
- map__lookup(ConsTable, cons(unqualified(Name), Arity), Tag)
+ map__lookup(ConsTable, cons(Name, Arity), Tag)
).
%-----------------------------------------------------------------------------%
Index: compiler/det_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/det_util.m,v
retrieving revision 1.7
diff -u -r1.7 det_util.m
--- det_util.m 1997/01/20 03:27:07 1.7
+++ det_util.m 1997/02/10 03:54:08
@@ -111,12 +111,9 @@
interpret_unify(X, var(Y), Subst0, Subst) :-
term__unify(term__variable(X), term__variable(Y), Subst0, Subst).
interpret_unify(X, functor(ConsId, ArgVars), Subst0, Subst) :-
- term__context_init(Context),
term__var_list_to_term_list(ArgVars, ArgTerms),
- cons_id_to_const(ConsId, Functor, _),
- term__unify(term__variable(X),
- term__functor(Functor, ArgTerms, Context),
- Subst0, Subst).
+ cons_id_and_args_to_term(ConsId, ArgTerms, RhsTerm),
+ term__unify(term__variable(X), RhsTerm, Subst0, Subst).
interpret_unify(_X, lambda_goal(_PredOrFunc, _LambdaVars, _Modes, _Det, _Goal),
Subst0, Subst) :-
% For ease of implementation we just ignore unifications with
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_data.m,v
retrieving revision 1.10
diff -u -r1.10 hlds_data.m
--- hlds_data.m 1996/11/04 06:25:39 1.10
+++ hlds_data.m 1997/02/15 03:33:55
@@ -57,13 +57,17 @@
% Various predicates for accessing the cons_id type.
- % Given a cons_id, convert it into a const (from term.m) and
- % an integer arity. Fails if the cons_id is not representable
- % as a const (for example, if it is a higher-order pred constant
- % or an address constant or has a module qualifier).
+ % Given a cons_id and a list of argument terms, convert it into a
+ % term. Fails for compiler generated cons_ids.
-:- pred cons_id_to_const(cons_id, const, arity).
-:- mode cons_id_to_const(in, out, out) is semidet.
+:- pred cons_id_and_args_to_term(cons_id, list(term), term).
+:- mode cons_id_and_args_to_term(in, in, out) is semidet.
+
+ % Get the arity of a cons_id, aborting on compiler-generated
+ % cons_ids.
+
+:- pred cons_id_arity(cons_id, arity).
+:- mode cons_id_arity(in, out) is det.
% The reverse conversion - make a cons_id for a functor.
% Given a const and an arity for the functor, create a cons_id.
@@ -78,25 +82,82 @@
:- pred make_cons_id(sym_name, list(constructor_arg), type_id, cons_id).
:- mode make_cons_id(in, in, in, out) is det.
+:- pred cons_table_insert(cons_table, cons_id, hlds__cons_defn, cons_table).
+:- mode cons_table_insert(in, in, in, out) is det.
+
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module require.
+:- import_module prog_util.
+:- import_module require, std_util.
- % Module qualified cons_ids can't be converted to consts.
-cons_id_to_const(cons(unqualified(Name), Arity), term__atom(Name), Arity).
-cons_id_to_const(int_const(Int), term__integer(Int), 0).
-cons_id_to_const(string_const(String), term__string(String), 0).
-cons_id_to_const(float_const(Float), term__float(Float), 0).
+cons_id_and_args_to_term(int_const(Int), [], Term) :-
+ term__context_init(Context),
+ Term = term__functor(term__integer(Int), [], Context).
+cons_id_and_args_to_term(float_const(Float), [], Term) :-
+ term__context_init(Context),
+ Term = term__functor(term__float(Float), [], Context).
+cons_id_and_args_to_term(string_const(String), [], Term) :-
+ term__context_init(Context),
+ Term = term__functor(term__string(String), [], Context).
+cons_id_and_args_to_term(cons(SymName, _Arity), Args, Term) :-
+ construct_qualified_term(SymName, Args, Term).
+
+cons_id_arity(cons(_, Arity), Arity).
+cons_id_arity(int_const(_), 0).
+cons_id_arity(string_const(_), 0).
+cons_id_arity(float_const(_), 0).
+cons_id_arity(pred_const(_, _), _) :-
+ error("cons_id_arity: can't get arity of pred_const").
+cons_id_arity(code_addr_const(_, _), _) :-
+ error("cons_id_arity: can't get arity of code_addr_const").
+cons_id_arity(base_type_info_const(_, _, _), _) :-
+ error("cons_id_arity: can't get arity of base_type_info_const").
make_functor_cons_id(term__atom(Name), Arity, cons(unqualified(Name), Arity)).
make_functor_cons_id(term__integer(Int), _, int_const(Int)).
make_functor_cons_id(term__string(String), _, string_const(String)).
make_functor_cons_id(term__float(Float), _, float_const(Float)).
-make_cons_id(SymName, Args, _TypeId, cons(SymName, Arity)) :-
+make_cons_id(SymName0, Args, TypeId, cons(SymName, Arity)) :-
+ (
+ SymName0 = unqualified(ConsName),
+ (
+ TypeId = unqualified(_) - _,
+ SymName = SymName0
+ ;
+ TypeId = qualified(TypeModule, _) - _,
+ SymName = qualified(TypeModule, ConsName)
+ )
+ ;
+ SymName0 = qualified(_, _),
+ SymName = SymName0
+ ),
list__length(Args, Arity).
+
+cons_table_insert(ConsTable0, ConsId, ConsDefn, ConsTable) :-
+ ( ConsId = cons(qualified(_, ConsName), Arity) ->
+ % Add both the qualified and unqualified versions of
+ % the cons_id to the table.
+ UnqualifiedConsId = cons(unqualified(ConsName), Arity),
+ add_cons_defn(ConsTable0, UnqualifiedConsId,
+ ConsDefn, ConsTable1),
+ add_cons_defn(ConsTable1, ConsId, ConsDefn, ConsTable)
+ ;
+ error("cons_table_insert: invalid cons_id")
+ ).
+
+:- pred add_cons_defn(cons_table, cons_id, hlds__cons_defn, cons_table).
+:- mode add_cons_defn(in, in, in, out) is det.
+
+add_cons_defn(ConsTable0, ConsId, ConsDefn, ConsTable) :-
+ ( map__search(ConsTable0, ConsId, ConsDefns0) ->
+ ConsDefns = [ConsDefn | ConsDefns0]
+ ;
+ ConsDefns = [ConsDefn]
+ ),
+ map__set(ConsTable0, ConsId, ConsDefns, ConsTable).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_pred.m,v
retrieving revision 1.24
diff -u -r1.24 hlds_pred.m
--- hlds_pred.m 1997/02/02 13:09:36 1.24
+++ hlds_pred.m 1997/02/13 23:24:44
@@ -765,13 +765,12 @@
proc_info_get_initial_instmap(ProcInfo, ModuleInfo, InstMap) :-
proc_info_headvars(ProcInfo, HeadVars),
proc_info_argmodes(ProcInfo, ArgModes),
- mode_list_get_initial_insts(ArgModes, ModuleInfo, InitialInsts),
-/***********
+ mode_list_get_initial_insts(ArgModes, ModuleInfo, InitialInsts0),
% propagate type information into the modes
proc_info_vartypes(ProcInfo, VarTypes),
- propagate_type_info_inst_list(VarTypes, ModuleInfo, InitialInsts0,
+ map__apply_to_list(HeadVars, VarTypes, ArgTypes),
+ propagate_type_info_inst_list(ArgTypes, ModuleInfo, InitialInsts0,
InitialInsts),
-***********/
assoc_list__from_corresponding_lists(HeadVars, InitialInsts, InstAL),
instmap__from_assoc_list(InstAL, InstMap).
Index: compiler/inst_match.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/inst_match.m,v
retrieving revision 1.26
diff -u -r1.26 inst_match.m
--- inst_match.m 1997/01/25 13:45:51 1.26
+++ inst_match.m 1997/02/13 00:51:48
@@ -124,7 +124,7 @@
% Compute the inst that results from abstractly unifying two variables.
-:- pred abstractly_unify_inst_functor(is_live, inst, const, list(inst),
+:- pred abstractly_unify_inst_functor(is_live, inst, cons_id, list(inst),
list(is_live), unify_is_real, module_info,
inst, module_info).
:- mode abstractly_unify_inst_functor(in, in, in, in, in, in, in, out, out)
@@ -1266,10 +1266,8 @@
% unifies a variable (or rather, it's instantiatedness)
% with a functor.
-abstractly_unify_inst_functor(Live, InstA, Name, ArgInsts, ArgLives,
+abstractly_unify_inst_functor(Live, InstA, ConsId, ArgInsts, ArgLives,
Real, ModuleInfo0, Inst, ModuleInfo) :-
- list__length(ArgInsts, Arity),
- make_functor_cons_id(Name, Arity, ConsId),
inst_expand(ModuleInfo0, InstA, InstA2),
abstractly_unify_inst_functor_2(Live, InstA2, ConsId, ArgInsts,
ArgLives, Real, ModuleInfo0, Inst, ModuleInfo).
Index: compiler/instmap.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/instmap.m,v
retrieving revision 1.5
diff -u -r1.5 instmap.m
--- instmap.m 1997/01/20 03:27:25 1.5
+++ instmap.m 1997/02/13 00:53:17
@@ -137,8 +137,7 @@
:- mode instmap_delta_set(in, in, in, out) is det.
% Bind a variable in an instmap to a functor at the beginning
- % of a case in a switch.
- % (note: cons_id_to_const must succeed given the cons_id).
+ % of a case in a switch. Aborts on compiler generated cons_ids.
:- pred instmap_delta_bind_var_to_functor(var, cons_id, instmap,
instmap_delta, instmap_delta, module_info, module_info).
:- mode instmap_delta_bind_var_to_functor(in, in, in, in, out, in, out) is det.
@@ -408,15 +407,11 @@
:- mode bind_inst_to_functor(in, in, out, in, out) is det.
bind_inst_to_functor(Inst0, ConsId, Inst, ModuleInfo0, ModuleInfo) :-
- ( cons_id_to_const(ConsId, Name1, Arity) ->
- list__duplicate(Arity, dead, ArgLives),
- list__duplicate(Arity, free, ArgInsts),
- Name = Name1
- ;
- error("bind_inst_to_functor: cons_id to const failed")
- ),
+ cons_id_arity(ConsId, Arity),
+ list__duplicate(Arity, dead, ArgLives),
+ list__duplicate(Arity, free, ArgInsts),
(
- abstractly_unify_inst_functor(dead, Inst0, Name, ArgInsts,
+ abstractly_unify_inst_functor(dead, Inst0, ConsId, ArgInsts,
ArgLives, real_unify, ModuleInfo0, Inst1, ModuleInfo1)
->
ModuleInfo = ModuleInfo1,
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/make_hlds.m,v
retrieving revision 1.218
diff -u -r1.218 make_hlds.m
--- make_hlds.m 1997/02/02 13:00:16 1.218
+++ make_hlds.m 1997/02/12 00:35:47
@@ -916,12 +916,11 @@
hlds_out__write_type_id(TypeId),
io__write_string("' multiply defined.\n"),
io__set_exit_status(1),
- io__set_output_stream(OldStream, _),
- { ConsDefns2 = ConsDefns1 }
+ io__set_output_stream(OldStream, _)
;
- { ConsDefns2 = [ConsDefn | ConsDefns1] }
+ []
),
- { map__set(Ctors0, ConsId, ConsDefns2, Ctors1) },
+ { cons_table_insert(Ctors0, ConsId, ConsDefn, Ctors1) },
ctors_add(Rest, TypeId, Context, Ctors1, Ctors).
%---------------------------------------------------------------------------%
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.93
diff -u -r1.93 mercury_to_mercury.m
--- mercury_to_mercury.m 1997/01/27 22:22:25 1.93
+++ mercury_to_mercury.m 1997/02/11 12:59:15
@@ -81,6 +81,9 @@
:- pred mercury_output_inst(inst, varset, io__state, io__state).
:- mode mercury_output_inst(in, in, di, uo) is det.
+:- pred mercury_output_cons_id(cons_id, bool, io__state, io__state).
+:- mode mercury_output_cons_id(in, in, di, uo) is det.
+
:- pred mercury_output_inst_list(list(inst), varset, io__state, io__state).
:- mode mercury_output_inst_list(in, in, di, uo) is det.
@@ -535,15 +538,10 @@
mercury_output_bound_insts([], _) --> [].
mercury_output_bound_insts([functor(ConsId, Args) | BoundInsts], VarSet) -->
- { cons_id_to_const(ConsId, Name0, _Arity) ->
- Name = Name0
- ;
- error("mercury_output_bound_insts: cons_id_to_const failed")
- },
( { Args = [] } ->
- mercury_output_bracketed_constant(Name)
+ mercury_output_cons_id(ConsId, yes)
;
- term_io__write_constant(Name),
+ mercury_output_cons_id(ConsId, no),
io__write_string("("),
mercury_output_inst_list(Args, VarSet),
io__write_string(")")
@@ -554,6 +552,25 @@
io__write_string(" ; "),
mercury_output_bound_insts(BoundInsts, VarSet)
).
+
+mercury_output_cons_id(cons(Name, _), Bracketed) -->
+ ( { Bracketed = yes } ->
+ mercury_output_bracketed_sym_name(Name)
+ ;
+ mercury_output_sym_name(Name)
+ ).
+mercury_output_cons_id(int_const(X), _) -->
+ io__write_int(X).
+mercury_output_cons_id(float_const(X), _) -->
+ io__write_float(X).
+mercury_output_cons_id(string_const(X), _) -->
+ io__write_strings(["""", X, """"]).
+mercury_output_cons_id(pred_const(_, _), _) -->
+ { error("mercury_output_cons_id: pred_const") }.
+mercury_output_cons_id(code_addr_const(_, _), _) -->
+ { error("mercury_output_cons_id: code_addr_const") }.
+mercury_output_cons_id(base_type_info_const(_, _, _), _) -->
+ { error("mercury_output_cons_id: base_type_info_const") }.
:- mercury_output_mode_defn(_, X, _, _, _) when X. % NU-Prolog indexing.
Index: compiler/mode_errors.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mode_errors.m,v
retrieving revision 1.41
diff -u -r1.41 mode_errors.m
--- mode_errors.m 1996/12/30 11:31:07 1.41
+++ mode_errors.m 1997/02/14 01:44:57
@@ -70,7 +70,7 @@
% a negated context
; mode_error_unify_var_var(var, var, inst, inst)
% attempt to unify two free variables
- ; mode_error_unify_var_functor(var, const, list(var),
+ ; mode_error_unify_var_functor(var, cons_id, list(var),
inst, list(inst))
% attempt to unify a free var with a functor containing
% free arguments
@@ -95,7 +95,7 @@
:- type mode_error_unify_rhs
---> error_at_var(var)
- ; error_at_functor(const, list(var))
+ ; error_at_functor(cons_id, list(var))
; error_at_lambda(list(var), list(mode)).
:- type mode_error_info
@@ -311,7 +311,7 @@
io__write_string(" `"),
mercury_output_var(Var, VarSet, no),
io__write_string("' :: "),
- mercury_output_inst_list(Insts, InstVarSet),
+ output_inst_list(Insts, InstVarSet),
io__write_string(".\n"),
write_merge_error_list(Errors, ModeInfo).
@@ -341,11 +341,11 @@
io__write_string(" Variable `"),
mercury_output_var(Var, VarSet, no),
io__write_string("' has instantiatedness `"),
- mercury_output_inst(VarInst, InstVarSet),
+ output_inst(VarInst, InstVarSet),
io__write_string("',\n"),
prog_out__write_context(Context),
io__write_string(" expected instantiatedness was `"),
- mercury_output_inst(Inst, InstVarSet),
+ output_inst(Inst, InstVarSet),
io__write_string("'.\n"),
globals__io_lookup_bool_option(verbose_errors, VerboseErrors),
( { VerboseErrors = yes } ->
@@ -377,7 +377,7 @@
io__write_string("'\n"),
prog_out__write_context(Context),
io__write_string(" have insts `"),
- mercury_output_inst_list(Insts, InstVarSet),
+ output_inst_list(Insts, InstVarSet),
io__write_string("',\n"),
prog_out__write_context(Context),
io__write_string(" which does not match any of the modes for "),
@@ -405,7 +405,7 @@
io__write_string(" mode error: variable `"),
mercury_output_var(Var, VarSet, no),
io__write_string("' has instantiatedness `"),
- mercury_output_inst(VarInst, InstVarSet),
+ output_inst(VarInst, InstVarSet),
io__write_string("',\n"),
prog_out__write_context(Context),
( { PredOrFunc = predicate },
@@ -445,11 +445,11 @@
io__write_string(" mode error: variable `"),
mercury_output_var(Var, VarSet, no),
io__write_string("' has instantiatedness `"),
- mercury_output_inst(VarInst, InstVarSet),
+ output_inst(VarInst, InstVarSet),
io__write_string("',\n"),
prog_out__write_context(Context),
io__write_string(" expected instantiatedness was `"),
- mercury_output_inst(Inst, InstVarSet),
+ output_inst(Inst, InstVarSet),
io__write_string("'.\n").
:- pred report_mode_error_implied_mode(mode_info, var, inst, inst,
@@ -472,11 +472,11 @@
io__write_string(" Variable `"),
mercury_output_var(Var, VarSet, no),
io__write_string("' has instantiatedness `"),
- mercury_output_inst(VarInst, InstVarSet),
+ output_inst(VarInst, InstVarSet),
io__write_string("',\n"),
prog_out__write_context(Context),
io__write_string(" expected instantiatedness was `"),
- mercury_output_inst(Inst, InstVarSet),
+ output_inst(Inst, InstVarSet),
io__write_string("'.\n")
;
[]
@@ -509,8 +509,8 @@
{ RHS = error_at_var(Y) },
mercury_output_var(Y, VarSet, no)
;
- { RHS = error_at_functor(Const, ArgVars) },
- hlds_out__write_functor(Const, ArgVars, VarSet, no)
+ { RHS = error_at_functor(ConsId, ArgVars) },
+ hlds_out__write_functor_cons_id(ConsId, ArgVars, VarSet, no)
;
{ RHS = error_at_lambda(ArgVars, ArgModes) },
io__write_string("lambda(["),
@@ -565,13 +565,13 @@
io__write_string(" Variable `"),
mercury_output_var(X, VarSet, no),
io__write_string("' has instantiatedness `"),
- mercury_output_inst(InstX, InstVarSet),
+ output_inst(InstX, InstVarSet),
io__write_string("',\n"),
prog_out__write_context(Context),
io__write_string(" variable `"),
mercury_output_var(Y, VarSet, no),
io__write_string("' has instantiatedness `"),
- mercury_output_inst(InstY, InstVarSet),
+ output_inst(InstY, InstVarSet),
io__write_string("'.\n").
%-----------------------------------------------------------------------------%
@@ -594,21 +594,21 @@
io__write_string(" Variable `"),
mercury_output_var(X, VarSet, no),
io__write_string("' has instantiatedness `"),
- mercury_output_inst(InstX, InstVarSet),
+ output_inst(InstX, InstVarSet),
io__write_string("',\n"),
prog_out__write_context(Context),
io__write_string(" lambda expression has instantiatedness `"),
- mercury_output_inst(InstY, InstVarSet),
+ output_inst(InstY, InstVarSet),
io__write_string("'.\n").
%-----------------------------------------------------------------------------%
-:- pred report_mode_error_unify_var_functor(mode_info, var, const, list(var),
+:- pred report_mode_error_unify_var_functor(mode_info, var, cons_id, list(var),
inst, list(inst), io__state, io__state).
:- mode report_mode_error_unify_var_functor(mode_info_ui, in, in, in, in, in,
di, uo) is det.
-report_mode_error_unify_var_functor(ModeInfo, X, Name, Args, InstX, ArgInsts)
+report_mode_error_unify_var_functor(ModeInfo, X, ConsId, Args, InstX, ArgInsts)
-->
{ mode_info_get_context(ModeInfo, Context) },
{ mode_info_get_varset(ModeInfo, VarSet) },
@@ -618,28 +618,28 @@
io__write_string(" mode error in unification of `"),
mercury_output_var(X, VarSet, no),
io__write_string("' and `"),
- hlds_out__write_functor(Name, Args, VarSet, no),
+ hlds_out__write_functor_cons_id(ConsId, Args, VarSet, no),
io__write_string("'.\n"),
prog_out__write_context(Context),
io__write_string(" Variable `"),
mercury_output_var(X, VarSet, no),
io__write_string("' has instantiatedness `"),
- mercury_output_inst(InstX, InstVarSet),
+ output_inst(InstX, InstVarSet),
io__write_string("',\n"),
prog_out__write_context(Context),
io__write_string(" term `"),
- hlds_out__write_functor(Name, Args, VarSet, no),
+ hlds_out__write_functor_cons_id(ConsId, Args, VarSet, no),
( { Args \= [] } ->
io__write_string("'\n"),
prog_out__write_context(Context),
io__write_string(" has instantiatedness `"),
- term_io__write_constant(Name),
+ mercury_output_cons_id(ConsId, no),
io__write_string("("),
- mercury_output_inst_list(ArgInsts, InstVarSet),
+ output_inst_list(ArgInsts, InstVarSet),
io__write_string(")")
;
io__write_string("' has instantiatedness `"),
- term_io__write_constant(Name)
+ mercury_output_cons_id(ConsId, no)
),
io__write_string("'.\n").
@@ -708,12 +708,12 @@
io__write_string(" Final instantiatedness of `"),
mercury_output_var(Var, VarSet, no),
io__write_string("' was `"),
- mercury_output_inst(VarInst, InstVarSet),
+ output_inst(VarInst, InstVarSet),
io__write_string("',\n"),
prog_out__write_context(Context),
io__write_string(" expected final instantiatedness was `"),
- mercury_output_inst(Inst, InstVarSet),
+ output_inst(Inst, InstVarSet),
io__write_string("'.\n").
@@ -894,6 +894,22 @@
;
ModeInfo = ModeInfo0
).
+
+%-----------------------------------------------------------------------------%
+
+:- pred output_inst((inst), varset, io__state, io__state).
+:- mode output_inst(in, in, di, uo) is det.
+
+output_inst(Inst0, VarSet) -->
+ { strip_builtin_qualifiers_from_inst(Inst0, Inst) },
+ mercury_output_inst(Inst, VarSet).
+
+:- pred output_inst_list(list(inst), varset, io__state, io__state).
+:- mode output_inst_list(in, in, di, uo) is det.
+
+output_inst_list(Insts0, VarSet) -->
+ { strip_builtin_qualifiers_from_inst_list(Insts0, Insts) },
+ mercury_output_inst_list(Insts, VarSet).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/mode_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mode_util.m,v
retrieving revision 1.79
diff -u -r1.79 mode_util.m
--- mode_util.m 1997/01/31 22:48:42 1.79
+++ mode_util.m 1997/02/14 01:35:33
@@ -214,10 +214,20 @@
:- pred get_arg_lives(list(mode), module_info, list(is_live)).
:- mode get_arg_lives(in, in, out) is det.
- % Predicate to make error messages more readable by stripping
+ % Predicates to make error messages more readable by stripping
% "mercury_builtin" module qualifiers from modes.
-:- pred strip_builtin_qualifiers_from_mode_list(list(mode)::in,
- list(mode)::out) is det.
+
+:- pred strip_builtin_qualifier_from_cons_id(cons_id, cons_id).
+:- mode strip_builtin_qualifier_from_cons_id(in, out) is det.
+
+:- pred strip_builtin_qualifiers_from_mode_list(list(mode), list(mode)).
+:- mode strip_builtin_qualifiers_from_mode_list(in, out) is det.
+
+:- pred strip_builtin_qualifiers_from_inst_list(list(inst), list(inst)).
+:- mode strip_builtin_qualifiers_from_inst_list(in, out) is det.
+
+:- pred strip_builtin_qualifiers_from_inst((inst), (inst)).
+:- mode strip_builtin_qualifiers_from_inst(in, out) is det.
% Given the switched on variable and the instmaps before the switch
% and after a branch make sure that any information added by the
@@ -1062,7 +1072,9 @@
(
type_constructors(Type, ModuleInfo, Constructors)
->
- propagate_ctor_info(Inst0, Type, Constructors, ModuleInfo,
+ % propagate_ctor_info(Inst0, Type, Constructors, ModuleInfo,
+ % Inst) % temporarily disabled
+ ex_propagate_ctor_info(Inst0, Type, Constructors, ModuleInfo,
Inst)
;
Inst = Inst0
@@ -1096,9 +1108,9 @@
propagate_ctor_info(free(_), _, _, _, _) :-
error("propagate_ctor_info: type info already present").
-propagate_ctor_info(bound(Uniq, BoundInsts0), _Type, Constructors, ModuleInfo,
+propagate_ctor_info(bound(Uniq, BoundInsts0), Type, Constructors, ModuleInfo,
Inst) :-
- propagate_ctor_info_2(BoundInsts0, Constructors, ModuleInfo,
+ propagate_ctor_info_2(BoundInsts0, Type, Constructors, ModuleInfo,
BoundInsts),
( BoundInsts = [] ->
Inst = not_reached
@@ -1106,7 +1118,8 @@
% XXX do we need to sort the BoundInsts?
Inst = bound(Uniq, BoundInsts)
).
-propagate_ctor_info(ground(Uniq, no), _Type, Constructors, ModuleInfo, Inst) :-
+propagate_ctor_info(ground(Uniq, no), _Type,
+ Constructors, ModuleInfo, Inst) :-
constructors_to_bound_insts(Constructors, Uniq, ModuleInfo,
BoundInsts0),
list__sort_and_remove_dups(BoundInsts0, BoundInsts),
@@ -1135,9 +1148,9 @@
% XXX loses type info!
ex_propagate_ctor_info(free(_), _, _, _, _) :-
error("ex_propagate_ctor_info: type info already present").
-ex_propagate_ctor_info(bound(Uniq, BoundInsts0), _Type, Constructors,
+ex_propagate_ctor_info(bound(Uniq, BoundInsts0), Type, Constructors,
ModuleInfo, Inst) :-
- propagate_ctor_info_2(BoundInsts0, Constructors, ModuleInfo,
+ propagate_ctor_info_2(BoundInsts0, Type, Constructors, ModuleInfo,
BoundInsts),
( BoundInsts = [] ->
Inst = not_reached
@@ -1145,8 +1158,9 @@
% XXX do we need to sort the BoundInsts?
Inst = bound(Uniq, BoundInsts)
).
-ex_propagate_ctor_info(ground(Uniq, no), Type, _, _, Inst) :-
- Inst = defined_inst(typed_ground(Uniq, Type)).
+% ex_propagate_ctor_info(ground(Uniq, no), Type, _, _, Inst) :-
+% Inst = defined_inst(typed_ground(Uniq, Type)). % temporarily disabled
+ex_propagate_ctor_info(ground(Uniq, no), _Type, _, _, ground(Uniq, no)).
ex_propagate_ctor_info(ground(Uniq, yes(PredInstInfo)), _, _, _,
% for higher-order pred modes, the information we need is already
% in the inst, so we leave it unchanged
@@ -1178,16 +1192,67 @@
:- mode ctor_arg_list_to_inst_list(in, in, out) is det.
ctor_arg_list_to_inst_list([], _, []).
-ctor_arg_list_to_inst_list([_Name - Type | Args], Uniq, [Inst | Insts]) :-
- Inst = defined_inst(typed_ground(Uniq, Type)),
+ctor_arg_list_to_inst_list([_Name - _Type | Args], Uniq, [Inst | Insts]) :-
+ %Inst = defined_inst(typed_ground(Uniq, Type)), % temporarily disabled.
+ Inst = ground(Uniq, no),
ctor_arg_list_to_inst_list(Args, Uniq, Insts).
-:- pred propagate_ctor_info_2(list(bound_inst), list(constructor),
+:- pred propagate_ctor_info_2(list(bound_inst), (type), list(constructor),
module_info, list(bound_inst)).
-:- mode propagate_ctor_info_2(in, in, in, out) is det.
+:- mode propagate_ctor_info_2(in, in, in, in, out) is det.
-propagate_ctor_info_2(BoundInsts0, _Constructors, _ModuleInfo, BoundInsts) :-
- BoundInsts = BoundInsts0. % XXX Stub only!!
+propagate_ctor_info_2(BoundInsts0, Type, Constructors,
+ ModuleInfo, BoundInsts) :-
+ (
+ type_to_type_id(Type, TypeId, _),
+ TypeId = qualified(TypeModule, _) - _
+ ->
+ propagate_ctor_info_3(BoundInsts0, TypeModule,
+ Constructors, ModuleInfo, BoundInsts1),
+ list__sort(BoundInsts1, BoundInsts)
+ ;
+ % Builtin types don't need processing.
+ BoundInsts = BoundInsts0
+ ).
+
+:- pred propagate_ctor_info_3(list(bound_inst), string, list(constructor),
+ module_info, list(bound_inst)).
+:- mode propagate_ctor_info_3(in, in, in, in, out) is det.
+
+propagate_ctor_info_3([], _, _, _, []).
+propagate_ctor_info_3([BoundInst0 | BoundInsts0], TypeModule, Constructors,
+ ModuleInfo, [BoundInst | BoundInsts]) :-
+ BoundInst0 = functor(ConsId0, ArgInsts0),
+ ( ConsId0 = cons(unqualified(Name), Ar) ->
+ ConsId = cons(qualified(TypeModule, Name), Ar)
+ ;
+ ConsId = ConsId0
+ ),
+ (
+ ConsId = cons(ConsName, Arity),
+ GetCons = lambda([Ctor::in] is semidet, (
+ Ctor = ConsName - CtorArgs,
+ list__length(CtorArgs, Arity)
+ )),
+ list__filter(GetCons, Constructors, [Constructor])
+ ->
+ Constructor = _ - Args,
+ GetArgTypes = lambda([CtorArg::in, ArgType::out] is det, (
+ CtorArg = _ArgName - ArgType
+ )),
+ list__map(GetArgTypes, Args, ArgTypes),
+ propagate_type_info_inst_list(ArgTypes,
+ ModuleInfo, ArgInsts0, ArgInsts),
+ BoundInst = functor(ConsId, ArgInsts)
+ ;
+ % The cons_id is not a valid constructor for the type,
+ % so leave it alone. This can only happen in a user defined
+ % bound_inst. A mode error should be reported if anything
+ % tries to match with the inst.
+ BoundInst = functor(ConsId, ArgInsts0)
+ ),
+ propagate_ctor_info_3(BoundInsts0, TypeModule,
+ Constructors, ModuleInfo, BoundInsts).
%-----------------------------------------------------------------------------%
@@ -1680,6 +1745,14 @@
strip_builtin_qualifiers_from_inst_list(Insts0, Insts),
strip_builtin_qualifier_from_sym_name(SymName0, SymName).
+strip_builtin_qualifier_from_cons_id(ConsId0, ConsId) :-
+ ( ConsId0 = cons(Name0, Arity) ->
+ strip_builtin_qualifier_from_sym_name(Name0, Name),
+ ConsId = cons(Name, Arity)
+ ;
+ ConsId = ConsId0
+ ).
+
:- pred strip_builtin_qualifier_from_sym_name(sym_name::in,
sym_name::out) is det.
@@ -1690,13 +1763,9 @@
SymName = SymName0
).
-:- pred strip_builtin_qualifiers_from_inst_list(list(inst)::in,
- list(inst)::out) is det.
strip_builtin_qualifiers_from_inst_list(Insts0, Insts) :-
list__map(strip_builtin_qualifiers_from_inst, Insts0, Insts).
-:- pred strip_builtin_qualifiers_from_inst((inst)::in, (inst)::out) is det.
-
strip_builtin_qualifiers_from_inst(inst_var(V), inst_var(V)).
strip_builtin_qualifiers_from_inst(not_reached, not_reached).
strip_builtin_qualifiers_from_inst(free, free).
@@ -1722,7 +1791,8 @@
:- pred strip_builtin_qualifiers_from_bound_inst(bound_inst::in,
bound_inst::out) is det.
strip_builtin_qualifiers_from_bound_inst(BoundInst0, BoundInst) :-
- BoundInst0 = functor(ConsId, Insts0),
+ BoundInst0 = functor(ConsId0, Insts0),
+ strip_builtin_qualifier_from_cons_id(ConsId0, ConsId),
BoundInst = functor(ConsId, Insts),
list__map(strip_builtin_qualifiers_from_inst, Insts0, Insts).
Index: compiler/modecheck_call.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/modecheck_call.m,v
retrieving revision 1.5
diff -u -r1.5 modecheck_call.m
--- modecheck_call.m 1996/12/11 18:56:11 1.5
+++ modecheck_call.m 1997/02/13 00:33:30
@@ -83,14 +83,13 @@
PredInstInfo = pred_inst_info(PredOrFunc, Modes0, Det0),
list__length(Modes0, Arity)
->
- Modes = Modes0,
Det = Det0,
%
% Check that `Args0' have livenesses which match the
% expected livenesses.
%
- get_arg_lives(Modes, ModuleInfo0, ExpectedArgLives),
+ get_arg_lives(Modes0, ModuleInfo0, ExpectedArgLives),
modecheck_var_list_is_live(Args0, ExpectedArgLives, 1,
ModeInfo0, ModeInfo1),
@@ -99,11 +98,9 @@
% initial insts, and set their new final insts (introducing
% extra unifications for implied modes, if necessary).
%
- /*********************
% propagate type info into modes
- propagate_type_info_mode_list(Types, ModuleInfo0, Modes1,
+ propagate_type_info_mode_list(Types, ModuleInfo0, Modes0,
Modes),
- *********************/
mode_list_get_initial_insts(Modes, ModuleInfo0, InitialInsts),
modecheck_var_has_inst_list(Args0, InitialInsts, 1,
ModeInfo1, ModeInfo2),
@@ -171,13 +168,10 @@
modecheck_var_list_is_live(ArgVars0, ProcArgLives0, 0,
ModeInfo0, ModeInfo1),
-/*********************
% propagate type info into modes
mode_info_get_types_of_vars(ModeInfo0, ArgVars0, ArgTypes),
propagate_type_info_mode_list(ArgTypes, ModuleInfo,
ProcArgModes0, ProcArgModes),
-*********************/
- ProcArgModes = ProcArgModes0,
%
% Check that `ArgsVars0' have insts which match the expected
@@ -261,13 +255,10 @@
proc_info_argmodes(ProcInfo, ProcArgModes0),
mode_info_get_module_info(ModeInfo0, ModuleInfo),
proc_info_arglives(ProcInfo, ModuleInfo, ProcArgLives0),
-/**************
% propagate the type information into the modes
mode_info_get_types_of_vars(ModeInfo0, ArgVars0, ArgTypes),
propagate_type_info_mode_list(ArgTypes, ModuleInfo,
ProcArgModes0, ProcArgModes),
-**************/
- ProcArgModes = ProcArgModes0,
mode_list_get_initial_insts(ProcArgModes, ModuleInfo, InitialInsts),
% check whether the livenesses of the args matches their
Index: compiler/modecheck_unify.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/modecheck_unify.m,v
retrieving revision 1.8
diff -u -r1.8 modecheck_unify.m
--- modecheck_unify.m 1997/01/20 03:27:39 1.8
+++ modecheck_unify.m 1997/02/14 05:53:24
@@ -97,7 +97,7 @@
Unify = unify(X, var(Y), Modes, Unification, UnifyContext)
).
-modecheck_unification(X0, functor(Name, ArgVars0), Unification0,
+modecheck_unification(X0, functor(ConsId, ArgVars0), Unification0,
UnifyContext, GoalInfo0, HowToCheckGoal,
Goal, ModeInfo0, ModeInfo) :-
mode_info_get_module_info(ModeInfo0, ModuleInfo0),
@@ -116,7 +116,7 @@
% been expanded.)
%
HowToCheckGoal \= check_unique_modes,
- Name = cons(unqualified(ApplyName), _),
+ ConsId = cons(unqualified(ApplyName), _),
( ApplyName = "apply" ; ApplyName = "" ),
Arity >= 2,
ArgVars0 = [FuncVar | FuncArgVars]
@@ -143,7 +143,23 @@
% Find the set of candidate predicates which have the
% specified name and arity (and module, if module-qualified)
- Name = cons(PredName, _),
+ ConsId = cons(PredName, _),
+ module_info_pred_info(ModuleInfo0, ThisPredId, PredInfo),
+
+ %
+ % We don't do this for compiler-generated predicates;
+ % they are assumed to have been generated with all
+ % functions already expanded.
+ % If we did this check for compiler-generated
+ % predicates, it would cause the wrong behaviour
+ % in the case where there is a user-defined function
+ % whose type is exactly the same as the type of
+ % a constructor. (Normally that would cause
+ % a type ambiguity error, but compiler-generated
+ % predicates are not type-checked.)
+ %
+
+ \+ code_util__compiler_generated(PredInfo),
(
PredName = unqualified(UnqualPName),
predicate_table_search_func_name_arity(PredTable,
@@ -153,27 +169,12 @@
% have argument/return types which subsume the actual
% argument/return types of this function call
- module_info_pred_info(ModuleInfo0,
- ThisPredId, PredInfo),
pred_info_typevarset(PredInfo, TVarSet),
map__apply_to_list(ArgVars0, VarTypes0, ArgTypes0),
list__append(ArgTypes0, [TypeOfX], ArgTypes),
typecheck__find_matching_pred_id(PredIds, ModuleInfo0,
- TVarSet, ArgTypes, PredId, QualifiedFuncName),
+ TVarSet, ArgTypes, PredId, QualifiedFuncName)
- %
- % We don't do this for compiler-generated predicates;
- % they are assumed to have been generated with all
- % functions already expanded.
- % If we did this check for compiler-generated
- % predicates, it would cause the wrong behaviour
- % in the case where there is a user-defined function
- % whose type is exactly the same as the type of
- % a constructor. (Normally that would cause
- % a type ambiguity error, but compiler-generated
- % predicates are not type-checked.)
- %
- \+ code_util__compiler_generated(PredInfo)
;
PredName = qualified(FuncModule, UnqualName),
predicate_table_search_func_m_n_a(PredTable,
@@ -189,7 +190,7 @@
ProcId = 0,
list__append(ArgVars0, [X0], ArgVars),
FuncCallUnifyContext = call_unify_context(X0,
- functor(Name, ArgVars0), UnifyContext),
+ functor(ConsId, ArgVars0), UnifyContext),
FuncCall = call(PredId, ProcId, ArgVars, not_builtin,
yes(FuncCallUnifyContext), QualifiedFuncName),
%
@@ -223,7 +224,7 @@
% check if variable has a higher-order pred type
type_is_higher_order(TypeOfX, PredOrFunc, PredArgTypes),
- Name = cons(PName, _),
+ ConsId = cons(PName, _),
% but in case we are redoing mode analysis, make sure
% we don't mess with the address constants for type_info
% fields created by polymorphism.m
@@ -277,7 +278,7 @@
),
CallUnifyContext = call_unify_context(X0,
- functor(Name, ArgVars0), UnifyContext),
+ functor(ConsId, ArgVars0), UnifyContext),
LambdaGoalExpr = call(PredId, ProcId, Args, not_builtin,
yes(CallUnifyContext), QualifiedPName),
@@ -327,19 +328,13 @@
% It's not a higher-order pred unification - just
% call modecheck_unify_functor to do the ordinary thing.
%
- ( cons_id_to_const(Name, Const0, _) ->
- Const = Const0
- ;
- % This should be caught by typecheck.
- error("sorry, not implemented: module qualified constructors")
- ),
mode_info_get_instmap(ModeInfo0, InstMap0),
- modecheck_unify_functor(X0, Const, ArgVars0, Unification0,
- ExtraGoals, Mode, ArgVars, Unification,
- ModeInfo0, ModeInfo),
+ modecheck_unify_functor(X0, TypeOfX, ConsId, ArgVars0,
+ Unification0, ExtraGoals, Mode, ArgVars,
+ Unification, ModeInfo0, ModeInfo),
%
% Optimize away construction of unused terms by
- % replace the unification with `true'.
+ % replacing the unification with `true'.
%
(
Unification = construct(ConstructTarget, _, _, _),
@@ -347,7 +342,7 @@
->
Goal = conj([])
;
- Functor = functor(Name, ArgVars),
+ Functor = functor(ConsId, ArgVars),
Unify = unify(X, Functor, Mode, Unification,
UnifyContext),
X = X0,
@@ -502,24 +497,33 @@
Unification = Unification0
).
-:- pred modecheck_unify_functor(var, const, list(var), unification,
+:- pred modecheck_unify_functor(var, (type), cons_id, list(var), unification,
pair(list(hlds__goal)), pair(mode), list(var),
unification,
mode_info, mode_info).
-:- mode modecheck_unify_functor(in, in, in, in, out, out, out, out,
+:- mode modecheck_unify_functor(in, in, in, in, in, out, out, out, out,
mode_info_di, mode_info_uo) is det.
-modecheck_unify_functor(X, Name, ArgVars0, Unification0,
+modecheck_unify_functor(X, TypeOfX, ConsId0, ArgVars0, Unification0,
ExtraGoals, Mode, ArgVars, Unification,
ModeInfo0, ModeInfo) :-
mode_info_get_module_info(ModeInfo0, ModuleInfo0),
+ list__length(ArgVars0, Arity),
+ (
+ % module qualify cons_ids
+ ConsId0 = cons(unqualified(Name), _),
+ type_to_type_id(TypeOfX, TypeId, _),
+ TypeId = qualified(TypeModule, _) - _
+ ->
+ ConsId = cons(qualified(TypeModule, Name), Arity)
+ ;
+ ConsId = ConsId0
+ ),
mode_info_get_instmap(ModeInfo0, InstMap0),
instmap__lookup_var(InstMap0, X, InstOfX),
instmap__lookup_vars(ArgVars0, InstMap0, InstArgs),
mode_info_var_is_live(ModeInfo0, X, LiveX),
mode_info_var_list_is_live(ArgVars0, ModeInfo0, LiveArgs),
- list__length(ArgVars0, Arity),
- make_functor_cons_id(Name, Arity, ConsId),
InstOfY = bound(unique, [functor(ConsId, InstArgs)]),
(
% The occur check: X = f(X) is considered a mode error
@@ -533,7 +537,7 @@
->
set__list_to_set([X], WaitingVars),
mode_info_error(WaitingVars,
- mode_error_unify_var_functor(X, Name, ArgVars0,
+ mode_error_unify_var_functor(X, ConsId, ArgVars0,
InstOfX, InstArgs),
ModeInfo0, ModeInfo1
),
@@ -557,7 +561,7 @@
ArgVars = ArgVars0,
ExtraGoals = [] - []
;
- abstractly_unify_inst_functor(LiveX, InstOfX, Name,
+ abstractly_unify_inst_functor(LiveX, InstOfX, ConsId,
InstArgs, LiveArgs, real_unify, ModuleInfo0,
UnifyInst, ModuleInfo1)
->
@@ -582,7 +586,7 @@
),
mode_info_get_var_types(ModeInfo1, VarTypes),
categorize_unify_var_functor(ModeOfX, ModeOfXArgs, ModeArgs,
- X, Name, ArgVars0, VarTypes,
+ X, ConsId, ArgVars0, VarTypes,
Unification0, ModeInfo1,
Unification1, ModeInfo2),
split_complicated_subunifies(Unification1, ArgVars0,
@@ -597,7 +601,7 @@
;
set__list_to_set([X | ArgVars0], WaitingVars), % conservative
mode_info_error(WaitingVars,
- mode_error_unify_var_functor(X, Name, ArgVars0,
+ mode_error_unify_var_functor(X, ConsId, ArgVars0,
InstOfX, InstArgs),
ModeInfo0, ModeInfo1
),
@@ -926,17 +930,16 @@
% unification or a deconstruction. It also works out whether it will
% be deterministic or semideterministic.
-:- pred categorize_unify_var_functor(mode, list(mode), list(mode), var, const,
- list(var), map(var, type), unification, mode_info,
- unification, mode_info).
+:- pred categorize_unify_var_functor(mode, list(mode), list(mode), var,
+ cons_id, list(var), map(var, type), unification, mode_info,
+ unification, mode_info).
:- mode categorize_unify_var_functor(in, in, in, in, in, in, in, in,
mode_info_di, out, mode_info_uo) is det.
categorize_unify_var_functor(ModeOfX, ModeOfXArgs, ArgModes0,
- X, Name, ArgVars, VarTypes, Unification0, ModeInfo0,
+ X, NewConsId, ArgVars, VarTypes, Unification0, ModeInfo0,
Unification, ModeInfo) :-
mode_info_get_module_info(ModeInfo0, ModuleInfo),
- list__length(ArgVars, Arity),
map__lookup(VarTypes, X, TypeOfX),
% if we are re-doing mode analysis, preserve the existing cons_id
( Unification0 = construct(_, ConsId0, _, _) ->
@@ -944,7 +947,7 @@
; Unification0 = deconstruct(_, ConsId1, _, _, _) ->
ConsId = ConsId1
;
- make_functor_cons_id(Name, Arity, ConsId)
+ ConsId = NewConsId
),
mode_util__modes_to_uni_modes(ModeOfXArgs, ArgModes0,
ModuleInfo, ArgModes),
@@ -987,7 +990,7 @@
set__init(WaitingVars),
mode_info_error(WaitingVars,
mode_error_unify_pred(X,
- error_at_functor(Name, ArgVars),
+ error_at_functor(ConsId, ArgVars),
TypeOfX, PredOrFunc),
ModeInfo0, ModeInfo)
;
Index: compiler/modes.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/modes.m,v
retrieving revision 1.193
diff -u -r1.193 modes.m
--- modes.m 1997/01/27 07:45:25 1.193
+++ modes.m 1997/02/13 00:31:36
@@ -490,14 +490,12 @@
;
proc_info_context(ProcInfo0, Context)
),
-/**************
% extract the predicate's type from the pred_info
% and propagate the type information into the modes
pred_info_arg_types(PredInfo, _TypeVars, ArgTypes),
propagate_type_info_mode_list(ArgTypes, ModuleInfo0, ArgModes0,
ArgModes1),
-**************/
- ArgModes1 = ArgModes0,
+
% modecheck the clause - first set the initial instantiation
% of the head arguments, mode-check the body, and
% then check that the final instantiation matches that in
@@ -1064,17 +1062,10 @@
% record the fact that Var was bound to ConsId in the
% instmap before processing this case
- ( { cons_id_to_const(ConsId, _Const, Arity) } ->
- { list__duplicate(Arity, free, ArgInsts) },
- modecheck_set_var_inst(Var,
- bound(unique, [functor(ConsId, ArgInsts)]))
- ;
- % cons_id_to_const will fail for pred_consts and
- % address_consts; we don't worry about them,
- % since you can't have a switch on a higher-order
- % pred term anyway.
- []
- ),
+ { cons_id_arity(ConsId, Arity) },
+ { list__duplicate(Arity, free, ArgInsts) },
+ modecheck_set_var_inst(Var,
+ bound(unique, [functor(ConsId, ArgInsts)])),
modecheck_goal(Goal0, Goal1),
mode_info_dcg_get_instmap(InstMap),
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/polymorphism.m,v
retrieving revision 1.94
diff -u -r1.94 polymorphism.m
--- polymorphism.m 1997/02/14 05:54:09 1.94
+++ polymorphism.m 1997/02/14 06:05:46
@@ -1040,10 +1040,7 @@
Term = functor(cons(PredName2, 0), []),
- % Since constructors in bound insts cannot be module
- % qualified, remove the qualifier here.
- unqualify_name(PredName2, PredName3),
- Inst = bound(unique, [functor(cons(unqualified(PredName3), 0), [])]),
+ Inst = bound(unique, [functor(cons(PredName2, 0), [])]),
UnifyMode = (free -> Inst) - (Inst -> Inst),
UnifyContext = unify_context(explicit, []),
% XXX the UnifyContext is wrong
@@ -1145,7 +1142,7 @@
polymorphism__init_type_info_var(Type, ArgVars, Symbol, VarSet0, VarTypes0,
TypeInfoVar, TypeInfoGoal, VarSet, VarTypes) :-
- ConsId = cons(unqualified(Symbol), 1),
+ ConsId = cons(qualified("mercury_builtin", Symbol), 1),
TypeInfoTerm = functor(ConsId, ArgVars),
% introduce a new variable
@@ -1173,7 +1170,7 @@
% note that we could perhaps be more accurate than
% `ground(shared)', but it shouldn't make any
% difference.
- InstConsId = cons(unqualified(Symbol), NumArgVars),
+ InstConsId = cons(qualified("mercury_builtin", Symbol), NumArgVars),
instmap_delta_from_assoc_list(
[TypeInfoVar - bound(unique, [functor(InstConsId, ArgInsts)])],
InstMapDelta),
Index: compiler/prog_io.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_io.m,v
retrieving revision 1.151
diff -u -r1.151 prog_io.m
--- prog_io.m 1997/01/27 07:45:30 1.151
+++ prog_io.m 1997/02/12 00:07:28
@@ -884,15 +884,15 @@
:- mode process_du_type(in, in, in, out) is det.
process_du_type(ModuleName, Head, Body, Result) :-
check_for_errors(ModuleName, Head, Body, Result0),
- process_du_type_2(Result0, Body, Result).
+ process_du_type_2(ModuleName, Result0, Body, Result).
-:- pred process_du_type_2(maybe_functor, term, maybe1(type_defn)).
-:- mode process_du_type_2(in, in, out) is det.
-process_du_type_2(error(Error, Term), _, error(Error, Term)).
-process_du_type_2(ok(Functor, Args), Body, Result) :-
+:- pred process_du_type_2(string, maybe_functor, term, maybe1(type_defn)).
+:- mode process_du_type_2(in, in, in, out) is det.
+process_du_type_2(_, error(Error, Term), _, error(Error, Term)).
+process_du_type_2(ModuleName, ok(Functor, Args), Body, Result) :-
% check that body is a disjunction of constructors
( %%% some [Constrs]
- convert_constructors(Body, Constrs)
+ convert_constructors(ModuleName, Body, Constrs)
->
Result = ok(du_type(Functor, Args, Constrs))
;
@@ -977,29 +977,29 @@
% (known as a "disjunction", even thought the terms aren't goals
% in this case) into a list of constructors
-:- pred convert_constructors(term, list(constructor)).
-:- mode convert_constructors(in, out) is semidet.
-convert_constructors(Body, Constrs) :-
+:- pred convert_constructors(string, term, list(constructor)).
+:- mode convert_constructors(in, in, out) is semidet.
+convert_constructors(ModuleName, Body, Constrs) :-
disjunction_to_list(Body, List),
- convert_constructors_2(List, Constrs).
+ convert_constructors_2(ModuleName, List, Constrs).
% true if input argument is a valid list of constructors
-:- pred convert_constructors_2(list(term), list(constructor)).
-:- mode convert_constructors_2(in, out) is semidet.
-convert_constructors_2([], []).
-convert_constructors_2([Term | Terms], [Constr | Constrs]) :-
- convert_constructor(Term, Constr),
- convert_constructors_2(Terms, Constrs).
+:- pred convert_constructors_2(string, list(term), list(constructor)).
+:- mode convert_constructors_2(in, in, out) is semidet.
+convert_constructors_2(_, [], []).
+convert_constructors_2(ModuleName, [Term | Terms], [Constr | Constrs]) :-
+ convert_constructor(ModuleName, Term, Constr),
+ convert_constructors_2(ModuleName, Terms, Constrs).
% true if input argument is a valid constructor.
% Note that as a special case, one level of
% curly braces around the constructor are ignored.
% This is to allow you to define ';'/2 constructors.
-:- pred convert_constructor(term, constructor).
-:- mode convert_constructor(in, out) is semidet.
-convert_constructor(Term, Result) :-
+:- pred convert_constructor(string, term, constructor).
+:- mode convert_constructor(in, in, out) is semidet.
+convert_constructor(ModuleName, Term, Result) :-
(
Term = term__functor(term__atom("{}"), [Term1], _Context)
->
@@ -1007,7 +1007,8 @@
;
Term2 = Term
),
- parse_qualified_term(Term2, "convert_constructor/2", ok(F, As)),
+ parse_qualified_term(ModuleName, Term2,
+ "convert_constructor/2", ok(F, As)),
convert_constructor_arg_list(As, Args),
Result = F - Args.
Index: compiler/prog_io_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_io_util.m,v
retrieving revision 1.1
diff -u -r1.1 prog_io_util.m
--- prog_io_util.m 1997/01/27 07:45:33 1.1
+++ prog_io_util.m 1997/02/13 00:55:00
@@ -284,10 +284,18 @@
:- pred convert_bound_inst(term, bound_inst).
:- mode convert_bound_inst(in, out) is semidet.
-convert_bound_inst(term__functor(Name0, Args0, _), functor(ConsId, Args)) :-
- list__length(Args0, Arity),
- make_functor_cons_id(Name0, Arity, ConsId),
- convert_inst_list(Args0, Args).
+convert_bound_inst(InstTerm, functor(ConsId, Args)) :-
+ InstTerm = term__functor(Functor, Args0, _),
+ ( Functor = term__atom(_) ->
+ parse_qualified_term(InstTerm, "", ok(SymName, Args1)),
+ list__length(Args1, Arity),
+ ConsId = cons(SymName, Arity)
+ ;
+ Args1 = Args0,
+ list__length(Args1, Arity),
+ make_functor_cons_id(Functor, Arity, ConsId)
+ ),
+ convert_inst_list(Args1, Args).
disjunction_to_list(Term, List) :-
binop_term_to_list(";", Term, List).
Index: compiler/simplify.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/simplify.m,v
retrieving revision 1.24
diff -u -r1.24 simplify.m
--- simplify.m 1997/02/10 08:32:27 1.24
+++ simplify.m 1997/02/13 00:28:19
@@ -312,9 +312,9 @@
; Cases1 = [case(ConsId, SingleGoal0)] ->
% a singleton switch is equivalent to the goal itself with
% a possibly can_fail unification with the functor on the front.
+ cons_id_arity(ConsId, Arity),
(
SwitchCanFail = can_fail,
- cons_id_to_const(ConsId, _, Arity),
MaybeConsIds \= yes([ConsId])
->
simplify__create_test_unification(Var, ConsId, Arity,
Index: compiler/typecheck.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/typecheck.m,v
retrieving revision 1.185
diff -u -r1.185 typecheck.m
--- typecheck.m 1997/02/06 23:06:51 1.185
+++ typecheck.m 1997/02/14 01:38:38
@@ -141,7 +141,7 @@
:- import_module hlds_goal, hlds_data, prog_util, type_util, code_util.
:- import_module prog_data, prog_io, prog_io_util, prog_out, hlds_out.
-:- import_module mercury_to_mercury, options, getopt, globals.
+:- import_module mercury_to_mercury, mode_util, options, getopt, globals.
:- import_module passes_aux, clause_to_proc.
:- import_module int, list, map, string, require, std_util, tree234.
@@ -2375,9 +2375,7 @@
% us a list of possible cons_type_infos.
type_info_get_ctors(TypeInfo, Ctors),
(
- % Qualified functors can only be function calls or
- % higher-order predicate constants.
- Functor = cons(unqualified(_), Arity),
+ Functor = cons(_, _),
map__search(Ctors, Functor, HLDS_ConsDefnList)
->
convert_cons_defn_list(TypeInfo, HLDS_ConsDefnList,
@@ -2775,11 +2773,12 @@
io__write_string("\n"),
prog_out__write_context(Context),
io__write_string(" and term `"),
- hlds_out__write_functor_cons_id(Functor, Args, VarSet, no),
+ { strip_builtin_qualifier_from_cons_id(Functor, Functor1) },
+ hlds_out__write_functor_cons_id(Functor1, Args, VarSet, no),
io__write_string("':\n"),
prog_out__write_context(Context),
io__write_string(" type error in argument(s) of "),
- write_functor_name(Functor, Arity),
+ write_functor_name(Functor1, Arity),
io__write_string(".\n"),
% XXX we should print type pairs (one type from each side)
@@ -2823,16 +2822,17 @@
:- mode write_functor_name(in, in, di, uo) is det.
write_functor_name(Functor, Arity) -->
+ { strip_builtin_qualifier_from_cons_id(Functor, Functor1) },
( { Arity = 0 } ->
io__write_string("constant `"),
( { Functor = cons(Name, _) } ->
prog_out__write_sym_name(Name)
;
- hlds_out__write_cons_id(Functor)
+ hlds_out__write_cons_id(Functor1)
)
;
io__write_string("functor `"),
- hlds_out__write_cons_id(Functor)
+ hlds_out__write_cons_id(Functor1)
),
io__write_string("'").
@@ -2881,22 +2881,15 @@
io__state, io__state).
:- mode write_cons_type(in, in, in, di, uo) is det.
-write_cons_type(cons_type_info(TVarSet, ConsType0, ArgTypes0), Functor, Context)
- -->
+write_cons_type(cons_type_info(TVarSet, ConsType0, ArgTypes0), Functor, _) -->
+ { strip_builtin_qualifier_from_cons_id(Functor, Functor1) },
{ strip_builtin_qualifiers_from_type_list(ArgTypes0, ArgTypes) },
( { ArgTypes \= [] } ->
- {
- cons_id_to_const(Functor, Const, _)
- ->
- Term = term__functor(Const, ArgTypes, Context)
- ;
- Functor = cons(SymName, _)
- ->
- construct_qualified_term(SymName, ArgTypes, Term)
+ ( { cons_id_and_args_to_term(Functor1, ArgTypes, Term) } ->
+ mercury_output_term(Term, TVarSet, no)
;
- error("typecheck:write_cons_type - invalid cons_id")
- },
- mercury_output_term(Term, TVarSet, no),
+ { error("typecheck:write_cons_type - invalid cons_id") }
+ ),
io__write_string(" :: ")
;
[]
@@ -3335,14 +3328,6 @@
% clearer error messages
%
(
- { Functor = cons(qualified(Module, Name), Arity) }
- ->
- % qualified cons_ids can only be function calls
- % or higher-order pred constants.
- { string__int_to_string(Arity, ArStr) },
- io__write_strings([" error: undefined predicate or function `",
- Module, ":", Name, "'/", ArStr, ".\n"])
- ;
{ Functor = cons(unqualified(Name), _) },
{ language_builtin(Name, Arity) }
->
@@ -3404,7 +3389,8 @@
)
;
io__write_string(" error: undefined symbol `"),
- hlds_out__write_cons_id(Functor),
+ { strip_builtin_qualifier_from_cons_id(Functor, Functor1) },
+ hlds_out__write_cons_id(Functor1),
io__write_string("'.\n")
).
Index: compiler/unique_modes.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/unique_modes.m,v
retrieving revision 1.30
diff -u -r1.30 unique_modes.m
--- unique_modes.m 1997/01/27 07:45:40 1.30
+++ unique_modes.m 1997/02/13 00:32:18
@@ -126,11 +126,10 @@
% Extract the useful fields in the proc_info.
%
proc_info_headvars(ProcInfo0, Args),
- proc_info_argmodes(ProcInfo0, ArgModes),
+ proc_info_argmodes(ProcInfo0, ArgModes0),
proc_info_arglives(ProcInfo0, ModuleInfo0, ArgLives),
proc_info_goal(ProcInfo0, Goal0),
-/**************
%
% extract the predicate's type from the pred_info
% and propagate the type information into the modes
@@ -138,7 +137,6 @@
pred_info_arg_types(PredInfo, _TypeVars, ArgTypes),
propagate_type_info_mode_list(ArgTypes, ModuleInfo0, ArgModes0,
ArgModes),
-**************/
%
% Figure out the right context to use.
@@ -599,13 +597,10 @@
unique_modes__check_call_modes(ArgVars, ProcArgModes0, CodeModel, NeverSucceeds,
ModeInfo0, ModeInfo) :-
mode_info_get_module_info(ModeInfo0, ModuleInfo),
-/*********************
% propagate type info into modes
mode_info_get_types_of_vars(ModeInfo0, ArgVars, ArgTypes),
propagate_type_info_mode_list(ArgTypes, ModuleInfo,
ProcArgModes0, ProcArgModes),
-*********************/
- ProcArgModes = ProcArgModes0,
mode_list_get_initial_insts(ProcArgModes, ModuleInfo,
InitialInsts),
modecheck_var_has_inst_list(ArgVars, InitialInsts, 0,
@@ -689,17 +684,10 @@
% record the fact that Var was bound to ConsId in the
% instmap before processing this case
- ( { cons_id_to_const(ConsId, _Const, Arity) } ->
- { list__duplicate(Arity, free, ArgInsts) },
- modecheck_set_var_inst(Var,
- bound(unique, [functor(ConsId, ArgInsts)]))
- ;
- % cons_id_to_const will fail for pred_consts and
- % address_consts; we don't worry about them,
- % since you can't have a switch on a higher-order
- % pred term anyway.
- []
- ),
+ { cons_id_arity(ConsId, Arity) },
+ { list__duplicate(Arity, free, ArgInsts) },
+ modecheck_set_var_inst(Var,
+ bound(unique, [functor(ConsId, ArgInsts)])),
unique_modes__check_goal(Goal0, Goal1),
mode_info_dcg_get_instmap(InstMap),
More information about the developers
mailing list