[m-dev.] for review: record syntax [2]
Simon Taylor
stayl at cs.mu.OZ.AU
Tue Jan 4 17:06:26 AEDT 2000
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.17
diff -u -u -r1.17 post_typecheck.m
--- post_typecheck.m 1999/11/11 23:12:08 1.17
+++ post_typecheck.m 1999/12/22 05:14:07
@@ -33,7 +33,7 @@
:- module post_typecheck.
:- interface.
-:- import_module hlds_goal, hlds_module, hlds_pred, prog_data.
+:- import_module hlds_data, hlds_goal, hlds_module, hlds_pred, prog_data.
:- import_module list, io, bool.
% check_type_bindings(PredId, PredInfo, ModuleInfo, ReportErrors):
@@ -74,6 +74,15 @@
:- mode post_typecheck__finish_aditi_builtin(in, in, in, in,
in, out, in, out, out, di, uo) is det.
+ % Work out whether a var-functor unification is actually a function
+ % call. If so, replace the unification goal with a call.
+ %
+:- pred post_typecheck__resolve_unify_functor(prog_var, cons_id,
+ list(prog_var), unify_mode, unification, unify_context,
+ hlds_goal_info, module_info, pred_info, pred_info, hlds_goal).
+:- mode post_typecheck__resolve_unify_functor(in, in, in, in, in, in,
+ in, in, in, out, out) is det.
+
% Do the stuff needed to initialize the pred_infos and proc_infos
% so that a pred is ready for running polymorphism and then
% mode checking.
@@ -104,11 +113,12 @@
:- implementation.
:- import_module (assertion), code_util, typecheck, clause_to_proc.
-:- import_module mode_util, inst_match, (inst).
-:- import_module mercury_to_mercury, prog_out, hlds_data, hlds_out, type_util.
+:- import_module mode_util, inst_match, (inst), prog_util.
+:- import_module mercury_to_mercury, prog_out, hlds_out, type_util.
:- import_module globals, options.
:- import_module map, set, assoc_list, bool, std_util, term, require, int.
+:- import_module varset.
%-----------------------------------------------------------------------------%
% Check for unbound type variables
@@ -568,9 +578,7 @@
%
post_typecheck__finish_pred(ModuleInfo, PredId, PredInfo0, PredInfo) -->
post_typecheck__propagate_types_into_modes(ModuleInfo, PredId,
- PredInfo0, PredInfo1),
- { post_typecheck__resolve_func_overloading(PredInfo1, ModuleInfo,
- PredInfo) }.
+ PredInfo0, PredInfo).
%
% For ill-typed preds, we just need to set the modes up correctly
@@ -749,152 +757,11 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
- %
- % post_typecheck__resolve_func_overloading
- %
- % Convert unifications that are function calls into HLDS call
- % instructions.
- %
-:- pred post_typecheck__resolve_func_overloading(pred_info::in,
- module_info::in, pred_info::out) is det.
-
-post_typecheck__resolve_func_overloading(PredInfo0, ModuleInfo, PredInfo) :-
-
- pred_info_clauses_info(PredInfo0, ClausesInfo0),
- clauses_info_clauses(ClausesInfo0, Clauses0),
-
- list__map(post_typecheck__resolve_func_overloading_clauses(PredInfo0,
- ModuleInfo),
- Clauses0, Clauses),
-
- clauses_info_set_clauses(ClausesInfo0, Clauses, ClausesInfo),
- pred_info_set_clauses_info(PredInfo0, ClausesInfo, PredInfo).
-
-:- pred post_typecheck__resolve_func_overloading_clauses(pred_info::in,
- module_info::in, clause::in, clause::out) is det.
-
-post_typecheck__resolve_func_overloading_clauses(PredInfo, ModuleInfo,
- Clause0, Clause) :-
- Clause0 = clause(ProcIds, Goal0, Context),
- post_typecheck__resolve_data_cons_and_funcs(Goal0, ModuleInfo,
- PredInfo, Goal),
- Clause = clause(ProcIds, Goal, Context).
-
-%-----------------------------------------------------------------------------%
-
- %
- % post_typecheck__resolve_data_cons_and_funcs
- %
- % Traverse the hlds_goal structure transforming the unifications
- % that are function application into the correct calls.
- %
-:- pred post_typecheck__resolve_data_cons_and_funcs(hlds_goal::in,
- module_info::in, pred_info::in,
- hlds_goal::out) is det.
-
-post_typecheck__resolve_data_cons_and_funcs(
- unify(XVar, Y, Mode, Unification, UnifyContext) - GoalInfo,
- ModuleInfo, PredInfo, Goal) :-
- (
- Y = functor(ConsId, Args),
- post_typecheck__resolve_unify_functor(XVar, ConsId,
- Args, Mode, Unification, UnifyContext,
- GoalInfo, ModuleInfo, PredInfo, Goal)
- ;
- Y = lambda_goal(A, B, C, D, E, F, G, LambdaGoal0),
- post_typecheck__resolve_data_cons_and_funcs(LambdaGoal0,
- ModuleInfo, PredInfo, LambdaGoal),
- NewY = lambda_goal(A, B, C, D, E, F, G, LambdaGoal),
- Goal = unify(XVar, NewY, Mode, Unification, UnifyContext)
- - GoalInfo
- ;
- Y = var(_),
- Goal = unify(XVar, Y, Mode, Unification, UnifyContext)
- - GoalInfo
- ).
-
- % Goals which simply traverse the hlds_goal structure.
-post_typecheck__resolve_data_cons_and_funcs(call(A,B,C,D,E,F) - GoalInfo,
- _, _, call(A,B,C,D,E,F) - GoalInfo).
-post_typecheck__resolve_data_cons_and_funcs(generic_call(A,B,C,D) - GoalInfo,
- _, _, generic_call(A,B,C,D) - GoalInfo).
-post_typecheck__resolve_data_cons_and_funcs(pragma_c_code(A,B,C,D,E,F,G) -
- GoalInfo, _, _, pragma_c_code(A,B,C,D,E,F,G) - GoalInfo).
-post_typecheck__resolve_data_cons_and_funcs(conj(Goals0) - GoalInfo,
- ModuleInfo, PredInfo, conj(Goals) - GoalInfo) :-
- post_typecheck__resolve_data_cons_and_funcs_list(Goals0,
- ModuleInfo, PredInfo, Goals).
-post_typecheck__resolve_data_cons_and_funcs(switch(A,B,Cases0,D) - GoalInfo,
- ModuleInfo, PredInfo,
- switch(A,B,Cases,D) - GoalInfo) :-
- post_typecheck__resolve_data_cons_and_funcs_cases(Cases0,
- ModuleInfo, PredInfo, Cases).
-post_typecheck__resolve_data_cons_and_funcs(disj(Goals0,B) - GoalInfo,
- ModuleInfo, PredInfo, disj(Goals,B) - GoalInfo) :-
- post_typecheck__resolve_data_cons_and_funcs_list(Goals0,
- ModuleInfo, PredInfo, Goals).
-post_typecheck__resolve_data_cons_and_funcs(not(Goal0) - GoalInfo,
- ModuleInfo, PredInfo, not(Goal) - GoalInfo) :-
- post_typecheck__resolve_data_cons_and_funcs(Goal0,
- ModuleInfo, PredInfo, Goal).
-post_typecheck__resolve_data_cons_and_funcs(some(A,B,Goal0) - GoalInfo,
- ModuleInfo, PredInfo, some(A,B,Goal) - GoalInfo) :-
- post_typecheck__resolve_data_cons_and_funcs(Goal0,
- ModuleInfo, PredInfo, Goal).
-post_typecheck__resolve_data_cons_and_funcs(par_conj(Goals0,B) - GoalInfo,
- ModuleInfo, PredInfo, par_conj(Goals,B) - GoalInfo) :-
- post_typecheck__resolve_data_cons_and_funcs_list(Goals0,
- ModuleInfo, PredInfo, Goals).
-post_typecheck__resolve_data_cons_and_funcs(if_then_else(A,If0,Then0,Else0,E)
- - GoalInfo, ModuleInfo, PredInfo,
- if_then_else(A,If,Then,Else,E) - GoalInfo) :-
- post_typecheck__resolve_data_cons_and_funcs(If0,
- ModuleInfo, PredInfo, If),
- post_typecheck__resolve_data_cons_and_funcs(Then0,
- ModuleInfo, PredInfo, Then),
- post_typecheck__resolve_data_cons_and_funcs(Else0,
- ModuleInfo, PredInfo, Else).
-post_typecheck__resolve_data_cons_and_funcs(bi_implication(_, _) - _, _, _, _) :-
- % these should have been expanded out by now
- error("post_typecheck__resolve_data_cons_and_funcs: unexpected bi_implication").
-
-:- pred post_typecheck__resolve_data_cons_and_funcs_list(list(hlds_goal)::in,
- module_info::in, pred_info::in, list(hlds_goal)::out) is det.
-
-post_typecheck__resolve_data_cons_and_funcs_list([], _, _, []).
-post_typecheck__resolve_data_cons_and_funcs_list([Goal0 | Goal0s],
- ModuleInfo, PredInfo, [Goal | Goals]) :-
- post_typecheck__resolve_data_cons_and_funcs(Goal0,
- ModuleInfo, PredInfo, Goal),
- post_typecheck__resolve_data_cons_and_funcs_list(Goal0s,
- ModuleInfo, PredInfo, Goals).
-
-:- pred post_typecheck__resolve_data_cons_and_funcs_cases(list(case)::in,
- module_info::in, pred_info::in, list(case)::out) is det.
-
-post_typecheck__resolve_data_cons_and_funcs_cases([], _, _, []).
-post_typecheck__resolve_data_cons_and_funcs_cases([Case0 | Case0s],
- ModuleInfo, PredInfo, [Case | Cases]) :-
- Case0 = case(ConsId, Goal0),
- post_typecheck__resolve_data_cons_and_funcs(Goal0,
- ModuleInfo, PredInfo, Goal),
- Case = case(ConsId, Goal),
- post_typecheck__resolve_data_cons_and_funcs_cases(Case0s,
- ModuleInfo, PredInfo, Cases).
-
-%-----------------------------------------------------------------------------%
-
-:- pred post_typecheck__resolve_unify_functor(prog_var, cons_id, list(prog_var),
- unify_mode, unification, unify_context, hlds_goal_info,
- module_info, pred_info, hlds_goal).
-:- mode post_typecheck__resolve_unify_functor(in, in, in, in, in, in,
- in, in, in, out) is det.
-
post_typecheck__resolve_unify_functor(X0, ConsId0, ArgVars0, Mode0,
Unification0, UnifyContext, GoalInfo0,
- ModuleInfo0, PredInfo, Goal) :-
+ ModuleInfo0, PredInfo0, PredInfo, Goal) :-
- pred_info_clauses_info(PredInfo, ClausesInfo),
+ pred_info_clauses_info(PredInfo0, ClausesInfo),
clauses_info_vartypes(ClausesInfo, VarTypes0),
map__lookup(VarTypes0, X0, TypeOfX),
@@ -923,6 +790,7 @@
higher_order(FuncVar, function, FullArity),
ArgVars, Modes, Det),
+ PredInfo = PredInfo0,
Goal = HOCall - GoalInfo0
;
%
@@ -946,7 +814,7 @@
% a type ambiguity error, but compiler-generated
% predicates are not type-checked.)
%
- \+ code_util__compiler_generated(PredInfo),
+ \+ code_util__compiler_generated(PredInfo0),
module_info_get_predicate_table(ModuleInfo0, PredTable),
predicate_table_search_func_sym_arity(PredTable,
@@ -956,7 +824,7 @@
% argument/return types which subsume the actual
% argument/return types of this function call
- pred_info_typevarset(PredInfo, TVarSet),
+ pred_info_typevarset(PredInfo0, TVarSet),
map__apply_to_list(ArgVars0, VarTypes0, ArgTypes0),
list__append(ArgTypes0, [TypeOfX], ArgTypes),
typecheck__find_matching_pred_id(PredIds, ModuleInfo0,
@@ -974,15 +842,341 @@
FuncCall = call(PredId, ProcId, ArgVars, not_builtin,
yes(FuncCallUnifyContext), QualifiedFuncName),
+ PredInfo = PredInfo0,
Goal = FuncCall - GoalInfo0
;
%
+ % Is it call to a field access function for
+ % which the user has not provided a definition.
+ % This test must be after conversion of function
+ % calls into predicate calls above.
+ %
+ ConsId0 = cons(Name, Arity),
+ is_field_access_function_name(ModuleInfo0, Name, Arity,
+ AccessType, _IsBuiltin, FieldName)
+ ->
+ post_typecheck__finish_field_access_function(ModuleInfo0,
+ PredInfo0, PredInfo, AccessType, FieldName,
+ UnifyContext, X0, ArgVars0, GoalInfo0, Goal)
+ ;
+ %
% ordinary construction/deconstruction unifications
% we leave alone
%
+ PredInfo = PredInfo0,
Goal = unify(X0, functor(ConsId0, ArgVars0), Mode0,
Unification0, UnifyContext) - GoalInfo0
).
+
+%-----------------------------------------------------------------------------%
+
+ % Convert a field access function call into the equivalent unifications
+ % so that later passes do not have to handle them as a special case.
+ % The error messages from mode analysis and determinism analysis
+ % shouldn't be too much worse than if the goals were special cases.
+ %
+:- pred post_typecheck__finish_field_access_function(module_info, pred_info,
+ pred_info, field_access_type, ctor_field_name,
+ unify_context, prog_var, list(prog_var),
+ hlds_goal_info, hlds_goal).
+:- mode post_typecheck__finish_field_access_function(in, in, out, in, in,
+ in, in, in, in, out) is det.
+
+post_typecheck__finish_field_access_function(ModuleInfo, PredInfo0, PredInfo,
+ AccessType, FieldName, UnifyContext,
+ Var, Args, GoalInfo, GoalExpr - GoalInfo) :-
+ (
+ AccessType = get,
+ field_extraction_function_args(Args, TermVar),
+ post_typecheck__translate_get_function(ModuleInfo,
+ PredInfo0, PredInfo, FieldName, UnifyContext,
+ Var, TermVar, GoalInfo, GoalExpr)
+ ;
+ AccessType = set,
+ field_update_function_args(Args, TermInputVar, FieldVar),
+ post_typecheck__translate_set_function(ModuleInfo,
+ PredInfo0, PredInfo, FieldName, UnifyContext,
+ FieldVar, TermInputVar, Var,
+ GoalInfo, GoalExpr)
+ ).
+
+:- pred post_typecheck__translate_get_function(module_info,
+ pred_info, pred_info, ctor_field_name, unify_context, prog_var,
+ prog_var, hlds_goal_info, hlds_goal_expr).
+:- mode post_typecheck__translate_get_function(in, in, out,
+ in, in, in, in, in, out) is det.
+
+post_typecheck__translate_get_function(ModuleInfo, PredInfo0, PredInfo,
+ FieldName, UnifyContext, FieldVar, TermInputVar,
+ OldGoalInfo, GoalExpr) :-
+ pred_info_clauses_info(PredInfo0, ClausesInfo0),
+ clauses_info_vartypes(ClausesInfo0, VarTypes0),
+ map__lookup(VarTypes0, TermInputVar, TermType),
+ get_constructor_containing_field(ModuleInfo, TermType, FieldName,
+ ConsId, FieldNumber),
+
+ get_cons_id_arg_types_adding_existq_tvars(ModuleInfo, ConsId,
+ TermType, ArgTypes, _, PredInfo0, PredInfo1),
+
+ split_list_at_index(FieldNumber, ArgTypes,
+ TypesBeforeField, _, TypesAfterField),
+
+ make_new_vars(TypesBeforeField, VarsBeforeField, PredInfo1, PredInfo2),
+ make_new_vars(TypesAfterField, VarsAfterField, PredInfo2, PredInfo),
+
+ list__append(VarsBeforeField, [FieldVar | VarsAfterField], ArgVars),
+
+ goal_info_get_nonlocals(OldGoalInfo, RestrictNonLocals),
+ create_atomic_unification_with_nonlocals(TermInputVar,
+ functor(ConsId, ArgVars), OldGoalInfo,
+ RestrictNonLocals, [FieldVar, TermInputVar],
+ UnifyContext, FunctorGoal),
+ FunctorGoal = GoalExpr - _.
+
+:- pred post_typecheck__translate_set_function(module_info,
+ pred_info, pred_info, ctor_field_name, unify_context, prog_var,
+ prog_var, prog_var, hlds_goal_info, hlds_goal_expr).
+:- mode post_typecheck__translate_set_function(in, in, out,
+ in, in, in, in, in, in, out) is det.
+
+post_typecheck__translate_set_function(ModuleInfo, PredInfo0, PredInfo,
+ FieldName, UnifyContext, FieldVar, TermInputVar, TermOutputVar,
+ OldGoalInfo, Goal) :-
+ pred_info_clauses_info(PredInfo0, ClausesInfo0),
+ clauses_info_vartypes(ClausesInfo0, VarTypes0),
+ map__lookup(VarTypes0, TermInputVar, TermType),
+
+ get_constructor_containing_field(ModuleInfo, TermType, FieldName,
+ ConsId0, FieldNumber),
+
+ get_cons_id_arg_types_adding_existq_tvars(ModuleInfo, ConsId0,
+ TermType, ArgTypes, ExistQVars, PredInfo0, PredInfo1),
+
+ split_list_at_index(FieldNumber, ArgTypes,
+ TypesBeforeField, TermFieldType, TypesAfterField),
+
+ make_new_vars(TypesBeforeField, VarsBeforeField, PredInfo1, PredInfo2),
+ make_new_var(TermFieldType, SingletonFieldVar, PredInfo2, PredInfo3),
+ make_new_vars(TypesAfterField, VarsAfterField, PredInfo3, PredInfo),
+
+ %
+ % Build a goal to deconstruct the input.
+ %
+ list__append(VarsBeforeField, [SingletonFieldVar | VarsAfterField],
+ DeconstructArgs),
+ goal_info_get_nonlocals(OldGoalInfo, OldNonLocals),
+ list__append(VarsBeforeField, VarsAfterField, NonLocalArgs),
+ set__insert_list(OldNonLocals, NonLocalArgs,
+ DeconstructRestrictNonLocals),
+
+ create_atomic_unification_with_nonlocals(TermInputVar,
+ functor(ConsId0, DeconstructArgs), OldGoalInfo,
+ DeconstructRestrictNonLocals, [TermInputVar | DeconstructArgs],
+ UnifyContext, DeconstructGoal),
+
+ %
+ % Build a goal to construct the output.
+ %
+ list__append(VarsBeforeField, [FieldVar | VarsAfterField],
+ ConstructArgs),
+ set__insert_list(OldNonLocals, NonLocalArgs,
+ ConstructRestrictNonLocals),
+
+ % If the cons_id is existentially quantified, add a `new' prefix
+ % so that polymorphism.m adds the appropriate type_infos.
+ ( ExistQVars = [] ->
+ ConsId = ConsId0
+ ;
+ ( ConsId0 = cons(ConsName0, ConsArity) ->
+ remove_new_prefix(ConsName, ConsName0),
+ ConsId = cons(ConsName, ConsArity)
+ ;
+ error(
+ "post_typecheck__translate_set_function: invalid cons_id")
+ )
+ ),
+
+ create_atomic_unification_with_nonlocals(TermOutputVar,
+ functor(ConsId, ConstructArgs), OldGoalInfo,
+ ConstructRestrictNonLocals, [TermOutputVar | ConstructArgs],
+ UnifyContext, ConstructGoal),
+
+ Conj = conj([DeconstructGoal, ConstructGoal]) - OldGoalInfo,
+
+ % Make mode analysis treat the translated access function
+ % as an atomic goal.
+ Goal = some([], can_remove, Conj).
+
+:- pred get_cons_id_arg_types_adding_existq_tvars(module_info, cons_id,
+ (type), list(type), list(tvar), pred_info, pred_info).
+:- mode get_cons_id_arg_types_adding_existq_tvars(in, in, in,
+ out, out, in, out) is det.
+
+get_cons_id_arg_types_adding_existq_tvars(ModuleInfo, ConsId, TermType,
+ ArgTypes, NewExistQVars, PredInfo0, PredInfo) :-
+ %
+ % Split the list of argument types at the named field.
+ %
+ type_util__get_type_and_cons_defn(ModuleInfo, TermType,
+ ConsId, TypeDefn, ConsDefn),
+ ConsDefn = hlds_cons_defn(ExistQVars, _, ArgTypes0, _, _),
+ ( ExistQVars = [] ->
+ ArgTypes1 = ArgTypes0,
+ PredInfo = PredInfo0,
+ NewExistQVars = []
+ ;
+ %
+ % Rename apart the existentially quantified type variables.
+ %
+ list__length(ExistQVars, NumExistQVars),
+ pred_info_typevarset(PredInfo0, TVarSet0),
+ varset__new_vars(TVarSet0, NumExistQVars, NewExistQVars,
+ TVarSet),
+ pred_info_set_typevarset(PredInfo0, TVarSet, PredInfo),
+ map__from_corresponding_lists(ExistQVars, NewExistQVars,
+ TVarSubst),
+ term__apply_variable_renaming_to_list(ArgTypes0, TVarSubst,
+ ArgTypes1)
+ ),
+ hlds_data__get_type_defn_tparams(TypeDefn, TypeParams),
+ term__term_list_to_var_list(TypeParams, TypeDefnArgs),
+ ( type_to_type_id(TermType, _, TypeArgs) ->
+ map__from_corresponding_lists(TypeDefnArgs, TypeArgs, TSubst)
+ ;
+ error(
+ "get_cons_id_arg_types_adding_existq_tvars: type_to_type_id failed")
+
+ ),
+ term__apply_substitution_to_list(ArgTypes1, TSubst, ArgTypes).
+
+:- pred split_list_at_index(int, list(T), list(T), T, list(T)).
+:- mode split_list_at_index(in, in, out, out, out) is det.
+
+split_list_at_index(Index, List, Before, At, After) :-
+ (
+ list__split_list(Index - 1, List, Before0, AtAndAfter),
+ AtAndAfter = [At0 | After0]
+ ->
+ Before = Before0,
+ At = At0,
+ After = After0
+ ;
+ error("post_typecheck__split_list_at_index")
+ ).
+
+%-----------------------------------------------------------------------------%
+
+ % Work out which constructor of the type has an argument with the
+ % given field name.
+:- pred get_constructor_containing_field(module_info, (type), ctor_field_name,
+ cons_id, int).
+:- mode get_constructor_containing_field(in, in, in, out, out) is det.
+
+get_constructor_containing_field(ModuleInfo, TermType, FieldName,
+ ConsId, FieldNumber) :-
+ ( type_to_type_id(TermType, TermTypeId0, _) ->
+ TermTypeId = TermTypeId0
+ ;
+ error(
+ "get_constructor_containing_field: type_to_type_id failed")
+ ),
+ module_info_types(ModuleInfo, Types),
+ map__lookup(Types, TermTypeId, TermTypeDefn),
+ hlds_data__get_type_defn_body(TermTypeDefn, TermTypeBody),
+ ( TermTypeBody = du_type(Ctors, _, _, _) ->
+ get_constructor_containing_field_2(Ctors, FieldName, ConsId,
+ FieldNumber)
+ ;
+ error("get_constructor_containing_field: not du type")
+ ).
+
+:- pred get_constructor_containing_field_2(list(constructor),
+ ctor_field_name, cons_id, int).
+:- mode get_constructor_containing_field_2(in, in, out, out) is det.
+
+get_constructor_containing_field_2([], _, _, _) :-
+ error("get_constructor_containing_field: can't find field").
+get_constructor_containing_field_2([Ctor | Ctors], FieldName,
+ ConsId, FieldNumber) :-
+ Ctor = ctor(_, _, SymName, CtorArgs),
+ (
+ get_constructor_containing_field_3(CtorArgs,
+ FieldName, 1, FieldNumber0)
+ ->
+ list__length(CtorArgs, Arity),
+ ConsId = cons(SymName, Arity),
+ FieldNumber = FieldNumber0
+ ;
+ get_constructor_containing_field_2(Ctors, FieldName,
+ ConsId, FieldNumber)
+ ).
+
+:- pred get_constructor_containing_field_3(list(constructor_arg),
+ ctor_field_name, int, int).
+:- mode get_constructor_containing_field_3(in, in, in, out) is semidet.
+
+get_constructor_containing_field_3([MaybeArgFieldName - _ | CtorArgs],
+ FieldName, FieldNumber0, FieldNumber) :-
+ (
+ MaybeArgFieldName = yes(ArgFieldName),
+ unqualify_name(ArgFieldName, UnqualFieldName),
+ unqualify_name(FieldName, UnqualFieldName)
+ ->
+ FieldNumber = FieldNumber0
+ ;
+ get_constructor_containing_field_3(CtorArgs, FieldName,
+ FieldNumber0 + 1, FieldNumber)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- pred create_atomic_unification_with_nonlocals(prog_var, unify_rhs,
+ hlds_goal_info, set(prog_var), list(prog_var),
+ unify_context, hlds_goal).
+:- mode create_atomic_unification_with_nonlocals(in, in,
+ in, in, in, in, out) is det.
+
+create_atomic_unification_with_nonlocals(Var, RHS, OldGoalInfo,
+ RestrictNonLocals, VarsList, UnifyContext, Goal) :-
+ goal_info_get_context(OldGoalInfo, Context),
+ UnifyContext = unify_context(UnifyMainContext, UnifySubContext),
+ create_atomic_unification(Var, RHS,
+ Context, UnifyMainContext, UnifySubContext, Goal0),
+ Goal0 = GoalExpr0 - GoalInfo0,
+
+ % Compute the nonlocals of the goal.
+ set__list_to_set(VarsList, NonLocals1),
+ set__intersect(RestrictNonLocals, NonLocals1, NonLocals),
+ goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo),
+ Goal = GoalExpr0 - GoalInfo.
+
+:- pred make_new_vars(list(type), list(prog_var), pred_info, pred_info).
+:- mode make_new_vars(in, out, in, out) is det.
+
+make_new_vars(Types, Vars, PredInfo0, PredInfo) :-
+ pred_info_clauses_info(PredInfo0, ClausesInfo0),
+ clauses_info_varset(ClausesInfo0, VarSet0),
+ clauses_info_vartypes(ClausesInfo0, VarTypes0),
+ list__length(Types, NumVars),
+ varset__new_vars(VarSet0, NumVars, Vars, VarSet),
+ map__det_insert_from_corresponding_lists(VarTypes0,
+ Vars, Types, VarTypes),
+ clauses_info_set_varset(ClausesInfo0, VarSet, ClausesInfo1),
+ clauses_info_set_vartypes(ClausesInfo1, VarTypes, ClausesInfo),
+ pred_info_set_clauses_info(PredInfo0, ClausesInfo, PredInfo).
+
+:- pred make_new_var((type), prog_var, pred_info, pred_info).
+:- mode make_new_var(in, out, in, out) is det.
+
+make_new_var(Type, Var, PredInfo0, PredInfo) :-
+ pred_info_clauses_info(PredInfo0, ClausesInfo0),
+ clauses_info_varset(ClausesInfo0, VarSet0),
+ clauses_info_vartypes(ClausesInfo0, VarTypes0),
+ varset__new_var(VarSet0, Var, VarSet),
+ map__det_insert(VarTypes0, Var, Type, VarTypes),
+ clauses_info_set_varset(ClausesInfo0, VarSet, ClausesInfo1),
+ clauses_info_set_vartypes(ClausesInfo1, VarTypes, ClausesInfo),
+ pred_info_set_clauses_info(PredInfo0, ClausesInfo, PredInfo).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.50
diff -u -u -r1.50 prog_data.m
--- prog_data.m 1999/11/11 23:12:09 1.50
+++ prog_data.m 1999/12/21 01:27:07
@@ -629,7 +629,13 @@
list(constructor_arg)
).
-:- type constructor_arg == pair(string, type).
+:- type constructor_arg ==
+ pair(
+ maybe(ctor_field_name),
+ type
+ ).
+
+:- type ctor_field_name == sym_name.
% An equality_pred specifies the name of a user-defined predicate
% used for equality on a type. See the chapter on them in the
Index: compiler/prog_io.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io.m,v
retrieving revision 1.185
diff -u -u -r1.185 prog_io.m
--- prog_io.m 1999/11/16 07:51:14 1.185
+++ prog_io.m 1999/11/23 03:13:33
@@ -1613,7 +1613,7 @@
),
parse_implicitly_qualified_term(ModuleName,
Term5, Term0, "constructor definition", ok(F, As)),
- convert_constructor_arg_list(As, Args),
+ convert_constructor_arg_list(ModuleName, As, Args),
Result = ctor(ExistQVars, Constraints, F, Args).
%-----------------------------------------------------------------------------%
@@ -2843,22 +2843,25 @@
parse_type(T0, ok(T)) :-
term__coerce(T0, T).
-:- pred convert_constructor_arg_list(list(term), list(constructor_arg)).
-:- mode convert_constructor_arg_list(in, out) is det.
+:- pred convert_constructor_arg_list(module_name,
+ list(term), list(constructor_arg)).
+:- mode convert_constructor_arg_list(in, in, out) is semidet.
-convert_constructor_arg_list([], []).
-convert_constructor_arg_list([Term | Terms], [Arg | Args]) :-
+convert_constructor_arg_list(_, [], []).
+convert_constructor_arg_list(ModuleName, [Term | Terms], [Arg | Args]) :-
(
- Term = term__functor(term__atom("::"), [NameTerm, TypeTerm], _),
- NameTerm = term__functor(term__atom(Name), [], _)
+ Term = term__functor(term__atom("::"), [NameTerm, TypeTerm], _)
->
+ parse_implicitly_qualified_term(ModuleName, NameTerm, Term,
+ "field name", NameResult),
+ NameResult = ok(SymName, []),
convert_type(TypeTerm, Type),
- Arg = Name - Type
+ Arg = yes(SymName) - Type
;
convert_type(Term, Type),
- Arg = "" - Type
+ Arg = no - Type
),
- convert_constructor_arg_list(Terms, Args).
+ convert_constructor_arg_list(ModuleName, Terms, Args).
:- pred convert_type(term, type).
:- mode convert_type(in, out) is det.
Index: compiler/prog_io_dcg.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_dcg.m,v
retrieving revision 1.13
diff -u -u -r1.13 prog_io_dcg.m
--- prog_io_dcg.m 1998/11/20 04:08:57 1.13
+++ prog_io_dcg.m 1999/12/07 01:11:02
@@ -173,6 +173,13 @@
term__coerce(A0, A),
Goal = unify(A, term__variable(Var)) - Context.
+ % Call to ':='/1 - unify argument with DCG output arg.
+parse_dcg_goal_2(":=", [A0], Context, VarSet0, N0, _Var0,
+ Goal, VarSet, N, Var) :-
+ new_dcg_var(VarSet0, N0, VarSet, N, Var),
+ term__coerce(A0, A),
+ Goal = unify(A, term__variable(Var)) - Context.
+
% If-then (Prolog syntax).
% We need to add an else part to unify the DCG args.
Index: compiler/prog_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_util.m,v
retrieving revision 1.47
diff -u -u -r1.47 prog_util.m
--- prog_util.m 1999/07/14 14:56:14 1.47
+++ prog_util.m 1999/12/07 01:11:37
@@ -61,6 +61,33 @@
:- pred match_sym_name(sym_name, sym_name).
:- mode match_sym_name(in, in) is semidet.
+ % remove_sym_name_prefix(SymName0, Prefix, SymName)
+ % succeeds iff
+ % SymName and SymName0 have the same module qualifier
+ % and the unqualified part of SymName0 has the given prefix
+ % and the unqualified part of SymName is the unqualified
+ % part of SymName0 with the prefix removed
+:- pred remove_sym_name_prefix(sym_name, string, sym_name).
+:- mode remove_sym_name_prefix(in, in, out) is semidet.
+:- mode remove_sym_name_prefix(out, in, in) is det.
+
+ % remove_sym_name_suffix(SymName0, Suffix, SymName)
+ % succeeds iff
+ % SymName and SymName0 have the same module qualifier
+ % and the unqualified part of SymName0 has the given suffix
+ % and the unqualified part of SymName is the unqualified
+ % part of SymName0 with the suffix removed
+:- pred remove_sym_name_suffix(sym_name, string, sym_name).
+:- mode remove_sym_name_suffix(in, in, out) is semidet.
+
+ % add_sym_name_suffix(SymName0, Suffix, SymName)
+ % succeeds iff
+ % SymName and SymName0 have the same module qualifier
+ % and the unqualified part of SymName is the unqualified
+ % part of SymName0 with the suffix added
+:- pred add_sym_name_suffix(sym_name, string, sym_name).
+:- mode add_sym_name_suffix(in, in, out) is det.
+
% insert_module_qualifier(ModuleName, SymName0, SymName):
% prepend the specified ModuleName onto the module
% qualifiers in SymName0, giving SymName.
@@ -319,6 +346,26 @@
match_sym_name(unqualified(Name), unqualified(Name)).
match_sym_name(unqualified(Name), qualified(_, Name)).
+%-----------------------------------------------------------------------------%
+
+remove_sym_name_prefix(qualified(Module, Name0), Prefix,
+ qualified(Module, Name)) :-
+ string__append(Prefix, Name, Name0).
+remove_sym_name_prefix(unqualified(Name0), Prefix, unqualified(Name)) :-
+ string__append(Prefix, Name, Name0).
+
+remove_sym_name_suffix(qualified(Module, Name0), Suffix,
+ qualified(Module, Name)) :-
+ string__remove_suffix(Name0, Suffix, Name).
+remove_sym_name_suffix(unqualified(Name0), Suffix, unqualified(Name)) :-
+ string__remove_suffix(Name0, Suffix, Name).
+
+add_sym_name_suffix(qualified(Module, Name0), Suffix,
+ qualified(Module, Name)) :-
+ string__append(Name0, Suffix, Name).
+add_sym_name_suffix(unqualified(Name0), Suffix, unqualified(Name)) :-
+ string__append(Name0, Suffix, Name).
+
%-----------------------------------------------------------------------------%
make_pred_name_with_context(ModuleName, Prefix,
Index: compiler/purity.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/purity.m,v
retrieving revision 1.21
diff -u -u -r1.21 purity.m
--- purity.m 1999/11/03 04:13:15 1.21
+++ purity.m 1999/11/23 03:13:39
@@ -145,7 +145,7 @@
:- implementation.
-:- import_module make_hlds, hlds_pred, prog_io_util.
+:- import_module hlds_pred, prog_io_util.
:- import_module type_util, mode_util, code_util, prog_data, unify_proc.
:- import_module globals, options, mercury_to_mercury, hlds_out.
:- import_module passes_aux, typecheck, module_qual, clause_to_proc.
@@ -362,11 +362,15 @@
;
{ pred_info_clauses_info(PredInfo0, ClausesInfo0) },
{ clauses_info_clauses(ClausesInfo0, Clauses0) },
- compute_purity(Clauses0, Clauses, PredInfo0, ModuleInfo,
- pure, Purity, 0, NumErrors0),
- { clauses_info_set_clauses(ClausesInfo0, Clauses,
+ compute_purity(Clauses0, Clauses, PredInfo0, PredInfo1,
+ ModuleInfo, pure, Purity, 0, NumErrors0),
+
+ % 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) },
+ { clauses_info_set_clauses(ClausesInfo1, Clauses,
ClausesInfo) },
- { pred_info_set_clauses_info(PredInfo0, ClausesInfo,
+ { pred_info_set_clauses_info(PredInfo1, ClausesInfo,
PredInfo) },
{ WorstPurity = Purity }
),
@@ -391,39 +395,42 @@
% Infer the purity of a single (non-pragma c_code) predicate
-:- pred compute_purity(list(clause), list(clause), pred_info, module_info,
- purity, purity, int, int, io__state, io__state).
-:- mode compute_purity(in, out, in, in, in, out, in, out, di, uo) is det.
+:- pred compute_purity(list(clause), list(clause), pred_info, pred_info,
+ module_info, purity, purity, int, int, io__state, io__state).
+:- mode compute_purity(in, out, in, out, in, in, out, in, out, di, uo) is det.
-compute_purity([], [], _, _, Purity, Purity, NumErrors, NumErrors) -->
+compute_purity([], [], PredInfo, PredInfo, _, Purity, Purity,
+ NumErrors, NumErrors) -->
[].
-compute_purity([Clause0|Clauses0], [Clause|Clauses], PredInfo, ModuleInfo,
- Purity0, Purity, NumErrors0, NumErrors) -->
+compute_purity([Clause0|Clauses0], [Clause|Clauses], PredInfo0, PredInfo,
+ ModuleInfo, Purity0, Purity, NumErrors0, NumErrors) -->
{ Clause0 = clause(Ids, Body0 - Info0, Context) },
- compute_expr_purity(Body0, Body, Info0, PredInfo, ModuleInfo,
- no, Bodypurity, NumErrors0, NumErrors1),
+ 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, PredInfo, ModuleInfo,
+ compute_purity(Clauses0, Clauses, PredInfo1, PredInfo, ModuleInfo,
Purity1, Purity, NumErrors1, NumErrors).
:- pred compute_expr_purity(hlds_goal_expr, hlds_goal_expr, hlds_goal_info,
- pred_info, module_info, bool, purity, int, int, io__state, io__state).
-:- mode compute_expr_purity(in, out, in, in, in, in, out, in, out, di, uo)
- is det.
-
-compute_expr_purity(conj(Goals0), conj(Goals), _, PredInfo, ModuleInfo,
- InClosure, Purity, NumErrors0, NumErrors) -->
- compute_goals_purity(Goals0, Goals, PredInfo, ModuleInfo,
- InClosure, pure, Purity, NumErrors0, NumErrors).
-compute_expr_purity(par_conj(Goals0, SM), par_conj(Goals, SM), _, PredInfo,
+ pred_info, pred_info, module_info, bool, purity, int, int,
+ io__state, io__state).
+:- mode compute_expr_purity(in, out, in, in, out, in, in, out, in, out,
+ di, uo) is det.
+
+compute_expr_purity(conj(Goals0), conj(Goals), _, PredInfo0, PredInfo,
ModuleInfo, InClosure, Purity, NumErrors0, NumErrors) -->
- compute_goals_purity(Goals0, Goals, PredInfo, ModuleInfo,
+ compute_goals_purity(Goals0, Goals, PredInfo0, PredInfo, ModuleInfo,
InClosure, pure, Purity, NumErrors0, NumErrors).
+compute_expr_purity(par_conj(Goals0, SM), par_conj(Goals, SM), _,
+ PredInfo0, PredInfo, ModuleInfo, InClosure, Purity,
+ 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, ModuleInfo, InClosure, ActualPurity,
+ PredInfo, PredInfo, ModuleInfo, InClosure, ActualPurity,
NumErrors0, NumErrors) -->
{ post_typecheck__resolve_pred_overloading(PredId0, Vars, PredInfo,
ModuleInfo, Name0, Name, PredId) },
@@ -454,44 +461,50 @@
DeclaredPurity),
{ NumErrors = NumErrors0 }
).
-compute_expr_purity(generic_call(GenericCall0, Args, Modes0, Det),
- generic_call(GenericCall, Args, Modes, Det),
- GoalInfo, PredInfo, ModuleInfo, _InClosure, Purity,
- NumErrors, NumErrors) -->
- { Purity = pure },
+compute_expr_purity(generic_call(GenericCall0, Args, Modes0, Det), GoalExpr,
+ GoalInfo, PredInfo0, PredInfo, ModuleInfo, _InClosure, Purity,
+ NumErrors0, NumErrors) -->
(
{ GenericCall0 = higher_order(_, _, _) },
- { GenericCall = GenericCall0 },
- { Modes = Modes0 }
+ { Purity = pure },
+ { PredInfo = PredInfo0 },
+ { NumErrors = NumErrors0 },
+ { GoalExpr = generic_call(GenericCall0, Args, Modes0, Det) }
;
{ GenericCall0 = class_method(_, _, _, _) },
- { GenericCall = GenericCall0 },
- { Modes = Modes0 }
+ { Purity = pure },
+ { PredInfo = PredInfo0 },
+ { NumErrors = NumErrors0 },
+ { GoalExpr = generic_call(GenericCall0, Args, Modes0, Det) }
;
{ GenericCall0 = aditi_builtin(Builtin0, CallId0) },
+ { Purity = pure },
{ goal_info_get_context(GoalInfo, Context) },
post_typecheck__finish_aditi_builtin(ModuleInfo, PredInfo,
Args, Context, Builtin0, Builtin,
CallId0, CallId, Modes),
- { GenericCall = aditi_builtin(Builtin, CallId) }
+ { GenericCall = aditi_builtin(Builtin, CallId) },
+ { GoalExpr = generic_call(GenericCall, Args, Modes, Det) },
+ { PredInfo = PredInfo0 },
+ { NumErrors = NumErrors0 }
).
compute_expr_purity(switch(Var,Canfail,Cases0,Storemap),
- switch(Var,Canfail,Cases,Storemap), _, PredInfo,
+ switch(Var,Canfail,Cases,Storemap), _, PredInfo0, PredInfo,
ModuleInfo, InClosure, Purity, NumErrors0, NumErrors) -->
- compute_cases_purity(Cases0, Cases, PredInfo, ModuleInfo,
+ compute_cases_purity(Cases0, Cases, PredInfo0, PredInfo, ModuleInfo,
InClosure, pure, Purity, NumErrors0, NumErrors).
-compute_expr_purity(Unif0, Unif, GoalInfo, PredInfo, ModuleInfo, _,
- pure, NumErrors0, NumErrors) -->
- { Unif0 = unify(A,RHS0,C,D,E) },
- { Unif = unify(A,RHS,C,D,E) },
+compute_expr_purity(Unif0, GoalExpr, GoalInfo, PredInfo0, PredInfo,
+ ModuleInfo, _, pure, NumErrors0, NumErrors) -->
+ { Unif0 = unify(Var, RHS0, Mode, Unification, UnifyContext) },
+
(
{ RHS0 = lambda_goal(F, EvalMethod, FixModes, H, Vars,
Modes0, K, Goal0 - Info0) }
->
{ RHS = lambda_goal(F, EvalMethod, modes_are_ok, H, Vars,
Modes, K, Goal - Info0) },
- compute_expr_purity(Goal0, Goal, Info0, PredInfo, ModuleInfo,
- yes, Purity, NumErrors0, NumErrors1),
+ compute_expr_purity(Goal0, Goal, Info0, PredInfo0, PredInfo,
+ ModuleInfo, yes, Purity, NumErrors0, NumErrors1),
error_if_closure_impure(GoalInfo, Purity,
NumErrors1, NumErrors),
{
@@ -524,64 +537,77 @@
map__apply_to_list(Vars, VarTypes, LambdaVarTypes),
fix_aditi_state_modes(StateMode, LambdaVarTypes,
Modes0, Modes)
- }
+ },
+ { GoalExpr = unify(Var, RHS, Mode, Unification, UnifyContext) }
;
- { RHS = RHS0 },
+ { RHS0 = functor(ConsId, Args) }
+ ->
+ { post_typecheck__resolve_unify_functor(Var, ConsId, Args,
+ Mode, Unification, UnifyContext, GoalInfo,
+ ModuleInfo, PredInfo0, PredInfo, Goal) },
+ { Goal = GoalExpr - _ },
+ { NumErrors = NumErrors0 }
+ ;
+ { PredInfo = PredInfo0 },
+ { GoalExpr = Unif0 },
{ NumErrors = NumErrors0 }
).
-compute_expr_purity(disj(Goals0,Store), disj(Goals,Store), _, PredInfo,
- ModuleInfo, InClosure, Purity, NumErrors0, NumErrors) -->
- compute_goals_purity(Goals0, Goals, PredInfo, ModuleInfo,
+compute_expr_purity(disj(Goals0,Store), disj(Goals,Store), _,
+ PredInfo0, PredInfo, ModuleInfo, InClosure, Purity,
+ NumErrors0, NumErrors) -->
+ compute_goals_purity(Goals0, Goals, PredInfo0, PredInfo, ModuleInfo,
InClosure, pure, Purity, NumErrors0, NumErrors).
-compute_expr_purity(not(Goal0), NotGoal, GoalInfo0, PredInfo, ModuleInfo,
- InClosure, Purity, NumErrors0, NumErrors) -->
+compute_expr_purity(not(Goal0), NotGoal, GoalInfo0, PredInfo0, PredInfo,
+ ModuleInfo, InClosure, Purity, NumErrors0, NumErrors) -->
%
% eliminate double negation
%
{ negate_goal(Goal0, GoalInfo0, NotGoal0) },
( { NotGoal0 = not(Goal1) - _GoalInfo1 } ->
- compute_goal_purity(Goal1, Goal, PredInfo, ModuleInfo,
- InClosure, Purity, NumErrors0, NumErrors),
+ compute_goal_purity(Goal1, Goal, PredInfo0, PredInfo,
+ ModuleInfo, InClosure, Purity, NumErrors0, NumErrors),
{ NotGoal = not(Goal) }
;
- compute_goal_purity(NotGoal0, NotGoal1, PredInfo, ModuleInfo,
- InClosure, Purity, NumErrors0, NumErrors),
+ compute_goal_purity(NotGoal0, NotGoal1, PredInfo0, PredInfo,
+ ModuleInfo, InClosure, Purity, NumErrors0, NumErrors),
{ NotGoal1 = NotGoal - _ }
).
compute_expr_purity(some(Vars, CanRemove, Goal0), some(Vars, CanRemove, Goal),
- _, PredInfo, ModuleInfo, InClosure, Purity,
+ _, PredInfo0, PredInfo, ModuleInfo, InClosure, Purity,
NumErrors0, NumErrors) -->
- compute_goal_purity(Goal0, Goal, PredInfo, ModuleInfo,
+ compute_goal_purity(Goal0, Goal, PredInfo0, PredInfo, ModuleInfo,
InClosure, Purity, NumErrors0, NumErrors).
compute_expr_purity(if_then_else(Vars,Goali0,Goalt0,Goale0,Store),
- if_then_else(Vars,Goali,Goalt,Goale,Store), _, PredInfo,
- ModuleInfo, InClosure, Purity, NumErrors0, NumErrors) -->
- compute_goal_purity(Goali0, Goali, PredInfo, ModuleInfo,
+ if_then_else(Vars,Goali,Goalt,Goale,Store), _,
+ PredInfo0, PredInfo, ModuleInfo, InClosure, Purity,
+ NumErrors0, NumErrors) -->
+ compute_goal_purity(Goali0, Goali, PredInfo0, PredInfo1, ModuleInfo,
InClosure, Purity1, NumErrors0, NumErrors1),
- compute_goal_purity(Goalt0, Goalt, PredInfo, ModuleInfo,
+ compute_goal_purity(Goalt0, Goalt, PredInfo1, PredInfo2, ModuleInfo,
InClosure, Purity2, NumErrors1, NumErrors2),
- compute_goal_purity(Goale0, Goale, PredInfo, ModuleInfo,
+ compute_goal_purity(Goale0, Goale, PredInfo2, PredInfo, ModuleInfo,
InClosure, Purity3, NumErrors2, NumErrors),
{ worst_purity(Purity1, Purity2, Purity12) },
{ worst_purity(Purity12, Purity3, Purity) }.
-compute_expr_purity(Ccode, Ccode, _, _, ModuleInfo, _, Purity,
+compute_expr_purity(Ccode, Ccode, _, PredInfo, PredInfo, ModuleInfo, _, Purity,
NumErrors, NumErrors) -->
{ Ccode = pragma_c_code(_,PredId,_,_,_,_,_) },
{ module_info_preds(ModuleInfo, Preds) },
- { map__lookup(Preds, PredId, PredInfo) },
- { pred_info_get_purity(PredInfo, Purity) }.
-compute_expr_purity(bi_implication(_, _), _, _, _, _, _, _, _, _) -->
+ { map__lookup(Preds, PredId, CalledPredInfo) },
+ { pred_info_get_purity(CalledPredInfo, Purity) }.
+compute_expr_purity(bi_implication(_, _), _, _, _, _, _, _, _, _, _) -->
% these should have been expanded out by now
{ error("compute_expr_purity: unexpected bi_implication") }.
-:- pred compute_goal_purity(hlds_goal, hlds_goal, pred_info,
+:- pred compute_goal_purity(hlds_goal, hlds_goal, pred_info, pred_info,
module_info, bool, purity, int, int, io__state, io__state).
-:- mode compute_goal_purity(in, out, in, in, in, out, in, out, di, uo) is det.
+:- mode compute_goal_purity(in, out, in, out, in, in,
+ out, in, out, di, uo) is det.
-compute_goal_purity(Goal0 - GoalInfo0, Goal - GoalInfo, PredInfo, ModuleInfo,
- InClosure, Purity, NumErrors0, NumErrors) -->
- compute_expr_purity(Goal0, Goal, GoalInfo0, PredInfo, ModuleInfo,
- InClosure, Purity, NumErrors0, NumErrors),
+compute_goal_purity(Goal0 - GoalInfo0, Goal - GoalInfo, PredInfo0, PredInfo,
+ ModuleInfo, InClosure, Purity, NumErrors0, NumErrors) -->
+ compute_expr_purity(Goal0, Goal, GoalInfo0, PredInfo0, PredInfo,
+ ModuleInfo, InClosure, Purity, NumErrors0, NumErrors),
{ add_goal_info_purity_feature(GoalInfo0, Purity, GoalInfo) }.
@@ -589,38 +615,42 @@
% disjunction is computed the same way as the purity of a conjunction, we use
% the same code for both
-:- pred compute_goals_purity(list(hlds_goal), list(hlds_goal), pred_info,
- module_info, bool, purity, purity, int, int, io__state, io__state).
-:- mode compute_goals_purity(in, out, in, in, in, in, out, in, out, di, uo)
- is det.
+:- pred compute_goals_purity(list(hlds_goal), list(hlds_goal),
+ pred_info, pred_info, module_info, bool, purity, purity, int, int,
+ io__state, io__state).
+:- mode compute_goals_purity(in, out, in, out, in, in, in, out, in, out,
+ di, uo) is det.
-compute_goals_purity([], [], _, _, _, Purity, Purity, NumErrors, NumErrors) -->
+compute_goals_purity([], [], PredInfo, PredInfo, _, _, Purity, Purity,
+ NumErrors, NumErrors) -->
[].
-compute_goals_purity([Goal0|Goals0], [Goal|Goals], PredInfo, ModuleInfo,
- InClosure, Purity0, Purity, NumErrors0, NumErrors) -->
- compute_goal_purity(Goal0, Goal, PredInfo, ModuleInfo,
- InClosure, Purity1, NumErrors0, NumErrors1),
+compute_goals_purity([Goal0|Goals0], [Goal|Goals], PredInfo0, PredInfo,
+ ModuleInfo, InClosure, Purity0, Purity,
+ NumErrors0, NumErrors) -->
+ compute_goal_purity(Goal0, Goal, PredInfo0, PredInfo1, ModuleInfo,
+ InClosure, Purity1, NumErrors0, NumErrors1),
{ worst_purity(Purity0, Purity1, Purity2) },
- compute_goals_purity(Goals0, Goals, PredInfo, ModuleInfo, InClosure,
- Purity2, Purity, NumErrors1, NumErrors).
+ compute_goals_purity(Goals0, Goals, PredInfo1, PredInfo, ModuleInfo,
+ InClosure, Purity2, Purity, NumErrors1, NumErrors).
-:- pred compute_cases_purity(list(case), list(case), pred_info, module_info,
- bool, purity, purity, int, int, io__state, io__state).
-:- mode compute_cases_purity(in, out, in, in, in, in, out, in, out, di, uo)
- is det.
+:- pred compute_cases_purity(list(case), list(case), pred_info, pred_info,
+ module_info, bool, purity, purity, int, int, io__state, io__state).
+:- mode compute_cases_purity(in, out, in, out, in, in, in, out, in, out,
+ di, uo) is det.
-compute_cases_purity([], [], _, _, _, Purity, Purity, NumErrors, NumErrors) -->
+compute_cases_purity([], [], PredInfo, PredInfo, _, _, Purity, Purity,
+ NumErrors, NumErrors) -->
[].
compute_cases_purity([case(Ctor,Goal0)|Goals0], [case(Ctor,Goal)|Goals],
- PredInfo, ModuleInfo, InClosure, Purity0, Purity,
+ PredInfo0, PredInfo, ModuleInfo, InClosure, Purity0, Purity,
NumErrors0, NumErrors) -->
- compute_goal_purity(Goal0, Goal, PredInfo, ModuleInfo,
- InClosure, Purity1, NumErrors0, NumErrors1),
+ compute_goal_purity(Goal0, Goal, PredInfo0, PredInfo1, ModuleInfo,
+ InClosure, Purity1, NumErrors0, NumErrors1),
{ worst_purity(Purity0, Purity1, Purity2) },
- compute_cases_purity(Goals0, Goals, PredInfo, ModuleInfo, InClosure,
- Purity2, Purity, NumErrors1, NumErrors).
+ compute_cases_purity(Goals0, Goals, PredInfo1, PredInfo, ModuleInfo,
+ InClosure, Purity2, Purity, NumErrors1, NumErrors).
% Make sure lambda expressions introduced by the compiler
% have the correct mode for their `aditi__state' arguments.
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.75
diff -u -u -r1.75 type_util.m
--- type_util.m 1999/10/28 00:57:01 1.75
+++ type_util.m 1999/12/19 04:38:05
@@ -170,6 +170,12 @@
:- pred type_util__get_cons_id_arg_types(module_info::in, (type)::in,
cons_id::in, list(type)::out) is det.
+ % Given a type and a cons_id, look up the definitions of that
+ % type and constructor. Aborts if the cons_id is not user-defined.
+:- pred type_util__get_type_and_cons_defn(module_info, (type), cons_id,
+ hlds_type_defn, hlds_cons_defn).
+:- mode type_util__get_type_and_cons_defn(in, in, in, out, out) is det.
+
% Given a type and a cons_id, look up the definition of that
% constructor; if it is existentially typed, return its definition,
% otherwise fail.
@@ -656,20 +662,13 @@
type_util__get_cons_id_arg_types(ModuleInfo, VarType, ConsId, ArgTypes) :-
(
- type_to_type_id(VarType, TypeId, TypeArgs),
- module_info_ctors(ModuleInfo, Ctors),
- % will fail for builtin cons_ids.
- map__search(Ctors, ConsId, ConsDefns),
- CorrectCons = lambda([ConsDefn::in] is semidet, (
- ConsDefn = hlds_cons_defn(_, _, _, TypeId, _)
- )),
- list__filter(CorrectCons, ConsDefns,
- [hlds_cons_defn(ExistQVars0, _Constraints0, ArgTypes0,
- _, _)]),
+ type_to_type_id(VarType, _, TypeArgs),
+ type_util__do_get_type_and_cons_defn(ModuleInfo, VarType,
+ ConsId, TypeDefn, ConsDefn),
+ ConsDefn = hlds_cons_defn(ExistQVars0, _Constraints0,
+ ArgTypes0, _, _),
ArgTypes0 \= []
->
- module_info_types(ModuleInfo, Types),
- map__lookup(Types, TypeId, TypeDefn),
hlds_data__get_type_defn_tparams(TypeDefn, TypeDefnParams),
term__term_list_to_var_list(TypeDefnParams, TypeDefnVars),
@@ -690,14 +689,8 @@
(type)::in, cons_id::in, hlds_cons_defn::out) is semidet.
type_util__is_existq_cons(ModuleInfo, VarType, ConsId, ConsDefn) :-
- type_to_type_id(VarType, TypeId, _TypeArgs),
- module_info_ctors(ModuleInfo, Ctors),
- % will fail for builtin cons_ids.
- map__search(Ctors, ConsId, ConsDefns),
- MatchingCons = lambda([ThisConsDefn::in] is semidet, (
- ThisConsDefn = hlds_cons_defn(_, _, _, TypeId, _)
- )),
- list__filter(MatchingCons, ConsDefns, [ConsDefn]),
+ type_to_type_id(VarType, TypeId, _),
+ type_util__get_cons_defn(ModuleInfo, TypeId, ConsId, ConsDefn),
ConsDefn = hlds_cons_defn(ExistQVars, _, _, _, _),
ExistQVars \= [].
@@ -712,10 +705,46 @@
map__lookup(Types, TypeId, TypeDefn),
hlds_data__get_type_defn_tvarset(TypeDefn, TypeVarSet),
hlds_data__get_type_defn_tparams(TypeDefn, TypeDefnParams),
+ type_to_type_id(VarType, TypeId, _),
construct_type(TypeId, TypeDefnParams, RetType),
CtorDefn = ctor_defn(TypeVarSet, ExistQVars, Constraints,
ArgTypes, RetType).
+type_util__get_type_and_cons_defn(ModuleInfo, Type, ConsId,
+ TypeDefn, ConsDefn) :-
+ (
+ type_util__do_get_type_and_cons_defn(ModuleInfo,
+ Type, ConsId, TypeDefn0, ConsDefn0)
+ ->
+ TypeDefn = TypeDefn0,
+ ConsDefn = ConsDefn0
+ ;
+ error("type_util__get_type_and_cons_defn")
+ ).
+
+:- pred type_util__do_get_type_and_cons_defn(module_info::in,
+ (type)::in, cons_id::in, hlds_type_defn::out,
+ hlds_cons_defn::out) is semidet.
+
+type_util__do_get_type_and_cons_defn(ModuleInfo, VarType, ConsId,
+ TypeDefn, ConsDefn) :-
+ type_to_type_id(VarType, TypeId, _TypeArgs),
+ type_util__get_cons_defn(ModuleInfo, TypeId, ConsId, ConsDefn),
+ module_info_types(ModuleInfo, Types),
+ map__lookup(Types, TypeId, TypeDefn).
+
+:- pred type_util__get_cons_defn(module_info::in, type_id::in, cons_id::in,
+ hlds_cons_defn::out) is semidet.
+
+type_util__get_cons_defn(ModuleInfo, TypeId, ConsId, ConsDefn) :-
+ module_info_ctors(ModuleInfo, Ctors),
+ % will fail for builtin cons_ids.
+ map__search(Ctors, ConsId, ConsDefns),
+ MatchingCons = lambda([ThisConsDefn::in] is semidet, (
+ ThisConsDefn = hlds_cons_defn(_, _, _, TypeId, _)
+ )),
+ list__filter(MatchingCons, ConsDefns, [ConsDefn]).
+
%-----------------------------------------------------------------------------%
% The checks for type_info and type_ctor_info
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.268
diff -u -u -r1.268 typecheck.m
--- typecheck.m 1999/12/08 09:44:56 1.268
+++ typecheck.m 1999/12/20 04:00:07
@@ -327,9 +327,11 @@
Changed = no,
IOState = IOState0
;
- pred_info_arg_types(PredInfo0, _ArgTypeVarSet, ExistQVars0,
+ maybe_add_default_field_access_clauses(ModuleInfo,
+ PredInfo0, PredInfo1),
+ pred_info_arg_types(PredInfo1, _ArgTypeVarSet, ExistQVars0,
ArgTypes0),
- pred_info_clauses_info(PredInfo0, ClausesInfo0),
+ pred_info_clauses_info(PredInfo1, ClausesInfo0),
clauses_info_clauses(ClausesInfo0, Clauses0),
clauses_info_headvars(ClausesInfo0, HeadVars),
clauses_info_varset(ClausesInfo0, VarSet),
@@ -340,7 +342,7 @@
% There are no clauses for class methods.
% The clauses are generated later on,
% in polymorphism__expand_class_method_bodies
- pred_info_get_markers(PredInfo0, Markers),
+ pred_info_get_markers(PredInfo1, Markers),
( check_marker(Markers, class_method) ->
IOState = IOState0,
% For the moment, we just insert the types
@@ -349,29 +351,29 @@
VarTypes),
clauses_info_set_vartypes(ClausesInfo0, VarTypes,
ClausesInfo),
- pred_info_set_clauses_info(PredInfo0, ClausesInfo,
- PredInfo1),
+ pred_info_set_clauses_info(PredInfo1, ClausesInfo,
+ PredInfo2),
% We also need to set the head_type_params
% field to indicate that all the existentially
% quantified tvars in the head of this
% pred are indeed bound by this predicate.
term__vars_list(ArgTypes0,
HeadVarsIncludingExistentials),
- pred_info_set_head_type_params(PredInfo1,
+ pred_info_set_head_type_params(PredInfo2,
HeadVarsIncludingExistentials, PredInfo),
Error = no,
Changed = no
;
- report_error_no_clauses(PredId, PredInfo0, ModuleInfo,
+ report_error_no_clauses(PredId, PredInfo1, ModuleInfo,
IOState0, IOState),
- PredInfo = PredInfo0,
+ PredInfo = PredInfo1,
Error = yes,
Changed = no
)
;
- pred_info_typevarset(PredInfo0, TypeVarSet0),
- pred_info_import_status(PredInfo0, Status),
- pred_info_get_markers(PredInfo0, Markers),
+ pred_info_typevarset(PredInfo1, TypeVarSet0),
+ pred_info_import_status(PredInfo1, Status),
+ pred_info_get_markers(PredInfo1, Markers),
( check_marker(Markers, infer_type) ->
% For a predicate whose type is inferred,
% the predicate is allowed to bind the type
@@ -391,7 +393,7 @@
term__vars_list(ArgTypes0, HeadTypeParams0),
list__delete_elems(HeadTypeParams0, ExistQVars0,
HeadTypeParams1),
- pred_info_get_class_context(PredInfo0,
+ pred_info_get_class_context(PredInfo1,
PredConstraints)
),
@@ -427,10 +429,10 @@
clauses_info_set_vartypes(ClausesInfo0, InferredVarTypes,
ClausesInfo1),
clauses_info_set_clauses(ClausesInfo1, Clauses, ClausesInfo),
- pred_info_set_clauses_info(PredInfo0, ClausesInfo, PredInfo1),
- pred_info_set_typevarset(PredInfo1, TypeVarSet, PredInfo2),
- pred_info_set_constraint_proofs(PredInfo2, ConstraintProofs,
- PredInfo3),
+ pred_info_set_clauses_info(PredInfo1, ClausesInfo, PredInfo2),
+ pred_info_set_typevarset(PredInfo2, TypeVarSet, PredInfo3),
+ pred_info_set_constraint_proofs(PredInfo3, ConstraintProofs,
+ PredInfo4),
%
% Split the inferred type class constraints into those that
@@ -452,8 +454,8 @@
% bound in to types that make the constraints satisfiable,
% causing the error to go away.
%
- pred_info_set_unproven_body_constraints(PredInfo3,
- UnprovenBodyConstraints, PredInfo4),
+ pred_info_set_unproven_body_constraints(PredInfo4,
+ UnprovenBodyConstraints, PredInfo5),
is_bool(Inferring),
( Inferring = yes ->
@@ -467,13 +469,13 @@
%
% Now save the information we inferred in the pred_info
%
- pred_info_set_head_type_params(PredInfo4,
- HeadTypeParams, PredInfo5),
- pred_info_set_arg_types(PredInfo5, TypeVarSet,
- ExistQVars, ArgTypes, PredInfo6),
- pred_info_get_class_context(PredInfo0,
+ pred_info_set_head_type_params(PredInfo5,
+ HeadTypeParams, PredInfo6),
+ pred_info_set_arg_types(PredInfo6, TypeVarSet,
+ ExistQVars, ArgTypes, PredInfo7),
+ pred_info_get_class_context(PredInfo1,
OldTypeConstraints),
- pred_info_set_class_context(PredInfo6,
+ pred_info_set_class_context(PredInfo7,
InferredTypeConstraints, PredInfo),
%
% Check if anything changed
@@ -493,8 +495,8 @@
Changed = yes
)
; % Inferring = no
- pred_info_set_head_type_params(PredInfo4,
- HeadTypeParams2, PredInfo5),
+ pred_info_set_head_type_params(PredInfo5,
+ HeadTypeParams2, PredInfo6),
%
% leave the original argtypes etc., but
@@ -533,9 +535,9 @@
PredConstraints1, RenamedOldConstraints),
% save the results in the pred_info
- pred_info_set_arg_types(PredInfo5, TypeVarSet,
- ExistQVars, RenamedOldArgTypes, PredInfo6),
- pred_info_set_class_context(PredInfo6,
+ pred_info_set_arg_types(PredInfo6, TypeVarSet,
+ ExistQVars, RenamedOldArgTypes, PredInfo7),
+ pred_info_set_class_context(PredInfo7,
RenamedOldConstraints, PredInfo),
Changed = no
@@ -730,6 +732,56 @@
%-----------------------------------------------------------------------------%
+ %
+ % For a field access function for which the user has supplied
+ % a declaration but no clauses, add a clause
+ % 'foo:='(X, Y) = 'builtin foo:='(X, Y).
+ %
+:- pred maybe_add_default_field_access_clauses(module_info,
+ pred_info, pred_info).
+:- mode maybe_add_default_field_access_clauses(in, in, out) is det.
+
+maybe_add_default_field_access_clauses(ModuleInfo, PredInfo0, PredInfo) :-
+ pred_info_module(PredInfo0, FuncModule),
+ pred_info_name(PredInfo0, FuncName),
+ pred_info_arity(PredInfo0, PredArity),
+ pred_info_get_is_pred_or_func(PredInfo0, PredOrFunc),
+ pred_info_import_status(PredInfo0, ImportStatus),
+ FuncSymName = qualified(FuncModule, FuncName),
+ pred_info_clauses_info(PredInfo0, ClausesInfo0),
+ clauses_info_clauses(ClausesInfo0, Clauses0),
+ (
+ PredOrFunc = function,
+ Clauses0 = [],
+ status_defined_in_this_module(ImportStatus, yes),
+ adjust_func_arity(function, FuncArity, PredArity),
+ is_field_access_function_name(ModuleInfo, FuncSymName,
+ FuncArity, AccessType, non_builtin_field_access,
+ FieldName)
+ ->
+ field_access_function_name(AccessType, FieldName,
+ builtin_field_access, BuiltinFuncName),
+ clauses_info_headvars(ClausesInfo0, HeadVars),
+ pred_args_to_func_args(HeadVars, FuncArgs, FuncRetVal),
+ pred_info_context(PredInfo0, Context),
+ create_atomic_unification(FuncRetVal,
+ functor(cons(BuiltinFuncName, FuncArity), FuncArgs),
+ Context, explicit, [], Goal0),
+ Goal0 = GoalExpr - GoalInfo0,
+ set__list_to_set(HeadVars, NonLocals),
+ goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo),
+ Goal = GoalExpr - GoalInfo,
+ ProcIds = [], % the clause applies to all procedures.
+ Clause = clause(ProcIds, Goal, Context),
+ clauses_info_set_clauses(ClausesInfo0, [Clause], ClausesInfo),
+ pred_info_set_clauses_info(PredInfo0, ClausesInfo, PredInfo)
+ ;
+ PredInfo = PredInfo0
+ ).
+
+
+%-----------------------------------------------------------------------------%
+
% Iterate over the list of clauses for a predicate.
:- pred typecheck_clause_list(list(clause), list(prog_var), list(type),
@@ -2102,11 +2154,11 @@
%
list__length(Args, Arity),
typecheck_info_get_ctor_list(TypeCheckInfo0, Functor, Arity,
- ConsDefnList),
+ ConsDefnList, InvalidConsDefnList),
( ConsDefnList = [] ->
typecheck_info_get_io_state(TypeCheckInfo0, IOState0),
- report_error_undef_cons(TypeCheckInfo0, Functor, Arity,
- IOState0, IOState1),
+ report_error_undef_cons(TypeCheckInfo0, InvalidConsDefnList,
+ Functor, Arity, IOState0, IOState1),
typecheck_info_set_io_state(TypeCheckInfo0, IOState1,
TypeCheckInfo1),
typecheck_info_set_found_error(TypeCheckInfo1, yes,
@@ -2757,6 +2809,323 @@
ConsTypeInfos = [cons_type_info(TypeVarSet, ExistQVars, RetType,
[FuncType | ArgTypes], Constraints)].
+ % builtin_field_access_function_type(TypeCheckInfo, Functor,
+ % Arity, ConsTypeInfos):
+ % Succeed if Functor is the name of one the automatically
+ % generated field access functions (fieldname, '<fieldname>:=') for
+ % which the user has not supplied a definition.
+:- pred builtin_field_access_function_type(typecheck_info, cons_id, arity,
+ list(cons_type_info), list(invalid_field_update)).
+:- mode builtin_field_access_function_type(typecheck_info_ui, in, in,
+ out, out) is semidet.
+
+builtin_field_access_function_type(TypeCheckInfo, Functor, Arity,
+ ConsTypeInfos, InvalidFieldUpdates) :-
+ %
+ % Taking the address of automatically generated field access
+ % functions is not allowed, so currying does have to be
+ % considered here.
+ %
+ Functor = cons(Name, Arity),
+ typecheck_info_get_module_info(TypeCheckInfo, ModuleInfo),
+ is_field_access_function_name(ModuleInfo, Name, Arity,
+ AccessType, IsBuiltin, FieldName),
+
+ module_info_ctor_field_table(ModuleInfo, CtorFieldTable),
+ map__search(CtorFieldTable, FieldName, FieldDefns),
+
+ list__filter_map(
+ make_field_access_function_cons_type_info(TypeCheckInfo, Name,
+ Arity, AccessType, IsBuiltin, FieldName),
+ FieldDefns, MaybeConsTypeInfos),
+
+ list__filter_map(
+ (pred(MaybeConsTypeInfo::in, ConsTypeInfo::out) is semidet :-
+ MaybeConsTypeInfo = cons_type_info(ConsTypeInfo)
+ ), MaybeConsTypeInfos, ConsTypeInfos),
+
+ list__filter_map(
+ (pred(MaybeConsTypeInfo::in, InvalidCons::out) is semidet :-
+ MaybeConsTypeInfo = invalid_field_update(InvalidCons)
+ ), MaybeConsTypeInfos, InvalidFieldUpdates).
+
+:- pred make_field_access_function_cons_type_info(typecheck_info,
+ sym_name, arity, field_access_type,
+ field_access_function_is_builtin,
+ ctor_field_name, hlds_ctor_field_defn, maybe_cons_type_info).
+:- mode make_field_access_function_cons_type_info(in,
+ in, in, in, in, in, in, out) is semidet.
+
+make_field_access_function_cons_type_info(TypeCheckInfo, FuncName, Arity,
+ AccessType, IsBuiltin, FieldName, FieldDefn, ConsTypeInfo) :-
+ get_field_access_constructor(TypeCheckInfo, FuncName, Arity,
+ AccessType, IsBuiltin, FieldDefn, FunctorConsTypeInfo),
+ convert_field_access_cons_type_info(AccessType, FieldName, FieldDefn,
+ FunctorConsTypeInfo, ConsTypeInfo).
+
+:- pred get_field_access_constructor(typecheck_info, sym_name, arity,
+ field_access_type, field_access_function_is_builtin,
+ hlds_ctor_field_defn, cons_type_info).
+:- mode get_field_access_constructor(typecheck_info_ui,
+ in, in, in, in, in, out) is semidet.
+
+get_field_access_constructor(TypeCheckInfo, FuncName, Arity, _AccessType,
+ IsBuiltin, FieldDefn, FunctorConsTypeInfo) :-
+
+ FieldDefn = hlds_ctor_field_defn(_, _, TypeId, ConsId, _),
+ TypeId = qualified(TypeModule, _) - _,
+
+ %
+ % If the user has supplied a definition, we use that instead
+ % of the automatically generated version.
+ % Those cases will be picked up by builtin_pred_type.
+ %
+ typecheck_info_get_module_info(TypeCheckInfo, ModuleInfo),
+ module_info_get_predicate_table(ModuleInfo, PredTable),
+ unqualify_name(FuncName, UnqualFuncName),
+ \+ predicate_table_search_func_m_n_a(PredTable, TypeModule,
+ UnqualFuncName, Arity, _),
+
+ %
+ % Only allow calls to the `'builtin <field>'/1' and
+ % `'builtin field:='/2' functions from within the same module
+ % as the type definition.
+ %
+ (
+ IsBuiltin = builtin_field_access,
+ typecheck_info_get_predid(TypeCheckInfo, PredId),
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ pred_info_module(PredInfo, PredModule),
+ PredModule = TypeModule
+ ;
+ IsBuiltin = non_builtin_field_access
+ ),
+
+ module_info_ctors(ModuleInfo, Ctors),
+ map__lookup(Ctors, ConsId, ConsDefns0),
+ list__filter(
+ (pred(CtorDefn::in) is semidet :-
+ CtorDefn = hlds_cons_defn(_, _, _, TypeId, _)
+ ), ConsDefns0, ConsDefns),
+ ConsDefns = [ConsDefn],
+ convert_cons_defn(TypeCheckInfo, ConsDefn, FunctorConsTypeInfo).
+
+:- type maybe_cons_type_info
+ ---> cons_type_info(cons_type_info)
+ ; invalid_field_update(invalid_field_update)
+ .
+
+:- type invalid_field_update
+ ---> invalid_field_update(ctor_field_name, hlds_ctor_field_defn,
+ tvarset, list(tvar)).
+
+:- pred convert_field_access_cons_type_info(field_access_type,
+ ctor_field_name, hlds_ctor_field_defn,
+ cons_type_info, maybe_cons_type_info) is det.
+:- mode convert_field_access_cons_type_info(in, in, in, in, out) is det.
+
+convert_field_access_cons_type_info(AccessType, FieldName, FieldDefn,
+ FunctorConsTypeInfo, ConsTypeInfo) :-
+ FunctorConsTypeInfo = cons_type_info(TVarSet0, ExistQVars0,
+ FunctorType, ConsArgTypes, ClassConstraints0),
+ FieldDefn = hlds_ctor_field_defn(_, _, _, _, FieldNumber),
+ list__index1_det(ConsArgTypes, FieldNumber, FieldType),
+
+ (
+ AccessType = get,
+ RetType = FieldType,
+ ArgTypes = [FunctorType],
+ TVarSet = TVarSet0,
+ ExistQVars = ExistQVars0,
+ ClassConstraints = ClassConstraints0,
+ ConsTypeInfo = cons_type_info(cons_type_info(TVarSet, ExistQVars,
+ RetType, ArgTypes, ClassConstraints))
+ ;
+ AccessType = set,
+
+ %
+ % A `'field:='/2' function has no existentially
+ % quantified type variables - the values of all
+ % type variables in the field are supplied by
+ % the caller, all the others are supplied by
+ % the input term.
+ %
+ ExistQVars = [],
+
+ %
+ % When setting a polymorphic field, the type of the
+ % field in the result is not necessarily the
+ % same as in the input.
+ % If a type variable occurs only in the field being set,
+ % create a new type variable for it in the result type.
+ %
+ % This allows code such as
+ % :- type pair(T, U)
+ % ---> '-'(fst::T, snd::U).
+ %
+ % Pair0 = 1 - 'a',
+ % Pair = Pair0 ^ snd := 2.
+ %
+ term__vars(FieldType, TVarsInField),
+ ( TVarsInField = [] ->
+ TVarSet = TVarSet0,
+ RetType = FunctorType,
+ ArgTypes = [FunctorType, FieldType],
+
+ %
+ % Remove any existential constraints - the
+ % typeclass-infos supplied by the input term
+ % are local to the set function, so they don't
+ % have to be considered here.
+ %
+ ClassConstraints0 = constraints(UnivConstraints, _),
+ ClassConstraints = constraints(UnivConstraints, []),
+ ConsTypeInfo = cons_type_info(
+ cons_type_info(TVarSet, ExistQVars,
+ RetType, ArgTypes, ClassConstraints))
+ ;
+ %
+ % XXX This demonstrates a problem - if a
+ % type variable occurs in the types of multiple
+ % fields, any predicates changing values of
+ % one of these fields cannot change their types.
+ % This especially a problem for existentially typed
+ % fields, because setting the field always changes
+ % the type.
+ %
+ % Haskell gets around this problem by allowing
+ % multiple fields to be set by the same expression.
+ % Haskell doesn't handle all cases -- it is not
+ % possible to get multiple existentially typed fields
+ % using record syntax and pass them to a function
+ % whose type requires that the fields are of the
+ % same type. It probably won't come up too often.
+ %
+ list__replace_nth_det(ConsArgTypes, FieldNumber, int_type,
+ ArgTypesWithoutField),
+ term__vars_list(ArgTypesWithoutField,
+ TVarsInOtherArgs),
+ set__intersect(
+ set__list_to_set(TVarsInField),
+ set__intersect(
+ set__list_to_set(TVarsInOtherArgs),
+ set__list_to_set(ExistQVars0)
+ ),
+ ExistQVarsInFieldAndOthers),
+ (
+ set__empty(ExistQVarsInFieldAndOthers)
+ ->
+ %
+ % Rename apart type variables occurring only in the
+ % field to be replaced - the values of those
+ % type variables will be supplied by the
+ % replacement field value.
+ %
+ list__delete_elems(TVarsInField, TVarsInOtherArgs,
+ TVarsOnlyInField0),
+ list__sort_and_remove_dups(TVarsOnlyInField0,
+ TVarsOnlyInField),
+ list__length(TVarsOnlyInField, NumNewTVars),
+ varset__new_vars(TVarSet0, NumNewTVars,
+ NewTVars, TVarSet),
+ map__from_corresponding_lists(TVarsOnlyInField,
+ NewTVars, TVarRenaming),
+ term__apply_variable_renaming(FieldType, TVarRenaming,
+ RenamedFieldType),
+ term__apply_variable_renaming(FunctorType,
+ TVarRenaming, OutputFunctorType),
+
+ %
+ % Rename the class constraints, projecting
+ % the constraints onto the set of type variables
+ % occuring in the types of the arguments of
+ % the call to `'field:='/2'.
+ %
+ term__vars_list([FunctorType, FieldType],
+ CallTVars0),
+ set__list_to_set(CallTVars0, CallTVars),
+ project_rename_flip_class_constraints(CallTVars,
+ TVarRenaming, ClassConstraints0,
+ ClassConstraints),
+
+ RetType = OutputFunctorType,
+ ArgTypes = [FunctorType, RenamedFieldType],
+ ConsTypeInfo = cons_type_info(
+ cons_type_info(TVarSet, ExistQVars,
+ RetType, ArgTypes, ClassConstraints))
+ ;
+ %
+ % This field cannot be set. Pass out some information
+ % so that we can give a better error message.
+ % Errors involving changing the types of universally
+ % quantified type variables will be caught by
+ % typecheck_functor_arg_types.
+ %
+ set__to_sorted_list(ExistQVarsInFieldAndOthers,
+ ExistQVarsInFieldAndOthers1),
+ ConsTypeInfo =
+ invalid_field_update(
+ invalid_field_update(FieldName, FieldDefn,
+ TVarSet0, ExistQVarsInFieldAndOthers1))
+ )
+ )
+ ).
+
+ % Rename constraints containing variables that have been renamed.
+ % These constraints are all universal constraints - the values
+ % of the type variables are supplied by the caller.
+:- pred project_rename_flip_class_constraints(set(tvar), map(tvar, tvar),
+ class_constraints, class_constraints).
+:- mode project_rename_flip_class_constraints(in, in, in, out) is det.
+
+project_rename_flip_class_constraints(CallTVars, TVarRenaming,
+ Constraints0, Constraints) :-
+ Constraints0 = constraints(UnivConstraints0, ExistConstraints0),
+
+ %
+ % XXX We currently don't allow universal constraints on
+ % types or data constructors (but we should). When we
+ % implement handling of those, they will need to be renamed
+ % here as well.
+ %
+ ( UnivConstraints0 = [] ->
+ true
+ ;
+ error(
+ "project_rename_flip_class_constraints: universal constraints")
+ ),
+
+ %
+ % Project the constraints down onto the list of tvars
+ % in the call.
+ %
+ ProjectConstraints =
+ (pred(ConstraintToCheck::in) is semidet :-
+ ConstraintToCheck = constraint(_, TypesToCheck),
+ term__vars_list(TypesToCheck, TVarsToCheck0),
+ set__list_to_set(TVarsToCheck0, TVarsToCheck),
+ set__intersect(TVarsToCheck, CallTVars, RelevantTVars),
+ \+ set__empty(RelevantTVars)
+ ),
+ list__filter(ProjectConstraints, ExistConstraints0, ExistConstraints1),
+
+ RenameConstraints =
+ (pred(Constraint0::in, Constraint::out) is semidet :-
+ Constraint0 = constraint(ClassName, ConstraintTypes0),
+ some [Var] (
+ term__contains_var_list(ConstraintTypes0, Var),
+ map__contains(TVarRenaming, Var)
+ ),
+ term__apply_variable_renaming_to_list(ConstraintTypes0,
+ TVarRenaming, ConstraintTypes),
+ Constraint = constraint(ClassName, ConstraintTypes)
+ ),
+ list__filter_map(RenameConstraints, ExistConstraints1, NewConstraints),
+
+ % The variables which were previously existentially quantified
+ % are now universally quantified.
+ Constraints = constraints(NewConstraints, []).
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -3322,25 +3691,30 @@
%-----------------------------------------------------------------------------%
:- pred typecheck_info_get_ctor_list(typecheck_info, cons_id, int,
- list(cons_type_info)).
-:- mode typecheck_info_get_ctor_list(typecheck_info_ui, in, in, out) is det.
+ list(cons_type_info), list(invalid_field_update)).
+:- mode typecheck_info_get_ctor_list(typecheck_info_ui,
+ in, in, out, out) is det.
-typecheck_info_get_ctor_list(TypeCheckInfo, Functor, Arity, ConsInfoList) :-
+typecheck_info_get_ctor_list(TypeCheckInfo, Functor, Arity,
+ ConsInfoList, InvalidFieldUpdates) :-
(
builtin_apply_type(TypeCheckInfo, Functor, Arity,
ApplyConsInfoList)
->
- ConsInfoList = ApplyConsInfoList
+ ConsInfoList = ApplyConsInfoList,
+ InvalidFieldUpdates = []
;
typecheck_info_get_ctor_list_2(TypeCheckInfo, Functor, Arity,
- ConsInfoList)
+ ConsInfoList, InvalidFieldUpdates)
).
:- pred typecheck_info_get_ctor_list_2(typecheck_info, cons_id,
- int, list(cons_type_info)).
-:- mode typecheck_info_get_ctor_list_2(typecheck_info_ui, in, in, out) is det.
+ int, list(cons_type_info), list(invalid_field_update)).
+:- mode typecheck_info_get_ctor_list_2(typecheck_info_ui,
+ in, in, out, out) is det.
-typecheck_info_get_ctor_list_2(TypeCheckInfo, Functor, Arity, ConsInfoList) :-
+typecheck_info_get_ctor_list_2(TypeCheckInfo, Functor, Arity,
+ ConsInfoList, InvalidFieldUpdates) :-
% Check if `Functor/Arity' has been defined as a constructor
% in some discriminated union type(s). This gives
% us a list of possible cons_type_infos.
@@ -3414,9 +3788,26 @@
builtin_pred_type(TypeCheckInfo, Functor, Arity,
PredConsInfoList)
->
- list__append(ConsInfoList2, PredConsInfoList, ConsInfoList)
+ list__append(ConsInfoList2, PredConsInfoList, ConsInfoList3)
;
- ConsInfoList = ConsInfoList2
+ ConsInfoList3 = ConsInfoList2
+ ),
+
+ %
+ % Check if Functor is a field access function which has not
+ % been overridden by the user.
+ %
+ (
+ builtin_field_access_function_type(TypeCheckInfo,
+ Functor, Arity, FieldAccessConsInfoList,
+ InvalidFieldUpdates0)
+ ->
+ list__append(FieldAccessConsInfoList,
+ ConsInfoList3, ConsInfoList),
+ InvalidFieldUpdates = InvalidFieldUpdates0
+ ;
+ InvalidFieldUpdates = [],
+ ConsInfoList = ConsInfoList3
).
:- pred flip_quantifiers(cons_type_info, cons_type_info).
@@ -4867,66 +5258,67 @@
:- pred write_type_stuff_list(list(type_stuff), io__state, io__state).
:- mode write_type_stuff_list(in, di, uo) is det.
-write_type_stuff_list([]) --> [].
-write_type_stuff_list([type_stuff(T, TVarSet, TBinding) | Ts]) -->
- write_type_b(T, TVarSet, TBinding),
- write_type_stuff_list_2(Ts).
+write_type_stuff_list(Ts) -->
+ write_comma_separated_error_list(write_type_stuff, Ts).
-:- pred write_type_stuff_list_2(list(type_stuff), io__state, io__state).
-:- mode write_type_stuff_list_2(in, di, uo) is det.
+:- pred write_type_stuff(type_stuff, io__state, io__state).
+:- mode write_type_stuff(in, di, uo) is det.
-write_type_stuff_list_2([]) --> [].
-write_type_stuff_list_2([type_stuff(T, TVarSet, TBinding) | Ts]) -->
- io__write_string(", "),
- write_type_b(T, TVarSet, TBinding),
- write_type_stuff_list_2(Ts).
+write_type_stuff(type_stuff(T, TVarSet, TBinding)) -->
+ write_type_b(T, TVarSet, TBinding).
:- pred write_var_type_stuff_list(list(type_stuff), type, io__state, io__state).
:- mode write_var_type_stuff_list(in, in, di, uo) is det.
-write_var_type_stuff_list([], _Type) --> [].
-write_var_type_stuff_list([type_stuff(VT, TVarSet, TBinding) | Ts], T) -->
- write_type_b(VT, TVarSet, TBinding),
- io__write_string("/"),
- write_type_b(T, TVarSet, TBinding),
- write_var_type_stuff_list_2(Ts, T).
-
-:- pred write_var_type_stuff_list_2(list(type_stuff), type,
- io__state, io__state).
-:- mode write_var_type_stuff_list_2(in, in, di, uo) is det.
+write_var_type_stuff_list(Ts, T) -->
+ write_comma_separated_error_list(write_var_type_stuff(T), Ts).
-write_var_type_stuff_list_2([], _Type) --> [].
-write_var_type_stuff_list_2([type_stuff(VT, TVarSet, TBinding) | Ts], T) -->
- io__write_string(", "),
+:- pred write_var_type_stuff(type, type_stuff, io__state, io__state).
+:- mode write_var_type_stuff(in, in, di, uo) is det.
+
+write_var_type_stuff(T, type_stuff(VT, TVarSet, TBinding)) -->
write_type_b(VT, TVarSet, TBinding),
io__write_string("/"),
- write_type_b(T, TVarSet, TBinding),
- write_type_stuff_list_2(Ts).
+ write_type_b(T, TVarSet, TBinding).
:- pred write_arg_type_stuff_list(list(arg_type_stuff), io__state, io__state).
:- mode write_arg_type_stuff_list(in, di, uo) is det.
+
+write_arg_type_stuff_list(Ts) -->
+ write_comma_separated_error_list(write_arg_type_stuff, Ts).
+
+:- pred write_arg_type_stuff(arg_type_stuff, io__state, io__state).
+:- mode write_arg_type_stuff(in, di, uo) is det.
-write_arg_type_stuff_list([]) --> [].
-write_arg_type_stuff_list([arg_type_stuff(T0, VT0, TVarSet) | Ts]) -->
+write_arg_type_stuff(arg_type_stuff(T0, VT0, TVarSet)) -->
{ strip_builtin_qualifiers_from_type(VT0, VT) },
mercury_output_term(VT, TVarSet, no),
io__write_string("/"),
{ strip_builtin_qualifiers_from_type(T0, T) },
- mercury_output_term(T, TVarSet, no),
- write_arg_type_stuff_list_2(Ts).
+ mercury_output_term(T, TVarSet, no).
-:- pred write_arg_type_stuff_list_2(list(arg_type_stuff), io__state, io__state).
-:- mode write_arg_type_stuff_list_2(in, di, uo) is det.
+%-----------------------------------------------------------------------------%
+
+:- pred write_comma_separated_error_list(pred(T, io__state, io__state),
+ list(T), io__state, io__state).
+:- mode write_comma_separated_error_list(pred(in, di, uo) is det, in,
+ di, uo) is det.
+
+write_comma_separated_error_list(_, []) --> [].
+write_comma_separated_error_list(Pred, [Error | Errors]) -->
+ Pred(Error),
+ write_comma_separated_error_list_2(Pred, Errors).
-write_arg_type_stuff_list_2([]) --> [].
-write_arg_type_stuff_list_2([arg_type_stuff(T0, VT0, TVarSet) | Ts]) -->
+:- pred write_comma_separated_error_list_2(pred(T, io__state, io__state),
+ list(T), io__state, io__state).
+:- mode write_comma_separated_error_list_2(pred(in, di, uo) is det, in,
+ di, uo) is det.
+
+write_comma_separated_error_list_2(_, []) --> [].
+write_comma_separated_error_list_2(Pred, [Error | Errors]) -->
io__write_string(", "),
- { strip_builtin_qualifiers_from_type(VT0, VT) },
- mercury_output_term(VT, TVarSet, no),
- io__write_string("/"),
- { strip_builtin_qualifiers_from_type(T0, T) },
- mercury_output_term(T, TVarSet, no),
- write_arg_type_stuff_list_2(Ts).
+ Pred(Error),
+ write_comma_separated_error_list_2(Pred, Errors).
%-----------------------------------------------------------------------------%
@@ -5121,11 +5513,12 @@
prog_out__write_sym_name(SymName),
io__write_string("'.\n").
-:- pred report_error_undef_cons(typecheck_info, cons_id, int, io__state,
- io__state).
-:- mode report_error_undef_cons(typecheck_info_no_io, in, in, di, uo) is det.
+:- pred report_error_undef_cons(typecheck_info, list(invalid_field_update),
+ cons_id, int, io__state, io__state).
+:- mode report_error_undef_cons(typecheck_info_no_io, in,
+ in, in, di, uo) is det.
-report_error_undef_cons(TypeCheckInfo, Functor, Arity) -->
+report_error_undef_cons(TypeCheckInfo, InvalidFieldUpdates, Functor, Arity) -->
{ typecheck_info_get_called_predid(TypeCheckInfo, CalledPredId) },
{ typecheck_info_get_arg_num(TypeCheckInfo, ArgNum) },
{ typecheck_info_get_context(TypeCheckInfo, Context) },
@@ -5224,7 +5617,13 @@
;
[]
)
- ;
+ ; { InvalidFieldUpdates = [_ | _] } ->
+ io__write_string(
+ " error: invalid field update `"),
+ hlds_out__write_cons_id(Functor),
+ io__write_string("':\n"),
+ report_invalid_field_updates(InvalidFieldUpdates)
+ ;
(
{ Functor = cons(Constructor, Arity) },
{ typecheck_info_get_ctors(TypeCheckInfo, ConsTable) },
@@ -5254,6 +5653,45 @@
)
)
).
+
+:- pred report_invalid_field_updates(list(invalid_field_update),
+ io__state, io__state).
+:- mode report_invalid_field_updates(in, di, uo) is det.
+
+report_invalid_field_updates(Updates) -->
+ write_comma_separated_error_list(report_invalid_field_update, Updates).
+
+:- pred report_invalid_field_update(invalid_field_update,
+ io__state, io__state).
+:- mode report_invalid_field_update(in, di, uo) is det.
+
+report_invalid_field_update(invalid_field_update(FieldName, FieldDefn,
+ TVarSet, TVars)) -->
+ { FieldDefn = hlds_ctor_field_defn(Context, _, _, ConsId, _) },
+ prog_out__write_context(Context),
+ io__write_string(" existentially quantified type "),
+ (
+ { TVars = [] },
+ { error("report_invalid_field_update: no type variables") }
+ ;
+ { TVars = [TVar] },
+ io__write_string("variable `"),
+ mercury_output_var(TVar, TVarSet, no),
+ io__write_string("' occurs\n")
+ ;
+ { TVars = [_, _ | _] },
+ io__write_string("variables `"),
+ mercury_output_vars(TVars, TVarSet, no),
+ io__write_string("' occur\n")
+ ),
+ prog_out__write_context(Context),
+ io__write_string(" in the types of field `"),
+ prog_out__write_sym_name(FieldName),
+ io__write_string("' and some other field\n"),
+ prog_out__write_context(Context),
+ io__write_string(" in definition of constructor `"),
+ hlds_out__write_cons_id(ConsId),
+ io__write_string(" '.\n").
:- pred report_wrong_arity_constructor(sym_name, arity, list(int),
prog_context, io__state, io__state).
Index: doc/reference_manual.texi
===================================================================
RCS file: /home/mercury1/repository/mercury/doc/reference_manual.texi,v
retrieving revision 1.162
diff -u -u -r1.162 reference_manual.texi
--- reference_manual.texi 1999/12/13 13:30:47 1.162
+++ reference_manual.texi 2000/01/04 05:27:34
@@ -713,6 +713,41 @@
transform(V_in, V_out, =(Term)) = (Term = V_in, V_out = V_in)
@end example
+ at item :=(@var{Term})
+A DCG output unification. Unifies @var{Term} with the implicit DCG output
+argument, ignoring the input DCG argument.
+ at var{Term} must be a valid data-term.
+
+Semantics:
+ at example
+transform(V_in, V_out, :=(Term)) = (V_out = Term)
+ at end example
+
+ at item @var{Term} := ^ @var{Field1} ^ ... ^ @var{FieldN}
+Unifies @var{Term} with the field of the implicit DCG argument
+labelled by @var{Field}.
+ at var{Term} must be a valid data-term.
+ at var{Field1} @dots{} @var{FieldN} must be valid field names.
+ at xref{Record syntax}.
+
+Semantics:
+ at example
+transform(V_in, V_out, Term := ^ Field1 ^ @dots{} ^ FieldN ) =
+ (Term = V_in ^ Field1 ^ @dots{} ^ FieldN, V_out = V_in)
+ at end example
+
+ at item ^ @var{Field} := @var{Term}
+Replaces a field in the implicit DCG argument.
+ at var{Term} must be a valid data-term.
+ at var{Field1} @dots{} @var{FieldN} must be valid field names.
+ at xref{Record syntax}.
+
+Semantics:
+ at example
+transform(V_in, V_out, ^ Field1 ^ @dots{} ^ FieldN := Term) =
+ (V_out = V_in ^ Field1 ^ @dots{} ^ FieldN := Term)
+ at end example
+
@item @var{DCG-call}
Any term which does not match any of the above forms
must be a DCG predicate call.
@@ -745,6 +780,7 @@
@menu
* Data-functors::
+* Record syntax::
* Conditional expressions::
* Lambda expressions::
* Higher-order function applications::
@@ -762,6 +798,51 @@
must name a function, predicate, or data constructor declared
in the program or in the interface of an imported module.
+ at node Record syntax
+ at subsection Record syntax
+
+Record syntax provides a convenient way to extract or update fields
+of data constructors, independent of the definition of the constructor.
+
+A field within a term is specified by a list of
+(possibly module-qualified) field names separated by the operator `^'.
+For example @samp{field1}, @samp{module__field1} and
+ at samp{field1 ^ field2} are all valid field specifiers.
+
+Record syntax expressions are transformed into sequences of calls
+to field extraction or update functions (@pxref{Field access functions}).
+
+ at table @code
+ at item @var{Term} ^ @var{Field1} ^ @dots{} ^ @var{FieldN}
+
+A field extraction.
+ at var{Term} must be a valid data-term.
+ at var{Field1} @dots{} @var{FieldN} must be valid field names.
+
+This is equivalent to a sequence of function calls:
+ at example
+ at var{FieldN}(@dots{} @var{Field1}(@var{Term}) @dots{}).
+ at end example
+
+ at item @var{Term} ^ @var{Field1} ^ @dots{} ^ @var{FieldN} := @var{FieldValue}
+
+A field update.
+ at var{Term} must be a valid data-term.
+ at var{Field1} @dots{} @var{FieldN} must be valid field names.
+
+This is equivalent to the code:
+ at example
+OldField1 = Term ^ Field1,
+OldField2 = OldField1 ^ OldField2,
+ at dots{}
+NewField_N_Minus_1 = 'FieldN:='(OldField_N_Minus_1, FieldValue),
+ at dots{}
+NewField1 = 'Field2:='(OldField1, NewField2),
+Result = 'Field1:='(Term, NewField1)
+ at end example
+
+ at end table
+
@node Conditional expressions
@subsection Conditional expressions
@@ -915,6 +996,16 @@
type classes (@pxref{Type classes}), and existentially quantified types
(@pxref{Existential types}).
+ at menu
+* Builtin types::
+* User-defined types::
+* Predicate and function types::
+* Field access functions::
+ at end menu
+
+ at node Builtin types
+ at section Builtin types
+
Certain special types are builtin, or are defined in the Mercury library:
@table @asis
@@ -945,13 +1036,22 @@
@end table
+ at node User-defined types
+ at section User-defined types
+
New types can be introduced with @samp{:- type} declarations.
There are several categories of derived types:
- at itemize @bullet
- at item
-Discriminated unions: these encompass both enumeration and
-record types in other languages.
+ at menu
+* Discriminated unions::
+* Equivalence types::
+* Abstract types::
+ at end menu
+
+ at node Discriminated unions
+ at subsection Discriminated unions
+
+These encompass both enumeration and record types in other languages.
A derived type is defined using @samp{:- type @var{type} ---> @var{body}}.
(Note there are @emph{three} dashes in that arrow.
It should not be confused with the two-dash arrow used for DCGs
@@ -976,6 +1076,12 @@
Existentially typed discriminated union definitions need not be
transparent.
+The arguments of constructor definitions may be labelled.
+These labels can be used to conveniently extract and update fields
+of a constructor in a manner independent of the definition of the
+constructor (@pxref{Field access functions}). A labelled argument
+is of the form `@code{@var{FieldName} :: @var{Type}}'.
+
Here are some examples of discriminated union definitions:
@example
@@ -991,9 +1097,9 @@
:- type employee
---> employee(
- string, % name
- int, % age
- string % department
+ name :: string,
+ age :: int,
+ department :: string
).
:- type tree
@@ -1033,8 +1139,22 @@
Having two different definitions of a type with the same name and arity in
the same module is an error.
- at item
-Equivalence types: these are type abbreviations.
+Constructors may be overloaded among different types:
+there may be any number of constructors with a given name and arity,
+so long as they all have different types.
+However, there must not be more than one constructor
+with the same name, arity, and result type in the same module.
+(There is no particularly good reason for this restriction;
+in the future we may allow several such functors
+as long as they have different argument types.)
+Note that excessive overloading of constructors can slow down type checking
+and can make the program confusing for human readers,
+so overloading should not be over-used.
+
+ at node Equivalence types
+ at subsection Equivalence types
+
+These are type abbreviations.
They are defined using @samp{==} as follows.
They may be polymorphic.
@@ -1056,8 +1176,10 @@
the two are equivalent in all respects
in scopes where the equivalence type is visible.
- at item
-Abstract types: these are types whose implementation is hidden.
+ at node Abstract types
+ at subsection Abstract types
+
+These are types whose implementation is hidden.
The type declarations
@example
@@ -1076,20 +1198,9 @@
Abstract types may be defined as either discriminated union types
or as equivalence types.
- at end itemize
+ at node Predicate and function types
+ at section Predicate and function types
-Constructors may be overloaded among different types:
-there may be any number of constructors with a given name and arity,
-so long as they all have different types.
-However, there must not be more than one constructor
-with the same name, arity, and result type in the same module.
-(There is no particularly good reason for this restriction;
-in the future we may allow several such functors
-as long as they have different argument types.)
-Note that excessive overloading of constructors can slow down type checking
-and can make the program confusing for human readers,
-so overloading should not be over-used.
-
The argument types of each predicate
must be explicitly declared with a @samp{:- pred} declaration.
The argument types and return type of each function must be
@@ -1183,6 +1294,154 @@
if there is a unique (up to renaming) most general valid type assignment.
Every clause in a Mercury program must be type-correct.
+ at node Field access functions
+ at section Field access functions
+
+Fields of constructors of discriminated union types may be
+labelled. These labels can be used to extract and update individual
+fields of a constructor a manner independent of the definition of
+the constructor.
+
+The Mercury language includes syntactic sugar to make it more convenient
+to extract and update fields inside nested terms (@pxref{Record syntax})
+and to extract and update fields of the DCG arguments of a
+clause (@pxref{DCG-goals}).
+
+ at menu
+* Field extraction::
+* Field update::
+* Overriding field access functions::
+* Field access examples::
+ at end menu
+
+ at node Field extraction
+ at subsection Field extraction
+
+ at example
+ at var{Field}(@var{Term})
+ at end example
+
+Each field label @samp{@var{Field}} in a constructor causes generation
+of a field extraction function @samp{@var{Field}/1}, which takes a data-term
+of the same type as the constructor and returns the value of the
+labelled field, failing if the top-level constructor of the argument
+is not the constructor containing the field.
+
+By default, this function has no modes --- the modes are inferred at
+each call to the function.
+
+An explicit lambda expression must be used to create a higher-order term
+from a field extraction function, unless a mode declaration is supplied.
+
+ at node Field update
+ at subsection Field update
+
+ at example
+'@var{Field}:='(@var{Term}, @var{ValueTerm})
+ at end example
+
+Each field label @samp{@var{Field}} in a constructor causes generation
+of a field update function @samp{'@var{Field}:='/2}.
+The first argument of this function is a data-term of the same type as the
+constructor. The second argument is a data-term of the same type as the
+labelled field. The return value is a copy of the first argument with
+value of the labelled field replaced by the second argument.
+ at samp{'@var{Field}:='/2} fails if the top-level constructor of the
+first argument is not the constructor containing the labelled field.
+
+By default, this function has no modes --- the modes
+are inferred at each call to the function.
+
+Some fields cannot be updated using field update functions.
+For the constructor @samp{unsettable/2} below, neither field may be updated
+because the resulting term would not be well-typed. A future release
+may allow multiple fields to be updated by a single expression to avoid
+this problem.
+
+ at example
+:- type unsettable
+ ---> some [T] unsettable(
+ unsettable1 :: T,
+ unsettable2 :: T
+ ).
+ at end example
+
+An explicit lambda expression must be used to create a higher-order term
+from a field update function, unless a mode declaration is supplied.
+
+ at node Overriding field access functions
+ at subsection Overriding field access functions
+
+Users can provide declarations and clauses for field access
+functions @samp{@var{Field}/1} and @samp{'@var{Field}:='/2},
+overriding the compiler-generated default declarations and
+clauses.
+
+The compiler-generated field access functions can always
+be called using the functions @samp{'builtin @var{Field}'/1} and
+ at samp{'builtin @var{Field}:='/2}. These functions may not be overridden
+by the user. They are visible only in the module containing the declaration
+of the type containing the field --- client modules must always use the
+user-supplied field access functions.
+
+Declarations for user-supplied field access functions for fields occurring
+in the interface section of a module must also occur in the interface section.
+
+Declarations for field access functions for fields local
+to a module may be placed in the interface section of the module. This allows
+the implementation of a type to be hidden while still allowing
+client modules to use record syntax to manipulate values of the type.
+Clauses need not be supplied for such functions --- the compiler adds
+a default clause containing a call to the corresponding builtin
+field access function.
+
+Declarations of field access functions can also be supplied for fields
+which are not a part of any type. This is useful when the data structures of
+a program change so that a value which was previously stored as part
+of a type is now computed each time it is requested. It also
+allows record syntax to be used for type class methods.
+
+ at node Field access examples
+ at subsection Field access examples
+
+The type declaration
+ at example
+:- type type1
+ ---> type1(
+ field1 :: int,
+ field2 :: string
+ ).
+ at end example
+causes the following functions to be automatically defined by the compiler:
+ at example
+:- func field1(type1) = int.
+field1(type1(Field1, _)) = Field1.
+
+:- func 'field1:='(type1, int) = type1.
+'field1:='(type1(_, Field2), Field1) = type1(Field1, Field2).
+
+:- func field2(type1) = string.
+field2(type1(_, Field2)) = Field2.
+
+:- func 'field2:='(type1, string) = type1.
+'field2:='(type1(Field1, _), Field2) = type1(Field1, Field2).
+ at end example
+
+The programmer can add a restriction on the domain of
+ at samp{field1} (checked at runtime), by overriding the
+update function for @samp{field1}:
+
+ at example
+:- func 'field1:='(type1, int) = type1.
+
+'field1:='(Term, Field1) = 'builtin field1:='(Term, Field1) :-
+ ( Field1 < 0 ->
+ error("'field1:=': negative value for field1")
+ ;
+ true
+ ).
+ at end example
+
@node Modes
@chapter Modes
@@ -2759,8 +3018,8 @@
@code{import_module} or @code{use_module} declaration should be in
the implementation section.
-The names of predicates, functions, constructors, types, modes, insts,
-type classes,
+The names of predicates, functions, constructors, constructor fields,
+types, modes, insts, type classes,
and (sub-)modules can be explicitly module qualified using the @samp{:}
operator, e.g. @samp{module:name} or @samp{module:submodule:name}.
This is useful both for readability and for resolving name conflicts.
Index: doc/transition_guide.texi
===================================================================
RCS file: /home/mercury1/repository/mercury/doc/transition_guide.texi,v
retrieving revision 1.31
diff -u -u -r1.31 transition_guide.texi
--- transition_guide.texi 1999/11/12 09:12:35 1.31
+++ transition_guide.texi 1999/11/23 03:15:34
@@ -126,6 +126,7 @@
:- xfx 1200
:- fx 1200
:: xfx 1175
+:= xfx 650
; xfy 1100
< xfx 700
<< yfx 400
@@ -143,7 +144,8 @@
\+ fy 900
\/ yfx 500
\= xfx 700
-^ xfy 200
+^ xfy 99
+^ fx 100
~ fy 900
aditi_bottom_up fx 500
aditi_top_down fx 500
Index: library/ops.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/ops.m,v
retrieving revision 1.27
diff -u -u -r1.27 ops.m
--- ops.m 1999/11/16 07:51:20 1.27
+++ ops.m 1999/12/21 01:28:31
@@ -141,6 +141,7 @@
ops__op_table(":-", after, xfx, 1200). % standard ISO Prolog
ops__op_table(":-", before, fx, 1200). % standard ISO Prolog
ops__op_table("::", after, xfx, 1175). % Mercury extension
+ops__op_table(":=", after, xfx, 650). % Mercury extension
ops__op_table(";", after, xfy, 1100). % standard ISO Prolog
ops__op_table("<", after, xfx, 700). % standard ISO Prolog
ops__op_table("<<", after, yfx, 400). % standard ISO Prolog
@@ -167,7 +168,11 @@
ops__op_table("\\/", after, yfx, 500). % standard ISO Prolog
ops__op_table("\\=", after, xfx, 700). % standard ISO Prolog
ops__op_table("\\==", after, xfx, 700). % standard ISO Prolog (*)
-ops__op_table("^", after, xfy, 200). % standard ISO Prolog
+ops__op_table("^", after, xfy, 99). % ISO Prolog (prec. 200,
+ % bitwise xor)
+ % Mercury (record syntax)
+ops__op_table("^", before, fx, 100). % Mercury extension
+ % (record syntax)
ops__op_table("aditi_bottom_up", before, fx, 500). % Mercury extension
ops__op_table("aditi_top_down", before, fx, 500). % Mercury extension
ops__op_table("all", before, fxy, 950). % Mercury/NU-Prolog extension
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.73
diff -u -u -r1.73 Mmakefile
--- Mmakefile 1999/11/17 02:13:56 1.73
+++ Mmakefile 1999/12/21 03:33:34
@@ -86,6 +86,7 @@
quantifier2 \
quoting_bug_test \
rational_test \
+ record_syntax \
redoip_clobber \
relation_test \
remove_file \
Index: tests/hard_coded/record_syntax.exp
===================================================================
RCS file: record_syntax.exp
diff -N record_syntax.exp
--- /dev/null Tue Jan 4 16:29:29 2000
+++ record_syntax.exp Wed Dec 22 12:49:02 1999
@@ -0,0 +1,18 @@
+X ^ arg1 = 1
+X ^ arg2 = 2
+X ^ arg3 = foo2(3, 4)
+X ^ arg3 ^ arg4 = 3
+updated arg1 = foo(5, 2, foo2(3, 4))
+updated arg2 = foo(1, 6, foo2(3, 4))
+updated arg3 ^ arg4 = foo(1, 2, foo2(7, 4))
+List1 = cons(1, cons(2, cons(4, nil)))
+List2 ^ e_next ^ e_data = 'b'
+List3 = e_cons(1, e_cons("new value", e_nil))
+List3 ^ e_next ^ e_data = "new value"
+size(List3 ^ e_next ^ e_data) = 9
+Pair0 ^ fst = 1
+Pair = "new first elem" - 2
+DCG ^ arg1 = 1
+DCG ^ arg3 ^ arg4 = 3
+updated DCG arg1 = foo(8, 2, foo2(3, 4))
+updated DCG arg3 ^ arg4 = foo(8, 2, foo2(9, 4))
Index: tests/invalid/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/Mmakefile,v
retrieving revision 1.56
diff -u -u -r1.56 Mmakefile
--- Mmakefile 1999/12/27 11:07:33 1.56
+++ Mmakefile 2000/01/04 03:41:55
@@ -52,6 +52,7 @@
prog_io_erroneous.m \
qual_basic_test2.m \
qualified_cons_id2.m \
+ record_syntax_errors.m \
some.m \
spurious_mode_error.m \
test_nested.m \
Index: tests/invalid/record_syntax_errors.err_exp
===================================================================
RCS file: record_syntax_errors.err_exp
diff -N record_syntax_errors.err_exp
--- /dev/null Tue Jan 4 16:29:29 2000
+++ record_syntax_errors.err_exp Thu Dec 23 11:55:41 1999
@@ -0,0 +1,36 @@
+record_syntax_errors.m:028: In DCG field update goal:
+record_syntax_errors.m:028: error: expected field name at term `Field'.
+record_syntax_errors.m:031: Error: expected `Field := ^ field1 ^ ... ^ fieldN'
+record_syntax_errors.m:031: or `^ field1 ^ ... ^ fieldN := Field'.
+record_syntax_errors.m:031: in DCG field access goal.
+record_syntax_errors.m:048: Error: clause for predicate `record_syntax_errors:term_type_error/1'
+record_syntax_errors.m:048: without preceding `pred' declaration.
+record_syntax_errors.m:054: In declaration of function `record_syntax_errors:field4/1':
+record_syntax_errors.m:054: error: a field access function for an
+record_syntax_errors.m:054: exported field must also be exported.
+record_syntax_errors.m:056: Error: redefinition of builtin field access function `record_syntax_errors:builtin field4/1'.
+record_syntax_errors.m:056: In declaration of function `record_syntax_errors:builtin field4/1':
+record_syntax_errors.m:056: error: a field access function for an
+record_syntax_errors.m:056: exported field must also be exported.
+record_syntax_errors.m:014: Error: no clauses for predicate `record_syntax_errors:dcg_syntax/2'.
+record_syntax_errors.m:016: Error: no clauses for predicate `record_syntax_errors:dcg_syntax_2/2'.
+record_syntax_errors.m:042: In clause for predicate `record_syntax_errors:construct_exist_cons/1':
+record_syntax_errors.m:042: error: invalid field update `field2:=/2':
+record_syntax_errors.m:005: existentially quantified type variable `T' occurs
+record_syntax_errors.m:005: in the types of field `field2' and some other field
+record_syntax_errors.m:005: in definition of constructor `record_syntax_errors:exist_cons/3 '.
+record_syntax_errors.m:046: In clause for predicate `record_syntax_errors:arg_type_error/1':
+record_syntax_errors.m:046: in argument 2 of functor `field6:=/2':
+record_syntax_errors.m:046: in argument 2 of functor `field7:=/2':
+record_syntax_errors.m:046: type error in unification of argument
+record_syntax_errors.m:046: and constant `"invalid value"'.
+record_syntax_errors.m:046: argument has type `int',
+record_syntax_errors.m:046: constant `"invalid value"' has type `string'.
+record_syntax_errors.m:050: In clause for predicate `record_syntax_errors:term_type_error/1':
+record_syntax_errors.m:050: in argument 2 of functor `field6:=/2':
+record_syntax_errors.m:050: in unification of argument
+record_syntax_errors.m:050: and term `'field4:='(V_5, V_4)':
+record_syntax_errors.m:050: type error in argument(s) of functor `field4:=/2'.
+record_syntax_errors.m:050: Argument 1 has type `(record_syntax_errors:cons2)',
+record_syntax_errors.m:050: expected type was `(record_syntax_errors:cons)'.
+For more information, try recompiling with `-E'.
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to: mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions: mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------
More information about the developers
mailing list