## make-anormcode-equality-fn.pkg
#
# Constructing generic equality functions. The current version will
# use runtime polyequal function to deal with abstract types. (ZHONG)
#
# We're invoked only from:
#
# src/lib/compiler/back/top/forms/insert-anormcode-boxing-and-coercion-code.pkg# Compiled by:
# src/lib/compiler/core.sublib### "Every child is an artist. The problem is
### how to remain an artist once he grows up."
###
### -- Pablo Picasso
stipulate
package acf = anormcode_form; # anormcode_form is from src/lib/compiler/back/top/anormcode/anormcode-form.pkgherein
api Make_Anormcode_Equality_Fn {
#
make_equal_branch_fn
:
( acf::Baseop,
List( acf::Value ),
acf::Expression,
acf::Expression
)
->
acf::Expression;
debugging: Ref( Bool );
};
end;
stipulate
package acf = anormcode_form; # anormcode_form is from src/lib/compiler/back/top/anormcode/anormcode-form.pkg package acj = anormcode_junk; # anormcode_junk is from src/lib/compiler/back/top/anormcode/anormcode-junk.pkg package hbo = highcode_baseops; # highcode_baseops is from src/lib/compiler/back/top/highcode/highcode-baseops.pkg package hbt = highcode_basetypes; # highcode_basetypes is from src/lib/compiler/back/top/highcode/highcode-basetypes.pkg package hcf = highcode_form; # highcode_form is from src/lib/compiler/back/top/highcode/highcode-form.pkg package mtt = more_type_types; # more_type_types is from src/lib/compiler/front/typer/types/more-type-types.pkg# package pp = standard_prettyprinter; # standard_prettyprinter is from src/lib/prettyprint/big/src/standard-prettyprinter.pkg package tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkgherein
package make_anormcode_equality_fn
: (weak) Make_Anormcode_Equality_Fn # Make_Anormcode_Equality_Fn is from src/lib/compiler/back/top/forms/make-anormcode-equality-fn.pkg {
debugging = REF FALSE;
fun bug msg
=
error_message::impossible("Equal: " + msg);
say = global_controls::print::say;
make_var = highcode_codetemp::issue_highcode_codetemp;
ident = \\ x = x;
my (true_valcon', false_valcon')
=
{ type = hcf::make_arrow_uniqtypoid # "Void -> Bool" type.
(
hcf::rawraw_variable_calling_convention,
[ hcf::void_uniqtypoid ],
[ hcf::bool_uniqtypoid ]
);
fun h (tdt::VALCON { name, form, ... } )
=
(name, form, type);
( h mtt::true_valcon,
h mtt::false_valcon
);
};
tc_eqv = hcf::same_uniqtype;
fun bool_lexp b
=
acf::RECORD ( acj::rk_tuple,
[],
v,
acf::CONSTRUCTOR (dc, [], acf::VAR v, w, acf::RET [acf::VAR w])
)
where
v = make_var();
w = make_var();
dc = if b true_valcon';
else false_valcon';
fi;
end;
exception POLY;
###############################################################################
# Commonly-used Anormcode Types
###############################################################################
# We assume types created here will
# be reprocessed in src/lib/compiler/back/top/forms/insert-anormcode-boxing-and-coercion-code.pkg #
fun eq_lty lt
=
hcf::make_arrow_uniqtypoid
(
hcf::rawraw_variable_calling_convention,
[ lt, lt ],
[ hcf::bool_uniqtypoid ]
);
fun eq_type tc = eq_lty (hcf::make_type_uniqtypoid tc);
inteqty = eq_lty (hcf::int_uniqtypoid);
int1eqty = eq_lty (hcf::int1_uniqtypoid);
booleqty = eq_lty (hcf::bool_uniqtypoid);
realeqty = eq_lty (hcf::float64_uniqtypoid);
###############################################################################
# equal --- the equality function generator
###############################################################################
exception NOT_FOUND;
fkfun = { loop_info => NULL,
private => FALSE,
call_as => acf::CALL_AS_FUNCTION hcf::rawraw_variable_calling_convention,
inlining_hint => acf::INLINE_IF_SIZE_SAFE
};
fun branch (e, te, fe)
=
{ x = make_var();
acf::LET ([x], e,
acf::SWITCH (acf::VAR x, mtt::bool_signature,
[ (acf::VAL_CASETAG (true_valcon', [], make_var()), te),
(acf::VAL_CASETAG (false_valcon', [], make_var()), fe)
],
NULL));
};
fun equal (peqv, seqv)
=
{
fun eq (tc, x, y, 0, te, fe)
=>
raise exception POLY;
eq (tc, x, y, d, te, fe)
=>
{ fun eq_tuple (_, _, [], te, fe)
=>
te;
eq_tuple (n, d, type ! tys, te, fe)
=>
{ a = make_var();
b = make_var();
acf::GET_FIELD (x, n, a,
acf::GET_FIELD (y, n, b,
eq (type, acf::VAR a, acf::VAR b, d - 1,
eq_tuple (n + 1, d - 1, tys, te, fe),
fe)));
};
end;
if (hcf::uniqtype_is_tuple tc )
#
case fe
#
(acf::APPLY _ | acf::RET _)
=>
eq_tuple (0, d, hcf::unpack_tuple_uniqtype tc, te, fe);
_ =>
{ f = make_var();
acf::MUTUALLY_RECURSIVE_FNS([(fkfun, f, [], fe)],
eq_tuple (0, d, hcf::unpack_tuple_uniqtype tc,
te, acf::APPLY (acf::VAR f, [])));
};
esac;
elif (tc_eqv (tc, hcf::int_uniqtype) )
acf::BRANCH((NULL, hbo::ieql, inteqty, []), [x, y], te, fe);
elif (tc_eqv (tc, hcf::int1_uniqtype) )
acf::BRANCH((NULL, hbo::ieql, int1eqty, []), [x, y], te, fe);
elif (tc_eqv (tc, hcf::bool_uniqtype) )
acf::BRANCH((NULL, hbo::ieql, booleqty, []), [x, y], te, fe);
elif (tc_eqv (tc, hcf::string_uniqtype) )
branch (acf::APPLY (acf::VAR seqv, [x, y]), te, fe);
elif ( (hcf::uniqtype_is_apply_typefun tc)
and
{ my (x, _) = hcf::unpack_apply_typefun_uniqtype tc;
#
((hcf::uniqtype_is_basetype x) and (hcf::unpack_basetype_uniqtype x == hbt::basetype_ref));
}
)
acf::BRANCH((NULL, hbo::POINTER_EQL, eq_type tc, []), [x, y], te, fe);
else
raise exception POLY;
fi;
};
end;
\\ (tc, x, y, d, te, fe)
=
eq (tc, x, y, d, te, fe)
except
POLY =
{ f = make_var();
#
acf::LET ([f], acf::APPLY_TYPEFUN (acf::VAR peqv, [tc]), branch (acf::APPLY (acf::VAR f, [x, y]), te, fe));
};
};
fun make_equal_branch_fn ((d, p, lt, ts), vs, e1, e2)
=
case (d, p, ts, vs)
#
( THE { default => pv, table => [(_, sv)] },
hbo::POLY_EQL,
[tc],
[x, y]
)
=>
equal (pv, sv) (tc, x, y, 10, e1, e2);
_ => bug "unexpected case in equal_branch";
esac;
}; # package equal
end; # toplevel stipulate