[m-rev.] EDCG diff3
Peter Nicholas MALKIN
pnmalk at students.cs.mu.oz.au
Thu Mar 15 19:24:44 AEDT 2001
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.182
diff -u -r1.182 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 2001/02/09 03:24:07 1.182
+++ compiler/mercury_to_mercury.m 2001/03/14 06:11:06
@@ -15,7 +15,7 @@
:- interface.
:- import_module prog_data, (inst).
-:- import_module hlds_goal, hlds_data.
+:- import_module hlds_goal, hlds_data, hlds_pred, hlds_module.
:- import_module bool, std_util, list, io, varset, term.
@@ -47,6 +47,17 @@
:- mode mercury_output_pred_type(in, in, in, in, in, in, in, in, in,
di, uo) is det.
+:- pred mercury_output_pred_type(tvarset, existq_tvars, sym_name, list(type),
+ edcg_forms, maybe(determinism), purity,
+ class_constraints, prog_context, bool, io__state, io__state).
+:- mode mercury_output_pred_type(in, in, in, in, in, in, in, in, in, in,
+ di, uo) is det.
+
+ % Output a `:- pred' declaration, but listing only the EDCG arguments.
+:- pred mercury_output_pred_type(module_info, pred_id, edcg_forms,
+ prog_context, io__state, io__state).
+:- mode mercury_output_pred_type(in, in, in, in, di, uo) is det.
+
% Output a `:- func' declaration, making sure that the variable
% number appears in variable names if the boolean argument
% is set to `yes'.
@@ -113,6 +124,14 @@
io__state, io__state).
:- mode mercury_output_type_defn(in, in, in, di, uo) is det.
+:- pred mercury_output_etype_decl(tvarset, sym_name, etype_defn, term__context,
+ io__state, io__state).
+:- mode mercury_output_etype_decl(in, in, in, in, di, uo) is det.
+
+:- pred mercury_output_emode_decl(inst_varset, sym_name, emode_defn,
+ term__context, io__state, io__state).
+:- mode mercury_output_emode_decl(in, in, in, in, di, uo) is det.
+
:- pred mercury_output_ctor(constructor, tvarset, io__state, io__state).
:- mode mercury_output_ctor(in, in, di, uo) is det.
@@ -203,6 +222,9 @@
:- pred mercury_output_bracketed_sym_name(sym_name, io__state, io__state).
:- mode mercury_output_bracketed_sym_name(in, di, uo) is det.
+:- pred mercury_output_sym_name(sym_name, io__state, io__state).
+:- mode mercury_output_sym_name(in, di, uo) is det.
+
:- pred mercury_convert_var_name(string, string).
:- mode mercury_convert_var_name(in, out) is det.
@@ -298,11 +320,20 @@
maybe_output_line_number(Context),
mercury_output_mode_defn(VarSet, ModeDefn, Context).
+mercury_output_item(etype_defn(VarSet, Name, TypeDefn), Context) -->
+ maybe_output_line_number(Context),
+ mercury_output_etype_decl(VarSet, Name, TypeDefn, Context).
+
+mercury_output_item(emode_defn(VarSet, Name, ModeDefn), Context) -->
+ maybe_output_line_number(Context),
+ mercury_output_emode_decl(VarSet, Name, ModeDefn, Context).
+
mercury_output_item(pred(TypeVarSet, InstVarSet, ExistQVars, PredName,
- TypesAndModes, Det, _Cond, Purity, ClassContext), Context) -->
+ TypesAndModes, EDCGForms, Det, _Cond, Purity, ClassContext),
+ Context) -->
maybe_output_line_number(Context),
mercury_output_pred_decl(TypeVarSet, InstVarSet, ExistQVars, PredName,
- TypesAndModes, Det, Purity, ClassContext, Context,
+ TypesAndModes, EDCGForms, Det, Purity, ClassContext, Context,
":- ", ".\n", ".\n").
mercury_output_item(func(TypeVarSet, InstVarSet, ExistQVars, PredName,
@@ -329,9 +360,11 @@
maybe_output_line_number(Context),
mercury_output_module_defn(VarSet, ModuleDefn, Context).
-mercury_output_item(pred_clause(VarSet, PredName, Args, Body), Context) -->
+mercury_output_item(pred_clause(VarSet, PredName, Args, Body, MaybeEDCG),
+ Context) -->
maybe_output_line_number(Context),
- mercury_output_pred_clause(VarSet, PredName, Args, Body, Context),
+ mercury_output_pred_clause(VarSet, PredName, Args, Body, Context,
+ MaybeEDCG),
io__write_string(".\n").
mercury_output_item(func_clause(VarSet, FuncName, Args, Result, Body),
@@ -534,7 +567,7 @@
TypesAndModes, Detism, _Condition, Purity, ClassContext,
Context) },
mercury_output_pred_decl(TypeVarSet, InstVarSet, ExistQVars,
- Name, TypesAndModes, Detism, Purity, ClassContext,
+ Name, TypesAndModes, [], Detism, Purity, ClassContext,
Context, "", ",\n\t", "")
;
{ Method = func(TypeVarSet, InstVarSet, ExistQVars, Name,
@@ -587,11 +620,11 @@
{ WriteOneItem = (pred(Item::in, di, uo) is det -->
(
{ Item = pred_clause(VarSet, _PredName,
- HeadTerms, Body) }
+ HeadTerms, Body, MaybeEDCG) }
->
mercury_output_pred_clause(VarSet,
- Name1, HeadTerms, Body,
- Context)
+ Name1, HeadTerms, Body, Context,
+ MaybeEDCG)
;
{ error("invalid instance item") }
)) },
@@ -1390,15 +1423,70 @@
%-----------------------------------------------------------------------------%
+mercury_output_emode_decl(VarSet, Name, HmodeDefn, Context) -->
+ mercury_output_emode_decl_2(VarSet, Name, HmodeDefn, Context,
+ ":- ", ".\n").
+
+:- pred mercury_output_emode_decl_2(inst_varset, sym_name, emode_defn,
+ term__context, string, string, io__state, io__state).
+:- mode mercury_output_emode_decl_2(in, in, in, in, in, in, di, uo) is det.
+
+mercury_output_emode_decl_2(VarSet, Name, HmodeDefn, _Context,
+ StartString, Separator) -->
+ io__write_string(StartString),
+ io__write_string("emode("),
+ mercury_output_sym_name(Name),
+ mercury_output_emode_decl_3(changed, HmodeDefn, VarSet),
+ mercury_output_emode_decl_3(passed, HmodeDefn, VarSet),
+ mercury_output_emode_decl_3(produced, HmodeDefn, VarSet),
+ io__write_string(")"),
+ io__write_string(Separator).
+
+:- pred mercury_output_emode_decl_3(form, emode_defn, inst_varset,
+ io__state, io__state).
+:- mode mercury_output_emode_decl_3(in, in, in, di, uo) is det.
+mercury_output_emode_decl_3(Form, HmodeDefn, VarSet) -->
+ ( { get_edcg_modes(Form, HmodeDefn, ModeList) } ->
+ { form_to_string(Form, FormString) },
+ io__write_string(", "),
+ io__write_strings([FormString, "("]),
+ mercury_output_mode_list(ModeList, VarSet),
+ io__write_string(")")
+ ;
+ { true }
+ ).
+
+%-----------------------------------------------------------------------------%
+
+mercury_output_etype_decl(VarSet, Name, HtypeDefn, Context) -->
+ mercury_output_etype_decl_2(VarSet, Name, HtypeDefn, Context,
+ ":- ", ".\n").
+
+:- pred mercury_output_etype_decl_2(tvarset, sym_name, etype_defn,
+ term__context, string, string, io__state, io__state).
+:- mode mercury_output_etype_decl_2(in, in, in, in, in, in, di, uo) is det.
+
+mercury_output_etype_decl_2(VarSet, EDCGName, etype_defn(Type),
+ _Context, StartString, Separator) -->
+ io__write_string(StartString),
+ io__write_string("etype("),
+ mercury_output_sym_name(EDCGName),
+ io__write_string(", "),
+ mercury_output_term(Type, VarSet, no),
+ io__write_string(")"),
+ io__write_string(Separator).
+
+%-----------------------------------------------------------------------------%
+
:- pred mercury_output_pred_decl(tvarset, inst_varset, existq_tvars,
- sym_name, list(type_and_mode),
+ sym_name, list(type_and_mode), edcg_forms,
maybe(determinism), purity, class_constraints,
prog_context, string, string, string, io__state, io__state).
:- mode mercury_output_pred_decl(in, in, in, in, in, in, in, in, in, in, in, in,
- di, uo) is det.
+ in, di, uo) is det.
mercury_output_pred_decl(TypeVarSet, InstVarSet, ExistQVars, PredName,
- TypesAndModes, MaybeDet, Purity, ClassContext, Context,
+ TypesAndModes, EDCGForms, MaybeDet, Purity, ClassContext, Context,
StartString, Separator, Terminator) -->
{ split_types_and_modes(TypesAndModes, Types, MaybeModes) },
(
@@ -1407,32 +1495,37 @@
->
{ AppendVarnums = no },
mercury_output_pred_type_2(TypeVarSet, ExistQVars, PredName,
- Types, MaybeDet, Purity, ClassContext, Context,
+ Types, EDCGForms, MaybeDet, Purity, ClassContext, Context,
AppendVarnums, StartString, Separator),
mercury_output_pred_mode_decl_2(InstVarSet, PredName, Modes,
MaybeDet, Context, StartString, Terminator)
;
{ AppendVarnums = no },
mercury_output_pred_type_2(TypeVarSet, ExistQVars, PredName,
- Types, MaybeDet, Purity, ClassContext, Context,
+ Types, EDCGForms, MaybeDet, Purity, ClassContext, Context,
AppendVarnums, StartString, Terminator)
).
mercury_output_pred_type(VarSet, ExistQVars, PredName, Types, MaybeDet, Purity,
ClassContext, Context, AppendVarnums) -->
mercury_output_pred_type_2(VarSet, ExistQVars, PredName, Types,
- MaybeDet, Purity, ClassContext, Context, AppendVarnums,
+ [], MaybeDet, Purity, ClassContext, Context, AppendVarnums,
":- ", ".\n").
+mercury_output_pred_type(VarSet, ExistQVars, PredName, Types, EDCGForms,
+ MaybeDet, Purity, ClassContext, Context, AppenVarnums) -->
+ mercury_output_pred_type_2(VarSet, ExistQVars, PredName, Types,
+ EDCGForms, MaybeDet, Purity, ClassContext,
+ Context, AppenVarnums, ":- ", ".\n").
:- pred mercury_output_pred_type_2(tvarset, existq_tvars, sym_name, list(type),
- maybe(determinism), purity, class_constraints,
+ edcg_forms, maybe(determinism), purity, class_constraints,
prog_context, bool, string, string, io__state, io__state).
:- mode mercury_output_pred_type_2(in, in, in, in, in, in, in, in, in, in, in,
- di, uo) is det.
+ in, di, uo) is det.
-mercury_output_pred_type_2(VarSet, ExistQVars, PredName, Types, MaybeDet,
- Purity, ClassContext, _Context, AppendVarnums,
+mercury_output_pred_type_2(VarSet, ExistQVars, PredName, Types, EDCGForms,
+ MaybeDet, Purity, ClassContext, _Context, AppendVarnums,
StartString, Separator) -->
io__write_string(StartString),
mercury_output_quantifier(VarSet, AppendVarnums, ExistQVars),
@@ -1451,10 +1544,12 @@
mercury_output_term(Type, VarSet, AppendVarnums),
mercury_output_remaining_terms(Rest, VarSet, AppendVarnums),
io__write_string(")"),
+ mercury_output_edcg_args(EDCGForms),
mercury_output_class_context(ClassContext, ExistQVars, VarSet,
AppendVarnums)
;
mercury_output_bracketed_sym_name(PredName),
+ mercury_output_edcg_args(EDCGForms),
mercury_output_class_context(ClassContext, ExistQVars, VarSet,
AppendVarnums),
mercury_output_det_annotation(MaybeDet)
@@ -1483,7 +1578,46 @@
),
io__write_string(Separator).
+mercury_output_pred_type(ModuleInfo, PredId, EDCGForms, Context) -->
+ mercury_output_pred_type_2(ModuleInfo, PredId, EDCGForms, Context,
+ ".\n").
+
+:- pred mercury_output_pred_type_2(module_info, pred_id, edcg_forms,
+ prog_context, string, io__state, io__state).
+:- mode mercury_output_pred_type_2(in, in, in, in, in, di, uo) is det.
+
+mercury_output_pred_type_2(ModuleInfo, PredId, EDCGForms,
+ _Context, Separator) -->
+ hlds_out__write_pred_id(ModuleInfo, PredId),
+ mercury_output_edcg_args(EDCGForms),
+ io__write_string(Separator).
+
+:- pred mercury_output_edcg_args(edcg_forms, io__state, io__state).
+:- mode mercury_output_edcg_args(in, di, uo) is det.
+
+mercury_output_edcg_args([]) --> [].
+mercury_output_edcg_args([EDCGForm|Others]) -->
+ io__write_string("+edcg("),
+ mercury_output_edcg_args_2([EDCGForm|Others]),
+ io__write_string(")").
+:- pred mercury_output_edcg_args_2(edcg_forms, io__state, io__state).
+:- mode mercury_output_edcg_args_2(in, di, uo) is det.
+
+mercury_output_edcg_args_2([]) --> [].
+mercury_output_edcg_args_2([SymName - Form|Rest]) -->
+ { form_to_string(Form, FormString) },
+ io__write_string(FormString),
+ io__write_string("("),
+ mercury_output_sym_name(SymName),
+ io__write_string(")"),
+ ( { Rest \= [] } ->
+ io__write_string(", "),
+ mercury_output_edcg_args_2(Rest)
+ ;
+ { true }
+ ).
+
%-----------------------------------------------------------------------------%
:- pred mercury_output_func_decl(tvarset, inst_varset, existq_tvars, sym_name,
@@ -1797,10 +1931,11 @@
% Output a clause.
:- pred mercury_output_pred_clause(prog_varset, sym_name, list(prog_term), goal,
- prog_context, io__state, io__state).
-:- mode mercury_output_pred_clause(in, in, in, in, in, di, uo) is det.
+ prog_context, maybe_edcg, io__state, io__state).
+:- mode mercury_output_pred_clause(in, in, in, in, in, in, di, uo) is det.
-mercury_output_pred_clause(VarSet, PredName, Args, Body, _Context) -->
+mercury_output_pred_clause(VarSet, PredName, Args, Body, _Context,
+ MaybeEDCG) -->
mercury_output_sym_name(PredName),
(
{ Args = [Arg | Args0] }
@@ -1817,7 +1952,11 @@
->
[]
;
- io__write_string(" :-\n\t"),
+ ( { MaybeEDCG = edcg_no } ->
+ io__write_string(" :-\n\t")
+ ;
+ io__write_string(" -->>\n\t")
+ ),
mercury_output_goal(Body, VarSet, 1)
).
@@ -1981,9 +2120,9 @@
mercury_output_newline(Indent),
io__write_string(")").
-mercury_output_goal_2(call(Name, Term, Purity), VarSet, Indent) -->
+mercury_output_goal_2(call(Name, Term, EDCGTerm, Purity), VarSet, Indent) -->
write_purity_prefix(Purity),
- mercury_output_call(Name, Term, VarSet, Indent).
+ mercury_output_call(Name, Term, EDCGTerm, VarSet, Indent).
mercury_output_goal_2(unify(A, B, Purity), VarSet, _Indent) -->
write_purity_prefix(Purity),
@@ -1991,12 +2130,23 @@
io__write_string(" = "),
mercury_output_term(B, VarSet, no, next_to_graphic_token).
+mercury_output_goal_2(edcg_goal(Head, Body), VarSet, Indent0) -->
+ io__write_string("("),
+ mercury_output_term(Head, VarSet, no),
+ mercury_output_newline(Indent0),
+ io__write_string("-->>"),
+ { Indent is Indent0 + 1 },
+ mercury_output_newline(Indent),
+ mercury_output_goal(Body, VarSet, Indent),
+ mercury_output_newline(Indent0),
+ io__write_string(")").
-:- pred mercury_output_call(sym_name, list(prog_term), prog_varset, int,
+:- pred mercury_output_call(sym_name, list(prog_term),
+ assoc_list(edcg_arg, list(prog_term)), prog_varset, int,
io__state, io__state).
-:- mode mercury_output_call(in, in, in, in, di, uo) is det.
+:- mode mercury_output_call(in, in, in, in, in, di, uo) is det.
-mercury_output_call(Name, Term, VarSet, _Indent) -->
+mercury_output_call(Name, Term, EDCGTerm, VarSet, _Indent) -->
(
{ Name = qualified(ModuleName, PredName) },
mercury_output_bracketed_sym_name(ModuleName,
@@ -2010,8 +2160,38 @@
{ term__context_init(Context0) },
mercury_output_term(term__functor(term__atom(PredName),
Term, Context0), VarSet, no, next_to_graphic_token)
- ).
+ ),
+ mercury_output_edcg_term(EDCGTerm, VarSet).
+:- pred mercury_output_edcg_term(assoc_list(edcg_arg, list(prog_term)),
+ prog_varset, io__state, io__state).
+:- mode mercury_output_edcg_term(in, in, di, uo) is det.
+
+mercury_output_edcg_term([], _) --> [].
+mercury_output_edcg_term([EDCG|Terms], VarSet) -->
+ io__write_string(" +edcg("),
+ mercury_output_edcg_term_2([EDCG|Terms], VarSet),
+ io__write_string(")").
+
+:- pred mercury_output_edcg_term_2(assoc_list(edcg_arg, list(prog_term)),
+ prog_varset, io__state, io__state).
+:- mode mercury_output_edcg_term_2(in, in, di, uo) is det.
+
+mercury_output_edcg_term_2([], _) --> [].
+mercury_output_edcg_term_2([EDCG - Args], VarSet) -->
+ { term__context_init(Context0) },
+ { prog_out__sym_name_to_string(EDCG, EDCGString) },
+ mercury_output_term(term__functor(term__atom(EDCGString),
+ Args, Context0), VarSet, no, next_to_graphic_token).
+mercury_output_edcg_term_2([EDCG1 - Args1, EDCG2 - Args2|Terms],
+ VarSet) -->
+ { term__context_init(Context0) },
+ { prog_out__sym_name_to_string(EDCG1, EDCGString) },
+ mercury_output_term(term__functor(term__atom(EDCGString),
+ Args1, Context0), VarSet, no, next_to_graphic_token),
+ io__write_string(","),
+ mercury_output_edcg_term_2([EDCG2 - Args2|Terms], VarSet).
+
:- pred mercury_output_disj(goal, prog_varset, int, io__state, io__state).
:- mode mercury_output_disj(in, in, in, di, uo) is det.
@@ -2794,9 +2974,6 @@
% no arguments, otherwise use mercury_output_sym_name.
%
-:- pred mercury_output_sym_name(sym_name, io__state, io__state).
-:- mode mercury_output_sym_name(in, di, uo) is det.
-
mercury_output_sym_name(SymName) -->
mercury_output_sym_name(SymName, not_next_to_graphic_token).
@@ -2897,6 +3074,7 @@
:- mode mercury_infix_op(in) is semidet.
mercury_infix_op("--->").
+mercury_infix_op("-->>").
mercury_infix_op("-->").
mercury_infix_op(":-").
mercury_infix_op("::").
@@ -2953,6 +3131,8 @@
mercury_infix_op("mod").
mercury_infix_op("rem").
mercury_infix_op("^").
+mercury_unary_prefix_op("$").
+mercury_unary_prefix_op("$=").
:- pred mercury_unary_prefix_op(string).
:- mode mercury_unary_prefix_op(in) is semidet.
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.78
diff -u -r1.78 ml_code_gen.m
--- compiler/ml_code_gen.m 2001/02/28 15:59:17 1.78
+++ compiler/ml_code_gen.m 2001/03/12 15:35:49
@@ -1966,7 +1966,7 @@
ml_gen_generic_call(GenericCall, Vars, Modes, CodeModel, Context,
MLDS_Decls, MLDS_Statements).
-ml_gen_goal_expr(call(PredId, ProcId, ArgVars, BuiltinState, _, PredName),
+ml_gen_goal_expr(call(PredId, ProcId, ArgVars, _, BuiltinState, _, PredName),
CodeModel, Context, MLDS_Decls, MLDS_Statements) -->
(
{ BuiltinState = not_builtin }
@@ -2042,6 +2042,10 @@
ml_gen_goal_expr(bi_implication(_, _), _, _, _, _) -->
% these should have been expanded out by now
{ error("ml_gen_goal_expr: unexpected bi_implication") }.
+
+ml_gen_goal_expr(edcg_goal(_, _, _), _, _, _, _) -->
+ % these should have been expanded out by now
+ { error("ml_gen_goal_expr: unexpected edcg_goal") }.
:- pred ml_gen_nondet_pragma_c_code(code_model, pragma_foreign_code_attributes,
pred_id, proc_id, list(prog_var),
Index: compiler/mode_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mode_util.m,v
retrieving revision 1.134
diff -u -r1.134 mode_util.m
--- compiler/mode_util.m 2000/11/17 17:47:59 1.134
+++ compiler/mode_util.m 2001/03/12 15:35:51
@@ -1361,8 +1361,8 @@
{ instmap_delta_from_mode_list(Vars, Modes,
ModuleInfo, InstMapDelta) }.
-recompute_instmap_delta_2(_, call(PredId, ProcId, Args, D, E, F), _,
- call(PredId, ProcId, Args, D, E, F), VarTypes,
+recompute_instmap_delta_2(_, call(PredId, ProcId, Args, D, E, F, G), _,
+ call(PredId, ProcId, Args, D, E, F, G), VarTypes,
InstMap, InstMapDelta) -->
recompute_instmap_delta_call(PredId, ProcId,
Args, VarTypes, InstMap, InstMapDelta).
@@ -1402,6 +1402,12 @@
recompute_instmap_delta_2(_, bi_implication(_, _), _, _, _, _, _) -->
% these should have been expanded out by now
{ error("recompute_instmap_delta_2: unexpected bi_implication") }.
+
+recompute_instmap_delta_2(_, edcg_goal(_, _, _), _, _, _, _, _) -->
+ % these should have been expanded out by now
+ { error("recompute_instmap_delta_2: unexpected edcg_goal") }.
+
+%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/modecheck_unify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modecheck_unify.m,v
retrieving revision 1.45
diff -u -r1.45 modecheck_unify.m
--- compiler/modecheck_unify.m 2001/01/17 01:42:05 1.45
+++ compiler/modecheck_unify.m 2001/03/12 15:35:51
@@ -165,6 +165,8 @@
ConsId0, ArgVars0, Unification0, UnifyContext,
GoalInfo0, Goal, ModeInfo0, ModeInfo)
).
+modecheck_unification(_, edcg_op(_, _), _, _, _, _, _, _) :-
+ error("modecheck_unification: unexpected edcg_op").
modecheck_unification(X,
lambda_goal(PredOrFunc, EvalMethod, _, ArgVars,
@@ -1026,7 +1028,7 @@
(
RHS0 = lambda_goal(_, EvalMethod, _,
_, _, _, _, Goal),
- Goal = call(PredId, ProcId, _, _, _, _) - _
+ Goal = call(PredId, ProcId, _, _, _, _, _) - _
->
module_info_pred_info(ModuleInfo,
PredId, PredInfo),
Index: compiler/modes.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modes.m,v
retrieving revision 1.251
diff -u -r1.251 modes.m
--- compiler/modes.m 2001/01/17 01:42:08 1.251
+++ compiler/modes.m 2001/03/13 00:21:44
@@ -792,7 +792,7 @@
pred_info_clauses_info(PredInfo, ClausesInfo),
clauses_info_clauses(ClausesInfo, ClauseList),
( ClauseList = [FirstClause | _] ->
- FirstClause = clause(_, _, Context)
+ FirstClause = clause(_, _, _, Context)
;
proc_info_context(ProcInfo0, Context)
),
@@ -1183,7 +1183,7 @@
modecheck_goal(G0, G),
mode_checkpoint(exit, "some").
-modecheck_goal_expr(call(PredId, ProcId0, Args0, _, Context, PredName),
+modecheck_goal_expr(call(PredId, ProcId0, Args0, _, _, Context, PredName),
GoalInfo0, Goal) -->
{ prog_out__sym_name_to_string(PredName, PredNameString) },
{ string__append("call ", PredNameString, CallString) },
@@ -1202,7 +1202,7 @@
=(ModeInfo),
{ mode_info_get_module_info(ModeInfo, ModuleInfo) },
{ code_util__builtin_state(ModuleInfo, PredId, Mode, Builtin) },
- { Call = call(PredId, Mode, Args, Builtin, Context, PredName) },
+ { Call = call(PredId, Mode, Args, [], Builtin, Context, PredName) },
handle_extra_goals(Call, ExtraGoals, GoalInfo0, Args0, Args,
InstMap0, Goal),
@@ -1295,6 +1295,10 @@
% these should have been expanded out by now
{ error("modecheck_goal_expr: unexpected bi_implication") }.
+modecheck_goal_expr(edcg_goal(_, _, _), _, _) -->
+ % these should have been expanded out by now
+ { error("modecheck_goal_expr: unexpected edcg_goal") }.
+
append_extra_goals(no_extra_goals, ExtraGoals, ExtraGoals).
append_extra_goals(extra_goals(BeforeGoals, AfterGoals),
no_extra_goals, extra_goals(BeforeGoals, AfterGoals)).
@@ -2221,8 +2225,8 @@
predicate_table_search_pred_m_n_a(PredicateTable, Module, Name, Arity,
[PredId]),
hlds_pred__proc_id_to_int(ModeId, 0), % first mode
- Call = call(PredId, ModeId, ArgVars, not_builtin, CallUnifyContext,
- qualified(Module, Name)),
+ Call = call(PredId, ModeId, ArgVars, [], not_builtin,
+ CallUnifyContext, qualified(Module, Name)),
goal_info_init(GoalInfo0),
goal_info_set_context(GoalInfo0, Context, GoalInfo),
Goal = Call - GoalInfo.
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.63
diff -u -r1.63 module_qual.m
--- compiler/module_qual.m 2001/01/10 02:05:06 1.63
+++ compiler/module_qual.m 2001/03/14 13:20:05
@@ -7,15 +7,15 @@
:- module module_qual.
% Main authors: stayl, fjh.
%
-% Module qualifies types, insts and modes within declaration items.
-% The head of all declarations should be module qualified in prog_io.m.
-% This module qualifies the bodies of the declarations.
-% Checks for undefined types, insts and modes.
-% Uses two passes over the item list, one to collect all type, mode
-% and inst ids and a second to do the qualification and report errors.
-% If the --warn-interface-imports option is set, warns about modules
-% imported in the interface that do not need to be in the interface.
-% The modes of lambda expressions are qualified in modes.m.
+% Module qualifies types, insts and modes and edcg variables within
+% declaration items. The head of all declarations should be module
+% qualified in prog_io.m. This module qualifies the bodies of the
+% declarations. hecks for undefined types, insts and modes. Uses two
+% passes over the item list, one to collect all type, mode, inst and edcg
+% variable ids and a second to do the qualification and report errors. If
+% the --warn-interface-imports option is set, warns about modules imported
+% in the interface that do not need to be in the interface. The modes of
+% lambda expressions are qualified in modes.m.
%
:- interface.
@@ -51,6 +51,21 @@
:- mode module_qual__qualify_type_qualification(in, out, in, in,
out, di, uo) is det.
+ % This is called from make_hlds.m to qualify a
+ % edcg variable used by a edcg operator.
+:- pred module_qual__qualify_edcg_arg(edcg_arg, edcg_arg, prog_context,
+ mq_info, mq_info, io__state, io__state).
+:- mode module_qual__qualify_edcg_arg(in, out, in, in,
+ out, di, uo) is det.
+
+ % This is called from make_hlds.m to qualify a
+ % list of edcg variables in a predicate call.
+:- pred module_qual__qualify_edcg_arg_list(list(edcg_arg), list(edcg_arg),
+ sym_name, arity, prog_context, mq_info, mq_info,
+ io__state, io__state).
+:- mode module_qual__qualify_edcg_arg_list(in, out, in, in, in, in, out,
+ di, uo) is det.
+
% The type mq_info holds information needed for doing module
% qualification.
:- type mq_info.
@@ -126,6 +141,17 @@
{ mq_info_set_error_context(Info0, lambda_expr - Context, Info1) },
qualify_mode_list(Modes0, Modes, Info1, Info).
+module_qual__qualify_edcg_arg(EDCG0, EDCG, Context, Info0, Info) -->
+ { mq_info_set_error_context(Info0, edcg_op(EDCG0 - 0) - Context,
+ Info1) },
+ qualify_edcg(EDCG0, EDCG, Info1, Info).
+
+module_qual__qualify_edcg_arg_list(EDCGs0, EDCGs, PredName, PredArity,
+ Context, Info0, Info) -->
+ { mq_info_set_error_context(Info0,
+ pred_call(PredName - PredArity) - Context, Info1) },
+ qualify_edcgs(EDCGs0, EDCGs, Info1, Info).
+
module_qual__qualify_type_qualification(Type0, Type, Context, Info0, Info) -->
{ mq_info_set_error_context(Info0, type_qual - Context, Info1) },
qualify_type(Type0, Type, Info1, Info).
@@ -139,12 +165,14 @@
imported_modules::set(module_name),
% Sets of all modules, types, insts, modes,
- % and typeclasses visible in this module.
+ % edcg variables and typeclasses visible in this
+ % module.
modules::module_id_set,
types::type_id_set,
insts::inst_id_set,
modes::mode_id_set,
classes::class_id_set,
+ etypes::edcg_id_set,
unused_interface_modules::set(module_name),
% modules imported in the
@@ -196,7 +224,7 @@
:- pred collect_mq_info_2(item::in, mq_info::in, mq_info::out) is det.
-collect_mq_info_2(pred_clause(_,_,_,_), Info, Info).
+collect_mq_info_2(pred_clause(_,_,_,_,_), Info, Info).
collect_mq_info_2(func_clause(_,_,_,_,_), Info, Info).
collect_mq_info_2(type_defn(_, TypeDefn, _), Info0, Info) :-
add_type_defn(TypeDefn, Info0, Info).
@@ -204,10 +232,13 @@
add_inst_defn(InstDefn, Info0, Info).
collect_mq_info_2(mode_defn(_, ModeDefn, _), Info0, Info) :-
add_mode_defn(ModeDefn, Info0, Info).
+collect_mq_info_2(emode_defn(_,_,_), Info, Info).
+collect_mq_info_2(etype_defn(_,Name,HtypeDefn), Info0, Info) :-
+ add_etype_defn(Name,HtypeDefn, Info0, Info).
collect_mq_info_2(module_defn(_, ModuleDefn), Info0, Info) :-
process_module_defn(ModuleDefn, Info0, Info).
-collect_mq_info_2(pred(_,__,_,_,_,_,_,_,_), Info, Info).
-collect_mq_info_2(func(_,_,__,_,_,_,_,_,_,_), Info, Info).
+collect_mq_info_2(pred(_,_,_,_,_,_,_,_,_,_), Info, Info).
+collect_mq_info_2(func(_,_,_,_,_,_,_,_,_,_), Info, Info).
collect_mq_info_2(pred_mode(_,_,_,_,_), Info, Info).
collect_mq_info_2(func_mode(_,_,_,_,_,_), Info, Info).
collect_mq_info_2(pragma(_), Info, Info).
@@ -260,6 +291,16 @@
id_set_insert(NeedQualifier, SymName - Arity, Types0, Types),
mq_info_set_types(Info0, Types, Info).
+:- pred add_etype_defn(sym_name::in, etype_defn::in, mq_info::in,
+ mq_info::out) is det.
+
+add_etype_defn(SymName, _HtypeDefn, Info0, Info) :-
+ mq_info_get_etypes(Info0, Htypes0),
+ mq_info_get_need_qual_flag(Info0, NeedQualifier),
+ edcg_name_to_id(SymName, EDCGId),
+ id_set_insert(NeedQualifier, EDCGId, Htypes0, Htypes),
+ mq_info_set_etypes(Info0, Htypes, Info).
+
:- pred add_inst_defn(inst_defn::in, mq_info::in, mq_info::out) is det.
add_inst_defn(InstDefn, Info0, Info) :-
@@ -416,15 +457,20 @@
list__append(Symbols0, SymbolsC, Symbols),
bool__and(SuccessA, SuccessB, Success0),
bool__and(Success0, SuccessC, Success).
-process_assert(call(SymName, Args0, _Purity) - _, Symbols, Success) :-
+process_assert(call(SymName, Args0, EDCGs0, _Purity) - _, Symbols, Success) :-
(
SymName = qualified(_, _)
->
list__map(term__coerce, Args0, Args),
+ assoc_list__values(EDCGs0, EDCGArgs0),
+ list__condense(EDCGArgs0, EDCGArgs1),
+ list__map(term__coerce, EDCGArgs1, EDCGArgs),
(
- term_qualified_symbols_list(Args, Symbols0)
+ term_qualified_symbols_list(Args, Symbols0),
+ term_qualified_symbols_list(EDCGArgs, Symbols1),
+ list__append(Symbols0, Symbols1, Symbols2)
->
- Symbols = [SymName | Symbols0],
+ Symbols = [SymName | Symbols2],
Success = yes
;
Symbols = [],
@@ -447,6 +493,19 @@
Symbols = [],
Success = no
).
+process_assert(edcg_goal(Head0, Body) - _, Symbols, Success) :-
+ term__coerce(Head0, Head),
+ process_assert(Body, Symbols1, Success1),
+ (
+ term_qualified_symbols(Head, Symbols0)
+ ->
+ list__append(Symbols0, Symbols1, Symbols),
+ Success0 = yes
+ ;
+ Symbols = Symbols1,
+ Success0 = no
+ ),
+ bool__or(Success0, Success1, Success).
% term_qualified_symbols(T, S)
%
@@ -500,12 +559,20 @@
mq_info::in, mq_info::out, bool::out,
io__state::di, io__state::uo) is det.
-module_qualify_item(pred_clause(A,B,C,D) - Con, pred_clause(A,B,C,D) - Con,
+module_qualify_item(pred_clause(A,B,C,D,E) - Con, pred_clause(A,B,C,D,E) - Con,
Info, Info, yes) --> [].
module_qualify_item(func_clause(A,B,C,D,E) - Con, func_clause(A,B,C,D,E) - Con,
Info, Info, yes) --> [].
+module_qualify_item(etype_defn(A, Name, HtypeDefn0) - Context,
+ etype_defn(A, Name, HtypeDefn) - Context, Info0, Info, yes) -->
+ qualify_etype_defn(Name, HtypeDefn0, HtypeDefn, Info0, Info, Context).
+
+module_qualify_item(emode_defn(A, Name, HmodeDefn0) - Context,
+ emode_defn(A, Name, HmodeDefn) - Context, Info0, Info, yes) -->
+ qualify_emode_defn(Name, HmodeDefn0, HmodeDefn, Info0, Info, Context).
+
module_qualify_item(type_defn(A, TypeDefn0, C) - Context,
type_defn(A, TypeDefn, C) - Context, Info0, Info, yes) -->
qualify_type_defn(TypeDefn0, TypeDefn, Info0, Info, Context).
@@ -523,16 +590,20 @@
{ update_import_status(ModuleDefn, Info0, Info, Continue) }.
module_qualify_item(
- pred(A, IVs, B, SymName, TypesAndModes0, C, D, E,
- Constraints0) - Context,
- pred(A, IVs, B, SymName, TypesAndModes, C, D, E,
- Constraints) - Context,
+ pred(A, IVs, B, SymName, TypesAndModes0, FormsAndNames0, C, D,
+ E, Constraints0) - Context,
+ pred(A, IVs, B, SymName, TypesAndModes, FormsAndNames, C, D,
+ E, Constraints) - Context,
Info0, Info, yes) -->
{ list__length(TypesAndModes0, Arity) },
{ mq_info_set_error_context(Info0, pred(SymName - Arity) - Context,
Info1) },
qualify_types_and_modes(TypesAndModes0, TypesAndModes, Info1, Info2),
- qualify_class_constraints(Constraints0, Constraints, Info2, Info).
+ { assoc_list__keys(FormsAndNames0, EDCGs0) },
+ { assoc_list__values(FormsAndNames0, Forms) },
+ qualify_edcgs(EDCGs0, EDCGs, Info2, Info3),
+ { assoc_list__from_corresponding_lists(EDCGs, Forms, FormsAndNames) },
+ qualify_class_constraints(Constraints0, Constraints, Info3, Info).
module_qualify_item(
func(A, IVs, B, SymName, TypesAndModes0, TypeAndMode0, F, G, H,
@@ -894,6 +965,88 @@
Info = Info2
}.
+ % Qualify the type of a edcg argument declaration.
+:- pred qualify_etype_defn(sym_name::in, etype_defn::in, etype_defn::out,
+ mq_info::in, mq_info::out, term__context::in,
+ io__state::di, io__state::uo) is det.
+
+qualify_etype_defn(Name, etype_defn(Type0),
+ etype_defn(Type),
+ Info0, Info, Context) -->
+ { Arity is 0 },
+ { mq_info_set_error_context(Info0, etype(Name - Arity) - Context,
+ Info1) },
+ qualify_type(Type0, Type, Info1, Info).
+
+ % Qualify the mode(s) of a edcg argument mode declaration.
+:- pred qualify_emode_defn(sym_name::in, emode_defn::in, emode_defn::out,
+ mq_info::in, mq_info::out, term__context::in,
+ io__state::di, io__state::uo) is det.
+
+qualify_emode_defn(Name, HmodeDefn0, HmodeDefn,
+ Info0, Info, Context) -->
+ { Arity is 0 },
+ { mq_info_set_error_context(Info0, emode(Name - Arity) - Context,
+ Info1) },
+ qualify_emode_defn_2(changed, HmodeDefn0, HmodeDefn1, Info1, Info2),
+ qualify_emode_defn_2(produced, HmodeDefn1, HmodeDefn2, Info2, Info3),
+ qualify_emode_defn_2(passed, HmodeDefn2, HmodeDefn, Info3, Info).
+
+:- pred qualify_emode_defn_2(form, emode_defn, emode_defn, mq_info, mq_info,
+ io__state, io__state).
+:- mode qualify_emode_defn_2(in, in, out, in, out, di, uo) is det.
+
+qualify_emode_defn_2(Form, HmodeDefn0, HmodeDefn, Info0, Info) -->
+ ( { get_edcg_modes(Form, HmodeDefn0, ModeList0) } ->
+ qualify_mode_list(ModeList0, ModeList, Info0, Info),
+ (
+ % Fails if ModeList is the wrong length.
+ % This was checked earlier.
+ { set_edcg_modes(Form, HmodeDefn0, ModeList,
+ HmodeDefn1) }
+ ->
+ { HmodeDefn1 = HmodeDefn }
+ ;
+ { error("emode_defn data structure access error.") }
+ )
+ ;
+ % No mode declaration for Form.
+ { Info0 = Info },
+ { HmodeDefn0 = HmodeDefn }
+ ).
+
+
+ % Also checks for duplicates.
+:- pred qualify_edcgs(list(edcg_arg), list(edcg_arg),
+ mq_info, mq_info, io__state, io__state).
+:- mode qualify_edcgs(in, out, in, out, di, uo) is det.
+
+qualify_edcgs(EDCGArgs0, EDCGArgs, Info0, Info) -->
+ qualify_edcgs_2(EDCGArgs0, EDCGArgs, Info0, Info1),
+ { list__remove_dups(EDCGArgs, _, DupEDCGArgs) },
+ maybe_dup_error(DupEDCGArgs, Info1, Info).
+
+:- pred qualify_edcgs_2(list(edcg_arg), list(edcg_arg),
+ mq_info, mq_info, io__state, io__state).
+:- mode qualify_edcgs_2(in, out, in, out, di, uo) is det.
+
+qualify_edcgs_2([], [], Info, Info) --> [].
+qualify_edcgs_2([EDCG0|Others0], [EDCG|Others],
+ Info0, Info) -->
+ qualify_edcg(EDCG0, EDCG, Info0, Info1),
+ qualify_edcgs_2(Others0, Others, Info1, Info).
+
+:- pred qualify_edcg(edcg_arg, edcg_arg, mq_info, mq_info,
+ io__state, io__state).
+:- mode qualify_edcg(in, out, in, out, di, uo) is det.
+
+qualify_edcg(EDCG0, EDCG, Info0, Info) -->
+ { mq_info_get_etypes(Info0, Htypes) },
+ { edcg_name_to_id(EDCG0, EDCGId0) },
+ find_unique_match(EDCGId0, EDCGId, Htypes, edcg_id,
+ Info0, Info),
+ { id_to_edcg_name(EDCGId, EDCG) }.
+
% Qualify the modes in a pragma c_code(...) decl.
:- pred qualify_pragma((pragma_type)::in, (pragma_type)::out,
mq_info::in, mq_info::out, io__state::di, io__state::uo) is det.
@@ -1175,7 +1328,8 @@
type_id
; mode_id
; inst_id
- ; class_id.
+ ; class_id
+ ; edcg_id.
:- type error_context == pair(error_context2, prog_context).
@@ -1185,16 +1339,29 @@
type(id)
; inst(id)
; mode(id)
+ ; emode(id)
+ ; etype(id)
+ ; edcg_op(id)
; pred(id)
; func(id)
; pred_mode(id)
; func_mode(id)
+ ; pred_call(id)
; (pragma)
; lambda_expr
; type_qual
; class(id)
; instance(id).
+ % EDCG arguments have no arguments so their arity is assigned to 0.
+:- pred edcg_name_to_id(sym_name::in, id::out) is det.
+edcg_name_to_id(SymName, SymName - 0).
+
+ % EDCG arguments have no arguments so their arity is irrelevant.
+:- pred id_to_edcg_name(id::in, sym_name::out) is det.
+id_to_edcg_name(SymName - _, SymName).
+
+
% Report an undefined type, inst or mode.
:- pred report_undefined(mq_info, pair(sym_name, int),
id_type, io__state, io__state).
@@ -1277,12 +1444,24 @@
write_error_context2(inst(Id)) -->
io__write_string("definition of inst "),
write_id(Id).
+write_error_context2(etype(Id)) -->
+ io__write_string("type declaration for edcg argument "),
+ write_id(Id).
+write_error_context2(emode(Id)) -->
+ io__write_string("mode declaration for edcg argument "),
+ write_id(Id).
+write_error_context2(edcg_op(Id)) -->
+ io__write_string("use of edcg operator for edcg argument "),
+ write_id(Id).
write_error_context2(pred(Id)) -->
io__write_string("definition of predicate "),
write_id(Id).
write_error_context2(pred_mode(Id)) -->
io__write_string("mode declaration for predicate "),
write_id(Id).
+write_error_context2(pred_call(Id)) -->
+ io__write_string("call to predicate "),
+ write_id(Id).
write_error_context2(func(Id)) -->
io__write_string("definition of function "),
write_id(Id).
@@ -1308,6 +1487,7 @@
id_type_to_string(mode_id, "mode").
id_type_to_string(inst_id, "inst").
id_type_to_string(class_id, "typeclass").
+id_type_to_string(edcg_id, "edcg argument").
% Write sym_name/arity.
:- pred write_id(id::in, io__state::di, io__state::uo) is det.
@@ -1388,6 +1568,42 @@
mercury_output_term(Type, VarSet, no),
io__write_string("'.\n").
+ % Outputs error message resulting from multiple listings of edcg
+ % arguments in pred declarations or predicate calls.
+:- pred maybe_dup_error(list(edcg_arg), mq_info, mq_info,
+ io__state, io__state).
+:- mode maybe_dup_error(in, in, out, di, uo) is det.
+
+maybe_dup_error([], Info, Info) --> [].
+maybe_dup_error([EDCGArg | EDCGArgs], Info0, Info) -->
+ (
+ { mq_info_get_report_error_flag(Info0, yes) }
+ ->
+ { mq_info_set_error_flag(Info0, edcg_id, Info1) },
+ { mq_info_incr_errors(Info1, Info2) },
+ { mq_info_get_error_context(Info2, ErrorContext) },
+ report_dup_error(EDCGArg, ErrorContext),
+ maybe_dup_error(EDCGArgs, Info2, Info)
+ ;
+ { Info0 = Info }
+ ).
+
+:- pred report_dup_error(edcg_arg, error_context, io__state, io__state).
+:- mode report_dup_error(in, in, di, uo) is det.
+
+report_dup_error(EDCGArg, ErrorContext - Context) -->
+ io__set_exit_status(1),
+ prog_out__write_context(Context),
+ io__write_string("In"),
+ write_error_context2(ErrorContext),
+ io__write_string("\n"),
+ prog_out__write_context(Context),
+ io__write_string(" edcg argument error: Multiple inclusions of\n"),
+ prog_out__write_context(Context),
+ io__write_string(" "),
+ write_id(EDCGArg - 0),
+ io__write_string(".\n").
+
%-----------------------------------------------------------------------------%
% is_builtin_atomic_type(TypeId)
@@ -1417,8 +1633,8 @@
set__list_to_set(ImportDeps `list__append` UseDeps, ImportedModules),
id_set_init(Empty),
Info0 = mq_info(ImportedModules, Empty, Empty, Empty, Empty,
- Empty, InterfaceModules0, not_exported, 0, no, no,
- ReportErrors, ErrorContext, ModuleName,
+ Empty, Empty, InterfaceModules0, not_exported, 0, no,
+ no, ReportErrors, ErrorContext, ModuleName,
may_be_unqualified).
:- pred mq_info_get_imported_modules(mq_info::in, set(module_name)::out) is det.
@@ -1427,6 +1643,7 @@
:- pred mq_info_get_insts(mq_info::in, inst_id_set::out) is det.
:- pred mq_info_get_modes(mq_info::in, mode_id_set::out) is det.
:- pred mq_info_get_classes(mq_info::in, class_id_set::out) is det.
+:- pred mq_info_get_etypes(mq_info::in, edcg_id_set::out) is det.
:- pred mq_info_get_unused_interface_modules(mq_info::in,
set(module_name)::out) is det.
:- pred mq_info_get_import_status(mq_info::in, import_status::out) is det.
@@ -1442,6 +1659,7 @@
mq_info_get_insts(MQInfo, MQInfo^insts).
mq_info_get_modes(MQInfo, MQInfo^modes).
mq_info_get_classes(MQInfo, MQInfo^classes).
+mq_info_get_etypes(MQInfo, MQInfo^etypes).
mq_info_get_unused_interface_modules(MQInfo, MQInfo^unused_interface_modules).
mq_info_get_import_status(MQInfo, MQInfo^import_status).
mq_info_get_num_errors(MQInfo, MQInfo^num_errors).
@@ -1459,6 +1677,7 @@
:- pred mq_info_set_insts(mq_info::in, inst_id_set::in, mq_info::out) is det.
:- pred mq_info_set_modes(mq_info::in, mode_id_set::in, mq_info::out) is det.
:- pred mq_info_set_classes(mq_info::in, class_id_set::in, mq_info::out) is det.
+:- pred mq_info_set_etypes(mq_info::in, edcg_id_set::in, mq_info::out) is det.
:- pred mq_info_set_unused_interface_modules(mq_info::in, set(module_name)::in,
mq_info::out) is det.
:- pred mq_info_set_import_status(mq_info::in, import_status::in,
@@ -1475,6 +1694,7 @@
mq_info_set_insts(MQInfo, Insts, MQInfo^insts := Insts).
mq_info_set_modes(MQInfo, Modes, MQInfo^modes := Modes).
mq_info_set_classes(MQInfo, Classes, MQInfo^classes := Classes).
+mq_info_set_etypes(MQInfo, Htypes, MQInfo^etypes := Htypes).
mq_info_set_unused_interface_modules(MQInfo,
Modules, MQInfo^unused_interface_modules := Modules).
mq_info_set_import_status(MQInfo, Status, MQInfo^import_status := Status).
@@ -1497,6 +1717,8 @@
mq_info_set_mode_error_flag(Info0, Info).
mq_info_set_error_flag(Info0, class_id, Info) :-
mq_info_set_type_error_flag(Info0, Info).
+mq_info_set_error_flag(Info0, edcg_id, Info) :-
+ mq_info_set_type_error_flag(Info0, Info).
% If the current item is in the interface, remove its module
% name from the list of modules not used in the interface
@@ -1554,6 +1776,7 @@
:- type mode_id_set == id_set.
:- type inst_id_set == id_set.
:- type class_id_set == id_set.
+:- type edcg_id_set == id_set.
% Modules don't have an arity, but for simplicity we use the same
% data structure here, assigning arity zero to all module names.
:- type module_id_set == id_set.
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.154
diff -u -r1.154 modules.m
--- compiler/modules.m 2001/03/01 12:06:30 1.154
+++ compiler/modules.m 2001/03/12 15:35:52
@@ -956,7 +956,7 @@
check_for_clauses_in_interface([ItemAndContext0 | Items0], Items) -->
{ ItemAndContext0 = Item0 - Context },
(
- ( { Item0 = pred_clause(_,_,_,_) }
+ ( { Item0 = pred_clause(_,_,_,_,_) }
; { Item0 = func_clause(_,_,_,_,_) }
)
->
@@ -1003,7 +1003,7 @@
->
split_clauses_and_decls(Items0, ClauseItems, InterfaceItems)
;
- ( Item0 = pred_clause(_,_,_,_)
+ ( Item0 = pred_clause(_,_,_,_,_)
; Item0 = func_clause(_,_,_,_,_)
; Item0 = pragma(Pragma),
pragma_allowed_in_interface(Pragma, no)
Index: compiler/options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.315
diff -u -r1.315 options.m
--- compiler/options.m 2001/03/05 03:35:26 1.315
+++ compiler/options.m 2001/03/13 01:01:06
@@ -127,9 +127,11 @@
; infer_types
; infer_modes
; infer_det
+ ; infer_edcgs
; infer_all
; type_inference_iteration_limit
; mode_inference_iteration_limit
+ ; edcg_inference_iteration_limit
% Compilation Model options
; grade
; target
@@ -543,9 +545,11 @@
infer_types - bool(no),
infer_modes - bool(no),
infer_det - bool(yes),
+ infer_edcgs - bool(no),
infer_all - bool_special,
type_inference_iteration_limit - int(60),
- mode_inference_iteration_limit - int(30)
+ mode_inference_iteration_limit - int(30),
+ edcg_inference_iteration_limit - int(30)
]).
option_defaults_2(compilation_model_option, [
% Compilation model options (ones that affect binary
@@ -960,10 +964,13 @@
long_option("infer-modes", infer_modes).
long_option("infer-determinism", infer_det).
long_option("infer-det", infer_det).
+long_option("infer-edcgs", infer_edcgs).
long_option("type-inference-iteration-limit",
type_inference_iteration_limit).
long_option("mode-inference-iteration-limit",
mode_inference_iteration_limit).
+long_option("edcg-inference-iteration-limit",
+ edcg_inference_iteration_limit).
% compilation model options
long_option("grade", grade).
@@ -1364,7 +1371,8 @@
override_options([
infer_types - bool(Infer),
infer_modes - bool(Infer),
- infer_det - bool(Infer)
+ infer_det - bool(Infer),
+ infer_edcgs - bool(Infer)
], OptionTable0, OptionTable).
special_handler(opt_space, none, OptionTable0, ok(OptionTable)) :-
opt_space(OptionSettingsList),
Index: compiler/pd_cost.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pd_cost.m,v
retrieving revision 1.10
diff -u -r1.10 pd_cost.m
--- compiler/pd_cost.m 2000/11/17 17:48:27 1.10
+++ compiler/pd_cost.m 2001/03/12 15:35:52
@@ -61,7 +61,7 @@
pd_cost__goal(Else, Cost3),
Cost is Cost1 + Cost2 + Cost3.
-pd_cost__goal(call(_, _, Args, BuiltinState, _, _) - _, Cost) :-
+pd_cost__goal(call(_, _, Args, _, BuiltinState, _, _) - _, Cost) :-
( BuiltinState = inline_builtin ->
pd_cost__builtin_call(Cost)
;
@@ -107,6 +107,10 @@
pd_cost__goal(bi_implication(_, _) - _, _) :-
% these should have been expanded out by now
error("pd_cost__goal: unexpected bi_implication").
+
+pd_cost__goal(edcg_goal(_, _, _) - _, _) :-
+ % these should have been expanded out by now
+ error("pd_cost__goal: unexpected edcg_goal").
:- pred pd_cost__unify(set(prog_var)::in, unification::in, int::out) is det.
Index: compiler/pd_term.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pd_term.m,v
retrieving revision 1.2
diff -u -r1.2 pd_term.m
--- compiler/pd_term.m 1998/11/20 04:08:44 1.2
+++ compiler/pd_term.m 2001/03/12 15:35:52
@@ -123,8 +123,8 @@
_InstMap, Versions, Info0, Info, Result) :-
Info0 = global_term_info(SingleGoalCover0, MultipleGoalCover0),
(
- EarlierGoal = call(PredId1, ProcId1, _, _, _, _) - _,
- LaterGoal = call(PredId2, ProcId2, _, _, _, _) - _,
+ EarlierGoal = call(PredId1, ProcId1, _, _, _, _, _) - _,
+ LaterGoal = call(PredId2, ProcId2, _, _, _, _, _) - _,
Hd = lambda([List::in, Head::out] is semidet,
List = [Head | _]),
expand_calls(Hd, Versions, proc(PredId1, ProcId1),
@@ -203,7 +203,7 @@
%-----------------------------------------------------------------------------%
pd_term__local_check(ModuleInfo, Goal1, InstMap, Cover0, Cover) :-
- Goal1 = call(PredId, ProcId, Args, _, _, _) - _,
+ Goal1 = call(PredId, ProcId, Args, _, _, _, _) - _,
( map__search(Cover0, proc(PredId, ProcId), CoveringInstSizes0) ->
pd_term__do_local_check(ModuleInfo, InstMap, Args,
CoveringInstSizes0, CoveringInstSizes),
Index: compiler/pd_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pd_util.m,v
retrieving revision 1.14
diff -u -r1.14 pd_util.m
--- compiler/pd_util.m 2000/11/19 12:43:31 1.14
+++ compiler/pd_util.m 2001/03/12 15:35:52
@@ -137,7 +137,7 @@
pd_util__goal_get_calls(Goal0, CalledPreds) :-
goal_to_conj_list(Goal0, GoalList),
GetCalls = lambda([Goal::in, CalledPred::out] is semidet, (
- Goal = call(PredId, ProcId, _, _, _, _) - _,
+ Goal = call(PredId, ProcId, _, _, _, _, _) - _,
CalledPred = proc(PredId, ProcId)
)),
list__filter_map(GetCalls, GoalList, CalledPreds).
@@ -623,7 +623,7 @@
pd_util__examine_branch(_, _, _, [], _, _, Vars, Vars).
pd_util__examine_branch(ModuleInfo, ProcArgInfo, BranchNo,
[Goal | Goals], VarTypes, InstMap, Vars0, Vars) :-
- ( Goal = call(PredId, ProcId, Args, _, _, _) - _ ->
+ ( Goal = call(PredId, ProcId, Args, _, _, _, _) - _ ->
(
map__search(ProcArgInfo, proc(PredId, ProcId),
ThisProcArgInfo)
@@ -948,8 +948,8 @@
NewArgs = [NewVar | NewArgs1]
)
;
- OldGoal = call(PredId, ProcId, OldArgs, _, _, _) - _,
- NewGoal = call(PredId, ProcId, NewArgs, _, _, _) - _
+ OldGoal = call(PredId, ProcId, OldArgs, _, _, _, _) - _,
+ NewGoal = call(PredId, ProcId, NewArgs, _, _, _, _) - _
;
% We don't need to check the modes here -
% if the goals match and the insts of the argument
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.206
diff -u -r1.206 polymorphism.m
--- compiler/polymorphism.m 2001/02/12 05:14:44 1.206
+++ compiler/polymorphism.m 2001/03/12 15:35:53
@@ -583,7 +583,7 @@
->
{ Clause = Clause0 }
;
- { Clause0 = clause(ProcIds, Goal0, Context) },
+ { Clause0 = clause(ProcIds, Goal0, Context, MaybeEDCG) },
%
% process any polymorphic calls inside the goal
%
@@ -602,7 +602,7 @@
{ pred_info_get_exist_quant_tvars(PredInfo0, ExistQVars) },
polymorphism__fixup_quantification(NewHeadVars, ExistQVars,
Goal2, Goal),
- { Clause = clause(ProcIds, Goal, Context) }
+ { Clause = clause(ProcIds, Goal, Context, MaybeEDCG) }
).
:- pred polymorphism__process_procs(list(proc_id), proc_table,
@@ -1057,13 +1057,13 @@
).
polymorphism__process_goal_expr(Goal0, GoalInfo, Goal) -->
- { Goal0 = call(PredId, ProcId, ArgVars0, Builtin,
+ { Goal0 = call(PredId, ProcId, ArgVars0, EDCGArgs, Builtin,
UnifyContext, Name) },
polymorphism__process_call(PredId, ArgVars0, GoalInfo,
ArgVars, _ExtraVars, CallGoalInfo, ExtraGoals),
- { Call = call(PredId, ProcId, ArgVars, Builtin, UnifyContext, Name)
- - CallGoalInfo },
+ { Call = call(PredId, ProcId, ArgVars, EDCGArgs, Builtin,
+ UnifyContext, Name) - CallGoalInfo },
{ list__append(ExtraGoals, [Call], GoalList) },
{ conj_list_to_goal(GoalList, GoalInfo, Goal) }.
@@ -1159,6 +1159,9 @@
polymorphism__process_goal_expr(bi_implication(_, _), _, _) -->
% these should have been expanded out by now
{ error("polymorphism__process_goal_expr: unexpected bi_implication") }.
+polymorphism__process_goal_expr(edcg_goal(_, _, _), _, _) -->
+ % these should have been expanded out by now
+ { error("polymorphism__process_goal_expr: unexpected edcg_goal") }.
% type_info_vars prepends a comma seperated list of variables
@@ -1248,6 +1251,9 @@
{ goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo) },
{ Goal = unify(XVar, Y1, Mode, Unification0, UnifyContext)
- GoalInfo }
+ ;
+ { Y = edcg_op(_, _) },
+ { error("polymorphism__process_unify: unexpected edcg_op") }
).
polymorphism__unification_typeinfos(Type, TypeInfoMap,
@@ -1444,7 +1450,7 @@
CallUnifyContext = call_unify_context(X0,
functor(ConsId0, ArgVars0), UnifyContext),
- LambdaGoalExpr = call(PredId, ProcId, Args, not_builtin,
+ LambdaGoalExpr = call(PredId, ProcId, Args, [], not_builtin,
yes(CallUnifyContext), QualifiedPName),
%
@@ -2343,7 +2349,7 @@
ModuleInfo, PredId, ProcId),
Call = call(PredId, ProcId,
[SubClassVar, IndexVar, Var],
- not_builtin, no,
+ [], not_builtin, no,
ExtractSuperClass
),
@@ -3058,7 +3064,7 @@
Call = call(PredId, ProcId,
[TypeClassInfoVar, IndexVar, TypeInfoVar],
- not_builtin, no, ExtractTypeInfo) - GoalInfo,
+ [], not_builtin, no, ExtractTypeInfo) - GoalInfo,
Goals = [IndexGoal, Call].
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.29
diff -u -r1.29 post_typecheck.m
--- compiler/post_typecheck.m 2000/10/13 13:55:51 1.29
+++ compiler/post_typecheck.m 2001/03/12 15:35:53
@@ -1038,7 +1038,7 @@
list__append(ArgVars0, [X0], ArgVars),
FuncCallUnifyContext = call_unify_context(X0,
functor(ConsId0, ArgVars0), UnifyContext),
- FuncCall = call(PredId, ProcId, ArgVars, not_builtin,
+ FuncCall = call(PredId, ProcId, ArgVars, [], not_builtin,
yes(FuncCallUnifyContext), QualifiedFuncName),
PredInfo = PredInfo0,
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.63
diff -u -r1.63 prog_data.m
--- compiler/prog_data.m 2000/12/06 06:05:14 1.63
+++ compiler/prog_data.m 2001/03/14 06:15:07
@@ -44,8 +44,9 @@
:- type item_and_context == pair(item, prog_context).
:- type item
- ---> pred_clause(prog_varset, sym_name, list(prog_term), goal)
- % VarNames, PredName, HeadArgs, ClauseBody
+ ---> pred_clause(prog_varset, sym_name, list(prog_term), goal,
+ maybe_edcg)
+ % VarNames, PredName, HeadArgs, ClauseBody, IsEDCG
; func_clause(prog_varset, sym_name, list(prog_term),
prog_term, goal)
@@ -56,12 +57,16 @@
; mode_defn(inst_varset, mode_defn, condition)
; module_defn(prog_varset, module_defn)
+ ; etype_defn(tvarset, sym_name, etype_defn)
+ ; emode_defn(inst_varset, sym_name, emode_defn)
+
; pred(tvarset, inst_varset, existq_tvars, sym_name,
- list(type_and_mode), maybe(determinism), condition,
- purity, class_constraints)
+ list(type_and_mode), edcg_forms, maybe(determinism),
+ condition, purity, class_constraints)
% TypeVarNames, InstVarNames,
% ExistentiallyQuantifiedTypeVars, PredName, ArgTypes,
- % Deterministicness, Cond, Purity, TypeClassContext
+ % EDCGForms, Deterministicness, Cond, Purity,
+ % TypeClassContext
; func(tvarset, inst_varset, existq_tvars, sym_name,
list(type_and_mode), type_and_mode, maybe(determinism),
@@ -104,6 +109,21 @@
---> type_only(type)
; type_and_mode(type, mode).
+:- type edcg_arg == sym_name.
+
+:- type edcg_forms == assoc_list(edcg_arg, form).
+
+:- type form
+ ---> changed
+ ; passed
+ ; produced
+ ; nothing. % this form can only be inferred
+
+:- type maybe_edcg
+ ---> edcg_yes
+ ; edcg_no
+ ; edcg_fact.
+
:- type foreign_language
---> c
% ; cplusplus
@@ -618,8 +638,12 @@
; if_then(prog_vars, goal, goal)
; if_then_else(prog_vars, goal, goal, goal)
+ % EDCG goal
+ ; edcg_goal(prog_term, goal)
+
% atomic goals
- ; call(sym_name, list(prog_term), purity)
+ ; call(sym_name, list(prog_term),
+ assoc_list(sym_name, list(prog_term)), purity)
; unify(prog_term, prog_term, purity).
:- type goals == list(goal).
@@ -821,6 +845,21 @@
% mode/4 defined above
+ % Data constructors may need to be added later.
+:- type etype_defn
+ ---> etype_defn(type).
+
+:- type emode_defn
+ ---> emode_defn(
+ changed_modes,
+ passed_mode,
+ produced_mode
+ ).
+
+:- type changed_modes == maybe(pair(mode, mode)).
+:- type passed_mode == maybe(mode).
+:- type produced_mode == maybe(mode).
+
%-----------------------------------------------------------------------------%
%
% Module system
Index: compiler/prog_io.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io.m,v
retrieving revision 1.194
diff -u -r1.194 prog_io.m
--- compiler/prog_io.m 2000/11/01 05:12:11 1.194
+++ compiler/prog_io.m 2001/03/14 06:17:45
@@ -707,54 +707,75 @@
parse_dcg_clause(ModuleName, VarSet, DCG_H, DCG_B,
DCG_Context, Result)
;
- % It's either a fact or a rule
- ( %%% some [H, B, TermContext]
- Term = term__functor(term__atom(":-"), [H, B],
- TermContext)
- ->
- % it's a rule
- Head = H,
- Body = B,
- TheContext = TermContext
- ;
- % it's a fact
- Head = Term,
- (
- Head = term__functor(_Functor, _Args,
- HeadContext)
- ->
- TheContext = HeadContext
- ;
- % term consists of just a single
- % variable - the context has been lost
- term__context_init(TheContext)
- ),
- Body = term__functor(term__atom("true"), [], TheContext)
- ),
- varset__coerce(VarSet, ProgVarSet),
- parse_goal(Body, ProgVarSet, Body2, ProgVarSet2),
+ parse_clause(ModuleName, VarSet, Term, Result)
+ ).
+
+:- pred parse_clause(module_name, varset, term, maybe_item_and_context).
+:- mode parse_clause(in, in, in, out) is det.
+parse_clause(ModuleName, VarSet, Term, Result):-
+ % It's either a fact or a rule
+ ( %%% some [H, B, TermContext]
+ Term = term__functor(term__atom(":-"), [H, B], TermContext)
+ ->
+ % it's a rule
+ Head = H,
+ Body = B,
+ TheContext = TermContext,
+ MaybeEdcg = edcg_no
+ ;
+ Term = term__functor(term__atom("-->>"), [H, B], TermContext)
+ ->
+ % it's an edcg rule
+ Head = H,
+ Body = B,
+ TheContext = TermContext,
+ MaybeEdcg = edcg_yes
+ ;
+ % it's a fact
+ Head = Term,
(
- Head = term__functor(term__atom("="),
- [FuncHead, FuncResult], _)
+ Head = term__functor(_Functor, _Args,
+ HeadContext)
->
+ TheContext = HeadContext
+ ;
+ % term consists of just a single
+ % variable - the context has been lost
+ term__context_init(TheContext)
+ ),
+ Body = term__functor(term__atom("true"), [], TheContext),
+ MaybeEdcg = edcg_fact
+ ),
+ varset__coerce(VarSet, ProgVarSet),
+ parse_goal(Body, ProgVarSet, Body2, ProgVarSet2),
+ (
+ Head = term__functor(term__atom("="),
+ [FuncHead, FuncResult], _)
+ ->
+ ( MaybeEdcg = edcg_yes ->
+ R3 = error("EDCGs cannot be used with functions.",
+ Term)
+ ;
parse_implicitly_qualified_term(ModuleName,
FuncHead, Head, "equation head", R2),
process_func_clause(R2, FuncResult, ProgVarSet2, Body2,
R3)
- ;
- parse_implicitly_qualified_term(ModuleName,
- Head, Term, "clause head", R2),
- process_pred_clause(R2, ProgVarSet2, Body2, R3)
- ),
- add_context(R3, TheContext, Result)
- ).
+ )
+ ;
+ parse_implicitly_qualified_term(ModuleName,
+ Head, Term, "clause head", R2),
+ process_pred_clause(R2, ProgVarSet2, Body2, MaybeEdcg, R3)
+ ),
+ add_context(R3, TheContext, Result).
-:- pred process_pred_clause(maybe_functor, prog_varset, goal, maybe1(item)).
-:- mode process_pred_clause(in, in, in, out) is det.
-process_pred_clause(ok(Name, Args0), VarSet, Body,
- ok(pred_clause(VarSet, Name, Args, Body))) :-
+:- pred process_pred_clause(maybe_functor, prog_varset, goal, maybe_edcg,
+ maybe1(item)).
+:- mode process_pred_clause(in, in, in, in, out) is det.
+process_pred_clause(ok(Name, Args0), VarSet, Body, MaybeEDCG,
+ ok(pred_clause(VarSet, Name, Args, Body, MaybeEDCG))) :-
list__map(term__coerce, Args0, Args).
-process_pred_clause(error(ErrMessage, Term0), _, _, error(ErrMessage, Term)) :-
+process_pred_clause(error(ErrMessage, Term0), _, _, _,
+ error(ErrMessage, Term)) :-
term__coerce(Term0, Term).
:- pred process_func_clause(maybe_functor, term, prog_varset, goal,
@@ -841,6 +862,14 @@
process_decl(ModuleName, VarSet, "func", [FuncDecl], Attributes, Result) :-
parse_type_decl_func(ModuleName, VarSet, FuncDecl, Attributes, Result).
+process_decl(ModuleName, VarSet, "etype", TypeDecl, Attributes, Result) :-
+ parse_edcg_type_decl(ModuleName, VarSet, TypeDecl, Result0),
+ check_no_attributes(Result0, Attributes, Result).
+
+process_decl(ModuleName, VarSet, "emode", ModeDecl, Attributes, Result) :-
+ parse_edcg_mode_decl(ModuleName, VarSet, ModeDecl, Result0),
+ check_no_attributes(Result0, Attributes, Result).
+
process_decl(ModuleName, VarSet, "mode", [ModeDecl], Attributes, Result) :-
parse_mode_decl(ModuleName, VarSet, ModeDecl, Result0),
check_no_attributes(Result0, Attributes, Result).
@@ -1626,30 +1655,56 @@
get_class_context(ModuleName, Attributes0, Attributes, MaybeContext),
(
MaybeContext = ok(ExistQVars, Constraints),
- parse_implicitly_qualified_term(ModuleName,
- PredType, PredType, "`:- pred' declaration",
- R),
- process_pred_2(R, PredType, VarSet, MaybeDet, Cond,
- ExistQVars, Constraints, Attributes, Result)
- ;
- MaybeContext = error(String, Term),
- Result = error(String, Term)
- ).
+ (
+ % Does the predicate declaration have edcg
+ % arguments
+ PredType = term__functor(term__atom("+"),
+ [VisualDecl, EDCGDecl], _Context)
+ ->
+ VisualPredType = VisualDecl,
+ process_edcg_decl(EDCGDecl, PredType, MaybeEDCGFN)
+ ;
+ VisualPredType = PredType,
+ MaybeEDCGFN = ok([])
+ ),
+ process_pred_2(ModuleName, VisualPredType, PredType, VarSet,
+ MaybeDet, Cond, ExistQVars, Constraints, Attributes,
+ MaybeEDCGFN, Result)
+ ;
+ MaybeContext = error(String, Term),
+ Result = error(String, Term)
+ ).
-:- pred process_pred_2(maybe_functor, term, varset, maybe(determinism),
- condition, existq_tvars, class_constraints, decl_attrs,
+
+:- pred process_pred_2(module_name, term, term, varset,
+ maybe(determinism), condition, existq_tvars,
+ class_constraints, decl_attrs, maybe1(edcg_forms),
maybe1(item)).
-:- mode process_pred_2(in, in, in, in, in, in, in, in, out) is det.
+:- mode process_pred_2(in, in, in, in, in, in, in, in, in, in, out) is det.
+
+process_pred_2(ModuleName, VisualPredType, PredType, VarSet0, MaybeDet, Cond,
+ ExistQVars, ClassContext, Attributes0, ok(EDCGFN), Result) :-
+ parse_implicitly_qualified_term(ModuleName, VisualPredType, PredType,
+ "`:- pred' declaration", R),
+ process_pred_3(R, PredType, VarSet0, MaybeDet, Cond,
+ ExistQVars, ClassContext, Attributes0, EDCGFN, Result).
+process_pred_2(_, _, _, _, _, _, _, _, _, error(M, T), error(M, T)).
-process_pred_2(ok(F, As0), PredType, VarSet0, MaybeDet, Cond, ExistQVars,
- ClassContext, Attributes0, Result) :-
+:- pred process_pred_3(maybe_functor, term, varset, maybe(determinism),
+ condition, existq_tvars, class_constraints, decl_attrs,
+ edcg_forms, maybe1(item)).
+:- mode process_pred_3(in, in, in, in, in, in, in, in, in, out) is det.
+
+process_pred_3(ok(F, As0), PredType, VarSet0, MaybeDet, Cond, ExistQVars,
+ ClassContext, Attributes0, EDCGFN, Result) :-
( convert_type_and_mode_list(As0, As) ->
( verify_type_and_mode_list(As) ->
get_purity(Attributes0, Purity, Attributes),
varset__coerce(VarSet0, TVarSet),
varset__coerce(VarSet0, IVarSet),
Result0 = ok(pred(TVarSet, IVarSet, ExistQVars, F,
- As, MaybeDet, Cond, Purity, ClassContext)),
+ As, EDCGFN, MaybeDet, Cond, Purity,
+ ClassContext)),
check_no_attributes(Result0, Attributes, Result)
;
Result = error("some but not all arguments have modes",
@@ -1659,7 +1714,7 @@
Result = error("syntax error in `:- pred' declaration",
PredType)
).
-process_pred_2(error(M, T), _, _, _, _, _, _, _, error(M, T)).
+process_pred_3(error(M, T), _, _, _, _, _, _, _, _, error(M, T)).
:- pred get_purity(decl_attrs, purity, decl_attrs).
:- mode get_purity(in, out, out) is det.
@@ -1673,6 +1728,44 @@
Attributes = Attributes0
).
+:- pred process_edcg_decl(term, term, maybe1(edcg_forms)).
+:- mode process_edcg_decl(in, in, out) is det.
+
+process_edcg_decl(Term, PredType, Result):-
+ (
+ Term = term__functor(term__atom("edcg"), Args, _),
+ convert_to_edcg_forms(Args, EDCGArgs)
+ ->
+ Result = EDCGArgs
+ ;
+ Result = error("syntax error in `:- pred' declaration",
+ PredType)
+ ).
+
+:- pred convert_to_edcg_forms(list(term), maybe1(edcg_forms)).
+:- mode convert_to_edcg_forms(in, out) is semidet.
+
+convert_to_edcg_forms([], ok([])).
+convert_to_edcg_forms([Term|Others0], Result) :-
+ Term = term__functor(term__atom(FormString), [NameTerm], _),
+ parse_qualified_term(NameTerm, Term, "pred declaration", R),
+ ( R = error(Msg, T) ->
+ Result = error(Msg, T)
+ ; R = ok(SymName, []) ->
+ ( form_to_string(Form, FormString) ->
+ convert_to_edcg_forms(Others0, Others),
+ ( Others = ok(FormAndNameList) ->
+ Result = ok([SymName - Form|FormAndNameList])
+ ;
+ Result = Others
+ )
+ ;
+ Result = error("Unrecognised edcg form.", Term)
+ )
+ ;
+ Result = error("EDCG arguments take no arguments.", Term)
+ ).
+
%-----------------------------------------------------------------------------%
% We could perhaps get rid of some code duplication between here and
@@ -2320,6 +2413,110 @@
:- mode make_mode_defn(in, in, in, out) is det.
make_mode_defn(VarSet0, Cond, ModeDefn, mode_defn(VarSet, ModeDefn, Cond)) :-
varset__coerce(VarSet0, VarSet).
+
+%---------------------------------------------------------------------------%
+
+:- pred parse_edcg_type_decl(module_name, varset, list(term), maybe1(item)).
+:- mode parse_edcg_type_decl(in, in, in, out)is semidet.
+
+parse_edcg_type_decl(ModuleName, VarSet0, [NameTerm, Type0], Item):-
+ parse_implicitly_qualified_term(ModuleName, NameTerm, NameTerm,
+ "`:- etype' declaration", Result),
+ ( Result = ok(Name, []) ->
+ ( term__is_ground(Type0) ->
+ convert_type(Type0, Type),
+ varset__coerce(VarSet0, VarSet),
+ Item = ok(etype_defn(VarSet, Name, etype_defn(Type)))
+ ;
+ Item = error("EDCG arguments are not polymorphic",
+ NameTerm)
+ )
+ ; Result = ok(_, [_|_]) ->
+ Item = error("EDCG arguments take no arguments", NameTerm)
+ ;
+ Result = error(M, T),
+ Item = error(M, T)
+ ).
+
+%---------------------------------------------------------------------------%
+
+:- pred parse_edcg_mode_decl(module_name, varset, list(term), maybe1(item)).
+:- mode parse_edcg_mode_decl(in, in, in, out) is det.
+
+parse_edcg_mode_decl(_, _, [], Item) :-
+ dummy_term(DummyTerm),
+ Item = error("emode declarations take arguments.", DummyTerm).
+parse_edcg_mode_decl(ModuleName, VarSet0, [NameTerm|FormAndModeTerms], Item):-
+ parse_implicitly_qualified_term(ModuleName, NameTerm, NameTerm,
+ "`:- emode' declaration", Result),
+ (
+ Result = ok(_, [_|_])
+ ->
+ Item = error("EDCG arguments take no arguments", NameTerm)
+ ;
+ Result = error(M, T)
+ ->
+ Item = error(M, T)
+ ;
+ Result = ok(Name, []),
+ init_emode_defn(HmodeDefn0),
+ convert_to_form_and_mode(FormAndModeTerms, HmodeDefn0,
+ HmodeDefn)
+ ->
+ (
+ HmodeDefn = error(M, T),
+ Item = error(M, T)
+ ;
+ HmodeDefn = ok(FormAndModes),
+ varset__coerce(VarSet0, VarSet),
+ Item = ok(emode_defn(VarSet, Name, FormAndModes))
+ )
+ ;
+ Item = error("Multiple mode declarations for the same EDCG form for edcg",
+ NameTerm)
+ ).
+
+ % Fails if there are multiple mode declarations for the same form.
+:- pred convert_to_form_and_mode(list(term), emode_defn, maybe1(emode_defn)).
+:- mode convert_to_form_and_mode(in, in, out) is semidet.
+
+convert_to_form_and_mode([], HmodeDefn, ok(HmodeDefn)).
+convert_to_form_and_mode([Term|OtherTerms], HmodeDefn0, HmodeDefn) :-
+ Term = term__functor(term__atom(FormString), ModeList0, _),
+ ( form_to_string(Form, FormString) ->
+ ( check_number_of_modes(Form, ModeList0) ->
+ ( prog_io_util__convert_mode_list(ModeList0, ModeList) ->
+ init_edcg_modes(Form, HmodeDefn0, ModeList, HmodeDefn1),
+ convert_to_form_and_mode(OtherTerms, HmodeDefn1, HmodeDefn)
+ ;
+ HmodeDefn = error("Invalid mode(s)", Term)
+ )
+ ;
+ HmodeDefn = error("Wrong number of modes for EDCG form", Term)
+ )
+ ;
+ HmodeDefn = error("Unrecognized EDCG form", Term)
+ ).
+
+:- pred init_emode_defn(emode_defn::out) is det.
+
+init_emode_defn(emode_defn(no, no, no)).
+
+ % Fails if the modes are already defined.
+:- pred init_edcg_modes(form, emode_defn, list(mode), emode_defn).
+:- mode init_edcg_modes(in, in, in, out) is semidet.
+
+init_edcg_modes(changed, emode_defn(no,B,C), [Mode1, Mode2],
+ emode_defn(yes(Mode1 - Mode2),B,C)).
+init_edcg_modes(passed, emode_defn(A,no,C), [Mode],
+ emode_defn(A,yes(Mode),C)).
+init_edcg_modes(produced, emode_defn(A,B,no), [Mode],
+ emode_defn(A,B,yes(Mode))).
+
+:- pred check_number_of_modes(form::in, list(term)::in) is semidet.
+check_number_of_modes(changed, [_,_]).
+check_number_of_modes(passed, [_]).
+check_number_of_modes(produced, [_]).
%-----------------------------------------------------------------------------%
Index: compiler/prog_io_dcg.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_dcg.m,v
retrieving revision 1.16
diff -u -r1.16 prog_io_dcg.m
--- compiler/prog_io_dcg.m 2000/09/18 11:51:40 1.16
+++ compiler/prog_io_dcg.m 2001/03/12 15:35:53
@@ -112,7 +112,7 @@
list__append(Args0,
[term__variable(Var0),
term__variable(Var)], Args),
- Goal = call(SymName, Args, pure) - Context
+ Goal = call(SymName, Args, [], pure) - Context
)
;
% A call to a free variable, or to a number or string.
@@ -121,7 +121,7 @@
new_dcg_var(VarSet0, N0, VarSet, N, Var),
term__coerce(Term, ProgTerm),
Goal = call(unqualified("call"), [ProgTerm,
- term__variable(Var0), term__variable(Var)],
+ term__variable(Var0), term__variable(Var)], [],
pure) - Context
).
@@ -310,8 +310,8 @@
parse_dcg_goal_with_purity(G, VarSet0, N0, Var0, Purity, Goal, VarSet,
N, Var) :-
parse_dcg_goal(G, VarSet0, N0, Var0, Goal1, VarSet, N, Var),
- ( Goal1 = call(Pred, Args, pure) - Context ->
- Goal = call(Pred, Args, Purity) - Context
+ ( Goal1 = call(Pred, Args, EDCGArgs, pure) - Context ->
+ Goal = call(Pred, Args, EDCGArgs, Purity) - Context
; Goal1 = unify(ProgTerm1, ProgTerm2, pure) - Context ->
Goal = unify(ProgTerm1, ProgTerm2, Purity) - Context
;
@@ -321,7 +321,7 @@
Goal1 = _ - Context,
purity_name(Purity, PurityString),
term__coerce(G, G1),
- Goal = call(unqualified(PurityString), [G1], pure) - Context
+ Goal = call(unqualified(PurityString), [G1], [], pure) - Context
).
:- pred append_to_disjunct(goal, goal_expr, prog_context, goal).
@@ -460,7 +460,7 @@
:- mode process_dcg_clause(in, in, in, in, in, out) is det.
process_dcg_clause(ok(Name, Args0), VarSet, Var0, Var, Body,
- ok(pred_clause(VarSet, Name, Args, Body))) :-
+ ok(pred_clause(VarSet, Name, Args, Body, edcg_no))) :-
list__map(term__coerce, Args0, Args1),
list__append(Args1, [term__variable(Var0),
term__variable(Var)], Args).
Index: compiler/prog_io_goal.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_goal.m,v
retrieving revision 1.19
diff -u -r1.19 prog_io_goal.m
--- compiler/prog_io_goal.m 2000/04/22 07:12:00 1.19
+++ compiler/prog_io_goal.m 2001/03/12 15:35:53
@@ -97,7 +97,7 @@
:- import_module mode_util, purity, prog_io, prog_io_util, term_util.
:- import_module term.
-:- import_module int, map, string, std_util.
+:- import_module int, map, string, std_util, assoc_list.
% Parse a goal.
%
@@ -126,21 +126,41 @@
% it's not a builtin
term__coerce(Term, ArgsTerm),
(
+ ArgsTerm = term__functor(term__atom("+"),
+ [VisualTerm, EDCGTerm], _Context),
+ sym_name_and_args(EDCGTerm, unqualified("edcg"),
+ EDCGArgs0),
+ parse_edcg_args(EDCGArgs0, EDCGArgs),
+ sym_name_and_args(VisualTerm, SymName, VisualArgs)
+ ->
+ VarSet = VarSet0,
+ Goal = call(SymName, VisualArgs, EDCGArgs, pure)
+ - Context
+ ;
% check for predicate calls
- sym_name_and_args(ArgsTerm, SymName, Args)
+ sym_name_and_args(ArgsTerm, SymName, VisualArgs)
->
VarSet = VarSet0,
- Goal = call(SymName, Args, pure) - Context
+ Goal = call(SymName, VisualArgs, [], pure) - Context
;
% A call to a free variable, or to a number or string.
% Just translate it into a call to call/1 - the typechecker
% will catch calls to numbers and strings.
- Goal = call(unqualified("call"), [ArgsTerm], pure)
+ Goal = call(unqualified("call"), [ArgsTerm], [], pure)
- Context,
VarSet = VarSet0
)
).
+:- pred parse_edcg_args(list(prog_term),
+ assoc_list(sym_name, list(prog_term))).
+:- mode parse_edcg_args(in, out) is semidet.
+
+parse_edcg_args([], []).
+parse_edcg_args([EDCGTerm | EDCGTerms], [EDCGArg - Args | Rest]) :-
+ sym_name_and_args(EDCGTerm, EDCGArg, Args),
+ parse_edcg_args(EDCGTerms, Rest).
+
%-----------------------------------------------------------------------------%
:- pred parse_goal_2(string, list(term), prog_varset, goal_expr, prog_varset).
@@ -234,6 +254,9 @@
parse_goal_with_purity(A0, V0, (impure), A, V).
parse_goal_2("semipure", [A0], V0, A, V) :-
parse_goal_with_purity(A0, V0, (semipure), A, V).
+parse_goal_2("-->>", [EdcgGoalHead0, A0], V0, edcg_goal(EdcgGoalHead, A), V) :-
+ parse_goal(A0, V0, A, V),
+ term__coerce(EdcgGoalHead0, EdcgGoalHead).
:- pred parse_goal_with_purity(term, prog_varset, purity, goal_expr,
@@ -242,8 +265,8 @@
parse_goal_with_purity(A0, V0, Purity, A, V) :-
parse_goal(A0, V0, A1, V),
- ( A1 = call(Pred, Args, pure) - _ ->
- A = call(Pred, Args, Purity)
+ ( A1 = call(Pred, Args, EDCGArgs, pure) - _ ->
+ A = call(Pred, Args, EDCGArgs, Purity)
; A1 = unify(ProgTerm1, ProgTerm2, pure) - _ ->
A = unify(ProgTerm1, ProgTerm2, Purity)
;
@@ -252,7 +275,7 @@
% descriptive for these errors.
purity_name(Purity, PurityString),
term__coerce(A0, A2),
- A = call(unqualified(PurityString), [A2], pure)
+ A = call(unqualified(PurityString), [A2], [], pure)
).
Index: compiler/prog_io_typeclass.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_typeclass.m,v
retrieving revision 1.18
diff -u -r1.18 prog_io_typeclass.m
--- compiler/prog_io_typeclass.m 2000/11/01 05:12:13 1.18
+++ compiler/prog_io_typeclass.m 2001/03/12 15:35:53
@@ -214,9 +214,9 @@
item_to_class_method(error(String, Term), _, error(String, Term)).
item_to_class_method(ok(Item, Context), Term, Result) :-
(
- Item = pred(A, B, C, D, E, F, G, H, I)
+ Item = pred(A, B, C, D, E, _, G, H, I, J)
->
- Result = ok(pred(A, B, C, D, E, F, G, H, I, Context))
+ Result = ok(pred(A, B, C, D, E, G, H, I, J, Context))
;
Item = func(A, B, C, D, E, F, G, H, I, J)
->
@@ -639,7 +639,7 @@
Result0 = ok(Item, Context),
(
Item = pred_clause(_VarNames, ClassMethodName,
- HeadArgs, _ClauseBody),
+ HeadArgs, _ClauseBody, _MaybeEDCG),
PredOrFunc = predicate,
ArityInt = list__length(HeadArgs)
;
Index: compiler/prog_rep.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_rep.m,v
retrieving revision 1.5
diff -u -r1.5 prog_rep.m
--- compiler/prog_rep.m 2001/01/16 15:44:22 1.5
+++ compiler/prog_rep.m 2001/03/12 15:35:53
@@ -191,7 +191,7 @@
DetismRep, FilenameRep, LinenoRep, ChangedVarsRep),
Rep = atomic_goal_rep(DetismRep, FilenameRep, LinenoRep,
ChangedVarsRep, AtomicGoalRep).
-prog_rep__represent_goal_expr(call(PredId, _, Args, _, _, _),
+prog_rep__represent_goal_expr(call(PredId, _, Args, _, _, _, _),
GoalInfo, InstMap0, Info, Rep) :-
module_info_pred_info(Info^module_info, PredId, PredInfo),
pred_info_name(PredInfo, PredName),
@@ -213,6 +213,9 @@
prog_rep__represent_goal_expr(bi_implication(_, _), _, _, _, _) :-
% these should have been expanded out by now
error("prog_rep__represent_goal: unexpected bi_implication").
+prog_rep__represent_goal_expr(edcg_goal(_, _, _), _, _, _, _) :-
+ % these should have been expanded out by now
+ error("prog_rep__represent_goal: unexpected edcg_goal").
%---------------------------------------------------------------------------%
Index: compiler/prog_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_util.m,v
retrieving revision 1.51
diff -u -r1.51 prog_util.m
--- compiler/prog_util.m 2000/09/21 00:21:06 1.51
+++ compiler/prog_util.m 2001/03/14 12:10:15
@@ -122,6 +122,20 @@
:- pred construct_qualified_term(sym_name, list(term(T)), prog_context, term(T)).
:- mode construct_qualified_term(in, in, in, out) is det.
+ % extract the edcg modes for a particular edcg form from an
+ % emode_defn
+:- pred get_edcg_modes(form, emode_defn, list(mode)).
+:- mode get_edcg_modes(in, in, out) is semidet.
+
+ % set the edcg modes for a particular edcg form from an
+ % emode_defn
+:- pred set_edcg_modes(form, emode_defn, list(mode), emode_defn).
+:- mode set_edcg_modes(in, in, in, out) is semidet.
+
+:- pred form_to_string(form, string).
+:- mode form_to_string(in, out) is det.
+:- mode form_to_string(out, in) is semidet.
+
%-----------------------------------------------------------------------------%
% make_pred_name_with_context(ModuleName, Prefix, PredOrFunc, PredName,
@@ -179,7 +193,7 @@
:- implementation.
:- import_module mercury_to_mercury, (inst).
-:- import_module bool, string, int, map, varset.
+:- import_module bool, string, int, map, varset, assoc_list.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -308,17 +322,22 @@
prog_util__rename_in_goal(Cond0, OldVar, NewVar, Cond),
prog_util__rename_in_goal(Then0, OldVar, NewVar, Then),
prog_util__rename_in_goal(Else0, OldVar, NewVar, Else).
-prog_util__rename_in_goal_expr(call(SymName, Terms0, Purity), OldVar, NewVar,
- call(SymName, Terms, Purity)) :-
+prog_util__rename_in_goal_expr(call(SymName, Terms0, HTerms0, Purity), OldVar,
+ NewVar, call(SymName, Terms, HTerms, Purity)) :-
term__substitute_list(Terms0, OldVar, term__variable(NewVar),
- Terms).
+ Terms),
+ prog_util__rename_in_edcg_call(HTerms0, OldVar, NewVar, HTerms).
prog_util__rename_in_goal_expr(unify(TermA0, TermB0, Purity), OldVar, NewVar,
unify(TermA, TermB, Purity)) :-
term__substitute(TermA0, OldVar, term__variable(NewVar),
TermA),
term__substitute(TermB0, OldVar, term__variable(NewVar),
TermB).
-
+prog_util__rename_in_goal_expr(edcg_goal(Head0, Body0), OldVar, NewVar,
+ edcg_goal(Head, Body)) :-
+ term__substitute(Head0, OldVar, term__variable(NewVar), Head),
+ prog_util__rename_in_goal(Body0, OldVar, NewVar, Body).
+
:- pred prog_util__rename_in_vars(list(prog_var), prog_var, prog_var,
list(prog_var)).
:- mode prog_util__rename_in_vars(in, in, in, out) is det.
@@ -332,6 +351,20 @@
),
prog_util__rename_in_vars(Vars0, OldVar, NewVar, Vars).
+:- pred prog_util__rename_in_edcg_call(
+ assoc_list(edcg_arg, list(prog_term)), prog_var, prog_var,
+ assoc_list(edcg_arg, list(prog_term))).
+:- mode prog_util__rename_in_edcg_call(in, in, in, out) is det.
+
+prog_util__rename_in_edcg_call([], _, _, []).
+prog_util__rename_in_edcg_call([EDCG - Args0 | EDCGArgs0],
+ OldVar, NewVar, [EDCG - Args | EDCGArgs]) :-
+ term__substitute_list(Args0, OldVar, term__variable(NewVar),
+ Args),
+ prog_util__rename_in_edcg_call(EDCGArgs0, OldVar, NewVar,
+ EDCGArgs).
+
+
%-----------------------------------------------------------------------------%
% This would be simpler if we had a string__rev_sub_string_search/3 pred.
@@ -392,7 +425,26 @@
string__append(Name0, Suffix, Name).
add_sym_name_suffix(unqualified(Name0), Suffix, unqualified(Name)) :-
string__append(Name0, Suffix, Name).
-
+
+%-----------------------------------------------------------------------------%
+
+get_edcg_modes(changed, emode_defn(yes(Mode1 - Mode2),_,_),
+ [Mode1, Mode2]).
+get_edcg_modes(passed, emode_defn(_,yes(Mode),_), [Mode]).
+get_edcg_modes(produced, emode_defn(_,_,yes(Mode)), [Mode]).
+
+set_edcg_modes(changed, emode_defn(_,B,C), [Mode1, Mode2],
+ emode_defn(yes(Mode1 - Mode2),B,C)).
+set_edcg_modes(passed, emode_defn(A,_,C), [Mode],
+ emode_defn(A,yes(Mode),C)).
+set_edcg_modes(produced, emode_defn(A,B,_), [Mode],
+ emode_defn(A,B,yes(Mode))).
+
+form_to_string(passed, "passed").
+form_to_string(changed, "changed").
+form_to_string(produced, "produced").
+form_to_string(nothing, "nothing").
+
%-----------------------------------------------------------------------------%
make_pred_name_with_context(ModuleName, Prefix,
Index: compiler/purity.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/purity.m,v
retrieving revision 1.28
diff -u -r1.28 purity.m
--- compiler/purity.m 2000/11/17 17:48:35 1.28
+++ compiler/purity.m 2001/03/14 03:35:32
@@ -33,6 +33,13 @@
% It needs to be done somewhere after quantification analysis and
% before mode analysis, and this is convenient place to do it.
%
+% We also do some EDCG analysis which needs to be done after predicate
+% overloading has been resolved. The analysis involves flagging which
+% predicates need an EDCG transformation performed upon. This is used to speed
+% up the EDCG pass. The flag is set to yes if the predicate contains a clause
+% which has an EDCG goal, EDCG operator or a call to a predicate with edcg
+% arguments listed explicitly. Also if the predicate has declared EDCG
+% arguments.
%
% The aim of Mercury's purity system is to allow one to declare certain parts
% of one's program to be impure, thereby forbidding the compiler from making
@@ -411,12 +418,16 @@
compute_purity(Clauses0, Clauses, PredInfo0, PredInfo1,
ModuleInfo, pure, Purity, 0, NumErrors0),
+ % Set the NeedsEDCGTransform flag to yes if the predicate has
+ % declared edcg arguments.
+ { pred_info_needs_edcg_transform(PredInfo1, PredInfo2) },
+
% The code in post_typecheck.m to handle field access functions
% may modify the varset and vartypes in the clauses_info.
- { pred_info_clauses_info(PredInfo1, ClausesInfo1) },
+ { pred_info_clauses_info(PredInfo2, ClausesInfo1) },
{ clauses_info_set_clauses(ClausesInfo1, Clauses,
ClausesInfo) },
- { pred_info_set_clauses_info(PredInfo1, ClausesInfo,
+ { pred_info_set_clauses_info(PredInfo2, ClausesInfo,
PredInfo) },
{ WorstPurity = Purity },
{ IsPragmaCCode = no }
@@ -455,14 +466,15 @@
[].
compute_purity([Clause0|Clauses0], [Clause|Clauses], PredInfo0, PredInfo,
ModuleInfo, Purity0, Purity, NumErrors0, NumErrors) -->
- { Clause0 = clause(Ids, Body0 - Info0, Context) },
+ { Clause0 = clause(Ids, Body0 - Info0, MaybeEDCG, Context) },
compute_expr_purity(Body0, Body, Info0, PredInfo0, PredInfo1,
ModuleInfo, no, Bodypurity, NumErrors0, NumErrors1),
{ add_goal_info_purity_feature(Info0, Bodypurity, Info) },
{ worst_purity(Purity0, Bodypurity, Purity1) },
- { Clause = clause(Ids, Body - Info, Context) },
- compute_purity(Clauses0, Clauses, PredInfo1, PredInfo, ModuleInfo,
- Purity1, Purity, NumErrors1, NumErrors).
+ { Clause = clause(Ids, Body - Info, MaybeEDCG, Context) },
+ compute_purity(Clauses0, Clauses, PredInfo1, PredInfo2, ModuleInfo,
+ Purity1, Purity, NumErrors1, NumErrors),
+ { pred_info_needs_edcg_transform(PredInfo2, MaybeEDCG, PredInfo) }.
:- pred compute_expr_purity(hlds_goal_expr, hlds_goal_expr, hlds_goal_info,
pred_info, pred_info, module_info, bool, purity, int, int,
@@ -479,11 +491,11 @@
NumErrors0, NumErrors) -->
compute_goals_purity(Goals0, Goals, PredInfo0, PredInfo, ModuleInfo,
InClosure, pure, Purity, NumErrors0, NumErrors).
-compute_expr_purity(call(PredId0,ProcId,Vars,BIState,UContext,Name0),
- call(PredId,ProcId,Vars,BIState,UContext,Name), GoalInfo,
- PredInfo, PredInfo, ModuleInfo, InClosure, ActualPurity,
- NumErrors0, NumErrors) -->
- { post_typecheck__resolve_pred_overloading(PredId0, Vars, PredInfo,
+compute_expr_purity(call(PredId0,ProcId,Vars,EDCGArgs,BIState,UContext,Name0),
+ call(PredId,ProcId,Vars,EDCGArgs,BIState,UContext,Name),
+ GoalInfo, PredInfo0, PredInfo, ModuleInfo, InClosure,
+ ActualPurity, NumErrors0, NumErrors) -->
+ { post_typecheck__resolve_pred_overloading(PredId0, Vars, PredInfo0,
ModuleInfo, Name0, Name, PredId) },
{ module_info_preds(ModuleInfo, Preds) },
{ map__lookup(Preds, PredId, CalleePredInfo) },
@@ -491,6 +503,9 @@
{ infer_goal_info_purity(GoalInfo, DeclaredPurity) },
{ goal_info_get_context(GoalInfo, CallContext) },
+ { pred_info_needs_edcg_transform(PredInfo0, PredInfo, CalleePredInfo,
+ EDCGArgs) },
+
{ perform_goal_purity_checks(PredInfo, ActualPurity, DeclaredPurity,
InClosure, PurityCheckResult) },
( { PurityCheckResult = insufficient_decl },
@@ -620,6 +635,13 @@
),
{ Goal = GoalExpr - _ }
;
+ { RHS0 = edcg_op(_,_) }
+ ->
+ { pred_info_set_needs_edcg_transform(PredInfo0, PredInfo) },
+ { GoalExpr = Unif0 },
+ { ActualPurity = pure },
+ { NumErrors = NumErrors0 }
+ ;
{ PredInfo = PredInfo0 },
{ GoalExpr = Unif0 },
{ ActualPurity = pure },
@@ -671,7 +693,12 @@
compute_expr_purity(bi_implication(_, _), _, _, _, _, _, _, _, _, _) -->
% these should have been expanded out by now
{ error("compute_expr_purity: unexpected bi_implication") }.
-
+compute_expr_purity(edcg_goal(A, B, Goal0), edcg_goal(A, B, Goal),
+ _, PredInfo0, PredInfo, ModuleInfo, InClosure, Purity,
+ NumErrors0, NumErrors) -->
+ compute_goal_purity(Goal0, Goal, PredInfo0, PredInfo1, ModuleInfo,
+ InClosure, Purity, NumErrors0, NumErrors),
+ { pred_info_set_needs_edcg_transform(PredInfo1, PredInfo) }.
:- pred check_higher_order_purity(module_info, pred_info,
hlds_goal_info, cons_id, prog_var, list(prog_var),
@@ -1130,4 +1157,3 @@
write_purity(Purity),
io__write_string(", but expression was not a function call.\n").
-%-----------------------------------------------------------------------------%
Index: compiler/quantification.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/quantification.m,v
retrieving revision 1.78
diff -u -r1.78 quantification.m
--- compiler/quantification.m 2000/11/17 17:48:36 1.78
+++ compiler/quantification.m 2001/03/14 06:18:30
@@ -123,7 +123,7 @@
:- import_module instmap, goal_util.
:- import_module map, term, varset.
-:- import_module std_util, bool, require.
+:- import_module std_util, bool, require, assoc_list.
:- import_module enum, sparse_bitset.
% The `outside vars', `lambda outside vars', and `quant vars'
@@ -429,9 +429,12 @@
{ union(NonLocalsO, NonLocalsL, NonLocals) },
quantification__set_nonlocals(NonLocals).
-implicitly_quantify_goal_2(call(A, B, HeadVars, D, E, F), _,
- call(A, B, HeadVars, D, E, F)) -->
- implicitly_quantify_atomic_goal(HeadVars).
+implicitly_quantify_goal_2(call(A, B, HeadVars, EDCGHeadVars, E, F, G), _,
+ call(A, B, HeadVars, EDCGHeadVars, E, F, G)) -->
+ { assoc_list__values(EDCGHeadVars, EDCGVars0) },
+ { list__condense(EDCGVars0, EDCGVars) },
+ { list__append(HeadVars, EDCGVars, AllHeadVars) },
+ implicitly_quantify_atomic_goal(AllHeadVars).
implicitly_quantify_goal_2(generic_call(GenericCall, ArgVars1, C, D), _,
generic_call(GenericCall, ArgVars1, C, D)) -->
@@ -570,6 +573,40 @@
{ Goal = conj([ForwardsImplication, ReverseImplication]) }.
+implicitly_quantify_goal_2(edcg_goal(GoalInfo, Inferred, Body0), _Context,
+ edcg_goal(GoalInfo, Inferred, Body)) -->
+ quantification__get_nonlocals_to_recompute(NonLocalsToRecompute),
+ { goal_util__edcg_goal_head_vars(GoalInfo, HeadVars0) },
+ { quantification__goal_vars(NonLocalsToRecompute, Body0,
+ BodyVars, LambdaVars) },
+
+ quantification__get_outside(OutsideVars),
+ quantification__get_lambda_outside(LambdaOutsideVars),
+
+ % Compute non-locals for EDCG goal head.
+ { union(OutsideVars, BodyVars, HeadOutsideVars) },
+ { union(LambdaOutsideVars, LambdaVars, HeadLambdaOutsideVars) },
+ { list_to_set(HeadVars0, HeadVars) },
+ quantification__update_seen_vars(HeadVars),
+ { intersect(HeadVars, HeadOutsideVars, HeadNonLocalVars1) },
+ { intersect(HeadVars, HeadLambdaOutsideVars, HeadNonLocalVars2) },
+ { union(HeadNonLocalVars1, HeadNonLocalVars2, HeadNonLocalVars) },
+
+ % Compute non-locals for EDCG goal body.
+ { union(OutsideVars, HeadNonLocalVars, BodyOutsideVars) },
+ quantification__set_outside(BodyOutsideVars),
+ implicitly_quantify_goal(Body0, Body),
+ quantification__get_nonlocals(BodyNonLocalVars),
+
+ % Compute non-locals for EDCG goal.
+ { union(HeadNonLocalVars, BodyNonLocalVars, NonLocalVars0) },
+ { intersect(NonLocalVars0, OutsideVars, NonLocalVars1) },
+ { intersect(NonLocalVars0, LambdaOutsideVars, NonLocalVars2) },
+ { union(NonLocalVars1, NonLocalVars2, NonLocalVars) },
+
+ quantification__set_outside(OutsideVars),
+ quantification__set_nonlocals(NonLocalVars).
+
:- pred implicitly_quantify_atomic_goal(list(prog_var), quant_info, quant_info).
:- mode implicitly_quantify_atomic_goal(in, in, out) is det.
@@ -608,6 +645,8 @@
list_to_set(ArgVars, Vars)
},
quantification__set_nonlocals(Vars).
+implicitly_quantify_unify_rhs(edcg_op(A,B), _, Unification, _, edcg_op(A,B),
+ Unification) --> [].
implicitly_quantify_unify_rhs(
lambda_goal(PredOrFunc, EvalMethod, FixModes, LambdaNonLocals0,
LambdaVars0, Modes, Det, Goal0),
@@ -928,9 +967,12 @@
insert_list(Set0, ArgVars0, Set1),
insert_list(Set1, ArgVars1, Set).
-quantification__goal_vars_2(_, call(_, _, ArgVars, _, _, _), Set0, LambdaSet,
- Set, LambdaSet) :-
- insert_list(Set0, ArgVars, Set).
+quantification__goal_vars_2(_, call(_, _, ArgVars, EDCGArgVars, _, _, _), Set0,
+ LambdaSet, Set, LambdaSet) :-
+ insert_list(Set0, ArgVars, Set1),
+ assoc_list__values(EDCGArgVars, EDCGVars0),
+ list__condense(EDCGVars0, EDCGVars),
+ insert_list(Set1, EDCGVars, Set).
quantification__goal_vars_2(NonLocalsToRecompute, conj(Goals),
Set0, LambdaSet0, Set, LambdaSet) :-
@@ -994,6 +1036,14 @@
goal_list_vars_2(NonLocalsToRecompute, [LHS, RHS],
Set0, LambdaSet0, Set, LambdaSet).
+quantification__goal_vars_2(NonLocalsToRecompute,
+ edcg_goal(GoalInfo, _, Goal - _), Set0, LambdaSet0, Set,
+ LambdaSet) :-
+ goal_util__edcg_goal_head_vars(GoalInfo, EDCGHeadVars0),
+ insert_list(Set0, EDCGHeadVars0, Set1),
+ quantification__goal_vars_2(NonLocalsToRecompute, Goal, Set1,
+ LambdaSet0, Set, LambdaSet).
+
:- pred quantification__unify_rhs_vars(nonlocals_to_recompute,
unify_rhs, maybe(cell_to_reuse), set_of_var, set_of_var,
set_of_var, set_of_var).
@@ -1016,6 +1066,8 @@
;
insert_list(Set0, ArgVars, Set)
).
+quantification__unify_rhs_vars(_, edcg_op(_,_), _, Set, LambdaSet,
+ Set, LambdaSet).
quantification__unify_rhs_vars(NonLocalsToRecompute,
lambda_goal(_POrF, _E, _F, _N, LambdaVars, _M, _D, Goal),
_, Set, LambdaSet0, Set, LambdaSet) :-
Index: compiler/rl_exprn.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_exprn.m,v
retrieving revision 1.18
diff -u -r1.18 rl_exprn.m
--- compiler/rl_exprn.m 2000/11/17 17:48:38 1.18
+++ compiler/rl_exprn.m 2001/03/12 15:35:54
@@ -810,7 +810,7 @@
rl_exprn__goal(unify(_, _, _, Uni, _) - Info, Fail, Code) -->
rl_exprn__unify(Uni, Info, Fail, Code).
-rl_exprn__goal(call(PredId, ProcId, Args, _, _, _) - Info, Fail, Code) -->
+rl_exprn__goal(call(PredId, ProcId, Args, _, _, _, _) - Info, Fail, Code) -->
rl_exprn__call(PredId, ProcId, Args, Info, Fail, Code).
rl_exprn__goal(not(NegGoal) - _, Fail, Code) -->
rl_exprn_info_get_next_label_id(EndLabel),
@@ -860,6 +860,9 @@
rl_exprn__goal(bi_implication(_, _) - _, _, _) -->
% these should have been expanded out by now
{ error("rl_exprn__goal: unexpected bi_implication") }.
+rl_exprn__goal(edcg_goal(_, _, _) - _, _, _) -->
+ % these should have been expanded out by now
+ { error("rl_exprn__goal: unexpected edcg_goal") }.
:- pred rl_exprn__cases(prog_var::in, list(case)::in, byte_tree::in,
byte_tree::in, byte_tree::out,
Index: compiler/rl_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_gen.m,v
retrieving revision 1.5
diff -u -r1.5 rl_gen.m
--- compiler/rl_gen.m 1999/07/13 08:53:28 1.5
+++ compiler/rl_gen.m 2001/03/12 15:35:54
@@ -916,7 +916,7 @@
rl_gen__goal_is_aditi_call(ModuleInfo, Goal, CallGoal, MaybeNegGoals) :-
(
- Goal = call(PredId, _, _, _, _, _) - _,
+ Goal = call(PredId, _, _, _, _, _, _) - _,
rl_gen__call_is_aditi_call(ModuleInfo, PredId),
CallGoal = Goal,
MaybeNegGoals = no
@@ -931,7 +931,7 @@
% magic.m will strip any explicit somes away
% from the negated goal.
goal_to_conj_list(NegGoal, [CallGoal | OtherGoals]),
- CallGoal = call(PredId, _, _, _, _, _) - _,
+ CallGoal = call(PredId, _, _, _, _, _, _) - _,
rl_gen__call_is_aditi_call(ModuleInfo, PredId),
MaybeNegGoals = yes(OtherGoals)
).
@@ -949,7 +949,7 @@
rl_gen__collect_call_info(CallGoal, MaybeNegGoals, DBCall) -->
(
- { CallGoal = call(PredId, ProcId, Args, _, _, _) - GoalInfo }
+ { CallGoal = call(PredId, ProcId, Args, _, _, _, _) - GoalInfo }
->
{ PredProcId = proc(PredId, ProcId) },
rl_info_get_module_info(ModuleInfo),
--------------------------------------------------------------------------
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