diff: test passing typeclass_infos to C code
Fergus Henderson
fjh at cs.mu.OZ.AU
Thu Oct 29 21:13:46 AEDT 1998
Estimated hours taken: 0.75
Test passing typeclass_infos to C code.
tests/hard_coded/typeclasses/existential_type_classes.m:
tests/debugger/existential_type_classes.m:
Add some code to test passing typeclass_infos to C code.
tests/debugger/existential_type_classes.inp:
Change the mdb input for this test case so that that
output will match what happened previously.
tests/hard_coded/typeclasses/existential_type_classes.exp:
tests/debugger/existential_type_classes.exp:
Modify the expected output for these test cases to reflect
what mdb now outputs for them.
Index: tests/debugger/existential_type_classes.m
===================================================================
RCS file: /home/mercury1/repository/tests/debugger/existential_type_classes.m,v
retrieving revision 1.2
diff -u -r1.2 existential_type_classes.m
--- existential_type_classes.m 1998/10/29 08:53:16 1.2
+++ existential_type_classes.m 1998/10/29 09:51:09
@@ -27,9 +27,14 @@
% my_univ_value(Univ):
% returns the value of the object stored in Univ.
-:- some [T] func my_univ_value(univ) = T => fooable(T).
-:- some [T] func call_my_univ_value(univ) = T => fooable(T).
+:- type my_univ ---> my_univ(c_pointer).
+
+:- func my_univ(T) = my_univ <= fooable(T).
+
+:- some [T] func my_univ_value(my_univ) = T => fooable(T).
+
+:- some [T] func call_my_univ_value(my_univ) = T => fooable(T).
:- some [T] func my_exist_t = T => fooable(T).
@@ -47,8 +52,8 @@
do_foo("blah", T2),
do_foo(my_exist_t, T3),
do_foo(call_my_exist_t, T4),
- do_foo(my_univ_value(univ(45)), T5),
- do_foo(call_my_univ_value(univ("something")), T6)
+ do_foo(my_univ_value(my_univ(45)), T5),
+ do_foo(call_my_univ_value(my_univ("something")), T6)
},
io__write_int(T1), nl,
io__write_int(T2), nl,
@@ -68,12 +73,15 @@
my_exist_t = 43.
-/*
-XXX we don't yet support `pragma c_code' for existential type class constraints
:- pragma c_code(my_univ_value(Univ::in) = (Value::out), will_not_call_mercury, "
- TypeInfo_for_T = field(mktag(0), Univ, UNIV_OFFSET_FOR_TYPEINFO);
- Value = field(mktag(0), Univ, UNIV_OFFSET_FOR_DATA);
- ClassInfo_1 = XXX;
+ TypeClassInfo_for_existential_type_classes__fooable_T =
+ field(mktag(0), Univ, 0);
+ Value = field(mktag(0), Univ, 1);
+").
+
+:- pragma c_code(my_univ(Value::in) = (Univ::out), will_not_call_mercury, "
+ incr_hp(Univ, 2);
+ field(mktag(0), Univ, 0) =
+ (Word) TypeClassInfo_for_existential_type_classes__fooable_T;
+ field(mktag(0), Univ, 1) = (Word) Value;
").
-*/
-my_univ_value(_Univ) = 44.
Index: tests/hard_coded/typeclasses/existential_type_classes.exp
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/typeclasses/existential_type_classes.exp,v
retrieving revision 1.2
diff -u -r1.2 existential_type_classes.exp
--- existential_type_classes.exp 1998/07/08 20:59:09 1.2
+++ existential_type_classes.exp 1998/10/29 09:36:02
@@ -2,5 +2,5 @@
4
86
86
-88
-88
+90
+9
Index: tests/hard_coded/typeclasses/existential_type_classes.m
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/typeclasses/existential_type_classes.m,v
retrieving revision 1.3
diff -u -r1.3 existential_type_classes.m
--- existential_type_classes.m 1998/10/29 08:53:49 1.3
+++ existential_type_classes.m 1998/10/29 09:41:39
@@ -27,9 +27,14 @@
% my_univ_value(Univ):
% returns the value of the object stored in Univ.
-:- some [T] func my_univ_value(univ) = T => fooable(T).
-:- some [T] func call_my_univ_value(univ) = T => fooable(T).
+:- type my_univ == c_pointer.
+
+:- func my_univ(T) = my_univ <= fooable(T).
+
+:- some [T] func my_univ_value(my_univ) = T => fooable(T).
+
+:- some [T] func call_my_univ_value(my_univ) = T => fooable(T).
:- some [T] func my_exist_t = T => fooable(T).
@@ -44,8 +49,8 @@
do_foo("blah"),
do_foo(my_exist_t),
do_foo(call_my_exist_t),
- do_foo(my_univ_value(univ(45))),
- do_foo(call_my_univ_value(univ("something"))).
+ do_foo(my_univ_value(my_univ(45))),
+ do_foo(call_my_univ_value(my_univ("something"))).
:- pred do_foo(T::in, io__state::di, state::uo) is det <= fooable(T).
do_foo(X) -->
@@ -58,13 +63,15 @@
my_exist_t = 43.
-/*
-XXX we don't yet support `pragma c_code' for existential type class constraints
:- pragma c_code(my_univ_value(Univ::in) = (Value::out), will_not_call_mercury, "
- TypeInfo_for_T = field(mktag(0), Univ, UNIV_OFFSET_FOR_TYPEINFO);
- Value = field(mktag(0), Univ, UNIV_OFFSET_FOR_DATA);
- ClassInfo_1 = XXX;
+ TypeClassInfo_for_existential_type_classes__fooable_T =
+ field(mktag(0), Univ, 0);
+ Value = field(mktag(0), Univ, 1);
").
-*/
-my_univ_value(_Univ) = 44.
+:- pragma c_code(my_univ(Value::in) = (Univ::out), will_not_call_mercury, "
+ incr_hp(Univ, 2);
+ field(mktag(0), Univ, 0) = (Word)
+ TypeClassInfo_for_existential_type_classes__fooable_T;
+ field(mktag(0), Univ, 1) = (Word) Value;
+").
Index: tests/debugger/existential_type_classes.exp
===================================================================
RCS file: /home/mercury1/repository/tests/debugger/existential_type_classes.exp,v
retrieving revision 1.1
diff -u -r1.1 existential_type_classes.exp
--- existential_type_classes.exp 1998/10/23 00:41:44 1.1
+++ existential_type_classes.exp 1998/10/29 10:08:24
@@ -107,46 +107,52 @@
HeadVar__1 43
HeadVar__2 86
mdb> continue -a
- 40: 21 2 CALL func existential_type_classes:my_univ_value/2-0 (det)
- 41: 21 2 EXIT func existential_type_classes:my_univ_value/2-0 (det)
- 42: 22 2 CALL pred existential_type_classes:do_foo/2-0 (det)
+ 40: 21 2 CALL func existential_type_classes:my_univ/2-0 (det)
+ 41: 21 2 EXIT func existential_type_classes:my_univ/2-0 (det)
+ 42: 22 2 CALL func existential_type_classes:my_univ_value/2-0 (det)
+ 43: 22 2 EXIT func existential_type_classes:my_univ_value/2-0 (det)
+ 44: 23 2 CALL pred existential_type_classes:do_foo/2-0 (det)
mdb> P
- HeadVar__1 44
+ HeadVar__1 45
mdb>
- 43: 23 3 CALL pred existential_type_classes:foo/2-0 (det)
+ 45: 24 3 CALL pred existential_type_classes:foo/2-0 (det)
mdb> P
- HeadVar__1 44
+ HeadVar__1 45
mdb>
- 44: 24 4 CALL pred existential_type_classes:Introduced_pred_for_existential_type_classes__fooable__int_0_____existential_type_classes__foo_2/2-0 (det)
+ 46: 25 4 CALL pred existential_type_classes:Introduced_pred_for_existential_type_classes__fooable__int_0_____existential_type_classes__foo_2/2-0 (det)
mdb> P
- HeadVar__1 44
+ HeadVar__1 45
mdb> continue -a
- 45: 25 5 CALL pred existential_type_classes:int_foo/2-0 (det)
- 46: 25 5 EXIT pred existential_type_classes:int_foo/2-0 (det)
- 47: 24 4 EXIT pred existential_type_classes:Introduced_pred_for_existential_type_classes__fooable__int_0_____existential_type_classes__foo_2/2-0 (det)
- 48: 23 3 EXIT pred existential_type_classes:foo/2-0 (det)
- 49: 22 2 EXIT pred existential_type_classes:do_foo/2-0 (det)
+ 47: 26 5 CALL pred existential_type_classes:int_foo/2-0 (det)
+ 48: 26 5 EXIT pred existential_type_classes:int_foo/2-0 (det)
+ 49: 25 4 EXIT pred existential_type_classes:Introduced_pred_for_existential_type_classes__fooable__int_0_____existential_type_classes__foo_2/2-0 (det)
+ 50: 24 3 EXIT pred existential_type_classes:foo/2-0 (det)
+ 51: 23 2 EXIT pred existential_type_classes:do_foo/2-0 (det)
mdb> P
- HeadVar__1 44
- HeadVar__2 88
+ HeadVar__1 45
+ HeadVar__2 90
mdb>
- 50: 26 2 CALL func existential_type_classes:call_my_univ_value/2-0 (det)
+ 52: 27 2 CALL func existential_type_classes:my_univ/2-0 (det)
+mdb>
+ 53: 27 2 EXIT func existential_type_classes:my_univ/2-0 (det)
+mdb>
+ 54: 28 2 CALL func existential_type_classes:call_my_univ_value/2-0 (det)
mdb> P
- HeadVar__1 "something"
+ HeadVar__1 my_univ('<<c_pointer>>')
mdb>
- 51: 27 3 CALL func existential_type_classes:my_univ_value/2-0 (det)
+ 55: 29 3 CALL func existential_type_classes:my_univ_value/2-0 (det)
mdb> P
- HeadVar__1 "something"
+ Univ my_univ('<<c_pointer>>')
mdb> continue -a
- 52: 27 3 EXIT func existential_type_classes:my_univ_value/2-0 (det)
- 53: 26 2 EXIT func existential_type_classes:call_my_univ_value/2-0 (det)
- 54: 28 2 CALL pred existential_type_classes:do_foo/2-0 (det)
+ 56: 29 3 EXIT func existential_type_classes:my_univ_value/2-0 (det)
+ 57: 28 2 EXIT func existential_type_classes:call_my_univ_value/2-0 (det)
+ 58: 30 2 CALL pred existential_type_classes:do_foo/2-0 (det)
mdb> P
- HeadVar__1 44
+ HeadVar__1 something
mdb> continue -S
84
4
86
86
-88
-88
+90
+9
Index: tests/debugger/existential_type_classes.inp
===================================================================
RCS file: /home/mercury1/repository/tests/debugger/existential_type_classes.inp,v
retrieving revision 1.1
diff -u -r1.1 existential_type_classes.inp
--- existential_type_classes.inp 1998/10/23 00:41:45 1.1
+++ existential_type_classes.inp 1998/10/29 10:06:59
@@ -43,6 +43,8 @@
continue -a
P
+
+
P
P
--
Fergus Henderson <fjh at cs.mu.oz.au> | "I have always known that the pursuit
WWW: <http://www.cs.mu.oz.au/~fjh> | of excellence is a lethal habit"
PGP: finger fjh at 128.250.37.3 | -- the last words of T. S. Garp.
More information about the developers
mailing list