[m-rev.] Extended the promise_<purity> scopes

[Ralph Becket]

Zoltan Somogyi, Tuesday, 26 April 2005:
> 
> Effectively, you have written a white box test, and I am asking for a
> black box test. A copy of an existing test for purity, with the
> annotations deleted, ought to do.

How about these?  impure_foreign2.m tests promise_impure_implicit
with genuinely impure goals; impure_foreign3.m tests
promise_impure_implicit as a DCG goal.

-- Ralph

Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.254
diff -u -r1.254 Mmakefile
--- tests/hard_coded/Mmakefile	14 Apr 2005 06:51:02 -0000	1.254
+++ tests/hard_coded/Mmakefile	26 Apr 2005 05:31:45 -0000
@@ -95,6 +95,8 @@
 	ho_univ_to_type \
 	impossible_unify \
 	impure_foreign \
+	impure_foreign2 \
+	impure_foreign3 \
 	impure_prune \
 	integer_test \
 	intermod_c_code \
@@ -173,6 +175,7 @@
 	test_bitset \
 	test_cord \
 	test_imported_no_tag \
+	test_promise_impure_implicit \
 	time_test \
 	tim_qual1 \
 	transform_value \
Index: tests/hard_coded/impure_foreign2.exp
===================================================================
RCS file: tests/hard_coded/impure_foreign2.exp
diff -N tests/hard_coded/impure_foreign2.exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/impure_foreign2.exp	26 Apr 2005 05:16:53 -0000
@@ -0,0 +1,2 @@
+1
+4
Index: tests/hard_coded/impure_foreign2.m
===================================================================
RCS file: tests/hard_coded/impure_foreign2.m
diff -N tests/hard_coded/impure_foreign2.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/impure_foreign2.m	26 Apr 2005 05:31:13 -0000
@@ -0,0 +1,73 @@
+% Test promise_impure_implicit with real impure goals.
+
+:- module impure_foreign2.
+
+:- interface.
+
+:- import_module io.
+
+:- impure pred main(io__state::di, io__state::uo) is det.
+
+:- implementation.
+
+:- import_module require.
+
+main(!IO) :-
+	promise_impure_implicit (
+			% Inlining this call forces recomputation
+			% of purity for main/2 (because of the
+			% `:- pragma promise_pure').
+			% In some versions of this compiler, this
+			% recomputation would erroneously infer
+			% that the inlined calls to incr/1 below
+			% were `pure'. Duplicate call elimination
+			% would then remove all but one of them.
+		unsafe_get(Val0),
+
+		io__write_int(Val0, !IO),
+		io__nl(!IO),
+
+		incr(_),
+		incr(_),
+		incr(_),
+		get(Val),
+		io__write_int(Val, !IO),
+		io__nl(!IO)
+	).
+
+:- pragma foreign_decl("C",
+"
+	int counter;
+").
+
+:- pragma foreign_code("C",
+"
+	int counter = 1;
+").
+
+:- pragma foreign_code("C#", "static int counter = 1;").
+
+:- impure pred incr(int::out) is det.
+
+incr(_::out) :- error("incr/1 called for language other than C").
+
+:- pragma foreign_proc("C", incr(Val::out), [will_not_call_mercury],
+			"counter++; Val = counter;").
+:- pragma foreign_proc("C#", incr(Val::out), [will_not_call_mercury],
+			"counter++; Val = counter;").
+
+:- semipure pred get(int::out) is det.
+
+get(_::out) :- error("get/1 called for language other than C").
+
+:- pragma foreign_proc("C", get(Val::out),
+		[will_not_call_mercury, promise_semipure],
+		"Val = counter").
+:- pragma foreign_proc("C#", get(Val::out),
+		[will_not_call_mercury, promise_semipure],
+		"Val = counter;").
+	
+:- pred unsafe_get(int::out) is det.
+:- pragma promise_pure(unsafe_get/1).
+
+unsafe_get(X) :- semipure get(X).
Index: tests/hard_coded/impure_foreign3.exp
===================================================================
RCS file: tests/hard_coded/impure_foreign3.exp
diff -N tests/hard_coded/impure_foreign3.exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/impure_foreign3.exp	26 Apr 2005 05:31:27 -0000
@@ -0,0 +1,2 @@
+1
+4
Index: tests/hard_coded/impure_foreign3.m
===================================================================
RCS file: tests/hard_coded/impure_foreign3.m
diff -N tests/hard_coded/impure_foreign3.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/impure_foreign3.m	26 Apr 2005 05:30:56 -0000
@@ -0,0 +1,73 @@
+% Test promise_impure_implicit in DCGs.
+
+:- module impure_foreign3.
+
+:- interface.
+
+:- import_module io.
+
+:- impure pred main(io__state::di, io__state::uo) is det.
+
+:- implementation.
+
+:- import_module require.
+
+main -->
+	promise_impure_implicit (
+			% Inlining this call forces recomputation
+			% of purity for main/2 (because of the
+			% `:- pragma promise_pure').
+			% In some versions of this compiler, this
+			% recomputation would erroneously infer
+			% that the inlined calls to incr/1 below
+			% were `pure'. Duplicate call elimination
+			% would then remove all but one of them.
+		{ unsafe_get(Val0) },
+
+		io__write_int(Val0),
+		io__nl,
+
+		{ impure incr(_) },
+		{ impure incr(_) },
+		{ impure incr(_) },
+		{ semipure get(Val) },
+		io__write_int(Val),
+		io__nl
+	).
+
+:- pragma foreign_decl("C",
+"
+	int counter;
+").
+
+:- pragma foreign_code("C",
+"
+	int counter = 1;
+").
+
+:- pragma foreign_code("C#", "static int counter = 1;").
+
+:- impure pred incr(int::out) is det.
+
+incr(_::out) :- error("incr/1 called for language other than C").
+
+:- pragma foreign_proc("C", incr(Val::out), [will_not_call_mercury],
+			"counter++; Val = counter;").
+:- pragma foreign_proc("C#", incr(Val::out), [will_not_call_mercury],
+			"counter++; Val = counter;").
+
+:- semipure pred get(int::out) is det.
+
+get(_::out) :- error("get/1 called for language other than C").
+
+:- pragma foreign_proc("C", get(Val::out),
+		[will_not_call_mercury, promise_semipure],
+		"Val = counter").
+:- pragma foreign_proc("C#", get(Val::out),
+		[will_not_call_mercury, promise_semipure],
+		"Val = counter;").
+	
+:- pred unsafe_get(int::out) is det.
+:- pragma promise_pure(unsafe_get/1).
+
+unsafe_get(X) :- semipure get(X).
Index: tests/hard_coded/test_promise_impure_implicit.exp
===================================================================
RCS file: tests/hard_coded/test_promise_impure_implicit.exp
diff -N tests/hard_coded/test_promise_impure_implicit.exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/test_promise_impure_implicit.exp	26 Apr 2005 03:17:25 -0000
@@ -0,0 +1 @@
+Hello, World!
Index: tests/hard_coded/test_promise_impure_implicit.m
===================================================================
RCS file: tests/hard_coded/test_promise_impure_implicit.m
diff -N tests/hard_coded/test_promise_impure_implicit.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/test_promise_impure_implicit.m	26 Apr 2005 03:17:47 -0000
@@ -0,0 +1,40 @@
+%-----------------------------------------------------------------------------%
+% test_promise_impure_implicit.m
+% Ralph Becket <rafe at cs.mu.oz.au>
+% Tue Apr 26 13:14:12 EST 2005
+% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
+%
+%-----------------------------------------------------------------------------%
+
+:- module test_promise_impure_implicit.
+
+:- interface.
+
+:- import_module io.
+
+
+
+:- pred main(io :: di, io :: uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+%-----------------------------------------------------------------------------%
+
+main(!IO) :-
+    promise_pure_implicit (
+        X = some_impure_string,
+        io.print(X, !IO)
+    ).
+
+:- impure func some_impure_string = string.
+
+some_impure_string = X :-
+    promise_impure (
+        X = "Hello, World!\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
--------------------------------------------------------------------------