[m-dev.] for review: Aditi updates[4]

[Simon Taylor]

Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/post_typecheck.m,v
retrieving revision 1.6
diff -u -u -r1.6 post_typecheck.m
--- post_typecheck.m	1999/06/01 09:44:13	1.6
+++ post_typecheck.m	1999/06/02 01:21:12
@@ -37,7 +37,7 @@
 
 :- module post_typecheck.
 :- interface.
-:- import_module hlds_module, hlds_pred, io.
+:- import_module hlds_goal, hlds_module, hlds_pred, io.
 :- import_module list, prog_data.
 
 	% Check that the all of the types which have been inferred
@@ -58,6 +58,13 @@
 :- mode post_typecheck__resolve_pred_overloading(in, in, in, in, in,
 		out, out) is det.
 
+	% Resolve overloading.
+:- pred post_typecheck__finish_aditi_builtin(module_info, pred_info,
+		list(prog_var), aditi_builtin, aditi_builtin,
+		simple_call_id, simple_call_id, list(mode)).
+:- mode post_typecheck__finish_aditi_builtin(in, in, in,
+		in, out, in, out, out) is det.
+
 	% Do the stuff needed to initialize the proc_infos so that
 	% a pred is ready for mode checking (copy clauses from the
 	% clause_info to the proc_info, etc.)
@@ -79,11 +86,11 @@
 %-----------------------------------------------------------------------------%
 :- implementation.
 
-:- import_module typecheck, clause_to_proc, mode_util, inst_match.
-:- import_module mercury_to_mercury, prog_out, hlds_out, type_util.
+:- import_module typecheck, clause_to_proc, mode_util, inst_match, hlds_data.
+:- import_module mercury_to_mercury, prog_out, hlds_out, type_util, (inst).
 :- import_module globals, options.
 
-:- import_module map, set, assoc_list, bool, std_util, term.
+:- import_module map, set, assoc_list, bool, std_util, term, require, int.
 
 %-----------------------------------------------------------------------------%
 %			Check for unbound type variables
@@ -320,6 +327,151 @@
 
 %-----------------------------------------------------------------------------%
 
+post_typecheck__finish_aditi_builtin(_, _, _, aditi_call(_, _, _, _),
+		_, _, _, _) :-
+	error("post_typecheck__finish_aditi_builtin: aditi_call").
+post_typecheck__finish_aditi_builtin(ModuleInfo, CallerPredInfo, Args,
+		aditi_insert(PredId0), aditi_insert(PredId),
+		PredOrFunc - SymName0/Arity, PredOrFunc - SymName/Arity,
+		Modes) :-
+	get_state_args_det(Args, OtherArgs, _, _),
+	post_typecheck__resolve_pred_overloading(PredId0, OtherArgs,
+		CallerPredInfo, ModuleInfo, SymName0, SymName, PredId),
+
+	module_info_pred_info(ModuleInfo, PredId, CalledPredInfo),
+	pred_info_arg_types(CalledPredInfo, ArgTypes),
+	in_mode(InMode),
+	aditi_builtin_modes(InMode, (aditi_top_down),
+		ArgTypes, InsertArgModes),
+	list__append(InsertArgModes, [aditi_di_mode, aditi_uo_mode], Modes).
+
+post_typecheck__finish_aditi_builtin(ModuleInfo, CallerPredInfo, Args,
+		aditi_delete(PredId0, Syntax), aditi_delete(PredId, Syntax),
+		PredOrFunc - SymName0/Arity, PredOrFunc - SymName/Arity,
+		Modes) :-
+	AdjustArgTypes = lambda([X::in, X::out] is det, true),
+	resolve_aditi_builtin_overloading(ModuleInfo, CallerPredInfo, Args,
+		AdjustArgTypes, PredId0, PredId, SymName0, SymName),
+
+	module_info_pred_info(ModuleInfo, PredId, CalledPredInfo),
+	pred_info_arg_types(CalledPredInfo, ArgTypes),
+	in_mode(InMode),
+	aditi_builtin_modes(InMode, (aditi_top_down),
+		ArgTypes, DeleteArgModes),
+	Inst = ground(shared, yes(pred_inst_info(PredOrFunc,
+		DeleteArgModes, semidet))),
+	Modes = [(Inst -> Inst), aditi_di_mode, aditi_uo_mode].
+
+post_typecheck__finish_aditi_builtin(ModuleInfo, CallerPredInfo, Args,
+		aditi_bulk_operation(Op, PredId0),
+		aditi_bulk_operation(Op, PredId),
+		PredOrFunc - SymName0/Arity, PredOrFunc - SymName/Arity,
+		Modes) :-
+	AdjustArgTypes = lambda([X::in, X::out] is det, true),
+	resolve_aditi_builtin_overloading(ModuleInfo, CallerPredInfo, Args,
+		AdjustArgTypes, PredId0, PredId, SymName0, SymName),
+
+	module_info_pred_info(ModuleInfo, PredId, CalledPredInfo),
+	pred_info_arg_types(CalledPredInfo, ArgTypes),
+	out_mode(OutMode),
+	aditi_builtin_modes(OutMode, (aditi_bottom_up), ArgTypes, OpArgModes),
+	Inst = ground(shared, yes(pred_inst_info(PredOrFunc,
+		OpArgModes, nondet))),
+	Modes = [(Inst -> Inst), aditi_di_mode, aditi_uo_mode].
+
+post_typecheck__finish_aditi_builtin(ModuleInfo, CallerPredInfo, Args,
+		aditi_modify(PredId0, Syntax), aditi_modify(PredId, Syntax),
+		PredOrFunc - SymName0/Arity, PredOrFunc - SymName/Arity,
+		Modes) :-
+
+	% The argument types of the closure passed to `aditi_modify'
+	% contain two copies of the arguments of the base relation -
+	% one set input and one set output.
+	AdjustArgTypes =
+	    lambda([Types0::in, Types::out] is det, (
+		list__length(Types0, Length),
+		HalfLength is Length // 2,
+		( list__split_list(HalfLength, Types0, Types1, _) ->
+			Types = Types1
+		;
+			error("post_typecheck__finish_aditi_builtin: modify")
+		)
+	    )),
+	resolve_aditi_builtin_overloading(ModuleInfo, CallerPredInfo, Args,
+		AdjustArgTypes, PredId0, PredId, SymName0, SymName),
+	module_info_pred_info(ModuleInfo, PredId, CalledPredInfo),
+	pred_info_arg_types(CalledPredInfo, ArgTypes),
+	in_mode(InMode),
+	out_mode(OutMode),
+	aditi_builtin_modes(InMode, (aditi_top_down), ArgTypes, InputArgModes),
+	aditi_builtin_modes(OutMode, (aditi_top_down),
+		ArgTypes, OutputArgModes),
+	list__append(InputArgModes, OutputArgModes, ModifyArgModes),
+	Inst = ground(shared, yes(pred_inst_info(predicate,
+		ModifyArgModes, semidet))),
+	Modes = [(Inst -> Inst), aditi_di_mode, aditi_uo_mode].
+
+:- pred resolve_aditi_builtin_overloading(module_info, pred_info,
+		list(prog_var), pred(list(type), list(type)),
+		pred_id, pred_id, sym_name, sym_name).
+:- mode resolve_aditi_builtin_overloading(in, in, in, pred(in, out) is det,
+		in, out, in, out) is det.
+
+resolve_aditi_builtin_overloading(ModuleInfo, CallerPredInfo, Args,
+		AdjustArgTypes, PredId0, PredId, SymName0, SymName) :-
+	get_state_args_det(Args, OtherArgs, _, _),
+	( invalid_pred_id(PredId0) ->
+		(
+			OtherArgs = [HOArg],
+			pred_info_typevarset(CallerPredInfo, TVarSet),
+			pred_info_clauses_info(CallerPredInfo, ClausesInfo),
+			ClausesInfo = clauses_info(_, _, VarTypes, _, _),
+			map__lookup(VarTypes, HOArg, HOArgType),
+			type_is_higher_order(HOArgType, predicate,
+				(aditi_top_down), ArgTypes0)
+		->
+			call(AdjustArgTypes, ArgTypes0, ArgTypes),
+			FilterPredIds =
+			    lambda([Module::in, PredIds0::in,
+					PredIds::out] is det, (
+				list__filter(
+					hlds_pred__is_base_relation(Module),
+					PredIds0, PredIds)
+			    )),
+			typecheck__resolve_pred_overloading_2(ModuleInfo,
+				FilterPredIds, ArgTypes, TVarSet,
+				SymName0, SymName, PredId)
+		;
+			error("post_typecheck__finish_aditi_builtin: delete")
+		)
+	;
+		PredId = PredId0,
+		SymName = SymName0
+	).
+
+:- pred aditi_builtin_modes((mode), lambda_eval_method,
+		list(type), list(mode)).
+:- mode aditi_builtin_modes(in, in, in, out) is det.
+
+aditi_builtin_modes(_, _, [], []).
+aditi_builtin_modes(Mode, EvalMethod, [ArgType | ArgTypes],
+		[ArgMode | ArgModes]) :-
+	( type_is_aditi_state(ArgType) ->
+		( EvalMethod = (aditi_top_down) ->
+			% The top-down Aditi closures are not allowed
+			% to call database predicates, so their aditi__state
+			% arguments must have mode `unused'
+			ArgMode = (free -> free)
+		;
+			ArgMode = aditi_ui_mode
+		)
+	;
+		ArgMode = Mode
+	),
+	aditi_builtin_modes(Mode, EvalMethod, ArgTypes, ArgModes).
+
+%-----------------------------------------------------------------------------%
+
 	% 
 	% Copy clauses to procs, then ensure that all 
 	% constructors occurring in predicate mode 
@@ -432,9 +584,8 @@
 	{ pred_info_arity(PredInfo, Arity) },
 	{ pred_info_get_is_pred_or_func(PredInfo, PredOrFunc) },
 	io__write_string("Error: `:- pragma aditi' declaration for "),
-	hlds_out__write_pred_or_func(PredOrFunc),
-	io__write_string(" "),
-	hlds_out__write_pred_call_id(qualified(Module, Name)/Arity),
+	hlds_out__write_simple_call_id(PredOrFunc,
+		qualified(Module, Name), Arity),
 	io__write_string("  without an `aditi:state' argument.\n").
 
 :- pred report_multiple_aditi_states(pred_info, io__state, io__state).
@@ -449,9 +600,8 @@
 	{ pred_info_arity(PredInfo, Arity) },
 	{ pred_info_get_is_pred_or_func(PredInfo, PredOrFunc) },
 	io__write_string("Error: `:- pragma aditi' declaration for "),
-	hlds_out__write_pred_or_func(PredOrFunc),
-	io__write_string(" "),
-	hlds_out__write_pred_call_id(qualified(Module, Name)/Arity),
+	hlds_out__write_simple_call_id(PredOrFunc,
+		qualified(Module, Name), Arity),
 	io__nl,
 	prog_out__write_context(Context),
 	io__write_string("  with multiple `aditi:state' arguments.\n").
Index: compiler/prog_data.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_data.m,v
retrieving revision 1.45
diff -u -u -r1.45 prog_data.m
--- prog_data.m	1999/04/23 01:02:58	1.45
+++ prog_data.m	1999/05/12 06:30:17
@@ -143,8 +143,7 @@
 	;	source_file(string)
 			% Source file name.
 
-	;	unused_args(pred_or_func, sym_name, int,
-			proc_id, list(int))
+	;	unused_args(pred_or_func, sym_name, arity, proc_id, list(int))
 			% PredName, Arity, Mode, Optimized pred name,
 			% 	Removed arguments.
 			% Used for inter-module unused argument
@@ -705,6 +704,8 @@
 :- type sym_name 	
 	--->	unqualified(string)
 	;	qualified(module_specifier, string).
+:- type sym_name_and_arity
+	--->	sym_name / arity.
 
 :- type module_specifier ==	sym_name.
 :- type module_name 	== 	sym_name.
Index: compiler/prog_io_goal.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_io_goal.m,v
retrieving revision 1.15
diff -u -u -r1.15 prog_io_goal.m
--- prog_io_goal.m	1999/03/24 13:30:21	1.15
+++ prog_io_goal.m	1999/05/24 05:43:29
@@ -38,8 +38,8 @@
 	% 	`[Var1::Mode1, ..., VarN::ModeN] is Det'
 	% part.
 	%
-:- pred parse_lambda_expression(term, list(prog_term), list(mode),
-		determinism).
+:- pred parse_lambda_expression(term, list(prog_term),
+		list(mode), determinism).
 :- mode parse_lambda_expression(in, out, out, out) is semidet.
 
 	% parse_pred_expression/3 converts the first argument to a :-/2
@@ -48,9 +48,9 @@
 	% a variant on parse_lambda_expression with a different syntax:
 	% 	`(pred(Var1::Mode1, ..., VarN::ModeN) is Det :- Goal)'.
 	%
-:- pred parse_pred_expression(term, list(prog_term), list(mode),
-		determinism).
-:- mode parse_pred_expression(in, out, out, out) is semidet.
+:- pred parse_pred_expression(term, lambda_eval_method, list(prog_term),
+		list(mode), determinism).
+:- mode parse_pred_expression(in, out, out, out, out) is semidet.
 
 	% parse_dcg_pred_expression/3 converts the first argument to a -->/2
 	% higher-order dcg pred expression into a list of arguments, a list
@@ -60,9 +60,9 @@
 	%	`(pred(Var1::Mode1, ..., VarN::ModeN, DCG0Mode, DCGMode)
 	%		is Det --> Goal)'.
 	%
-:- pred parse_dcg_pred_expression(term, list(prog_term),
+:- pred parse_dcg_pred_expression(term, lambda_eval_method, list(prog_term),
 		list(mode), determinism).
-:- mode parse_dcg_pred_expression(in, out, out, out) is semidet.
+:- mode parse_dcg_pred_expression(in, out, out, out, out) is semidet.
 
 	% parse_func_expression/3 converts the first argument to a :-/2
 	% higher-order func expression into a list of arguments, a list
@@ -71,9 +71,14 @@
 	% 	`(func(Var1::Mode1, ..., VarN::ModeN) = (VarN1::ModeN1) is Det
 	%		:- Goal)'.
 	%
-:- pred parse_func_expression(term, list(prog_term), list(mode),
-		determinism).
-:- mode parse_func_expression(in, out, out, out) is semidet.
+:- pred parse_func_expression(term, lambda_eval_method, list(prog_term),
+		list(mode), determinism).
+:- mode parse_func_expression(in, out, out, out, out) is semidet.
+
+	% parse_lambda_eval_method/3 extracts the `aditi' or `aditi_top_down'
+	% annotation from a pred expression and returns the rest of the term.
+:- pred parse_lambda_eval_method(term(T), lambda_eval_method, term(T)).
+:- mode parse_lambda_eval_method(in, out, out) is det.
 
 %-----------------------------------------------------------------------------%
 
@@ -289,38 +294,46 @@
 
 %-----------------------------------------------------------------------------%
 
-parse_pred_expression(PredTerm, Args, Modes, Det) :-
-	PredTerm = term__functor(term__atom("is"), [PredArgsTerm, DetTerm], _),
+parse_pred_expression(PredTerm, EvalMethod, Args, Modes, Det) :-
+	PredTerm = term__functor(term__atom("is"),
+		[PredEvalArgsTerm, DetTerm], _),
 	DetTerm = term__functor(term__atom(DetString), [], _),
 	standard_det(DetString, Det),
+	parse_lambda_eval_method(PredEvalArgsTerm, EvalMethod, PredArgsTerm),
 	PredArgsTerm = term__functor(term__atom("pred"), PredArgsList, _),
 	parse_pred_expr_args(PredArgsList, Args, Modes).
 
-parse_dcg_pred_expression(PredTerm, Args, Modes, Det) :-
-	PredTerm = term__functor(term__atom("is"), [PredArgsTerm, DetTerm], _),
+parse_dcg_pred_expression(PredTerm, EvalMethod, Args, Modes, Det) :-
+	PredTerm = term__functor(term__atom("is"),
+		[PredEvalArgsTerm, DetTerm], _),
 	DetTerm = term__functor(term__atom(DetString), [], _),
 	standard_det(DetString, Det),
+	parse_lambda_eval_method(PredEvalArgsTerm, EvalMethod, PredArgsTerm),
 	PredArgsTerm = term__functor(term__atom("pred"), PredArgsList, _),
 	parse_dcg_pred_expr_args(PredArgsList, Args, Modes).
 
-parse_func_expression(FuncTerm, Args, Modes, Det) :-
+parse_func_expression(FuncTerm, EvalMethod, Args, Modes, Det) :-
 	%
 	% parse a func expression with specified modes and determinism
 	%
 	FuncTerm = term__functor(term__atom("is"), [EqTerm, DetTerm], _),
-	EqTerm = term__functor(term__atom("="), [FuncArgsTerm, RetTerm], _),
+	EqTerm = term__functor(term__atom("="),
+		[FuncEvalArgsTerm, RetTerm], _),
 	DetTerm = term__functor(term__atom(DetString), [], _),
 	standard_det(DetString, Det),
+	parse_lambda_eval_method(FuncEvalArgsTerm, EvalMethod, FuncArgsTerm),
 	FuncArgsTerm = term__functor(term__atom("func"), FuncArgsList, _),
 	parse_pred_expr_args(FuncArgsList, Args0, Modes0),
 	parse_lambda_arg(RetTerm, RetArg, RetMode),
 	list__append(Args0, [RetArg], Args),
 	list__append(Modes0, [RetMode], Modes).
-parse_func_expression(FuncTerm, Args, Modes, Det) :-
+parse_func_expression(FuncTerm, EvalMethod, Args, Modes, Det) :-
 	%
 	% parse a func expression with unspecified modes and determinism
 	%
-	FuncTerm = term__functor(term__atom("="), [FuncArgsTerm, RetArg], _),
+	FuncTerm = term__functor(term__atom("="),
+		[FuncEvalArgsTerm, RetArg], _),
+	parse_lambda_eval_method(FuncEvalArgsTerm, EvalMethod, FuncArgsTerm),
 	FuncArgsTerm = term__functor(term__atom("func"), Args0, _),
 	%
 	% the argument modes default to `in',
@@ -336,6 +349,23 @@
 	list__append(Modes0, [RetMode], Modes),
 	list__append(Args0, [RetArg], Args1),
 	list__map(term__coerce, Args1, Args).
+
+parse_lambda_eval_method(Term0, EvalMethod, Term) :-
+	( Term0 = term__functor(term__atom(MethodStr), [Term1], _) ->
+		( MethodStr = "aditi_bottom_up" ->
+			EvalMethod = (aditi_bottom_up),
+			Term = Term1
+		; MethodStr = "aditi_top_down" ->
+			EvalMethod = (aditi_top_down),
+			Term = Term1
+		;	
+			EvalMethod = normal,
+			Term = Term0
+		)	
+	;
+		EvalMethod = normal,
+		Term = Term0
+	).
 
 :- pred parse_pred_expr_args(list(term), list(prog_term), list(mode)).
 :- mode parse_pred_expr_args(in, out, out) is semidet.
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.19
diff -u -u -r1.19 prog_io_pragma.m
--- prog_io_pragma.m	1999/04/23 01:02:59	1.19
+++ prog_io_pragma.m	1999/05/24 05:29:36
@@ -671,27 +671,16 @@
 
 parse_pred_name_and_arity(ModuleName, PragmaType, PredAndArityTerm,
 		ErrorTerm, Result) :-
-    (
-	PredAndArityTerm = term__functor(term__atom("/"), 
-		[PredNameTerm, ArityTerm], _)
-    ->
 	(
-	    parse_implicitly_qualified_term(ModuleName,
-		PredNameTerm, ErrorTerm, "", ok(PredName, [])),
-	    ArityTerm = term__functor(term__integer(Arity), [], _)
+		parse_name_and_arity(ModuleName, PredAndArityTerm,
+			PredName, Arity)
 	->
-	    Result = ok(PredName, Arity)
+		Result = ok(PredName, Arity)
 	;
-	    string__append_list(
-		["expected predname/arity for `:- pragma ",
-		 PragmaType, "' declaration"], ErrorMsg),
-	    Result = error(ErrorMsg, PredAndArityTerm)
-	)
-    ;
-	string__append_list(["expected predname/arity for `:- pragma ",
-		 PragmaType, "' declaration"], ErrorMsg),
-	Result = error(ErrorMsg, PredAndArityTerm)
-    ).
+		string__append_list(["expected predname/arity for `pragma ",
+			PragmaType, "' declaration"], ErrorMsg),
+		Result = error(ErrorMsg, ErrorTerm)
+	).
 
 %-----------------------------------------------------------------------------%
 
@@ -946,7 +935,6 @@
 
 :- type maybe_pred_or_func_modes ==
 		maybe2(pair(sym_name, pred_or_func), list(mode)).
-:- type maybe_pred_or_func(T) == maybe2(sym_name, pair(list(T), maybe(T))).
 
 :- pred parse_pred_or_func_and_arg_modes(maybe(module_name), term, term,
 		string, maybe_pred_or_func_modes).
@@ -982,38 +970,6 @@
 	;
 		PredAndArgsResult = error(ErrorMsg, Term),
 		Result = error(ErrorMsg, Term)
-	).
-
-:- pred parse_pred_or_func_and_args(maybe(sym_name), term, term, string,
-		maybe_pred_or_func(term)).
-:- mode parse_pred_or_func_and_args(in, in, in, in, out) is det.
-
-parse_pred_or_func_and_args(MaybeModuleName, PredAndArgsTerm, ErrorTerm,
-		Msg, PredAndArgsResult) :-
-	(
-		PredAndArgsTerm = term__functor(term__atom("="),
-			[FuncAndArgsTerm, FuncResultTerm], _)
-	->
-		FunctorTerm = FuncAndArgsTerm,
-		MaybeFuncResult = yes(FuncResultTerm)
-	;
-		FunctorTerm = PredAndArgsTerm,
-		MaybeFuncResult = no
-	),
-	(
-		MaybeModuleName = yes(ModuleName),
-		parse_implicitly_qualified_term(ModuleName, FunctorTerm,
-			ErrorTerm, Msg, Result)
-	;
-		MaybeModuleName = no,
-		parse_qualified_term(FunctorTerm, ErrorTerm, Msg, Result)
-	),
-	(
-		Result = ok(SymName, Args),
-		PredAndArgsResult = ok(SymName, Args - MaybeFuncResult)
-	;
-		Result = error(ErrorMsg, Term),
-		PredAndArgsResult = error(ErrorMsg, Term)
 	).
 
 :- pred convert_bool_list(term::in, list(bool)::out) is semidet.
Index: compiler/prog_io_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_io_util.m,v
retrieving revision 1.13
diff -u -u -r1.13 prog_io_util.m
--- prog_io_util.m	1999/04/23 01:03:00	1.13
+++ prog_io_util.m	1999/05/24 06:15:45
@@ -25,9 +25,8 @@
 
 :- interface.
 
-:- import_module prog_data, hlds_data, (inst).
-:- import_module term.
-:- import_module list, map, term, io.
+:- import_module prog_data, hlds_data, hlds_pred, (inst).
+:- import_module io, list, map, std_util, term.
 
 :- type maybe2(T1, T2)	--->	error(string, term)
 			;	ok(T1, T2).
@@ -39,6 +38,9 @@
 :- type maybe_functor	== 	maybe_functor(generic).
 :- type maybe_functor(T) == 	maybe2(sym_name, list(term(T))).
 
+	% ok(SymName, Args - MaybeFuncRetArg) ; error(Msg, Term).
+:- type maybe_pred_or_func(T) == maybe2(sym_name, pair(list(T), maybe(T))).
+
 :- type maybe_item_and_context
 			==	maybe2(item, prog_context).
 
@@ -57,6 +59,28 @@
 :- pred parse_list_of_vars(term(T), list(var(T))).
 :- mode parse_list_of_vars(in, out) is semidet.
 
+:- pred parse_name_and_arity(module_name, term(_T), sym_name, arity).
+:- mode parse_name_and_arity(in, in, out, out) is semidet.
+
+:- pred parse_name_and_arity(term(_T), sym_name, arity).
+:- mode parse_name_and_arity(in, out, out) is semidet.
+
+:- pred parse_pred_or_func_name_and_arity(module_name,
+		term(_T), pred_or_func, sym_name, arity).
+:- mode parse_pred_or_func_name_and_arity(in, in, out, out, out) is semidet.
+
+:- pred parse_pred_or_func_name_and_arity(term(_T), pred_or_func,
+		sym_name, arity).
+:- mode parse_pred_or_func_name_and_arity(in, out, out, out) is semidet.
+
+:- pred parse_pred_or_func_and_args(maybe(module_name), term(_T), term(_T),
+		string, maybe_pred_or_func(term(_T))).
+:- mode parse_pred_or_func_and_args(in, in, in, in, out) is det.
+
+:- pred parse_pred_or_func_and_args(term(_T), pred_or_func, sym_name,
+		list(term(_T))).
+:- mode parse_pred_or_func_and_args(in, out, out, out) is semidet.
+
 :- pred convert_mode_list(list(term), list(mode)).
 :- mode convert_mode_list(in, out) is semidet.
 
@@ -113,6 +137,73 @@
 
 add_context(error(M, T), _, error(M, T)).
 add_context(ok(Item), Context, ok(Item, Context)).
+
+parse_name_and_arity(ModuleName, PredAndArityTerm, SymName, Arity) :-
+	PredAndArityTerm = term__functor(term__atom("/"),
+		[PredNameTerm, ArityTerm], _),
+	parse_implicitly_qualified_term(ModuleName,
+		PredNameTerm, PredNameTerm, "", ok(SymName, [])),
+	ArityTerm = term__functor(term__integer(Arity), [], _).
+
+parse_name_and_arity(PredAndArityTerm, SymName, Arity) :-
+	parse_name_and_arity(unqualified(""),
+		PredAndArityTerm, SymName, Arity).
+
+parse_pred_or_func_name_and_arity(ModuleName, PorFPredAndArityTerm,
+		PredOrFunc, SymName, Arity) :-
+	PorFPredAndArityTerm = term__functor(term__atom(PredOrFuncStr),
+		Args, _),
+	( PredOrFuncStr = "pred", PredOrFunc = predicate
+	; PredOrFuncStr = "func", PredOrFunc = function
+	),
+	Args = [Arg],
+	parse_name_and_arity(ModuleName, Arg, SymName, Arity).
+
+parse_pred_or_func_name_and_arity(PorFPredAndArityTerm,
+		PredOrFunc, SymName, Arity) :-
+	parse_pred_or_func_name_and_arity(unqualified(""),
+		PorFPredAndArityTerm, PredOrFunc, SymName, Arity).
+
+parse_pred_or_func_and_args(Term, PredOrFunc, SymName, ArgTerms) :-
+	parse_pred_or_func_and_args(no, Term, Term, "",
+		ok(SymName, ArgTerms0 - MaybeRetTerm)), 
+	(
+		MaybeRetTerm = yes(RetTerm),
+		PredOrFunc = function,
+		list__append(ArgTerms0, [RetTerm], ArgTerms)
+	;
+		MaybeRetTerm = no,
+		PredOrFunc = predicate,
+		ArgTerms = ArgTerms0
+	).
+
+parse_pred_or_func_and_args(MaybeModuleName, PredAndArgsTerm, ErrorTerm,
+		Msg, PredAndArgsResult) :-
+	(
+		PredAndArgsTerm = term__functor(term__atom("="),
+			[FuncAndArgsTerm, FuncResultTerm], _)
+	->
+		FunctorTerm = FuncAndArgsTerm,
+		MaybeFuncResult = yes(FuncResultTerm)
+	;
+		FunctorTerm = PredAndArgsTerm,
+		MaybeFuncResult = no
+	),
+	(
+		MaybeModuleName = yes(ModuleName),
+		parse_implicitly_qualified_term(ModuleName, FunctorTerm,
+			ErrorTerm, Msg, Result)
+	;
+		MaybeModuleName = no,
+		parse_qualified_term(FunctorTerm, ErrorTerm, Msg, Result)
+	),
+	(
+		Result = ok(SymName, Args),
+		PredAndArgsResult = ok(SymName, Args - MaybeFuncResult)
+	;
+		Result = error(ErrorMsg, Term),
+		PredAndArgsResult = error(ErrorMsg, Term)
+	).
 
 parse_list_of_vars(term__functor(term__atom("[]"), [], _), []).
 parse_list_of_vars(term__functor(term__atom("."), [Head, Tail], _), [V|Vs]) :-
Index: compiler/prog_out.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_out.m,v
retrieving revision 1.42
diff -u -u -r1.42 prog_out.m
--- prog_out.m	1999/03/12 06:14:16	1.42
+++ prog_out.m	1999/05/12 07:16:07
@@ -44,6 +44,10 @@
 :- pred prog_out__write_sym_name(sym_name, io__state, io__state).
 :- mode prog_out__write_sym_name(in, di, uo) is det.
 
+:- pred prog_out__write_sym_name_and_arity(sym_name_and_arity,
+		io__state, io__state).
+:- mode prog_out__write_sym_name_and_arity(in, di, uo) is det.
+
 	% Write out a symbol name, enclosed in single forward quotes ('...')
 	% if necessary, and with any special characters escaped.
 	% The output should be a syntactically valid Mercury term.
@@ -199,6 +203,11 @@
 	term_io__write_escaped_string(Name).
 prog_out__write_sym_name(unqualified(Name)) -->
 	term_io__write_escaped_string(Name).
+
+prog_out__write_sym_name_and_arity(Name / Arity) -->
+	prog_out__write_sym_name(Name),
+	io__write_string("/"),
+	io__write_int(Arity).
 
 prog_out__write_quoted_sym_name(SymName) -->
 	io__write_string("'"),
Index: compiler/purity.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/purity.m,v
retrieving revision 1.13
diff -u -u -r1.13 purity.m
--- purity.m	1999/03/05 13:09:31	1.13
+++ purity.m	1999/05/27 23:47:31
@@ -135,7 +135,7 @@
 
 :- implementation.
 
-:- import_module make_hlds, hlds_data, hlds_pred, prog_io_util.
+:- import_module make_hlds, hlds_data, hlds_pred, prog_io_util, (inst).
 :- 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.
@@ -424,10 +424,24 @@
 						    DeclaredPurity),
 		{ NumErrors = NumErrors0 }
 	).
-compute_expr_purity(HOCall, HOCall, _, _, _, _, pure, NumErrors, NumErrors) -->
-	{ HOCall = higher_order_call(_,_,_,_,_,_) }.
-compute_expr_purity(CMCall, CMCall, _, _, _, _, pure, NumErrors, NumErrors) -->
-	{ CMCall = class_method_call(_,_,_,_,_,_) }.
+compute_expr_purity(generic_call(GenericCall0, Args, Modes0, Det),
+		generic_call(GenericCall, Args, Modes, Det),
+		_GoalInfo, PredInfo, ModuleInfo, _InClosure, pure,
+		NumErrors, NumErrors) -->
+	(
+		{ GenericCall0 = higher_order(_, _, _) },
+		{ GenericCall = GenericCall0 },
+		{ Modes = Modes0 }
+	;
+		{ GenericCall0 = class_method(_, _, _, _) },
+		{ GenericCall = GenericCall0 },
+		{ Modes = Modes0 }
+	;
+		{ GenericCall0 = aditi_builtin(Builtin0, CallId0) },
+		{ post_typecheck__finish_aditi_builtin(ModuleInfo, PredInfo,
+			Args, Builtin0, Builtin, CallId0, CallId, Modes) },
+		{ GenericCall = aditi_builtin(Builtin, CallId) }
+	).
 compute_expr_purity(switch(Var,Canfail,Cases0,Storemap),
 		switch(Var,Canfail,Cases,Storemap), _, PredInfo,
 		ModuleInfo, InClosure, Purity, NumErrors0, NumErrors) -->
@@ -437,12 +451,43 @@
 		pure, NumErrors0, NumErrors) -->
 	{ Unif0 = unify(A,RHS0,C,D,E) },
 	{ Unif  = unify(A,RHS,C,D,E) },
-	(   { RHS0 = lambda_goal(F, G, H, I, J, Goal0 - Info0) } ->
-		{ RHS = lambda_goal(F, G, H, I, J, Goal - Info0) },
+	(
+		{ 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),
 		error_if_closure_impure(GoalInfo, Purity,
-					NumErrors1, NumErrors)
+					NumErrors1, NumErrors),
+		{
+			FixModes = modes_are_ok,
+			Modes = Modes0
+		;
+			FixModes = modes_need_fixing,
+			(
+				EvalMethod = normal,
+				error(
+	"compute_expr_purity: modes need fixing for normal lambda_goal")
+			;
+				EvalMethod = (aditi_top_down),
+				% `aditi_top_down' predicates can't call
+				% database predicates, so their `aditi__state'
+				% arguments must have mode `unused'.
+				StateMode = (free -> free)
+			;
+				EvalMethod = (aditi_bottom_up),
+				% Make sure `aditi_bottom_up' expressions have
+				% a `ui' mode for their aditi_state.
+				StateMode = aditi_ui_mode
+			),
+			pred_info_clauses_info(PredInfo, ClausesInfo),
+			ClausesInfo = clauses_info(_, _, VarTypes, _, _),
+			map__apply_to_list(Vars, VarTypes, LambdaVarTypes),
+			fix_aditi_state_modes(StateMode, LambdaVarTypes,
+				Modes0, Modes)
+		}
 	;
 		{ RHS = RHS0 },
 		{ NumErrors = NumErrors0 }
@@ -455,8 +500,9 @@
 		InClosure, Purity, NumErrors0, NumErrors) -->
 	compute_goal_purity(Goal0, Goal, PredInfo, ModuleInfo, 
 			    InClosure, Purity, NumErrors0, NumErrors).
-compute_expr_purity(some(Vars,Goal0), some(Vars,Goal), _, PredInfo,
-		ModuleInfo, InClosure, Purity, NumErrors0, NumErrors) -->
+compute_expr_purity(some(Vars, CanRemove, Goal0), some(Vars, CanRemove, Goal),
+		_, PredInfo, ModuleInfo, InClosure, Purity,
+		NumErrors0, NumErrors) -->
 	compute_goal_purity(Goal0, Goal, PredInfo, ModuleInfo, 
 			    InClosure, Purity, NumErrors0, NumErrors).
 compute_expr_purity(if_then_else(Vars,Goali0,Goalt0,Goale0,Store),
@@ -476,8 +522,6 @@
 	{ module_info_preds(ModuleInfo, Preds) },
 	{ map__lookup(Preds, PredId, PredInfo) },
 	{ pred_info_get_purity(PredInfo, Purity) }.
-	
-
 
 :- pred compute_goal_purity(hlds_goal, hlds_goal, pred_info,
 	module_info, bool, purity, int, int, io__state, io__state).
@@ -527,7 +571,24 @@
 	compute_cases_purity(Goals0, Goals, PredInfo, ModuleInfo, InClosure,
 			     Purity2, Purity, NumErrors1, NumErrors).
 
-
+	% Make sure lambda expressions introduced by the compiler
+	% have the correct mode for their `aditi__state' arguments.
+:- pred fix_aditi_state_modes((mode), list(type), list(mode), list(mode)).
+:- mode fix_aditi_state_modes(in, in, in, out) is det.
+
+fix_aditi_state_modes(_, [], [], []).
+fix_aditi_state_modes(_, [_|_], [], []) :-
+	error("purity:fix_aditi_state_modes").
+fix_aditi_state_modes(_, [], [_|_], []) :-
+	error("purity:fix_aditi_state_modes").
+fix_aditi_state_modes(Mode, [Type | Types],
+		[ArgMode0 | Modes0], [ArgMode | Modes]) :-
+	( type_is_aditi_state(Type) ->
+		ArgMode = Mode
+	;
+		ArgMode = ArgMode0
+	),
+	fix_aditi_state_modes(Mode, Types, Modes0, Modes).
 
 %-----------------------------------------------------------------------------%
 %				Print error messages
Index: compiler/quantification.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/quantification.m,v
retrieving revision 1.64
diff -u -u -r1.64 quantification.m
--- quantification.m	1999/03/13 01:29:10	1.64
+++ quantification.m	1999/05/27 23:47:41
@@ -184,7 +184,8 @@
 	% so we don't.)  Thus we replace `some(Vars, Goal0)' with
 	% an empty quantifier `some([], Goal)'.
 
-implicitly_quantify_goal_2(some(Vars0, Goal0), Context, some([], Goal)) -->
+implicitly_quantify_goal_2(some(Vars0, CanRemove, Goal0), Context,
+		some([], CanRemove, Goal)) -->
 	quantification__get_outside(OutsideVars),
 	quantification__get_lambda_outside(LambdaOutsideVars),
 	quantification__get_quant_vars(QuantVars),
@@ -304,13 +305,11 @@
 		call(A, B, HeadVars, D, E, F)) -->
 	implicitly_quantify_atomic_goal(HeadVars).
 
-implicitly_quantify_goal_2(higher_order_call(PredVar, ArgVars, C, D, E, F), _,
-		higher_order_call(PredVar, ArgVars, C, D, E, F)) -->
-	implicitly_quantify_atomic_goal([PredVar|ArgVars]).
-
-implicitly_quantify_goal_2(class_method_call(TCVar, B, ArgVars, D, E, F), _,
-		class_method_call(TCVar, B, ArgVars, D, E, F)) -->
-	implicitly_quantify_atomic_goal([TCVar|ArgVars]).
+implicitly_quantify_goal_2(generic_call(GenericCall, ArgVars1, C, D), _,
+		generic_call(GenericCall, ArgVars1, C, D)) -->
+	{ goal_util__generic_call_vars(GenericCall, ArgVars0) },
+	{ list__append(ArgVars0, ArgVars1, ArgVars) },
+	implicitly_quantify_atomic_goal(ArgVars).
 
 implicitly_quantify_goal_2(
 		unify(Var, UnifyRHS0, Mode, Unification0, UnifyContext),
@@ -321,7 +320,16 @@
 	implicitly_quantify_unify_rhs(UnifyRHS0, Unification0, Context,
 		UnifyRHS, Unification),
 	quantification__get_nonlocals(VarsUnifyRHS),
-	{ set__insert(VarsUnifyRHS, Var, GoalVars) },
+	{ set__insert(VarsUnifyRHS, Var, GoalVars0) },
+	{ Unification = construct(_, _, _, _, CellToReuse, _, _) ->
+		( CellToReuse = yes(cell_to_reuse(ReuseVar, _, _)) ->
+			set__insert(GoalVars0, ReuseVar, GoalVars)
+		;
+			GoalVars = GoalVars0
+		)
+	;
+		GoalVars = GoalVars0
+	},
 	quantification__update_seen_vars(GoalVars),
 	{ set__intersect(GoalVars, OutsideVars, NonLocalVars1) },
 	{ set__intersect(GoalVars, LambdaOutsideVars, NonLocalVars2) },
@@ -358,11 +366,11 @@
 	{ set__list_to_set(ArgVars, Vars) },
 	quantification__set_nonlocals(Vars).
 implicitly_quantify_unify_rhs(
-		lambda_goal(PredOrFunc, LambdaNonLocals0,
+		lambda_goal(PredOrFunc, EvalMethod, FixModes, LambdaNonLocals0,
 			LambdaVars0, Modes, Det, Goal0),
 		Unification0,
 		Context,
-		lambda_goal(PredOrFunc, LambdaNonLocals,
+		lambda_goal(PredOrFunc, EvalMethod, FixModes, LambdaNonLocals,
 			LambdaVars, Modes, Det, Goal),
 		Unification
 		) -->
@@ -445,12 +453,14 @@
 	% so we can just use the old modes.
 	%
 	{
-		Unification0 = construct(ConstructVar, ConsId, Args0, ArgModes0)
+		Unification0 = construct(ConstructVar, ConsId, Args0,
+			ArgModes0, Reuse, Uniq, AditiInfo)
 	->
 		map__from_corresponding_lists(Args0, ArgModes0, ArgModesMap),
 		set__to_sorted_list(NonLocals, Args),
 		map__apply_to_list(Args, ArgModesMap, ArgModes),
-		Unification = construct(ConstructVar, ConsId, Args, ArgModes)
+		Unification = construct(ConstructVar, ConsId, Args,
+			ArgModes, Reuse, Uniq, AditiInfo)
 	;
 		% after mode analysis, unifications with lambda variables
 		% should always be construction unifications, but
@@ -619,18 +629,25 @@
 		set(prog_var), set(prog_var), set(prog_var)).
 :- mode quantification__goal_vars_2(in, in, in, out, out) is det.
 
-quantification__goal_vars_2(unify(A, B, _, _, _), Set0, LambdaSet0,
+quantification__goal_vars_2(unify(A, B, _, D, _), Set0, LambdaSet0,
 		Set, LambdaSet) :-
 	set__insert(Set0, A, Set1),
-	quantification__unify_rhs_vars(B, Set1, LambdaSet0, Set, LambdaSet).
-
-quantification__goal_vars_2(higher_order_call(PredVar, ArgVars, _, _, _, _),
-		Set0, LambdaSet, Set, LambdaSet) :-
-	set__insert_list(Set0, [PredVar | ArgVars], Set).
+	( D = construct(_, _, _, _, Reuse, _, _) ->
+		( Reuse = yes(cell_to_reuse(ReuseVar, _, _)) ->
+			set__insert(Set1, ReuseVar, Set2)
+		;
+			Set2 = Set1
+		)
+	;
+		Set2 = Set1
+	),
+	quantification__unify_rhs_vars(B, Set2, LambdaSet0, Set, LambdaSet).
 
-quantification__goal_vars_2(class_method_call(TCVar, _, ArgVars, _, _, _),
+quantification__goal_vars_2(generic_call(GenericCall, ArgVars1, _, _),
 		Set0, LambdaSet, Set, LambdaSet) :-
-	set__insert_list(Set0, [TCVar | ArgVars], Set).
+	goal_util__generic_call_vars(GenericCall, ArgVars0),
+	set__insert_list(Set0, ArgVars0, Set1),
+	set__insert_list(Set1, ArgVars1, Set).
 
 quantification__goal_vars_2(call(_, _, ArgVars, _, _, _), Set0, LambdaSet,
 		Set, LambdaSet) :-
@@ -650,7 +667,7 @@
 	set__insert(Set0, Var, Set1),
 	case_list_vars_2(Cases, Set1, LambdaSet0, Set, LambdaSet).
 
-quantification__goal_vars_2(some(Vars, Goal), Set0, LambdaSet0,
+quantification__goal_vars_2(some(Vars, _, Goal), Set0, LambdaSet0,
 		Set, LambdaSet) :-
 	quantification__goal_vars(Goal, Set1, LambdaSet1),
 	set__delete_list(Set1, Vars, Set2),
@@ -693,7 +710,7 @@
 		Set, LambdaSet) :-
 	set__insert_list(Set0, ArgVars, Set).
 quantification__unify_rhs_vars(
-		lambda_goal(_POrF, _NonLocals, LambdaVars, _M, _D, Goal), 
+		lambda_goal(_POrF, _E, _F, _N, LambdaVars, _M, _D, Goal), 
 		Set, LambdaSet0, Set, LambdaSet) :-
 	% Note that the NonLocals list is not counted, since all the 
 	% variables in that list must occur in the goal.
Index: compiler/rl.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/rl.m,v
retrieving revision 1.2
diff -u -u -r1.2 rl.m
--- rl.m	1999/04/28 01:18:38	1.2
+++ rl.m	1999/04/30 00:15:04
@@ -418,6 +418,15 @@
 :- type rl_var_bounds == map(prog_var, pair(key_term)).
 
 %-----------------------------------------------------------------------------%
+	
+	% This is used for a closure executed top-down on the Aditi
+	% side of the connection.
+	% These expression numbers are stored in the proc_info - the owner
+	% and module name from the pred_info are also required to completely
+	% identify the expressions.
+:- type rl_exprn_id == int.
+
+%-----------------------------------------------------------------------------%
 
 :- type label_id == int.
 
@@ -466,6 +475,23 @@
 
 %-----------------------------------------------------------------------------%
 
+	% Find out the name of the RL procedure corresponding
+	% to the given Mercury procedure.
+:- pred rl__get_entry_proc_name(module_info, pred_proc_id, rl_proc_name).
+:- mode rl__get_entry_proc_name(in, in, out) is det.
+
+	% Work out the name for a permanent relation.
+:- pred rl__permanent_relation_name(module_info::in,
+		pred_id::in, string::out) is det.
+
+	% rl__get_permanent_relation_info(ModuleInfo, PredId,
+	% 	Owner, Module, Name, Arity, RelationName, SchemaString).
+:- pred rl__get_permanent_relation_info(module_info::in, pred_id::in,
+		string::out, string::out, string::out, int::out,
+		string::out, string::out) is det.
+
+%-----------------------------------------------------------------------------%
+
 :- pred rl__proc_name_to_string(rl_proc_name::in, string::out) is det.
 :- pred rl__label_id_to_string(label_id::in, string::out) is det.
 :- pred rl__relation_id_to_string(relation_id::in, string::out) is det.
@@ -500,7 +526,8 @@
 %-----------------------------------------------------------------------------%
 :- implementation.
 
-:- import_module globals, options, prog_out, prog_util, type_util.
+:- import_module code_util, globals, llds_out, options, prog_out.
+:- import_module prog_util, type_util.
 :- import_module bool, int, require, string.
 
 rl__default_temporary_state(ModuleInfo, TmpState) :-
@@ -650,6 +677,36 @@
 
 rl__goal_produces_tuple(RLGoal) :-
 	RLGoal = rl_goal(_, _, _, _, _, yes(_), _, _).
+
+%-----------------------------------------------------------------------------%
+
+rl__get_entry_proc_name(ModuleInfo, proc(PredId, ProcId), ProcName) :-
+	code_util__make_proc_label(ModuleInfo, PredId, ProcId, Label),
+	llds_out__get_proc_label(Label, no, ProcLabel),
+	module_info_pred_info(ModuleInfo, PredId, PredInfo),
+	pred_info_module(PredInfo, PredModule0),
+	pred_info_get_aditi_owner(PredInfo, Owner),
+	prog_out__sym_name_to_string(PredModule0, PredModule),
+	ProcName = rl_proc_name(Owner, PredModule, ProcLabel, 2).
+
+rl__permanent_relation_name(ModuleInfo, PredId, ProcName) :-
+	rl__get_permanent_relation_info(ModuleInfo, PredId, Owner,
+		Module, _, _, Name, _),
+	string__format("%s/%s/%s", [s(Owner), s(Module), s(Name)],
+		ProcName).
+
+rl__get_permanent_relation_info(ModuleInfo, PredId, Owner, PredModule,
+		PredName, PredArity, RelName, SchemaString) :-
+	module_info_pred_info(ModuleInfo, PredId, PredInfo),
+	pred_info_name(PredInfo, PredName),
+	pred_info_module(PredInfo, PredModule0),
+	prog_out__sym_name_to_string(PredModule0, PredModule),
+	pred_info_get_aditi_owner(PredInfo, Owner),
+	pred_info_arity(PredInfo, PredArity),
+	string__format("%s__%i", [s(PredName), i(PredArity)], RelName),
+	pred_info_arg_types(PredInfo, ArgTypes0),
+	type_util__remove_aditi_state(ArgTypes0, ArgTypes0, ArgTypes),
+	rl__schema_to_string(ModuleInfo, ArgTypes, SchemaString).
 
 %-----------------------------------------------------------------------------%
 
Index: compiler/rl_exprn.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/rl_exprn.m,v
retrieving revision 1.3
diff -u -u -r1.3 rl_exprn.m
--- rl_exprn.m	1999/04/28 01:18:39	1.3
+++ rl_exprn.m	1999/05/14 04:54:12
@@ -324,7 +324,7 @@
 	;
 		Code = Code0
 	}.
-rl_exprn__set_term_arg_cons_id_code(pred_const(_, _), _, _, _, _, _, _) -->
+rl_exprn__set_term_arg_cons_id_code(pred_const(_, _, _), _, _, _, _, _, _) -->
 	{ error("rl_exprn__set_term_arg_cons_id_code") }.
 rl_exprn__set_term_arg_cons_id_code(code_addr_const(_, _),
 		_, _, _, _, _, _) -->
@@ -641,13 +641,11 @@
 	{ GotoEnd = node([rl_EXP_jmp(EndSwitch)]) },
 	rl_exprn__cases(Var, Cases, GotoEnd, Fail, SwitchCode),
 	{ Code = tree(SwitchCode, node([rl_PROC_label(EndSwitch)])) }.
-rl_exprn__goal(higher_order_call(_, _, _, _, _, _) - _, _, _) -->
-	{ error("rl_exprn__goal: higher-order call not yet implemented") }.
-rl_exprn__goal(class_method_call(_, _, _, _, _, _) - _, _, _) -->
-	{ error("rl_exprn__goal: class method calls not yet implemented") }.
+rl_exprn__goal(generic_call(_, _, _, _) - _, _, _) -->
+	{ error("rl_exprn__goal: higher-order and class-method calls not yet implemented") }.
 rl_exprn__goal(pragma_c_code(_, _, _, _, _, _, _) - _, _, _) -->
 	{ error("rl_exprn__goal: pragma_c_code not yet implemented") }.
-rl_exprn__goal(some(_, Goal) - _, Fail, Code) -->
+rl_exprn__goal(some(_, _, Goal) - _, Fail, Code) -->
 	rl_exprn__goal(Goal, Fail, Code).
 
 :- pred rl_exprn__cases(prog_var::in, list(case)::in, byte_tree::in,
@@ -827,7 +825,7 @@
 		byte_tree::in, byte_tree::out,
 		rl_exprn_info::in, rl_exprn_info::out) is det.
 	
-rl_exprn__unify(construct(Var, ConsId, Args, UniModes), 
+rl_exprn__unify(construct(Var, ConsId, Args, UniModes, _, _, _), 
 		GoalInfo, _Fail, Code) -->
 	rl_exprn_info_lookup_var_type(Var, Type),
 	rl_exprn_info_lookup_var(Var, VarReg),
@@ -873,7 +871,7 @@
 		{ ConsId = float_const(Float) },
 		rl_exprn__assign(reg(VarReg), const(float(Float)), Type, Code)
 	; 
-		{ ConsId = pred_const(_, _) },
+		{ ConsId = pred_const(_, _, _) },
 		{ error("rl_exprn__unify: unsupported cons_id - pred_const") }
 	; 
 		{ ConsId = code_addr_const(_, _) },
Index: compiler/rl_gen.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/rl_gen.m,v
retrieving revision 1.3
diff -u -u -r1.3 rl_gen.m
--- rl_gen.m	1999/04/28 01:18:42	1.3
+++ rl_gen.m	1999/05/27 02:14:57
@@ -16,22 +16,17 @@
 
 :- interface.
 
-:- import_module hlds_module, hlds_pred, rl.
+:- import_module hlds_module, rl.
 :- import_module io.
 
 :- pred rl_gen__module(module_info, rl_code, io__state, io__state).
 :- mode rl_gen__module(in, out, di, uo) is det.
 
-	% Find out the name of the RL procedure corresponding
-	% to the given Mercury procedure.
-:- pred rl_gen__get_entry_proc_name(module_info, pred_proc_id, rl_proc_name).
-:- mode rl_gen__get_entry_proc_name(in, in, out) is det.
-
 %-----------------------------------------------------------------------------%
 :- implementation.
 
 :- import_module code_aux, code_util, det_analysis, hlds_data, hlds_goal.
-:- import_module instmap, llds_out, mode_util, prog_data, prog_out.
+:- import_module hlds_pred, instmap, mode_util, prog_data, prog_out.
 :- import_module rl_relops, rl_info.
 :- import_module tree, type_util, dependency_graph.
 :- import_module inst_match, (inst), goal_util, inlining, globals, options.
@@ -155,16 +150,7 @@
 
 rl_gen__get_single_entry_proc_name(PredProcId, ProcName) -->
 	rl_info_get_module_info(ModuleInfo),
-	{ rl_gen__get_entry_proc_name(ModuleInfo, PredProcId, ProcName) }.
-
-rl_gen__get_entry_proc_name(ModuleInfo, proc(PredId, ProcId), ProcName) :-
-	code_util__make_proc_label(ModuleInfo, PredId, ProcId, Label),
-	llds_out__get_proc_label(Label, no, ProcLabel),
-	module_info_pred_info(ModuleInfo, PredId, PredInfo),
-	pred_info_module(PredInfo, PredModule0),
-	pred_info_get_aditi_owner(PredInfo, Owner),
-	prog_out__sym_name_to_string(PredModule0, PredModule),
-	ProcName = rl_proc_name(Owner, PredModule, ProcLabel, 2).
+	{ rl__get_entry_proc_name(ModuleInfo, PredProcId, ProcName) }.
 
 %-----------------------------------------------------------------------------%
 
@@ -216,8 +202,8 @@
 		rl_info_get_module_info(ModuleInfo),
 		( { mode_is_input(ModuleInfo, Mode) } ->
 			(
-				{ type_is_higher_order(Type,
-					predicate, PredArgTypes) } 
+				{ type_is_higher_order(Type, predicate,
+					(aditi_bottom_up), PredArgTypes) } 
 			->
 				rl_info_get_new_temporary(schema(PredArgTypes),
 					InputRel),
@@ -936,7 +922,8 @@
 		MaybeNegGoals = no
 	; 
 		% XXX check that the var is an input relation variable.
-		Goal = higher_order_call(_, _, _, _, _, predicate) - _,
+		Goal = generic_call(higher_order(_, predicate, _),
+			_, _, _) - _,
 		CallGoal = Goal,
 		MaybeNegGoals = no
 	;
@@ -976,8 +963,8 @@
 		{ DBCall = db_call(called_pred(PredProcId), MaybeNegGoals, 
 				InputArgs, OutputArgs, GoalInfo) }
 	;
-		{ CallGoal = higher_order_call(Var, Args, _,
-			ArgModes, _, predicate) - GoalInfo }
+		{ CallGoal = generic_call(higher_order(Var, predicate, _),
+			Args, ArgModes, _) - GoalInfo }
 	->
 		{ CallId = ho_called_var(Var) },
 		rl_info_get_module_info(ModuleInfo),
@@ -1012,8 +999,8 @@
 		% Only closure constructions can come 
 		% between two Aditi calls.
 		Goal = unify(_, _, _, Uni, _) - _,
-		Uni = construct(_, ConsId, _, _),
-		ConsId = pred_const(_, _)
+		Uni = construct(_, ConsId, _, _, _, _, _),
+		ConsId = pred_const(_, _, _)
 	->
 		rl_gen__find_aditi_call(ModuleInfo, Goals,
 			[Goal | RevBetweenGoals0], BetweenGoals, 
@@ -1033,8 +1020,8 @@
 rl_gen__setup_var_rels([BetweenGoal | BetweenGoals]) -->
 	( 
 		{ BetweenGoal = unify(_, _, _, Uni, _) - _ },
-		{ Uni = construct(Var, ConsId, CurriedArgs, _) },
-		{ ConsId = pred_const(PredId, ProcId) }
+		{ Uni = construct(Var, ConsId, CurriedArgs, _, _, _, _) },
+		{ ConsId = pred_const(PredId, ProcId, _EvalMethod) }
 	->
 		{ Closure = closure_pred(CurriedArgs, 
 			proc(PredId, ProcId)) },
@@ -1721,8 +1708,13 @@
 		OutputRelation, Code) -->
 	rl_info_get_var_type(ComputeInitial, ComputeInitialType),
 	(
+		% XXX The type declaration in extras/aditi/aditi.m
+		% should be changed to require that the eval_method
+		% for the UpdateAcc and ComputeInitial parameters
+		% is `aditi_top_down', and the InputRelationArg
+		% is `aditi_bottom_up'.
 		{ type_is_higher_order(ComputeInitialType, 
-			predicate, ComputeInitialArgTypes) },
+			predicate, _, ComputeInitialArgTypes) },
 		{ ComputeInitialArgTypes = [GrpByType, _NGrpByType, AccType] }
 	->
 		%
Index: compiler/rl_key.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/rl_key.m,v
retrieving revision 1.1
diff -u -u -r1.1 rl_key.m
--- rl_key.m	1998/12/06 23:45:23	1.1
+++ rl_key.m	1998/12/11 04:03:08
@@ -688,7 +688,7 @@
 	rl_key__unify_var_var(Var1, Var2).
 rl_key__extract_key_range_unify(assign(Var1, Var2)) -->
 	rl_key__unify_var_var(Var1, Var2).
-rl_key__extract_key_range_unify(construct(Var, ConsId, Args, _)) -->
+rl_key__extract_key_range_unify(construct(Var, ConsId, Args, _, _, _, _)) -->
 	rl_key__unify_functor(Var, ConsId, Args).
 rl_key__extract_key_range_unify(
 		deconstruct(Var, ConsId, Args, _, _)) -->
Index: compiler/rl_out.pp
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/rl_out.pp,v
retrieving revision 1.3
diff -u -u -r1.3 rl_out.pp
--- rl_out.pp	1999/05/11 05:03:59	1.3
+++ rl_out.pp	1999/05/21 04:35:07
@@ -98,35 +98,17 @@
 		{ Module = PredModule },
 		{ check_marker(Markers, base_relation) }
 	->
-		{ rl_out__get_perm_rel_info(ModuleInfo, PredId,
+		{ rl__get_permanent_relation_info(ModuleInfo, PredId,
 			Owner, ModuleName, PredName, PredArity0,
 			RelName, RelSchema) },
 		{ string__int_to_string(PredArity0, PredArity) },
 		io__write_strings([ModuleName, ":", PredName, "/", PredArity,
 			"\t", Owner, "/", ModuleName, "/", RelName,
 			"\t", RelSchema, "\n"])
-	;	
+	;
 		[]
 	).
 
-:- pred rl_out__get_perm_rel_info(module_info::in, pred_id::in,
-		string::out, string::out, string::out, int::out,
-		string::out, string::out) is det.
-
-rl_out__get_perm_rel_info(ModuleInfo, PredId, Owner, PredModule,
-		PredName, PredArity, RelName, SchemaString) :-
-	module_info_pred_info(ModuleInfo, PredId, PredInfo),
-	pred_info_name(PredInfo, PredName),
-	pred_info_module(PredInfo, PredModule0),
-	prog_out__sym_name_to_string(PredModule0, PredModule),
-	pred_info_get_aditi_owner(PredInfo, Owner),
-	pred_info_arity(PredInfo, PredArity),
-	string__format("%s__%i", [s(PredName), i(PredArity)], RelName),
-	pred_info_arg_types(PredInfo, ArgTypes0),
-	magic_util__remove_aditi_state(ArgTypes0, ArgTypes0, ArgTypes),
-	rl__schema_to_string(ModuleInfo, ArgTypes, SchemaString).
-
-
 %-----------------------------------------------------------------------------%
 
 	% If the RL procedure is callable from the query shell or Mercury,
@@ -370,7 +352,7 @@
 		% If one memoed relation is dropped, all must be 
 		% dropped for correctness. We could possibly be a
 		% little smarter about this.
-		rl_out__collect_memoed_rels(Owner, Name, MemoedList, 0,
+		rl_out__collect_memoed_relations(Owner, Name, MemoedList, 0,
 			CollectCode, NameCode),
 		rl_out__get_rel_var_list(MemoedList, RelVarCodes),
 		{ GroupCode = tree(node([rl_PROC_grouprels]), RelVarCodes) }
@@ -378,7 +360,7 @@
 
 	rl_out_info_get_relation_addrs(Addrs),
 	{ map__to_assoc_list(Addrs, AddrsAL) },
-	rl_out__collect_permanent_rels(AddrsAL, [], PermRelCodes),
+	rl_out__collect_permanent_relations(AddrsAL, [], PermRelCodes),
 
 	rl_out_info_get_proc_expressions(Exprns),
 	{ list__length(Exprns, NumExprns) },
@@ -423,14 +405,13 @@
 	% to maintain correctness. Aditi should prefer to drop unnamed 
 	% temporaries to named ones, since unnamed temporaries cannot
 	% possibly be used later.
-	% XXX Reference counting is not yet implemented in Aditi.
-:- pred rl_out__collect_memoed_rels(string::in, rl_proc_name::in,
+:- pred rl_out__collect_memoed_relations(string::in, rl_proc_name::in,
 		list(relation_id)::in, int::in, list(bytecode)::out,
 		list(bytecode)::out, rl_out_info::in,
 		rl_out_info::out) is det.
 
-rl_out__collect_memoed_rels(_, _, [], _, [], []) --> [].
-rl_out__collect_memoed_rels(Owner, ProcName, [Rel | Rels], Counter0,
+rl_out__collect_memoed_relations(_, _, [], _, [], []) --> [].
+rl_out__collect_memoed_relations(Owner, ProcName, [Rel | Rels], Counter0,
 		[GetCode | GetCodes], [NameCode, DropCode | NameCodes]) -->
 
 	rl_out_info_get_relation_addr(Rel, Addr),
@@ -472,17 +453,18 @@
 	{ DropCode = rl_PROC_unsetrel(Addr) },
 
 	{ Counter is Counter0 + 1 },
-	rl_out__collect_memoed_rels(Owner, ProcName, Rels, Counter,
+	rl_out__collect_memoed_relations(Owner, ProcName, Rels, Counter,
 		GetCodes, NameCodes).
 
 	% Put pointers to all the permanent relations
 	% used by the procedure into variables.
-:- pred rl_out__collect_permanent_rels(assoc_list(relation_id, int)::in,
+:- pred rl_out__collect_permanent_relations(assoc_list(relation_id, int)::in,
 		list(bytecode)::in, list(bytecode)::out,
 		rl_out_info::in, rl_out_info::out) is det.
 
-rl_out__collect_permanent_rels([], Codes, Codes) --> [].
-rl_out__collect_permanent_rels([RelationId - Addr | Rels], Codes0, Codes) -->
+rl_out__collect_permanent_relations([], Codes, Codes) --> [].
+rl_out__collect_permanent_relations([RelationId - Addr | Rels],
+		Codes0, Codes) -->
 	rl_out_info_get_relations(Relations),
 	{ map__lookup(Relations, RelationId, RelInfo) },
 	{ RelInfo = relation_info(RelType, _Schema, _Index, _) },
@@ -491,7 +473,7 @@
 	->
 		rl_out_info_get_module_info(ModuleInfo),
 
-		{ rl_out__get_perm_rel_info(ModuleInfo, PredId,
+		{ rl__get_permanent_relation_info(ModuleInfo, PredId,
 			Owner, PredModule, _, _, RelName, SchemaString) },
 
 		rl_out_info_assign_const(string(Owner), OwnerConst), 
@@ -515,7 +497,7 @@
 	;
 		{ Codes1 = Codes0 }
 	),
-	rl_out__collect_permanent_rels(Rels, Codes1, Codes).
+	rl_out__collect_permanent_relations(Rels, Codes1, Codes).
 
 %-----------------------------------------------------------------------------%
 
@@ -684,7 +666,7 @@
 
 	% If the produced tuple is independent of the input tuple,
 	% generate:
-	% if (empty(Input) {
+	% if (empty(Input)) {
 	% 	init(Output);
 	% } else
 	% 	init(Output);
@@ -755,7 +737,7 @@
 		    OtherOutputInitCodeList, empty, OtherOutputInitCode) },
 
 		{ list__map(rl__output_rel_relation,
-			OtherOutputRels, OtherOutputRelations ) },
+			OtherOutputRels, OtherOutputRelations) },
 		rl_out__get_rel_var_list(OtherOutputRelations, VarListCode),
 		list__foldl2(rl_out__generate_project_exprn, OtherOutputs,
 			empty, ExprnListCode),
Index: compiler/saved_vars.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/saved_vars.m,v
retrieving revision 1.18
diff -u -u -r1.18 saved_vars.m
--- saved_vars.m	1999/03/12 06:14:17	1.18
+++ saved_vars.m	1999/05/14 04:54:27
@@ -109,15 +109,11 @@
 		saved_vars_in_goal(Else0, SlotInfo2, Else, SlotInfo),
 		Goal = if_then_else(Vars, Cond, Then, Else, SM) - GoalInfo0
 	;
-		GoalExpr0 = some(Var, SubGoal0),
+		GoalExpr0 = some(Var, CanRemove, SubGoal0),
 		saved_vars_in_goal(SubGoal0, SlotInfo0, SubGoal, SlotInfo),
-		Goal = some(Var, SubGoal) - GoalInfo0
+		Goal = some(Var, CanRemove, SubGoal) - GoalInfo0
 	;
-		GoalExpr0 = higher_order_call(_, _, _, _, _, _),
-		Goal = GoalExpr0 - GoalInfo0,
-		SlotInfo = SlotInfo0
-	;
-		GoalExpr0 = class_method_call(_, _, _, _, _, _),
+		GoalExpr0 = generic_call(_, _, _, _),
 		Goal = GoalExpr0 - GoalInfo0,
 		SlotInfo = SlotInfo0
 	;
@@ -156,7 +152,7 @@
 		Goals, SlotInfo) :-
 	(
 		Goal0 = unify(_, _, _, Unif, _) - _,
-		Unif = construct(Var, _, [], _),
+		Unif = construct(Var, _, [], _, _, _, _),
 		skip_constant_constructs(Goals0, Constants, Others),
 		Others = [First | _Rest],
 		can_push(Var, First)
@@ -185,7 +181,7 @@
 skip_constant_constructs([Goal0 | Goals0], Constants, Others) :-
 	(
 		Goal0 = unify(_, _, _, Unif, _) - _,
-		Unif = construct(_, _, [], _)
+		Unif = construct(_, _, [], _, _, _, _)
 	->
 		skip_constant_constructs(Goals0, Constants1, Others),
 		Constants = [Goal0 | Constants1]
@@ -210,7 +206,7 @@
 		(
 			FirstExpr = conj(_)
 		;
-			FirstExpr = some(_, _)
+			FirstExpr = some(_, _, _)
 		;
 			FirstExpr = not(_)
 		;
@@ -276,16 +272,7 @@
 				IsNonLocal, SlotInfo1, Goals1, SlotInfo),
 			Goals = [NewConstruct, Goal1 | Goals1]
 		;
-			Goal0Expr = higher_order_call(_, _, _, _, _, _),
-			rename_var(SlotInfo0, Var, _NewVar, Subst, SlotInfo1),
-			goal_util__rename_vars_in_goal(Construct, Subst,
-				NewConstruct),
-			goal_util__rename_vars_in_goal(Goal0, Subst, Goal1),
-			saved_vars_delay_goal(Goals0, Construct, Var,
-				IsNonLocal, SlotInfo1, Goals1, SlotInfo),
-			Goals = [NewConstruct, Goal1 | Goals1]
-		;
-			Goal0Expr = class_method_call(_, _, _, _, _, _),
+			Goal0Expr = generic_call(_, _, _, _),
 			rename_var(SlotInfo0, Var, _NewVar, Subst, SlotInfo1),
 			goal_util__rename_vars_in_goal(Construct, Subst,
 				NewConstruct),
@@ -313,7 +300,7 @@
 				IsNonLocal, SlotInfo0, Goals1, SlotInfo),
 			Goals = [Goal0|Goals1]
 		;
-			Goal0Expr = some(SomeVars, SomeGoal0),
+			Goal0Expr = some(SomeVars, CanRemove, SomeGoal0),
 			rename_var(SlotInfo0, Var, NewVar, Subst, SlotInfo1),
 			goal_util__rename_vars_in_goal(Construct, Subst,
 				NewConstruct),
@@ -321,7 +308,8 @@
 				SomeGoal1),
 			push_into_goal(SomeGoal1, NewConstruct, NewVar,
 				SlotInfo1, SomeGoal, SlotInfo2),
-			Goal1 = some(SomeVars, SomeGoal) - Goal0Info,
+			Goal1 = some(SomeVars, CanRemove, SomeGoal)
+					- Goal0Info,
 			saved_vars_delay_goal(Goals0, Construct, Var,
 				IsNonLocal, SlotInfo2, Goals1, SlotInfo),
 			Goals = [Goal1 | Goals1]
Index: compiler/simplify.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/simplify.m,v
retrieving revision 1.66
diff -u -u -r1.66 simplify.m
--- simplify.m	1998/12/06 23:45:50	1.66
+++ simplify.m	1999/05/27 06:11:30
@@ -450,7 +450,7 @@
 			goal_info_set_determinism(GoalInfo0,
 				InnerDetism, InnerInfo),
 			InnerGoal = conj(Goals) - InnerInfo,
-			Goal = some([], InnerGoal)
+			Goal = some([], can_remove, InnerGoal)
 		;
 			Goal = conj(Goals)
 		),
@@ -577,13 +577,21 @@
 	).
 
 simplify__goal_2(Goal0, GoalInfo, Goal, GoalInfo, Info0, Info) :-
-	Goal0 = higher_order_call(Closure, Args, _, Modes, Det, _PredOrFunc),
-	( simplify_do_calls(Info0) ->
+	Goal0 = generic_call(GenericCall, Args, Modes, Det),
+	(
+		simplify_do_calls(Info0),
+		% XXX We should do duplicate call elimination for
+		% class method calls here.
+		GenericCall = higher_order(Closure, _, _)
+	->
 		common__optimise_higher_order_call(Closure, Args, Modes, Det,
 			Goal0, GoalInfo, Goal, Info0, Info)
-	; simplify_do_warn_calls(Info0) ->
-		% we need to do the pass, for the warnings, but we ignore
-		% the optimized goal and instead use the original one
+	;
+		simplify_do_warn_calls(Info0),
+		GenericCall = higher_order(Closure, _, _)
+	->
+		% We need to do the pass, for the warnings, but we ignore
+		% the optimized goal and instead use the original one.
 		common__optimise_higher_order_call(Closure, Args, Modes, Det,
 			Goal0, GoalInfo, _Goal1, Info0, Info),
 		Goal = Goal0
@@ -592,11 +600,6 @@
 		Info = Info0
 	).
 
-	% XXX We ought to do duplicate call elimination for class 
-	% XXX method calls here.
-simplify__goal_2(Goal, GoalInfo, Goal, GoalInfo, Info, Info) :-
-	Goal = class_method_call(_, _, _, _, _, _).
-
 simplify__goal_2(Goal0, GoalInfo0, Goal, GoalInfo, Info0, Info) :-
 	Goal0 = call(PredId, ProcId, Args, IsBuiltin, _, _),
 	simplify_info_get_module_info(Info0, ModuleInfo),
@@ -749,8 +752,8 @@
 		true_goal(Context, Goal - GoalInfo),
 		Info = Info0
 	;
-		RT0 = lambda_goal(PredOrFunc, NonLocals, Vars, 
-			Modes, LambdaDeclaredDet, LambdaGoal0)
+		RT0 = lambda_goal(PredOrFunc, EvalMethod, FixModes,
+			NonLocals, Vars, Modes, LambdaDeclaredDet, LambdaGoal0)
 	->
 		simplify_info_enter_lambda(Info0, Info1),
 		simplify_info_get_common_info(Info1, Common1),
@@ -770,8 +773,8 @@
 		simplify__goal(LambdaGoal0, LambdaGoal, Info3, Info4),
 		simplify_info_set_common_info(Info4, Common1, Info5),
 		simplify_info_set_instmap(Info5, InstMap1, Info6),
-		RT = lambda_goal(PredOrFunc, NonLocals, Vars, Modes, 
-			LambdaDeclaredDet, LambdaGoal),
+		RT = lambda_goal(PredOrFunc, EvalMethod, FixModes, NonLocals,
+			Vars, Modes, LambdaDeclaredDet, LambdaGoal),
 		simplify_info_leave_lambda(Info6, Info),
 		Goal = unify(LT0, RT, M, U0, C),
 		GoalInfo = GoalInfo0
@@ -917,7 +920,7 @@
 				at_most_many),
 			goal_info_set_determinism(GoalInfo1, InnerDetism,
 				InnerInfo),
-			Goal = some([], IfThenElse - InnerInfo)
+			Goal = some([], can_remove, IfThenElse - InnerInfo)
 		;
 			Goal = IfThenElse
 		),
@@ -967,20 +970,23 @@
 		Info = Info3
 	).
 
-simplify__goal_2(some(Vars1, Goal1), SomeInfo, Goal, GoalInfo, Info0, Info) :-
+simplify__goal_2(some(Vars1, CanRemove0, Goal1), SomeInfo,
+		Goal, GoalInfo, Info0, Info) :-
 	simplify__goal(Goal1, Goal2, Info0, Info),
-	simplify__nested_somes(Vars1, Goal2, Vars, Goal3),
+	simplify__nested_somes(CanRemove0, Vars1, Goal2,
+		CanRemove, Vars, Goal3),
 	Goal3 = GoalExpr3 - GoalInfo3,
 	(
 		goal_info_get_determinism(GoalInfo3, Detism),
-		goal_info_get_determinism(SomeInfo, Detism)
+		goal_info_get_determinism(SomeInfo, Detism),
+		CanRemove = can_remove
 	->
 		% If the inner and outer detisms match the `some'
 		% is unnecessary.
 		Goal = GoalExpr3,
 		GoalInfo = GoalInfo3
 	;
-		Goal = some(Vars, Goal3),
+		Goal = some(Vars, CanRemove, Goal3),
 		GoalInfo = SomeInfo
 	).
 
@@ -1025,14 +1031,26 @@
 %-----------------------------------------------------------------------------%
 
 	% replace nested `some's with a single `some',
-:- pred simplify__nested_somes(list(prog_var)::in, hlds_goal::in,
-		list(prog_var)::out, hlds_goal::out) is det.
+:- pred simplify__nested_somes(can_remove::in, list(prog_var)::in,
+		hlds_goal::in, can_remove::out, list(prog_var)::out,
+		hlds_goal::out) is det.
 
-simplify__nested_somes(Vars0, Goal0, Vars, Goal) :-
-	( Goal0 = some(Vars1, Goal1) - _ ->
+simplify__nested_somes(CanRemove0, Vars0, Goal0, CanRemove, Vars, Goal) :-
+	( Goal0 = some(Vars1, CanRemove1, Goal1) - _ ->
+		(
+			( CanRemove0 = cannot_remove
+			; CanRemove1 = cannot_remove
+			)
+		->
+			CanRemove2 = cannot_remove
+		;
+			CanRemove2 = can_remove
+		),
 		list__append(Vars0, Vars1, Vars2),
-		simplify__nested_somes(Vars2, Goal1, Vars, Goal)
+		simplify__nested_somes(CanRemove2, Vars2, Goal1,
+			CanRemove, Vars, Goal)
 	;
+		CanRemove = CanRemove0,
 		Vars = Vars0,
 		Goal = Goal0
 	).
@@ -1061,7 +1079,7 @@
 		GoalInfo = InnerGoalInfo,
 		Info = Info0
 	;
-		Goal = some([], Goal1 - InnerGoalInfo),
+		Goal = some([], can_remove, Goal1 - InnerGoalInfo),
 		GoalInfo = OuterGoalInfo,
 		simplify_info_set_rerun_det(Info0, Info)
 	).
@@ -1769,8 +1787,7 @@
 			BeforeAfter = before,
 			Goal = GoalExpr - _,
 			GoalExpr \= call(_, _, _, _, _, _),
-			GoalExpr \= higher_order_call(_, _, _, _, _, _),
-			GoalExpr \= class_method_call(_, _, _, _, _, _),
+			GoalExpr \= generic_call(_, _, _, _),
 			GoalExpr \= pragma_c_code(_, _, _, _, _, _, _)
 		)
 	->
Index: compiler/store_alloc.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/store_alloc.m,v
retrieving revision 1.68
diff -u -u -r1.68 store_alloc.m
--- store_alloc.m	1998/11/20 04:09:10	1.68
+++ store_alloc.m	1999/05/14 07:28:54
@@ -58,7 +58,8 @@
 		proc_info_goal(ProcInfo0, Goal0),
 
 		find_final_follow_vars(ProcInfo0, FollowVars0),
-		find_follow_vars_in_goal(Goal0, ModuleInfo,
+		proc_info_vartypes(ProcInfo0, VarTypes),
+		find_follow_vars_in_goal(Goal0, VarTypes, ModuleInfo,
 			FollowVars0, Goal1, FollowVars),
 		Goal1 = GoalExpr1 - GoalInfo1,
 		goal_info_set_follow_vars(GoalInfo1, yes(FollowVars),
@@ -187,16 +188,14 @@
 	store_alloc_in_goal(Else0, Liveness0, ResumeVars0, ModuleInfo,
 		StackSlotInfo, Else, _Liveness2).
 
-store_alloc_in_goal_2(some(Vars, Goal0), Liveness0, ResumeVars0, ModuleInfo,
-		StackSlotInfo, some(Vars, Goal), Liveness) :-
+store_alloc_in_goal_2(some(Vars, CanRemove, Goal0), Liveness0, ResumeVars0,
+		ModuleInfo,
+		StackSlotInfo, some(Vars, CanRemove, Goal), Liveness) :-
 	store_alloc_in_goal(Goal0, Liveness0, ResumeVars0, ModuleInfo,
 		StackSlotInfo, Goal, Liveness).
 
-store_alloc_in_goal_2(higher_order_call(A, B, C, D, E, F), Liveness, _, _,
-		_, higher_order_call(A, B, C, D, E, F), Liveness).
-
-store_alloc_in_goal_2(class_method_call(A, B, C, D, E, F), Liveness, _, _,
-		_, class_method_call(A, B, C, D, E, F), Liveness).
+store_alloc_in_goal_2(generic_call(A, B, C, D), Liveness, _, _,
+		_, generic_call(A, B, C, D), Liveness).
 
 store_alloc_in_goal_2(call(A, B, C, D, E, F), Liveness, _, _,
 		_, call(A, B, C, D, E, F), Liveness).
Index: compiler/stratify.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/stratify.m,v
retrieving revision 1.19
diff -u -u -r1.19 stratify.m
--- stratify.m	1998/11/20 04:09:14	1.19
+++ stratify.m	1999/05/27 06:12:25
@@ -51,6 +51,7 @@
 :- import_module prog_out, globals, options.
 
 :- import_module assoc_list, map, list, set, bool, std_util, relation, require.
+:- import_module string.
 
 stratify__check_stratification(Module0, Module) -->
 	{ module_info_ensure_dependency_info(Module0, Module1) },
@@ -169,7 +170,7 @@
 		Error, Module1, Module2),
 	first_order_check_goal(Else, EInfo, Negated, WholeScc, ThisPredProcId,
 		Error, Module2, Module).
-first_order_check_goal(some(_Vars, Goal - GoalInfo), _GoalInfo,
+first_order_check_goal(some(_Vars, _, Goal - GoalInfo), _GoalInfo,
 		Negated, WholeScc, ThisPredProcId, Error, Module0, Module) -->
 	first_order_check_goal(Goal, GoalInfo, Negated, WholeScc, 
 		ThisPredProcId, Error, Module0, Module).
@@ -208,12 +209,9 @@
 	;
 		{ Module = Module0 }
 	).
-first_order_check_goal(higher_order_call(_Var, _Vars, _Types, _Modes, 
-	_Det, _PredOrFunc), _GInfo, _Negated, _WholeScc, _ThisPredProcId, 
+first_order_check_goal(generic_call(_Var, _Vars, _Modes, _Det),
+	_GInfo, _Negated, _WholeScc, _ThisPredProcId, 
 	_Error,  Module, Module) --> []. 
-first_order_check_goal(class_method_call(_Var, _Num, _Vars, _Types, _Modes, 
-	_Det), _GInfo, _Negated, _WholeScc, _ThisPredProcId, _Error,  
-	Module, Module) --> [].
 
 :- pred first_order_check_goal_list(list(hlds_goal), bool, 
 	list(pred_proc_id), pred_proc_id, bool, module_info, 
@@ -324,7 +322,7 @@
 		HighOrderLoops, Error, Module1, Module2),
 	higher_order_check_goal(Else, EInfo, Negated, WholeScc, ThisPredProcId,
 		HighOrderLoops, Error, Module2, Module).
-higher_order_check_goal(some(_Vars, Goal - GoalInfo), _GoalInfo, Negated, 
+higher_order_check_goal(some(_Vars, _, Goal - GoalInfo), _GoalInfo, Negated, 
 		WholeScc, ThisPredProcId, HighOrderLoops, 
 		Error, Module0, Module) -->
 	higher_order_check_goal(Goal, GoalInfo, Negated, WholeScc, 
@@ -360,37 +358,26 @@
 		{ Module = Module0 }
 	).
 	
-higher_order_check_goal(higher_order_call(_Var, _Vars, _Types, _Modes, _Det,
-			_PredOrFunc), 
+higher_order_check_goal(generic_call(GenericCall, _Vars, _Modes, _Det), 
 		GoalInfo, Negated, _WholeScc, ThisPredProcId, HighOrderLoops, 
 		Error, Module0, Module) -->
 	(
 		{ Negated = yes },
-		{ HighOrderLoops = yes }
+		{ HighOrderLoops = yes },
+		{ GenericCall = higher_order(_, _, _), Msg = "higher order"
+		; GenericCall = class_method(_, _, _, _), Msg = "class method"
+		}
 	->
 		{ goal_info_get_context(GoalInfo, Context) },
-		emit_message(ThisPredProcId, Context, 
-			"higher order call may introduce a non-stratified loop",
+		{ string__append(Msg, 
+			" call may introduce a non-stratified loop",
+			ErrorMsg) },
+		emit_message(ThisPredProcId, Context, ErrorMsg,
 			Error, Module0, Module)		
 	;
 		{ Module = Module0 }
 	).
 
-higher_order_check_goal(class_method_call(_Var, _Num, _Vars, _Types, _Modes,
-		_Det), GoalInfo, Negated, _WholeScc, ThisPredProcId,
-		HighOrderLoops, Error, Module0, Module) -->
-	(
-		{ Negated = yes },
-		{ HighOrderLoops = yes }
-	->
-		{ goal_info_get_context(GoalInfo, Context) },
-		emit_message(ThisPredProcId, Context, 
-			"class method call may introduce a non-stratified loop",
-			Error, Module0, Module)		
-	;
-		{ Module = Module0 }
-	).
-	
 :- pred higher_order_check_goal_list(list(hlds_goal), bool, set(pred_proc_id),
 	pred_proc_id, bool, bool, module_info, module_info, 
 	io__state, io__state).
@@ -722,7 +709,7 @@
 		% XXX : will have to use a more general check for higher
 		% order constants in parameters user could hide higher
 		% order consts in a data structure etc..
-		type_is_higher_order(Type, _, _)
+		type_is_higher_order(Type, _, _, _)
 	->	
 		(
 			mode_is_input(Module, Mode) 
@@ -767,8 +754,8 @@
 		% lambda goal have addresses taken. this is not
 		% always to case, but should be a suitable approximation for
 		% the stratification analysis
-		RHS = lambda_goal(_PredOrFunc, _NonLocals, _Vars, 
-				_Modes, _Determinism, Goal - _GoalInfo)
+		RHS = lambda_goal(_PredOrFunc, _EvalMethod, _Fix, _NonLocals,
+				_Vars, _Modes, _Determinism, Goal - _GoalInfo)
 	->
 		get_called_procs(Goal, [], CalledProcs),
 		set__insert_list(HasAT0, CalledProcs, HasAT)
@@ -777,11 +764,11 @@
 		% currently when this pass is run the construct/4
 		% case will not happen as higher order constants have
 		% been transformed to lambda goals. see above
-		Unification = construct(_Var2, ConsId, _VarList, _ModeList)
+		Unification = construct(_Var2, ConsId, _, _, _, _, _)
 	->
 		(
 			(
-				ConsId = pred_const(PredId, ProcId)
+				ConsId = pred_const(PredId, ProcId, _)
 			;
 				ConsId = code_addr_const(PredId, ProcId)
 			)
@@ -800,14 +787,9 @@
 	set__insert(Calls0, proc(CPred, CProc), Calls).
 
 	% record that the higher order call was made
-check_goal1(higher_order_call(_Var, _Vars, _Types, _Modes, _Det, _PredOrFUnc),
+check_goal1(generic_call(_Var, _Vars, _Modes, _Det),
 		Calls, Calls, HasAT, HasAT, _, yes).
 
-	% record that the higher order call was made. Well... a class method
-	% call is pretty similar to a higher order call...
-check_goal1(class_method_call(_Var, _Num, _Vars, _Types, _Modes, _Det), Calls,
-		Calls, HasAT, HasAT, _, yes).
-
 check_goal1(conj(Goals), Calls0, Calls, HasAT0, HasAT, CallsHO0, CallsHO) :-
 	check_goal_list(Goals, Calls0, Calls, HasAT0, HasAT, CallsHO0, CallsHO).
 check_goal1(par_conj(Goals, _), Calls0, Calls, HasAT0, HasAT,
@@ -825,7 +807,7 @@
 	check_goal1(Then, Calls1, Calls2, HasAT1, HasAT2, CallsHO1, CallsHO2),
 	check_goal1(Else, Calls2, Calls, HasAT2, HasAT, CallsHO2, CallsHO).
 	
-check_goal1(some(_Vars, Goal - _GoalInfo), Calls0, Calls, HasAT0, HasAT, 
+check_goal1(some(_Vars, _, Goal - _GoalInfo), Calls0, Calls, HasAT0, HasAT, 
 		CallsHO0, CallsHO) :- 
 	check_goal1(Goal, Calls0, Calls, HasAT0, HasAT, CallsHO0, CallsHO).
 
@@ -871,19 +853,19 @@
 		% lambda goal have addresses taken. this is not
 		% always to case, but should be a suitable approximation for
 		% the stratification analysis
-		RHS = lambda_goal(_PredOrFunc, _NonLocals, _Vars, 
-				_Modes, _Determinism, Goal - _GoalInfo)
+		RHS = lambda_goal(_PredOrFunc, _EvalMethod, _Fix, _NonLocals,
+				_Vars, _Modes, _Determinism, Goal - _GoalInfo)
 	->
 		get_called_procs(Goal, Calls0, Calls)
 	;
 		% currently when this pass is run the construct/4
 		% case will not happen as higher order constants have
 		% been transformed to lambda goals see above
-		Unification = construct(_Var2, ConsId, _VarList, _ModeList)
+		Unification = construct(_Var2, ConsId, _, _, _, _, _)
 	->
 		(
 			(
-				ConsId = pred_const(PredId, ProcId)
+				ConsId = pred_const(PredId, ProcId, _)
 			;
 				ConsId = code_addr_const(PredId, ProcId)
 			)
@@ -901,11 +883,7 @@
 		Calls) :- 
 	Calls = [proc(CPred, CProc) | Calls0].
 
-get_called_procs(higher_order_call(_Var, _Vars, _Types, _Modes, _Det,
-		_PredOrFunc), Calls, Calls).
-
-get_called_procs(class_method_call(_Var, _Num,_Vars, _Types, _Modes, _Det),
-	Calls, Calls).
+get_called_procs(generic_call(_Var, _Vars, _Modes, _Det), Calls, Calls).
 
 get_called_procs(conj(Goals), Calls0, Calls) :-
 	check_goal_list(Goals, Calls0, Calls).
@@ -920,7 +898,7 @@
 	get_called_procs(Cond, Calls0, Calls1),
 	get_called_procs(Then, Calls1, Calls2),
 	get_called_procs(Else, Calls2, Calls). 
-get_called_procs(some(_Vars, Goal - _GoalInfo), Calls0, Calls) :-
+get_called_procs(some(_Vars, _, Goal - _GoalInfo), Calls0, Calls) :-
 	get_called_procs(Goal, Calls0, Calls).
 get_called_procs(not(Goal - _GoalInfo), Calls0, Calls) :-
 	get_called_procs(Goal, Calls0, Calls).
Index: compiler/switch_detection.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/switch_detection.m,v
retrieving revision 1.85
diff -u -u -r1.85 switch_detection.m
--- switch_detection.m	1998/11/20 04:09:16	1.85
+++ switch_detection.m	1999/05/27 06:12:02
@@ -184,30 +184,30 @@
 	detect_switches_in_goal(Then0, InstMap1, VarTypes, ModuleInfo, Then),
 	detect_switches_in_goal(Else0, InstMap0, VarTypes, ModuleInfo, Else).
 
-detect_switches_in_goal_2(some(Vars, Goal0), _GoalInfo, InstMap0,
-		VarTypes, ModuleInfo, some(Vars, Goal)) :-
+detect_switches_in_goal_2(some(Vars, CanRemove, Goal0), _GoalInfo, InstMap0,
+		VarTypes, ModuleInfo, some(Vars, CanRemove, Goal)) :-
 	detect_switches_in_goal(Goal0, InstMap0, VarTypes, ModuleInfo, Goal).
 
-detect_switches_in_goal_2(higher_order_call(A,B,C,D,E,F), _, _, _, _,
-		higher_order_call(A,B,C,D,E,F)).
-
-detect_switches_in_goal_2(class_method_call(A,B,C,D,E,F), _, _, _, _,
-		class_method_call(A,B,C,D,E,F)).
+detect_switches_in_goal_2(generic_call(A,B,C,D), _, _, _, _,
+		generic_call(A,B,C,D)).
 
 detect_switches_in_goal_2(call(A,B,C,D,E,F), _, _, _, _,
 		call(A,B,C,D,E,F)).
 
 detect_switches_in_goal_2(unify(A,RHS0,C,D,E), __GoalInfo, InstMap0,
 		VarTypes, ModuleInfo, unify(A,RHS,C,D,E)) :-
-	( RHS0 = lambda_goal(PredOrFunc, NonLocals, Vars, Modes, Det, Goal0) ->
+	(
+		RHS0 = lambda_goal(PredOrFunc, EvalMethod, FixModes,
+			NonLocals, Vars, Modes, Det, Goal0)
+	->
 		% we need to insert the initial insts for the lambda
 		% variables in the instmap before processing the lambda goal
 		instmap__pre_lambda_update(ModuleInfo, 
 			Vars, Modes, InstMap0, InstMap1),
 		detect_switches_in_goal(Goal0, InstMap1, VarTypes, ModuleInfo,
 			Goal),
-		RHS = lambda_goal(PredOrFunc, NonLocals, 
-			Vars, Modes, Det, Goal)
+		RHS = lambda_goal(PredOrFunc, EvalMethod, FixModes,
+			NonLocals, Vars, Modes, Det, Goal)
 	;
 		RHS = RHS0
 	).
@@ -462,11 +462,11 @@
 
 find_bind_var(Var, ProcessUnify, Goal0 - GoalInfo, Goal, Substitution0,
 		Substitution, Result0, Result, Info0, Info, Continue) :-
-	( Goal0 = some(Vars, SubGoal0) ->
+	( Goal0 = some(Vars, CanRemove, SubGoal0) ->
 		find_bind_var(Var, ProcessUnify, SubGoal0, SubGoal,
 			Substitution0, Substitution, Result0, Result,
 			Info0, Info, Continue),
-		Goal = some(Vars, SubGoal) - GoalInfo
+		Goal = some(Vars, CanRemove, SubGoal) - GoalInfo
 	; Goal0 = conj(SubGoals0) ->
 		conj_find_bind_var(Var, ProcessUnify, SubGoals0, SubGoals,
 			Substitution0, Substitution, Result0, Result,
Index: compiler/switch_gen.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/switch_gen.m,v
retrieving revision 1.70
diff -u -u -r1.70 switch_gen.m
--- switch_gen.m	1999/04/22 01:04:13	1.70
+++ switch_gen.m	1999/04/23 00:12:57
@@ -209,7 +209,7 @@
 switch_gen__priority(float_constant(_), 3).
 switch_gen__priority(shared_remote_tag(_, _), 4).
 switch_gen__priority(string_constant(_), 5).
-switch_gen__priority(pred_closure_tag(_, _), 6).	% should never occur
+switch_gen__priority(pred_closure_tag(_, _, _), 6).	% should never occur
 switch_gen__priority(code_addr_constant(_, _), 6).	% should never occur
 switch_gen__priority(type_ctor_info_constant(_, _, _), 6).% should never occur
 switch_gen__priority(base_typeclass_info_constant(_, _, _), 6).% shouldn't occur
Index: compiler/table_gen.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/table_gen.m,v
retrieving revision 1.7
diff -u -u -r1.7 table_gen.m
--- table_gen.m	1999/04/20 11:47:50	1.7
+++ table_gen.m	1999/04/23 00:40:20
@@ -636,7 +636,8 @@
 	UnifyMode = (free -> VarInst) - (VarInst -> VarInst),
 	UnifyContext = unify_context(explicit, []),
 	GoalExpr = unify(PredTableVar, functor(ConsId, []), UnifyMode,
-			construct(PredTableVar, ConsId, [], []), UnifyContext),
+	    construct(PredTableVar, ConsId, [], [], no, cell_is_unique, no),
+	    UnifyContext),
 
 	set__singleton_set(NonLocals, PredTableVar),
 	instmap_delta_from_assoc_list([PredTableVar - VarInst],
@@ -1173,7 +1174,8 @@
 	Inst = bound(unique, [functor(int_const(VarValue), [])]),
 	VarUnify = unify(Var, functor(int_const(VarValue), []),
 		(free -> Inst) - (Inst -> Inst),
-		construct(Var, int_const(VarValue), [], []),
+		construct(Var, int_const(VarValue), [], [],
+			no, cell_is_unique, no),
 		unify_context(explicit, [])),
 	set__singleton_set(VarNonLocals, Var),
 	instmap_delta_from_assoc_list([Var - Inst],
@@ -1198,7 +1200,8 @@
 	Inst = bound(unique, [functor(string_const(VarValue), [])]),
 	VarUnify = unify(Var, functor(string_const(VarValue), []),
 		(free -> Inst) - (Inst -> Inst),
-		construct(Var, string_const(VarValue), [], []),
+		construct(Var, string_const(VarValue), [], [],
+			no, cell_is_unique, no),
 		unify_context(explicit, [])),
 	set__singleton_set(VarNonLocals, Var),
 	instmap_delta_from_assoc_list([Var - Inst],
Index: compiler/term_traversal.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/term_traversal.m,v
retrieving revision 1.8
diff -u -u -r1.8 term_traversal.m
--- term_traversal.m	1998/11/20 04:09:26	1.8
+++ term_traversal.m	1999/05/14 04:55:36
@@ -117,7 +117,7 @@
 traverse_goal_2(unify(_Var, _RHS, _UniMode, Unification, _Context),
 		_GoalInfo, Params, Info0, Info) :-
 	(
-		Unification = construct(OutVar, ConsId, Args, Modes),
+		Unification = construct(OutVar, ConsId, Args, Modes, _, _, _),
 		(
 			unify_change(OutVar, ConsId, Args, Modes, Params,
 				Gamma, InVars, OutVars0)
@@ -175,7 +175,7 @@
 		% but it shouldn't hurt either.
 	traverse_goal(Goal, Params, Info0, Info).
 
-traverse_goal_2(some(_Vars, Goal), _GoalInfo, Params, Info0, Info) :-
+traverse_goal_2(some(_Vars, _, Goal), _GoalInfo, Params, Info0, Info) :-
 	traverse_goal(Goal, Params, Info0, Info).
 
 traverse_goal_2(if_then_else(_, Cond, Then, Else, _), _, Params, Info0, Info) :-
@@ -193,17 +193,12 @@
 	goal_info_get_context(GoalInfo, Context),
 	error_if_intersect(OutVars, Context, pragma_c_code, Info0, Info).
 
-traverse_goal_2(higher_order_call(_, _, _, _, _, _),
-		GoalInfo, Params, Info0, Info) :-
-	goal_info_get_context(GoalInfo, Context),
-	add_error(Context, horder_call, Params, Info0, Info).
-
 	% For now, we'll pretend that the class method call is a higher order
 	% call. In reality, we could probably analyse further than this, since
 	% we know that the method being called must come from one of the
 	% instance declarations, and we could potentially (globally) analyse
 	% these.
-traverse_goal_2(class_method_call(_, _, _, _, _, _),
+traverse_goal_2(generic_call(_, _, _, _),
 		GoalInfo, Params, Info0, Info) :-
 	goal_info_get_context(GoalInfo, Context),
 	add_error(Context, horder_call, Params, Info0, Info).
@@ -433,7 +428,7 @@
 	params_get_functor_info(Params, FunctorInfo),
 	params_get_var_types(Params, VarTypes),
 	map__lookup(VarTypes, OutVar, Type),
-	\+ type_is_higher_order(Type, _, _),
+	\+ type_is_higher_order(Type, _, _, _),
 	( type_to_type_id(Type, TypeId, _) ->
 		params_get_module_info(Params, Module),
 		functor_norm(FunctorInfo, TypeId, ConsId, Module,
Index: compiler/term_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/term_util.m,v
retrieving revision 1.11
diff -u -u -r1.11 term_util.m
--- term_util.m	1998/11/20 04:09:27	1.11
+++ term_util.m	1998/12/08 01:15:20
@@ -523,7 +523,7 @@
 horder_vars([Arg | Args], VarType) :-
 	(
 		map__lookup(VarType, Arg, Type),
-		type_is_higher_order(Type, _, _)
+		type_is_higher_order(Type, _, _, _)
 	;
 		horder_vars(Args, VarType)
 	).
Index: compiler/type_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/type_util.m,v
retrieving revision 1.66
diff -u -u -r1.66 type_util.m
--- type_util.m	1999/05/31 09:22:50	1.66
+++ type_util.m	1999/06/01 00:15:24
@@ -35,18 +35,23 @@
 	% argument types (for functions, the return type is appended to the
 	% end of the argument types).
 
-:- pred type_is_higher_order(type, pred_or_func, list(type)).
-:- mode type_is_higher_order(in, out, out) is semidet.
+:- pred type_is_higher_order(type, pred_or_func,
+		lambda_eval_method, list(type)).
+:- mode type_is_higher_order(in, out, out, out) is semidet.
 
 	% type_id_is_higher_order(TypeId, PredOrFunc) succeeds iff
 	% TypeId is a higher-order predicate or function type.
 
-:- pred type_id_is_higher_order(type_id, pred_or_func).
-:- mode type_id_is_higher_order(in, out) is semidet.
+:- pred type_id_is_higher_order(type_id, pred_or_func, lambda_eval_method).
+:- mode type_id_is_higher_order(in, out, out) is semidet.
 
 :- pred type_is_aditi_state(type).
 :- mode type_is_aditi_state(in) is semidet.
 
+	% Remove an `aditi:state' from the given list if one is present.
+:- pred type_util__remove_aditi_state(list(type), list(T), list(T)).
+:- mode type_util__remove_aditi_state(in, in, out) is det.
+
 	% A test for types that are defined by hand (not including
 	% the builtin types).  Don't generate type_ctor_*
 	% for these types.
@@ -88,6 +93,18 @@
 :- pred construct_type(type_id, list(type), prog_context, (type)).
 :- mode construct_type(in, in, in, out) is det.
 
+:- pred construct_higher_order_type(pred_or_func, lambda_eval_method,
+		list(type), (type)).
+:- mode construct_higher_order_type(in, in, in, out) is det.
+
+:- pred construct_higher_order_pred_type(lambda_eval_method,
+		list(type), (type)).
+:- mode construct_higher_order_pred_type(in, in, out) is det.
+
+:- pred construct_higher_order_func_type(lambda_eval_method,
+		list(type), (type), (type)).
+:- mode construct_higher_order_func_type(in, in, in, out) is det.
+
 	% Construct builtin types.
 :- func int_type = (type).
 :- func string_type = (type).
@@ -251,7 +268,7 @@
 %-----------------------------------------------------------------------------%
 
 :- implementation.
-:- import_module bool, require, std_util.
+:- import_module bool, int, require, std_util.
 :- import_module prog_io, prog_io_goal, prog_util.
 
 type_util__type_id_module(_ModuleInfo, TypeName - _Arity, ModuleName) :-
@@ -295,7 +312,7 @@
 			Type = float_type
 		; TypeId = unqualified("string") - 0 ->
 			Type = str_type
-		; type_id_is_higher_order(TypeId, _) ->
+		; type_id_is_higher_order(TypeId, _, _) ->
 			Type = pred_type
 		; type_id_is_enumeration(TypeId, ModuleInfo) ->
 			Type = enum_type
@@ -306,28 +323,65 @@
 		Type = polymorphic_type
 	).
 
-type_is_higher_order(Type, PredOrFunc, PredArgTypes) :-
+type_is_higher_order(Type, PredOrFunc, EvalMethod, PredArgTypes) :-
 	(
-		Type = term__functor(term__atom("pred"),
-					PredArgTypes, _),
-		PredOrFunc = predicate
-	;
 		Type = term__functor(term__atom("="),
-				[term__functor(term__atom("func"),
-					FuncArgTypes, _),
-				 FuncRetType], _),
+			[FuncEvalAndArgs, FuncRetType], _)
+	->
+		get_lambda_eval_method(FuncEvalAndArgs, EvalMethod,
+			FuncAndArgs),
+		FuncAndArgs = term__functor(term__atom("func"),
+			FuncArgTypes, _),
 		list__append(FuncArgTypes, [FuncRetType], PredArgTypes),
 		PredOrFunc = function
+	;
+		get_lambda_eval_method(Type, EvalMethod, PredAndArgs),
+		PredAndArgs = term__functor(term__atom("pred"),
+					PredArgTypes, _),
+		PredOrFunc = predicate
+	).
+
+	% From the type of a lambda expression, work out how it should
+	% be evaluated.
+:- pred get_lambda_eval_method((type), lambda_eval_method, (type)) is det.
+:- mode get_lambda_eval_method(in, out, out) is det.
+
+get_lambda_eval_method(Type0, EvalMethod, Type) :-
+	( Type0 = term__functor(term__atom(MethodStr), [Type1], _) ->
+		( MethodStr = "aditi_bottom_up" ->
+			EvalMethod = (aditi_bottom_up),
+			Type = Type1
+		; MethodStr = "aditi_top_down" ->
+			EvalMethod = (aditi_top_down),
+			Type = Type1
+		;
+			EvalMethod = normal,
+			Type = Type0
+		)
+	;
+		EvalMethod = normal,
+		Type = Type0
 	).
 
-type_id_is_higher_order(SymName - Arity, PredOrFunc) :-
-	unqualify_name(SymName, TypeName),
-	( 
-		TypeName = "pred",
+type_id_is_higher_order(SymName - _Arity, PredOrFunc, EvalMethod) :-
+	(
+		SymName = qualified(unqualified(EvalMethodStr), PorFStr),
+		(
+			EvalMethodStr = "aditi_bottom_up",
+			EvalMethod = (aditi_bottom_up)
+		;
+			EvalMethodStr = "aditi_top_down",
+			EvalMethod = (aditi_top_down)
+		)
+	;
+		SymName = unqualified(PorFStr),
+		EvalMethod = normal
+	),
+	(
+		PorFStr = "pred",
 		PredOrFunc = predicate
-	; 
-		TypeName = "=",
-		Arity = 2,
+	;
+		PorFStr = "func",
 		PredOrFunc = function
 	).
 
@@ -335,6 +389,19 @@
         type_to_type_id(Type,
 		qualified(unqualified("aditi"), "state") - 0, []).
 
+type_util__remove_aditi_state([], [], []).
+type_util__remove_aditi_state([], [_|_], _) :-
+	error("type_util__remove_aditi_state").
+type_util__remove_aditi_state([_|_], [], _) :-
+	error("type_util__remove_aditi_state").
+type_util__remove_aditi_state([Type | Types], [Arg | Args0], Args) :-
+	( type_is_aditi_state(Type) ->
+		type_util__remove_aditi_state(Types, Args0, Args)
+	;
+		type_util__remove_aditi_state(Types, Args0, Args1),
+		Args = [Arg | Args1]
+	).
+
 :- pred type_id_is_enumeration(type_id, module_info).
 :- mode type_id_is_enumeration(in, in) is semidet.
 
@@ -346,7 +413,7 @@
 	IsEnum = yes.
 
 type_to_type_id(Type, SymName - Arity, Args) :-
-	sym_name_and_args(Type, SymName, Args1),
+	sym_name_and_args(Type, SymName0, Args1),
 
 	% `private_builtin:constraint' is introduced by polymorphism, and
 	% should only appear as the argument of a `typeclass:info/1' type.
@@ -360,12 +427,35 @@
 	% their arguments don't directly correspond to the
 	% arguments of the term.
 	(
-		type_is_higher_order(Type, _, PredArgTypes) 
+		type_is_higher_order(Type, PredOrFunc,
+			EvalMethod, PredArgTypes) 
 	->
 		Args = PredArgTypes,
-		list__length(Args1, Arity)	% functions have arity 2, 
-						% (they are =/2)
+		list__length(Args, Arity0),
+		(
+			PredOrFunc = predicate,
+			PorFStr = "pred",
+			Arity = Arity0
+		;
+			PredOrFunc = function,
+			PorFStr = "func",
+			Arity is Arity0 - 1
+		),
+		(
+			EvalMethod = (aditi_bottom_up),
+			SymName = qualified(unqualified("aditi_bottom_up"),
+					PorFStr)
+		;
+			EvalMethod = (aditi_top_down),
+			SymName = qualified(unqualified("aditi_top_down"),
+					PorFStr)
+			
+		;
+			EvalMethod = normal,
+			SymName = unqualified(PorFStr)
+		)
 	;
+		SymName = SymName0,
 		Args = Args1,
 		list__length(Args, Arity)
 	).
@@ -375,24 +465,47 @@
 	construct_type(TypeId, Args, Context, Type).
 
 construct_type(TypeId, Args, Context, Type) :-
+	( type_id_is_higher_order(TypeId, PredOrFunc, EvalMethod) ->
+		construct_higher_order_type(PredOrFunc, EvalMethod, Args, Type)
+	;
+		TypeId = SymName - _,
+		construct_qualified_term(SymName, Args, Context, Type)
+	).
+
+construct_higher_order_type(PredOrFunc, EvalMethod, ArgTypes, Type) :-
 	(
-		type_id_is_higher_order(TypeId, PredOrFunc)
-	->
-		(
-			PredOrFunc = predicate,
-			NewArgs = Args
-		;
-			PredOrFunc = function,
-			pred_args_to_func_args(Args, FuncArgTypes, FuncRetType),
-			NewArgs = [term__functor(term__atom("func"),
-						FuncArgTypes, Context),
-					 FuncRetType]
-		)
+		PredOrFunc = predicate,
+		construct_higher_order_pred_type(EvalMethod, ArgTypes, Type)
 	;
-		NewArgs = Args
-	),
-	TypeId = SymName - _,
-	construct_qualified_term(SymName, NewArgs, Context, Type).
+		PredOrFunc = function,
+		pred_args_to_func_args(ArgTypes, FuncArgTypes, FuncRetType),
+		construct_higher_order_func_type(EvalMethod, FuncArgTypes,
+			FuncRetType, Type)
+	).
+
+construct_higher_order_pred_type(EvalMethod, ArgTypes, Type) :-
+	term__context_init(Context),
+	construct_qualified_term(unqualified("pred"),
+		ArgTypes, Context, Type0),
+	qualify_higher_order_type(EvalMethod, Type0, Type).
+
+construct_higher_order_func_type(EvalMethod, ArgTypes, RetType, Type) :-
+	term__context_init(Context),
+	construct_qualified_term(unqualified("func"),
+		ArgTypes, Context, Type0),
+	qualify_higher_order_type(EvalMethod, Type0, Type1),
+	Type = term__functor(term__atom("="), [Type1, RetType], Context).
+
+:- pred qualify_higher_order_type(lambda_eval_method, (type), (type)).
+:- mode qualify_higher_order_type(in, in, out) is det.
+
+qualify_higher_order_type(normal, Type, Type).
+qualify_higher_order_type((aditi_top_down), Type0,
+	    term__functor(term__atom("aditi_top_down"), [Type0], Context)) :- 
+	term__context_init(Context).
+qualify_higher_order_type((aditi_bottom_up), Type0,
+	    term__functor(term__atom("aditi_bottom_up"), [Type0], Context)) :-
+	term__context_init(Context).
 
 int_type = Type :- construct_type(unqualified("int") - 0, [], Type).
 string_type = Type :- construct_type(unqualified("string") - 0, [], Type).
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------