## convert-monoarg-to-multiarg-anormcode.pkg
# Compiled by:
# src/lib/compiler/core.sublib### "Mathematicians stand on each other's shoulders while
### computer scientists stand on each other's toes."
###
### -- R. W. Hamming
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 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 hut = highcode_uniq_types; # highcode_uniq_types is from src/lib/compiler/back/top/highcode/highcode-uniq-types.pkg package lcf = lambdacode_form; # lambdacode_form is from src/lib/compiler/back/top/lambdacode/lambdacode-form.pkgherein
package convert_monoarg_to_multiarg_anormcode
: (weak) Convert_Monoarg_To_Multiarg_Anormcode # Convert_Monoarg_To_Multiarg_Anormcode is from src/lib/compiler/back/top/lambdacode/convert-monoarg-to-multiarg-anormcode.api {
Llty = hut::Uniqtypoid;
Ltyc = hut::Uniqtype;
Flty = hut::Uniqtypoid;
Ftyc = hut::Uniqtype;
Expression = acf::Expression;
Value = acf::Value;
Variable = tmp::Codetemp;
fun bug s = error_message::impossible ("Convert_Monoarg_To_Multiarg_Anormcode:" + s);
make_var = highcode_codetemp::issue_highcode_codetemp;
say = global_controls::print::say;
##############################################################################
# FUNCTIONS USED BY LAMBDACODE TO HIGHCODE NORMALIZATION
##############################################################################
# Recursively turn cooked types
# into raw when possible:
#
fun ltc_raw x = x;
fun tcc_raw x = x;
fun v_punflatten_fn ltys
=
\\ (lv, lambda_expression)
=
{ lvs = map (\\ _ = make_var()) ltys;
( lvs,
acf::RECORD (acj::rk_tuple, map acf::VAR lvs, lv, lambda_expression)
);
};
fun v_pflatten_fn ltys
=
(\\ v
=
{ lvs = map (\\ _ = make_var()) ltys;
( map (\\ v = acf::VAR v) lvs,
\\ lambda_expression
=
#1 (fold_forward
(\\ (lv, (lambda_expression, field'))
=
(acf::GET_FIELD (v, field', lv, lambda_expression), field'+1)
)
(lambda_expression, 0)
lvs
)
);
}
);
v_punflatten_def = \\ (lv, lambda_expression) = ([lv], lambda_expression);
v_pflatten_def = \\ v = ([v], \\ lambda_expression = lambda_expression);
# punflatten: (Variable, Expression) -> List( Variable, Expression)
# turn `lambda_expression' from an expression expecting a single value bound to `Variable'
# to an expression expecting multiple values to be bound to `Variable list'.
# It seems generally more convenient to choose the `Variable list' inside
# bundlefn than outside.
# pflatten: Value -> (List(Value), Expression -> Expression)
# expand `Value' into its flattened `List(Value)' around `Expression'.
# The `List(Value)' might be required in order to construct the
# `Expression' argument, which is why `Value' and `Expression'
# are passed in two steps.
#
fun t_pflatten (lambda_type: Llty)
=
hut::lt_autoflat lambda_type;
fun v_punflatten (lambda_type: Llty)
=
{ my x as (_, ltys, flag)
=
hut::lt_autoflat lambda_type;
( x,
flag ?? v_punflatten_fn ltys
:: v_punflatten_def
);
};
fun v_pflatten (lambda_type: Llty)
=
{ my x as (_, ltys, flag)
=
hut::lt_autoflat lambda_type;
( x,
flag ?? v_pflatten_fn ltys
:: v_pflatten_def
);
};
###############################################################################
# FUNCTIONS USED BY HIGHCODE TYPE SPECIALIZATION
###############################################################################
fun v_unflatten_fn ltys
=
\\ ([lv], lambda_expression)
=>
{ lvs = map (\\ _ = make_var())
ltys;
( lvs,
acf::RECORD
( acj::rk_tuple,
map acf::VAR lvs,
lv,
lambda_expression
)
);
};
_ => bug "unexpected case in v_unflattenGen";
end;
fun v_flatten_fn ltys
=
\\ [v]
=>
{ lvs = map (\\ _ = make_var())
ltys;
( map (\\ x = acf::VAR x) lvs,
\\ lambda_expression
=
#1 (fold_forward (\\ (lv, (lambda_expression, field'))
=
(acf::GET_FIELD (v, field', lv, lambda_expression), field'+1)
)
(lambda_expression, 0)
lvs
)
);
};
_ => bug "unexpected case in v_flatten_fn";
end;
v_unflatten_def
=
\\ (vs, lambda_expression)
=
(vs, lambda_expression);
v_flatten_def
=
\\ vs
=
( vs,
\\ lambda_expression = lambda_expression
);
fun t_flatten ([flty], FALSE) => hut::lt_autoflat flty;
t_flatten ( fltys, TRUE ) => (TRUE, fltys, FALSE);
t_flatten _ => bug "unexpected case in t_flatten";
end;
fun v_unflatten ([flty], FALSE)
=>
{ my x as (_, fltys, flag)
=
hut::lt_autoflat flty;
( x,
flag ?? v_unflatten_fn fltys
:: v_unflatten_def
);
};
v_unflatten (fltys, FALSE) => ((TRUE, fltys, FALSE), v_unflatten_def); # Are these two -intended- to be identical?
v_unflatten (fltys, TRUE ) => ((TRUE, fltys, FALSE), v_unflatten_def); # If so, why not just use v_unflatten (fltys, _) => ... }
end;
fun v_flatten ([flty], FALSE)
=>
{ my x as (_, fltys, flag)
=
hut::lt_autoflat flty;
( x,
flag ?? v_flatten_fn fltys
:: v_flatten_def
);
};
v_flatten (fltys, FALSE) => ((TRUE, fltys, FALSE), v_flatten_def); # Same question as above. :-)
v_flatten (fltys, TRUE ) => ((TRUE, fltys, FALSE), v_flatten_def);
end;
###########################################################################
# FUNCTIONS USED BY HIGHCODE REPRESENTATION ANALYSIS
############################################################################
# NOTE: The implementation of v_coerce
# should be consistent with that
# of v_flattenGen and v_unflattenGen
#
fun v_coerce (wflag, nftcs, oftcs)
=
{ nlen = length nftcs;
olen = length oftcs;
if (nlen == olen)
#
(oftcs, NULL);
elif (nlen == 1 and (olen > 1 or olen == 0))
( [hcf::make_tuple_uniqtype oftcs],
if wflag
#
v = make_var();
THE ( \\ vs = ( [acf::VAR v],
\\ le = acf::RECORD (acj::rk_tuple, vs, v, le)
)
);
else
THE (v_flatten_fn (map hcf::make_type_uniqtypoid oftcs));
fi
);
else
bug "unexpected case in v_coerce";
fi;
}; # function v_coerce
}; # package convert_monoarg_to_multiarg_anormcode
end; # stipulate