mirror of
https://github.com/Mercury-Language/mercury.git
synced 2026-04-17 02:13:54 +00:00
457 lines
14 KiB
Mathematica
457 lines
14 KiB
Mathematica
%---------------------------------------------------------------------------%
|
||
% vim: ts=4 sw=4 et ft=mercury
|
||
%---------------------------------------------------------------------------%
|
||
%
|
||
% Test case for functor, arg, deconstruct and their variants.
|
||
%
|
||
% Author: zs
|
||
%
|
||
% There are two expected output files for this test case.
|
||
% The .exp file is for LLDS grades.
|
||
% The .exp2 file is for MLDS grades.
|
||
%
|
||
% According to the first log entry of the .exp2 file, they are different
|
||
% because of missing information in closure layout structures in hlc grades.
|
||
%
|
||
%---------------------------------------------------------------------------%
|
||
|
||
:- module deconstruct_arg.
|
||
:- interface.
|
||
:- import_module io.
|
||
|
||
:- pred main(io::di, io::uo) is cc_multi.
|
||
|
||
:- implementation.
|
||
|
||
%---------------------------------------------------------------------------%
|
||
|
||
:- import_module array.
|
||
:- import_module assoc_list.
|
||
:- import_module float.
|
||
:- import_module list.
|
||
:- import_module string.
|
||
:- import_module deconstruct.
|
||
:- import_module maybe.
|
||
:- import_module pair.
|
||
:- import_module stream.
|
||
:- import_module stream.string_writer.
|
||
:- import_module univ.
|
||
|
||
:- type enum
|
||
---> one
|
||
; two
|
||
; three.
|
||
|
||
:- type fruit
|
||
---> apple(list(int))
|
||
; banana(list(enum)).
|
||
|
||
:- type thingie
|
||
---> foo
|
||
; bar(int)
|
||
; bar(int, int)
|
||
; qux(int)
|
||
; quux(int)
|
||
; quuux(int, int)
|
||
; wombat
|
||
; zoom(int)
|
||
; zap(int, float, int)
|
||
; zip(int, int, int, int)
|
||
; zop(float, float)
|
||
; moomoo(
|
||
moo :: int,
|
||
'mooo!' :: string
|
||
)
|
||
; packed(
|
||
packed1 :: int,
|
||
packed2 :: enum,
|
||
packed3 :: enum,
|
||
packed4 :: enum,
|
||
packed5 :: string
|
||
).
|
||
|
||
:- type poly(A, B)
|
||
---> poly_one(A)
|
||
; poly_two(B)
|
||
; poly_three(B, A, poly(B, A)).
|
||
|
||
:- type no_tag
|
||
---> qwerty(int).
|
||
|
||
:- type set(T)
|
||
---> set_rep(list(T))
|
||
where equality is set_equal.
|
||
|
||
% An enum type whose representation takes 1 bit.
|
||
:- type flag
|
||
---> flag_clear
|
||
; flag_set.
|
||
|
||
% An enum type whose representation takes 2 bits.
|
||
:- type color
|
||
---> red
|
||
; green
|
||
; blue.
|
||
|
||
% An enum type whose representation takes 3 bits.
|
||
:- type packed_fruit
|
||
---> apple
|
||
; pear
|
||
; peach
|
||
; orange
|
||
; banana.
|
||
|
||
% Every function symbol fN* should be allocated primary tag N.
|
||
% The function symbols whose names end in _[abc] share their
|
||
% primary tags, being distinguished by a local (f0) or remote (f7)
|
||
% secondary tag. These all have an initial sequence of subword-sized
|
||
% arguments that the compiler should pack next to the secondary tag.
|
||
:- type t
|
||
---> f0_a
|
||
; f0_b(f0_b1 :: flag, f0_b2 :: color, f0_b3 :: packed_fruit)
|
||
; f0_c(f0_c1 :: color, f0_c2 :: packed_fruit, f0_c3 :: flag)
|
||
; f1(int)
|
||
; f2(int)
|
||
; f3(int)
|
||
; f4(int)
|
||
; f5(int)
|
||
; f6(int)
|
||
; f7_a(f7_a1 :: int)
|
||
; f7_b(f7_b1 :: flag, f7_b2 :: color, f7_b3 :: packed_fruit)
|
||
; f7_c(f7_c1 :: packed_fruit, f7_c2 :: flag, f7_c3 :: color,
|
||
f7_c4 :: int).
|
||
|
||
%---------------------------------------------------------------------------%
|
||
|
||
% convert list to set
|
||
:- func set(list(T)) = set(T).
|
||
|
||
set(List) = set_rep(List).
|
||
|
||
% convert set to sorted list
|
||
:- func set_to_sorted_list(set(T)) = list(T).
|
||
|
||
set_to_sorted_list(Set) = Sorted :-
|
||
promise_equivalent_solutions [Sorted] (
|
||
Set = set_rep(Unsorted),
|
||
list.sort_and_remove_dups(Unsorted, Sorted)
|
||
).
|
||
|
||
:- pred set_equal(set(T)::in, set(T)::in) is semidet.
|
||
|
||
set_equal(Set1, Set2) :-
|
||
set_to_sorted_list(Set1) = set_to_sorted_list(Set2).
|
||
|
||
%---------------------------------------------------------------------------%
|
||
|
||
main(!IO) :-
|
||
% test enumerations
|
||
% test_all(one, !IO),
|
||
|
||
% test primary tags
|
||
test_all(apple([]), !IO),
|
||
test_all(apple([9, 5, 1]), !IO),
|
||
|
||
% test remote secondary tags
|
||
test_all(zop(3.3, 2.03), !IO),
|
||
test_all(zap(50, 51.0, 52), !IO),
|
||
test_all(zip(50, 51, 52, 53), !IO),
|
||
|
||
% test local secondary tags
|
||
test_all(wombat, !IO),
|
||
|
||
% test notag
|
||
test_all(qwerty(5), !IO),
|
||
|
||
% test named arguments
|
||
test_all(moomoo(50, "moo."), !IO),
|
||
|
||
% test terms with arguments packed next to the local secondary tag
|
||
test_all(f0_a, !IO),
|
||
test_all(f0_b(flag_set, blue, peach), !IO),
|
||
test_all(f0_c(green, orange, flag_clear), !IO),
|
||
|
||
% test terms with arguments packed next to the remote secondary tag
|
||
test_all(f7_a(41), !IO),
|
||
test_all(f7_b(flag_clear, red, peach), !IO),
|
||
test_all(f7_c(pear, flag_set, green, 43), !IO),
|
||
|
||
% test characters
|
||
test_all('a', !IO),
|
||
test_all(' ', !IO),
|
||
test_all('\a', !IO),
|
||
test_all('\b', !IO),
|
||
test_all('\r', !IO),
|
||
test_all('\f', !IO),
|
||
test_all('\t', !IO),
|
||
test_all('\n', !IO),
|
||
test_all('\v', !IO),
|
||
test_all('\\', !IO),
|
||
test_all('\'', !IO),
|
||
test_all('~', !IO),
|
||
|
||
% test C0 control characters
|
||
test_all('\001\', !IO),
|
||
test_all('\037\', !IO),
|
||
test_all('\177\', !IO),
|
||
% test C1 control characters
|
||
test_all('\200\', !IO),
|
||
test_all('\237\', !IO),
|
||
% No-break space (next codepoint after C1 control characters)
|
||
test_all('\240\', !IO),
|
||
|
||
% test a character that requires more than one byte in its
|
||
% UTF-8 encoding.
|
||
test_all('Ω', !IO),
|
||
|
||
% test strings (that do not require escapes)
|
||
test_all("", !IO),
|
||
test_all("azBZ09", !IO),
|
||
test_all("\u03b1\u2200\U0001f713", !IO),
|
||
|
||
% test strings (that do require escapes)
|
||
test_all("\a\b\f\n\t\r\v\"\\", !IO),
|
||
test_all("\x1\\a\x1f\AZ[`az~\x7f\", !IO),
|
||
test_all("\x80\\a\x9f\\xa0\\xc0\\xff\", !IO),
|
||
test_all("α\nβ\tγ,a\nα\001\α\001\a\001\α", !IO),
|
||
|
||
% test a float which requires 17 digits of precision
|
||
test_all(0.12345678901234566, !IO),
|
||
|
||
% test infinite floats
|
||
test_all(float.infinity, !IO),
|
||
NegInf : float = -float.infinity,
|
||
test_all(NegInf, !IO),
|
||
|
||
% test integers
|
||
test_all(4, !IO),
|
||
|
||
% test unsigned integers
|
||
test_all(561u, !IO),
|
||
|
||
% test fixed size integers.
|
||
test_all(42i8, !IO),
|
||
test_all(42u8, !IO),
|
||
test_all(42i16, !IO),
|
||
test_all(42u16, !IO),
|
||
test_all(42i32, !IO),
|
||
test_all(43u32, !IO),
|
||
test_all(66i64, !IO),
|
||
test_all(67u64, !IO),
|
||
|
||
% test univ.
|
||
type_to_univ(["hi! I'm a univ!"], Univ),
|
||
test_all(Univ, !IO),
|
||
|
||
% test noncanonical type
|
||
test_all(set([1, 2, 3, 3]), !IO),
|
||
|
||
% test predicates
|
||
test_all(newline, !IO),
|
||
test_all(test_all([1, 2]), !IO),
|
||
test_all(p(1, 2.2, "three"), !IO),
|
||
|
||
% test tuples
|
||
test_all({1, 'b'}, !IO),
|
||
test_all({3, 'c', "3rd"}, !IO),
|
||
test_all({5, 'd', "third", {1, 2, 3, 4}}, !IO),
|
||
|
||
% test arrays
|
||
test_all(array([1000, 2000]), !IO),
|
||
test_all(array([100, 200, 300]), !IO),
|
||
test_all(array([10, 20, 30, 40]), !IO),
|
||
|
||
% test packed fields
|
||
test_all(packed(100, one, two, three, "four"), !IO).
|
||
|
||
:- pred p(int::in, float::in, string::in, io::di, io::uo) is det.
|
||
|
||
p(_, _, _, !IO).
|
||
|
||
:- pred newline(io::di, io::uo) is det.
|
||
|
||
newline(!IO) :-
|
||
io.write_char('\n', !IO).
|
||
|
||
%---------------------------------------------------------------------------%
|
||
|
||
:- pred test_all(T::in, io::di, io::uo) is cc_multi.
|
||
|
||
test_all(T, !IO) :-
|
||
io.write_string("test term: ", !IO),
|
||
io.write_line(T, !IO),
|
||
test_deconstruct_functor(T, MaybeConstant, !IO),
|
||
|
||
some [!RevPairs] (
|
||
!:RevPairs = [],
|
||
test_deconstruct_arg(T, 0, !RevPairs),
|
||
test_deconstruct_arg(T, 1, !RevPairs),
|
||
test_deconstruct_arg(T, 2, !RevPairs),
|
||
test_deconstruct_arg(T, 3, !RevPairs),
|
||
test_deconstruct_named_arg(T, "moo", !RevPairs),
|
||
test_deconstruct_named_arg(T, "mooo!", !RevPairs),
|
||
test_deconstruct_named_arg(T, "packed1", !RevPairs),
|
||
test_deconstruct_named_arg(T, "packed2", !RevPairs),
|
||
test_deconstruct_named_arg(T, "packed3", !RevPairs),
|
||
test_deconstruct_named_arg(T, "f0_b1", !RevPairs),
|
||
test_deconstruct_named_arg(T, "f0_b2", !RevPairs),
|
||
test_deconstruct_named_arg(T, "f0_b3", !RevPairs),
|
||
test_deconstruct_named_arg(T, "f0_c1", !RevPairs),
|
||
test_deconstruct_named_arg(T, "f0_c2", !RevPairs),
|
||
test_deconstruct_named_arg(T, "f0_c3", !RevPairs),
|
||
test_deconstruct_named_arg(T, "f7_a1", !RevPairs),
|
||
test_deconstruct_named_arg(T, "f7_b1", !RevPairs),
|
||
test_deconstruct_named_arg(T, "f7_b2", !RevPairs),
|
||
test_deconstruct_named_arg(T, "f7_b3", !RevPairs),
|
||
test_deconstruct_named_arg(T, "f7_c1", !RevPairs),
|
||
test_deconstruct_named_arg(T, "f7_c2", !RevPairs),
|
||
test_deconstruct_named_arg(T, "f7_c3", !RevPairs),
|
||
test_deconstruct_named_arg(T, "f7_c4", !RevPairs),
|
||
list.reverse(!.RevPairs, Pairs),
|
||
|
||
% Do not bore readers with each negative result individually;
|
||
% print just one message for them all collectively, and even that
|
||
% only if is not the expected result.
|
||
list.filter(has_arg, Pairs, HasArgPairs, NoArgPairs),
|
||
(
|
||
HasArgPairs = [],
|
||
(
|
||
MaybeConstant = constant(_)
|
||
% Not being able to get any arguments is not surprising
|
||
% for terms that do not have any.
|
||
;
|
||
MaybeConstant = not_constant(_, _),
|
||
io.write_string("no argument access succeeded\n", !IO)
|
||
)
|
||
;
|
||
HasArgPairs = [_ | _],
|
||
list.foldl(write_arg_pair, HasArgPairs, !IO),
|
||
(
|
||
NoArgPairs = [_ | _],
|
||
io.write_string("no other argument access succeeded\n", !IO)
|
||
;
|
||
NoArgPairs = []
|
||
)
|
||
)
|
||
),
|
||
|
||
test_deconstruct_deconstruct(MaybeConstant, T, !IO),
|
||
test_deconstruct_limited_deconstruct(MaybeConstant, T, 3, !IO),
|
||
io.nl(!IO).
|
||
|
||
%---------------------------------------------------------------------------%
|
||
|
||
:- type maybe_constant
|
||
---> not_constant(string, int)
|
||
; constant(string).
|
||
|
||
:- pred test_deconstruct_functor(T::in, maybe_constant::out,
|
||
io::di, io::uo) is cc_multi.
|
||
|
||
test_deconstruct_functor(T, MaybeConstant, !IO) :-
|
||
deconstruct.functor(T, include_details_cc, Functor, Arity),
|
||
( if Arity = 0 then
|
||
MaybeConstant = constant(Functor)
|
||
else
|
||
MaybeConstant = not_constant(Functor, Arity)
|
||
),
|
||
io.format("deconstruct functor: %s/%d\n", [s(Functor), i(Arity)], !IO).
|
||
|
||
%---------------------------------------------------------------------------%
|
||
|
||
:- pred test_deconstruct_arg(T::in, int::in,
|
||
assoc_list(string, maybe_arg)::in, assoc_list(string, maybe_arg)::out)
|
||
is cc_multi.
|
||
|
||
test_deconstruct_arg(T, ArgNum, !RevPairs) :-
|
||
string.format("argument #%d: ", [i(ArgNum)], Desc),
|
||
deconstruct.arg_cc(T, ArgNum, MaybeArg),
|
||
!:RevPairs = [Desc - MaybeArg | !.RevPairs].
|
||
|
||
:- pred test_deconstruct_named_arg(T::in, string::in,
|
||
assoc_list(string, maybe_arg)::in, assoc_list(string, maybe_arg)::out)
|
||
is cc_multi.
|
||
|
||
test_deconstruct_named_arg(T, Name, !RevPairs) :-
|
||
string.format("argument named '%s': ", [s(Name)], Desc),
|
||
deconstruct.named_arg_cc(T, Name, MaybeArg),
|
||
!:RevPairs = [Desc - MaybeArg | !.RevPairs].
|
||
|
||
%---------------------------------------------------------------------------%
|
||
|
||
:- pred has_arg(pair(string, maybe_arg)::in) is semidet.
|
||
|
||
has_arg(_Desc - arg(_)).
|
||
|
||
:- pred write_arg_pair(pair(string, maybe_arg)::in, io::di, io::uo) is det.
|
||
|
||
write_arg_pair(Desc - MaybeArg, !IO) :-
|
||
io.write_string(Desc, !IO),
|
||
(
|
||
MaybeArg = arg(Arg),
|
||
io.write(Arg, !IO),
|
||
io.nl(!IO)
|
||
;
|
||
MaybeArg = no_arg,
|
||
io.write_string("does not exist\n", !IO)
|
||
).
|
||
|
||
%---------------------------------------------------------------------------%
|
||
|
||
:- pred test_deconstruct_deconstruct(maybe_constant::in, T::in,
|
||
io::di, io::uo) is cc_multi.
|
||
|
||
test_deconstruct_deconstruct(MaybeConstant, T, !IO) :-
|
||
Desc = "plain deconstruct:",
|
||
deconstruct.deconstruct(T, include_details_cc, Functor, Arity, ArgUnivs),
|
||
write_deconstruct_results_if_interesting(Desc, MaybeConstant,
|
||
Functor, Arity, ArgUnivs, !IO).
|
||
|
||
:- pred test_deconstruct_limited_deconstruct(maybe_constant::in, T::in,
|
||
int::in, io::di, io::uo) is cc_multi.
|
||
|
||
test_deconstruct_limited_deconstruct(MaybeConstant, T, Limit, !IO) :-
|
||
string.format("limited deconstruct %d:", [i(Limit)], Desc),
|
||
deconstruct.limited_deconstruct_cc(T, Limit, Result),
|
||
(
|
||
Result = yes({Functor, Arity, ArgUnivs}),
|
||
write_deconstruct_results_if_interesting(Desc, MaybeConstant,
|
||
Functor, Arity, ArgUnivs, !IO)
|
||
;
|
||
Result = no,
|
||
io.format("%s failed\n", [s(Desc)], !IO)
|
||
).
|
||
|
||
:- pred write_deconstruct_results_if_interesting(string::in,
|
||
maybe_constant::in, string::in, int::in, list(univ)::in,
|
||
io::di, io::uo) is det.
|
||
|
||
write_deconstruct_results_if_interesting(Desc, MaybeConstant,
|
||
Functor, Arity, ArgUnivs, !IO) :-
|
||
( if
|
||
MaybeConstant = constant(ConstantFunctor),
|
||
Functor = ConstantFunctor,
|
||
Arity = 0,
|
||
ArgUnivs = []
|
||
then
|
||
% The result of the deconstruct operation is exactly what we expected.
|
||
% The test_deconstruct_functor predicate has already printed
|
||
% the functor and the arity, so there is nothing interesting for us
|
||
% to print here.
|
||
true
|
||
else
|
||
io.format("%s\n", [s(Desc)], !IO),
|
||
io.format("functor %s arity %d ", [s(Functor), i(Arity)], !IO),
|
||
io.write_string("[", !IO),
|
||
io.write_list(ArgUnivs, ", ", write_arg_univ, !IO),
|
||
io.write_string("]\n", !IO)
|
||
).
|
||
|
||
:- pred write_arg_univ(univ::in, io::di, io::uo) is det.
|
||
|
||
write_arg_univ(Univ, !IO) :-
|
||
io.stdout_stream(Stdout, !IO),
|
||
stream.string_writer.write_univ(Stdout, Univ, !IO).
|
||
|
||
%---------------------------------------------------------------------------%
|