## translate-deep-syntax-types-to-lambdacode.pkg
# Compiled by:
# src/lib/compiler/core.sublib# This is a dedicated support utility for translate_deep_syntax_to_lambdacode,
# the only package which references us:
#
# src/lib/compiler/back/top/translate/translate-deep-syntax-to-lambdacode.pkg### "Every really new idea looks crazy at first."
###
### -- Alfred North Whitehead
stipulate
package di = debruijn_index; # debruijn_index is from src/lib/compiler/front/typer/basics/debruijn-index.pkg package hcf = highcode_form; # highcode_form is from src/lib/compiler/back/top/highcode/highcode-form.pkg package hbt = highcode_basetypes; # highcode_basetypes is from src/lib/compiler/back/top/highcode/highcode-basetypes.pkg package hut = highcode_uniq_types; # highcode_uniq_types is from src/lib/compiler/back/top/highcode/highcode-uniq-types.pkg package mld = module_level_declarations; # module_level_declarations is from src/lib/compiler/front/typer-stuff/modules/module-level-declarations.pkg package trj = typer_junk; # typer_junk is from src/lib/compiler/front/typer/main/typer-junk.pkg package tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkgherein
api Translate_Deep_Syntax_Types_To_Lambdacode {
make_deep_syntax_to_lambdacode_type_translator
:
Void
->
{ deepsyntax_typepath_to_uniqkind: tdt::Typepath -> hut::Uniqkind,
deepsyntax_typepath_to_uniqtype: di::Debruijn_Depth -> tdt::Typepath -> hut::Uniqtype,
deepsyntax_type_to_uniqtype: di::Debruijn_Depth -> tdt::Typoid -> hut::Uniqtype,
deepsyntax_typoid_to_uniqtypoid: di::Debruijn_Depth -> tdt::Typoid -> hut::Uniqtypoid,
deepsyntax_package_to_uniqtypoid
:
( mld::Package,
di::Debruijn_Depth,
trj::Per_Compile_Stuff
)
->
hut::Uniqtypoid,
deepsyntax_generic_package_to_uniqtypoid
:
( mld::Generic,
di::Debruijn_Depth,
trj::Per_Compile_Stuff
)
->
hut::Uniqtypoid,
mark_letbound_typevar
:
( di::Debruijn_Depth,
Int
)
->
Int
};
};
end;
stipulate
package da = varhome; # varhome is from src/lib/compiler/front/typer-stuff/basics/varhome.pkg package di = debruijn_index; # debruijn_index is from src/lib/compiler/front/typer/basics/debruijn-index.pkg package epc = stamppath_context; # stamppath_context is from src/lib/compiler/front/typer-stuff/modules/stamppath-context.pkg package err = error_message; # error_message is from src/lib/compiler/front/basics/errormsg/error-message.pkg package ev = expand_generic; # expand_generic is from src/lib/compiler/front/semantic/modules/expand-generic.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 hut = highcode_uniq_types; # highcode_uniq_types is from src/lib/compiler/back/top/highcode/highcode-uniq-types.pkg package ins = generics_expansion_junk; # generics_expansion_junk is from src/lib/compiler/front/semantic/modules/generics-expansion-junk.pkg package ip = inverse_path; # inverse_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg package mj = module_junk; # module_junk is from src/lib/compiler/front/typer-stuff/modules/module-junk.pkg package mld = module_level_declarations; # module_level_declarations is from src/lib/compiler/front/typer-stuff/modules/module-level-declarations.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 syx = symbolmapstack; # symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.pkg package tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg package trd = typer_debugging; # typer_debugging is from src/lib/compiler/front/typer/main/typer-debugging.pkg package tro = typerstore; # typerstore is from src/lib/compiler/front/typer-stuff/modules/typerstore.pkg package tvi = typevar_info; # typevar_info is from src/lib/compiler/front/semantic/types/typevar-info.pkg package tyj = type_junk; # type_junk is from src/lib/compiler/front/typer-stuff/types/type-junk.pkg package ut = unparse_type; # unparse_type is from src/lib/compiler/front/typer/print/unparse-type.pkgherein
package translate_deep_syntax_types_to_lambdacode
: (weak) Translate_Deep_Syntax_Types_To_Lambdacode # Translate_Deep_Syntax_Types_To_Lambdacode is from src/lib/compiler/back/top/translate/translate-deep-syntax-types-to-lambdacode.pkg {
fun bug msg
=
error_message::impossible ("translate_types: " + msg);
say = global_controls::print::say;
debugging = global_controls::compiler::translate_types_debugging;
fun if_debugging_say (msg: String)
=
if *debugging { say msg; say "\n";};
else ();
fi;
debug_print
=
(\\ x = trd::debug_print debugging x);
default_error
=
err::error_no_file (err::default_plaint_sink(), REF FALSE) line_number_db::null_region;
symbolmapstack = syx::empty;
fun prettyprint_type t
=
(pp::with_standard_prettyprinter
#
(err::default_plaint_sink()) []
#
(\\ pp: pp::Prettyprinter
=
{ pp.lit "find: ";
ut::reset_unparse_type();
ut::unparse_typoid symbolmapstack pp t;
}
) )
except _ = say "fail to print anything";
fun prettyprint_type x
=
(pp::with_standard_prettyprinter
#
(err::default_plaint_sink ()) []
#
(\\ pp: pp::Prettyprinter
=
{ pp.lit "find: ";
ut::reset_unparse_type ();
ut::unparse_type symbolmapstack pp x;
}
)
)
except
_ = say "fail to print anything";
#############################################################################
# TRANSLATING SOURCE-LANGUAGE TYPES INTO HIGHCODE TYPES #
#############################################################################
stipulate
rec_ty_context = REF [-1];
herein
fun enter_rec_type (a)
=
(rec_ty_context := (a ! *rec_ty_context));
fun exit_rec_type ()
=
(rec_ty_context := tail *rec_ty_context);
fun rec_type i
=
{ x = head *rec_ty_context;
base = di::innermost;
if (x == 0) hcf::make_debruijn_typevar_uniqtype (base, i);
elif (x > 0) hcf::make_debruijn_typevar_uniqtype (di::di_inner base, i);
else bug "unexpected tdt::RECURSIVE_TYPE";
fi;
};
fun free_type i
=
{ x = head *rec_ty_context;
base = di::di_inner (di::innermost);
if (x == 0)
hcf::make_debruijn_typevar_uniqtype (base, i);
elif (x > 0)
hcf::make_debruijn_typevar_uniqtype (di::di_inner base, i);
else
bug "unexpected tdt::RECURSIVE_TYPE";
fi;
};
end; # end of recTypeConstructor and freeTypeConstructor hack
# typevar_info is from src/lib/compiler/front/semantic/types/typevar-info.pkg fun deepsyntax_typepath_to_uniqkind (tdt::TYPEPATH_VARIABLE x)
=>
(tvi::get_typevar_info x).kind;
deepsyntax_typepath_to_uniqkind _
=>
bug "unexpected Typepath parameters in deepsyntax_typepath_to_uniqkind";
end;
fun make_deep_syntax_to_lambdacode_type_translator ()
=
{ deepsyntax_typepath_to_uniqkind,
deepsyntax_typepath_to_uniqtype,
deepsyntax_type_to_uniqtype,
deepsyntax_typoid_to_uniqtypoid,
deepsyntax_package_to_uniqtypoid,
deepsyntax_generic_package_to_uniqtypoid,
mark_letbound_typevar
}
where
nextmark = REF 0;
markmap = REF int_red_black_map::empty;
# We are marking a LET-bound typevar as a reminder
# to later convert it from most-general type (needed during typechecking)
# to most-specific type (which allows better code optimization).
#
# We save the typevar's de Bruijn (depth, n) pair and
# return a key via which we can later retrieve them. (See next fn.)
#
# This fn is (only) called from translate_deep_syntax_to_lambdacode::translate_pattern_expression in
#
# src/lib/compiler/back/top/translate/translate-deep-syntax-to-lambdacode.pkg #
fun mark_letbound_typevar
( debruijn_depth: di::Debruijn_Depth,
n: Int
)
: Int
=
{ m = *nextmark;
#
nextmark := m + 1;
markmap := int_red_black_map::set (*markmap, m, (debruijn_depth, n));
#
m;
};
# Retrieve a (depth, n) pair stored via
# the above mark_letbound_typevar fn:
#
fun find_letbound_typevar mark
=
case (int_red_black_map::get (*markmap, mark))
#
THE v => v;
NULL => error_message::impossible "transtypes: find_letbound_typevar";
esac;
fun deepsyntax_typepath_to_uniqtype d tp
=
h (tp, d)
where
fun h (tdt::TYPEPATH_VARIABLE x, cur)
=>
{
(tvi::get_typevar_info x)
->
{ debruijn_depth, num, ... };
hcf::make_debruijn_typevar_uniqtype (di::subtract (cur, debruijn_depth), num);
};
h (tdt::TYPEPATH_TYPE tc, cur)
=>
tyc_type (tc, cur);
h (tdt::TYPEPATH_SELECT (tp, i), cur)
=>
hcf::make_ith_in_typeseq_uniqtype (h(tp, cur), i);
h (tdt::TYPEPATH_APPLY (tp, ps), cur)
=>
hcf::make_apply_typefun_uniqtype (h(tp, cur), map (\\ x => h (x, cur); end ) ps);
h (tdt::TYPEPATH_GENERIC (ps, ts), cur) =>
{ ks = map deepsyntax_typepath_to_uniqkind ps;
cur' = di::next cur;
ts' = map (\\ x = h (x, cur'))
ts;
hcf::make_typefun_uniqtype (ks, hcf::make_typeseq_uniqtype ts');
};
end;
end
/*
also tycTypeConstructor x =
compile_statistics::do_phase (compile_statistics::make_phase "Compiler 043 1-tycTypeConstructor") tycTypeConstructor0 x
*/
also
fun tyc_type (tc, d)
=
g tc
where
fun dts_type nd ( { valcons: List( tdt::Valcon_Info ), arity=>i, ... }: tdt::Sumtype_Member)
=
{ nnd = i == 0 ?? nd
:: di::next nd;
fun f ( { domain=>NULL, form, name }, r) => (hcf::void_uniqtype ) ! r;
f ( { domain=>THE t, form, name }, r) => (deepsyntax_type_to_uniqtype nnd t) ! r;
end;
enter_rec_type i;
core = hcf::make_sum_uniqtype (fold_backward f [] valcons);
exit_rec_type();
result_type
=
if (i == 0)
#
core;
else
ks = hcf::n_plaintype_uniqkinds i;
#
hcf::make_typefun_uniqtype (ks, core);
fi;
( hcf::make_n_arg_typefun_uniqkind i,
result_type
);
};
fun dts_fam (free_types, fam as { members, ... }: tdt::Sumtype_Family)
=
case (package_property_lists::dtf_ltyc fam)
#
THE (tc, od)
=>
hcf::change_depth_of_uniqtype (tc, od, d); # Invariant: tc contains no free variables
# so change_depth_of_uniqtype should have no effects.
NULL
=>
{ fun ttk (tdt::SUM_TYPE { arity, ... } )
=>
hcf::make_n_arg_typefun_uniqkind arity;
ttk (tdt::NAMED_TYPE { typescheme=>tdt::TYPESCHEME { arity=>i, ... }, ... } )
=>
hcf::make_n_arg_typefun_uniqkind i;
ttk _
=>
bug "unexpected ttk in dts_fam";
end;
ks = map ttk free_types;
my (nd, header)
=
case ks [] => (d, \\ t = t );
_ => (di::next d, \\ t = hcf::make_typefun_uniqtype (ks, t));
esac;
mbs = vector::fold_backward (!) NIL members;
mtcs = map (dts_type (di::next nd)) mbs;
(paired_lists::unzip mtcs)
->
(fks, fts);
nft = case fts [x] => x;
_ => hcf::make_typeseq_uniqtype fts;
esac;
tc = header (hcf::make_typefun_uniqtype (fks, nft));
package_property_lists::set_dtf_ltyc (fam, THE (tc, d));
tc;
};
esac;
/*
fun dtsFam (_, { lambdatyc=REF (THE (tc, od)), ... } : Sumtype_Family) =
hcf::change_depth_of_uniqtype (tc, od, d) /* invariant: tc contains no free variables so change_depth_of_uniqtype should have no effects */
| dtsFam (free_types, { members, lambdatyc=x, ... } ) =
let fun ttk (tdt::SUM_TYPE { arity, ... } ) = hcf::make_n_arg_typefun_uniqkind arity
| ttk (tdt::NAMED_TYPE { typescheme=tdt::TYPESCHEME { arity=i, ... }, ... } ) = hcf::make_n_arg_typefun_uniqkind i
| ttk _ = bug "unexpected ttk in dtsFam"
ks = map ttk free_types
my (nd, header) =
case ks of [] => (d, \\ t => t)
| _ => (di::next d, \\ t => hcf::make_typefun_uniqtype (ks, t))
mbs = vector::fold_backward (!) NIL members
mtcs = map (dtsTypeConstructor (di::next nd)) mbs
my (fks, fts) = paired_lists::unzip mtcs
nft = case fts of [x] => x | _ => hcf::make_typeseq_uniqtype fts
tc = header (hcf::make_typefun_uniqtype (fks, nft))
(x := THE (tc, d))
in tc
end
*/
fun g (type as tdt::SUM_TYPE { arity, kind, ... } )
=>
case kind
#
k as tdt::SUMTYPE _
=>
tyj::types_are_equal (type, mtt::ref_type)
?? hcf::make_basetype_uniqtype (hbt::basetype_ref)
:: h (k, arity);
k => h (k, arity);
esac;
g (tdt::NAMED_TYPE { typescheme, ... } )
=>
tf_type (typescheme, d);
g (tdt::RECURSIVE_TYPE i) => rec_type i;
g (tdt::FREE_TYPE i) => free_type i;
g (tdt::RECORD_TYPE _)
=>
bug "unexpected tdt::RECORD_TYPE in tycTypeConstructor-g";
g (tdt::TYPE_BY_STAMPPATH { arity, namepath => ip::INVERSE_PATH ss, stamppath } )
=>
{ # say "*** Warning for compiler writers: TYPE_BY_STAMPPATH ";
# apply (\\ x => (say (symbol::name x); say ".")) ss;
# say " in translate: ";
# say (stamppath::macroExpansionPathToString stamppath);
# say "\n";
if (arity > 0) hcf::make_typefun_uniqtype (hcf::n_plaintype_uniqkinds arity, hcf::truevoid_uniqtype);
else hcf::truevoid_uniqtype;
fi;
};
g (tdt::ERRONEOUS_TYPE)
=>
bug "unexpected type in tycTypeConstructor-g";
end
also
fun h (tdt::BASE hbt, _)
=>
hcf::make_basetype_uniqtype (hbt::basetype_from_int hbt);
h (tdt::SUMTYPE { index, family, free_types, stamps, root }, _)
=>
{ tc = dts_fam (free_types, family);
n = vector::length stamps;
# invariant: n should be the length of family members
hcf::make_recursive_uniqtype((n, tc, (map g free_types)), index);
};
h (tdt::ABSTRACT tc, 0)
=>
(g tc);
/* >>> hcf::make_abstract_uniqtype (g tc) <<< */
h (tdt::ABSTRACT tc, n)
=>
(g tc);
# >>> We tempoarily turned off the use of abstract types in
# the intermediate language; proper support of ML-like
# abstract types in the IL may require changes to the
# ML language. (ZHONG)
# let ks = hcf::n_plaintype_uniqkinds n
# fun fromto (i, j) = if i < j then (i ! fromto (i+1, j)) else []
# fs = fromto (0, n)
# ts = map (\\ i => hcf::make_debruijn_typevar_uniqtype (di::innermost, i)) fs
# b = hcf::make_apply_typefun_uniqtype (tycTypeConstructor (tc, di::next d), ts)
# in hcf::make_typefun_uniqtype (ks, hcf::make_abstract_uniqtype b)
# end
# <<<
h (tdt::FLEXIBLE_TYPE tp, _)
=>
deepsyntax_typepath_to_uniqtype d tp;
h (tdt::FORMAL, _)
=>
bug "unexpected FORMAL kind in tycTypeConstructor-h";
h (tdt::TEMP, _)
=>
bug "unexpected TEMP kind in tycTypeConstructor-h";
end;
end
also
fun tf_type (tdt::TYPESCHEME { arity=>0, body }, d)
=>
deepsyntax_type_to_uniqtype d body;
tf_type (tdt::TYPESCHEME { arity, body }, d)
=>
{
ks = hcf::n_plaintype_uniqkinds arity;
hcf::make_typefun_uniqtype (ks, deepsyntax_type_to_uniqtype (di::next d) body);
};
end
also
fun deepsyntax_type_to_uniqtype
(debruijn_depth: di::Debruijn_Depth)
(t: tdt::Typoid)
: hut::Uniqtype
=
{
result = g t;
result;
}
where
# A pair-list mapping variables to types.
# This is a length-64 (max) cache with most
# recently used items sorted to front:
#
var_to_type_cache
=
REF ([]: List( (Ref( tdt::Typevar ), hut::Uniqtype)) );
fun get_ref_typevar_type (tv as { id => _, ref_typevar => type_ref }) # "tv" == "type variable"
=
search_cache (*var_to_type_cache, [], 0)
where
# Get var type from cache if present,
# otherwise compute it via 'h':
#
fun search_cache
( (vt as (type_ref', type)) ! rest, # Remaining cache to check. "vt" == "(vartypoid_ref, type)"
checked, # Cache cells already checked.
checked_len # Length of previous.
)
=>
if (type_ref' == type_ref)
var_to_type_cache := vt ! ((reverse checked) @ rest); # Move 'vt' to front of cache list.
type; # Return cached type for tv.
else
search_cache (rest, vt ! checked, checked_len+1);
fi;
search_cache ([], checked, checked_len)
=>
{ tv_type = h *type_ref; # 'tv' is not in our cache so compute its type honestly.
checked = checked_len > 64 ?? tail checked :: checked; # Idea seems to be to keep a 64-size cache, recently used stuff sorted to front.
var_to_type_cache := (type_ref, tv_type) ! (reverse checked);
tv_type; #
};
end;
end
# translate_deep_syntax_to_lambdacode is from src/lib/compiler/back/top/translate/translate-deep-syntax-to-lambdacode.pkg also
fun h (tdt::RESOLVED_TYPEVAR t) => g t;
h (tdt::META_TYPEVAR _) => hcf::truevoid_uniqtype;
h (tdt::INCOMPLETE_RECORD_TYPEVAR _) => hcf::truevoid_uniqtype;
h (tdt::TYPEVAR_MARK m) # These TYPEVAR_MARK values get set in translate_deep_syntax_to_lambdacode::translate_pattern_expression().
=>
{ (find_letbound_typevar m) -> (depth, num);
#
hcf::make_debruijn_typevar_uniqtype (di::subtract (debruijn_depth, depth), num);
};
h _ => hcf::truevoid_uniqtype; # ZHONG? XXX BUGGO FIXME
end
also
fun g (tdt::TYPEVAR_REF ref_typevar) => /* h *tv */ get_ref_typevar_type ref_typevar;
g (tdt::TYPCON_TYPOID (tdt::RECORD_TYPE _, [])) => hcf::void_uniqtype;
g (tdt::TYPCON_TYPOID (tdt::RECORD_TYPE _, ts)) => hcf::make_tuple_uniqtype (map g ts);
g (tdt::TYPCON_TYPOID (type, [])) => tyc_type (type, debruijn_depth);
g (tdt::TYPCON_TYPOID (tdt::NAMED_TYPE { typescheme, ... }, args)) => g (tyj::apply_typescheme (typescheme, args));
g (tdt::TYPCON_TYPOID (tc as tdt::SUM_TYPE { kind, ... }, ts))
=>
case (kind, ts)
#
(tdt::ABSTRACT _, ts)
=>
hcf::make_apply_typefun_uniqtype (tyc_type (tc, debruijn_depth), map g ts);
(_, [t1, t2])
=>
if (tyj::types_are_equal (tc, mtt::arrow_type) ) hcf::make_lambdacode_arrow_uniqtype (g t1, g t2);
else hcf::make_apply_typefun_uniqtype (tyc_type (tc, debruijn_depth), [g t1, g t2]);
fi;
_ => hcf::make_apply_typefun_uniqtype (tyc_type (tc, debruijn_depth), map g ts);
esac;
g (tdt::TYPCON_TYPOID (type, ts))
=>
hcf::make_apply_typefun_uniqtype
(
tyc_type (type, debruijn_depth),
map g ts
);
g (tdt::TYPESCHEME_ARG i)
=>
hcf::make_debruijn_typevar_uniqtype (di::innermost, i);
g (tdt::TYPESCHEME_TYPOID _) => bug "unexpected poly-type in toTypeConstructor";
g (tdt::UNDEFINED_TYPOID) => bug "unexpected undef-type in toTypeConstructor";
g (tdt::WILDCARD_TYPOID) => bug "unexpected wildcard-type in toTypeConstructor";
end;
end
also
fun deepsyntax_typoid_to_uniqtypoid d (tdt::TYPESCHEME_TYPOID { typescheme=>tdt::TYPESCHEME { arity=>0, body }, ... } )
=>
deepsyntax_typoid_to_uniqtypoid d body;
deepsyntax_typoid_to_uniqtypoid d (tdt::TYPESCHEME_TYPOID { typescheme=>tdt::TYPESCHEME { arity, body }, ... } )
=>
{ ks = hcf::n_plaintype_uniqkinds arity;
hcf::make_typeagnostic_uniqtypoid (ks, [deepsyntax_typoid_to_uniqtypoid (di::next d) body]);
};
deepsyntax_typoid_to_uniqtypoid d x
=>
hcf::make_type_uniqtypoid (deepsyntax_type_to_uniqtype d x);
end;
#############################################################################
# TRANSLATING SOURCE-LANGUAGE MODULES INTO HIGHCODE TYPES #
#############################################################################
fun spec_lty (elements, typerstore, depth, per_compile_stuff)
=
g (elements, typerstore, [])
where
fun g ([], typerstore, ltys)
=>
reverse ltys;
g ((symbol, mld::TYPE_IN_API _) ! rest, typerstore, ltys)
=>
g (rest, typerstore, ltys);
g ((symbol, mld::PACKAGE_IN_API { an_api, module_stamp, ... } ) ! rest, typerstore, ltys)
=>
{ typechecked_package
=
tro::find_package_by_module_stamp
( typerstore,
module_stamp
);
lt = generics_expansion_lambdatype (an_api, typechecked_package, depth, per_compile_stuff);
g (rest, typerstore, lt ! ltys);
};
g ((symbol, mld::GENERIC_IN_API { a_generic_api, module_stamp, ... } ) ! rest, typerstore, ltys)
=>
{ typechecked_package
=
tro::find_generic_by_module_stamp
( typerstore,
module_stamp
);
lt = typechecked_generic_lty (a_generic_api, typechecked_package, depth, per_compile_stuff);
g (rest, typerstore, lt ! ltys);
};
g ((symbol, spec) ! rest, typerstore, ltys)
=>
{ if_debugging_say ">>spec_lty/g/TOP";
fun transty type
=
(mj::translate_typoid typerstore type)
except
tro::UNBOUND
=
{ if_debugging_say " + spec_lty";
trd::with_internals
(\\ () =
debug_print( "typerstore: ",
(\\ pps =
\\ ee =
unparse_package_language::unparse_typerstore pps (ee, syx::empty, 12)
),
typerstore
)
);
if_debugging_say (" + spec_lty: should have printed typerstore");
raise exception tro::UNBOUND;
};
fun mapty t
=
deepsyntax_typoid_to_uniqtypoid depth (transty t);
case spec
#
mld::VALUE_IN_API { typoid, ... }
=>
g (rest, typerstore, (mapty typoid) ! ltys);
mld::VALCON_IN_API
{
sumtype => tdt::VALCON
{
form => da::EXCEPTION _,
typoid,
...
},
...
}
=>
{ argt = mtt::is_arrow_type typoid
?? #1 (hcf::unpack_lambdacode_arrow_uniqtypoid (mapty typoid))
:: hcf::void_uniqtypoid;
g (rest, typerstore, (hcf::make_exception_tag_uniqtypoid argt) ! ltys);
};
mld::VALCON_IN_API { sumtype => tdt::VALCON _, ... }
=>
g (rest, typerstore, ltys);
_ => bug "unexpected spec in spec_lty";
esac;
};
end;
end
# also
# signLty (an_api, depth, per_compile_stuff)
# =
# let fun h (BEGIN_API { kind=THE _, lambdaty=REF (THE (lt, od)), ... } ) = lt
# # hcf::change_depth_of_uniqtypoid (lt, od, depth)
# | h (an_api as BEGIN_API { kind=THE _, lambdaty as REF NULL, ... } ) =
# # Invariant: we assum that all named APIs (kind=THE _) are
# # defined at top-level, outside any generic package definitions. (ZHONG)
#
# let my { typechecked_package = typechecked_package, typeConstructorPaths=typeConstructorPaths } =
# INS::doPkgFunParameterApi { an_api=sign, typerstore=tro::empty, depth=depth,
# inverse_path = ip::INVERSE_PATH[], per_compile_stuff=per_compile_stuff,
# source_code_region=line_number_db::nullRegion }
# nd = di::next depth
# nlty = strMetaLty (an_api, typechecked_package, nd, per_compile_stuff)
#
# ks = map tpsKnd typeConstructorPaths
# lt = hcf::make_typeagnostic_uniqtypoid (ks, nlty)
# in lambdaty := THE (lt, depth); lt
# end
# | h _ = bug "unexpected an_api in signLty"
# in h an_api
# end
also
fun package_meta_lty (an_api, typechecked_package as { typerstore, ... }: mld::Typechecked_Package, depth, per_compile_stuff)
=
case (an_api, package_property_lists::generics_expansion_lambdatype typechecked_package)
#
(_, THE (lt, od))
=>
hcf::change_depth_of_uniqtypoid (lt, od, depth);
(mld::API { api_elements, ... }, NULL)
=>
{ ltys = spec_lty (api_elements, typerstore, depth, per_compile_stuff);
lt = /* case ltys of [] => hcf::int_uniqtypoid
| _ => */ hcf::make_package_uniqtypoid (ltys);
package_property_lists::set_generics_expansion_lty (typechecked_package, THE (lt, depth));
lt;
};
_ => bug "unexpected an_api and typechecked_package in strMetaLty";
esac
also
fun generics_expansion_lambdatype (an_api, typechecked_package: mld::Typechecked_Package, depth, per_compile_stuff)
=
case (an_api, package_property_lists::generics_expansion_lambdatype typechecked_package)
(an_api, THE (lt, od))
=>
hcf::change_depth_of_uniqtypoid (lt, od, depth);
# Note: the code here is designed to improve the "deepsyntax_typoid_to_uniqtypoid" translation;
# by translating the api instead of the package, this can
# potentially save time on str_lty. But it can increase the cost of
# other procedures. Thus we turn it off temporarily. (ZHONG) XXX BUGGO FIXME
#
# | (API { kind=THE _, ... }, { lambdaty, ... } ) =>
# let sgt = signLty (an_api, depth, per_compile_stuff)
# # Invariant: we assum that all named APIs
# # (kind=THE _) are defined at top-level, outside any
# # generic package definitions. (ZHONG)
# #
# parameterTypes = INS::get_packages_typepaths { an_api=sign, typechecked_package = typechecked_package,
# typerstore=tro::empty, per_compile_stuff=per_compile_stuff }
# lt = hcf::macroExpandTypeagnosticLambdaTypeOrHOC (sgt, map (tpsTypeConstructor depth) parameterTypes)
# in lambdaty := THE (lt, depth); lt
# end
_ => package_meta_lty (an_api, typechecked_package, depth, per_compile_stuff);
esac
also
fun typechecked_generic_lty (an_api, typechecked_package, debruijn_depth, per_compile_stuff)
=
case (an_api, package_property_lists::typechecked_generic_lty typechecked_package, typechecked_package)
#
(an_api, THE (lt, od), _)
=>
hcf::change_depth_of_uniqtypoid (lt, od, debruijn_depth);
( mld::GENERIC_API { parameter_api, body_api, ... },
_,
{ generic_closure as mld::GENERIC_CLOSURE { typerstore=>symbolmapstack, ... }, ... }
)
=>
{ my { typechecked_package => argument_typechecked_package,
typepaths
}
=
ins::do_generic_parameter_api
{
an_api => parameter_api,
typerstore => symbolmapstack,
inverse_path => ip::INVERSE_PATH [],
source_code_region => line_number_db::null_region,
debruijn_depth,
per_compile_stuff
};
debruijn_depth' = di::next debruijn_depth;
param_lty
=
package_meta_lty
( parameter_api,
argument_typechecked_package,
debruijn_depth',
per_compile_stuff
);
ks = map deepsyntax_typepath_to_uniqkind typepaths;
body_typechecked_package
=
ev::expand_generic
( typechecked_package,
argument_typechecked_package,
debruijn_depth',
epc::init_context,
ip::empty,
per_compile_stuff
);
body_lty
=
generics_expansion_lambdatype
( body_api,
body_typechecked_package,
debruijn_depth',
per_compile_stuff
);
lt = hcf::make_typeagnostic_uniqtypoid (ks, [hcf::make_generic_package_uniqtypoid([param_lty],[body_lty])]);
package_property_lists::set_typechecked_generic_lty (typechecked_package, THE (lt, debruijn_depth));
lt;
};
_ => bug "genericMacroExpansionLty";
esac
also
fun deepsyntax_package_to_uniqtypoid (pkg as mld::A_PACKAGE { an_api, typechecked_package, ... }, depth, per_compile_stuff)
=>
case (package_property_lists::generics_expansion_lambdatype typechecked_package)
THE (lt, od)
=>
hcf::change_depth_of_uniqtypoid (lt, od, depth);
NULL
=>
{ lt = generics_expansion_lambdatype (an_api, typechecked_package, depth, per_compile_stuff);
package_property_lists::set_generics_expansion_lty (typechecked_package, THE (lt, depth));
lt;
};
esac;
deepsyntax_package_to_uniqtypoid _
=>
bug "unexpected package in deepsyntax_package_to_uniqtypoid";
end
also
fun deepsyntax_generic_package_to_uniqtypoid (mld::GENERIC { a_generic_api, typechecked_generic, ... }, depth, per_compile_stuff)
=>
case (package_property_lists::typechecked_generic_lty typechecked_generic)
#
THE (lt, od)
=>
hcf::change_depth_of_uniqtypoid (lt, od, depth);
NULL
=>
{ lt = typechecked_generic_lty (a_generic_api, typechecked_generic, depth, per_compile_stuff);
package_property_lists::set_typechecked_generic_lty (typechecked_generic, THE (lt, depth));
lt;
};
esac;
deepsyntax_generic_package_to_uniqtypoid _ => bug "unexpected generic package in deepsyntax_generic_package_to_uniqtypoid";
end;
/****************************************************************************
* A HASH-CONSING VERSION OF THE ABOVE TRANSLATIONS *
****************************************************************************/
/*
package mi_dictionary
=
red_black_map_g (pkg type Key = stampmapstack::modId
compare = stampmapstack::cmp
end)
*/
/*
m1 = REF (MIDict::mkDict()) # modid (Type) -> hut::Uniqtype
m2 = REF (MIDict::mkDict()) # modid (str/fct) -> hut::Uniqtypoid
fun tycTypeConstructorLook (t as (tdt::SUM_TYPE _ | tdt::NAMED_TYPE _), d) =
let tid = mj::type_identifier t
in (case MIDict::peek (*m1, tid)
of THE (t', od) => hcf::change_depth_of_uniqtype (t', od, d)
| NULL =>
let x = tycTypeConstructor (t, d)
(m1 := TcDict::set (*m1, tid, (x, d)))
in x
end)
end
| tycTypeConstructorLook x = tycTypeConstructor tycTypeConstructorLook x
/*
toTypeConstructor = toTypeConstructor tycTypeConstructorLook
deepsyntax_typoid_to_uniqtypoid = toTypeConstructor tycTypeConstructorLook
*/
coreDict = (toTypeConstructor, deepsyntax_typoid_to_uniqtypoid)
fun strLtyLook (s as A_PACKAGE _, d) =
let sid = mj::package_identifier s
in (case MIDict::peek (*m2, sid)
of THE (t', od) => hcf::change_depth_of_uniqtypoid (t', od, d)
| NULL =>
let x = strLty (coreDict, strLtyLook,
genericLtyLook) (s, d)
(m2 := TcDict::set (*m2, sid, (x, d)))
in x
end)
end
| strLtyLook x = strLty (coreDict, strLtyLook, genericLtyLook)
also
genericLtyLook (f as GENERIC _, d)
=
let fid = generic_identifier f
in
( case MIDict::peek (*m2, fid)
of THE (t', od)
=>
hcf::change_depth_of_uniqtypoid (t', od, d)
| NULL
=>
let x = genericLty (tycTypeConstructorLook, strLtyLook,
genericLtyLook) (s, d)
(m2 := TcDict::set (*m2, fid, (x, d)))
in x
end
)
end
| genericLtyLook x = genericLty (coreDict, strLtyLook, genericLtyLook)
*/
end; # fun make_deep_syntax_to_lambdacode_type_translator
}; # package translate_types
end;