## drop-types-from-anormcode-junk.pkg "type-oper.pkg" in SML/NJ
#
# This package is used (only) in:
#
# src/lib/compiler/back/top/forms/drop-types-from-anormcode.pkg# Compiled by:
# src/lib/compiler/core.sublib### "You should learn from the mistakes of others,
### because you'll never have enough time to make
### all those mistakes yourself."
###
### -- Ben Franklin
stipulate
package acf = anormcode_form; # anormcode_form is from src/lib/compiler/back/top/anormcode/anormcode-form.pkg package hbo = highcode_baseops; # highcode_baseops is from src/lib/compiler/back/top/highcode/highcode-baseops.pkg package hct = highcode_type; # highcode_type is from src/lib/compiler/back/top/highcode/highcode-type.pkg package tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkg package hut = highcode_uniq_types; # highcode_uniq_types is from src/lib/compiler/back/top/highcode/highcode-uniq-types.pkgherein
api Drop_Types_From_Anormcode_Junk {
#
Kenv;
#
# Highcode_Kind = hct::Highcode_Kind;
# Uniqtype = hct::Uniqtype;
# Uniqtypoid = hct::Uniqtypoid;
# Variable = tmp::Codetemp;
# Expression = acf::Expression;
# Value = acf::Value;
init_ke: Kenv;
tk_abs: ( Kenv,
List( (tmp::Codetemp, hut::Uniqkind) ),
tmp::Codetemp
)
->
( Kenv,
((acf::Expression, acf::Expression) -> acf::Expression)
);
tc_lexp: Kenv -> hut::Uniqtype -> acf::Expression;
ts_lexp: (Kenv, List( hut::Uniqtype )) -> acf::Expression;
utgc: (hut::Uniqtype, Kenv, hut::Uniqtype) -> acf::Value -> acf::Expression;
utgd: (hut::Uniqtype, Kenv, hut::Uniqtype) -> acf::Value -> acf::Expression;
tgdc: (Int, hut::Uniqtype, Kenv, hut::Uniqtype) -> acf::Value -> acf::Expression;
tgdd: (Int, hut::Uniqtype, Kenv, hut::Uniqtype) -> acf::Value -> acf::Expression;
make_wrap: (hut::Uniqtype, Kenv, Bool, hut::Uniqtype) -> acf::Expression -> acf::Expression;
make_unwrap: (hut::Uniqtype, Kenv, Bool, hut::Uniqtype) -> acf::Expression -> acf::Expression;
rw_vector_get: (hut::Uniqtype, Kenv, hut::Uniqtypoid, hut::Uniqtypoid) -> List( acf::Value ) -> acf::Expression;
rw_vector_set: (hut::Uniqtype, Kenv, hbo::Baseop, hut::Uniqtypoid, hut::Uniqtypoid) -> List( acf::Value ) -> acf::Expression;
make_rw_vector: (hut::Uniqtype, tmp::Codetemp, tmp::Codetemp, Kenv) -> List( acf::Value ) -> acf::Expression;
};
end;
stipulate
package acf = anormcode_form; # anormcode_form is from src/lib/compiler/back/top/anormcode/anormcode-form.pkgherein
api Outcome {
#
Outcome = YES
| NO
| MAYBE acf::Expression
;
};
end;
package ot: (weak) Outcome # Outcome is from src/lib/compiler/back/top/forms/drop-types-from-anormcode-junk.pkg = anormcode_runtime_type; # anormcode_runtime_type is from src/lib/compiler/back/top/forms/anormcode-runtime-type.pkgstipulate
package acf = anormcode_form; # anormcode_form is from src/lib/compiler/back/top/anormcode/anormcode-form.pkg package art = anormcode_runtime_type; # anormcode_runtime_type is from src/lib/compiler/back/top/forms/anormcode-runtime-type.pkg package di = debruijn_index; # debruijn_index is from src/lib/compiler/front/typer/basics/debruijn-index.pkg package hut = highcode_uniq_types; # highcode_uniq_types is from src/lib/compiler/back/top/highcode/highcode-uniq-types.pkg package hcf = highcode_form; # highcode_form is from src/lib/compiler/back/top/highcode/highcode-form.pkg package hct = highcode_type; # highcode_type is from src/lib/compiler/back/top/highcode/highcode-type.pkg package tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.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 mtt = more_type_types; # more_type_types is from src/lib/compiler/front/typer/types/more-type-types.pkgherein
package drop_types_from_anormcode_junk
: (weak) Drop_Types_From_Anormcode_Junk # Drop_Types_From_Anormcode_Junk is from src/lib/compiler/back/top/forms/drop-types-from-anormcode-junk.pkg {
# Highcode_Kind = hct::Highcode_Kind;
# Uniqtype = hct::Uniqtype;
# Uniqtypoid = hct::Uniqtypoid;
# Variable = tmp::Codetemp;
# Expression = acf::Expression;
# Value = acf::Value;
Kenv = art::Kenv;
fun bug s
=
error_message::impossible ("drop_types_from_anormcode_junk: " + s);
fun say (string: String)
=
global_controls::print::say string;
fun make_var _
=
tmp::issue_highcode_codetemp();
ident = \\ le = le;
fkfun = { loop_info => NULL,
private => FALSE,
inlining_hint => acf::INLINE_WHENEVER_POSSIBLE,
call_as => acf::CALL_AS_FUNCTION hcf::fixed_calling_convention
};
fun make_arrow (ts1, ts2)
=
hcf::make_arrow_uniqtype (hcf::fixed_calling_convention, ts1, ts2);
lt_arw = hcf::make_type_uniqtypoid o hcf::make_arrow_uniqtype;
stipulate
fun wrap_type tc = (NULL, hbo::WRAP, lt_arw (hcf::fixed_calling_convention, [tc], [hcf::truevoid_uniqtype]), []); # 'tc' might be 'type constructor'.
fun unwrap_type tc = (NULL, hbo::UNWRAP, lt_arw (hcf::fixed_calling_convention, [hcf::truevoid_uniqtype], [tc]), []);
herein
fun fu_wrap (tc, vs, v, e) = acf::BASEOP ( wrap_type tc, vs, v, e);
fun fu_unwrap (tc, vs, v, e) = acf::BASEOP (unwrap_type tc, vs, v, e);
end;
fu_rk_tuple = anormcode_junk::rk_tuple;
fun wrap_x (t, u)
=
{ v = make_var();
fu_wrap (t, [u], v, acf::RET [acf::VAR v]);
};
fun unwrap_x (t, u)
=
{ v = make_var();
fu_unwrap (t, [u], v, acf::RET [acf::VAR v]);
};
#############################################################################
# UTILITY FUNCTIONS AND CONSTANTS
#############################################################################
fun split (acf::RET [v])
=>
(v, ident);
split x
=>
{ v = make_var();
(acf::VAR v, \\ z = acf::LET([v], x, z));
};
end;
fun select_g (i, e)
=
{ my (v, header) = split e;
x = make_var();
header (acf::GET_FIELD (v, i, x, acf::RET [acf::VAR x]));
};
fun fn_g (vts, e)
=
{ f = make_var();
acf::MUTUALLY_RECURSIVE_FNS([(fkfun, f, vts, e)], acf::RET [acf::VAR f]);
};
fun select_v (i, u)
=
{ x = make_var();
acf::GET_FIELD (u, i, x, acf::RET [acf::VAR x]);
};
fun app_g (e1, e2)
=
{ my (v1, h1) = split e1;
my (v2, h2) = split e2;
h1 (h2 (acf::APPLY (v1, [v2])));
};
fun record_g es
=
f (es, [], ident)
where
fun f ([], vs, header)
=>
{ x = make_var();
header (acf::RECORD (fu_rk_tuple, reverse vs, x, acf::RET [acf::VAR x]));
};
f (e ! r, vs, header)
=>
{ my (v, h) = split e;
f (r, v ! vs, header o h);
};
end;
end;
fun srecord_g es
=
f (es, [], ident)
where
fun f ([], vs, header)
=>
{ x = make_var();
header (acf::RECORD (acf::RK_PACKAGE, reverse vs, x, acf::RET [acf::VAR x]));
};
f (e ! r, vs, header)
=>
{ my (v, h) = split e;
f (r, v ! vs, header o h);
};
end;
end;
fun wrap_g (z, b, e)
=
{ my (v, h) = split e;
h (wrap_x (z, v));
};
fun unwrap_g (z, b, e)
=
{ my (v, h) = split e;
h (unwrap_x (z, v));
};
fun wrap_cast (z, b, e)
=
{ my (v, h) = split e;
pt = hcf::make_arrow_uniqtypoid (hcf::fixed_calling_convention, [hcf::make_type_uniqtypoid z], [hcf::truevoid_uniqtypoid]);
pv = (NULL, hbo::CAST, pt,[]);
x = make_var();
h (acf::BASEOP (pv, [v], x, acf::RET [acf::VAR x]));
};
fun unwrap_cast (z, b, e)
=
{ my (v, h) = split e;
pt = hcf::make_arrow_uniqtypoid (hcf::fixed_calling_convention, [hcf::truevoid_uniqtypoid], [hcf::make_type_uniqtypoid z]);
pv = (NULL, hbo::CAST, pt,[]);
x = make_var();
h (acf::BASEOP (pv, [v], x, acf::RET [acf::VAR x]));
};
fun switch_g (e, s, ce, d)
=
{ (split e) -> (v, h);
#
h (acf::SWITCH (v, s, ce, d));
};
fun cond (u, e1, e2)
=
u (e1, e2);
/****************************************************************************
* KIND DICTIONARIES *
****************************************************************************/
fun add_ke (kenv, vs, ks)
=
art::add_ke;
/****************************************************************************
* MAIN FUNCTIONS *
****************************************************************************/
/* my tkAbsGen: kenv * List( tmp::Codetemp ) * List( hut::Uniqkind ) * tmp::Codetemp * fkind
-> kenv * ((acf::Expression * acf::Expression) -> acf::Expression) */
# tkAbsGen = art::tkAbsGen
# my tkAbs: kenv * List( tvar * hut::Uniqkind ) -> kenv * (acf::Expression * acf::Expression -> acf::Expression)
tk_abs = art::tk_abs;
# my tkTfn: kenv * List( hut::Uniqkind ) -> kenv * (acf::Expression -> acf::Expression)
#
tk_tfn = art::tk_tfn;
ieq_lexp = art::ieq_lexp;
iadd_lexp = art::iadd_lexp;
tovalue = art::tovalue;
tcode_truevoid = art::tcode_truevoid;
tcode_record = art::tcode_record;
tcode_int1 = art::tcode_int1;
tcode_pair = art::tcode_pair;
tcode_fpair = art::tcode_fpair;
tcode_float64 = art::tcode_float64;
tcode_real_n = art::tcode_real_n;
# tcLexp maps TC_VAR to proper highcode_variables,
# TC_BASE to proper constants
# my tcLexp: kenv -> hut::Uniqtype -> acf::Expression
init_ke = art::init_ke;
tc_lexp = art::rt_lexp;
ts_lexp = art::ts_lexp;
is_float = art::is_float;
is_pair = art::is_pair;
/****************************************************************************
* TYPED INTERPRETATION OF UNTAGGED *
****************************************************************************/
# * tc is of kind Omega; this function tests whether tc can be tagged_int ?
#
fun tc_tag (kenv, tc)
=
loop tc
where
fun loop x # A lot of approximations in this function
=
case (hut::uniqtype_to_type x)
#
hut::type::BASETYPE bt => hbt::basetype_is_unboxed bt ?? ot::NO
:: ot::YES;
# if hbt::ubxupd bt then ot::YES else ot::NO
# this is just an approximation
hut::type::ARROW (_, tc1, tc2) => ot::YES; # ot::NO
hut::type::RECURSIVE(_, i) => ot::YES;
hut::type::TUPLE (_, []) => ot::YES;
hut::type::TUPLE (_, ts) => ot::NO;
hut::type::ABSTRACT tx => loop tx;
hut::type::EXTENSIBLE_TOKEN(_, tx) => loop tx;
hut::type::APPLY_TYPEFUN (tx, _)
=>
case (hut::uniqtype_to_type tx)
#
(hut::type::APPLY_TYPEFUN _ | hut::type::ITH_IN_TYPESEQ _ | hut::type::DEBRUIJN_TYPEVAR _)
=>
ot::MAYBE (tc_lexp kenv x);
_ => ot::YES;
esac;
_ => ot::MAYBE (tc_lexp kenv x);
esac;
end; # fun tc_tag
# my utgc: (hut::Uniqtype, kenv, hut::Uniqtype) -> value -> acf::Expression
#
fun utgc (tc, kenv, rt)
=
case (tc_tag (kenv, tc))
#
ot::YES => \\ u = { v = make_var();
#
acf::RECORD
( fu_rk_tuple,
[u],
v,
wrap_x (hcf::make_tuple_uniqtype [rt], acf::VAR v)
);
};
ot::NO => \\ u = wrap_x (rt, u);
ot::MAYBE ne
=>
\\ u = { v = make_var();
hh = ieq_lexp (ne, tcode_truevoid);
cond ( hh,
acf::RECORD ( fu_rk_tuple,
[u],
v,
wrap_x (hcf::make_tuple_uniqtype [rt], acf::VAR v)
),
wrap_x (rt, u)
);
};
esac;
# my utgd: hut::Uniqtype * kenv * hut::Uniqtype -> value -> acf::Expression:
#
fun utgd (tc, kenv, rt)
=
case (tc_tag (kenv, tc))
#
ot::YES => \\ u = { v = make_var();
z = make_var();
fu_unwrap (hcf::make_tuple_uniqtype [rt], [u], v,
acf::GET_FIELD (acf::VAR v, 0, z, acf::RET [acf::VAR z]));
};
ot::NO => \\ u = unwrap_x (rt, u);
ot::MAYBE ne
=>
\\ u = { v = make_var ();
z = make_var ();
hh = ieq_lexp (ne, tcode_truevoid);
cond (hh, fu_unwrap (hcf::make_tuple_uniqtype [rt], [u], v,
acf::GET_FIELD (acf::VAR v, 0, z, acf::RET [acf::VAR z])),
unwrap_x (rt, u));
};
esac;
# my tgdc: (Int, hut::Uniqtype, kenv, hut::Uniqtype) -> value -> acf::Expression
#
fun tgdc (i, tc, kenv, rt)
=
{ nt = hcf::make_tuple_uniqtype [hcf::int_uniqtype, rt];
#
\\ u = { x = make_var();
#
acf::RECORD (fu_rk_tuple, [acf::INT i, u], x, wrap_x (nt, acf::VAR x));
};
};
# my tgdd: (Int, hut::Uniqtype, kenv, hut::Uniqtype) -> value -> acf::Expression
#
fun tgdd (i, tc, kenv, rt)
=
{ nt = hcf::make_tuple_uniqtype [hcf::int_uniqtype, rt];
#
\\ u = { x = make_var();
v = make_var();
#
fu_unwrap (nt, [u], x, acf::GET_FIELD (acf::VAR x, 1, v, acf::RET [acf::VAR v]));
};
};
/****************************************************************************
* TYPED INTERPRETATION OF FP acf::RECORD *
****************************************************************************/
# tc is a ground hut::Uniqtype of kind Omega,
# only record types also arrow types are
# interesting for the time being.
# All of these wrappers probably should be lifted to the top of the
# program, otherwise we may run into space blow-up ! XXX BUGGO FIXME
# my tc_coerce: (kenv, hut::Uniqtype, Bool, Bool) -> Null_Or( acf::Expression -> acf::Expression )
#
fun tc_coerce (kenv, tc, nt, wflag, b)
=
case ( hut::uniqtype_to_type tc,
hut::uniqtype_to_type nt
)
#
(hut::type::TUPLE (_, ts), _)
=>
h (ts, 0, acf::RET [acf::INT 0], [], 0)
where
fun h ([], i, e, el, 0)
=>
NULL;
h([], i, e, el, result)
=>
THE header
where
w = make_var();
wx = acf::VAR w;
fun g (i, NULL)
=>
select_v (i, wx);
g (i, THE _)
=>
wflag ?? unwrap_g (hcf::float64_uniqtype, b, select_v (i, wx))
:: wrap_g (hcf::float64_uniqtype, b, select_v (i, wx));
end;
ntc = hcf::make_tuple_uniqtype (map (\\ _ = hcf::float64_uniqtype) ts);
ne = record_g (map g (reverse el));
test = ieq_lexp (e, tcode_real_n result);
fun hdr0 xe
=
if wflag cond (test, acf::LET ([w], xe, wrap_cast (ntc, b, ne)), wrap_cast (nt, b, xe));
else cond (test, acf::LET ([w], unwrap_cast (ntc, b, xe), ne), unwrap_cast (nt, b, xe));
fi;
fun header (xe as (acf::RET [(acf::VAR _)]))
=>
hdr0 xe;
header xe
=>
{ z = make_var ();
#
acf::LET([z], xe, hdr0 (acf::RET [acf::VAR z]));
};
end;
end;
h (a ! r, i, e, el, result)
=>
case (is_float (kenv, a) )
#
ot::NO => NULL;
ot::YES => h (r, i+1, e, (i, NULL) ! el, result);
ot::MAYBE z => h (r, i+1, iadd_lexp (e, z),
(i, THE a) ! el, result+1);
esac;
end;
end;
(hut::type::ARROW _, _) # (tc1, tc2) =>
=>
{ my (tc1, _) = hcf::unpack_lambdacode_arrow_uniqtype tc;
my (_, tc2) = hcf::unpack_lambdacode_arrow_uniqtype nt;
case (is_pair (kenv, tc1))
#
(ot::YES | ot::NO) => NULL;
ot::MAYBE e
=>
{ w = make_var ();
#
test1 = ieq_lexp (acf::RET [(acf::VAR w)], tcode_pair);
test2 = ieq_lexp (acf::RET [(acf::VAR w)], tcode_fpair);
m = make_var(); m2 = make_var();
n = make_var(); n2 = make_var();
tc_real = hcf::float64_uniqtype;
tc_breal = hcf::truevoid_uniqtype; # hcf::make_extensible_token_uniqtype tc_real
lt_breal = hcf::make_type_uniqtypoid tc_breal;
tc_truevoid = hcf::truevoid_uniqtype;
lt_truevoid = hcf::truevoid_uniqtypoid;
tc_pair = hcf::make_tuple_uniqtype [tc_truevoid, tc_truevoid];
tc_fpair = hcf::make_tuple_uniqtype [tc_real, tc_real];
tc_bfpair = hcf::make_tuple_uniqtype [tc_breal, tc_breal];
lt_pair = hcf::make_type_uniqtypoid tc_pair;
lt_fpair = hcf::make_type_uniqtypoid tc_fpair;
lt_bfpair = hcf::make_type_uniqtypoid tc_bfpair;
ident = \\ le = le;
my (argt1, body1, hh1)
=
if wflag # wrapping
#
( [(m, lt_truevoid), (m2, lt_truevoid)],
#
\\ sv = { xx = make_var();
yy = make_var();
acf::RECORD (fu_rk_tuple, [acf::VAR m, acf::VAR m2], xx,
fu_wrap (tc_pair, [acf::VAR xx], yy,
acf::APPLY (sv, [acf::VAR yy])));
},
\\ le = wrap_cast
( make_arrow([tc_truevoid, tc_truevoid],[tc2]),
TRUE,
le
)
);
else # unwrapping
x = make_var ();
y = make_var ();
z = make_var ();
( [(m, lt_truevoid)],
#
\\ sv = { xx = make_var();
acf::LET
( [xx],
unwrap_cast
( make_arrow([tc_truevoid, tc_truevoid], [tc2]),
TRUE,
acf::RET [sv]
),
fu_unwrap
( tc_pair,
[acf::VAR m],
x,
acf::GET_FIELD
( acf::VAR x,
0,
y,
acf::GET_FIELD
( acf::VAR x,
1,
z,
acf::APPLY (acf::VAR xx, [acf::VAR y, acf::VAR z])
) ) ) );
},
ident
);
fi;
my (argt2, body2, hh2)
=
if wflag # wrapping
#
( [(n, lt_breal), (n2, lt_breal)],
#
\\ sv = { xx = make_var();
yy = make_var();
acf::LET ( [xx],
record_g [ unwrap_x (tc_real, acf::VAR n),
unwrap_x (tc_real, acf::VAR n2)
],
fu_wrap (tc_fpair, [acf::VAR xx], yy, acf::APPLY (sv, [acf::VAR yy]))
);
},
\\ le = wrap_cast (make_arrow([tc_breal, tc_breal],[tc2]),
TRUE, le)
);
else # unwrapping
x = make_var ();
y = make_var ();
z = make_var ();
q0 = make_var ();
q1 = make_var ();
( [(n, lt_truevoid)],
#
\\ sv = { xx = make_var();
#
acf::LET
( [xx],
unwrap_cast
( make_arrow ([tc_breal, tc_breal], [tc2]),
TRUE,
acf::RET [sv]
),
fu_unwrap
( tc_fpair,
[acf::VAR n],
x,
acf::GET_FIELD
( acf::VAR x,
0,
y,
fu_wrap
( tc_real,
[acf::VAR y],
q0,
acf::GET_FIELD
( acf::VAR x,
1,
z,
fu_wrap
( tc_real,
[acf::VAR z],
q1,
acf::APPLY (acf::VAR xx, [acf::VAR q0, acf::VAR q1])
) ) ) ) ) );
},
ident
);
fi;
hh3 = wflag ?? (\\ le = wrap_cast (nt, TRUE, le))
:: (\\ le = unwrap_cast (nt, TRUE, le));
# ** NEEDS MORE WORK TO DO THE RIGHT COERCIONS ** XXX BUGGO FIXME
#
fun hdr0 (sv)
=
acf::LET([w], e,
cond (test1, hh1 (fn_g (argt1, body1 sv)),
cond (test2, hh2 (fn_g (argt2, body2 sv)),
hh3 (acf::RET [sv]))));
fun header (xe as acf::RET [sv])
=>
hdr0 sv;
header xe
=>
{ z = make_var();
acf::LET([z], xe, hdr0 (acf::VAR z));
};
end;
THE header;
};
esac;
};
_ => NULL;
esac;
# my make_wrap: (hut::Uniqtype, kenv, Bool, hut::Uniqtype) -> acf::Expression -> acf::Expression
#
fun make_wrap (tc, kenv, b, nt)
=
case (tc_coerce (kenv, tc, nt, TRUE, b))
#
THE header => header;
NULL => (\\ le = wrap_g (nt, b, le));
esac;
# my make_unwrap: (hut::Uniqtype, kenv, Bool, hut::Uniqtype) -> acf::Expression -> acf::Expression
#
fun make_unwrap (tc, kenv, b, nt)
=
case (tc_coerce (kenv, tc, nt, FALSE, b))
#
THE header => header;
NULL => (\\ le = unwrap_g (nt, b, le));
esac;
stipulate
get_float64 = hbo::GET_VECSLOT_NUMERIC_CONTENTS { kind_and_size=>hbo::FLOAT 64, checkbounds=>FALSE, immutable=>FALSE };
set_float64 = hbo::SET_VECSLOT_TO_NUMERIC_VALUE { kind_and_size=>hbo::FLOAT 64, checkbounds=>FALSE };
herein
fun lexp_float64_get (vs, t)
=
{ x = make_var ();
#
acf::BASEOP ((NULL, get_float64, t, []), vs, x, acf::RET [acf::VAR x]);
};
fun lexp_float64_set (vs, t)
=
{ x = make_var();
#
acf::BASEOP ((NULL, set_float64, t, []), vs, x, acf::RET [acf::VAR x]);
};
end;
fun lexp_get (vs, t)
=
{ x = make_var ();
#
acf::BASEOP ((NULL, hbo::RW_VECTOR_GET, t, []), vs, x, acf::RET [acf::VAR x]);
};
fun lexp_set (po, vs, t)
=
{ x = make_var();
#
acf::BASEOP ((NULL, po, t, []), vs, x, acf::RET [acf::VAR x]);
};
fun rw_vector_get (tc, kenv, blt, rlt) # Exported fn. 'blt' ~~ 'base(==non-float) lambda type' 'rlt' ~~ 'real(==float) lambda type'
=
{ nt = blt;
rnt = rlt;
case (is_float (kenv, tc))
#
ot::NO => (\\ vs = lexp_get (vs, nt));
ot::YES => (\\ vs = wrap_g (hcf::float64_uniqtype, TRUE, lexp_float64_get (vs, rnt)));
ot::MAYBE z
=>
{ test = ieq_lexp (z, tcode_float64);
(\\ vs =
cond (test, wrap_g (hcf::float64_uniqtype, TRUE, lexp_float64_get (vs, rnt)),
lexp_get (vs, nt)));
};
esac;
};
fun rw_vector_set (tc, kenv, po, blt, rlt) # Exported fn. 'blt' ~~ 'base(==non-float) lambda type' 'rlt' ~~ 'real(==float) lambda type'
=
{ nt = blt;
rnt = rlt;
case (is_float (kenv, tc))
#
ot::NO => (\\ vs = lexp_set (po, vs, nt));
ot::YES =>
f
where
fun f [x, y, z]
=>
{ nz = make_var();
#
acf::LET([nz], unwrap_g (hcf::float64_uniqtype, TRUE, acf::RET [z]), lexp_float64_set ([x, y, acf::VAR nz], rnt));
};
f _
=>
bug "rw_vector_set: ot::YES";
end;
end;
ot::MAYBE z
=>
f
where
test = ieq_lexp (z, tcode_float64);
fun f (vs as [x, y, z])
=>
cond ( test,
{ nz = make_var();
#
acf::LET([nz], unwrap_g (hcf::float64_uniqtype, TRUE, acf::RET [z]), lexp_float64_set ([x, y, acf::VAR nz], rnt));
},
lexp_set (po, vs, nt)
);
f _ => bug "rw_vector_set: ot::MAYBE";
end;
end;
esac;
};
fun make_rw_vector (tc, pv, rv, kenv) # Exported fn. 'rv' ~ 'real(==float) mumble' 'pv' ~ 'non-float mumble' 'kenv'...'continuation symbol table'?
=
case (is_float (kenv, tc))
#
ot::NO => \\ vs = { x = make_var ();
#
acf::LET ([x], app_g (acf::RET [acf::VAR pv], ts_lexp (kenv, [tc])), acf::APPLY (acf::VAR x, vs));
};
ot::YES =>
f
where
fun f (vs as [x, y])
=>
{ z = make_var ();
#
acf::LET ([z], unwrap_g (hcf::float64_uniqtype, TRUE, acf::RET [y]), acf::APPLY (acf::VAR rv, [x, acf::VAR z]));
};
f _ => bug "arrNew: ot::YES";
end;
end;
ot::MAYBE z
=>
f
where
test = ieq_lexp (z, tcode_float64);
#
fun f (vs as [x, y])
=>
cond ( test,
#
{ z = make_var();
#
acf::LET([z], unwrap_g (hcf::float64_uniqtype, TRUE, acf::RET [y]), acf::APPLY (acf::VAR rv, [x, acf::VAR z]));
},
{ z= make_var();
#
acf::LET([z], app_g (acf::RET [acf::VAR pv], ts_lexp (kenv, [tc])), acf::APPLY (acf::VAR z, vs));
}
);
f _ => bug "make_rw_vector: ot::MAYBE";
end;
end;
esac;
}; # package drop_types_from_anormcode_junk
end; # toplevel stipulate