## expand-generic-g.pkg
# Compiled by:
# src/lib/compiler/front/typer/typer.sublib### "Within C++, there is a much
### smaller and cleaner language
### struggling to get out."
###
### -- Bjarne Stroustrup
# The center of the typechecker is
#
# src/lib/compiler/front/typer/main/type-package-language-g.pkg#
# -- see it for a higher-level overview.
# It calls us to do specialized generic
# expansion stuff.
stipulate
package di = debruijn_index; # debruijn_index is from src/lib/compiler/front/typer/basics/debruijn-index.pkg package ip = inverse_path; # inverse_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg package mld = module_level_declarations; # module_level_declarations is from src/lib/compiler/front/typer-stuff/modules/module-level-declarations.pkg package spc = stamppath_context; # stamppath_context is from src/lib/compiler/front/typer-stuff/modules/stamppath-context.pkg package trj = typer_junk; # typer_junk is from src/lib/compiler/front/typer/main/typer-junk.pkgherein
api Expand_Generic {
#
package generics_expansion_junk: Generics_Expansion_Junk; # Generics_Expansion_Junk is from src/lib/compiler/front/typer/modules/generics-expansion-junk-g.pkg expand_generic: ( mld::Typechecked_Generic,
mld::Typechecked_Package,
di::Debruijn_Depth,
spc::Context,
ip::Inverse_Path,
trj::Per_Compile_Stuff
)
-> mld::Typechecked_Package;
debugging: Ref( Bool );
};
end;
# Genericized to factor out dependencies on highcode:
stipulate
package trj = typer_junk; # typer_junk is from src/lib/compiler/front/typer/main/typer-junk.pkg package ip = inverse_path; # inverse_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg package lnd = line_number_db; # line_number_db is from src/lib/compiler/front/basics/source/line-number-db.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 sap = stamppath; # stamppath is from src/lib/compiler/front/typer-stuff/modules/stamppath.pkg package spc = stamppath_context; # stamppath_context is from src/lib/compiler/front/typer-stuff/modules/stamppath-context.pkg package stx = stampmapstack; # stampmapstack is from src/lib/compiler/front/typer-stuff/modules/stampmapstack.pkg package tro = typerstore; # typerstore is from src/lib/compiler/front/typer-stuff/modules/typerstore.pkg package tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg #
include package module_level_declarations;
herein
generic package expand_generic_g (
# ================
#
package i: Generics_Expansion_Junk; # Generics_Expansion_Junk is from src/lib/compiler/front/typer/modules/generics-expansion-junk-g.pkg )
: (weak) Expand_Generic # Expand_Generic is from src/lib/compiler/front/typer/modules/expand-generic-g.pkg {
package generics_expansion_junk = i;
# Debugging
say = control_print::say;
debugging = typer_data_controls::expand_generics_g_debugging;
fun if_debugging_say (msg: String)
=
if *debugging say msg; say "\n"; fi;
include package typer_debugging;
debug_print
=
(\\ x => debug_print debugging x; end ); # Value Restriction
fun bug msg
=
error_message::impossible ("expand_generic: " + msg);
anon_generic_sym = symbol::make_generic_symbol "anonymous_g";
param_sym = symbol::make_package_symbol "<generic_api_parameter_inst>";
anon_package_sym = symbol::make_package_symbol "<anonymous_package>";
result_id = symbol::make_package_symbol "<result_package>";
return_id = symbol::make_package_symbol "<return_package>";
default_error
=
error_message::error_no_file
(error_message::default_plaint_sink(), REF FALSE)
(0, 0);
fun evaluate_type (
entv,
typechecked_type_expression,
typerstore,
stamppath_context,
inverse_path,
per_compile_stuff as { make_fresh_stamp, ... }: trj::Per_Compile_Stuff
)
=
case typechecked_type_expression
#
CONSTANT_TYPE type
=>
type;
FORMAL_TYPE (tdt::SUM_TYPE { kind, arity, is_eqtype, namepath, ... } )
=>
case kind
#
tdt::SUMTYPE { index=>0, stamps, free_types, family, root=>NULL }
=>
{ viztyc = mj::translate_type typerstore;
nstamps = vector::map (\\ _ = make_fresh_stamp()) stamps;
nst = vector::get (nstamps, 0);
nfreetypes = map viztyc free_types;
spc::bind_typepath (stamppath_context, nst, entv);
tdt::SUM_TYPE
{
stamp => nst,
arity,
is_eqtype,
#
namepath => ip::append (inverse_path, namepath),
stub => NULL,
kind => tdt::SUMTYPE { index => 0,
stamps => nstamps,
root => NULL,
free_types => nfreetypes,
family
}
};
};
tdt::SUMTYPE { index=>i, root=>THE rtev, ... }
=>
{ my (nstamps, nfreetypes, nfamily)
=
case (tro::find_type_by_module_stamp (typerstore, rtev))
#
tdt::SUM_TYPE { kind => tdt::SUMTYPE dt, ... }
=>
( dt.stamps,
dt.free_types,
dt.family
);
_ => bug "unexpected case in evaluate_type-FMGENtyc (2)";
esac;
nst = vector::get (nstamps, i); # "nst" = "new stamp"?
spc::bind_typepath (stamppath_context, nst, entv);
tdt::SUM_TYPE { stamp => nst,
arity,
namepath => ip::append (inverse_path, namepath),
is_eqtype,
stub => NULL,
kind => tdt::SUMTYPE { index => i,
stamps => nstamps,
root => NULL,
free_types => nfreetypes,
family => nfamily
}
};
};
_ => bug "unexpected SUM_TYPE in evaluate_type";
esac;
FORMAL_TYPE (
tdt::NAMED_TYPE {
stamp,
strict,
namepath,
typescheme => tdt::TYPESCHEME { arity, body }
}
)
=>
{ nst = make_fresh_stamp();
# type_identifier=stamp (this should perhaps be more abstract some day)
spc::bind_typepath (stamppath_context, nst, entv);
tdt::NAMED_TYPE
{
stamp => nst,
strict,
namepath => ip::append (inverse_path, namepath),
typescheme => tdt::TYPESCHEME { arity,
body => mj::translate_typoid typerstore body
}
};
};
TYPEVAR_TYPE stamppath
=>
{ if_debugging_say (">>evaluate_type[TYPEVAR_TYPE]: " + sap::stamppath_to_string stamppath);
tro::find_type_via_stamppath (typerstore, stamppath);
};
_ => bug "unexpected typechecked_type_expression in evaluate_type";
esac
also
fun evaluate_package_expression (
package_expression,
depth,
stamppath_context,
module_stamp_v,
typerstore,
inverse_path,
per_compile_stuff as { make_fresh_stamp, ... }: trj::Per_Compile_Stuff
)
=
{ if_debugging_say ("[Inside evaluate_package_expression ......");
#
case package_expression
#
VARIABLE_PACKAGE stamppath
=>
{ if_debugging_say (">>evaluatePackageexpression[VARIABLE_PACKAGE]: " + sap::stamppath_to_string stamppath);
( tro::find_package_via_stamppath (typerstore, stamppath),
typerstore
);
};
CONSTANT_PACKAGE typechecked_package
=>
(typechecked_package, typerstore);
PACKAGE { stamp, module_declaration }
=>
{ stamppath_context = spc::enter_open (stamppath_context, module_stamp_v);
#
stp = evaluate_stamp_expression (stamp, depth, stamppath_context, typerstore, per_compile_stuff);
dictionary = evaluate_declaration( module_declaration, depth, stamppath_context, typerstore, inverse_path, per_compile_stuff);
( { stamp => stp,
typerstore => dictionary,
property_list => property_list::make_property_list (),
stub => NULL,
inverse_path
},
typerstore
);
};
APPLY (generic_expression, package_expression)
=>
{ (evaluate_generic (generic_expression, depth, stamppath_context, typerstore, per_compile_stuff))
->
(typechecked_generic, typerstore1);
my (argument_typechecked_package, typerstore2)
=
evaluate_package_expression (
package_expression,
depth,
stamppath_context,
module_stamp_v,
typerstore1,
ip::empty,
per_compile_stuff
);
stamppath_context
=
spc::enter_open (stamppath_context, module_stamp_v);
( expand_generic (typechecked_generic, argument_typechecked_package, depth, stamppath_context, inverse_path, per_compile_stuff),
typerstore2
);
};
PACKAGE_LET { declaration => module_declaration, expression => package_expression }
=>
{ typerstore1
=
evaluate_declaration (
module_declaration,
depth,
stamppath_context,
typerstore,
inverse_path,
per_compile_stuff
);
my (typechecked_package, typerstore2)
=
evaluate_package_expression (
package_expression,
depth,
stamppath_context,
module_stamp_v,
typerstore1,
inverse_path,
per_compile_stuff
);
(typechecked_package, typerstore2);
};
ABSTRACT_PACKAGE (an_api, package_expression)
=>
{ my (source_typechecked_package, typerstore1)
=
evaluate_package_expression
(
package_expression,
depth,
stamppath_context,
module_stamp_v,
typerstore,
inverse_path,
per_compile_stuff
);
my { typechecked_package,
abstract_types,
type_stamppaths
}
=
i::instantiate_package_abstractions
{
an_api,
typerstore,
source_typechecked_package,
inverse_path,
source_code_region => lnd::null_region,
per_compile_stuff
};
# Because the abstraction creates a
# bunch of new stamps, we have to
# bind them to the typechecked_package path context:
stamppath_context
=
spc::enter_open (stamppath_context, module_stamp_v);
fun h (tdt::SUM_TYPE gt, ep)
=>
spc::bind_type_long_path (
stamppath_context,
stx::typestamp_of gt,
ep
);
h _ => ();
end;
paired_lists::apply
h
( abstract_types,
type_stamppaths
);
( typechecked_package,
typerstore1
);
};
COERCED_PACKAGE { boundvar, raw, coercion }
=>
# Propagage the context inverse_path
# into the raw uncoerced package:
{ my (raw_typechecked_package, typerstore1)
=
evaluate_package_expression
(
raw,
depth,
stamppath_context,
THE boundvar,
typerstore,
inverse_path,
per_compile_stuff
);
typerstore2
=
tro::set (typerstore1, boundvar, PACKAGE_ENTRY raw_typechecked_package);
my (typechecked_package, typerstore3)
=
evaluate_package_expression
(
coercion,
depth,
stamppath_context,
module_stamp_v,
typerstore2,
ip::empty,
per_compile_stuff
);
(typechecked_package, typerstore3);
};
FORMAL_PACKAGE _ => bug "unexpected FORMAL_PACKAGE in evaluatePackageexpression";
esac;
}
also
fun evaluate_generic (
generic_expression,
debruijn_depth,
stamppath_context,
typerstore,
per_compile_stuff as { make_fresh_stamp, ... }: trj::Per_Compile_Stuff
)
=
case generic_expression
#
VARIABLE_GENERIC stamppath
=>
{ if_debugging_say (">>evaluateGeneric[VARIABLE_GENERIC]: " + sap::stamppath_to_string stamppath);
( tro::find_generic_via_stamppath (typerstore, stamppath),
typerstore
);
};
CONSTANT_GENERIC typechecked_generic
=>
(typechecked_generic, typerstore);
LAMBDA { parameter, body }
=>
{ clos = GENERIC_CLOSURE { parameter_module_stamp => parameter,
body_package_expression => body,
typerstore
};
( { stamp => make_fresh_stamp (),
generic_closure => clos,
property_list => property_list::make_property_list (),
typepath => NULL,
inverse_path => ip::INVERSE_PATH [anon_generic_sym],
stub => NULL
},
typerstore
);
};
LAMBDA_TP {
parameter,
body,
an_api as GENERIC_API { parameter_api, body_api, ... }
}
=>
{ generic_closure
=
GENERIC_CLOSURE
{ parameter_module_stamp => parameter,
body_package_expression => body,
typerstore
};
tps = { inverse_path' = ip::INVERSE_PATH [param_sym];
my { typechecked_package => param_typechecked_package, typepaths => param_tps }
=
i::do_generic_parameter_api {
an_api => parameter_api,
typerstore,
inverse_path => inverse_path',
debruijn_depth,
source_code_region => lnd::null_region,
per_compile_stuff
};
typerstore'
=
tro::mark (
make_fresh_stamp,
tro::set (typerstore, parameter, PACKAGE_ENTRY param_typechecked_package)
);
my (body_typechecked_package, _)
=
evaluate_package_expression (
body,
debruijn_index::next debruijn_depth,
stamppath_context,
NULL,
typerstore',
ip::empty,
per_compile_stuff
);
body_tps
=
i::get_packages_typepaths {
an_api => body_api,
typechecked_package => body_typechecked_package,
typerstore => typerstore',
per_compile_stuff
};
tdt::TYPEPATH_GENERIC (param_tps, body_tps);
};
( { stamp => make_fresh_stamp(),
generic_closure,
property_list => property_list::make_property_list (),
typepath => THE tps,
inverse_path => ip::INVERSE_PATH [anon_generic_sym],
stub => NULL
},
typerstore
);
};
LET_GENERIC (module_declaration, generic_expression)
=>
{ typerstore1
=
evaluate_declaration
(
module_declaration,
debruijn_depth,
stamppath_context,
typerstore,
ip::empty,
per_compile_stuff
);
my (typechecked_generic, typerstore2)
=
evaluate_generic
(
generic_expression,
debruijn_depth,
stamppath_context,
typerstore1,
per_compile_stuff
);
(typechecked_generic, typerstore2);
};
_ => bug "unexpected cases in evaluateGeneric";
esac
also
fun expand_generic (
typechecked_generic: mld::Typechecked_Generic,
argument_typechecked_package,
depth,
stamppath_context,
inverse_path,
per_compile_stuff as { make_fresh_stamp, ... }: trj::Per_Compile_Stuff
)
=
{ typechecked_generic
->
{ generic_closure => GENERIC_CLOSURE { parameter_module_stamp, body_package_expression, typerstore },
typepath,
...
};
new_typerstore
=
tro::mark( make_fresh_stamp,
tro::set ( typerstore,
parameter_module_stamp,
PACKAGE_ENTRY argument_typechecked_package
)
);
if_debugging_say ("[Inside EvalAPP] ......");
case (body_package_expression, typepath)
#
( FORMAL_PACKAGE
(GENERIC_API { parameter_api, body_api, ... } ),
THE tp
)
=>
{ arg_tps
=
i::get_packages_typepaths
{
an_api => parameter_api,
typechecked_package => argument_typechecked_package,
typerstore,
per_compile_stuff
};
result_tp = tdt::TYPEPATH_APPLY (tp, arg_tps);
# Failing to add the stamps into the
# typechecked_package path context is a
# potential bug here. Will fix this in the
# future. XXX BUGGO FIXME ZHONG
### "You can never plan the future by the past." -- Edmund Burke
my { typechecked_package,
abstract_types,
type_stamppaths
}
=
i::macro_expand_formal_generic_body_api
{
an_api => body_api,
typerstore => new_typerstore,
typepath => result_tp,
#
inverse_path,
source_code_region => lnd::null_region,
per_compile_stuff
};
fun bind_type (tdt::SUM_TYPE highcode_basetypes, stamppath)
=>
spc::bind_type_long_path (
#
stamppath_context,
stx::typestamp_of highcode_basetypes,
stamppath
);
bind_type _
=>
();
end;
paired_lists::apply
bind_type
(abstract_types, type_stamppaths);
typechecked_package;
};
_
=>
{ my (typechecked_package, typerstore_additions)
=
evaluate_package_expression
(
body_package_expression,
depth,
stamppath_context,
NULL,
new_typerstore,
inverse_path,
per_compile_stuff
);
# Invariant: macroExpansionDictionaryAdditions should always
# be same as newMacroExpansionDictionary if the body of
# an generic is always a BasePackage.
# Notice that the generic body is constructed
# either in the source programs (sml::grm) or in
# type-package-language.pkg when dealing
# with curried generic applications.
typechecked_package;
};
esac;
}
also
fun evaluate_declaration (
declaration,
depth,
stamppath_context,
typerstore,
inverse_path,
per_compile_stuff as { make_fresh_stamp, ... }: trj::Per_Compile_Stuff
)
=
{ if_debugging_say ("[Inside EvalDeclaration ......");
#
case declaration
#
TYPE_DECLARATION (module_stamp, typechecked_type_expression)
=>
{ typechecked_type
=
evaluate_type
( module_stamp,
typechecked_type_expression,
typerstore,
stamppath_context,
inverse_path,
per_compile_stuff
);
tro::set
( typerstore,
module_stamp,
TYPE_ENTRY typechecked_type
);
};
PACKAGE_DECLARATION (module_stamp, package_expression, symbol)
=>
{ inverse_path'
=
if ( symbol::eq (symbol, return_id)
or symbol::eq (symbol, result_id)
)
inverse_path;
else
ip::extend (inverse_path, symbol);
fi;
my (typechecked_package, typerstore1)
=
evaluate_package_expression
( package_expression,
depth,
stamppath_context,
THE module_stamp,
typerstore,
inverse_path',
per_compile_stuff
);
tro::set (typerstore1, module_stamp, PACKAGE_ENTRY typechecked_package);
};
GENERIC_DECLARATION (module_stamp, generic_expression)
=>
{ (evaluate_generic (generic_expression, depth, stamppath_context, typerstore, per_compile_stuff))
->
(typechecked_generic, typerstore1);
tro::set (typerstore1, module_stamp, GENERIC_ENTRY typechecked_generic);
};
SEQUENTIAL_DECLARATIONS decs
=>
tro::mark (make_fresh_stamp, fold_forward h typerstore decs)
where
fun h (declaration, typerstore0)
=
evaluate_declaration (declaration, depth, stamppath_context, typerstore0, inverse_path, per_compile_stuff);
end;
# The following may be wrong,
# but since ASSERTION! the
# bound symbols are all distinct,
# it would not appear to cause any harm.
LOCAL_DECLARATION (local_declaration, body_declaration)
=>
{ typerstore1
=
evaluate_declaration
( local_declaration,
depth,
stamppath_context,
typerstore,
ip::empty,
per_compile_stuff
);
evaluate_declaration (body_declaration, depth, stamppath_context, typerstore1, inverse_path, per_compile_stuff);
};
_ => typerstore;
esac;
}
also
fun evaluate_stamp_expression (
stamp_expression,
depth,
stamppath_context,
typerstore,
per_compile_stuff as { make_fresh_stamp, ... }: trj::Per_Compile_Stuff
)
=
case stamp_expression
#
MAKE_STAMP => make_fresh_stamp ();
# CONST stamp => stamp;
GET_STAMP package_expression
=>
.stamp (
#1 (
evaluate_package_expression
(
package_expression,
depth,
stamppath_context,
NULL,
typerstore,
ip::empty,
per_compile_stuff
)
)
);
esac;
# my expandGeneric
# =
# compile_statistics::do_phase
# (compile_statistics::make_phase "Compiler 044 x-expandGeneric")
# expandGeneric
}; # package expand_generic
end; # toplevel stipulate
## Copyright 1996 by AT&T Bell Laboratories
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.