[m-rev.] for review: implement arg_cc in Mercury

[Peter Ross]

Hi,

For fjh to review.  I also need to code up something similar to make
limited_deconstruct_idcc work, but I want to have this reviewed first before
continuing further.

===================================================================


Estimated hours taken: 4
Branches: main

Implement arg_cc in Mercury using rtti_implementation.

library/deconstruct.m:
	Implement univ_arg_idcc as a cc_multi predicate with the
	success of the predicate encoded into a maybe type, as it is
	impossible to implement is as cc_nondet.
	Change the C code version of univ_arg_idcc to match the
	Mercury versions behaviour.
	Delete the bogus modes of arg/4 and implement them as arg_cc/3
	instead.

library/std_util.m:
	Introduce a new type maybe_arg which is returned by arg_cc to
	return its result.
	Change arg_cc to have the correct determinism and type
	signature.
	Add utility predicates which allow us to construct values of
	the maybe type from a foreign language.

runtime/mercury_ml_arg_body.h:
	In the MR_NONCANON case this code is used inside a cc_multi
	predicate, so setting the SUCCESS_INDICATOR should be
	disabled.

tests/hard_coded/deconstruct_arg.m:
	Update the test case to test this new functionality.

Index: library/deconstruct.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/deconstruct.m,v
retrieving revision 1.15
diff -u -r1.15 deconstruct.m
--- library/deconstruct.m	30 Nov 2002 08:03:33 -0000	1.15
+++ library/deconstruct.m	30 Nov 2002 15:14:57 -0000
@@ -118,8 +118,12 @@
 :- some [ArgT] pred arg(T, noncanon_handling, int, ArgT).
 :- mode arg(in, in(do_not_allow), in, out) is semidet.
 :- mode arg(in, in(canonicalize), in, out) is semidet.
-:- mode arg(in, in(include_details_cc), in, out) is cc_nondet.
-:- mode arg(in, in, in, out) is cc_nondet.
+:- mode arg(in, in(include_details_cc), in, out) is erroneous.
+:- mode arg(in, in, in, out) is semidet.
+
+	% See the documentation of std_util__arg_cc
+:- pred arg_cc(T, int, std_util__maybe_arg).
+:- mode arg_cc(in, in, out) is cc_multi.
 
 	% named_arg(Data, NonCanon, Name, Argument)
 	%
@@ -225,6 +229,7 @@
 :- implementation.
 
 :- import_module int, require, rtti_implementation.
+:- pragma foreign_import_module("C", std_util).
 
 %-----------------------------------------------------------------------------%
 
@@ -271,10 +276,18 @@
 		univ_arg_can(Term, Index, Univ)
 	;
 		NonCanon = include_details_cc,
-		univ_arg_idcc(Term, Index, Univ)
+		error("deconstruct__arg called with include_details_cc")
 	),
 	Argument = univ_value(Univ).
 
+arg_cc(Term, Index, MaybeArg) :-
+	univ_arg_idcc(Term, Index, MaybeUniv),
+	( MaybeUniv = yes(Univ),
+		MaybeArg = 'new arg'(univ_value(Univ))
+	; MaybeUniv = no,
+		MaybeArg = std_util__no
+	).
+
 named_arg(Term, NonCanon, Name, Argument) :-
 	(
 		NonCanon = do_not_allow,
@@ -298,7 +311,7 @@
 			univ_arg_can(Term, Index, Univ)
 		;
 			NonCanon = include_details_cc,
-			univ_arg_idcc(Term, Index, Univ)
+			error("deconstruct__arg called with include_details_cc")
 		)
 	->
 		Argument = univ_value(Univ)
@@ -426,7 +439,7 @@
 
 :- pred univ_arg_dna(T::in, int::in, univ::out) is semidet.
 :- pred univ_arg_can(T::in, int::in, univ::out) is semidet.
-:- pred univ_arg_idcc(T::in, int::in, univ::out) is cc_nondet.
+:- pred univ_arg_idcc(T::in, int::in, maybe(univ)::out) is cc_multi.
 
 :- pred univ_named_arg_dna(T::in, string::in, univ::out) is semidet.
 :- pred univ_named_arg_can(T::in, string::in, univ::out) is semidet.
@@ -471,22 +484,30 @@
 }").
 
 :- pragma foreign_proc("C",
-	univ_arg_idcc(Term::in, Index::in, Argument::out),
+	univ_arg_idcc(Term::in, Index::in, MaybeArg::out),
 	[will_not_call_mercury, thread_safe, promise_pure],
 "{
-#define	TYPEINFO_ARG		TypeInfo_for_T
-#define	TERM_ARG		Term
-#define	SELECTOR_ARG		Index
-#define	SELECTED_ARG		Argument
-#define	SELECTED_TYPE_INFO	TypeInfo_for_ArgT
-#define	NONCANON		MR_NONCANON_CC
-#include ""mercury_ml_arg_body.h""
-#undef	TYPEINFO_ARG
-#undef	TERM_ARG
-#undef	SELECTOR_ARG
-#undef	SELECTED_ARG
-#undef	SELECTED_TYPE_INFO
-#undef	NONCANON
+	MR_Word Argument;
+
+	#define	TYPEINFO_ARG		TypeInfo_for_T
+	#define	TERM_ARG		Term
+	#define	SELECTOR_ARG		Index
+	#define	SELECTED_ARG		Argument
+	#define	SELECTED_TYPE_INFO	TypeInfo_for_ArgT
+	#define	NONCANON		MR_NONCANON_CC
+	#include ""mercury_ml_arg_body.h""
+	#undef	TYPEINFO_ARG
+	#undef	TERM_ARG
+	#undef	SELECTOR_ARG
+	#undef	SELECTED_ARG
+	#undef	SELECTED_TYPE_INFO
+	#undef	NONCANON
+
+	if (success) {
+		MaybeArg = ML_construct_maybe_yes((MR_Word) NULL, Argument);
+	} else {
+		MaybeArg = ML_construct_maybe_no((MR_Word) NULL);
+	}
 }").
 
 :- pragma foreign_proc("C",
@@ -560,10 +581,14 @@
 	rtti_implementation__deconstruct(Term,
 			canonicalize, _Functor, _Arity, Arguments),
 	list__index0(Arguments, Index, Arg).
-univ_arg_idcc(_Term::in, _Index::in, _Arg::out) :-
-	% This version is only used for back-ends for which there is no
-	% matching foreign_proc version.
-	private_builtin__sorry("univ_arg_idcc/3").
+univ_arg_idcc(Term::in, Index::in, MaybeArg::out) :-
+	rtti_implementation__deconstruct(Term,
+			include_details_cc, _Functor, _Arity, Arguments),
+	( list__index0(Arguments, Index, Arg) ->
+		MaybeArg = yes(Arg)
+	;
+		MaybeArg = no
+	).
 
 univ_named_arg_dna(_Term::in, _Name::in, _Arg::out) :-
 	% This version is only used for back-ends for which there is no
Index: library/std_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/std_util.m,v
retrieving revision 1.273
diff -u -r1.273 std_util.m
--- library/std_util.m	8 Nov 2002 00:44:25 -0000	1.273
+++ library/std_util.m	30 Nov 2002 15:14:59 -0000
@@ -563,6 +563,10 @@
 
 %-----------------------------------------------------------------------------%
 
+:- type maybe_arg
+	--->	some[T] arg(T)
+	;	no.
+
 	% functor, argument and deconstruct and their variants take any type
 	% (including univ), and return representation information for that type.
 	%
@@ -630,7 +634,7 @@
 	% of a non-canonical type.
 	%
 :- func arg(T::in, int::in) = (ArgT::out) is semidet.
-:- pred arg_cc(T::in, int::in, ArgT::out) is cc_nondet.
+:- pred arg_cc(T::in, int::in, maybe_arg::out) is cc_multi.
 :- func argument(T::in, int::in) = (univ::out) is semidet.
 :- pred argument_cc(T::in, int::in, univ::out) is cc_nondet.
 
@@ -789,6 +793,16 @@
 		Y = no
 	).
 
+	% Utility predicates which are useful for constructing values
+	% of the maybe(T) type from foreign code.
+:- func construct_yes(T) = maybe(T).
+:- pragma export(construct_yes(in) = out, "ML_construct_maybe_yes").
+construct_yes(T) = yes(T).
+
+:- func construct_no = maybe(T).
+:- pragma export(construct_no = out, "ML_construct_maybe_no").
+construct_no = no.
+
 %-----------------------------------------------------------------------------%
 
 /*
@@ -1606,12 +1620,7 @@
 	private_builtin__typed_unify(Argument0, Argument).
 
 arg_cc(Term, Index, Argument) :-
-	deconstruct__arg(Term, include_details_cc, Index, Argument0),
-	( private_builtin__typed_unify(Argument0, Argument1) ->
-		Argument = Argument1
-	;
-		error("arg_cc: argument has wrong type")
-	).
+	deconstruct__arg_cc(Term, Index, Argument).
 
 argument(Term, Index) = ArgumentUniv :-
 	deconstruct__arg(Term, canonicalize, Index, Argument),
Index: runtime/mercury_ml_arg_body.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_ml_arg_body.h,v
retrieving revision 1.3
diff -u -r1.3 mercury_ml_arg_body.h
--- runtime/mercury_ml_arg_body.h	18 Feb 2002 07:01:18 -0000	1.3
+++ runtime/mercury_ml_arg_body.h	30 Nov 2002 15:15:00 -0000
@@ -70,6 +70,8 @@
         MR_new_univ_on_hp(SELECTED_ARG, arg_type_info, *argument_ptr);
     }
 
+#ifndef MR_NONCANON_CC
     SUCCESS_INDICATOR = success;
+#endif
 
 #undef  arg_func
Index: tests/hard_coded/deconstruct_arg.m
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/deconstruct_arg.m,v
retrieving revision 1.4
diff -u -r1.4 deconstruct_arg.m
--- tests/hard_coded/deconstruct_arg.m	29 Nov 2002 13:26:00 -0000	1.4
+++ tests/hard_coded/deconstruct_arg.m	30 Nov 2002 15:15:00 -0000
@@ -154,7 +154,8 @@
 	{ string__format("deconstruct argument %d of ", [i(ArgNum)], Str) },
 	io__write_string(Str),
 	io__print(T),
-	( { deconstruct__arg(T, include_details_cc, ArgNum, Arg) } ->
+	{ deconstruct__arg_cc(T, ArgNum, MaybeArg) },
+	( { MaybeArg = arg(Arg) } ->
 		io__write_string(" is "),
 		io__write(Arg),
 		io__write_string("\n")

--------------------------------------------------------------------------
mercury-reviews mailing list
post:  mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe:   Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------