## 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 ty = types; # types is from src/lib/compiler/front/typer-stuff/types/types.pkgherein
api Translate_Deep_Syntax_Types_To_Lambdacode {
make_deep_syntax_to_lambdacode_type_translator
:
Void
->
{ deepsyntax_typpath_to_uniqkind: ty::Typ_Path -> hut::Uniqkind,
deepsyntax_typpath_to_uniqtyp: di::Debruijn_Depth -> ty::Typ_Path -> hut::Uniqtyp,
deepsyntax_type_to_uniqtyp: di::Debruijn_Depth -> ty::Type -> hut::Uniqtyp,
deepsyntax_type_to_uniqtype: di::Debruijn_Depth -> ty::Type -> hut::Uniqtype,
deepsyntax_package_to_uniqtype
:
( mld::Package,
di::Debruijn_Depth,
trj::Per_Compile_Info
)
->
hut::Uniqtype,
deepsyntax_generic_package_to_uniqtype
:
( mld::Generic,
di::Debruijn_Depth,
trj::Per_Compile_Info
)
->
hut::Uniqtype,
mark_letbound_typevar
:
( di::Debruijn_Depth,
Int
)
->
Int
};
};
end;
stipulate
package bt = type_types; # type_types is from src/lib/compiler/front/typer/types/type-types.pkg 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 err = error_message; # error_message is from src/lib/compiler/front/basics/errormsg/error-message.pkg package epc = stamppath_context; # stamppath_context is from src/lib/compiler/front/typer-stuff/modules/stamppath-context.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 syx = symbolmapstack; # symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.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 ty = types; # types is from src/lib/compiler/front/typer-stuff/types/types.pkg package tyj = type_junk; # type_junk is from src/lib/compiler/front/typer-stuff/types/type-junk.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
=
(fn x = trd::debug_print debugging x);
default_error
=
err::error_no_file (err::default_plaint_sink(), REF FALSE) line_number_db::null_region;
stipulate
package pp= prettyprint; # prettyprint is from src/lib/prettyprint/big/src/prettyprint.pkg herein
symbolmapstack = symbolmapstack::empty;
fun prettyprint_type t
=
(pp::with_prettyprint_device (err::default_plaint_sink())
(fn stream = { pp::string stream "find: ";
unparse_type::reset_unparse_type();
unparse_type::unparse_type symbolmapstack stream t;
}
) )
except _ = say "fail to print anything";
fun prettyprint_type x
=
(pp::with_prettyprint_device (err::default_plaint_sink ())
(fn stream = { pp::string stream "find: ";
unparse_type::reset_unparse_type ();
unparse_type::unparse_typ symbolmapstack stream x;
}
)
)
except
_ = say "fail to print anything";
end;
#############################################################################
# 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_typ (i)
=
{ x = head *rec_ty_context;
base = di::innermost;
if (x == 0) hcf::make_debruijn_typevar_uniqtyp (base, i);
elif (x > 0) hcf::make_debruijn_typevar_uniqtyp (di::di_inner base, i);
else bug "unexpected ty::RECURSIVE_TYPE";
fi;
};
fun free_typ (i)
=
{ x = head *rec_ty_context;
base = di::di_inner (di::innermost);
if (x == 0)
hcf::make_debruijn_typevar_uniqtyp (base, i);
elif (x > 0)
hcf::make_debruijn_typevar_uniqtyp (di::di_inner base, i);
else
bug "unexpected ty::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_typpath_to_uniqkind (ty::TYPPATH_VARIABLE x)
=>
(tvi::get_typevar_info x).kind;
deepsyntax_typpath_to_uniqkind _
=>
bug "unexpected Typ_Path parameters in deepsyntax_typpath_to_uniqkind";
end;
fun make_deep_syntax_to_lambdacode_type_translator ()
=
{ deepsyntax_typpath_to_uniqkind,
deepsyntax_typpath_to_uniqtyp,
deepsyntax_type_to_uniqtyp,
deepsyntax_type_to_uniqtype,
deepsyntax_package_to_uniqtype,
deepsyntax_generic_package_to_uniqtype,
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_typpath_to_uniqtyp d tp
=
h (tp, d)
where
fun h (ty::TYPPATH_VARIABLE x, cur)
=>
{
(tvi::get_typevar_info x)
->
{ debruijn_depth, num, ... };
hcf::make_debruijn_typevar_uniqtyp (di::subtract (cur, debruijn_depth), num);
};
h (ty::TYPPATH_TYP tc, cur)
=>
tyc_typ (tc, cur);
h (ty::TYPPATH_SELECT (tp, i), cur)
=>
hcf::make_ith_in_typeseq_uniqtyp (h(tp, cur), i);
h (ty::TYPPATH_APPLY (tp, ps), cur)
=>
hcf::make_apply_typefun_uniqtyp (h(tp, cur), map (fn x => h (x, cur); end ) ps);
h (ty::TYPPATH_GENERIC (ps, ts), cur) =>
{ ks = map deepsyntax_typpath_to_uniqkind ps;
cur' = di::next cur;
ts' = map (fn x = h (x, cur'))
ts;
hcf::make_typefun_uniqtyp (ks, hcf::make_typeseq_uniqtyp ts');
};
end;
end
/*
also tycTypeConstructor x =
compile_statistics::do_phase (compile_statistics::make_phase "Compiler 043 1-tycTypeConstructor") tycTypeConstructor0 x
*/
also
fun tyc_typ (tc, d)
=
g tc
where
fun dts_typ nd ( { constructor_list: List( ty::Constructor_Description ), arity=>i, ... }: ty::Datatype_Member)
=
{ nnd = i == 0 ?? nd
:: di::next nd;
fun f ( { domain=>NULL, form, name }, r) => (hcf::void_uniqtyp ) ! r;
f ( { domain=>THE t, form, name }, r) => (deepsyntax_type_to_uniqtyp nnd t) ! r;
end;
enter_rec_type i;
core = hcf::make_sum_uniqtyp (fold_right f [] constructor_list);
exit_rec_type();
result_typ
=
if (i == 0)
#
core;
else
ks = hcf::n_plaintype_uniqkinds i;
#
hcf::make_typefun_uniqtyp (ks, core);
fi;
( hcf::make_n_arg_typ_fun_uniqkind i,
result_typ
);
};
fun dts_fam (free_typs, fam as { members, ... }: ty::Datatype_Family)
=
case (package_property_lists::dtf_ltyc fam)
THE (tc, od)
=>
hcf::change_depth_of_uniqtyp (tc, od, d); # Invariant: tc contains no free variables
# so change_depth_of_uniqtyp should have no effects.
NULL
=>
{ fun ttk (ty::PLAIN_TYP { arity, ... } )
=>
hcf::make_n_arg_typ_fun_uniqkind arity;
ttk (ty::DEFINED_TYP { type_scheme=>ty::TYPE_SCHEME { arity=>i, ... }, ... } )
=>
hcf::make_n_arg_typ_fun_uniqkind i;
ttk _
=>
bug "unexpected ttk in dts_fam";
end;
ks = map ttk free_typs;
my (nd, header)
=
case ks [] => (d, fn t = t );
_ => (di::next d, fn t = hcf::make_typefun_uniqtyp (ks, t));
esac;
mbs = vector::fold_right (!) NIL members;
mtcs = map (dts_typ (di::next nd)) mbs;
my (fks, fts)
=
paired_lists::unzip mtcs;
nft = case fts [x] => x;
_ => hcf::make_typeseq_uniqtyp fts;
esac;
tc = header (hcf::make_typefun_uniqtyp (fks, nft));
package_property_lists::set_dtf_ltyc (fam, THE (tc, d));
tc;
};
esac;
/*
fun dtsFam (_, { lambdatyc=REF (THE (tc, od)), ... } : Datatype_Family) =
hcf::change_depth_of_uniqtyp (tc, od, d) /* invariant: tc contains no free variables so change_depth_of_uniqtyp should have no effects */
| dtsFam (free_typs, { members, lambdatyc=x, ... } ) =
let fun ttk (ty::PLAIN_TYP { arity, ... } ) = hcf::make_n_arg_typ_fun_uniqkind arity
| ttk (ty::DEFINED_TYP { type_scheme=ty::TYPE_SCHEME { arity=i, ... }, ... } ) = hcf::make_n_arg_typ_fun_uniqkind i
| ttk _ = bug "unexpected ttk in dtsFam"
ks = map ttk free_typs
my (nd, header) =
case ks of [] => (d, fn t => t)
| _ => (di::next d, fn t => hcf::make_typefun_uniqtyp (ks, t))
mbs = vector::fold_right (!) 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_uniqtyp fts
tc = header (hcf::make_typefun_uniqtyp (fks, nft))
(x := THE (tc, d))
in tc
end
*/
fun g (typ as ty::PLAIN_TYP { arity, kind, ... } )
=>
case kind
#
k as ty::DATATYPE _
=>
tyj::typs_are_equal (typ, bt::ref_typ)
?? hcf::make_basetype_uniqtyp (hbt::basetype_ref)
:: h (k, arity);
k => h (k, arity);
esac;
g (ty::DEFINED_TYP { type_scheme, ... } )
=>
tf_typ (type_scheme, d);
g (ty::RECURSIVE_TYPE i) => rec_typ i;
g (ty::FREE_TYPE i) => free_typ i;
g (ty::RECORD_TYP _)
=>
bug "unexpected ty::RECORD_TYP in tycTypeConstructor-g";
g (ty::TYP_BY_STAMPPATH { arity, path=>inverse_path::INVERSE_PATH ss, stamppath } )
=>
{ # say "*** Warning for compiler writers: TYP_BY_STAMPPATH ";
# apply (fn x => (say (symbol::name x); say ".")) ss;
# say " in translate: ";
# say (stamppath::macroExpansionPathToString stamppath);
# say "\n";
if (arity > 0) hcf::make_typefun_uniqtyp (hcf::n_plaintype_uniqkinds arity, hcf::truevoid_uniqtyp);
else hcf::truevoid_uniqtyp;
fi;
};
g (ty::ERRONEOUS_TYP)
=>
bug "unexpected typ in tycTypeConstructor-g";
end
also
fun h (ty::BASE hbt, _)
=>
hcf::make_basetype_uniqtyp (hbt::basetype_from_int hbt);
h (ty::DATATYPE { index, family, free_typs, stamps, root }, _)
=>
{ tc = dts_fam (free_typs, family);
n = vector::length stamps;
# invariant: n should be the length of family members
hcf::make_recursive_uniqtyp((n, tc, (map g free_typs)), index);
};
h (ty::ABSTRACT tc, 0)
=>
(g tc);
/* >>> hcf::make_abstract_uniqtyp (g tc) <<< */
h (ty::ABSTRACT tc, n)
=>
(g tc);
# >>> We tempoarily turned off the use of abstract typs 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 (fn i => hcf::make_debruijn_typevar_uniqtyp (di::innermost, i)) fs
# b = hcf::make_apply_typefun_uniqtyp (tycTypeConstructor (tc, di::next d), ts)
# in hcf::make_typefun_uniqtyp (ks, hcf::make_abstract_uniqtyp b)
# end
# <<<
h (ty::FLEXIBLE_TYP tp, _)
=>
deepsyntax_typpath_to_uniqtyp d tp;
h (ty::FORMAL, _)
=>
bug "unexpected FORMAL kind in tycTypeConstructor-h";
h (ty::TEMP, _)
=>
bug "unexpected TEMP kind in tycTypeConstructor-h";
end;
end
also
fun tf_typ (ty::TYPE_SCHEME { arity=>0, body }, d)
=>
deepsyntax_type_to_uniqtyp d body;
tf_typ (ty::TYPE_SCHEME { arity, body }, d)
=>
{
ks = hcf::n_plaintype_uniqkinds arity;
hcf::make_typefun_uniqtyp (ks, deepsyntax_type_to_uniqtyp (di::next d) body);
};
end
also
fun deepsyntax_type_to_uniqtyp
(debruijn_depth: di::Debruijn_Depth)
(t: ty::Type)
: hut::Uniqtyp
=
{
if_debugging_say "\ndeepsyntax_type_to_uniqtyp/TOP in translate-deep-syntax-types-to-lambdacode.pkg";
result = g t;
if_debugging_say "deepsyntax_type_to_uniqtyp/BOTTOM in translate-deep-syntax-types-to-lambdacode.pkg";
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( ty::Type_Variable ), hut::Uniqtyp)) );
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" == "(type_var, 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 (ty::RESOLVED_TYPE_VARIABLE t) => g t;
h (ty::META_TYPE_VARIABLE _) => hcf::truevoid_uniqtyp;
h (ty::INCOMPLETE_RECORD_TYPE_VARIABLE _) => hcf::truevoid_uniqtyp;
h (ty::TYPE_VARIABLE_MARK m) # These TYPE_VARIABLE_MARK values get set in translate_deep_syntax_to_lambdacode::translate_pattern_expression().
=>
{ (find_letbound_typevar m) -> (depth, num);
#
hcf::make_debruijn_typevar_uniqtyp (di::subtract (debruijn_depth, depth), num);
};
h _ => hcf::truevoid_uniqtyp; # ZHONG? XXX BUGGO FIXME
end
also
fun g (ty::TYPE_VARIABLE_REF ref_typevar) => /* h *tv */ get_ref_typevar_type ref_typevar;
g (ty::TYPCON_TYPE (ty::RECORD_TYP _, [])) => hcf::void_uniqtyp;
g (ty::TYPCON_TYPE (ty::RECORD_TYP _, ts)) => hcf::make_tuple_uniqtyp (map g ts);
g (ty::TYPCON_TYPE (typ, [])) => tyc_typ (typ, debruijn_depth);
g (ty::TYPCON_TYPE (ty::DEFINED_TYP { type_scheme, ... }, args)) => g (tyj::apply_type_scheme (type_scheme, args));
g (ty::TYPCON_TYPE (tc as ty::PLAIN_TYP { kind, ... }, ts))
=>
case (kind, ts)
#
(ty::ABSTRACT _, ts)
=>
hcf::make_apply_typefun_uniqtyp (tyc_typ (tc, debruijn_depth), map g ts);
(_, [t1, t2])
=>
if (tyj::typs_are_equal (tc, bt::arrow_typ) ) hcf::make_lambdacode_arrow_uniqtyp (g t1, g t2);
else hcf::make_apply_typefun_uniqtyp (tyc_typ (tc, debruijn_depth), [g t1, g t2]);
fi;
_ => hcf::make_apply_typefun_uniqtyp (tyc_typ (tc, debruijn_depth), map g ts);
esac;
g (ty::TYPCON_TYPE (typ, ts))
=>
hcf::make_apply_typefun_uniqtyp
(
tyc_typ (typ, debruijn_depth),
map g ts
);
g (ty::TYPE_SCHEME_ARG_I i)
=>
hcf::make_debruijn_typevar_uniqtyp (di::innermost, i);
g (ty::TYPE_SCHEME_TYPE _) => bug "unexpected poly-type in toTypeConstructor";
g (ty::UNDEFINED_TYPE) => bug "unexpected undef-type in toTypeConstructor";
g (ty::WILDCARD_TYPE) => bug "unexpected wildcard-type in toTypeConstructor";
end;
end
also
fun deepsyntax_type_to_uniqtype d (ty::TYPE_SCHEME_TYPE { type_scheme=>ty::TYPE_SCHEME { arity=>0, body }, ... } )
=>
deepsyntax_type_to_uniqtype d body;
deepsyntax_type_to_uniqtype d (ty::TYPE_SCHEME_TYPE { type_scheme=>ty::TYPE_SCHEME { arity, body }, ... } )
=>
{ ks = hcf::n_plaintype_uniqkinds arity;
hcf::make_typeagnostic_uniqtype (ks, [deepsyntax_type_to_uniqtype (di::next d) body]);
};
deepsyntax_type_to_uniqtype d x
=>
hcf::make_typ_uniqtype (deepsyntax_type_to_uniqtyp d x);
end;
#############################################################################
# TRANSLATING SOURCE-LANGUAGE MODULES INTO HIGHCODE TYPES #
#############################################################################
fun spec_lty (elements, typerstore, depth, per_compile_info)
=
g (elements, typerstore, [])
where
fun g ([], typerstore, ltys)
=>
reverse ltys;
g ((symbol, mld::TYP_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_info);
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_info);
g (rest, typerstore, lt ! ltys);
};
g ((symbol, spec) ! rest, typerstore, ltys)
=>
{ if_debugging_say ">>spec_lty/g/TOP";
fun transty type
=
(mj::translate_type typerstore type)
except
tro::UNBOUND
=
{ if_debugging_say " + spec_lty";
trd::with_internals
(fn () =
debug_print( "typerstore: ",
(fn pps =
fn 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_type_to_uniqtype depth (transty t);
case spec
#
mld::VALUE_IN_API { type, ... }
=>
g (rest, typerstore, (mapty type) ! ltys);
mld::VALCON_IN_API
{
datatype => ty::VALCON
{
form => da::EXCEPTION _,
type,
...
},
...
}
=>
{ argt = bt::is_arrow_type type
?? #1 (hcf::unpack_lambdacode_arrow_uniqtype (mapty type))
:: hcf::void_uniqtype;
g (rest, typerstore, (hcf::make_exception_tag_uniqtype argt) ! ltys);
};
mld::VALCON_IN_API { datatype => ty::VALCON _, ... }
=>
g (rest, typerstore, ltys);
_ => bug "unexpected spec in spec_lty";
esac;
};
end;
end
# also
# signLty (an_api, depth, per_compile_info)
# =
# let fun h (BEGIN_API { kind=THE _, lambdaty=REF (THE (lt, od)), ... } ) = lt
# # hcf::change_depth_of_uniqtype (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 = inverse_path::INVERSE_PATH[], per_compile_info=per_compile_info,
# source_code_region=line_number_db::nullRegion }
# nd = di::next depth
# nlty = strMetaLty (an_api, typechecked_package, nd, per_compile_info)
#
# ks = map tpsKnd typeConstructorPaths
# lt = hcf::make_typeagnostic_uniqtype (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_info)
=
case (an_api, package_property_lists::generics_expansion_lambdatype typechecked_package)
#
(_, THE (lt, od))
=>
hcf::change_depth_of_uniqtype (lt, od, depth);
(mld::API { api_elements, ... }, NULL)
=>
{ ltys = spec_lty (api_elements, typerstore, depth, per_compile_info);
lt = /* case ltys of [] => hcf::int_uniqtype
| _ => */ hcf::make_package_uniqtype (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_info)
=
case (an_api, package_property_lists::generics_expansion_lambdatype typechecked_package)
(an_api, THE (lt, od))
=>
hcf::change_depth_of_uniqtype (lt, od, depth);
# Note: the code here is designed to improve the "deepsyntax_type_to_uniqtype" 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_info)
# # Invariant: we assum that all named APIs
# # (kind=THE _) are defined at top-level, outside any
# # generic package definitions. (ZHONG)
# #
# parameterTypes = INS::get_packages_typ_paths { an_api=sign, typechecked_package = typechecked_package,
# typerstore=tro::empty, per_compile_info=per_compile_info }
# 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_info);
esac
also
fun typechecked_generic_lty (an_api, typechecked_package, debruijn_depth, per_compile_info)
=
case (an_api, package_property_lists::typechecked_generic_lty typechecked_package, typechecked_package)
#
(an_api, THE (lt, od), _)
=>
hcf::change_depth_of_uniqtype (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,
typ_paths
}
=
ins::do_generic_parameter_api
{
an_api => parameter_api,
typerstore => symbolmapstack,
inverse_path => inverse_path::INVERSE_PATH [],
source_code_region => line_number_db::null_region,
debruijn_depth,
per_compile_info
};
debruijn_depth' = di::next debruijn_depth;
param_lty
=
package_meta_lty
( parameter_api,
argument_typechecked_package,
debruijn_depth',
per_compile_info
);
ks = map deepsyntax_typpath_to_uniqkind typ_paths;
body_typechecked_package
=
ev::expand_generic
( typechecked_package,
argument_typechecked_package,
debruijn_depth',
epc::init_context,
ip::empty,
per_compile_info
);
body_lty
=
generics_expansion_lambdatype
( body_api,
body_typechecked_package,
debruijn_depth',
per_compile_info
);
lt = hcf::make_typeagnostic_uniqtype (ks, [hcf::make_generic_package_uniqtype([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_uniqtype (pkg as mld::A_PACKAGE { an_api, typechecked_package, ... }, depth, per_compile_info)
=>
case (package_property_lists::generics_expansion_lambdatype typechecked_package)
THE (lt, od)
=>
hcf::change_depth_of_uniqtype (lt, od, depth);
NULL
=>
{ lt = generics_expansion_lambdatype (an_api, typechecked_package, depth, per_compile_info);
package_property_lists::set_generics_expansion_lty (typechecked_package, THE (lt, depth));
lt;
};
esac;
deepsyntax_package_to_uniqtype _
=>
bug "unexpected package in deepsyntax_package_to_uniqtype";
end
also
fun deepsyntax_generic_package_to_uniqtype (mld::GENERIC { a_generic_api, typechecked_generic, ... }, depth, per_compile_info)
=>
case (package_property_lists::typechecked_generic_lty typechecked_generic)
#
THE (lt, od)
=>
hcf::change_depth_of_uniqtype (lt, od, depth);
NULL
=>
{ lt = typechecked_generic_lty (a_generic_api, typechecked_generic, depth, per_compile_info);
package_property_lists::set_typechecked_generic_lty (typechecked_generic, THE (lt, depth));
lt;
};
esac;
deepsyntax_generic_package_to_uniqtype _ => bug "unexpected generic package in deepsyntax_generic_package_to_uniqtype";
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::Uniqtyp
m2 = REF (MIDict::mkDict()) # modid (str/fct) -> hut::Uniqtype
fun tycTypeConstructorLook (t as (ty::PLAIN_TYP _ | ty::DEFINED_TYP _), d) =
let tid = mj::type_identifier t
in (case MIDict::peek (*m1, tid)
of THE (t', od) => hcf::change_depth_of_uniqtyp (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_type_to_uniqtype = toTypeConstructor tycTypeConstructorLook
*/
coreDict = (toTypeConstructor, deepsyntax_type_to_uniqtype)
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_uniqtype (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_uniqtype (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;